File Coverage

blib/lib/Tk/Taxis.pm

Criterion	Covered	Total	%
statement	43	49	87.7
branch			n/a
condition			n/a
subroutine	15	15	100.0
pod			n/a
total	58	64	90.6

package Tk::Taxis;

use 5.008006;
use strict;
use warnings::register( 'Tk::Taxis' );

our $VERSION = '2.03';

################################## defaults ####################################

use constant WIDTH       => 400;
use constant HEIGHT      => 400;
use constant POPULATION  => 20;
use constant PREFERENCE  => [ 100, 100 ];
use constant TUMBLE      => 0.03;
use constant SPEED       => 0.006;
use constant IMAGES      => "woodlice";
use constant FILL        => [ [ 'white', 'gray' ],
                              [ 'white', 'gray' ] ];
use constant LEFT_FILL  => "white"; # deprecated
use constant RIGHT_FILL => "gray";  # deprecated
use constant CALCULATION =>
							sub
							{
								my ( $critter ) = @_;
								my %boundries   = $critter->get_boundries();
								my ( $x, $y )   = $critter->get_pos();
								return
									$x / $boundries{ width  },
									$y / $boundries{ height };
							};

################################### widget #####################################

use Tk qw( DoOneEvent DONT_WAIT );
use Tk::Taxis::Critter;

require Tk::Frame;
our @ISA = ( 'Tk::Frame' );

Tk::Widget->Construct( 'Taxis' );

sub Populate
{
	my ( $taxis, $options ) = @_;
	my $canvas = $taxis->Canvas();
	$taxis->Advertise( 'canvas' => $canvas );
	$canvas->pack();

	$taxis->{ _supress_redraw } = 1; # so no multiple redraws on initialisation
	$taxis->images(      delete $options->{ -images }       || IMAGES );
	$taxis->preference(  delete $options->{ -preference }   || PREFERENCE );
	$taxis->tumble(      delete $options->{ -tumble }       || TUMBLE );
	$taxis->speed(       delete $options->{ -speed }        || SPEED );
	$taxis->width(       delete $options->{ -width }        || WIDTH );
	$taxis->height(      delete $options->{ -height }       || HEIGHT );
	$taxis->population(  delete $options->{ -population }   || POPULATION );
	$taxis->fill(        delete $options->{ -fill }         || FILL );
	$taxis->calculation( delete $options->{ -calculation }  || CALCULATION );

	# deprecated options
	if ( $options->{ -left_fill } )
	{
		$taxis->left_fill(   delete $options->{ -left_fill }    || LEFT_FILL );
	}
	if ( $options->{ -right_fill } )
	{
		$taxis->right_fill(  delete $options->{ -right_fill }   || RIGHT_FILL );
	}

	$taxis->{ _supress_redraw } = 0;
	$taxis->refresh();

	$taxis->ConfigSpecs
	(
		-images      => [ 'METHOD', 'images',      'Images',      undef ],
		-preference  => [ 'METHOD', 'preference',  'Preference',  undef ],
		-tumble      => [ 'METHOD', 'tumble',      'Tumble',      undef ],
		-speed       => [ 'METHOD', 'speed',       'Speed',       undef ],
		-width       => [ 'METHOD', 'width',       'Width',       undef ],
		-height      => [ 'METHOD', 'height',      'Height',      undef ],
		-population  => [ 'METHOD', 'population',  'Population',  undef ],
		-fill        => [ 'METHOD', 'fill',        'Fill',        undef ],
		-calculation => [ 'METHOD', 'calculation', 'Calculation', undef ],
		DEFAULT      => [ $canvas ],
	);
	$taxis->SUPER::Populate( $options );
	$taxis->Delegates( DEFAULT => $canvas );
}

################################### images #####################################

