home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / demos / widtrib / npuz.pl < prev    next >
Encoding:
Text File  |  1997-08-10  |  7.8 KB  |  243 lines
  1. # An N-puzzle implemented via the Grid geometry manager.
  2. #
  3. # This program is described in the Perl/Tk column from Volume 1, Issue 4 of
  4. # The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk
  5. # distribution with permission.  It has been modified slightly to conform
  6. # to the widget demo standard.
  7.  
  8. use vars qw/$TOP @LEVELS $PIECES $OLD_PIECES $CAMEL $CAMEL_HEIGHT $CAMEL_WIDTH
  9.         @ORDER $PF @PUZ $SIDE $SPACE $SPACE_IMAGE $WIDTRIB/;
  10.  
  11. sub npuz {
  12.     my($demo) = @ARG;
  13.     my $demo_widget = $MW->WidgetDemo(
  14.         -name             => $demo,    
  15.         -text             => 'An N-puzzle appears below as a collection of button images.  Use "File/New Puzzle" to start a new game, then click on any of the images NSEW of the red space, and that piece will slide over the space.  Continue until the puzzle is solved.',
  16.         -geometry_manager => 'grid',
  17.         -title            => 'N-puzzle Demonstration',
  18.         -iconname         => 'N-Puz',
  19.     );
  20.     $TOP = $demo_widget->Top;
  21.  
  22. #!/usr/local/bin/perl -w
  23. #
  24. # puz - demonstrate the Grid geometry manager by implementing an n-puzzle.
  25. #
  26. # Stephen O. Lidie, Lehigh University Computing Center, lusol@Lehigh.EDU
  27. # 96/08/11.
  28. #
  29. # Copyright (C) 1996 - 1996 Stephen O. Lidie. All rights reserved.
  30. #
  31. # This program is free software; you can redistribute it and/or modify it under
  32. # the same terms as Perl itself.
  33.  
  34. require 5.002;
  35. use English;
  36. use Tk;
  37. use Tk::Dialog;
  38. use strict;
  39. use subs qw(beep create_puz create_ui puz_fini move_piece new_puz randomly xy);
  40.  
  41. #my $CAMEL;            # Perl/Tk Xcamel.gif Photo image
  42. #my $CAMEL_HEIGHT;        # Xcamel height
  43. #my $CAMEL_WIDTH;        # Xcamel width
  44. (@LEVELS) = (9, 16, 36, 64);    # possible puzzle piece counts
  45. #my @ORDER;            # random puzzle piece ordinals
  46. $PIECES = $LEVELS[1];            # total puzzle piece count
  47. $OLD_PIECES = -1;        # previous puzzle piece count
  48. #my $PF;            # puzzle Frame
  49. #my @PUZ;            # puzzle piece information
  50. #my $SIDE;            # pieces per side of puzzle
  51. #my $SPACE;            # shortcut to puzzle space piece
  52. #my $SPACE_IMAGE;        # space piece image
  53.  
  54. create_ui;
  55. create_puz;
  56.  
  57. sub beep {$TOP->bell}
  58.  
  59. sub create_puz {
  60.  
  61.     return if $PIECES == $OLD_PIECES;
  62.  
  63.     # Create all the puzzle pieces - buttons with images - and arrange them 
  64.     # in a rectangular grid.  @PUZ is a list of button widget references which
  65.     # represent the puzzle pieces.
  66.     #
  67.     # The actual ordering is controlled by @ORDER, a list of list of two:
  68.     #
  69.     # $ORDER[$i]->[0] = puzzle piece ordinal
  70.     # $ORDER[$i]->[1] = random number used to shuffle the puzzle ordinals
  71.     #
  72.     # If the puzzle frame $PF exists, we've been here before, which means that
  73.     # all images and widgets associated with the previous puzzle need
  74.     # destroying, plugging a potential memory leak.  It's important to note
  75.     # that an image must be explicity deleted - it doesn't magically go away
  76.     # if a widget, which just happens to use it, is destroyed.  So, loop
  77.     # through all the puzzle pieces and delete their images, then destroy the
  78.     # puzzle's master frame $PF, destroying all child widgets.  Now, this
  79.     # scheme isn't particulary efficient, but it is simple; ideally, we'd like
  80.     # to create these images only once and reuse them as required.
  81.  
  82.     if (Exists $PF) {
  83.     my $image;
  84.     foreach (@PUZ) {
  85.         $image = $ARG->cget(-image);
  86.         $image = $SPACE_IMAGE if not defined $image;
  87.         $image->delete;
  88.     }
  89.     $PF->destroy;
  90.     }
  91.  
  92.     $PF = $TOP->Frame->grid;    # create the puzzle frame grid master
  93.     $OLD_PIECES = $PIECES;
  94.     $#PUZ = $#ORDER = $PIECES - 1;
  95.     $SIDE = sqrt $PIECES;
  96.  
  97.     my($i, $o, $c, $r, $w, $h, $x, $y, $but, $gif);
  98.  
  99.     foreach (0..$#ORDER) {$ORDER[$ARG] = [$ARG, undef]}
  100.  
  101.     for($i = 0; $i <= $#PUZ; $i++) {
  102.     $o = $ORDER[$i]->[0];
  103.     ($c, $r) = xy $o;    # puzzle ordinal to column/row
  104.     $w = $CAMEL_WIDTH  / $SIDE;
  105.     $h = $CAMEL_HEIGHT / $SIDE;
  106.     $x = $c * $w;        # x/column pixel offset
  107.     $y = $r * $h;        # y/row    pixel offset
  108.     $gif = $PF->Photo;    # new, empty, GIF image
  109.     $gif->copy($CAMEL, -from => $x, $y, $x+$w, $y+$h);
  110.     $but = $PF->Button(-image              => $gif,
  111.                -relief             => 'flat',
  112.                -borderwidth        => 0, 
  113.                -command            => \&beep,
  114.                -highlightthickness => 0,
  115.                );
  116.     $PUZ[$o] = $but;
  117.     ($c, $r) = xy $i;
  118.     $but->grid(-column => $c, -row => $r, -sticky => 'nsew');
  119.     if ($o == 0) {
  120.         $SPACE_IMAGE = $gif;
  121.         $SPACE = $but;
  122.     }
  123.     } # forend all puzzle pieces
  124.  
  125. } # end create_puz
  126.  
  127. sub create_ui {
  128.  
  129.     # Create a color Photo image of the Xcamel puzzle.
  130.  
  131.     $CAMEL = $TOP->Photo(-file => "$WIDTRIB/lib/npuz/Xcamel.npuz");
  132.     $CAMEL_WIDTH  = $CAMEL->image('width');
  133.     $CAMEL_HEIGHT = $CAMEL->image('height');
  134.  
  135.     # Create the menubar.
  136.  
  137.     my $mf = $TOP->Frame(-bg => 'blue')->grid(-sticky => 'ew');
  138.     $mf->gridColumnconfigure(1, -weight => 1);
  139.  
  140.     my $mbf = $mf->Menubutton(-text => 'File', -relief => 'raised');
  141.     $mbf->command(-label => 'New Puzzle', -command => \&new_puz);
  142.     $mbf->separator;
  143.     $mbf->command(-label => 'Quit', -command => [$TOP => 'bell']);
  144.  
  145.     my $mbp = $mf->Menubutton(-text => 'Prefs', -relief => 'raised');
  146.     my $pieces = 'Pieces';
  147.     $mbp->cascade(-label => $pieces);
  148.     my $mbpm = $mbp->cget(-menu);
  149.     my $mbpmp = $mbpm->Menu;
  150.     $mbp->entryconfigure($pieces, -menu => $mbpmp);
  151.     foreach (@LEVELS) {
  152.     $mbpmp->radiobutton(-label    => $ARG,
  153.                 -variable => \$PIECES,
  154.                 -value    => $ARG,
  155.                 -command  => \&create_puz,
  156.                 );
  157.     }
  158.  
  159.     my $mbq = $mf->Menubutton(-text => 'Help', -relief => 'raised');
  160.     my $about = $TOP->Dialog(-text => <<"END"
  161. npuz Version 1.0\n
  162. 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.
  163. END
  164.     );
  165.     $about->configure(-wraplength => '6i');
  166.     $mbq->command(-label => 'About', -command => [$about => 'Show']);
  167.  
  168.     $mbf->grid(-row => 0, -column => 0, -sticky => 'w');
  169.     $mbp->grid(-row => 0, -column => 1, -sticky => 'w');
  170.     $mbq->grid(-row => 0, -column => 2, -sticky => 'e');
  171.  
  172. } # end create_ui
  173.  
  174. sub puz_fini {
  175.  
  176.     # Return true iff all puzzle pieces are in order.
  177.     
  178.     my($i, $c, $r, %info);
  179.     for($i = 0; $i <= $#PUZ; $i++) {
  180.     ($c, $r) = xy $i;
  181.     %info = $PUZ[$i]->gridInfo;
  182.     return 0 if $c != $info{-column} or $r != $info{-row};
  183.     }
  184.     return 1;
  185.  
  186. } # end puz_fini
  187.  
  188. sub move_piece {
  189.  
  190.     my($piece) = @ARG;
  191.  
  192.     my(%info, $c, $r, $sc, $sr);
  193.     %info = $piece->gridInfo; ($c, $r)   = @info{-column,-row};
  194.     %info = $SPACE->gridInfo; ($sc, $sr) = @info{-column,-row};
  195.     if ( ($sr == $r and ($sc == $c-1 or $sc == $c+1)) or
  196.      ($sc == $c and ($sr == $r-1 or $sr == $r+1)) ) {
  197.     $SPACE->grid(-column => $c,  -row => $r);
  198.     $piece->grid(-column => $sc, -row => $sr);
  199.     }
  200.     if (puz_fini) {
  201.     my $color = ($SPACE->configure(-activebackground))[3];
  202.     $SPACE->configure(-image            => $SPACE_IMAGE,
  203.               -activebackground => $color,
  204.               -background       => $color,
  205.               -relief           => 'flat',
  206.               );
  207.     foreach (@PUZ) {$ARG->configure(-command => \&beep)}
  208.     }
  209.  
  210. } # end move_piece
  211.  
  212. sub new_puz {
  213.  
  214.     srand time;
  215.     foreach (0..$#ORDER) {$ORDER[$ARG]->[1] = rand $#ORDER}
  216.     my @order = sort randomly @ORDER;
  217.     #@order = @ORDER; # here's how I solve the puzzle (;
  218.     my($i, $o, $c, $r, $but);
  219.  
  220.     for($i = 0; $i <= $#PUZ; $i++) {
  221.     $o = $order[$i]->[0];
  222.     $but = $PUZ[$o];
  223.     if ($o == 0) {
  224.         $but->configure(-background       => 'red',
  225.                 -relief           => 'sunken',
  226.                 -image            => undef,
  227.                 -activebackground => 'red',
  228.                 );
  229.     } else {
  230.         $but->configure(-command => [\&move_piece, $but]);
  231.     }
  232.     ($c, $r)   = xy $i;
  233.     $but->grid(-column => $c, -row => $r, -sticky => 'nsew');
  234.     }
  235.  
  236. } # end new_puz
  237.  
  238. sub randomly {$a->[1] <=> $b->[1]} # randomize order of puzzle pieces
  239.  
  240. sub xy {my($n) = @ARG; ($n % $SIDE, int $n / $SIDE)} # ordinal to X/Y
  241.  
  242. } # end subroutine npuz
  243.