Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??

I've added a new twoticks method to advance the universe two ticks at a time. Advancing the universe by two generations is easy to implement and offers significant performance advantages (as pointed out by apg) because 2-periodic "ash" (e.g. blinker) is common in game of life, and stepping two ticks at a time automatically detects it.

Further improvements may be possible by adding more sophisticated history detection.

Updated Benchmark Results

Benchmark timings running the 3 million cell blinker for both two ticks and one hundred ticks:
Version3 million cell blinker, 2 ticks3 million cell blinker, 100 ticks
new Organism.pm (64 x 64 tiles) - one at a time5 secs256 secs
new Organism.pm (64 x 64 tiles) - two at a time3 secs3 secs!!!

When running the admittedly artificial blinker test two at a time, notice that the pattern does not change at all! ... so all tiles are marked as unchanged and no further calculations are performed!

Benchmark timings running AppleFritter's Lidka test for 30,000 ticks:
VersionLidka 30,000 ticks
new Organism.pm (64 x 64 tiles) - two at a time17 secs
new Organism.pm (32 x 32 tiles) - two at a time18 secs
new Organism.pm (64 x 64 tiles) - one at a time49 secs
new Organism.pm (32 x 32 tiles) - one at a time72 secs
old Organism.pm (Mario improvements)450 secs
old Organism.pm (Original)1635 secs
Game::Life::Infinite::Board640 secs

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.


In reply to Re^2: More Betterer Game of Life by eyepopslikeamosquito
in thread More Betterer Game of Life by eyepopslikeamosquito

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others wandering the Monastery: (8)
As of 2024-03-28 19:24 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found