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 above 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 changed 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_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 = $sqt->[$Neighbours]->[$NEIGH_TOP_LEFT] || $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 = $sqt->[$Neighbours]->[$NEIGH_TOP_RIGHT] || $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 = $sqt->[$Neighbours]->[$NEIGH_BOTTOM] || $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 = $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_MIDDLE) << $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_MIDDLE) >> $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_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 = $sqt->[$Neighbours]->[$NEIGH_RIGHT] || $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); } } } 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($sqt); $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 for 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_neighbour($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($sqt); $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 for 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, $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_neighbour($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_TOP); $iy >= $TILE_SIZE_CORE and $self->update_neighbour($sqt, $NEIGH_BOTTOM); 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;