Word Search Builder

[pbeckingham]

This is a word search program I wrote to generate word search grids interactively, which I then print out and give to my daughter, who loves them.

#! /usr/bin/perl
######################################################################
+##
## Program:     wordsearch
## Description: Interactively queries the user for words to add, then
##              adds and displays the modified grid.  On completion,
##              displays the grid and list of words within.
######################################################################
+##

use strict;
use warnings;
use Getopt::Long;

my $help;
my $width  = 20;
my $height = 20;
GetOptions ("help"     => \$help,
            "width=i"  => \$width,
            "height=i" => \$height);
if ($help)
{
  print <<EOHELP;
  Usage: ws [-width W] [-height H] [-help]

EOHELP
  exit 1;
}

# Orientations are thus:
#   7  0  1
#    \ | /
#  6 --.-- 2
#    / | \
#   5  4  3
my @xdelta = (0, 1, 1, 1, 0, -1, -1, -1);
my @ydelta = (-1, -1, 0, 1, 1, 1, 0, -1);

# Initialize the grid.
my @grid;
my @words;
initializeGrid (\@grid, $width, $height);
displayGrid (\@grid);
$| = 1;
srand (time);
my $command = '';
while (1)
{
  $command = getCommand ();
  last if $command eq 'quit';

  if ($command eq 'finish')
  {
    fillGapsInGrid (\@grid, $width, $height);
    displayGrid (\@grid);
    displayWords (\@words);
    last;
  }

  if ($command eq 'help' || $command eq '?')
  {
    print <<EOHELP;

The folllowing commands are supported:

  add <word>  adds the word to the grid, if possible
  help        displays this message
  ?           displays this message
  finish      fills in the remains of the grid, prints out grid and wo
+rds
  quit        quits program

EOHELP
    next;
  }

  my ($words) = $command =~ /^add (.+)$/;
  for my $word (split /\s+/, $words)
  {
    if (addWord (\@grid, $word))
    {
      push @words, $word;
      displayGrid (\@grid);
    }
    else
    {
      print "Could not add '$word'\n";
    }
  }
}

exit 0;

######################################################################
+##
sub initializeGrid
{
  my ($grid, $width, $height) = @_;
  for my $r (0 .. $height - 1)
  {
    $grid->[$r] = '.' x $width;
  }
}

######################################################################
+##
sub fillGapsInGrid
{
  my ($grid, $width, $height) = @_;
  my @alphabet = ('a' .. 'z');
  $_ =~ s/\./$alphabet[rand (26)]/eg for @$grid;
}

######################################################################
+##
sub displayGrid
{
  my ($grid) = @_;
  print "\n";
  for (@$grid)
  {
    my $row = $_;
    $row =~ s/(.)/ $1/g;
    print $row, "\n";
  }

  print "\n";
}

######################################################################
+##
sub displayWords
{
  my ($words) = @_;
  print "\n", join (', ', @$words), "\n";;
}

######################################################################
+##
sub getCommand
{
  my $input = '';

  while (1)
  {
    print "> ";
    $input = lc <>;
    chomp $input;

    return $input if $input =~ /^(?:quit|finish|help|\?|add .+)$/;
    print "Command '$input' not recognized\n" if $input;
  }
}

######################################################################
+##
sub addWord
{
  my ($grid, $word) = @_;

  # The random algorithm.
  for (0 .. $width * $height * 8)
  {
    my $x   = int rand $width;
    my $y   = int rand $height;
    my $dir = int rand 8;

    if (wordFits ($grid, $word, $x, $y, $dir))
    {
      insertWord ($grid, $word, $x, $y, $dir);
      return 1;
    }
  }

  # The exhaustive algorithm.
  for my $dir (0 .. 7)
  {
    for my $y (0 .. $height - 1)
    {
      for my $x (0 .. $width - 1)
      {
        if (wordFits ($grid, $word, $x, $y, $dir))
        {
          insertWord ($grid, $word, $x, $y, $dir);
          return 1;
        }
      }
    }
  }

  return 0;
}

######################################################################
+##
sub wordFits
{
  my ($grid, $word, $x, $y, $dir) = @_;
  #print "testing $word at [$x,$y] dir $dir\n";

  my $xi = $xdelta[$dir];
  my $yi = $ydelta[$dir];

  # Simple rejection based on length.
  my $endx = $x + (length ($word) - 1) * $xi;
  my $endy = $y + (length ($word) - 1) * $yi;
  return 0 if $endx >= $width  ||
              $endx < 0        ||
              $endy >= $height ||
              $endy < 0;

  for my $i (0 .. length ($word) - 1)
  {
    my $x0 = $x + ($i * $xi);
    my $y0 = $y + ($i * $yi);

    #print "looking for " . substr ($word, $i, 1) . " at $x0,$y0\n";
    return 0 if substr ($grid->[$y0], $x0, 1) ne '.' &&
                substr ($grid->[$y0], $x0, 1) ne substr ($word, $i, 1)
+;
  }

  return 1;
}

