Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

I've updated Organism.pm to automatically detect the integer size perl was built with and use 32 x 32 tiles for a 32-bit perl and 64 x 64 tiles for a 64-bit perl. You can override this by editing Organism.pm and manually setting $TILE_SIZE_FULL to 32 or 64. I've tested with an old 32-bit Perl 5.8.6 and it works for me.

Updated Benchmark Results

As you might expect, Organism.pm runs a bit slower (and uses more memory) with 32-bit ints -- but not by much.

Version375K cells750K cells1.5 million cells3 million cells
new Organism.pm (64 x 64 tiles)1 secs1 secs3 secs5 secs
new Organism.pm (32 x 32 tiles)1 secs1 secs4 secs7 secs
Organism.pm (Mario improvements)13 secs26 secs52 secs108 secs
Organism.pm (Original)35 secs70 secs141 secs284 secs
Game::Life::Infinite:Board37 secs96 secs273 secs905 secs

As for memory use, the maximum Windows Private Bytes used for the three million cell case by each process was:

  • New Organism.pm (64 x 64 tiles): 700,000K - 1,100,000K (update: seems to vary)
  • New Organism.pm (32 x 32 tiles): 1,400,000K
  • Organism.pm (Original): 1,455,004K
  • Organism.pm (Mario improvements): 1,596,368K
  • Game::Life::Infinite:Board: 18,138,504K

Benchmark timings running AppleFritter's Lidka test for 30,000 ticks were:
VersionLidka 30,000 ticks
new Organism.pm (64 x 64 tiles)58 secs
new Organism.pm (32 x 32 tiles)86 secs
Organism.pm (Mario improvements)450 secs
Organism.pm (Original)1635 secs
Game::Life::Infinite:Board640 secs

Updated Organism.pm follows.

