File Coverage

blib/lib/Game/Life/Faster.pm

Criterion	Covered	Total	%
statement	208	213	97.6
branch	58	72	80.5
condition	30	53	56.6
subroutine	36	37	97.3
pod	22	22	100.0
total	354	397	89.1

package Game::Life::Faster;

use 5.008001;

use strict;
use warnings;

use Carp;
use List::Util qw{ max min };

our $VERSION = '0.006';

use constant ARRAY_REF	=> ref [];

use constant DEFAULT_BREED	=> [ 3 ];
use constant DEFAULT_LIVE	=> [ 2, 3 ];
use constant DEFAULT_SIZE	=> 100;

use constant NEW_LINE_RE		=> qr< \n >smx;
use constant NON_NEGATIVE_INTEGER_RE	=> qr< \A [0-9]+ \z >smx;
use constant POSITIVE_INTEGER_RE	=> qr< \A [1-9][0-9]* \z >smx;

use constant TOGGLE_STATE	=> do { bless \my $x, 'Toggle_State' };
use constant TOGGLE_STATE_REF	=> ref TOGGLE_STATE;

sub new {
    my ( $class, $size, $breed, $live ) = @_;

    my $self;

    my $ref = ref $size;
    if ( ARRAY_REF eq $ref ) {
	$self->{size_x} = $size->[1];
	$self->{size_y} = $size->[0];
    } elsif ( ! $ref ) {
	$self->{size_x} = $self->{size_y} = $size;
    } else {
	croak "Argument may not be $size";
    }
    $self->{size_x} ||= DEFAULT_SIZE;
    $self->{size_y} ||= DEFAULT_SIZE;
    $self->{size_x} =~ POSITIVE_INTEGER_RE
	and $self->{size_y} =~ POSITIVE_INTEGER_RE
	or croak 'Sizes must be positive integers';
    $self->{max_x} = $self->{size_x} - 1;
    $self->{max_y} = $self->{size_y} - 1;

    bless $self, ref $class || $class;
    $self->set_rules( $breed, $live );

    $self->clear();

    return $self;
}

sub clear {
    my ( $self ) = @_;
    delete $self->{grid};
    delete $self->{changed};
    $self->{living_x} = [];
    $self->{living_y} = [];
    $self->{change_count} = 0;
    return $self;
}

sub get_active_grid_coord {
    my ( $self ) = @_;
    my ( $min_x, $max_x, $min_y, $max_y ) = ( $self->{size_x}, 0,
	$self->{size_y}, 0 );
    foreach my $ix ( keys %{ $self->{changed} } ) {
	$min_x = $ix if $ix < $min_x;
	$max_x = $ix if $ix > $max_x;
	foreach my $iy ( keys %{ $self->{changed}{$ix} } ) {
	    $min_y = $iy if $iy < $min_y;
	    $max_y = $iy if $iy > $max_y;
	}
    }
    $max_x < $min_x
	and croak 'No active cells';
    return [ $min_x, $max_x, $min_y, $max_y ];
}

sub get_breeding_rules {
    my ( $self ) = @_;
    return $self->get_rule( 'breed' );
}

sub get_grid {
    my ( $self, $coord ) = @_;
    $coord ||= $self->get_grid_coord();
    $self->{grid}
	or return [ ( [ ( 0 ) x ( $coord->[3] - $coord->[2] + 1 ) ] ) x
	    ( $coord->[1] - $coord->[0] + 1 ) ];
    my @rslt;
    foreach my $x ( $coord->[0] .. $coord->[1] ) {
	if ( $self->{grid}{$x} ) {
	    push @rslt, [];
	    foreach my $y ( $coord->[2] .. $coord->[3] ) {
		push @{ $rslt[-1] }, $self->{grid}{$x}{$y} ?
		    $self->{grid}{$x}{$y}[0] ? 1 : 0 : 0;
	    }
	} else {
	    push @rslt, [ ( 0 ) x ( $coord->[3] - $coord->[2] + 1 ) ];
	}
    }
    return \@rslt;
}