sub images
{
	my ( $taxis, $images ) = @_;
	if ( $images )
	{
		$taxis->{ images } = $images;
		unless ( $taxis->{ image_bank }{ $images } )
		{
			$taxis->{ image_bank }{ $images } =
			{
				n  => $taxis->Photo( -file => $taxis->_find_image( "n.gif"  ) ),
				ne => $taxis->Photo( -file => $taxis->_find_image( "ne.gif" ) ),
				e  => $taxis->Photo( -file => $taxis->_find_image( "e.gif"  ) ),
				se => $taxis->Photo( -file => $taxis->_find_image( "se.gif" ) ),
				s  => $taxis->Photo( -file => $taxis->_find_image( "s.gif"  ) ),
				sw => $taxis->Photo( -file => $taxis->_find_image( "sw.gif" ) ),
				w  => $taxis->Photo( -file => $taxis->_find_image( "w.gif"  ) ),
				nw => $taxis->Photo( -file => $taxis->_find_image( "nw.gif" ) ),
				0  => $taxis->Photo(),
			};
		}
		$taxis->image_height
		(
			$taxis->{ image_bank }{ $images }{ n }->height() || 50
		);
		$taxis->image_width
		(
			$taxis->{ image_bank }{ $images }{ n }->width()  || 50
		);
		$taxis->refresh();
	}
	return $taxis->{ images };
}

sub _find_image
{
	my ( $taxis, $file ) = @_;
	my $dir = $taxis->{ images };
	my $found;
	if ( my ( $path ) = $dir =~ /^\@(.*)$/ )
	{
		$found = ( grep { -e $_ } "$path/$file" )[ 0 ];
		warnings::warn( "No such file $path/$file" ) unless $found;
	}
	else
	{
		$found =
		   ( grep { -f $_ } map { "$_/Tk/Taxis/images/$dir/$file" } @INC )[ 0 ];
		warnings::warn( "No such file \@INC/Tk/Taxis/images/$dir/$file" )
			unless $found;
	}
	return $found;
}

sub _create_critter_image
{
	my ( $taxis, $critter ) = @_;
	my $canvas = $taxis->Subwidget( 'canvas' );
	my @pos    = $critter->get_pos();
	my $id     = $critter->get_id();
	my $image  =
		$taxis->{ image_bank }{ $taxis->{ images } }{ $critter->get_orient() };
	if ( defined $id )
	{
		$canvas->coords( $id, $pos[ 0 ], $pos[ 1 ] );
		$canvas->itemconfigure( $id, -image => $image );
	}
	else
	{
		my $id = $canvas->create
			( 'image', $pos[ 0 ], $pos[ 1 ],
				-anchor => 'center', -image  => $image );
		$critter->set_id( $id );
	}
	return $taxis;
}

sub _hide_critter_image
{
	my ( $taxis, $critter ) = @_;
	my $canvas = $taxis->Subwidget( 'canvas' );
	my $id     = $critter->get_id();
	my $image  = $taxis->{ image_bank }{ $taxis->{ images } }{ 0 };
	if ( defined $id )
	{
		$canvas->itemconfigure( $id, -image => $image );
	}
	return $taxis;
}

sub image_height
{
	my ( $taxis, $image_height ) = @_;
	if ( defined $image_height )
	{
		$taxis->{ image_height } = $image_height;
	}
	return $taxis->{ image_height };
}

sub image_width
{
	my ( $taxis, $image_width ) = @_;
	if ( defined $image_width )
	{
		$taxis->{ image_width } = $image_width;
	}
	return $taxis->{ image_width };
}

################################## critters ####################################

sub preference
{
	my ( $taxis, $preference ) = @_;
	if ( defined $preference )
	{
		$preference = [ $preference ] unless ref $preference;
		for my $i ( 0 .. 1 )
		{
			if ( defined $preference->[ $i ] )
			{
				if ( abs $preference->[ $i ] < 1 )
				{
					warnings::warn( "Absolute value of preference must be greater than 1" );
					${ $preference }[ $i ] = 1;
				}
			}
			else
			{
				$preference->[ $i ] = 1;
			}
		}
		$taxis->{ preference } = $preference;
	}
	return $taxis->{ preference };
}

sub tumble
{
	my ( $taxis, $tumble ) = @_;
	if ( defined $tumble )
	{
		if ( $tumble > 1 )
		{
			warnings::warn( "Tumble value too high, setting to 1" );
			$tumble = 1;
		}
		elsif ( $tumble < 0 )
		{
			warnings::warn( "Tumble value too low, setting to 0" );
			$tumble = 0;
		}
		$taxis->{ tumble } = $tumble;
	}
	return $taxis->{ tumble };
}

