Hey all,

I hacked a very quick Perl/Tk version of Conway's Game of Life and thought
some of you might enjoy it.

--Ala

#!/usr/bin/perl -w

use strict;
use Tk;

use vars qw/$repeat/;

my $size = 20;

#############################
# START OF USER CUSTOMIZABLE VARIABLES
#############################

# Size of the grid.
my $rows = 30;
my $cols = 30;

# The rules. An anonymous array of 2 arrays.
# The rules are like this:
# [
#   [ creation list  ]
#   [ survival list  ]
# ]
#
# The creation list is a list of numbers from 0 to 8 inclusive.
# If the sum of living neighbours of any cell is in this list
# then this cell springs up to life in the next generation.
#
# The survival list is a list of numbers from 0 to 8 inclusive.
# If the sum of living neighbours of any cell is in this list
# and the cell is alive, then it will survive to the next generation.
#
# All other cells die in the next generation.

my $rules = [
	     [3],
	     [2, 3],
	    ];

# Anonymous list or (row, column) coordinates of the starting
# pattern.

# Some boring test shape.
#  my $start = [
#  	     [4,3],
#  	     [4,4],
#  	     [4,5],
#  	     [4,6],
#  	    ];

# The infamous Glider!!
my $start = [
	     [1,2],
	     [2,3],
	     [3,1],
	     [3,2],
	     [3,3],
	    ];
#############################
# START OF USER CUSTOMIZABLE VARIABLES
#############################

drawGUI($rows, $cols, $size, $rules, $start);

MainLoop;

sub drawGUI {
    my ($rows,
	$cols,
	$size,
	$rules,
	$start,
       ) = @_;

    my $mw = new MainWindow;
    my $c  = $mw-> Canvas(-bg     => 'black',
			 -width  =>  $cols * $size,
			 -height =>  $rows * $size,
			)-> pack(qw/-side top/);

    $mw-> bind('<Any-Enter>', sub { $c->Tk::focus });

    my $array = [];
    for my $i (0 .. $rows - 1) {
	$array-> [$i] = [(0) x $cols];
    }

    # Draw the grid.
    for my $i (0 .. $rows) {
	$c-> createLine(0, $i * $size,
		       $cols * $size, $i * $size,
		       -fill =>  'white',
		      );
    }

    for my $i (0 .. $cols) {
	$c-> createLine($i * $size, 0,
		       $i * $size, $rows * $size,
		       -fill =>  'white',
		      );
    }

    my $frame = $mw-> Frame->pack(qw/-side top -expand 1
				 -fill both -padx 10 -pady 10/);

    $frame-> Button(
		   -text    =>  'Run',
		   -height  =>  3,
		   -command =>  [\&run, $array, $rules, $rows,
				$cols, $size, $c],
		  )-> pack(qw/side left -fill both -expand 1/);

    $frame-> Button(
		   -text    =>  'Exit',
		   -command =>  sub { exit },
		  )-> pack(qw/side left -fill both -expand 1/);

    # Fill in the starting pattern.
    for my $x (@$start) {
	fill($c, $size, @$x, $array);
    }
}

sub run {
    my ($array, $rules, $rows, $cols, $size, $c) = @_;

    $repeat = $c-> repeat(200, [\&step, $array, $rules,
			       $rows, $cols, $size, $c]);
}

sub step {
    my ($array, $rules, $rows, $cols, $size, $c) = @_;

    my ($fill, $unfill) = calc(
			       $array,
			       $rules,
			       $rows,
			       $cols,
			      );

    if (!@$unfill and !@$fill) {
	print "Done!\n";
	$c-> afterCancel($repeat);
    }

    fill  ($c, $size, @$_, $array) for @$fill;
    unfill($c, @$_, $array) for @$unfill;
    $c-> update;
}

sub fill {
    my ($c,
	$size,
	$row,
	$col,
	$array,
       ) = @_;

    $array-> [$row][$col] = 1;
    $c-> createOval(
		   $col * $size, $row * $size,
		   ($col + 1) * $size, ($row + 1) * $size,
		   -fill =>  'red',
		   -tags =>  "$row-$col",
		  );
}

sub unfill {
    my ($c, $row, $col, $array) = @_;

    $c-> delete("$row-$col");
    $array-> [$row][$col] = 0;
}

sub calc {
    my ($array, $rules, $rows, $cols) = @_;

    my (@fill, @unfill);

    for my $r (0 .. $rows - 1) {
	for my $c (0 .. $cols - 1) {
	    # Look at the neighbours.
	    my $sum = 0;

	    for my $n (
		       [$r - 1, $c - 1],
		       [$r - 1, $c    ],
		       [$r - 1, $c + 1],
		       [$r    , $c - 1],
		       [$r    , $c + 1],
		       [$r + 1, $c - 1],
		       [$r + 1, $c    ],
		       [$r + 1, $c + 1],
		      ) {

		$sum += $array-> [$n->[0]][$n->[1]] if
		    $n    -> [0] >= 0 && $n->[0] < $rows &&
			$n-> [1] >= 0 && $n->[1] < $cols;
	    }

	    if ($array-> [$r][$c]) {
		# will it survive?
		unless (grep {$_ == $sum} @{$rules-> [1]}) {
		    push @unfill =>  [$r, $c];
		}
	    } else {
		# will it get born?
		if (grep {$_ == $sum} @{$rules-> [0]}) {
		    push @fill =>  [$r, $c];
		}
	    }
	}
    }

    return (\@fill, \@unfill);
}