package Organism; use strict; use warnings; # ---------------------------------------------------------------- # 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). # Note: alternatively 32 x 32 (28 x 28 core) can be used with 32-bit i +ntegers. # 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) but advances # one tick at a time (rather than advancing two at a time) # and does not attempt to use universe history. # This was to keep the implementation short. # # ---------------------------------------------------------------- # SQUARE TILE # Note: if using 64 x 64 square tiles, perl must be built with 64-bit +integers # Choose tile size (32 or 64) automatically based on perl integer size +: use Config; my $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; 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; } my $BORDER_WIDTH = 2; my $BORDER_WIDTH_P1 = $BORDER_WIDTH + 1; my $TILE_SIZE_FULL_M1 = $TILE_SIZE_FULL - 1; 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 $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; # 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) # 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. # Note: $row can alternatively be 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 $mk = 1 << ($TILE_SIZE_FULL_M1 - $x); return $row->[$y] & $mk ? 1 : 0; } sub st_setcellval { my ($row, $x, $y, $v) = @_; my $mk = 1 << ($TILE_SIZE_FULL_M1 - $x); if ($v) { $row->[$y] |= $mk; } else { $row->[$y] &= ~$mk; } } 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_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] : 1 if square tile changed, else 0. # [1] : neighbour flags (see NEIGH flags above) # indicates which neighbours need to be updated sub st_tiletick { my $row = shift; my $neigh = 0; my $bigdiff = 0; my @carry = (0) x $TILE_SIZE_FULL; my @parity = (0) x $TILE_SIZE_FULL; my @diff = (0) x $TILE_SIZE_FULL; my ( $aa, $bb, $p, $q, $r, $s, $bit0, $bit1, $bit2 ); my $top = 0; my $bottom = $TILE_SIZE_FULL_M1; while ($top < $TILE_SIZE_FULL_M1 && $row->[$top] == 0) { ++$top } while ($bottom > 0 && $row->[$bottom] == 0) { --$bottom } if ($top > $bottom) { return ( 0, $neigh ) } 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; if ($top < 1) { $top = 1 } if ($bottom > $TILE_SIZE_MBD) { $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) { if ($bigdiff & $BM_LEFTMIDDLE) { $neigh |= 1 << $NEIGH_LEFT } if ($bigdiff & $BM_RIGHTMIDDLE) { $neigh |= 1 << $NEIGH_RIGHT } } if ($aa) { $neigh |= 1 << $NEIGH_TOP; if ($aa & $BM_LEFTMIDDLE) { $neigh |= 1 << $NEIGH_TOP_LEFT } if ($aa & $BM_RIGHTMIDDLE) { $neigh |= 1 << $NEIGH_TOP_RIGHT } } if ($bb) { $neigh |= 1 << $NEIGH_BOTTOM; if ($bb & $BM_LEFTMIDDLE) { $neigh |= 1 << $NEIGH_BOTTOM_LEFT } if ($bb & $BM_RIGHTMIDDLE) { $neigh |= 1 << $NEIGH_BOTTOM_RIGHT +} } my $changed = ($bigdiff != 0) ? 1 : 0; return ( $changed, $neigh ); } # See perlmonks.org, node_id: 1199987 # Inline this popcount function below # sub popcount { sprintf('%b', shift) =~ tr/1// } # ---------------------------------------------------------------- # ORGANISM sub count { my $self = shift; my $tiles = $self->{Tiles}; my $cnt = 0; for my $k (keys %{$tiles}) { my $row = $tiles->{$k}->{Row}; for my $y ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) { next unless $row->[$y]; # $cnt += popcount($row->[$y] & $BM_MIDDLE); $cnt += sprintf('%b', $row->[$iy] & $BM_MIDDLE) =~ tr/1//; } } return $cnt; } # 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 get_live_cells { my $self = shift; my $tiles = $self->{Tiles}; my @cells; for my $k (keys %{$tiles}) { my $sqt = $tiles->{$k}; for my $y ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) { next unless $sqt->{Row}->[$y]; for my $x ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) { if (st_getcellval($sqt->{Row}, $x, $y)) { push @cells, [$TILE_SIZE_CORE * $sqt->{Tx} + $x - $BORDER_WIDTH, $TILE_SIZE_CORE * $sqt->{Ty} + $y - $BORDER_WIDTH]; } } } } sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @cells; } sub get_neighbour { my $self = shift; my $sqt = shift; my $i = shift; unless ($sqt->{Neighbours}->[$i]) { my $x = $sqt->{Tx}; my $y = $sqt->{Ty}; if ($i >= $NEIGH_TOP_RIGHT && $i <= $NEIGH_BOTTOM_RIGHT) { ++ +$x } if ($i >= $NEIGH_BOTTOM_RIGHT && $i <= $NEIGH_BOTTOM_LEFT) { ++ +$y } if ($i >= $NEIGH_BOTTOM_LEFT && $i <= $NEIGH_TOP_LEFT) { -- +$x } if ($i == $NEIGH_TOP_LEFT || $i <= $NEIGH_TOP_RIGHT) { -- +$y } my $tiles = $self->{Tiles}; my $k = pack 'i2', $x, $y; unless (exists $tiles->{$k}) { $tiles->{$k} = { Row => [ (0) x $TILE_SIZE_FULL ], Tx => $x, Ty => $y, Updateflags => 0, Neighbours => [], }; } $sqt->{Neighbours}->[$i] = $tiles->{$k}; } return $sqt->{Neighbours}->[$i]; } # Alert the neighbour that its neighbour (the original tile) has chang +ed sub update_neighbour { my $self = shift; my $sqt = shift; my $i = shift; if ($self->get_neighbour($sqt, $i)->{Updateflags} == 0) { push @{$self->{Modified}}, $self->get_neighbour($sqt, $i); } $self->get_neighbour($sqt, $i)->{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. # Only perform this copying when necessary. # Note: alternatively: 32-by-32 with central 28-by-28. sub update_boundary { my $self = shift; my $sqt = shift; my $temp_modified = $self->{TempModified}; if ( $sqt->{Updateflags} & (1 << $NEIGH_TOP) ) { my $n = $self->get_neighbour($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_MIDDLE +) | ($sqt->{Row}->[1] & $BM_OUTER); } if ( $sqt->{Updateflags} & (1 << $NEIGH_TOP_LEFT) ) { my $n = $self->get_neighbour($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_MIDDL +E) << $TILE_SIZE_CORE) | ($sqt->{Row}->[1] & $BM_RIGHT); } if ( $sqt->{Updateflags} & (1 << $NEIGH_TOP_RIGHT) ) { my $n = $self->get_neighbour($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_MIDDL +E) >> $TILE_SIZE_CORE) | ($sqt->{Row}->[1] & $BM_LEFT); } if ( $sqt->{Updateflags} & (1 << $NEIGH_BOTTOM) ) { my $n = $self->get_neighbour($sqt, $NEIGH_BOTTOM); $sqt->{Row}->[$TILE_SIZE_MBD] = ($n->{Row}->[$BORDER_WIDTH] & $B +M_MIDDLE) | ($sqt->{Row}->[$TILE_SIZE_MBD] & $BM_OUTER); $sqt->{Row}->[$TILE_SIZE_FULL_M1] = ($n->{Row}->[3] & $BM_MIDDLE +) | ($sqt->{Row}->[$TILE_SIZE_FULL_M1] & $BM_OUTER); } if ( $sqt->{Updateflags} & (1 << $NEIGH_BOTTOM_LEFT) ) { my $n = $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_MIDDL +E) << $TILE_SIZE_CORE) | ($sqt->{Row}->[$TILE_SIZE_FULL_M1] & $BM_RIG +HT); } if ( $sqt->{Updateflags} & (1 << $NEIGH_BOTTOM_RIGHT) ) { my $n = $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_MIDDL +E) >> $TILE_SIZE_CORE) | ($sqt->{Row}->[$TILE_SIZE_FULL_M1] & $BM_LEF +T); } if ( $sqt->{Updateflags} & (1 << $NEIGH_LEFT) ) { my $n = $self->get_neighbour($sqt, $NEIGH_LEFT); for my $i ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) { $sqt->{Row}->[$i] = (($n->{Row}->[$i] & $BM_MIDDLE) << $TILE_ +SIZE_CORE) | ($sqt->{Row}->[$i] & $BM_RIGHT); } } if ( $sqt->{Updateflags} & (1 << $NEIGH_RIGHT) ) { my $n = $self->get_neighbour($sqt, $NEIGH_RIGHT); for my $i ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) { $sqt->{Row}->[$i] = (($n->{Row}->[$i] & $BM_MIDDLE) >> $TILE_ +SIZE_CORE) | ($sqt->{Row}->[$i] & $BM_LEFT); } } $sqt->{Updateflags} = 0; push @{$temp_modified}, $sqt; } # Advance the interior of the tile by one generation. sub update_tile { my $self = shift; my $modified = $self->{Modified}; my $sqt = shift; my ($update_flag, $neigh) = st_tiletick($sqt->{Row}); if ($update_flag) { if ($sqt->{Updateflags} == 0) { push @{$modified}, $sqt } $sqt->{Updateflags} |= 1 << $NUM_NEIGH; } for my $i (0 .. $NUM_NEIGH - 1) { if ($neigh & (1 << $i)) { $self->update_neighbour($sqt, $i) } } } sub tick { my $self = shift; my $modified = $self->{Modified}; my $temp_modified = $self->{TempModified}; while (@{$modified}) { $self->update_boundary(pop @{$modified}); } while (@{$temp_modified}) { $self->update_tile(pop @{$temp_modified}); } } sub updatecell { my $self = shift; my $sqt = shift; my $x = shift; my $y = shift; if ($sqt->{Updateflags} == 0) { push @{$self->{Modified}}, $sqt } $sqt->{Updateflags} |= 1 << $NUM_NEIGH; if ($y <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NEIGH_ +TOP) } if ($y >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEIGH_B +OTTOM) } if ($x <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NEIGH_LEFT); if ($y <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NEI +GH_TOP_LEFT) } if ($y >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEIG +H_BOTTOM_LEFT) } } if ($x >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEIGH_RIGHT); if ($y <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NEI +GH_TOP_RIGHT) } if ($y >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEIG +H_BOTTOM_RIGHT) } } } sub setcell { my $self = shift; my $x = shift; my $y = shift; my $state = shift; my $tiles = $self->{Tiles}; 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 $k = pack 'i2', $tx, $ty; unless (exists $tiles->{$k}) { $tiles->{$k} = { Row => [ (0) x $TILE_SIZE_FULL ], Tx => $tx, Ty => $ty, Updateflags => 0, Neighbours => [], }; } my $xx = $ox + $BORDER_WIDTH; my $yy = $oy + $BORDER_WIDTH; st_setcellval($tiles->{$k}->{Row}, $xx, $yy, $state); $self->updatecell($tiles->{$k}, $xx, $yy); } sub getcellval { my $self = shift; my $x = shift; my $y = shift; my $tiles = $self->{Tiles}; 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 $k = pack 'i2', $tx, $ty; exists $tiles->{$k} or return 0; return st_getcellval( $tiles->{$k}->{Row}, $ox + $BORDER_WIDTH, $oy + $BORDER_WIDTH ); } sub new { my $class = shift; my %init_self = ( Tiles => {}, Modified => [], TempModified => [] ) +; bless \%init_self, $class; } 1;