sub speed
{
	my ( $taxis, $speed ) = @_;
	if ( defined $speed )
	{
		my $canvas = $taxis->Subwidget( 'canvas' );
		my $max_x  = $canvas->cget( -width );
		my $max_y  = $canvas->cget( -height );
		my $min_speed = 2 / sqrt ( $max_x**2 + $max_y**2 );
		if ( $speed < $min_speed )
		{
			warnings::warn( "Speed too low, setting to minimum value of $min_speed" );
			$speed = $min_speed;
				# or they sit there and spin
		}
		$taxis->{ speed } = $speed;
	}
	return $taxis->{ speed };
}

sub calculation
{
	my ( $taxis, $calculation ) = @_;
	if ( defined $calculation )
	{
		$taxis->{ calculation } = $calculation;
	}
	return $taxis->{ calculation };
}

#################################### taxis #####################################

sub taxis
{
	my ( $taxis, $options ) = @_;
	my $canvas = $taxis->Subwidget( 'canvas' );
	if ( $taxis->{ critters } )
	{
		my $critter;
		for my $i ( 1 .. $taxis->{ population } )
		{
			$critter = $taxis->{ critters }[ $i ];
			$critter->move();
			$taxis->_create_critter_image( $critter );
		}
		DoOneEvent( DONT_WAIT );
	}
	return $taxis;
}

#################################### arena #####################################

sub population
{
	my ( $taxis, $population ) = @_;
	if ( defined $population )
	{
		$taxis->{ population } = abs $population;
		$taxis->refresh();
	}
	if ( wantarray )
	{
		my $canvas = $taxis->Subwidget( 'canvas' );
		my ( $top_left, $top_right, $bottom_left, $bottom_right )
		=  ( 0,         0,          0,            0             );
		my $vert_limit  = $canvas->cget( -height ) / 2;
		my $horiz_limit = $canvas->cget( -width )  / 2;
		for my $i ( 1 .. $taxis->{ population } )
		{
			if ( ${ $taxis->{ critters } }[ $i ]{ pos }[ 1 ]
					<= $vert_limit )
			{
				${ $taxis->{ critters } }[ $i ]{ pos }[ 0 ]
					<= $horiz_limit ?
						$top_left++ :
							$top_right++;
			}
			else
			{
				${ $taxis->{ critters } }[ $i ]{ pos }[ 0 ]
					<= $canvas->cget( -width ) / 2 ?
						$bottom_left++ :
							$bottom_right++;
			}
		}
		return
			(
				top          => ( $top_left     + $top_right ),
				bottom       => ( $bottom_left  + $bottom_right ),
				left         => ( $bottom_left  + $top_left ),
				right        => ( $bottom_right + $top_right ),
				top_left     => $top_left,
				bottom_left  => $bottom_left,
				top_right    => $top_right,
				bottom_right => $bottom_right,
				total        => ( $top_left + $top_right + $bottom_left + $bottom_right ),
			);
	}
	else
	{
		return $taxis->{ population };
	}
}

sub width
{
	my ( $taxis, $width ) = @_;
	if ( $width )
	{
		$taxis->{ width } = $width;
		$taxis->refresh();
	}
	return $taxis->{ width };
}

sub height
{
	my ( $taxis, $height ) = @_;
	if ( $height )
	{
		$taxis->{ height } = $height;
		$taxis->refresh();
	}
	return $taxis->{ height };
}

sub fill
{
	my ( $taxis, $fill ) = @_;
	if ( defined $fill )
	{
		if ( not ref $fill )
		{
			$taxis->{ fill } = [ [ $fill, $fill ], [ $fill, $fill ] ];
		}
		elsif ( ref $fill &&
				( not ref $fill->[0] ) &&
					( not ref $fill->[1] ) )
		{
			$taxis->{ fill } = [ [ $fill->[0], $fill->[1] ],
			                     [ $fill->[0], $fill->[1] ] ];
		}
		elsif ( ref $fill->[0] && ref $fill->[1] )
		{
			$taxis->{ fill } = [ [ $fill->[0][0], $fill->[0][1] ],
			                     [ $fill->[1][0], $fill->[1][1] ] ];
		}
		else
		{
			warnings::warn( "Invalid argument to fill" );
			return;
		}
		$taxis->refresh();
	}
	return $taxis->{ fill };
}

