tkhanoi.ppl (Mastering Perl/Tk)

C.12. tkhanoi.ppl

This next PPL program is a classic Tower of Hanoi game.
#!/usr/local/bin/perl -w
#
# Towers of Hanoi, Perl/Tk style.  2000/06/14, sol0@Lehigh.EDU

# Global package, subroutine and data declarations.

use Tk;
use Tk::Dialog;
use subs qw/do_hanoi fini hanoi init move_ring/;
use strict;

my $canvas;			# the Hanoi playing field
my @colors;			# 24 graduated ring colors
my $fly_y;			# canvas Y-coord along which rings fly
my $max_rings;			# be nice and keep @colors count-consistent
my $num_moves;			# total ring moves
my %pole;			# tracks pole X-coord and ring count
my %ring;			# tracks ring canvas ID, width and pole
my $ring_base;			# canvas Y-coord of base of ring pile
my $ring_spacing;		# pixels between adjacent rings
my $stopped;			# 1 IFF simulation is stopped
my $velocity;			# pixel delta the rings move while flying
my $version = '1.0, 2000/06/14';

# Main.

my $mw = MainWindow->new(-use => $Plugin::brinfo{xwindow_id});
init;
MainLoop;

sub do_hanoi {

    # Initialize for a new simulation.

    my($n) = @_;		# number of rings
    
    return unless $stopped;

    $stopped = 0;		# start ...
    $num_moves = 0;		# ... new simulation

    my $ring_height = 26;
    $ring_spacing = 0.67 * $ring_height;

    my $ring_width = 96 + $n * 12;

    my $canvas_width = 3 * $ring_width + 4 * 12;
    my $canvas_height = $ring_spacing * $n + $fly_y + 2 * $ring_height;

    $ring_base = $canvas_height - 32;

    # Remove all rings from the previous run and resize the canvas.

    for (my $i = 0; $i < $max_rings; $i++) {
        $canvas->delete($ring{$i, 'id'}) if defined $ring{$i, 'id'};
    }
    $canvas->configure(-width => $canvas_width, -height => $canvas_height);

    # Initialize the poles: no rings, updated X coordinate.

    for (my $i = 0; $i < 3; $i++) {
        $pole{$i, 'x'} = ($i * $canvas_width / 3) + ($ring_width / 2) + 8;
        $pole{$i, 'ring_count'} = 0;
    }

    # Initialize the rings: canvas ID, pole number, and width.

    for (my $i = 0; $i < $n; $i++) {
        my $color = '#' . $colors[$i % 24];
        my $w = $ring_width - ($i * 12);
        my $y = $ring_base - $i * $ring_spacing;
        my $x = $pole{0, 'x'} - $w / 2;
        my $r = $n - $i;
        $ring{$r, 'id'} = $canvas->createOval(
                $x, $y, $x + $w, $y + $ring_height,
                -fill => $color, -outline => 'black', -width => 1,
            );
        $ring{$r, 'width'} = $w;
        $ring{$r, 'pole'} = 0;
        $pole{0, 'ring_count'}++;
    }

    # Start the simulation.

    $mw->update;
    hanoi $n, 0, 2, 1;
    $stopped = 1;

} # end do_hanoi

sub hanoi {

    # Recursively move rings until complete or stopped by the user.

    my($n, $from, $to, $work) = @_;

    return if $n <=0 or $stopped;

    hanoi $n - 1, $from, $work, $to;
    move_ring $n, $to unless $stopped;
    hanoi $n - 1, $work, $to, $from;
}

