#!/usr/bin/perl -w
use strict;

use Tk;
use Tk::Canvas;
use Getopt::Std;
my $width	= 250;
my $height	= 250;
my $units	= 10;
my $background	= 'blue';
my $fill	= 'yellow';
my %opts	= ();
getopts( 'W:H:b:f:u:h', \%opts );
if( $opts{W} ) { $width		= $opts{W} ; }
if( $opts{H} ) { $height	= $opts{H} ; }
if( $opts{b} ) { $background	= $opts{b} ; }
if( $opts{f} ) { $fill		= $opts{f} ; }
if( $opts{u} ) { $units		= $opts{u} ; }

my $dx = $width  / $units;
my $dy = $height / $units;

#
# $selected, $jumper and $jumpy are used
# by the sub selectPeg below
#
my $selected 	=  0;
my $jumper 	= -1;
my $jumpy 	= -1;

#
# the game board
#
my $board 	= new board();

#
# our Tk objects
#
my $top = MainWindow->new();
my $can = $top->Canvas( -width => $width, -height=> $height )->pack();

placePegs( $can, $board );
MainLoop;

#
# draw the pegs on the board based on the information
# contained in the board object
#
sub placePegs {
	my $can = shift;
	my $board = shift;
	my $hole = 0;
	my $tag;
	my $radius = 10;

	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2)-$radius, $dy-$radius, $dx*($units/2)+$radius, $dy+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;

	
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2-1)-$radius, $dy*3-$radius, $dx*($units/2-1)+$radius, $dy*3+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2+1)-$radius, $dy*3-$radius, $dx*($units/2+1)+$radius, $dy*3+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2-2)-$radius, $dy*5-$radius, $dx*($units/2-2)+$radius, $dy*5+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2+0)-$radius, $dy*5-$radius, $dx*($units/2+0)+$radius, $dy*5+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2+2)-$radius, $dy*5-$radius, $dx*($units/2+2)+$radius, $dy*5+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	     
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2-3)-$radius, $dy*7-$radius, $dx*($units/2-3)+$radius, $dy*7+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2-1)-$radius, $dy*7-$radius, $dx*($units/2-1)+$radius, $dy*7+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2+1)-$radius, $dy*7-$radius, $dx*($units/2+1)+$radius, $dy*7+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2+3)-$radius, $dy*7-$radius, $dx*($units/2+3)+$radius, $dy*7+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2-4)-$radius, $dy*9-$radius, $dx*($units/2-4)+$radius, $dy*9+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] );
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2-2)-$radius, $dy*9-$radius, $dx*($units/2-2)+$radius, $dy*9+$radius,
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] );
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2+0)-$radius, $dy*9-$radius, $dx*($units/2+0)+$radius, $dy*9+$radius,
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] );
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2+2)-$radius, $dy*9-$radius, $dx*($units/2+2)+$radius, $dy*9+$radius,
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
	$tag = "HOLE_$hole";
	$can->create(oval => $dx*($units/2+4)-$radius, $dy*9-$radius, $dx*($units/2+4)+$radius, $dy*9+$radius, 
		-fill => $board->{'holes'}[$hole]->{'peg'},
       		-tag  => [$tag] );
	$can->bind( $tag,  '<Button>' , [\&selectPeg, $hole] ); 
	$hole++;
}

