Tam's Chinese Peg Game

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.

Comment on Tam's Chinese Peg Game Download Code

Replies are listed 'Best First'.
Re: Tam's Chinese Peg Game by rjray (Chaplain) on Jun 02, 2004 at 00:47 UTC
Pretty decent start. Definately ++. But it has a few problems... It completely loses it if you click on buttons/pegs in a non-logical order. Click on a peg, then click two pegs away, or click on the open area instead of the adjacent peg. You're pretty much locked up at that point. In a similar vein, consider binding "`q`" to being an exit-command. Please. A good next step might be to highlight the selected peg. Bonus points for highlighting the legal moves as well. Lastly, some sort of detection of when the game is over. Still, got my vote! `--rjray`	[reply]
Re: Tam's Chinese Peg Game by CountZero (Bishop) on Jun 05, 2004 at 18:50 UTC
Fun game and nice try! But you must give some indication when you are in "selecting" mode (choosing which peg to move) and when you are in "jumping" mode (choosing were to land the selected peg). May I suggest to switch the form of the mouse-cursor depending on the mode you're in? CountZero "If you have four groups working on a compiler, you'll get a 4-pass compiler." - Conway's Law	[reply]