Game of Life

[Ala Qumsieh]

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);
}