Further improvements may be possible by adding more sophisticated history detection.
Benchmark timings running the 3 million cell blinker for both two ticks and one hundred ticks:
Note that these timings were improved by a second or two by some minor Organism.pm code tweaks (based on Devel::NYTProf profiling) - also added "use integer" and tested with ancient 32-bit Perl 5.8.4.
Instructively, tweaking the code, via a long series of micro-optimizations,
reduced the running time from 1635 secs to 450 secs (i.e. 3.6 times faster),
while finding a better algorithm reduced it from 450 secs to 17 secs (26.5 times faster).
Updated Organism.pm follows. Note: This node contains the latest and best version of the Perl GOL code.
package Organism;
use strict;
use warnings;
# This seems to work fine and is a tiny bit faster
use integer;
# ----------------------------------------------------------------
# The Universe is modelled as a set of overlapping tiles.
# For background, see http://conwaylife.com/wiki/Life128_and_vlife
# We use a simple scheme of 64 x 64 tiles (60 x 60 core) with
# conventional tiling (each tile has eight neighbours).
# Alternatively 32 x 32 (28 x 28 core) are used with 32-bit integers.
# Note that this was chosen for simplicity; more efficient schemes
# are available, such as the "brick wall tiling" used by Goucher
# in later versions (apgmera, version 3)
# This code is loosely based on apgnano (version 2).
# ----------------------------------------------------------------
# SQUARE TILE
# Note: 64 x 64 square tiles require a perl built with 64-bit integers
# Choose tile size (32 or 64) automatically based on perl integer size
+:
use Config;
our $TILE_SIZE_FULL = $Config{ivsize} < 8 ? 32 : 64;
# ... or manually override by editing the next line
# $TILE_SIZE_FULL = 32; # manually set to 32 or 64
# warn __PACKAGE__, ": using $TILE_SIZE_FULL x $TILE_SIZE_FULL tiles\n
+";
my $BM_MIDDLE = 0x3ffffffc;
my $BM_LEFT = 0xfffffffc;
my $BM_RIGHT = 0x3fffffff;
my $BM_OUTER = 0xc0000003;
my $BM_LEFTMIDDLE = 0x30000000;
my $BM_RIGHTMIDDLE = 0x0000000c;
my $BM_FMT = '%032b';
if ($TILE_SIZE_FULL == 64) {
no warnings qw(portable overflow);
$BM_MIDDLE = 0x3ffffffffffffffc;
$BM_LEFT = 0xfffffffffffffffc;
$BM_RIGHT = 0x3fffffffffffffff;
$BM_OUTER = 0xc000000000000003;
$BM_LEFTMIDDLE = 0x3000000000000000;
$BM_RIGHTMIDDLE = 0x000000000000000c;
$BM_FMT = '%064b';
}
my $BORDER_WIDTH = 2;
my $BORDER_WIDTH_P1 = $BORDER_WIDTH + 1;
my $TILE_SIZE_FULL_M1 = $TILE_SIZE_FULL - 1;
my $TILE_SIZE_FULL_M2 = $TILE_SIZE_FULL - 2;
my $TILE_SIZE_MBD = $TILE_SIZE_FULL - $BORDER_WIDTH;
my $TILE_SIZE_MBD_M1 = $TILE_SIZE_MBD - 1;
my $TILE_SIZE_CORE = $TILE_SIZE_FULL - 2 * $BORDER_WIDTH;
my $TILE_SIZE_CORE_P1 = $TILE_SIZE_CORE + 1;
# Neighbours are numbered clockwise starting with the one directly abo
+ve
my $NUM_NEIGH = 8;
my $NUM_NEIGH_M1 = $NUM_NEIGH - 1;
my $NEIGH_TOP = 0;
my $NEIGH_TOP_RIGHT = 1;
my $NEIGH_RIGHT = 2;
my $NEIGH_BOTTOM_RIGHT = 3;
my $NEIGH_BOTTOM = 4;
my $NEIGH_BOTTOM_LEFT = 5;
my $NEIGH_LEFT = 6;
my $NEIGH_TOP_LEFT = 7;
my $NEIGH_ANY = 0xff; # test if any neighbour is set
# Note that the i ^ 4 trick sets i to the opposite one, that is:
# 0 > 4 (TOP > BOTTOM)
# 1 > 5 (TOP RIGHT > BOTTOM LEFT)
# 2 > 6 (RIGHT > LEFT)
# 3 > 7 (BOTTOM RIGHT > TOP LEFT)
# 4 > 0 (BOTTOM > TOP)
# 5 > 1 (BOTTOM LEFT > TOP RIGHT)
# 6 > 2 (LEFT > RIGHT)
# 7 > 3 (TOP LEFT > BOTTOM RIGHT)
# Instead of a hashref, these list indices are slightly faster
my $Tx = 0;
my $Ty = 1;
my $Updateflags = 2;
my $Row = 3;
my $Neighbours = 4;
# The functions starting with st_ manipulate
# a simple $TILE_SIZE_FULL x $TILE_SIZE_FULL square tile bitmap.
# Note that $x and $y must be in 0..$TILE_SIZE_FULL-1 range.
# $row is a ref to an array of 64 unsigned 64-bit ints
# ... or a ref to an array of 32 unsigned 32-bit ints.
# The value in row[] bitmap is 0 (dead) or 1 (alive).
sub st_getcellval {
my ($row, $x, $y) = @_;
# my $mask = 1 << ($TILE_SIZE_FULL_M1 - $x);
# return $row->[$y] & $mask ? 1 : 0;
$row->[$y] & ( 1 << ($TILE_SIZE_FULL_M1 - $x) );
}
sub st_setcellval {
my ($row, $x, $y, $v) = @_;
my $mask = 1 << ($TILE_SIZE_FULL_M1 - $x);
if ($v) { $row->[$y] |= $mask; } else { $row->[$y] &= ~$mask; }
}
sub st_insertcells {
my $row = shift;
for my $r (@_) { st_setcellval($row, $r->[0], $r->[1], 1) }
}
# Used for verification and unit testing of st_tiletick
sub st_count {
my $row = shift;
my $cnt = 0;
for my $y (0 .. $TILE_SIZE_FULL_M1) {
next unless $row->[$y];
# $cnt += popcount($row->[$y]);
$cnt += sprintf('%b', $row->[$y]) =~ tr/1//;
}
return $cnt;
}
# Used for verification and unit testing of st_tiletick
sub st_getlivecells {
my $row = shift;
my @cells;
for my $y (0 .. $TILE_SIZE_FULL_M1) {
next unless $row->[$y];
for my $x (0 .. $TILE_SIZE_FULL_M1) {
st_getcellval($row, $x, $y) and push @cells, [ $x, $y ];
}
}
sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @cells;
}
# Advance the interior of square tile by one tick.
# Return a two element list:
# [0] : boolean: TRUE if square tile changed, else FALSE
# [1] : neighbour flags (see NEIGH flags above)
# indicates which neighbours need to be updated
# $top is index of first non-zero element in $row
# $bottom is index of last non-zero element in $row
# Note: Do not call this function with all elements zero
# .... and it is pointless to do so
sub st_tiletick {
my ( $row, $top, $bottom ) = @_;
my $neigh = my $bigdiff = 0;
my @carry = my @parity = my @diff = my @ee = (0) x $TILE_SIZE_FULL;
my ( $aa, $bb, $p, $q, $r, $s, $bit0, $bit1, $bit2 );
for my $i ($top .. $bottom) {
$aa = $row->[$i] >> 1;
$bb = $row->[$i] << 1;
$q = $aa ^ $bb;
$parity[$i] = $q ^ $row->[$i];
$carry[$i] = ($q & $row->[$i]) | ($aa & $bb);
}
--$top; ++$bottom;
$top < 1 and $top = 1;
$bottom > $TILE_SIZE_MBD and $bottom = $TILE_SIZE_MBD;
for my $i ($top .. $bottom) {
$aa = $parity[$i-1];
$bb = $parity[$i+1];
$q = $aa ^ $bb;
$bit0 = $q ^ $parity[$i];
$r = ($q & $parity[$i]) | ($aa & $bb);
$aa = $carry[$i-1];
$bb = $carry[$i+1];
$q = $aa ^ $bb;
$p = $q ^ $carry[$i];
$s = ($q & $carry[$i]) | ($aa & $bb);
$bit1 = $p ^ $r;
$bit2 = $s ^ ($p & $r);
$p = ($bit0 & $bit1 & ~$bit2) | ($bit2 & ~$bit1 & ~$bit0 & $row-
+>[$i]);
$diff[$i] = ($row->[$i] ^ $p) & $BM_MIDDLE;
$bigdiff |= $diff[$i];
$row->[$i] = ($p & $BM_MIDDLE) | ($row->[$i] & ~$BM_MIDDLE);
}
$aa = $diff[$BORDER_WIDTH] | $diff[$BORDER_WIDTH_P1];
$bb = $diff[$TILE_SIZE_CORE] | $diff[$TILE_SIZE_CORE_P1];
if ($bigdiff) {
$bigdiff & $BM_LEFTMIDDLE and $neigh |= 1 << $NEIGH_LEFT;
$bigdiff & $BM_RIGHTMIDDLE and $neigh |= 1 << $NEIGH_RIGHT;
}
if ($aa) {
$neigh |= 1 << $NEIGH_TOP;
$aa & $BM_LEFTMIDDLE and $neigh |= 1 << $NEIGH_TOP_LEFT;
$aa & $BM_RIGHTMIDDLE and $neigh |= 1 << $NEIGH_TOP_RIGHT;
}
if ($bb) {
$neigh |= 1 << $NEIGH_BOTTOM;
$bb & $BM_LEFTMIDDLE and $neigh |= 1 << $NEIGH_BOTTOM_LEFT;
$bb & $BM_RIGHTMIDDLE and $neigh |= 1 << $NEIGH_BOTTOM_RIGHT;
}
( $bigdiff, $neigh );
}
# Advance the interior of square tile by two ticks.
# Return a two element list:
# [0] : boolean: TRUE if square tile changed, else FALSE
# [1] : neighbour flags (see NEIGH flags above)
# indicates which neighbours need to be updated
sub st_tiletwoticks {
my ( $row, $top, $bottom ) = @_;
my $neigh = my $bigdiff = 0;
my @carry = my @parity = my @diff = my @ee = (0) x $TILE_SIZE_FULL;
my ( $aa, $bb, $p, $q, $r, $s, $bit0, $bit1, $bit2 );
# even --> odd
for my $i ($top .. $bottom) {
$aa = $row->[$i] >> 1;
$bb = $row->[$i] << 1;
$q = $aa ^ $bb;
$parity[$i] = $q ^ $row->[$i];
$carry[$i] = ($q & $row->[$i]) | ($aa & $bb);
}
--$top; ++$bottom;
$top < 1 and $top = 1;
$bottom > $TILE_SIZE_MBD and $bottom = $TILE_SIZE_MBD;
for my $i ($top .. $bottom) {
$aa = $parity[$i-1];
$bb = $parity[$i+1];
$q = $aa ^ $bb;
$bit0 = $q ^ $parity[$i];
$r = ($q & $parity[$i]) | ($aa & $bb);
$aa = $carry[$i-1];
$bb = $carry[$i+1];
$q = $aa ^ $bb;
$p = $q ^ $carry[$i];
$s = ($q & $carry[$i]) | ($aa & $bb);
$bit1 = $p ^ $r;
$bit2 = $s ^ ($p & $r);
$ee[$i] = ($bit0 & $bit1 & ~$bit2) | ($bit2 & ~$bit1 & ~$bit0 &
+$row->[$i]);
}
# odd --> even
for my $i ($top .. $bottom) {
$aa = $ee[$i] >> 1;
$bb = $ee[$i] << 1;
$q = $aa ^ $bb;
$parity[$i] = $q ^ $ee[$i];
$carry[$i] = ($q & $ee[$i]) | ($aa & $bb);
}
--$top; ++$bottom;
$top < $BORDER_WIDTH and $top = $BORDER_WIDTH;
$bottom > $TILE_SIZE_MBD_M1 and $bottom = $TILE_SIZE_MBD_M1;
for my $i ($top .. $bottom) {
$aa = $parity[$i-1];
$bb = $parity[$i+1];
$q = $aa ^ $bb;
$bit0 = $q ^ $parity[$i];
$r = ($q & $parity[$i]) | ($aa & $bb);
$aa = $carry[$i-1];
$bb = $carry[$i+1];
$q = $aa ^ $bb;
$p = $q ^ $carry[$i];
$s = ($q & $carry[$i]) | ($aa & $bb);
$bit1 = $p ^ $r;
$bit2 = $s ^ ($p & $r);
$p = ($bit0 & $bit1 & ~$bit2) | ($bit2 & ~$bit1 & ~$bit0 & $ee[$
+i]);
$diff[$i] = ($row->[$i] ^ $p) & $BM_MIDDLE;
$bigdiff |= $diff[$i];
# $hist->[$i] |= ($row->[$i] | $ee[$i]) & $BM_MIDDLE;
$row->[$i] = ($p & $BM_MIDDLE) | ($row->[$i] & ~$BM_MIDDLE);
}
$aa = $diff[$BORDER_WIDTH] | $diff[$BORDER_WIDTH_P1];
$bb = $diff[$TILE_SIZE_CORE] | $diff[$TILE_SIZE_CORE_P1];
if ($bigdiff) {
$bigdiff & $BM_LEFTMIDDLE and $neigh |= 1 << $NEIGH_LEFT;
$bigdiff & $BM_RIGHTMIDDLE and $neigh |= 1 << $NEIGH_RIGHT;
}
if ($aa) {
$neigh |= 1 << $NEIGH_TOP;
$aa & $BM_LEFTMIDDLE and $neigh |= 1 << $NEIGH_TOP_LEFT;
$aa & $BM_RIGHTMIDDLE and $neigh |= 1 << $NEIGH_TOP_RIGHT;
}
if ($bb) {
$neigh |= 1 << $NEIGH_BOTTOM;
$bb & $BM_LEFTMIDDLE and $neigh |= 1 << $NEIGH_BOTTOM_LEFT;
$bb & $BM_RIGHTMIDDLE and $neigh |= 1 << $NEIGH_BOTTOM_RIGHT;
}
( $bigdiff, $neigh );
}
# Note: mapping of x (cell) to tx (tile) is:
# x tx
# ---------- --
# ...
# -121..-180 -3
# -61..-120 -2
# -1..-60 -1
# 0.. 59 0
# 60..119 1
# 120..179 2
# ...
# Ditto for y (cell) to ty (tile).
# Input cell (x, y). Return (tx, ty, ix, iy)
# (tx, ty) : Tile coords
# (ix, iy) : x, y coords inside tile
sub get_tile_coords {
my ( $x, $y ) = @_;
my $ox = $x % $TILE_SIZE_CORE;
my $oy = $y % $TILE_SIZE_CORE;
if ($ox < 0) { $ox += $TILE_SIZE_CORE }
if ($oy < 0) { $oy += $TILE_SIZE_CORE }
my $tx = ($x - $ox) / $TILE_SIZE_CORE;
my $ty = ($y - $oy) / $TILE_SIZE_CORE;
my $ix = $ox + $BORDER_WIDTH;
my $iy = $oy + $BORDER_WIDTH;
return ( $tx, $ty, $ix, $iy );
}
# Converse of get_tile_coords
# Input (tx, ty, ix, iy). Return cell (x, y)
sub get_cell_coords {
my ( $tx, $ty, $ix, $iy ) = @_;
my $x = $TILE_SIZE_CORE * $tx + $ix - $BORDER_WIDTH;
my $y = $TILE_SIZE_CORE * $ty + $iy - $BORDER_WIDTH;
return ( $x, $y );
}
# See perlmonks.org, node_id: 1199987
# Inline this popcount function below
# sub popcount { sprintf('%b', shift) =~ tr/1// }
# ----------------------------------------------------------------
# ORGANISM
# Input a list of [ x, y ] coords
sub insert_cells {
my $self = shift;
for my $r (@_) { $self->setcell($r->[0], $r->[1], 1) }
}
# Used for verification and testing the state of the organism
sub count {
my $self = shift;
my $tiles = $self->{Tiles};
my $cnt = 0;
for my $sqt (values %{$tiles}) {
my $row = $sqt->[$Row];
for my $iy ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) {
next unless $row->[$iy];
# $cnt += popcount($row->[$iy] & $BM_MIDDLE);
$cnt += sprintf('%b', $row->[$iy] & $BM_MIDDLE) =~ tr/1//;
}
}
return $cnt;
}
sub dump_one_tile {
my $sqt = shift;
my $tx = $sqt->[$Tx];
my $ty = $sqt->[$Ty];
my $updateflags = $sqt->[$Updateflags];
my $row = $sqt->[$Row];
my $ngh = $sqt->[$Neighbours];
my $popc = 0;
for my $iy ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) {
next unless $row->[$iy];
# $cnt += popcount($row->[$iy] & $BM_MIDDLE);
$popc += sprintf('%b', $row->[$iy] & $BM_MIDDLE) =~ tr/1//;
}
my $uf = sprintf '%032b', $updateflags;
print STDERR "tx=$tx ty=$ty popc=$popc\n";
print STDERR " updateflags=$uf\n";
print STDERR " live neighbours:";
for my $n (0 .. $NUM_NEIGH_M1) { $ngh->[$n] or next; print STDERR "
+ $n" }
print STDERR "\n";
}
# Used for verification and testing the state of the organism
sub dump_tiles {
my $self = shift;
my $tiles = $self->{Tiles};
my @tkeys = sort keys %{$tiles};
my $ntiles = @tkeys;
print STDERR "=== Dump Tiles, n=$ntiles ==========\n";
my $ii = 0;
for my $k (@tkeys) {
++$ii;
my ($kx, $ky) = unpack 'i2', $k; # Note: $kx,$ky match Tx,Ty
print STDERR "$ii:-----------------------------\n";
my $sqt = $tiles->{$k};
dump_one_tile($sqt);
}
my $modified = $self->{Modified};
my $nmodified = @{$modified};
print STDERR "=== Dump Modif, n=$nmodified ==========\n";
$ii = 0;
for my $sqt (@{$modified}) {
++$ii;
print STDERR "$ii:-----------------------------\n";
dump_one_tile($sqt);
}
}
# Used for verification and testing the state of the organism
sub get_live_cells {
my $self = shift;
my $tiles = $self->{Tiles};
my @cells;
for my $sqt (values %{$tiles}) {
my $tx = $sqt->[$Tx];
my $ty = $sqt->[$Ty];
my $row = $sqt->[$Row];
for my $iy ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) {
my $rowval = $row->[$iy];
next unless $rowval;
for my $ix ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) {
# next unless st_getcellval($row, $ix, $iy);
next unless $rowval & ( 1 << ($TILE_SIZE_FULL_M1 - $ix) );
push @cells,
[ $TILE_SIZE_CORE * $tx + $ix - $BORDER_WIDTH,
$TILE_SIZE_CORE * $ty + $iy - $BORDER_WIDTH ];
}
# my @biton = split //, sprintf($BM_FMT, $rowval & $BM_MIDDLE
+);
# for my $ix ( grep($biton[$_], 0 .. $#biton) )
# {
# push @cells,
# [ $TILE_SIZE_CORE * $tx + $ix - $BORDER_WIDTH,
# $TILE_SIZE_CORE * $ty + $iy - $BORDER_WIDTH ];
# }
}
}
sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @cells;
}
# Assumes initial $sqt->[$Neighbours]->[$i] check has been done
sub get_neighbour {
my $self = shift;
my $sqt = shift;
my $i = shift;
# $sqt->[$Neighbours]->[$i] and return $sqt->[$Neighbours]->[$i];
my $tx = $sqt->[$Tx];
my $ty = $sqt->[$Ty];
$i >= $NEIGH_TOP_RIGHT && $i <= $NEIGH_BOTTOM_RIGHT and ++$tx;
$i >= $NEIGH_BOTTOM_RIGHT && $i <= $NEIGH_BOTTOM_LEFT and ++$ty;
$i >= $NEIGH_BOTTOM_LEFT && $i <= $NEIGH_TOP_LEFT and --$tx;
$i == $NEIGH_TOP_LEFT || $i <= $NEIGH_TOP_RIGHT and --$ty;
my $tiles = $self->{Tiles};
my $k = pack 'i2', $tx, $ty;
exists($tiles->{$k}) or
$tiles->{$k} = [
$tx, # $Tx
$ty, # $Ty
0, # $Updateflags
[ (0) x $TILE_SIZE_FULL ], # $Row
[], # $Neighbours
];
$sqt->[$Neighbours]->[$i] = $tiles->{$k};
}
# Alert the neighbour that its neighbour (the original tile) has chang
+ed
sub update_neighbour {
my $self = shift;
my $sqt = shift;
my $i = shift;
my $n = $sqt->[$Neighbours]->[$i] || $self->get_neighbour($sqt, $i)
+;
$n->[$Updateflags] == 0 and push @{$self->{Modified}}, $n;
$n->[$Updateflags] |= 1 << ($i ^ 4);
}
# Update the relevant portions of the boundary (a 64-by-64 square
# with the central 60-by-60 square removed) by copying data from
# the interiors (the 60-by-60 central squares) of the neighbours.
# Alternatively, for 32-bit ints, 32-by-32 with 28-by-28 core.
# Only perform this copying when necessary.
sub update_boundary {
my $self = shift;
my $sqt = shift;
if ( $sqt->[$Updateflags] & (1 << $NEIGH_TOP) ) {
my $n = $sqt->[$Neighbours]->[$NEIGH_TOP] || $self->get_neighbou
+r($sqt, $NEIGH_TOP);
$sqt->[$Row]->[0] = ($n->[$Row]->[$TILE_SIZE_CORE] & $BM_MIDDLE)
+ | ($sqt->[$Row]->[0] & $BM_OUTER);
$sqt->[$Row]->[1] = ($n->[$Row]->[$TILE_SIZE_CORE_P1] & $BM_MIDD
+LE) | ($sqt->[$Row]->[1] & $BM_OUTER);
}
if ( $sqt->[$Updateflags] & (1 << $NEIGH_TOP_LEFT) ) {
my $n = $sqt->[$Neighbours]->[$NEIGH_TOP_LEFT] || $self->get_nei
+ghbour($sqt, $NEIGH_TOP_LEFT);
$sqt->[$Row]->[0] = (($n->[$Row]->[$TILE_SIZE_CORE] & $BM_MIDDLE
+) << $TILE_SIZE_CORE) | ($sqt->[$Row]->[0] & $BM_RIGHT);
$sqt->[$Row]->[1] = (($n->[$Row]->[$TILE_SIZE_CORE_P1] & $BM_MID
+DLE) << $TILE_SIZE_CORE) | ($sqt->[$Row]->[1] & $BM_RIGHT);
}
if ( $sqt->[$Updateflags] & (1 << $NEIGH_TOP_RIGHT) ) {
my $n = $sqt->[$Neighbours]->[$NEIGH_TOP_RIGHT] || $self->get_ne
+ighbour($sqt, $NEIGH_TOP_RIGHT);
$sqt->[$Row]->[0] = (($n->[$Row]->[$TILE_SIZE_CORE] & $BM_MIDDLE
+) >> $TILE_SIZE_CORE) | ($sqt->[$Row]->[0] & $BM_LEFT);
$sqt->[$Row]->[1] = (($n->[$Row]->[$TILE_SIZE_CORE_P1] & $BM_MID
+DLE) >> $TILE_SIZE_CORE) | ($sqt->[$Row]->[1] & $BM_LEFT);
}
if ( $sqt->[$Updateflags] & (1 << $NEIGH_BOTTOM) ) {
my $n = $sqt->[$Neighbours]->[$NEIGH_BOTTOM] || $self->get_neigh
+bour($sqt, $NEIGH_BOTTOM);
$sqt->[$Row]->[$TILE_SIZE_MBD] = ($n->[$Row]->[$BORDER_WIDTH] &
+$BM_MIDDLE) | ($sqt->[$Row]->[$TILE_SIZE_MBD] & $BM_OUTER);
$sqt->[$Row]->[$TILE_SIZE_FULL_M1] = ($n->[$Row]->[3] & $BM_MIDD
+LE) | ($sqt->[$Row]->[$TILE_SIZE_FULL_M1] & $BM_OUTER);
}
if ( $sqt->[$Updateflags] & (1 << $NEIGH_BOTTOM_LEFT) ) {
my $n = $sqt->[$Neighbours]->[$NEIGH_BOTTOM_LEFT] || $self->get_
+neighbour($sqt, $NEIGH_BOTTOM_LEFT);
$sqt->[$Row]->[$TILE_SIZE_MBD] = (($n->[$Row]->[$BORDER_WIDTH] &
+ $BM_MIDDLE) << $TILE_SIZE_CORE) | ($sqt->[$Row]->[$TILE_SIZE_MBD] &
+$BM_RIGHT);
$sqt->[$Row]->[$TILE_SIZE_FULL_M1] = (($n->[$Row]->[3] & $BM_MID
+DLE) << $TILE_SIZE_CORE) | ($sqt->[$Row]->[$TILE_SIZE_FULL_M1] & $BM_
+RIGHT);
}
if ( $sqt->[$Updateflags] & (1 << $NEIGH_BOTTOM_RIGHT) ) {
my $n = $sqt->[$Neighbours]->[$NEIGH_BOTTOM_RIGHT] || $self->get
+_neighbour($sqt, $NEIGH_BOTTOM_RIGHT);
$sqt->[$Row]->[$TILE_SIZE_MBD] = (($n->[$Row]->[$BORDER_WIDTH] &
+ $BM_MIDDLE) >> $TILE_SIZE_CORE) | ($sqt->[$Row]->[$TILE_SIZE_MBD] &
+$BM_LEFT);
$sqt->[$Row]->[$TILE_SIZE_FULL_M1] = (($n->[$Row]->[3] & $BM_MID
+DLE) >> $TILE_SIZE_CORE) | ($sqt->[$Row]->[$TILE_SIZE_FULL_M1] & $BM_
+LEFT);
}
if ( $sqt->[$Updateflags] & (1 << $NEIGH_LEFT) ) {
my $n = $sqt->[$Neighbours]->[$NEIGH_LEFT] || $self->get_neighbo
+ur($sqt, $NEIGH_LEFT);
for my $i ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) {
$sqt->[$Row]->[$i] = (($n->[$Row]->[$i] & $BM_MIDDLE) << $TIL
+E_SIZE_CORE) | ($sqt->[$Row]->[$i] & $BM_RIGHT);
}
}
if ( $sqt->[$Updateflags] & (1 << $NEIGH_RIGHT) ) {
my $n = $sqt->[$Neighbours]->[$NEIGH_RIGHT] || $self->get_neighb
+our($sqt, $NEIGH_RIGHT);
for my $i ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) {
$sqt->[$Row]->[$i] = (($n->[$Row]->[$i] & $BM_MIDDLE) >> $TIL
+E_SIZE_CORE) | ($sqt->[$Row]->[$i] & $BM_LEFT);
}
}
}
sub tick {
my $self = shift;
my $modified = $self->{Modified};
# Update boundary of all modified tiles
for my $sqt (@{$modified}) {
$sqt->[$Updateflags] & $NEIGH_ANY and $self->update_boundary($sq
+t);
$sqt->[$Updateflags] = 0;
}
# Update core of all modified tiles, creating new modified list
# Using map rather than foreach is odd, but it's faster (no need fo
+r temporary list)
@{$modified} = map {
my $sqt = $_;
my @tmp;
my $row = $sqt->[$Row];
my $top = my $bottom = $TILE_SIZE_FULL;
$row->[$_] and $top = $_, last for 0..$TILE_SIZE_FULL_M1;
if ($top != $TILE_SIZE_FULL) {
1 while --$bottom && !$row->[$bottom];
my ($update_flag, $neigh) = st_tiletick($row, $top, $bottom);
# update tile
if ($update_flag) {
$sqt->[$Updateflags] == 0 and push @tmp, $sqt;
$sqt->[$Updateflags] |= 1 << $NUM_NEIGH;
}
if ($neigh) {
for my $i (0 .. $NUM_NEIGH_M1) {
next unless $neigh & (1 << $i);
# $self->update_neighbour($sqt, $i)
my $n = $sqt->[$Neighbours]->[$i] || $self->get_neighbo
+ur($sqt, $i);
$n->[$Updateflags] == 0 and push @tmp, $n;
$n->[$Updateflags] |= 1 << ($i ^ 4);
}
}
}
@tmp
} @{$modified};
}
sub twoticks {
my $self = shift;
my $modified = $self->{Modified};
# Update boundary of all modified tiles
for my $sqt (@{$modified}) {
$sqt->[$Updateflags] & $NEIGH_ANY and $self->update_boundary($sq
+t);
$sqt->[$Updateflags] = 0;
}
# Update core of all modified tiles, creating new modified list
# Using map rather than foreach is odd, but it's faster (no need fo
+r temporary list)
@{$modified} = map {
my $sqt = $_;
my @tmp;
my $row = $sqt->[$Row];
my $top = my $bottom = $TILE_SIZE_FULL;
$row->[$_] and $top = $_, last for 0..$TILE_SIZE_FULL_M1;
if ($top != $TILE_SIZE_FULL) {
1 while --$bottom && !$row->[$bottom];
my ($update_flag, $neigh) = st_tiletwoticks($row, $top, $bott
+om);
# update tile
if ($update_flag) {
$sqt->[$Updateflags] == 0 and push @tmp, $sqt;
$sqt->[$Updateflags] |= 1 << $NUM_NEIGH;
}
if ($neigh) {
for my $i (0 .. $NUM_NEIGH_M1) {
next unless $neigh & (1 << $i);
# $self->update_neighbour($sqt, $i)
my $n = $sqt->[$Neighbours]->[$i] || $self->get_neighbo
+ur($sqt, $i);
$n->[$Updateflags] == 0 and push @tmp, $n;
$n->[$Updateflags] |= 1 << ($i ^ 4);
}
}
}
@tmp
} @{$modified};
}
sub ticks {
my $self = shift;
my $nticks = shift;
return if $nticks <= 0;
if ($nticks == 1) { $self->tick(); return }
my $half = $nticks >> 1;
my $rem = $nticks & 1;
$self->twoticks() for 1 .. $half;
$rem and $self->tick();
}
sub updatecell {
my $self = shift;
my $sqt = shift;
my $ix = shift;
my $iy = shift;
$sqt->[$Updateflags] == 0 and push @{$self->{Modified}}, $sqt;
$sqt->[$Updateflags] |= 1 << $NUM_NEIGH;
$iy <= $BORDER_WIDTH_P1 and $self->update_neighbour($sqt, $NEIGH_TO
+P);
$iy >= $TILE_SIZE_CORE and $self->update_neighbour($sqt, $NEIGH_BO
+TTOM);
if ($ix <= $BORDER_WIDTH_P1) {
$self->update_neighbour($sqt, $NEIGH_LEFT);
$iy <= $BORDER_WIDTH_P1 and $self->update_neighbour($sqt, $NEIGH
+_TOP_LEFT);
$iy >= $TILE_SIZE_CORE and $self->update_neighbour($sqt, $NEIGH
+_BOTTOM_LEFT);
}
if ($ix >= $TILE_SIZE_CORE) {
$self->update_neighbour($sqt, $NEIGH_RIGHT);
$iy <= $BORDER_WIDTH_P1 and $self->update_neighbour($sqt, $NEIGH
+_TOP_RIGHT);
$iy >= $TILE_SIZE_CORE and $self->update_neighbour($sqt, $NEIGH
+_BOTTOM_RIGHT);
}
}
sub setcell {
my $self = shift;
my $x = shift;
my $y = shift;
my $state = shift;
my $tiles = $self->{Tiles};
my ( $tx, $ty, $ix, $iy ) = get_tile_coords($x, $y);
my $k = pack 'i2', $tx, $ty;
exists($tiles->{$k}) or
$tiles->{$k} = [
$tx,
$ty,
0,
[ (0) x $TILE_SIZE_FULL ],
[],
];
st_setcellval($tiles->{$k}->[$Row], $ix, $iy, $state);
$self->updatecell($tiles->{$k}, $ix, $iy);
}
sub getcellval {
my $self = shift;
my $x = shift;
my $y = shift;
my $tiles = $self->{Tiles};
my ( $tx, $ty, $ix, $iy ) = get_tile_coords($x, $y);
my $k = pack 'i2', $tx, $ty;
exists $tiles->{$k} or return 0;
return st_getcellval( $tiles->{$k}->[$Row], $ix, $iy );
}
sub new {
my $class = shift;
my %init_self = ( Tiles => {}, Modified => [] );
bless \%init_self, $class;
}
1;
Along with an updated tbench1.pl that advances two at a time as much as possible.
# tbench1.pl - Simple benchmark of Organism class.
# Generate blinker test file with, for example:
# perl createblinker.pl 500000 -900000 100 >x.tmp 2>y.tmp
# then run this script for two ticks, for example:
# perl tbench1.pl x.tmp 2
use strict;
use warnings;
use Organism;
# XXX: To read Life 1.06 file, ignore leading line containing "#Life 1
+.06"
sub read_cells {
my $fname = shift;
open( my $fh, '<', $fname ) or die "error: open '$fname': $!";
map { [ split ' ' ] } <$fh>;
}
@ARGV == 2 or die "usage: $0 file nticks\n";
my $file = shift;
my $nticks = shift;
$nticks =~ /^\d+$/ or die "error: nticks ($nticks) not a number";
my $org = Organism->new();
{
my @cells = read_cells($file);
$org->insert_cells(@cells);
my $ncells = $org->count();
print "cell count at start = $ncells\n";
$ncells == scalar(@cells) or die "oops";
# Uncomment for tile dump
# $org->dump_tiles();
}
warn "run benchmark for $nticks ticks\n";
my $tstart = time;
# for my $i ( 1 .. $nticks ) { $org->tick() }
$org->ticks($nticks);
my $tend = time;
my $taken = $tend - $tstart;
my $ncells = $org->count();
# Uncomment for diff with goodlidkaout.txt
# {
# my @vcells = $org->get_live_cells();
# my $cnt = 0;
# for my $c (@vcells) {
# ++$cnt;
# print "$cnt: $c->[0],$c->[1]\n";
# }
# $cnt == $ncells or warn "error: $cnt != $ncells\n";
# }
print "cell count at end = $ncells\n";
warn "time taken: $taken secs\n";
# Uncomment for tile dump
# $org->dump_tiles();
Along with an updated tgol3.t to test the new twoticks() and ticks() methods:
# tgol3.t - Simple lidka test of Conway Game of Life Organism class
use strict;
use warnings;
use Organism;
use Test::More;
my $ntests = 321;
plan tests => $ntests;
sub test_one {
my $org = shift; # Organism handle
my $desc = shift; # Test description
my $nexpected = shift; # Expected cell count
# my $expected = shift; # Array ref of (sorted) expected cells
my @cells = $org->get_live_cells();
my $ncells = $org->count();
cmp_ok( $ncells, '==', $nexpected, "$desc cell count ($ncells)" );
cmp_ok( scalar(@cells), '==', $nexpected, "$desc cell array count"
+);
# is_deeply( \@cells, $expected, "$desc cell array" );
}
# Test first 101 ticks from famous lidka methuselah
# See: http://conwaylife.com/wiki/Lidka
my @lidka_ticks = (
13, # [ 0] initial count
15, # [ 1]
15, # [ 2]
19, # [ 3]
19, # [ 4]
23, # [ 5]
23, # [ 6]
32, # [ 7]
29, # [ 8]
47, # [ 9]
27, # [10]
32, # [11]
36, # [12]
42, # [13]
48, # [14]
48, # [15]
46, # [16]
60, # [17]
54, # [18]
56, # [19]
64, # [20]
86, # [21]
64, # [22]
74, # [23]
70, # [24]
68, # [25]
52, # [26]
58, # [27]
50, # [28]
44, # [29]
50, # [30]
54, # [31]
80, # [32]
50, # [33]
54, # [34]
56, # [35]
54, # [36]
62, # [37]
50, # [38]
58, # [39]
56, # [40]
70, # [41]
60, # [42]
48, # [43]
52, # [44]
56, # [45]
72, # [46]
70, # [47]
68, # [48]
78, # [49]
86, # [50]
82, # [51]
93, # [52]
98, # [53]
94, # [54]
110, # [55]
87, # [56]
95, # [57]
79, # [58]
88, # [59]
80, # [60]
69, # [61]
76, # [62]
91, # [63]
89, # [64]
93, # [65]
112, # [66]
108, # [67]
140, # [68]
129, # [69]
157, # [70]
138, # [71]
147, # [72]
129, # [73]
111, # [74]
101, # [75]
105, # [76]
98, # [77]
117, # [78]
106, # [79]
114, # [80]
131, # [81]
124, # [82]
132, # [83]
118, # [84]
128, # [85]
133, # [86]
128, # [87]
140, # [88]
129, # [89]
126, # [90]
140, # [91]
147, # [92]
168, # [93]
163, # [94]
174, # [95]
164, # [96]
170, # [97]
152, # [98]
150, # [99]
144, # [100]
135, # [101]
);
# Lidka cells after 100 ticks
my @lidka100 = (
[ -29, 2 ], # 1-10
[ -28, 1 ],
[ -28, 2 ],
[ -28, 3 ],
[ -27, 0 ],
[ -27, 4 ],
[ -26, 0 ],
[ -26, 1 ],
[ -26, 4 ],
[ -26, 5 ],
[ -25, 3 ], # 11-20
[ -25, 4 ],
[ -24, 2 ],
[ -24, 3 ],
[ -23, 1 ],
[ -23, 2 ],
[ -22, 0 ],
[ -21, 0 ],
[ -21, 1 ],
[ -17, -2 ],
[ -17, -1 ], # 21-30
[ -16, -2 ],
[ -16, -1 ],
[ -12, 8 ],
[ -11, 9 ],
[ -11, 10 ],
[ -11, 16 ],
[ -11, 17 ],
[ -10, 8 ],
[ -10, 9 ],
[ -10, 10 ], # 31-40
[ -10, 15 ],
[ -10, 16 ],
[ -10, 18 ],
[ -10, 19 ],
[ -9, 18 ],
[ -9, 19 ],
[ -8, 13 ],
[ -8, 18 ],
[ -8, 19 ],
[ -7, 12 ], # 41-50
[ -6, -19 ],
[ -6, -18 ],
[ -6, 16 ],
[ -6, 17 ],
[ -5, -19 ],
[ -5, -17 ],
[ -5, 12 ],
[ -5, 16 ],
[ -5, 17 ],
[ -4, -19 ], # 51-60
[ -4, 13 ],
[ -4, 14 ],
[ -4, 15 ],
[ -4, 16 ],
[ -4, 18 ],
[ -3, 14 ],
[ -3, 15 ],
[ -3, 18 ],
[ -2, 17 ],
[ -2, 18 ], # 61-70
[ -1, -13 ],
[ -1, 6 ],
[ 0, -14 ],
[ 0, -13 ],
[ 0, -12 ],
[ 0, 5 ],
[ 0, 6 ],
[ 0, 7 ],
[ 1, -15 ],
[ 1, -14 ], # 71-80
[ 1, -12 ],
[ 1, 6 ],
[ 1, 9 ],
[ 1, 10 ],
[ 2, -22 ],
[ 2, -15 ],
[ 2, 3 ],
[ 2, 6 ],
[ 3, -22 ],
[ 3, -16 ], # 81-90
[ 3, 2 ],
[ 3, 3 ],
[ 3, 4 ],
[ 3, 5 ],
[ 3, 9 ],
[ 4, -22 ],
[ 4, -17 ],
[ 4, -16 ],
[ 4, -15 ],
[ 4, -12 ], # 91-100
[ 4, -11 ],
[ 4, 3 ],
[ 4, 8 ],
[ 5, -16 ],
[ 5, -14 ],
[ 5, -12 ],
[ 5, 7 ],
[ 6, -16 ],
[ 6, -15 ],
[ 6, -14 ], # 101-110
[ 6, 4 ],
[ 6, 6 ],
[ 7, -15 ],
[ 7, -14 ],
[ 7, 4 ],
[ 7, 12 ],
[ 7, 13 ],
[ 8, -14 ],
[ 8, 12 ],
[ 8, 13 ], # 111-120
[ 9, -14 ],
[ 9, -13 ],
[ 9, -4 ],
[ 9, -2 ],
[ 9, 10 ],
[ 9, 11 ],
[ 10, -5 ],
[ 10, -1 ],
[ 10, 10 ],
[ 10, 11 ], # 121-130
[ 11, -1 ],
[ 11, 0 ],
[ 12, -7 ],
[ 12, -1 ],
[ 12, 0 ],
[ 13, -8 ],
[ 13, -7 ],
[ 13, -3 ],
[ 13, -2 ],
[ 13, -1 ], # 131-140
[ 14, -8 ],
[ 14, -3 ],
[ 14, -2 ],
[ 14, 1 ],
[ 15, -7 ],
[ 15, -6 ],
[ 15, -5 ],
[ 15, -1 ],
[ 15, 0 ],
[ 15, 1 ], # 141-144
[ 16, -7 ],
[ 16, -6 ],
[ 16, -5 ],
);
my @slidka100 = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @l
+idka100;
# Lidka cells after 101 ticks
my @lidka101 = (
[ -29, 1 ], # 1-10
[ -29, 2 ],
[ -29, 3 ],
[ -28, 1 ],
[ -28, 2 ],
[ -28, 3 ],
[ -27, 0 ],
[ -27, 4 ],
[ -27, 5 ],
[ -26, 0 ],
[ -26, 1 ], # 11-20
[ -26, 5 ],
[ -25, 1 ],
[ -25, 5 ],
[ -24, 1 ],
[ -24, 4 ],
[ -23, 1 ],
[ -23, 2 ],
[ -23, 3 ],
[ -22, 0 ],
[ -22, 2 ], # 21-30
[ -21, 0 ],
[ -21, 1 ],
[ -17, -2 ],
[ -17, -1 ],
[ -16, -2 ],
[ -16, -1 ],
[ -12, 9 ],
[ -11, 10 ],
[ -11, 15 ],
[ -11, 16 ], # 31-40
[ -11, 17 ],
[ -11, 18 ],
[ -10, 8 ],
[ -10, 10 ],
[ -10, 15 ],
[ -10, 16 ],
[ -10, 19 ],
[ -9, 9 ],
[ -9, 20 ],
[ -8, 18 ], # 41-50
[ -8, 19 ],
[ -7, 17 ],
[ -7, 18 ],
[ -6, -19 ],
[ -6, -18 ],
[ -6, 16 ],
[ -6, 17 ],
[ -5, -20 ],
[ -5, -19 ],
[ -5, 13 ], # 51-60
[ -5, 14 ],
[ -5, 18 ],
[ -4, -18 ],
[ -4, 13 ],
[ -4, 18 ],
[ -3, 13 ],
[ -3, 18 ],
[ -3, 19 ],
[ -2, 17 ],
[ -2, 18 ], # 61-70
[ -1, -14 ],
[ -1, -13 ],
[ -1, -12 ],
[ -1, 5 ],
[ -1, 6 ],
[ -1, 7 ],
[ 0, -15 ],
[ 0, -12 ],
[ 0, 5 ],
[ 0, 7 ], # 71-80
[ 1, -15 ],
[ 1, -12 ],
[ 2, -16 ],
[ 2, -15 ],
[ 2, -14 ],
[ 2, 2 ],
[ 2, 3 ],
[ 2, 6 ],
[ 2, 9 ],
[ 2, 10 ], # 81-90
[ 3, -23 ],
[ 3, -22 ],
[ 3, -21 ],
[ 3, -17 ],
[ 3, 2 ],
[ 3, 5 ],
[ 4, -17 ],
[ 4, -13 ],
[ 4, -12 ],
[ 4, -11 ], # 91-100
[ 4, 2 ],
[ 4, 3 ],
[ 4, 8 ],
[ 5, -14 ],
[ 5, -12 ],
[ 5, -11 ],
[ 5, 7 ],
[ 6, -16 ],
[ 6, 5 ],
[ 7, -16 ], # 101-110
[ 7, -13 ],
[ 7, 5 ],
[ 7, 12 ],
[ 7, 13 ],
[ 8, 13 ],
[ 9, -14 ],
[ 9, -13 ],
[ 9, 10 ],
[ 10, -2 ],
[ 10, -1 ], # 111-120
[ 10, 0 ],
[ 10, 10 ],
[ 10, 11 ],
[ 11, -2 ],
[ 12, -8 ],
[ 12, -7 ],
[ 13, -8 ],
[ 13, -7 ],
[ 13, -3 ],
[ 14, -8 ], # 121-130
[ 14, -4 ],
[ 14, -3 ],
[ 14, 1 ],
[ 15, -8 ],
[ 15, -5 ],
[ 15, -4 ],
[ 15, -2 ],
[ 15, -1 ],
[ 15, 0 ],
[ 15, 1 ], # 131-135
[ 16, -7 ],
[ 16, -5 ],
[ 16, 0 ],
[ 17, -6 ],
);
my @slidka101 = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @l
+idka101;
# Lidka starting pattern
my @lidka0 = (
[ -3, -7 ],
[ -4, -6 ],
[ -2, -6 ],
[ -3, -5 ],
[ 4, 3 ],
[ 2, 4 ],
[ 4, 4 ],
[ 1, 5 ],
[ 2, 5 ],
[ 4, 5 ],
[ 0, 7 ],
[ 1, 7 ],
[ 2, 7 ],
);
my @slidka0 = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @lid
+ka0;
# Test one tick at a time up to 101
{
# Initial cell array
my $org = Organism->new();
$org->insert_cells(@lidka0);
{
my @cells = $org->get_live_cells();
is_deeply( \@cells, \@slidka0, "lidka initial cell array" );
test_one( $org, "lidka 0", $lidka_ticks[0] );
}
# Test first 100 ticks
for my $i ( 1 .. 100 ) {
$org->tick();
test_one( $org, "lidka $i", $lidka_ticks[$i] );
}
# Final cell array after 100 ticks
{
my @cells = $org->get_live_cells();
cmp_ok( scalar(@cells), '==', $lidka_ticks[100], "lidka final ar
+ray count" );
is_deeply( \@cells, \@slidka100, "lidka final cell array" );
}
# Tick 101
{
my $i = 101;
$org->tick();
test_one( $org, "lidka $i", $lidka_ticks[$i] );
}
# Final cell array after 101 ticks
{
my @cells = $org->get_live_cells();
cmp_ok( scalar(@cells), '==', $lidka_ticks[101], "lidka final ar
+ray count" );
is_deeply( \@cells, \@slidka101, "lidka final cell array" );
}
}
# Test ticks(101) in one go
{
# Initial cell array
my $org = Organism->new();
$org->insert_cells(@lidka0);
{
my @cells = $org->get_live_cells();
is_deeply( \@cells, \@slidka0, "lidka initial cell array" );
test_one( $org, "lidka 0", $lidka_ticks[0] );
}
# Test cell array after 101 ticks
{
my $i = 101;
$org->ticks($i);
test_one( $org, "lidka $i", $lidka_ticks[$i] );
}
# Final cell array after 101 ticks
{
my @cells = $org->get_live_cells();
cmp_ok( scalar(@cells), '==', $lidka_ticks[101], "lidka final ar
+ray count" );
is_deeply( \@cells, \@slidka101, "lidka final cell array" );
}
}
# Test two ticks at a time up to 100
{
my $nticks_half = 50;
# Initial cell array
my $org = Organism->new();
$org->insert_cells(@lidka0);
{
my @cells = $org->get_live_cells();
is_deeply( \@cells, \@slidka0, "lidka initial cell array" );
test_one( $org, "lidka 0", $lidka_ticks[0] );
}
# Test first 100 ticks, two at a time
for my $i ( 1 .. $nticks_half ) {
my $j = $i * 2; # test two at a time
# $org->tick(); $org->tick(); # For parallel testing
$org->twoticks();
test_one( $org, "lidka $j", $lidka_ticks[$j] );
}
# Final cell array
{
my @cells = $org->get_live_cells();
cmp_ok( scalar(@cells), '==', $lidka_ticks[100], "lidka final ar
+ray count" );
is_deeply( \@cells, \@slidka100, "lidka final cell array" );
}
}
And a new tgol4.t to test the Organism.pm st_* functions in isolation:
# tgol4.t - Simple standalone test of Organism.pm st_ functions
use strict;
use warnings;
use Organism;
use Test::More;
my $ntests = 9;
plan tests => $ntests * 7;
# Test cells
sub test_cells {
my $desc = shift; # Test description
my $row = shift; # Row of cells in square tile
my $cells_ref = shift; # Expected cells
my $nexpected = Organism::st_count($row);
my @cells = Organism::st_getlivecells($row);
my $ncells = @cells;
cmp_ok( $ncells, '==', $nexpected, "$desc cell count ($ncells)" );
is_deeply( \@cells, $cells_ref, "$desc cell array" );
}
# Test one tick of a set of cells
sub test_one {
my $desc = shift; # Test description
my $one_two = shift; # 1 to test one tick, 2 to test two t
+icks
my $incells_ref = shift; # Initial input cells
my $outcells_ref = shift; # Expected output cells
my $expected_update = shift; # 1 if cells should change
$one_two == 1 || $one_two == 2 or die "oops: invalid one_two ($one_
+two)";
my @incells = @{$incells_ref};
my $TILE_SIZE_FULL = $Organism::TILE_SIZE_FULL;
my $TILE_SIZE_FULL_M1 = $TILE_SIZE_FULL - 1;
my @rowbuf = (0) x $TILE_SIZE_FULL;
my $row = \@rowbuf;
# Insert initial cells
Organism::st_insertcells($row, @incells);
# Sanity check of initial state
test_cells($desc, $row, $incells_ref);
# Find top and bottom of tile (first and last non-zero row)
my $top = my $bottom = $TILE_SIZE_FULL;
$row->[$_] and $top = $_, last for 0..$TILE_SIZE_FULL_M1;
if ($top != $TILE_SIZE_FULL) {
1 while --$bottom && !$row->[$bottom];
}
$top != $TILE_SIZE_FULL or die "oops, wrong top";
ok( 1, "top & bottom sane (TILE_SIZE_FULL=$TILE_SIZE_FULL top=$top
+bottom=$bottom)" );
# Test st_ tile tick.
my ($update_flag, $neigh) = ($one_two == 1)
? Organism::st_tiletick($row, $top, $bottom)
: Organism::st_tiletwoticks($row, $top, $bottom);
my $update_flag_bits = sprintf '%b', $update_flag;
$update_flag = !!$update_flag; # convert to boolean
cmp_ok( $update_flag, '==', $expected_update, "$desc update flag ($
+update_flag_bits)" );
cmp_ok( $neigh, '==', 0, "$desc neigh flag ($neigh)" );
# Check cells after tick/s
test_cells($desc, $row, $outcells_ref);
}
{
my @incells = (
[ 8, 5 ],
[ 8, 6 ],
[ 8, 7 ],
);
my @outcells = (
[ 7, 6 ],
[ 8, 6 ],
[ 9, 6 ],
);
@incells = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @in
+cells;
@outcells = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @ou
+tcells;
test_one("Vertical Blinker one", 1, \@incells, \@outcells, 1);
test_one("Vertical Blinker two", 2, \@incells, \@incells, 0);
}
{
my @incells = (
[ 7, 6 ],
[ 8, 6 ],
[ 9, 6 ],
);
my @outcells = (
[ 8, 5 ],
[ 8, 6 ],
[ 8, 7 ],
);
@incells = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @in
+cells;
@outcells = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @ou
+tcells;
test_one("Horizontal Blinker one", 1, \@incells, \@outcells, 1);
test_one("Horizontal Blinker two", 2, \@incells, \@incells, 0);
}
{
my @incells = (
[ 6, 6 ],
[ 7, 6 ],
[ 6, 7 ],
[ 7, 7 ],
);
@incells = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @inc
+ells;
test_one("Simple block one", 1, \@incells, \@incells, 0);
test_one("Simple block two", 2, \@incells, \@incells, 0);
}
{
my @incells = (
[ 6, 6 ], [ 6, 7 ], [ 6, 8 ],
[ 7, 6 ], [ 7, 7 ], [ 7, 8 ],
[ 8, 6 ], [ 8, 7 ], [ 8, 8 ],
[ 9, 6 ],
);
my @outcells = (
[ 5, 7 ],
[ 6, 6 ], [ 6, 8 ],
[ 7, 5 ], [ 7, 9 ],
[ 8, 5 ], [ 8, 8 ],
[ 9, 6 ],
);
my @outcells2 = (
[ 5, 7 ],
[ 6, 6 ], [ 6, 7 ], [ 6, 8 ],
[ 7, 5 ], [ 7, 6 ], [ 7, 7 ], [ 7, 8 ], [ 7, 9 ],
[ 8, 5 ], [ 8, 6 ],
);
@incells = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @i
+ncells;
@outcells = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @o
+utcells;
@outcells2 = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @o
+utcells2;
test_one("Weird block one-a", 1, \@incells, \@outcells, 1);
test_one("Weird block one-b", 1, \@outcells, \@outcells2, 1);
test_one("Weird block two", 2, \@incells, \@outcells2, 1);
}
References Added Later
Updated: Minor changes were made to the originally posted code.