diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 15:05:13 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 15:05:13 +0000 |
commit | 9fc19ef8e2dcd8bcf6a1d034b95c1de2b88e485c (patch) | |
tree | ee28de37fe0de6137d535fee2e64ecafaffefb91 /Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl | |
parent | 73b942cfb4ccf168f9c2b7f20a289b06f1f54a4b (diff) |
New tlperl part II
git-svn-id: svn://tug.org/texlive/trunk@21424 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl | 226 |
1 files changed, 226 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl new file mode 100644 index 00000000000..3a6ba17f937 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl @@ -0,0 +1,226 @@ +# A N-puzzle implemented via the Grid geometry manager. +# +# This program is described in the Perl/Tk column from Volume 1, Issue 4 of +# The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk +# distribution with permission. It has been modified slightly to conform +# to the widget demo standard. + +#!/usr/local/bin/perl -w +# +# puz - demonstrate the Grid geometry manager by implementing an n-puzzle. +# +# Stephen O. Lidie, Lehigh University Computing Center, lusol@Lehigh.EDU +# 96/08/11. +# +# Copyright (C) 1996 - 1998 Stephen O. Lidie. All rights reserved. +# +# This program is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself. + +require 5.002; +use Tk; +use Tk::Dialog; +use strict; +use subs qw(beep create_puz create_ui puz_fini move_piece new_puz randomly xy); + +my $CAMEL; # Perl/Tk Xcamel.gif Photo image +my $CAMEL_HEIGHT; # Xcamel height +my $CAMEL_WIDTH; # Xcamel width +my (@LEVELS) = (9, 16, 36, 64); # possible puzzle piece counts +my $MW = MainWindow->new; # program's main window +my @ORDER; # random puzzle piece ordinals +my $PIECES = $LEVELS[1]; # total puzzle piece count +my $OLD_PIECES = -1; # previous puzzle piece count +my $PF; # puzzle Frame +my @PUZ; # puzzle piece information +my $SIDE; # pieces per side of puzzle +my $SPACE; # shortcut to puzzle space piece +my $SPACE_IMAGE; # space piece image + +create_ui; +create_puz; + +sub beep {$MW->bell} + +sub create_puz { + + return if $PIECES == $OLD_PIECES; + + # Create all the puzzle pieces - buttons with images - and arrange them + # in a rectangular grid. @PUZ is a list of button widget references which + # represent the puzzle pieces. + # + # The actual ordering is controlled by @ORDER, a list of list of two: + # + # $ORDER[$i]->[0] = puzzle piece ordinal + # $ORDER[$i]->[1] = random number used to shuffle the puzzle ordinals + # + # If the puzzle frame $PF exists, we've been here before, which means that + # all images and widgets associated with the previous puzzle need + # destroying, plugging a potential memory leak. It's important to note + # that an image must be explicity deleted - it doesn't magically go away + # if a widget, which just happens to use it, is destroyed. So, loop + # through all the puzzle pieces and delete their images, then destroy the + # puzzle's master frame $PF, destroying all child widgets. Now, this + # scheme isn't particulary efficient, but it is simple; ideally, we'd like + # to create these images only once and reuse them as required. + + if (Exists $PF) { + my $image; + foreach (@PUZ) { + $image = $_->cget(-image); + $image = $SPACE_IMAGE if not defined $image; + $image->delete; + } + $PF->destroy; + } + + $PF = $MW->Frame->grid; # create the puzzle frame grid master + $OLD_PIECES = $PIECES; + $#PUZ = $#ORDER = $PIECES - 1; + $SIDE = sqrt $PIECES; + + my($i, $o, $c, $r, $w, $h, $x, $y, $but, $gif); + + foreach (0..$#ORDER) {$ORDER[$_] = [$_, undef]} + + for($i = 0; $i <= $#PUZ; $i++) { + $o = $ORDER[$i]->[0]; + ($c, $r) = xy $o; # puzzle ordinal to column/row + $w = $CAMEL_WIDTH / $SIDE; + $h = $CAMEL_HEIGHT / $SIDE; + $x = $c * $w; # x/column pixel offset + $y = $r * $h; # y/row pixel offset + $gif = $PF->Photo; # new, empty, GIF image + $gif->copy($CAMEL, -from => $x, $y, $x+$w, $y+$h); + $but = $PF->Button(-image => $gif, + -relief => 'flat', + -borderwidth => 0, + -command => \&beep, + -highlightthickness => 0, + ); + $PUZ[$o] = $but; + ($c, $r) = xy $i; + $but->grid(-column => $c, -row => $r, -sticky => 'nsew'); + if ($o == 0) { + $SPACE_IMAGE = $gif; + $SPACE = $but; + } + } # forend all puzzle pieces + +} # end create_puz + +sub create_ui { + + # Create a color Photo image of the Xcamel puzzle. + + $CAMEL = $MW->Photo(-file => "$WIDTRIB/lib/npuz/Xcamel.npuz"); + $CAMEL_WIDTH = $CAMEL->image('width'); + $CAMEL_HEIGHT = $CAMEL->image('height'); + + # Create the menubar. + + my $mf = $MW->Frame(-bg => 'blue')->grid(-sticky => 'ew'); + $mf->gridColumnconfigure(1, -weight => 1); + + my $mbf = $mf->Menubutton(-text => 'File', -relief => 'raised'); + $mbf->command(-label => 'New Puzzle', -command => \&new_puz); + $mbf->separator; + $mbf->command(-label => 'Quit', -command => [$MW => 'bell']); + + my $mbp = $mf->Menubutton(-text => 'Prefs', -relief => 'raised'); + my $pieces = 'Pieces'; + $mbp->cascade(-label => $pieces); + my $mbpm = $mbp->cget(-menu); + my $mbpmp = $mbpm->Menu; + $mbp->entryconfigure($pieces, -menu => $mbpmp); + foreach (@LEVELS) { + $mbpmp->radiobutton(-label => $_, + -variable => \$PIECES, + -value => $_, + -command => \&create_puz, + ); + } + + my $mbq = $mf->Menubutton(-text => 'Help', -relief => 'raised'); + my $about = $MW->Dialog(-text => <<"END" +npuz Version 1.0\n +Select \"File/New Puzzle\", then click around the red \"space\" to rearrange the pieces and solve the puzzle!\n\nThis program is described in the Perl/Tk column from Volume 1, Issue 4 of The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk distribution with permission. +END + ); + $about->configure(-wraplength => '6i'); + $mbq->command(-label => 'About', -command => [$about => 'Show']); + + $mbf->grid(-row => 0, -column => 0, -sticky => 'w'); + $mbp->grid(-row => 0, -column => 1, -sticky => 'w'); + $mbq->grid(-row => 0, -column => 2, -sticky => 'e'); + +} # end create_ui + +sub puz_fini { + + # Return true iff all puzzle pieces are in order. + + my($i, $c, $r, %info); + for($i = 0; $i <= $#PUZ; $i++) { + ($c, $r) = xy $i; + %info = $PUZ[$i]->gridInfo; + return 0 if $c != $info{-column} or $r != $info{-row}; + } + return 1; + +} # end puz_fini + +sub move_piece { + + my($piece) = @_; + + my(%info, $c, $r, $sc, $sr); + %info = $piece->gridInfo; ($c, $r) = @info{-column,-row}; + %info = $SPACE->gridInfo; ($sc, $sr) = @info{-column,-row}; + if ( ($sr == $r and ($sc == $c-1 or $sc == $c+1)) or + ($sc == $c and ($sr == $r-1 or $sr == $r+1)) ) { + $SPACE->grid(-column => $c, -row => $r); + $piece->grid(-column => $sc, -row => $sr); + } + if (puz_fini) { + my $color = ($SPACE->configure(-activebackground))[3]; + $SPACE->configure(-image => $SPACE_IMAGE, + -activebackground => $color, + -background => $color, + -relief => 'flat', + ); + foreach (@PUZ) {$_->configure(-command => \&beep)} + } + +} # end move_piece + +sub new_puz { + + srand time; + foreach (0..$#ORDER) {$ORDER[$_]->[1] = rand $#ORDER} + my @order = sort randomly @ORDER; + #@order = @ORDER; # here's how I solve the puzzle (; + my($i, $o, $c, $r, $but); + + for($i = 0; $i <= $#PUZ; $i++) { + $o = $order[$i]->[0]; + $but = $PUZ[$o]; + if ($o == 0) { + $but->configure(-background => 'red', + -relief => 'sunken', + -image => undef, + -activebackground => 'red', + ); + } else { + $but->configure(-command => [\&move_piece, $but]); + } + ($c, $r) = xy $i; + $but->grid(-column => $c, -row => $r, -sticky => 'nsew'); + } + +} # end new_puz + +sub randomly {$a->[1] <=> $b->[1]} # randomize order of puzzle pieces + +sub xy {my($n) = @_; ($n % $SIDE, int $n / $SIDE)} # ordinal to X/Y |