comment on

You are probably thinking, "It must be another slow day at the Chum-Bucket." and you would be right. Here is a Perl/Tk version of this game they have on the tables at Tam's Chinese Food in Santa Cruz. They have the best Orange Chicken! Well anyways the hardest trick is to leave 8 pegs without any of them being allowed to jump. The next hardest trick is to leave one peg in the initially empty hole. update I forgot to mention that to move a peg click on it then click on the peg you want to jump over. I agree that it is probably more intuitive to click on the peg you want to move the then click the hole where you want it to be, but I couldn't figure out how to verify the move was legal.

#!/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*($un
+its/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;
}}
[download]

Have fun!

Plankton: 1% Evil, 99% Hot Gas.

In reply to Tam's Chinese Peg Game by Plankton

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		`&`
	<		`<`
	>		`>`
	[		`[`
	]		`]`

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.