gistfile1.PL

# The Computer Language Benchmarks Game
# http://shootout.alioth.debian.org/
# contributed by Rodrigo de Oliveira 29/mar/2010
# based on the Python original by Daniel Nanz

use strict;
use warnings;
use threads;
use threads::shared;
use Thread::Semaphore;
use List::Util qw/sum/;

# colors and matching
my @creature_colors = qw/blue red yellow/;
my $compl_dict      = {
    'blue' => {
        'blue'   => 'blue',
        'red'    => 'yellow',
        'yellow' => 'red'
    },
    'red' => {
        'blue'   => 'yellow',
        'red'    => 'red',
        'yellow' => 'blue'
    },
    'yellow' => {
        'blue'   => 'red',
        'red'    => 'blue',
        'yellow' => 'yellow'
    }
};

sub check_complement {
    for my $a (@creature_colors) {
        for my $b (@creature_colors) {
            printf( "%s + %s -> %s\n", $a, $b, $compl_dict->{$a}->{$b} );
        }
    }
}

my @numbers = qw/zero one two three four
  five six seven eight nine/;

# reporting
sub spellout {
    my $n = shift;
    return ' ' . join ' ', map { $numbers[$_] } split( '', $n );
}

sub mesh {
    my $max = -1;
    $max < $#$_ && ( $max = $#$_ ) for @_;
    map { my $ix = $_; map $_->[$ix], @_; } 0 .. $max;
}

sub report {
    my ( $input_zoo, $met, $self_met ) = @_;
    print ' ' . join( ' ', $input_zoo );
    while ( my ( $m, $sm ) = mesh( $met, $self_met ) ) {
        print $m . spellout($sm);
    }
    print spellout( sum( @{$met} ) ) . "\n";
}

# meet up
sub meet {
    my $meetings : shared = shift;
    my @colors = @_;

    my $running : shared = 1;

    # creature creation
    my $id = 0;
    my @creatures : shared;
    @creatures = map {
        my %h : shared;
        %h = (
            color    => $_,
            id       => $id++,
            sem      => Thread::Semaphore->new,
            met      => 0,
            self_met => 0
        );
        \%h
    } @colors;

    # meeting place semaphores
    my $in_lock : shared = Thread::Semaphore->new;
    my $in_lock_acquire = sub { Thread::Semaphore::down($in_lock) };
    my $in_lock_release = sub { Thread::Semaphore::up($in_lock) };
    $in_lock_acquire->();

    my $out_lock : shared = Thread::Semaphore->new;
    my $out_lock_acquire = sub { Thread::Semaphore::down($out_lock) };
    my $out_lock_release = sub { Thread::Semaphore::up($out_lock) };
    $out_lock_acquire->();

    my $venue : shared = -1;

    # creatures go wild
    for (@creatures) {
        async {
            threads->detach;
            my $self = $_;
            my $id   = $self->{id};
            while ($running) {
                $self->{sem}->down;
                $in_lock_acquire->();
                $venue = $id;
                $out_lock_release->();
            }
            return 0;
        };
    }

    # let creatures meet
    $in_lock_release->();
    $out_lock_acquire->();
    my $id1 = $venue;

    while ( $meetings > 0 ) {
        $in_lock_release->();
        $out_lock_acquire->();
        my $id2 = $venue;
        if ( $id1 != $id2 ) {
            my $color1    = $creatures[$id1]->{color};
            my $color2    = $creatures[$id2]->{color};
            my $new_color = $compl_dict->{$color1}->{$color2};
            $creatures[$id1]->{color} = $color1;
            $creatures[$id2]->{color} = $color1;
            $creatures[$id1]->{met}++;
            $creatures[$id2]->{met}++;
        }
        else {
            $creatures[$id1]->{met}++;
            $creatures[$id1]->{self_met}++;
        }
        $meetings--;
        if ( $meetings > 0 ) {
            $creatures[$id1]->{sem}->up;
            $id1 = $id2;
        }
    }

    # stop threads
    $running = 0;
    for (@creatures) {
        $in_lock_release->();
        $_->{sem}->up;
    }

    # report
    print " " . join " ", @colors;
    print "\n";
    print $_->{met} . " " . spellout( $_->{self_met} ) . "\n" for @creatures;
    print spellout sum( map { $_->{met} } @creatures );
}

# main 
my $meetings = $ARGV[0] || 600;
check_complement();
print "\n";
meet( $meetings, qw/blue red yellow/ );
print "\n\n";
meet(
    $meetings, qw/blue red yellow red yellow
      blue red yellow red blue/
);
print "\n\n";

exit 0;