http://qs321.pair.com?node_id=11101663

The Times newspaper features an occasional "The Listener Crossword" which is in fact a numerically based logic puzzle in the form of a crossword. A friend of mine introduced me to the genera with #4321 which is a puzzle of two parts. The first part consists of populating the playing grid with hexadecimal numbers. The second part consist of using the populated grid to play a game of solitaire which, when played correctly on a correctly constructed grid ends up spelling out three words. There is a certain amount of trial and error involved in finding the solution!

So to aid playing the game in the second part of the puzzle I wrote the following script. The gameGrid is configured for a partial solution of the game. A feature of the code is that you can "save" the game state at any point then paste the saved gameGrid in place of the current grid to explore possibilities from that point.

As far as I can tell developing tools of this sort is all part of the solution domain for the puzzle. They are very much one off puzzles as each "crossword" is a puzzle of a completely different nature, so it is very unlikely that this tool will be useful for another "Crossword Puzzle". But it is a cool use for Perl!

Note that a few shortcuts have been taken in the code. In particular global variables are used, which I usually avoid. The rendered grid is not very pretty and the layout generally is rough, but good enough for the task at hand.

Play consists of clicking on a "peg" (piece to be moved) then an "empty" cell ("_") skipping over one intervening piece. The skipped piece is removed and added to the "skipped" string. Moves can be undone back to the starting state. For instructions beyond these you will need to find the original puzzle instructions and create the starting grid.

use strict;
use warnings;
use Tk;

my @gameGrid = ( # Word search start
    [qw(- - _ C C - -)],
    [qw(- - _ 0 _ - -)],
    [qw(D D 1 1 _ C A)],
    [qw(B _ 0 0 _ B F)],
    [qw(_ E _ C _ _ 0)],
    [qw(- - _ _ _ - -)],
    [qw(- - _ _ _ - -)],
    );
my $main = Tk::MainWindow->new(-title => "X4321");
my @rows;

for my $rowIdx (0 .. 6) {
    for my $colIdx (0 .. 6) {
        next if ($rowIdx < 2 || $rowIdx > 4) && ($colIdx < 2 || $colId
+x > 4);

        $rows[$rowIdx][$colIdx] = $main->Button(
            -textvariable => \$gameGrid[$rowIdx][$colIdx],
            -command => sub {onClick($rowIdx, $colIdx)}
        )->form(
            -top => $rowIdx * 20 + 2,
            -bottom => $rowIdx * 20 + 19,
            -left => $colIdx * 75 + 2,
            -right => $colIdx * 75 + 73
        );
    }
}

my @fromValue = '';
my $overValue = '';
my $lastToValue = '';
my $skipped = '';
my @stack;
my $topPix = 7 * 20 + 2;
my $botPix = 7 * 20 + 19;
my $fromField = $main->Label(-textvariable => \$fromValue[0])
    ->form(
        -top => $topPix, -bottom => $botPix,
        -left => 4, -right => 70
    );
my $overField = $main->Label(-textvariable => \$overValue)
    ->form(
        -top => $topPix, -bottom => $botPix,
        -left => 74, -right => 140
    );
my $toField = $main->Label(-textvariable => \$lastToValue)
    ->form(
        -top => $topPix, -bottom => $botPix,
        -left => 144, -right => 210
    );
my $skippedField = $main->Label(-textvariable => \$skipped)
    ->form(
        -top => $topPix, -bottom => $botPix,
        -left => 214, -right => 460
    );
my $undo = $main->Button(-text => 'undo', -command => sub {onUndo()})
    ->form(
        -top => $topPix, -bottom => $botPix,
        -left => 464, -right => 510
    );
my $save = $main->Button(-text => 'save', -command => sub {onSave()})
    ->form(
        -top => $topPix, -bottom => $botPix,
        -left => 514, -right => 560
    );

Tk::MainLoop();


sub onClick {
    my ($rowIdx, $colIdx) = @_;

    if (!$fromValue[0]) {
        $fromValue[0] = sprintf "%d, %d: %s", $rowIdx, $colIdx, $gameG
+rid[$rowIdx][$colIdx];
        $fromValue[1] = $rowIdx;
        $fromValue[2] = $colIdx;
        $lastToValue = '';
        return;
    }

    if ($rowIdx == $fromValue[1] && $colIdx == $fromValue[2]) {
        $fromValue[0] = '';
        return;
    }

    if (   !(  ($rowIdx == $fromValue[1] && abs($colIdx - $fromValue[2
+]) == 2)
            || ($colIdx == $fromValue[2] && abs($rowIdx - $fromValue[1
+]) == 2)
            )
        || $gameGrid[$rowIdx][$colIdx] ne '_'
        ) {
        $lastToValue = 'Invalid';
        return;
    }

    my $rowMid = ($rowIdx + $fromValue[1]) / 2;
    my $colMid = ($colIdx + $fromValue[2]) / 2;

    push @stack, [$gameGrid[$rowMid][$colMid], @fromValue[1, 2], $rowI
+dx, $colIdx];
    $skipped = join ' ', map {$_->[0]} @stack;
    $gameGrid[$rowIdx][$colIdx] = $gameGrid[$fromValue[1]][$fromValue[
+2]];
    $gameGrid[$rowMid][$colMid] = '_';
    $gameGrid[$fromValue[1]][$fromValue[2]] = '_';
    $fromValue[0] = '';
}


sub onUndo {
    return if !@stack;
    my $move = pop @stack;
    my ($delChar, $fromRow, $fromCol, $toRow, $toCol) = @$move;
    my $rowMid = ($fromRow + $toRow) / 2;
    my $colMid = ($fromCol + $toCol) / 2;

    $gameGrid[$fromRow][$fromCol] = $gameGrid[$toRow][$toCol];
    $gameGrid[$rowMid][$colMid] = $delChar;
    $gameGrid[$toRow][$toCol] = '_';
    $skipped = join ' ', map {$_->[0]} @stack;
    $fromValue[0] = '';
}


sub onSave {
    print "my \@gameGrid = (\n";

    for my $rowIdx (0 .. 6) {
        print "    [qw(";
        print join ' ', @{$gameGrid[$rowIdx]};
        print ")],\n";
    }

    print "    );\n";
}

[download]
Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond

Back to Cool Uses for Perl