#!/usr/local/bin/perl
# ========================================================================
# scramble_solver - solve Zynga "Word Scramble" word game
# Andrew Ho (andrew@zeuscat.com)
#
# This program contains embedded documentation in Perl POD (Plain Old
# Documentation) format. Search for the string "=head1" in this document
# to find documentation snippets, or use "perldoc" to read it; utilities
# like "pod2man" and "pod2html" can reformat as well.
#
# $Id: scramble_solver,v 1.4 2010/04/02 05:57:14 andrew Exp $
# ========================================================================

=head1 NAME

scramble_solver - solve Zynga "Word Scramble" word game

=head1 SYNPOSIS

    % scramble_solver [-h] [-v] [-d dictfile] [-m minlen] [puzzle]

=head1 DESCRIPTION

This program outputs solutions for the Zynga "Word Scramble" games, in
particular, the iPhone game known as "Scramble 2"
(L<http://www.zynga.com/games/index.php?media=iphone&game=wordscramble>).
This game outputs a 4x4 grid of letters, and challenges the player to
find words of 3 letters or longer that are contiguous in the grid (in
any direction, including diagonals). Another similar game is Boggle.

A puzzle is represented by the 16 letters that result from reading from
left to right, top to bottom from the grid. Letter case and
non-alphabetic characters are ignored. For example, consider the
following puzzle, whose solutions include C<GLOP>, C<INK>, C<KNIFE>, and
C<MINK>:

    ABCD
    EFGH
    IJKL
    MNOP

This puzzle can be represented equivalently by any of the following:

=over 4

=item C<ABCDEFGHIJKLMNOP>

=item C<abcdefghijklmnop>

=item C<abcd efgh ijkl mnop>

=item C<((a,b,c,d), (e,f,g,h), (i,j,k,l), (m,n,o,p))>

=back

Note that the single input letter C<Q> (or C<q>) represents the
two-letter sequence C<Qu>, to match the rules from Word Scramble.

There are no required command line options, but the solver will not work
without a dictionary file and a puzzle. The default dictionary is
F</usr/share/dict/words> (but see the warning below), and if no puzzle
is given on the command line, the user is interactively prompted for it.

The following options are available:

=over 4

=item -h

Display a usage message and exit.

=item -v

Enable verbose mode. In addition to printing out words found, print some
status messages, and a full board representation to stderr on each word
found. For example, for the word C<KNIFE> the following might be the
output:

    KNIFE
    -----
    abcd
    EFgh
    IjKl
    mNop

Letters that are in the word are shown in uppercase; other letters are
shown in lowercase. This mode is useful for debugging, and for quickly
finding a long word in a puzzle.

=item -d I<dictfile>

Load the words from the dictionary file I<dictfile>. The dictionary
should have one word per line. The default is F</usr/share/dict/words>.
Note that Unix dictionary files are typically quite different from
Scrabble dictionaries.

I<dictfile> may also be a BerkeleyDB file, in which case, it is assumed
that it already contains uppercase words and prefixes. You can use the
dict2db program (see L<dict2db>) to generate a BerkeleyDB file from a
text dictionary file:

    % dict2db -a -u -p dictionary.txt dictionary.db

Scrabble dictionaries are usually copyrighted, but, you can find some
free versions online; for example, the one at
L<http://www.calvin.edu/~rpruim/scrabble/ospd3.txt>.

=item -m I<minlen>

Only output words that are longer than I<minlen> letters or longer. The
default is 3 letters. This is useful for finding long words to get
higher points or trophies.

=back

=head1 COPYRIGHTS

This code is copyright (C) 2010 Andrew Ho, commercial rights reserved.
Zynga, iPhone, Boggle, Scrabble, Unix, and all other copyrights,
trademarks, and service marks are the respective property of their
holders.

=head1 AUTHOR

Andrew Ho E<lt>F<andrew@zeuscat.com>E<gt>

=cut


# ------------------------------------------------------------------------
# Libraries, globals, and constants

require 5.6.0;
use warnings;
use strict;
$| = 1;

use File::Basename qw(basename);
use Getopt::Long qw(GetOptions);
use BerkeleyDB qw(DB_RDONLY);

# User configurable options
our $Verbose = 0;
our $Dictionary_File = '/usr/share/dict/words';
our $Min_Word_Length = 3;
our $Puzzle;

# Record which words we already found, to avoid duplicates
our %Found_Word;

# Our puzzles are fixed at 4x4
our $PUZZLE_ROWS = 4;
our $PUZZLE_COLS = 4;
our $PUZZLE_LEN = $PUZZLE_ROWS * $PUZZLE_COLS;

# Precomputed constant table mapping each 4x4 index to its neighboring indices
our @NEXT_NEIGHBORS = (
  [1,4,5],       [0,2,4,5,6],           [1,3,5,6,7],           [2,6,7],
  [0,1,5,8,9],   [0,1,2,4,6,8,9,10],    [1,2,3,5,7,9,10,11],   [2,3,6,10,11],
  [4,5,9,12,13], [4,5,6,8,10,12,13,14], [5,6,7,9,11,13,14,15], [6,7,10,14,15],
  [8,9,13],      [8,9,10,12,14],        [9,10,11,13,15],       [10,11,14],
);

# Constants for command line help
our $ME = basename $0;
our $USAGE = "usage: $ME [-h] [-v] [-d dictfile] [-m minlen] [puzzle]\n";
our $FULL_USAGE = $USAGE . << "EndUsage";
    -h             display this help text and exit
    -v             verbose output, show extra output on stderr
    -d dictfile    dictionary file (default $Dictionary_File)
    -m minlen      only words of this length or more (default $Min_Word_Length)
    puzzle         puzzle ($PUZZLE_LEN letters, left to right, top to bottom)
EndUsage


# ------------------------------------------------------------------------
# Parse command line options, intialize word map from dictionary

{
    # Promote contextless Getopt::Long warnings to nicely formatted die()s
    local $SIG{__WARN__} = sub {
        my $errmsg = lcfirst join '', @_;
        chomp $errmsg;
        die "$ME: argument parsing error: $errmsg\n$USAGE";
    };
    my $help;
    GetOptions(
        'help'         => \$help,
        'verbose'      => \$Verbose,
        'dictionary=s' => \$Dictionary_File,
        'minlength=i'  => \$Min_Word_Length,
    );
    if($help) {
        print $FULL_USAGE;
        exit 0;
    }
}

# Init word map: keys exist for word prefixes, have true value for full words
print STDERR "Initializing dictionary from $Dictionary_File...\n" if $Verbose;
our $Word_Map = word_map($Dictionary_File);
if($Verbose) {
    my $nwords = scalar keys %$Word_Map;
    printf STDERR "Loaded %d word%s from dictionary file.\n\n",
        $nwords, $nwords == 1 ? '' : 's';
}

# Get puzzle from command line, or prompt interactively for one
if(@ARGV) {
    warn "$ME: ignoring extra command line arguments\n" if @ARGV > 1;
    $Puzzle = shift @ARGV;
} else {
    print STDERR
        "Enter puzzle ($PUZZLE_LEN letters, left to right, top to bottom):\n";
    $Puzzle = '';
    while(<STDIN>) {
        s/[^a-z]+//gi;
        $Puzzle .= $_;
        last if length($Puzzle) >= $PUZZLE_LEN;
    }
}

# Normalize puzzle and check for validity
$Puzzle = uc $Puzzle;
$Puzzle =~ s/[^A-Z]+//g;
if(length($Puzzle) < $PUZZLE_LEN) {
    die "$ME: invalid puzzle (need at least $PUZZLE_LEN letters)\n";
} elsif(length($Puzzle) > $PUZZLE_LEN) {
    warn "$ME: ignoring extra letters, using first $PUZZLE_LEN\n";
    $Puzzle = substr($Puzzle, 0, $PUZZLE_LEN);
}


# ------------------------------------------------------------------------
# Main loop

# Generate initial states, recursively handle each one
foreach my $state (initial_states($Puzzle)) {
    handle_state($state);
}

exit 0;


# ------------------------------------------------------------------------
# State management functions

# initial_states($puzzle) returns a list of $NUM_PUZZLES states, each
# with a single starting point (one of the letters in the puzzle) marked
# as visted.

sub initial_states {
    my $puzzle = shift;
    die 'missing required puzzle argument' if !defined $puzzle;
    die 'invalid puzzle' if $puzzle !~ /^[A-Z]{$PUZZLE_LEN}$/o;
    my @states;
    my @letters = map { $_ eq 'Q' ? 'QU' : $_ } split //, $puzzle;
    foreach my $i (0 .. $#letters) {
        my @state = map { [$_, 0] } @letters;
        $state[$i]->[1] = 1;
        push @states, \@state;
    }
    return @states;
}


# handle_state($state) recursively finds the next possible states that
# can be generated from $state, printing unique words that were found as
# they are encountered.

sub handle_state {
    my $state = shift;
    die 'missing required state argument' if !defined $state;
    die 'invalid state' if ref($state) ne 'ARRAY' || @$state != $PUZZLE_LEN;
    my @visited_idxes = grep { $state->[$_]->[1] } 0 .. $#$state;
    my $base_word = join '',
         map { $state->[$_]->[0] }
        sort { $state->[$a]->[1] <=> $state->[$b]->[1] }
             @visited_idxes;
    my %idx_is_visited = map { ($_ => 1) } @visited_idxes;
    my $max_idx =
        (sort { $state->[$b]->[1] <=> $state->[$a]->[1] } @visited_idxes)[0];
    my @candidate_idxes = grep { !$idx_is_visited{$_} }
                               next_neighbors($max_idx);
    my @next_states;
    foreach my $idx (@candidate_idxes) {
        my $word = $base_word . $state->[$idx]->[0];
        if(is_word_prefix($word)) {
            my $new_state = duplicate_state($state);
            $new_state->[$idx]->[1] = $state->[$max_idx]->[1] + 1;
            if(is_full_word($word)) {
                unless($Found_Word{$word}) {
                    print $word, "\n";
                    if($Verbose) {
                        print STDERR $word, "\n" if !-t STDOUT;
                        print STDERR '-' x length($word), "\n";
                        print_states($new_state);
                        print STDERR "\n";
                    }
                    $Found_Word{$word} = 1;
                }
            }
            handle_state($new_state);
        }
    }
}


# Create a copy of a state (deep-copy $state).

sub duplicate_state {
    my $state = shift;
    die 'missing required state argument' if !defined $state;
    die 'invalid state' if ref($state) ne 'ARRAY' || @$state != $PUZZLE_LEN;
    my @new_state;
    foreach my $tuple (@$state) {
        my @new_tuple = ($tuple->[0], $tuple->[1]);
        push @new_state, \@new_tuple;
    }
    return \@new_state;
}


# Print a human-readable representation of a state to stderr, useful for
# debugging or in verbose mode. Letters that are visited are printed in
# uppercase, other letters are printed in lowercase.

sub print_states {
    my @states = @_;
    return unless @states;
    foreach my $row (0 .. $PUZZLE_ROWS - 1) {
        foreach my $sidx (0 .. $#states) {
            foreach my $col (0 .. $PUZZLE_COLS - 1) {
                my $tuple = $states[$sidx]->[($row * $PUZZLE_ROWS) + $col];
                print STDERR $tuple->[1] ? uc($tuple->[0]) : lc($tuple->[0]);
            }
            print STDERR $sidx == $#states ? "\n" : ' ';
        }
    }
}


# ------------------------------------------------------------------------
# Helper functions

# word_map($filename) returns a hash reference which is a word map
# generated by loading the newline-separated words in $filename. A hash
# entry is generated for every word and word prefix from the dictionary
# file; hash values are true if the entry is a complete word.
#
# $filename may also be a BerkeleyDB file, in which case, it is assumed
# that it already contains the pregenerated, uppercase, alpha-only
# entries with prefixes that the word map is expected to contain. The
# related dict2db program ("dict2db -a -u -p input.txt output.db) can be
# used to pregenerate the BerkeleyDB file.

sub word_map {
    my $filename = shift;
    die 'missing required dictionary filename argument' if !defined $filename;
    my %word_map;

    my $opened_db;
    eval {
        $opened_db = tie %word_map, 'BerkeleyDB::Hash',
            -Filename => $filename, -Flags => DB_RDONLY;
    };
    unless($opened_db) {
        my $errstr = $BerkeleyDB::Error || $! || 'unknown error';
        if($errstr eq "$filename: unexpected file type or format") {
            open my $fh, '<', $filename
                or die "$ME: could not open $filename: $!\n";
            while(<$fh>) {
                s/^\s+//; s/#.*$//; s/\s+$//; next unless /\S/;
                my $word = uc $_;
                $word_map{$word} = 1;
                while(length($word) > 1) {
                    $word = substr($word, 0, length($word) - 1);
                    $word_map{$word} = 0 unless exists $word_map{$word};
                }
            }
            close $fh;
        } else {
            die "$ME: could not open $filename: $errstr\n";
        }
    }
    return \%word_map;
}


# is_word_prefix($str) returns true if the given $str exists in the
# global $Word_Map hash (that is, if $str is a word prefix or word).

sub is_word_prefix {
    my $str = shift;
    die 'missing required string argument' if !defined $str;
    return 1 if exists $Word_Map->{$str};
    return;
}


# is_word_prefix($str) returns true if the given $str exists in the
# global $Word_Map hash, has a true value, and is greater than the
# minimum word length (that is, if $str is a complete word that should
# be output as a solution).

sub is_full_word {
    my $str = shift;
    die 'missing required string argument' if !defined $str;
    return 1 if $Word_Map->{$str} && length($str) >= $Min_Word_Length;
    return;
}


# next_neighbors($idx) returns the set of indices that are the neighbors
# to the letter at index $idx. These are precalculated for a 4x4 grid in
# the global @NEXT_NEIGHBORS list.

sub next_neighbors {
    my $idx = shift;
    die 'missing required index argument' if !defined($idx);
    die 'non-numeric index argument' if $idx !~ /^\d+$/;
    die 'index argument out of range' if $idx > $#NEXT_NEIGHBORS;
    return @{$NEXT_NEIGHBORS[$idx]};
}


# ========================================================================
__END__