Update: For cheap thrills, I tried bigint with 128-bit integers. Very few changes needed to the code, just:

use bigint; $TILE_SIZE_FULL = 128; if ($TILE_SIZE_FULL == 128) { no warnings qw(portable overflow); $BM_MIDDLE = 0x3ffffffffffffffffffffffffffffffc; $BM_LEFT = 0xfffffffffffffffffffffffffffffffc; $BM_RIGHT = 0x3fffffffffffffffffffffffffffffff; $BM_OUTER = 0xc0000000000000000000000000000003; $BM_LEFTMIDDLE = 0x30000000000000000000000000000000; $BM_RIGHTMIDDLE = 0x0000000000000000000000000000000c; }
It appeared to work fine, but was super slow, as you might expect.

Update: Tried to clarify the code a bit by introducing a new coordinate mapping function get_tile_coords() and its converse get_cell_coords() (plus some other minor improvements).

package Organism; use strict; use warnings; # ---------------------------------------------------------------- # 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). # Note: alternatively 32 x 32 (28 x 28 core) can be used with 32-bit i +ntegers. # 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) but advances # one tick at a time (rather than advancing two at a time) # and does not attempt to use universe history. # This was to keep the implementation short. # # ---------------------------------------------------------------- # SQUARE TILE # Note: if using 64 x 64 square tiles, perl must be built with 64-bit +integers # Choose tile size (32 or 64) automatically based on perl integer size +: use Config; my $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_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 $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; # 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) # 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. # Note: $row can alternatively be 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_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] : 1 if square tile changed, else 0. # [1] : neighbour flags (see NEIGH flags above) # indicates which neighbours need to be updated sub st_tiletick { my $row = shift; my $neigh = 0; my $bigdiff = 0; my @carry = (0) x $TILE_SIZE_FULL; my @parity = (0) x $TILE_SIZE_FULL; my @diff = (0) x $TILE_SIZE_FULL; my ( $aa, $bb, $p, $q, $r, $s, $bit0, $bit1, $bit2 ); my $top = 0; my $bottom = $TILE_SIZE_FULL_M1; while ($top < $TILE_SIZE_FULL_M1 && $row->[$top] == 0) { ++$top } while ($bottom > 0 && $row->[$bottom] == 0) { --$bottom } if ($top > $bottom) { return ( 0, $neigh ) } 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; if ($top < 1) { $top = 1 } if ($bottom > $TILE_SIZE_MBD) { $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) { if ($bigdiff & $BM_LEFTMIDDLE) { $neigh |= 1 << $NEIGH_LEFT } if ($bigdiff & $BM_RIGHTMIDDLE) { $neigh |= 1 << $NEIGH_RIGHT } } if ($aa) { $neigh |= 1 << $NEIGH_TOP; if ($aa & $BM_LEFTMIDDLE) { $neigh |= 1 << $NEIGH_TOP_LEFT } if ($aa & $BM_RIGHTMIDDLE) { $neigh |= 1 << $NEIGH_TOP_RIGHT } } if ($bb) { $neigh |= 1 << $NEIGH_BOTTOM; if ($bb & $BM_LEFTMIDDLE) { $neigh |= 1 << $NEIGH_BOTTOM_LEFT } if ($bb & $BM_RIGHTMIDDLE) { $neigh |= 1 << $NEIGH_BOTTOM_RIGHT +} } my $changed = ($bigdiff != 0) ? 1 : 0; return ( $changed, $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; } # 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 $row = $sqt->{Row}; my $tx = $sqt->{Tx}; my $ty = $sqt->{Ty}; 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; } sub get_neighbour { my $self = shift; my $sqt = shift; my $i = shift; unless ($sqt->{Neighbours}->[$i]) { my $tx = $sqt->{Tx}; my $ty = $sqt->{Ty}; if ($i >= $NEIGH_TOP_RIGHT && $i <= $NEIGH_BOTTOM_RIGHT) { ++ +$tx } if ($i >= $NEIGH_BOTTOM_RIGHT && $i <= $NEIGH_BOTTOM_LEFT) { ++ +$ty } if ($i >= $NEIGH_BOTTOM_LEFT && $i <= $NEIGH_TOP_LEFT) { -- +$tx } if ($i == $NEIGH_TOP_LEFT || $i <= $NEIGH_TOP_RIGHT) { -- +$ty } my $tiles = $self->{Tiles}; my $k = pack 'i2', $tx, $ty; unless (exists $tiles->{$k}) { $tiles->{$k} = { Row => [ (0) x $TILE_SIZE_FULL ], Tx => $tx, Ty => $ty, Updateflags => 0, Neighbours => [], }; } $sqt->{Neighbours}->[$i] = $tiles->{$k}; } return $sqt->{Neighbours}->[$i]; } # Alert the neighbour that its neighbour (the original tile) has chang +ed sub update_neighbour { my $self = shift; my $sqt = shift; my $i = shift; if ($self->get_neighbour($sqt, $i)->{Updateflags} == 0) { push @{$self->{Modified}}, $self->get_neighbour($sqt, $i); } $self->get_neighbour($sqt, $i)->{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. # Only perform this copying when necessary. # Note: alternatively: 32-by-32 with central 28-by-28. sub update_boundary { my $self = shift; my $sqt = shift; my $temp_modified = $self->{TempModified}; if ( $sqt->{Updateflags} & (1 << $NEIGH_TOP) ) { my $n = $self->get_neighbour($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_MIDDLE +) | ($sqt->{Row}->[1] & $BM_OUTER); } if ( $sqt->{Updateflags} & (1 << $NEIGH_TOP_LEFT) ) { my $n = $self->get_neighbour($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_MIDDL +E) << $TILE_SIZE_CORE) | ($sqt->{Row}->[1] & $BM_RIGHT); } if ( $sqt->{Updateflags} & (1 << $NEIGH_TOP_RIGHT) ) { my $n = $self->get_neighbour($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_MIDDL +E) >> $TILE_SIZE_CORE) | ($sqt->{Row}->[1] & $BM_LEFT); } if ( $sqt->{Updateflags} & (1 << $NEIGH_BOTTOM) ) { my $n = $self->get_neighbour($sqt, $NEIGH_BOTTOM); $sqt->{Row}->[$TILE_SIZE_MBD] = ($n->{Row}->[$BORDER_WIDTH] & $B +M_MIDDLE) | ($sqt->{Row}->[$TILE_SIZE_MBD] & $BM_OUTER); $sqt->{Row}->[$TILE_SIZE_FULL_M1] = ($n->{Row}->[3] & $BM_MIDDLE +) | ($sqt->{Row}->[$TILE_SIZE_FULL_M1] & $BM_OUTER); } if ( $sqt->{Updateflags} & (1 << $NEIGH_BOTTOM_LEFT) ) { my $n = $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_MIDDL +E) << $TILE_SIZE_CORE) | ($sqt->{Row}->[$TILE_SIZE_FULL_M1] & $BM_RIG +HT); } if ( $sqt->{Updateflags} & (1 << $NEIGH_BOTTOM_RIGHT) ) { my $n = $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_MIDDL +E) >> $TILE_SIZE_CORE) | ($sqt->{Row}->[$TILE_SIZE_FULL_M1] & $BM_LEF +T); } if ( $sqt->{Updateflags} & (1 << $NEIGH_LEFT) ) { my $n = $self->get_neighbour($sqt, $NEIGH_LEFT); for my $i ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) { $sqt->{Row}->[$i] = (($n->{Row}->[$i] & $BM_MIDDLE) << $TILE_ +SIZE_CORE) | ($sqt->{Row}->[$i] & $BM_RIGHT); } } if ( $sqt->{Updateflags} & (1 << $NEIGH_RIGHT) ) { my $n = $self->get_neighbour($sqt, $NEIGH_RIGHT); for my $i ($BORDER_WIDTH .. $TILE_SIZE_MBD_M1) { $sqt->{Row}->[$i] = (($n->{Row}->[$i] & $BM_MIDDLE) >> $TILE_ +SIZE_CORE) | ($sqt->{Row}->[$i] & $BM_LEFT); } } $sqt->{Updateflags} = 0; push @{$temp_modified}, $sqt; } # Advance the interior of the tile by one generation. sub update_tile { my $self = shift; my $modified = $self->{Modified}; my $sqt = shift; my ($update_flag, $neigh) = st_tiletick($sqt->{Row}); if ($update_flag) { if ($sqt->{Updateflags} == 0) { push @{$modified}, $sqt } $sqt->{Updateflags} |= 1 << $NUM_NEIGH; } for my $i (0 .. $NUM_NEIGH - 1) { if ($neigh & (1 << $i)) { $self->update_neighbour($sqt, $i) } } } sub tick { my $self = shift; my $modified = $self->{Modified}; my $temp_modified = $self->{TempModified}; while (@{$modified}) { $self->update_boundary(pop @{$modified}); } while (@{$temp_modified}) { $self->update_tile(pop @{$temp_modified}); } } sub updatecell { my $self = shift; my $sqt = shift; my $ix = shift; my $iy = shift; if ($sqt->{Updateflags} == 0) { push @{$self->{Modified}}, $sqt } $sqt->{Updateflags} |= 1 << $NUM_NEIGH; if ($iy <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NEIGH +_TOP) } if ($iy >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEIGH_ +BOTTOM) } if ($ix <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NEIGH_LEFT); if ($iy <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NE +IGH_TOP_LEFT) } if ($iy >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEI +GH_BOTTOM_LEFT) } } if ($ix >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEIGH_RIGHT); if ($iy <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NE +IGH_TOP_RIGHT) } if ($iy >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEI +GH_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; unless (exists $tiles->{$k}) { $tiles->{$k} = { Row => [ (0) x $TILE_SIZE_FULL ], Tx => $tx, Ty => $ty, Updateflags => 0, Neighbours => [], }; } 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 => [], TempModified => [] ) +; bless \%init_self, $class; } 1;
Along with an associated tdumpxy.pl test program to help clarify the mapping:
# tdumpxy.pl - Test mapping of Cell x,y to Tile tx,ty use strict; use warnings; use Organism; for my $x ( -100 .. 100 ) { for my $y ( -100 .. 100 ) { my ( $tx, $ty, $ix, $iy ) = Organism::get_tile_coords($x, $y); my ( $nx, $ny ) = Organism::get_cell_coords($tx, $ty, $ix, $iy); warn "x=$x y=$y: tx=$tx ty=$ty ix=$ix iy=$iy: nx=$nx ny=$ny\n"; $x == $nx or die "oops x"; $y == $ny or die "oops y"; } }

Updated: Changed popcount() function above based on How to do popcount (aka Hamming weight) in Perl


In reply to Re: 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":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others making s'mores by the fire in the courtyard of the Monastery: (3)
    As of 2018-04-24 17:35 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      Notices?