#
# selectPeg keeps track of what peg the user
# wants to jump and what peg the user is attempting
# to jump over.
#
sub selectPeg {
	shift;
	my $holeIndex = shift;
	if ( $selected == 0 ) {
		$jumper = $holeIndex;
		$selected = 1;
	} else {
		$jumpy = $holeIndex;
		$selected = 0;

		my $canJump = $board->{'holes'}[$jumpy]->jumpingOver ( $jumper );
		if ( $canJump >= 0 ) {
			$board->{'holes'}[$jumper]->setPeg('white');
			$board->{'holes'}[$jumpy]->setPeg('white');
			$board->{'holes'}[$canJump]->setPeg('black');
		}
		placePegs( $can, $board );
	}
}
BEGIN 
{ 
{ package hole;

use strict;
use Exporter;
use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION 	= 1.00;
@ISA		= qw(Exporter);
@EXPORT		= ();
@EXPORT_OK	= qw( &new );
%EXPORT_TAGS	= ( DEFAULT => [qw ( &new )] );

#
# new - hole constructor
# 	peg  ) By convention, contains a fill color 
# 	       black implies there is a peg in the hole and
# 	       white impleis there is no peg in the hole.
# 
#	index) holes must be indexed 0 through 14
#
#	links) is a ref to an array of adjacent holes.
#	       This isn't typical passed to the new constructor.
#	       It is easier to call setLinks ( see below )
#
sub new {
	my ($pkg, $peg, $index, $level, $links ) = @_;
	my $obj = bless {
		peg		=> $peg, 
		holeIndex	=> $index,
		level		=> $level,
		links		=> $links # ref to array of holes
	}, $pkg;
	return $obj;
}

#
# takes a ref to an array of adjacent holes
# and sets this hole's links attribute
#
sub setLinks {
	my $obj = shift;
	my $links = shift;
	$obj->{'links'} = $links;
}

#
# takes a  fill color of the peg.
# black => has peg
# white => does not have peg
#
sub setPeg {
	my $obj = shift;
	my $peg = shift;
	$obj->{'peg'} = $peg;
}

#
# returns the links attribute
#
sub getLinks {
	my $obj = shift;
	return $obj->{'links'};
}

#
# returns the peg attribute
#
sub getPeg {
	my $obj = shift;
	return $obj->{'peg'};
}

#
# jumpingOver determines if another peg from the hole
# having index of $jumperIndex is allowed to jump the 
# peg in this hole.
#
sub jumpingOver {
	my $obj = shift;
	my $jumperIndex = shift;

	#
	# You have no peg to jump with
	#
	if ( $obj->{'peg'} eq 'white' ) { return -1; }

	#
	# You can't jump yourself
	#
	if ( $jumperIndex == $obj->{'holeIndex'} ) { return -1; }

	#
	# find jumper in links array
	#
	my $jumper = $obj->getHoleWithIndex ( $jumperIndex );
	# this caused problem pointed out by rjray. Thanks rjray!
        # if ( !$jumper->hasPeg() ) { return -1; }
	if ( $jumper ) {
                if ( !$jumper->hasPeg() ) { return -1; }
		my $objIndex 	= $obj->{'holeIndex'};
		my $jumperLevel = $jumper->{'level'};
		my $objLevel 	= $obj->{'level'};
		my $levelDiff 	= abs($objLevel - $jumperLevel);
		my $targetIndex = 2 * $objIndex + $levelDiff - $jumperIndex;
		my $targetHole 	= $obj->getHoleWithIndex( $targetIndex );
		if ( $targetHole ) {
			#
			# we can jump to hole with index of $targetIndex
			#
			return $targetIndex if $targetHole->{'peg'} eq 'white';
			#
			# we can jump because there is a peg is blocking 
			#
			return -1;
		} else {
			#
			# no hole
			#
			return -1;
		}
	} else {
		#
		# The jumper is not adjacent to this hole
		#
		return -1;
	}
	#
	# we should NOT get here.
	#
	return -1;
}

#
# If peg is black then there is a peg there
#
sub hasPeg {
	my $obj 	= shift;
	return ( $obj->{'peg'} eq 'black' );
}

#
# return the hole that has index, i
#
sub getHoleWithIndex {
	my $obj 	= shift;
	my $i		= shift;

	foreach my $link ( @{$obj->{'links'}} ) {
		if ( $link->{'holeIndex'} == $i ) {
			return $link;
		}
	} 
	return undef;
}

1;
} 
{ package board;

use strict;
use Exporter;
use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION 	= 1.00;
@ISA		= qw(Exporter);
@EXPORT		= ();
@EXPORT_OK	= qw( &new );
%EXPORT_TAGS	= ( DEFAULT => [qw ( &new )] );

#
# new - board constructor
#
# holes ) is an ref to a array of hole objects
#         This is not typically passed in to the
#         constructor.  The constructor will build
#         the holes attribute $holes is not passed.
#
# level ) is also not typically used.
#
sub new {
	my ($pkg, $holes, $level) = @_;

	unless ( $holes ) {
		#
		# create the holes
		#
		my $holeLevel = 0;
		for ( my $i=0; $i<15; $i++ ) {
			if ( $i > 0 ) { $holeLevel = 1; }
			if ( $i > 2 ) { $holeLevel = 2; }
			if ( $i > 5 ) { $holeLevel = 3; }
			if ( $i > 9 ) { $holeLevel = 4; }
			#
			# the 5th hole is usaully has no peg initially.
			#
			$holes->[$i] = new hole( ( $i == 4 ) ? 'white' : 'black' , $i, $holeLevel );
		}

		#
		# link the holes
		#
		$holes->[0]->setLinks( [ 
					$holes->[1], 
					$holes->[2] 
				       ] );
		$holes->[1]->setLinks( [
					$holes->[0], 
					$holes->[2],
					$holes->[3],
					$holes->[4]
				       ] );
		$holes->[2]->setLinks( [
					$holes->[0], 
					$holes->[1],
					$holes->[4],
					$holes->[5]
				       ] );
		$holes->[3]->setLinks( [
					$holes->[1], 
					$holes->[4],
					$holes->[6],
					$holes->[7]
				       ] );
		$holes->[4]->setLinks( [
					$holes->[1], 
					$holes->[2],
					$holes->[3],
					$holes->[5],
					$holes->[7],
					$holes->[8]
				       ] );
		$holes->[5]->setLinks( [
					$holes->[2], 
					$holes->[4],
					$holes->[8],
					$holes->[9]
				       ] );
		$holes->[6]->setLinks( [
					$holes->[3], 
					$holes->[7],
					$holes->[10],
					$holes->[11]
				       ] );
		$holes->[7]->setLinks( [
					$holes->[3], 
					$holes->[4],
					$holes->[6],
					$holes->[8],
					$holes->[11],
					$holes->[12]
				       ] );
		$holes->[8]->setLinks( [
					$holes->[4], 
					$holes->[5],
					$holes->[7],
					$holes->[9],
					$holes->[12],
					$holes->[13]
				       ] );
		$holes->[9]->setLinks( [
					$holes->[5], 
					$holes->[8],
					$holes->[13],
					$holes->[14]
				       ] );
		$holes->[10]->setLinks( [
					$holes->[6], 
					$holes->[11]
				       ] );
		$holes->[11]->setLinks( [
					$holes->[6], 
					$holes->[7],
					$holes->[10],
					$holes->[12]
				       ] );
		$holes->[12]->setLinks( [
					$holes->[7], 
					$holes->[8],
					$holes->[11],
					$holes->[13]
				       ] );
		$holes->[13]->setLinks( [
					$holes->[8], 
					$holes->[9],
					$holes->[12],
					$holes->[14]
				       ] );
		$holes->[14]->setLinks( [
					$holes->[9], 
					$holes->[13]
				       ] );
	}
	my $obj = bless {
		holes	=> $holes, # ref to array of holes
		level	=> defined( $level ) ? $level : 0
	}, $pkg;
	return $obj;
}

1;
}}