sub left_fill
{
	my ( $taxis, $left_fill ) = @_;
	if ( $left_fill )
	{
		warnings::warn( "left_fill is deprecated, use fill instead" );
		$taxis->{ fill }[0][0] = $left_fill;
		$taxis->{ fill }[1][0] = $left_fill;
		$taxis->refresh();
	}
	return $taxis->{ fill }[0][0];
}

sub right_fill
{
	my ( $taxis, $right_fill ) = @_;
	if ( $right_fill )
	{
		warnings::warn( "right_fill is deprecated, use fill instead" );
		$taxis->{ fill }[0][1] = $right_fill;
		$taxis->{ fill }[1][1] = $right_fill;
		$taxis->refresh();
	}
	return $taxis->{ fill }[1][1];
}

sub refresh
{
	my ( $taxis, $options ) = @_;
	return if $taxis->{ _supress_redraw };
	my $canvas = $taxis->Subwidget( 'canvas' );
	$canvas->configure( -width  => $taxis->width()  );
	$canvas->configure( -height => $taxis->height() );
	my $max_x  = $taxis->{ width };
	my $max_y  = $taxis->{ height };
	if ( $taxis->{ arena } )
	{
		my ( $top_left, $top_right, $bottom_left, $bottom_right )
					= @{ $taxis->{ arena } };
		$canvas->coords
			( $top_left, 0, 0, $max_x/2, $max_y/2 );
		$canvas->itemconfigure( $top_left, -fill => $taxis->{fill}[0][0] );

		$canvas->coords
			( $top_right, $max_x/2, 0, $max_x, $max_y/2 );
		$canvas->itemconfigure( $top_right, -fill => $taxis->{fill}[0][1] );

		$canvas->coords
			( $bottom_left, 0, $max_y/2, $max_x/2, $max_y);
		$canvas->itemconfigure( $bottom_left, -fill => $taxis->{fill}[1][0] );

		$canvas->coords
			( $bottom_right, $max_x/2, $max_y/2, $max_x, $max_y );
		$canvas->itemconfigure( $bottom_right, -fill => $taxis->{fill}[1][1] );

	}
	else
	{
		my $top_left = $canvas->create
			( 'rectangle', 0, 0, $max_x/2, $max_y/2,
				-fill => $taxis->{fill}[0][0] );

		my $top_right = $canvas->create
			( 'rectangle', $max_x/2, 0, $max_x, $max_y/2,
				-fill => $taxis->{fill}[0][1] );

		my $bottom_left = $canvas->create
			( 'rectangle', 0, $max_y/2, $max_x/2, $max_y,
				-fill => $taxis->{fill}[1][0] );

		my $bottom_right = $canvas->create
			( 'rectangle', $max_x/2, $max_y/2, $max_x, $max_y,
				-fill => $taxis->{fill}[1][1] );

		$taxis->{ arena } = [ $top_left, $top_right, $bottom_left, $bottom_right ];
	}
	my $i;
	for ( $i = 1 ; $i <= $taxis->{ population } ; $i++ )
	{
		my $critter = $taxis->{ critters }[ $i ];
		unless ( $critter )
		{
			$critter = Tk::Taxis::Critter->new( -taxis => $taxis );
			$taxis->{ critters }[ $i ] = $critter;
		}
		$critter->randomise();
		$taxis->_create_critter_image( $critter );
	}
	for my $j ( $i .. @{ $taxis->{ critters } } - 1  )
	{

		# We don't delete the critters from the critters arrayref,
		# we just keep track of the current population size, and
		# grow this as appropriate; we only hide their images from view in the
		# canvas. We do this because we cannot satifactorily
		# delete images from canvases, as this appears to cause memory leakage
		# even if we delete all references, and call the delete method on all
		# widgets. I presume this is a bug in Tk::Canvas, as it works for other
		# imaged widgets. This way we only get as big as the largest population
		# called during the life of the script.

		my $critter = $taxis->{ critters }[ $j ];
		$taxis->_hide_critter_image( $critter );
	}
	DoOneEvent( DONT_WAIT );
	return $taxis;
}

1;

__END__