sub get_grid_coord {
    my ( $self ) = @_;
    return [ 0, $self->{max_x}, 0, $self->{max_y} ];
}

sub get_living_rules {
    my ( $self ) = @_;
    return $self->get_rule( 'live' );
}

sub get_text_grid {
    my ( $self, $living, $dead, $coord ) = @_;
    $living	||= 'X';
    $dead	||= '.';
    $coord ||= $self->get_grid_coord();
    my @rslt;
    if ( $self->{grid} ) {
	foreach my $x ( $coord->[0] .. $coord->[1] ) {
	    if ( $self->{grid}{$x} ) {
		push @rslt, join '', map {
		    ( $self->{grid}{$x}{$_} && $self->{grid}{$x}{$_}[0]) ?
		    $living : $dead
		} $coord->[2] .. $coord->[3];
	    } else {
		push @rslt, $dead x ( $coord->[3] - $coord->[2] + 1 );
	    }
	}
    } else {
	@rslt = ( $dead x ( $coord->[3] - $coord->[2] + 1 ) ) x (
	    $coord->[1] - $coord->[0] + 1 );
    }
    return wantarray ? @rslt : join '', map { "$_\n" } @rslt;
}

sub get_active_text_grid {
    my ( $self, $living, $dead ) = @_;
    return $self->get_text_grid( $living, $dead,
	$self->get_active_grid_coord() );
}

sub get_used_text_grid {
    my ( $self, $living, $dead ) = @_;
    return $self->get_text_grid( $living, $dead,
	$self->get_used_grid_coord() );
}

sub get_used_grid {
    my ( $self ) = @_;
    return $self->get_grid( $self->get_used_grid_coord() );
}

sub get_used_grid_coord {
    my ( $self ) = @_;
    my $min_x = $self->{size_x};
    for ( $min_x = 0; $min_x < $self->{size_x}; $min_x++ ) {
	$self->{living_x}[$min_x]
	    or next;
	my ( $max_x, $min_y, $max_y );
	for ( $max_x = $self->{size_x}; $max_x >= $min_x; ) {
	    $self->{living_x}[--$max_x]
		and last;
	}
	for ( $min_y = 0; $min_y < $self->{size_y}; $min_y++ ) {
	    $self->{living_y}[$min_y]
		and last;
	}
	for ( $max_y = $self->{size_y}; $max_y >= $min_y; ) {
	    $self->{living_y}[--$max_y]
		and last;
	}
	return [ $min_x, $max_x, $min_y, $max_y ];
    }
    croak 'No occupied cells';
}

sub place_points {
    my ( $self, $x, $y, $array ) = @_;
    my $ix = $x;
    foreach my $row ( @{ $array } ) {
	my $iy = $y;
	foreach my $state ( @{ $row } ) {
	    $self->set_point_state( $ix, $iy, $state );
	    $iy++;
	}
	$ix++;
    }
    return;
}

sub place_text_points {
    my ( $self, $x, $y, $living, @array ) = @_;
    my $ix = $x;
    1 == @array
	and $array[0] =~ NEW_LINE_RE
	and @array = split qr< @{[ NEW_LINE_RE ]} >smx, $array[0];
    foreach my $line ( @array ) {
	my $iy = $y;
	foreach my $state ( map { $living eq $_ } split qr<>, $line ) {
	    $self->set_point_state( $ix, $iy, $state );
	    $iy++;
	}
	$ix++;
    }
    return;
}

