#!/usr/bin/perl -w
###############
# slidingBlock.cgi
#
# An implementation a sliding block puzzle as a cgi script,
# using the CGI.pm perl module.
#
# E F C
# D H G a scrambled position for the 3x3 sliding block puzzle
# B A
#
# The basic idea is that the entire puzzle state is passed
# in the URL on each request. The position shown above is
#
# slidingBlock.cgi?puzzlestring=EFCDHG-BA&size=3
#
# To slide a block, you click on a cell near the hole,
# and that link takes you to the next state of the puzzle.
#
# For example, with the puzzle as shown above,
# clicking on the "B" character would swap the B and the hole,
# and thus on the displayed webpage the "B" would be a link
# giving the puzzle state after that swap, i.e.
#
# B
#
# E F C After clicking on the "B",
# D H G the displayed page would look like this.
# B A
#
#
# ------ mod_perl issues -------
#
# In its current form this script is NOT save
# for useage under a persistent environment, i.e. mod_perl.
#
# Problems include:
# - the "exit;" statement which tries to kill the entire mod_perl
# - the __END__ marker (ditto)
# - the many "my" variables used as globals to this file
# (In a persistent environment like mod_perl,
# these are treated as "closures" - the instance that existed
# when the subroutines are defined are tied to those subroutines.
# This probably isn't quite the behavior one expects...)
#
# All three issues are pretty easy to fix.
#
# For the first, two, just delete the offending lines.
# (In fact, mod_perl itself redefines exit() before calling this routine;
# so the exit; line is actually OK. Go figure.)
#
# For the "my" issue, just change all those declarations to "our" -
# after all, we're treating them like globals - and put in a package
# declaration to limit their affect. As long as these variables are
# all see each time through, we should be OK. (On entry, they
# will have their previous values - so we can't assume that they're blank.)
#
##############
use strict;
use CGI;
use CGI::Carp qw( fatalsToBrowser );
my $cgi = new CGI;
my $color = "darkred";
my $linkcolor = "darkred"; # To make the clickable spots more visible,
# make $linkcolor something like "red".
my $url = $cgi->url( -relative=>1, -query=>0 );
my $size = $cgi->param("size") || 5;
my $puzzlestring = $cgi->param("puzzlestring") || makePuzzleString($size);
if ( $cgi->param("Change Size") ) {
$size = $cgi->param("sizePopUp");
$puzzlestring = makePuzzleString($size);
}
if ( $cgi->param("Scramble") ) {
$size = $cgi->param("sizePopUp");
$puzzlestring = makeRandomPuzzleString($size);
}
my $puzzle = makePuzzle($puzzlestring,$size);
my $dashindex = index($puzzlestring,"-");
my $rowdash = int($dashindex/$size);
my $coldash = $dashindex % $size;
printWebPage();
exit;
# --- subroutines -----------------------
# modify string passed by swapping two characters.
sub swapChars {
my ($string, $n1, $n2) = @_;
my $char1 = substr( $string, $n1, 1);
my $char2 = substr( $string, $n2, 1);
substr( $string, $n1, 1) = $char2;
substr( $string, $n2, 1) = $char1;
return $string;
}
# Same as makePuzzleString below, but
# initialize string in a random sequence.
sub makeRandomPuzzleString{
my ($size) = @_;
my $nrandomswaps = 2*$size*$size; # random pair exchanges.
my $sizesq = $size*$size;
my $tmpPuzzle = makePuzzleString($size);
for (my $i=0; $i<$nrandomswaps; $i++) {
my $first = int rand $sizesq;
my $second = $first;
while ($first == $second) {$second = int rand $sizesq; }
$tmpPuzzle = swapChars($tmpPuzzle,$first,$second);
}
return $tmpPuzzle;
}
# Usage: $puzzleString = makePuzzleString($size);
# Returns "ABCDEFGHIKLMNO-", $size*$size chars.
sub makePuzzleString {
my ($size) = @_;
my $char = "A";
my $ncells = $size * $size;
my $puzzlestring = "";
do {
$puzzlestring .= $char;
$char++;
} while length($puzzlestring) < ($ncells-1);
$puzzlestring .= "-";
return $puzzlestring;
}
# Usage: $puzzle = makePuzzle($puzzlestring);
# Returns a 2-dimensional array of chars,
# filling in $puzzlestring left-to-right and
# top-to-bottom.
sub makePuzzle {
my ($puzzlestring,$size) = @_;
my $puzzle;
# my $b = substring($puzzle,2,1); ######### UNCOMMENT THIS TO SEE CGI::Carp do its thing.
my $n=0;
for (my $y=0; $y<$size; $y++) {
for (my $x=0; $x< $size; $x++) {
$puzzle->[$y][$x] = substr($puzzlestring,$n,1);
$n++;
}
}
return $puzzle;
}
sub swapCharsUrl {
my ($row1,$col1,$row2,$col2) = @_;
my $newstring = $puzzlestring;
$newstring = swapChars($newstring, $col1+$size*$row1, $col2+$size*$row2);
return "";
}
sub tryDashAt {
my ($row,$col,$dr,$dc) = @_;
if ( $row+$dr eq $rowdash and $col+$dc eq $coldash ) {
print swapCharsUrl($row,$col,$row+$dr,$col+$dc);
print $puzzle->[$row][$col];
print "";
return 1;
}
else {
return 0;
}
}
# print the web page html for the puzzle.
sub printWebPage {
print $cgi->header;
print $cgi->start_html(
-title => "A Sliding Block Puzzle",
-alink => $linkcolor,
-link => $linkcolor,
-vlink => $linkcolor,
);
print "
A Sliding Block Puzzle -
click on one of the letters next to the hole
\n
";
print "
\n";
for (my $row=0; $row<$size; $row++) {
print "
";
for (my $col=0; $col<$size; $col++) {
my $char = $puzzle->[$row][$col];
$char = " " if $char eq "-";
print "
\n";
# Form pop-up and buttons to resize and scrable.
print "";
print $cgi->start_form;
print $cgi->popup_menu( -name => "sizePopUp",
-values => ["3","4","5"],
-default => $size );
print $cgi->submit("Change Size");
print $cgi->submit("Scramble");
print $cgi->end_form;
print $cgi->end_html;
}
__END__
=head1 NAME
slidingBlock.cgi implements the classic puzzle as a cgi webpage.
=head1 SYNOPSIS
Just point your web browser at it and let-er rip.
=head1 AUTHOR
Jim Mahoney (mahoney@marlboro.edu)
Marlboro College
=head1 SEE ALSO
perl, CGI.pm
=head1 COPYRIGHT
Copyright (c) 2001 Jim Mahoney
This software may be used and distributed under the same terms as Perl itself.
=cut