Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

Re^3: High Performance Game of Life

by marioroy (Parson)
on Aug 12, 2017 at 10:25 UTC ( #1197302=note: print w/replies, xml ) Need Help??


in reply to Re^2: High Performance Game of Life
in thread High Performance Game of Life

Hi eyepopslikeamosquito,

On my laptop, the following shaves 4 seconds from one-time stringification per key.

# Return the list of dead cells surrounding a cell
sub get_dead_cells {
   my ( $cells, $x0, $y0 ) = ( shift->{Cells}, @_ );
   my ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );
   my ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8 );

   ( ( $k1 = "$x1:$y1" ) x !( 0 + exists $cells->{ $k1 } ),
     ( $k2 = "$x1:$y0" ) x !( 0 + exists $cells->{ $k2 } ),
     ( $k3 = "$x1:$y2" ) x !( 0 + exists $cells->{ $k3 } ),
     ( $k4 = "$x0:$y1" ) x !( 0 + exists $cells->{ $k4 } ),
     ( $k5 = "$x0:$y2" ) x !( 0 + exists $cells->{ $k5 } ),
     ( $k6 = "$x2:$y1" ) x !( 0 + exists $cells->{ $k6 } ),
     ( $k7 = "$x2:$y0" ) x !( 0 + exists $cells->{ $k7 } ),
     ( $k8 = "$x2:$y2" ) x !( 0 + exists $cells->{ $k8 } ) );
}

[download]

To not allocate the key variables each time, another 2 seconds reduction is possible with the state feature.

use feature 'state';

# Return the list of dead cells surrounding a cell
sub get_dead_cells {
   my ( $cells, $x0, $y0 ) = ( shift->{Cells}, @_ );
   my ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );

   state ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8 );

   ( ( $k1 = "$x1:$y1" ) x !( 0 + exists $cells->{ $k1 } ),
     ( $k2 = "$x1:$y0" ) x !( 0 + exists $cells->{ $k2 } ),
     ( $k3 = "$x1:$y2" ) x !( 0 + exists $cells->{ $k3 } ),
     ( $k4 = "$x0:$y1" ) x !( 0 + exists $cells->{ $k4 } ),
     ( $k5 = "$x0:$y2" ) x !( 0 + exists $cells->{ $k5 } ),
     ( $k6 = "$x2:$y1" ) x !( 0 + exists $cells->{ $k6 } ),
     ( $k7 = "$x2:$y0" ) x !( 0 + exists $cells->{ $k7 } ),
     ( $k8 = "$x2:$y2" ) x !( 0 + exists $cells->{ $k8 } ) );
}

[download]

Regards, Mario

Replies are listed 'Best First'.
Re^4: High Performance Game of Life
by marioroy (Parson) on Aug 12, 2017 at 17:38 UTC

    Hi eyepopslikeamosquito,

    Here is Organism.pm modified to use pack/unpack, plus slight optimization applied to insert_cells.

    package Organism;

use strict;
use warnings;
use feature 'state';

sub count {
   return scalar keys %{ shift->{Cells} };
}

# Input a list of [ x, y ] coords
sub insert_cells {
   my $cells = shift->{Cells};
   for my $r (@_) { $cells->{ pack 'ii', @{$r} } = undef }
}

# Return sorted list of cells in the Organism.
# Used for verification and testing the state of the organism.
sub get_live_cells {
   sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] }
      map { [ unpack 'ii', $_ ] }
      keys %{ shift->{Cells} };
}

# Return the list of dead cells surrounding a cell
sub get_dead_cells {
   my ( $cells, $x0, $y0 ) = ( shift->{Cells}, @_ );
   my ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );

   state ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8 );

   ( ( $k1 = pack 'ii', $x1, $y1 ) x !( 0 + exists $cells->{ $k1 } ),
     ( $k2 = pack 'ii', $x1, $y0 ) x !( 0 + exists $cells->{ $k2 } ),
     ( $k3 = pack 'ii', $x1, $y2 ) x !( 0 + exists $cells->{ $k3 } ),
     ( $k4 = pack 'ii', $x0, $y1 ) x !( 0 + exists $cells->{ $k4 } ),
     ( $k5 = pack 'ii', $x0, $y2 ) x !( 0 + exists $cells->{ $k5 } ),
     ( $k6 = pack 'ii', $x2, $y1 ) x !( 0 + exists $cells->{ $k6 } ),
     ( $k7 = pack 'ii', $x2, $y0 ) x !( 0 + exists $cells->{ $k7 } ),
     ( $k8 = pack 'ii', $x2, $y2 ) x !( 0 + exists $cells->{ $k8 } ) )