######################################################################
+##
sub insertWord
{
  my ($grid, $word, $x, $y, $dir) = @_;

  my $xi = $xdelta[$dir];
  my $yi = $ydelta[$dir];

  for my $i (0 .. length ($word) - 1)
  {
    my $x0 = $x + ($i * $xi);
    my $y0 = $y + ($i * $yi);

    my $row = $grid->[$y0];
    $row = substr ($row, 0, $x0) .
           substr ($word, $i, 1) .
           substr ($row, $x0 + 1, length ($row) - $x0 - 1);
    $grid->[$y0] = $row;
  }
}

######################################################################
+##

[Jaap]

Ok i had to run it to get it, but what this thing does is create grids like this:

l a r r y
r l l a w
e i e h o
p a k b v
m t m h f

where you can find words (tail, perl, larry, wall, bell) you entered (interactively). Quite well made.

[Fendaria]

Wonderful little program.

I couldn't help myself from noticing though you can combine your two loops in addWord if you randomize the order you brute force search. As long as your brute force search hits all possibilities, you can search in whatever order you want.

sub randomizeArray(@)
{
    my @array = @_;
    for my $i ( 1 .. $#array ) {
        my $j = int rand( $i + 1 );
        ( $array[$i], $array[$j] ) = ( $array[$j], $array[$i] );
    }
    return @array;
} ## end sub randomizeArray(@)

sub addWord
{
    my ( $grid, $word ) = @_;

    for my $dir ( randomizeArray( 0 .. 7 ) ) {
        for my $y ( randomizeArray( 0 .. $height - 1 ) ) {
            for my $x ( randomizeArray( 0 .. $width - 1 ) ) {
                if ( wordFits( $grid, $word, $x, $y, $dir ) ) {
                    insertWord( $grid, $word, $x, $y, $dir );
                    return 1;
                }
            }
        } ## end for my $y ( randomizeArray...
    } ## end for my $dir ( randomizeArray...

    return 0;
} ## end sub addWord

It would also be neat if you allowed for 'turns' when adding a word. ex. in a 2,2 grid allow the word 'perl' as

pe
rl

I think the game 'boggle' allows for word grids in this style.

[aufflick]

You're insane! Just as nuts as my girlfriend's flatmate who loves borderless jigsaws that come with extra pieces!

[pbeckingham]

Thanks! You're right about the ordering. As for the Boggle thing, I don't know how I might go about that.

[Anonymous Monk]

This is so cool! Thanks you so very much for putting this up. My children will love this. This is one of those things I keep saying I want to do, but for one reason or another never have had time to do right.

Do you mind if I put this up on a private website for their webring of friends (it is https and password protected, so not generally accessable)? I think their friends would like this also.

[pbeckingham]

You may do with this as you wish.

[Anonymous Monk]

See also find-a-func.

[halley]

An interesting sub-problem is to find the smallest possible grid that fits all of the given words.

A naive method would just try over and over at a given size until it hit some threshold: if a thousand attempts can't fit all ten words into the grid, then increase the grid slightly and go over it again. Maybe that's good enough.

The layout of crosswords are a similar problem, except that (1) words are either ACROSS or DOWN, (2) there must be a dead space between two words in the same row or column, and (3) extra letters or nonsense words made from the intersecting direction are not allowed; a dictionary can be consulted to see if intersecting words are actually real words. Often, the dead spaces are dictated beforehand, to arrange them attractively.

[pbeckingham]

It all seems to hinge on the random placement of the first few words. After that, it jams them in wherever it can. But those first few make all the difference.

A challenging crossword algorithm would be one that randomly places a word, then the necessary dead spaces, then replicates the dead space according to some rule of symmetry, ultimately resulting in an "attractive" layout.

[RolandGunslinger]

This is pretty sweet. I had started tinkering with the idea of doing this myself, but didn't get very far. The only other things I would do with this script is make it possible to produce a PDF including some kind of image along with the grid and list of words.

[wolfger]

i q o x e z f m j z q c
q q a x f d h y h h k n
b i f z u m r h t s n g
d g n m x g u b c z s e
d d p j e m y r j p t u
g x a c j s i k z z a b
e q v u n k m s y k r f
d d x j t n q x i c k z
m y i l p v e c y b f k
x g k j e w g v m q h w
q d x d v u w v r v k z
q y l h h p + + u l x n


++


You might want to accept only letters, though...

[pbeckingham]

Good point. Thanks.

[flounder99]