Saturday, September 18, 2010

Knight's Tour Puzzle: perl on CalTrain

I wrote this on the ride home. I makes Knight's Tour Puzzles. This is a puzzle with a grid of letters, encoding a message that you discover by moving from square to square as a knight would in chess, never hitting the same square twice.

knightstour.pl:

#!/usr/local/bin/perl -w
use strict;
my $usage = "knightstour.pl ROWS COLS MESSAGE\n";
die $usage unless @ARGV == 3;

#main
{
    my( $numrows, $numcols, $message ) = @ARGV;

    my @letters = split //, $message;
    die "length of $message = ",scalar(@letters)," must be ",
      $numrows*$numcols,"\n"
      if @letters != $numrows * $numcols;

    # store grid in hash; $grid->{"0,0"} = "x";
    my $grid = {};

    # starting position.  use upper left corner.  could randomize
    my $row = 0;
    my $col = 0;

    # recursively look for solutions
    trypath( $grid, \@letters, $numrows, $numcols, $row, $col );
}

# look for a path
sub trypath {
    my( $gridref, $lettersref, $numrows, $numcols, $row, $col ) = @_;

    # make local copy of grid, letters-to-do list
    my $grid = { %$gridref };
    my $letters = [ @$lettersref ];

    # remove 1st letter from letter list.  store in a square
    $grid->{"$row,$col"} = shift @$letters;

    # if no more letters, print solution
    if( !@$letters ) {
        printgrid( $grid, $numrows, $numcols );

    # otherwise try possible next moves
    } else {

        # find possible next moves
        foreach (
          grep {
            # square under consideration actually on the grid
            $_->[0] >= 0
            && $_->[0] < $numrows
            && $_->[1] >= 0
            && $_->[1] < $numcols
            # no letter on it yet
            && !defined $grid->{"$_->[0],$_->[1]"}
          }
          # possible knight's moves
          [ $row-1, $col-2 ],
          [ $row-1, $col+2 ],
          [ $row+1, $col-2 ],
          [ $row+1, $col+2 ],
          [ $row-2, $col-1 ],
          [ $row-2, $col+1 ],
          [ $row+2, $col-1 ],
          [ $row+2, $col+1 ] ) {
            # try it
            trypath( $grid, $letters, $numrows, $numcols, $_->[0], $_->[1] );
        }
    }
}

sub printgrid {
    my( $grid, $numrows, $numcols ) = @_;
    for( my $row = 0; $row < $numrows; ++$row ) {
        for( my $col = 0; $col < $numcols; ++$col ) {
            print $grid->{"$row,$col"} || "_", " ";
        }
        print "\n";
    }
    print "\n";
}

Some sample results:

i i u k i 
b e l a n 
n s d k i 
s e e a r 
s s t b s

y e o e c m h 
o i a m c s o 
t u c k l o y

CS people have worked out interesting and more efficient solutions to this problem, but this script is fine for generating puzzles small enough for a human to actually solve.

6 comments:

Yokota Fritz said...

and now you've got me debugging your code; it doesn't work for me -- just iterates through trypath() once for each row and exits with no output. Likely a faulty cut/paste somewhere leading to early exit from the recursion, but I haven't figured out where yet.

Nick said...

What input are you giving it?

There might not actually be a solution.

4x4 grids, for example, do not. I spent a while debugging before I figured that out!

Yokota Fritz said...

Oh.

What should my input look like?

Nick said...

(I just meant the command line here--it doesn't read anything from STDIN).

Here's a sample that works:

./knightstour.pl 5 5 abcdefghijklmnoqrstuvwxyz

Yokota Fritz said...

Ah yes, tis a happy camper now.

Nick said...

Cool!

Hey, post a puzzle, and I'll try to solve it.