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 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) 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 above 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 changed 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_MIDDLE) << $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_MIDDLE) >> $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] & $BM_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_MIDDLE) << $TILE_SIZE_CORE) | ($sqt->{Row}->[$TILE_SIZE_FULL_M1] & $BM_RIGHT); } 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_MIDDLE) >> $TILE_SIZE_CORE) | ($sqt->{Row}->[$TILE_SIZE_FULL_M1] & $BM_LEFT); } 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, $NEIGH_TOP_LEFT) } if ($iy >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEIGH_BOTTOM_LEFT) } } if ($ix >= $TILE_SIZE_CORE) { $self->update_neighbour($sqt, $NEIGH_RIGHT); if ($iy <= $BORDER_WIDTH_P1) { $self->update_neighbour($sqt, $NEIGH_TOP_RIGHT) } if ($iy >= $TILE_SIZE_CORE) { $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; 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;