sub process {
    my ( $self, $steps ) = @_;
    $steps ||= 1;

    foreach ( 1 .. $steps ) {

	my $changed = delete $self->{changed};
	$self->{change_count} = 0;

	foreach my $x ( keys %{ $changed } ) {
	    foreach my $y ( keys %{ $changed->{$x} } ) {
		my $cell = $self->{grid}{$x}{$y};
		no warnings qw{ uninitialized };
		if ( $cell->[0] ) {
		    $self->{live}[ $changed->{$x}{$y} ]
			or $self->unset_point( $x, $y );
		} else {
		    $self->{breed}[ $changed->{$x}{$y} ]
			and $self->set_point( $x, $y );
		}
	    }
	}

	$self->{change_count}
	    or last;
    }
    return $self->{change_count};
}

sub set_point {
    my ( $self, $x, $y ) = @_;
    return $self->set_point_state( $x, $y, 1 );
}

sub set_point_state {
    my ( $self, $x, $y, $state ) = @_;

    defined $x
	and defined $y
	and $x =~ NON_NEGATIVE_INTEGER_RE
	and $y =~ NON_NEGATIVE_INTEGER_RE
	or croak 'Coordinates must be non-negative integers';
    defined $state
	or return $state;

    if ( $x >= 0 && $x < $self->{size_x} &&
	$y >= 0 && $y < $self->{size_y}
    ) {
	# We're on-grid.

	# This autovivifies, but we're going to assign it anyway, so ...
	my $prev_state = $self->{grid}{$x}{$y}[0] || 0;
	$state = TOGGLE_STATE_REF eq ref $state ? 1 - $prev_state :
	    $state ? 1 : 0;

	$self->{grid}{$x}{$y}[0] = $state;
	$self->{grid}{$x}{$y}[1] ||= 0;
	my $delta = $state - $prev_state
	    or return $state;
	$self->{living_x}[$x] += $delta;
	$self->{living_y}[$y] += $delta;

	$self->{change_count}++;

	foreach my $ix ( max( 0, $x - 1 ) .. min( $self->{max_x}, $x + 1 ) ) {
	    foreach my $iy ( max( 0, $y - 1 ) .. min( $self->{max_y}, $y + 1 )
	    ) {
		$self->{changed}{$ix}{$iy} =
		    $self->{grid}{$ix}{$iy}[1] += $delta;
	    }
	}

	# A cell is not its own neighbor, but the above nested loops
	# assumed that it was. We fix that here, rather than skip it
	# inside the loops.
	$self->{changed}{$x}{$y} =
	    $self->{grid}{$x}{$y}[1] -= $delta;

    } elsif ( $state ) {
	croak 'Attempt to place living cell outside grid';
    }

    return $state;
}

{
    my %dflt = (
	breed	=> DEFAULT_BREED,
	live	=> DEFAULT_LIVE,
    );

    sub get_rule {
	my ( $self, $kind ) = @_;
	$dflt{$kind}
	    or croak "'$kind' is not a valid rule kind";
	return( grep { $self->{$kind}[$_] } 0 .. $#{ $self->{$kind} } );
    }

    sub set_rule {
	my ( $self, $kind, $rule ) = @_;
	$dflt{$kind}
	    or croak "'$kind' is not a valid rule name";
	$rule ||= $dflt{$kind};
	ARRAY_REF eq ref $rule
	    or croak "\u$kind rule must be an array reference";
	$self->{$kind} = [];
	foreach ( @{ $rule } ) {
	    $_ =~ NON_NEGATIVE_INTEGER_RE
		or croak "\u$kind rule must be a reference to an array of non-negative integers";
	    $self->{$kind}[$_] = 1;
	}
	return;
    }
}

sub set_rules {
    my ( $self, $breed, $live ) = @_;
    $self->set_rule( breed => $breed );
    $self->set_rule( live => $live );
    return;
}

sub toggle_point {
    my ( $self, $x, $y ) = @_;
    return $self->set_point_state( $x, $y, TOGGLE_STATE );
}

sub unset_point {
    my ( $self, $x, $y ) = @_;
    return $self->set_point_state( $x, $y, 0 );
}

1;

__END__