+;
}

sub get_num_live {
   my ( $cells, $x0, $y0 ) = ( shift->{Cells}, @_ );
   my ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );

     ( 0 + exists $cells->{ pack 'ii', $x1, $y1 } )
   + ( 0 + exists $cells->{ pack 'ii', $x1, $y0 } )
   + ( 0 + exists $cells->{ pack 'ii', $x1, $y2 } )
   + ( 0 + exists $cells->{ pack 'ii', $x0, $y1 } )
   + ( 0 + exists $cells->{ pack 'ii', $x0, $y2 } )
   + ( 0 + exists $cells->{ pack 'ii', $x2, $y1 } )
   + ( 0 + exists $cells->{ pack 'ii', $x2, $y0 } )
   + ( 0 + exists $cells->{ pack 'ii', $x2, $y2 } );
}

sub tick {
   my $self = shift;
   my %new_cells;
   for my $c (keys %{ $self->{Cells} }) {
      # Get the (up to 8) dead cells surrounding the cell
      my @zcells = $self->get_dead_cells( unpack 'ii', $c );

      # Check the live cell
      # Note: next line equivalent to nlive == 2 || nlive == 3
      @zcells == 5 || @zcells == 6 and $new_cells{$c} = undef;

      # Check the dead cells
      for my $z (@zcells) {
         $self->get_num_live( unpack 'ii', $z ) == 3 and $new_cells{$z
+} = undef;
      }
   }
   $self->{Cells} = \%new_cells;
}

sub new {
   my $class = shift;
   my %init_self = ( Cells => {} );
   bless \%init_self, $class;
}

1;

    [download]

    Regards, Mario

[reply]
[d/l]

      Update: pack 'i2' is more efficient than pack 'ii'

      Organism.pm optimized with pack/unpack 'i2' and inlining critical paths.

      package Organism;

use strict;
use warnings;
use feature 'state';

sub count {
   return scalar keys %{ shift->{Cells} };
}

# Input a list of [ x, y ] coords
sub insert_cells {
   my $cells = shift->{Cells};
   for my $r (@_) { $cells->{ pack 'i2', @{$r} } = undef }
}

# Return sorted list of cells in the Organism.
# Used for verification and testing the state of the organism.
sub get_live_cells {
   sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] }
      map { [ unpack 'i2', $_ ] }
      keys %{ shift->{Cells} };
}

# Return the list of dead cells surrounding a cell
sub get_dead_cells {
   my ( $cells, $x0, $y0 ) = ( shift->{Cells}, @_ );
   my ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );

   state ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8 );

   ( ( $k1 = pack 'i2', $x1, $y1 ) x !( 0 + exists $cells->{ $k1 } ),
     ( $k2 = pack 'i2', $x1, $y0 ) x !( 0 + exists $cells->{ $k2 } ),
     ( $k3 = pack 'i2', $x1, $y2 ) x !( 0 + exists $cells->{ $k3 } ),
     ( $k4 = pack 'i2', $x0, $y1 ) x !( 0 + exists $cells->{ $k4 } ),
     ( $k5 = pack 'i2', $x0, $y2 ) x !( 0 + exists $cells->{ $k5 } ),
     ( $k6 = pack 'i2', $x2, $y1 ) x !( 0 + exists $cells->{ $k6 } ),
     ( $k7 = pack 'i2', $x2, $y0 ) x !( 0 + exists $cells->{ $k7 } ),
     ( $k8 = pack 'i2', $x2, $y2 ) x !( 0 + exists $cells->{ $k8 } ) )
+;
}

