File Coverage

blib/lib/Game/Life.pm

Criterion	Covered	Total	%
statement	81	105	77.1
branch	14	20	70.0
condition	28	64	43.7
subroutine	13	20	65.0
pod	12	12	100.0
total	148	221	66.9

#!/usr/bin/perl -w

package Game::Life;

#=============================================================================
#
# $Id: Life.pm,v 0.06 2013/05/16 08:55:32 ltp Exp $
# $Revision: 0.06 $
# $Author: ltp $
# $Date: 2013/05/16 08:55:32 $
# $Log: Life.pm,v $
#
# Revision 0.06  2013/05/16 08:55:32  ltp
#
# Improved test coverage.
#
# Revision 0.05  2013/05/15 21:18:29  ltp
#
# Modified constructor to allow arbitrary sized game board.
#
# Revision 0.04  2001/07/04 02:49:29  mneylon
#
# Fixed distribution problem
#
# Revision 0.03  2001/07/04 02:27:55  mneylon
#
# Updated README for distribution
#
# Revision 0.02  2001/07/04 02:23:13  mneylon
#
# Added test cases
# Added set_text_points, get_text_grid
# Added set_rules, get_breeding_rules, get_living_rules, and set default
#       values for these as Conway's rules
# Modifications from code as posted on Perlmonks.org
#
#
#=============================================================================

use strict;
use Exporter;
use Clone qw( clone );

BEGIN {
    use Exporter   ();
    use vars       qw($VERSION @ISA @EXPORT %EXPORT_TAGS);
    $VERSION     = sprintf( "%d.%02d", q($Revision: 0.06 $) =~ /\s(\d+)\.(\d+)/ );
    @ISA         = qw(Exporter);
    @EXPORT      = qw();
    %EXPORT_TAGS = ( );
}


my $default_size = 100;

sub new {
    my $class = shift;
    my $self = {} ;

    # No args, set up a blank one
    $self->{ size } = shift || $default_size;
    if ( ref( $self->{ size } ) ) {
      ( $self->{ size_y }, $self->{ size_x } ) = @{ $self->{ size } };
    }
    else {
      $self->{ size_y } = $self->{ size_x } = $self->{ size }
    }

    $self->{ grid } = [ map
			{ [ map { 0 } (1..$self->{ size_y } ) ] }
			(1..$self->{ size_x } ) ];

    bless $self, $class;

    my ( $breedlife, $keeplife ) = @_;
    # Default values for Conway's game
    $breedlife ||= [ 3 ];
    $keeplife  ||= [ 2,3 ];

    $self->set_rules( $breedlife, $keeplife );

    return $self;
}

sub set_rules {
    my $self = shift;
    my ( $breedlife, $keeplife ) = @_;

    die "Life rules must be arrayrefs if used"
	unless ( defined ( $breedlife ) && ref( $breedlife ) eq "ARRAY" &&
		 defined ( $keeplife  ) && ref( $keeplife ) eq "ARRAY" );

    # Force a duplication so we don't rely on the passed version
    my @temp1 = @$breedlife;
    my @temp2 = @$keeplife;

    $self->{ breed_criteria } = \@temp1;
    $self->{ keep_criteria } = \@temp2;
}

sub get_breeding_rules {
    my $self = shift;
    return @{ $self->{ breed_criteria } };
}

sub get_living_rules {
    my $self = shift;
    return @{ $self->{ keep_criteria } };
}

sub toggle_point {
    my ( $self, $x, $y ) = @_;
    return ( $self->{ grid }->[$x]->[$y] = !$self->{ grid }->[$x]->[$y] );
}

sub set_point {
    my ( $self, $x, $y ) = @_;
    $self->{ grid }->[$x]->[$y] = 1;
}

sub unset_point {
    my ( $self, $x, $y ) = @_;
    $self->{ grid }->[$x]->[$y] = 0;
}

sub place_points {
    my ( $self, $x, $y, $array ) = @_;
    return if ( $x < 0 || $x >= $self->{ size_x } ||
		$y < 0 || $y >= $self->{ size_y } );
    my ($i, $j);
    my $array_x = @$array;
    my $array_y = @{$$array[0]};
    for ( $i = 0 ; $i < $array_x && $i+$x < $self->{ size_x }; $i++ ) {
	for ( $j = 0 ; $j < $array_y && $j+$y < $self->{ size_y }; $j++ ) {
	    $self->{ grid }->[ $x + $i ]->[ $y + $j ] =
		($array->[ $i ]->[ $j ] > 0) ? 1 : 0;
	}
    }
    return 1;
}

sub place_text_points {
    my ( $self, $x, $y, $living, @array ) = @_;
    return if ( $x < 0 || $x >= $self->{ size_x } ||
		$y < 0 || $y >= $self->{ size_y } );
    my ($i, $j);
    my $array_x = @array;
    my $array_y = length $array[0];
    for ( $i = 0 ; $i < $array_x && $i+$x < $self->{ size_x }; $i++ ) {
	for ( $j = 0 ; $j < $array_y && $j+$y < $self->{ size_y }; $j++ ) {
	    $self->{ grid }->[ $x + $i ]->[ $y + $j ] =
		(substr($array[ $i ], $j, 1 ) eq $living) ? 1 : 0;
	}
    }
    return 1;
}


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

sub get_text_grid {
    my ( $self, $filled, $empty ) = @_;
    $filled ||= 'X';
    $empty ||= '.';

    my @array;
    for	my $i ( 0..$self->{ size_x }-1 ) {
	my $string = '';
	for my $j ( 0..$self->{ size_y }-1 ) {
	    $string .= $self->{ grid }->[ $i ]->[ $j ] ? $filled : $empty;
	}
	push @array, $string;
    }
    return @array;
}

sub process {
    my $self = shift;
    my $times = shift || 1;

    for (1..$times) {
	my $new_grid = clone( $self->{ grid } );
	use Data::Dumper;

	for my $i ( 0..$self->{ size_x }-1 ) {
	    for	my $j ( 0..$self->{ size_y }-1 ) {
		$new_grid->[$i]->[$j] =
		    $self->_determine_life_status( $i, $j );
	    }
	}
	$self->{ grid } = $new_grid;
    }
}

sub _determine_life_status {
    my ( $self, $x , $y ) = @_;
    my $n = 0;
    for my $i ( $x-1, $x, $x+1 ) {
	for my $j ( $y-1, $y, $y+1 ) {
	    $n++ if ( $i >= 0 && $i < $self->{ size_x } &&
		      $j >= 0 && $j < $self->{ size_y } ) &&
			  ( $self->{ grid }->[ $i ]->[ $j ] );
	}
    }
    # here's the deterministic part; force return of 0 or 1.
    $n-- if $self->{ grid }->[ $x ]->[ $y ];
    return ( 0 != grep { $_ == $n } @{ $self->{
	$self->{ grid }->[ $x ]->[ $y ]
	    ? 'keep_criteria' : 'breed_criteria' } } );
}

42;

__END__