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