sub init {

    $fly_y = 32;		# Y-coord rings use to fly between poles
    $stopped = 1;
    my $stop = sub {$stopped = 1};
    my $about = $mw->Dialog(
        -title          => 'About tkhanoi',
        -bitmap         => 'info',
        -default_button => 'OK',
        -buttons        => ['OK'],
        -text           => "tkhanoi version $version\n\n" .
                           "r - run  simulation\n"        .
                           "s - stop simulation\n"        .
                           "q - quit program\n",
        -wraplength     => '6i',
    );
    
    # Menubar and menubuttons.

    $mw->title("Towers of Hanoi");
    $mw->configure(-menu => my $menubar = $mw->Menu);

    my $file = $menubar->cascade(-label => 'File');
    $file->command(-label => '~Quit', -command => \&fini,-accelerator => 'q');

    my $game = $menubar->cascade(-label => 'Game');
    $game->command(-label => '~Run',  -command => sub {}, -accelerator => 'r');
    $game->command(-label => '~Stop', -command => $stop,  -accelerator => 's');

    my $help = $menubar->cascade(-label => 'Help');
    $help->command(-label => 'About', -command => sub {$about->Show});

    my $info = $mw->Frame->pack;

    # Number of rings scale.

    my $rframe = $info->Frame(qw/-borderwidth 2 -relief raised/);
    my $rlabel = $rframe->Label(-text => 'Number of Rings');
    my $rscale = $rframe->Scale(
        qw/-orient horizontal -from 1 -to 24 -length 200/,
    );
    $rscale->set(4);
    $game->cget(-menu)->entryconfigure('Run',
        -command => sub {do_hanoi $rscale->get},
    );

    $rframe->pack(qw/-side left/);
    $rscale->pack(qw/-side right -expand 1 -fill x/);
    $rlabel->pack(qw/-side left/);

    # Ring velocity scale.

    my $vframe = $info->Frame(qw/-borderwidth 2 -relief raised/);
    my $vlabel = $vframe->Label(-text => 'Ring Velocity %');
    my $vscale = $vframe->Scale(
        qw/-orient horizontal -from 0 -to 100 -length 200/,
        -command => sub {$velocity = shift},
    );
    $vscale->set(2);

    $vframe->pack(qw/-side left/);
    $vscale->pack(qw/-side right -expand 1 -fill x/);
    $vlabel->pack(qw/-side left/);

    # The simulation is played out on a canvas.

    $canvas = $mw->Canvas(qw/-relief sunken/);
    $canvas->pack(qw/-expand 1 -fill both/);
    $canvas->createWindow(40, 10, -window =>
        $canvas->Label(-textvariable => \$num_moves, -foreground => 'blue'),
    );

    # Each ring has a unique color, hopefully.

    @colors = (qw/
        ffff0000b000 ffff00006000 ffff40000000 ffff60000000 
        ffff80000000 ffffa0000000 ffffc0000000 ffffe0000000
        ffffffff0000 d000ffff0000 b000ffff0000 9000ffff0000
        6000ffff3000 0000ffff6000 0000ffff9000 0000ffffc000
        0000ffffffff 0000e000ffff 0000c000ffff 0000a000ffff
        00008000ffff 00006000ffff 00004000ffff 00000000ffff
    /); 

    $max_rings = 24;
    warn "Too few colors for $max_rings rings!" if $max_rings > $#colors + 1;

    # Global key bindings that emulate menu commands.

    $mw->bind('<KeyPress-r>' => sub {do_hanoi $rscale->get});
    $mw->bind('<KeyPress-q>' => \&fini);
    $mw->bind('<KeyPress-s>' => $stop);

} # end init

sub fini {
    $mw->destroy;
}

sub move_ring {

    # Move ring $n - its bounding box coordinates - to pole $to.

    my($n, $to) = @_;

    $num_moves++;
    my $r = $ring{$n, 'id'};
    my($x0, $y0, $x1, $y1) = map {int($_ + 0.5)} $canvas->coords($r); 

    # Float the ring upwards to the flying Y-coordinate, and decrement
    # this pole's count.

    my $delta;
    while ($y0 > $fly_y) {
        $delta = $y0 - $fly_y > $velocity ? $velocity : $y0 - $fly_y;
        $canvas->coords($r, $x0, $y0 -= $delta, $x1, $y1 -= $delta);
        $mw->update;
    }
    $pole{$ring{$n, 'pole'}, 'ring_count'}--;

    # Determine the target X coordinate based on destination pole, and
    # fly the ring over to the new pole. The first while moves rings
    # left-to-right, the second while moves rings right-to-left.

    my $x = $pole{$to, 'x'} - $ring{$n, 'width'} / 2;

    while ($x0 < $x) {
        $delta = $x - $x0 > $velocity ? $velocity : $x - $x0;
        $canvas->coords($r, $x0 += $delta, $y0, $x1 += $delta, $y1);
        $mw->update;
    }

    while ($x0 > $x) {
        $delta = $x0 - $x > $velocity ? $velocity : $x0 - $x;
        $canvas->coords($r, $x0 -= $delta, $y0, $x1 -= $delta, $y1);
        $mw->update;
    }

    # Determine ring's target Y coordinate, based on the destination
    # pole's ring count, and float the ring down.

    my $y = $ring_base - $pole{$to, 'ring_count'} * $ring_spacing;

    while ($y0 < $y) {
        $delta = $y - $y0 > $velocity ? $velocity : $y - $y0;
        $canvas->coords($r, $x0, $y0 += $delta, $x1, $y1 += $delta);
        $mw->update;
    }
    
    $pole{$to, 'ring_count'}++;
    $ring{$n, 'pole'} = $to;

} # end move_ring