Wordscape - Anagram word search assistant

wordfind.pl

#!/usr/bin/perl

# Program to find all words from a given pool of letters. Written to solve the
# Android puzzle game "Wordscape".

use strict;
use warnings;

# Default Debian ispell dictionary
my $dict = "/etc/dictionaries-common/words";

# Evaluate arguments.
our $min;
my $letters = '';
foreach (@ARGV) {
    # If a minimum length is provided and not already defined, assign it.
    if ($_ =~ m/^-m=\d+$/ && !defined $min) {
        $min = $_;
        $min =~ s/-m=(\d+)/$1/;
    # Otherwise all letters get appended.
    } elsif ($_ =~ m/^[a-z]+$/) {
        $letters .= $_;
    # Non-alphabetical characters throw error.
    } else {
        print "Invalid argument: $_\n";
        usage();
    }
}

# If a minimum length is not provided, set to 1
if (!defined $min) {
    $min = 1;
}

# Die if no letters were provided
unless ($letters) {
    print "No input letters to evaluate\n";
    usage();
}

# Die if fewer letters than required
if ($min > (length $letters)) {
    print "Fewer letters of input than the minimum word length\n";
    usage();
}

# Push all letters into an array
my @l;
for (my $i = 0; $i < (length $letters); $i++) {
    push @l, (substr $letters, $i, 1);
}

# Pull entire dictionary into memory
open my $fh, '<', $dict;
my @words;
while (<$fh>) {
    push @words, $_;
}
close $fh;

# Search pattern for all letters that CAN appear
our @unique;
my $possible = '[' . $letters . ']';

# Search pattern for all letters that CANNOT appear
my $impossible = '[';
foreach my $alpha ('a' .. 'z') {
    my $skip = 0;
    foreach my $used (@l) {
        if ($alpha eq $used) {
            $skip++;
            last;
        }
    }
    unless ($skip) {
        $impossible .= $alpha;
    }
}
$impossible .= ']';

# Create empty nested arrays for valid words of all available lengths
our @keepers;
foreach (my $i = $min; $i <= (length $letters); $i++) {
    @keepers[$i] = ();
}

# Eliminate words that cannot match, add others to appropriate length array
# Searching a truncated list of just the right length words drastically improves
# efficiency
foreach (@words) {
    chomp $_;
    if ($_ =~ m/$possible/i && !($_ =~ m/$impossible/i)) {
        push @{$keepers[(length $_)]}, $_;
    }
}
undef @words;

our @found; # Global array for good matches

# Pass initial blank string and all available letters to recursive algorithm
recursive_search('',@l);

# Print all results
foreach (@found) {
    print $_ . "\n";
}

sub recursive_search {
    my ($pattern, @remaining) = @_;

    # Length of $pattern plus the one character tried this round
    my $len = (length $pattern)+1;

    # Get unique array so that the same word isn't searched twice
    my @unique;
    foreach my $let (@remaining) {
        my $skip = 0;
        foreach (@unique) {
            if ($_ eq $let) {
                $skip++;
                last;
            }
        }
        unless ($skip) {
            push @unique, $let;
        }
    }

    # Skip if pattern will not be at or above minimum defined
    if ( $len >= $min ) {
        # Try to append each of the remaining characters to the pattern
        foreach my $add (@unique) {
            foreach my $word (@{$keepers[$len]}) {
                if ($word =~ m/$pattern$add/i) {
                    push @found, $word;
                    last;
                }
            }
        }
    }

    # If there are still enough letters for another round, continue
    if (scalar @remaining > 1) {
        # Prevent repeating the next round for the same letter
        my @tried;
        for (my $i = 0; $i < (scalar @remaining); $i++) {
            my $skip = 0;
            foreach (@tried) {
                if ($remaining[$i] eq $_) {
                    $skip++;
                    last;
                }
            }
            if ($skip) {
                next;
            } else {
                push @tried, $remaining[$i];
                my $tmp_pattern = $pattern;
                my @tmp_array = @remaining;
                $tmp_pattern = $pattern.$remaining[$i];
                splice @tmp_array, $i, 1;
                recursive_search($tmp_pattern,@tmp_array);
            }
        }
    }
}

sub usage {
    print <<"EOF";

Usage: $0 [-m=N] any alpha  i n p u t

-m=N    Define a minimum word length to find. eg. -m=6

All alphabetical input is used on a letter-by-letter basis to find words. It
does not matter how they are spaced. However, any input that is not
alphabetical will throw an error. A lack of input will also throw an error.
Finally, a minimum word length longer than the input will throw an error.

EOF
    exit
}