sub tick {
   my $self  = shift;
   my $cells = $self->{Cells};
   my %new_cells;

   for my $c (keys %{ $cells }) {
      # Get the (up to 8) dead cells surrounding the cell
      my @zcells = $self->get_dead_cells( unpack 'i2', $c );

      # Check the live cell
      # Note: next line equivalent to nlive == 2 || nlive == 3
      @zcells == 5 || @zcells == 6 and $new_cells{$c} = undef;

      # Check the dead cells
      for my $z (@zcells) {
         state ( $x0, $x1, $x2, $y0, $y1, $y2 );

         ( $x0, $y0 ) = unpack 'i2', $z;
         ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1
+ );

         # Get num live
         (   ( 0 + exists $cells->{ pack 'i2', $x1, $y1 } )
           + ( 0 + exists $cells->{ pack 'i2', $x1, $y0 } )
           + ( 0 + exists $cells->{ pack 'i2', $x1, $y2 } )
           + ( 0 + exists $cells->{ pack 'i2', $x0, $y1 } )
           + ( 0 + exists $cells->{ pack 'i2', $x0, $y2 } )
           + ( 0 + exists $cells->{ pack 'i2', $x2, $y1 } )
           + ( 0 + exists $cells->{ pack 'i2', $x2, $y0 } )
           + ( 0 + exists $cells->{ pack 'i2', $x2, $y2 } )
         ) == 3 and $new_cells{$z} = undef;
      }
   }

   $self->{Cells} = \%new_cells;
}

sub new {
   my $class = shift;
   my %init_self = ( Cells => {} );
   bless \%init_self, $class;
}

1;

      [download]

      Regards, Mario

[reply]
[d/l]

        Thanks Mario! Shaved a couple more seconds:

        • Inlined get_dead_cells()
        • Got rid of state (didn't seem to make it any faster)
        • Switched off warnings (admittedly this didn't make much, if any, difference)
        • Some other minor tweaks
        See "Mario improvements" entries in "Benchmark Results" section of root node for speed comparison with original Organism.pm.

        Note: The code below is the fastest version of the Perl GOL code in this node. 

        package Organism;

use strict;

sub count { scalar keys %{ shift->{Cells} } }

# Input a list of [ x, y ] coords
sub insert_cells {
   my $cells = shift->{Cells};
   for my $r (@_) { $cells->{ pack 'i2', @{$r} } = undef }
}

# Return sorted list of cells in the Organism.
# Used for verification and testing the state of the organism.
sub get_live_cells {
   sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] }
      map { [ unpack 'i2', $_ ] } keys %{ shift->{Cells} };
}

sub tick {
   my $self  = shift;
   my $cells = $self->{Cells};
   my ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8,
        $x0, $x1, $x2, $y0, $y1, $y2, %newcells );

   for my $c (keys %{ $cells }) {
      # Get the (up to 8) dead cells surrounding the cell
      ( $x0, $y0 ) = unpack 'i2', $c;
      ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );
      my @zcells = (
         ($k1 = pack 'i2', $x1, $y1) x !exists($cells->{$k1}),
         ($k2 = pack 'i2', $x1, $y0) x !exists($cells->{$k2}),
         ($k3 = pack 'i2', $x1, $y2) x !exists($cells->{$k3}),
         ($k4 = pack 'i2', $x0, $y1) x !exists($cells->{$k4}),
         ($k5 = pack 'i2', $x0, $y2) x !exists($cells->{$k5}),
         ($k6 = pack 'i2', $x2, $y1) x !exists($cells->{$k6}),
         ($k7 = pack 'i2', $x2, $y0) x !exists($cells->{$k7}),
         ($k8 = pack 'i2', $x2, $y2) x !exists($cells->{$k8})  );

      # Check the live cell (next line equivalent to nlive==2 || nlive
+==3)
      @zcells == 5 || @zcells == 6 and $newcells{$c} = undef;

      # Check the dead cells
      for my $z (@zcells) {
         ( $x0, $y0 ) = unpack 'i2', $z;
         ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1
+ );
           exists($cells->{pack 'i2', $x1, $y1})
         + exists($cells->{pack 'i2', $x1, $y0})
         + exists($cells->{pack 'i2', $x1, $y2})
         + exists($cells->{pack 'i2', $x0, $y1})
         + exists($cells->{pack 'i2', $x0, $y2})
         + exists($cells->{pack 'i2', $x2, $y1})
         + exists($cells->{pack 'i2', $x2, $y0})
         + exists($cells->{pack 'i2', $x2, $y2}) == 3 and $newcells{$z
+} = undef;
      }
   }
   $self->{Cells} = \%newcells;
}

