Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Re^7: High Performance Game of Life

by tybalt89 (Monsignor)
on Aug 13, 2017 at 16:50 UTC ( [id://1197335]=note: print w/replies, xml ) Need Help??


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

Try this. Notably faster on my machine that is horribly slower than yours.

package Organism; use strict; # use warnings; 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} }; } sub tick { my $self = shift; my $cells = $self->{Cells}; my ( $k1, $k2, $k3, $k4, $k5, $k6, $k7, $k8, $x0, $x1, $x2, $y0, $y1, $y2, %new_cells, %dead_cells ); 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 ); $dead_cells{$_}++ for 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 # Note: next line equivalent to nlive == 2 || nlive == 3 @zcells == 5 || @zcells == 6 and $new_cells{$c} = undef; } $dead_cells{$_} == 3 and $new_cells{$_} = undef for keys %dead_cell +s; $self->{Cells} = \%new_cells; } sub new { my $class = shift; my %init_self = ( Cells => {} ); bless \%init_self, $class; } 1;

Replies are listed 'Best First'.
Re^8: High Performance Game of Life
by marioroy (Prior) on Aug 13, 2017 at 18:11 UTC

    Hi tybalt89. The optimization is awesome.

    Update 1: Bit-manipulation will not work when $y is negative. See this post. I assumed that $y was always positive from testing using the initial test script.

    Update 2: See this post for a version that maps two integers into one integer successfully.

    I tried bit-manipulation by mapping $x and $y into $n. 16-bits is enough to hold $y.

    package Organism; use strict; # use warnings; sub _pack { my ( $x, $y ) = @_; $x < 0 ? -(abs($x) << 16 | $y) : $x << 16 | $y; } sub _unpack { my ( $n ) = @_; return $n < 0 ? ( -( abs($n) >> 16 ), abs($n) & 0xFFFF ) : ( $n >> 16 , $n & 0xFFFF ); } 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 @{$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 $_ ] } 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, %new_cells, %dead_cells ); for my $c (keys %{ $cells }) { # Get the (up to 8) dead cells surrounding the cell ( $x0, $y0 ) = $c < 0 ? ( -( abs($c) >> 16 ), abs($c) & 0xFFFF ) : ( $c >> 16 , $c & 0xFFFF ); ( $x1, $x2, $y1, $y2 ) = ( $x0 - 1, $x0 + 1, $y0 - 1, $y0 + 1 ); $dead_cells{$_}++ for my @zcells = ( ($k1 = $x1 < 0 ? -(abs($x1) << 16 | $y1) : $x1 << 16 | $y1) x + !(exists $cells->{$k1}), ($k2 = $x1 < 0 ? -(abs($x1) << 16 | $y0) : $x1 << 16 | $y0) x + !(exists $cells->{$k2}), ($k3 = $x1 < 0 ? -(abs($x1) << 16 | $y2) : $x1 << 16 | $y2) x + !(exists $cells->{$k3}), ($k4 = $x0 < 0 ? -(abs($x0) << 16 | $y1) : $x0 << 16 | $y1) x + !(exists $cells->{$k4}), ($k5 = $x0 < 0 ? -(abs($x0) << 16 | $y2) : $x0 << 16 | $y2) x + !(exists $cells->{$k5}), ($k6 = $x2 < 0 ? -(abs($x2) << 16 | $y1) : $x2 << 16 | $y1) x + !(exists $cells->{$k6}), ($k7 = $x2 < 0 ? -(abs($x2) << 16 | $y0) : $x2 << 16 | $y0) x + !(exists $cells->{$k7}), ($k8 = $x2 < 0 ? -(abs($x2) << 16 | $y2) : $x2 << 16 | $y2) x + !(exists $cells->{$k8}) ); # Check the live cell # Note: next line equivalent to nlive == 2 || nlive == 3 @zcells == 5 || @zcells == 6 and $new_cells{$c} = undef; } $dead_cells{$_} == 3 and $new_cells{$_} = undef for keys %dead_cell +s; $self->{Cells} = \%new_cells; } sub new { my $class = shift; my %init_self = ( Cells => {} ); bless \%init_self, $class; } 1;

    Regards, Mario

      You need to run the following little test to catch any errors with negative x and y values before firing off any benchmarks:

      # tgol.t - Simple blinker test of Conway Game of Life Organism class use strict; use warnings; use Organism; use Test::More; my $nblinks = 5; my $ntests = ( $nblinks + 1 ) * 3; plan tests => $ntests; sub test_one { my $org = shift; # Organism handle my $desc = shift; # Test description my $expected = shift; # Array ref of (sorted) expected cells my $nexpected = @{$expected}; my $ncells = $org->count(); my @cells = $org->get_live_cells(); cmp_ok( $ncells, '==', $nexpected, "$desc cell count ($ncells)" ); cmp_ok( scalar(@cells), '==', $nexpected, "$desc cell array count" +); is_deeply( \@cells, $expected, "$desc cell array" ); } # Blinker pattern my @blinker1 = ( [ -101, -100 ], [ -100, -100 ], [ -99, -100 ], [ -101, 100 ], [ -100, 100 ], [ -99, 100 ], [ -1, 0 ], [ 0, 0 ], [ 1, 0 ], [ 99, -100 ], [ 100, -100 ], [ 101, -100 ], [ 99, 100 ], [ 100, 100 ], [ 101, 100 ], ); my @blinker2 = ( [ -100, -99 ], [ -100, -100 ], [ -100, -101 ], [ -100, 99 ], [ -100, 100 ], [ -100, 101 ], [ 0, -1 ], [ 0, 0 ], [ 0, 1 ], [ 100, -99 ], [ 100, -100 ], [ 100, -101 ], [ 100, 99 ], [ 100, 100 ], [ 100, 101 ], ); my @sblinker1 = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @b +linker1; my @sblinker2 = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @b +linker2; # Initialization my $org = Organism->new(); $org->insert_cells(@blinker1); test_one( $org, "initial", \@sblinker1 ); # Pattern should just blink back and forth for my $i ( 1 .. $nblinks ) { $org->tick(); test_one( $org, "blinker $i", $i % 2 ? \@sblinker2 : \@sblinker1 ); }
      with the command line:
      prove tgol.t
      Unfortunately, your latest effort fails this test on my machine as shown below:
      # Failed test 'initial cell count (11)' # at tgol.t line 17. # got: 11 # expected: 15 # Failed test 'initial cell array count' # at tgol.t line 18. # got: 11 # expected: 15 # Failed test 'initial cell array' # at tgol.t line 19. # Structures begin differing at: # $got->[0][0] = '-281474976710655' # $expected->[0][0] = '-101' # Failed test 'blinker 1 cell count (10)' # at tgol.t line 17. # got: 10 # expected: 15 # Failed test 'blinker 1 cell array count' # at tgol.t line 18. # got: 10 # expected: 15 # Failed test 'blinker 1 cell array' # at tgol.t line 19. # Structures begin differing at: # $got->[0][0] = '-281474976710655' # $expected->[0][0] = '-100' # Failed test 'blinker 2 cell count (11)' # at tgol.t line 17. # got: 11 # expected: 15 # Failed test 'blinker 2 cell array count' # at tgol.t line 18. # got: 11 # expected: 15 # Failed test 'blinker 2 cell array' # at tgol.t line 19. # Structures begin differing at: # $got->[0][0] = '-281474976710655' # $expected->[0][0] = '-101' # Failed test 'blinker 3 cell count (9)' # at tgol.t line 17. # got: 9 # expected: 15 # Failed test 'blinker 3 cell array count' # at tgol.t line 18. # got: 9 # expected: 15 # Failed test 'blinker 3 cell array' # at tgol.t line 19. # Structures begin differing at: # $got->[0][1] = '99' # $expected->[0][1] = '-101' # Failed test 'blinker 4 cell count (9)' # at tgol.t line 17. # got: 9 # expected: 15 # Failed test 'blinker 4 cell array count' # at tgol.t line 18. # got: 9 # expected: 15 # Failed test 'blinker 4 cell array' # at tgol.t line 19. # Structures begin differing at: # $got->[0][1] = '100' # $expected->[0][1] = '-100' # Failed test 'blinker 5 cell count (8)' # at tgol.t line 17. # got: 8 # expected: 15 # Failed test 'blinker 5 cell array count' # at tgol.t line 18. # got: 8 # expected: 15 # Failed test 'blinker 5 cell array' # at tgol.t line 19. # Structures begin differing at: # $got->[0][1] = '99' # $expected->[0][1] = '-101' # Looks like you failed 18 tests of 18.

      I left this tgol.t test program out of the root node because it was already way too long ... then forgot about it. Sorry 'bout that. Update: I've now remedied my oversight by adding the tgol.t test program above to the root node.

        Hi eyepopslikeamosquito. Yes, I've been running tgol2.t found here and it's been running fine. I can comfirm that bit-manipulation is failing with the new tgot2.t. The initial test script did not test for negative $y. Thus, assumed that $y was always positive. The bit-manipulation code will no longer work.

        Okay, will comment readers to your post and strike out the bit-manipulation sections. Thank you for posting Extra Test Program tgol.t.

        Update: For closure, I tested mapping supporting negative $x and $y. Pack('i2') is faster unless running cperl.

        use strict; use warnings; use Time::HiRes qw(time); my ( $x , $y , $iters ) = ( -890394, 100, 5_000_000 ); my ( $xx, $yy, $n ); ## # sub _pack { # my ( $x, $y ) = @_; # return # $x < 0 ? -( abs($x) << 16 | $y ) : $x << 16 | $y; # } # # sub _unpack { # my ( $n ) = @_; # return $n < 0 # ? ( -( abs($n) >> 16 ), abs($n) & 0xFFFF ) # : ( $n >> 16 , $n & 0xFFFF ); # } ## bench( "bitops ", sub { # map two integers $x and $y into $n # support negative $x only for ( 1 .. $iters ) { $n = $x < 0 ? -( abs($x) << 16 | $y ) : $x << 16 | $y; ( $xx, $yy ) = $n < 0 ? ( -( abs($n) >> 16 ), abs($n) & 0xFFFF ) : ( $n >> 16 , $n & 0xFFFF ); } }); ## # sub _pack { # my ( $x, $y ) = @_; # # bits 0,1 indicate neg flag for $x,$y respectively # return # ( abs($x) << 18 ) + ( $x < 0 ? 1 : 0 ) + # ( abs($y) << 2 ) + ( $y < 0 ? 2 : 0 ); # } # # sub _unpack { # my ( $n ) = @_; # # bits 0,1 indicate neg flag for $x,$y respectively # return ( # $n & 0x1 ? -($n >> 18 ) : $n >> 18, # $n & 0x2 ? -($n >> 2 & 0xFFFF) : $n >> 2 & 0xFFFF # ); # } ## bench( "bitops neg ", sub { # map two integers $x and $y into $n # support negative $x and $y for ( 1 .. $iters ) { $n = ( abs($x) << 18 ) + ( $x < 0 ? 1 : 0 ) + ( abs($y) << 2 ) + ( $y < 0 ? 2 : 0 ); ( $xx, $yy ) = ( $n & 0x1 ? -($n >> 18 ) : $n >> 18, $n & 0x2 ? -($n >> 2 & 0xFFFF) : $n >> 2 & 0xFFFF ); } }); bench( "(un)pack ii", sub { for ( 1 .. $iters ) { $n = pack 'ii', $x, $y; ( $xx, $yy ) = unpack 'ii', $n; } }); bench( "(un)pack i2", sub { for ( 1 .. $iters ) { $n = pack 'i2', $x, $y; ( $xx, $yy ) = unpack 'i2', $n; } }); exit; sub bench { my ( $start, $desc, $fcn ) = ( scalar time, @_ ); $fcn->(); printf "duration $desc %0.03f\n", time - $start; }

        Regards, Mario

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://1197335]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others rifling through the Monastery: (4)
As of 2025-06-23 18:10 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?
    erzuuliAnonymous Monks are no longer allowed to use Super Search, due to an excessive use of this resource by robots.