sub new {
   my $class = shift;
   my %init_self = ( Cells => {} );
   bless \%init_self, $class;
}

1;

        [download]

        Update: Minor stylistic edits were made to Organism.pm above.

        Note that changing the main loop above from: 

        for my $c (keys %{ $cells }) {

        [download]
        to: 
        while ( my ($c) = each %{ $cells } ) {

        [download]
        uses less memory - though I couldn't measure any difference in speed.

        Update: This one is shorter, but a bit slower: 

        sub tick {
   my $self  = shift;
   my $cells = $self->{Cells};
   my ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8,
        $x0, $x1, $x2, $y0, $y1, $y2 );
   %{$cells} = map {
      ( $x0, $y0 ) = unpack 'i2', $_;
      ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );
      my @zcells = (
         ($k1 = pack 'i2', $x1, $y1) x !exists($cells->{$k1}),
         ($k2 = pack 'i2', $x1, $y0) x !exists($cells->{$k2}),
         ($k3 = pack 'i2', $x1, $y2) x !exists($cells->{$k3}),
         ($k4 = pack 'i2', $x0, $y1) x !exists($cells->{$k4}),
         ($k5 = pack 'i2', $x0, $y2) x !exists($cells->{$k5}),
         ($k6 = pack 'i2', $x2, $y1) x !exists($cells->{$k6}),
         ($k7 = pack 'i2', $x2, $y0) x !exists($cells->{$k7}),
         ($k8 = pack 'i2', $x2, $y2) x !exists($cells->{$k8})  );
      ($_, undef) x (@zcells == 5 || @zcells == 6),
      map { ( $x0, $y0 ) = unpack 'i2', $_;
          ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 
+1 );
          ($_, undef) x ( exists($cells->{pack 'i2', $x1, $y1})
          + exists($cells->{pack 'i2', $x1, $y0})
          + exists($cells->{pack 'i2', $x1, $y2})
          + exists($cells->{pack 'i2', $x0, $y1})
          + exists($cells->{pack 'i2', $x0, $y2})
          + exists($cells->{pack 'i2', $x2, $y1})
          + exists($cells->{pack 'i2', $x2, $y0})
          + exists($cells->{pack 'i2', $x2, $y2}) == 3 ) } @zcells
   } keys %{$cells};
}

        [download]
        as is this one: 
        sub tick {
   my $self  = shift;
   my $cells = $self->{Cells};
   my ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8,
        $x0, $x1, $x2, $y0, $y1, $y2 );
   my %newcells;
   @newcells{map {
      ( $x0, $y0 ) = unpack 'i2', $_;
      ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );
      my @zcells = (
         ($k1 = pack 'i2', $x1, $y1) x !exists($cells->{$k1}),
         ($k2 = pack 'i2', $x1, $y0) x !exists($cells->{$k2}),
         ($k3 = pack 'i2', $x1, $y2) x !exists($cells->{$k3}),
         ($k4 = pack 'i2', $x0, $y1) x !exists($cells->{$k4}),
         ($k5 = pack 'i2', $x0, $y2) x !exists($cells->{$k5}),
         ($k6 = pack 'i2', $x2, $y1) x !exists($cells->{$k6}),
         ($k7 = pack 'i2', $x2, $y0) x !exists($cells->{$k7}),
         ($k8 = pack 'i2', $x2, $y2) x !exists($cells->{$k8})  );
      ($_) x (@zcells == 5 || @zcells == 6),
      map { ( $x0, $y0 ) = unpack 'i2', $_;
          ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 
+1 );
          ($_) x ( exists($cells->{pack 'i2', $x1, $y1})
          + exists($cells->{pack 'i2', $x1, $y0})
          + exists($cells->{pack 'i2', $x1, $y2})
          + exists($cells->{pack 'i2', $x0, $y1})
          + exists($cells->{pack 'i2', $x0, $y2})
          + exists($cells->{pack 'i2', $x2, $y1})
          + exists($cells->{pack 'i2', $x2, $y0})
          + exists($cells->{pack 'i2', $x2, $y2}) == 3 ) } @zcells
   } keys %{$cells} } = undef;
   $self->{Cells} = \%newcells;
}

        [download]
        I'm guessing they are slower because the list of cells used in the hash slice contains many duplicate dead cells.

        Update: Changing: 

        my @zcells = (
   ($k1 = pack 'i2', $x1, $y1) x !exists($cells->{$k1}),
   ($k2 = pack 'i2', $x1, $y0) x !exists($cells->{$k2}),
   ($k3 = pack 'i2', $x1, $y2) x !exists($cells->{$k3}),
   ($k4 = pack 'i2', $x0, $y1) x !exists($cells->{$k4}),
   ($k5 = pack 'i2', $x0, $y2) x !exists($cells->{$k5}),
   ($k6 = pack 'i2', $x2, $y1) x !exists($cells->{$k6}),
   ($k7 = pack 'i2', $x2, $y0) x !exists($cells->{$k7}),
   ($k8 = pack 'i2', $x2, $y2) x !exists($cells->{$k8})  );

        [download]
        to: 
        my @zcells = grep( !exists($cells->{$_}),
   pack('i2', $x1, $y1),
   pack('i2', $x1, $y0),
   pack('i2', $x1, $y2),
   pack('i2', $x0, $y1),
   pack('i2', $x0, $y2),
   pack('i2', $x2, $y1),
   pack('i2', $x2, $y0),
   pack('i2', $x2, $y2) );

        [download]
        was slightly slower.

        This one was also slower: 

        sub tick {
   my $self  = shift;
   my $cells = $self->{Cells};
   my ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8,
        $x0, $x1, $x2, $y0, $y1, $y2, $z, %newcells );

   for my $c (keys %{ $cells }) {
      # Get the (up to 8) dead cells surrounding the cell
      ( $x0, $y0 ) = unpack 'i2', $c;
      ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 );
      my @zcells = (
         ($x1, $y1, $k1 = pack 'i2', $x1, $y1) x !exists($cells->{$k1}
+),
         ($x1, $y0, $k2 = pack 'i2', $x1, $y0) x !exists($cells->{$k2}
+),
         ($x1, $y2, $k3 = pack 'i2', $x1, $y2) x !exists($cells->{$k3}
+),
         ($x0, $y1, $k4 = pack 'i2', $x0, $y1) x !exists($cells->{$k4}
+),
         ($x0, $y2, $k5 = pack 'i2', $x0, $y2) x !exists($cells->{$k5}
+),
         ($x2, $y1, $k6 = pack 'i2', $x2, $y1) x !exists($cells->{$k6}
+),
         ($x2, $y0, $k7 = pack 'i2', $x2, $y0) x !exists($cells->{$k7}
+),
         ($x2, $y2, $k8 = pack 'i2', $x2, $y2) x !exists($cells->{$k8}
+)  );

      # Check the live cell (next line equivalent to nlive==2 || nlive
+==3)
      @zcells == 15 || @zcells == 18 and $newcells{$c} = undef;

      # Check the dead cells
      while (@zcells) {
         ( $x0, $y0, $z ) = splice @zcells, 0, 3;
         ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1
+ );
           exists($cells->{pack 'i2', $x1, $y1})
         + exists($cells->{pack 'i2', $x1, $y0})
         + exists($cells->{pack 'i2', $x1, $y2})
         + exists($cells->{pack 'i2', $x0, $y1})
         + exists($cells->{pack 'i2', $x0, $y2})
         + exists($cells->{pack 'i2', $x2, $y1})
         + exists($cells->{pack 'i2', $x2, $y0})
         + exists($cells->{pack 'i2', $x2, $y2}) == 3 and $newcells{$z
+} = undef;
      }
   }
   $self->{Cells} = \%newcells;
}

        [download]

[reply]
[d/l]
[select]

In Section Meditations

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: note [id://1197302]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (5)
As of 2022-05-23 14:57 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Do you prefer to work remotely?



    Results (82 votes). Check out past polls.
    Notices?