#!/usr/local/bin/perl -w

# I don't know if this is true but we've only tested it on 5.00x.
require 5.0;

$VERSION="1.0";

# defaults
$useplurals = 0;
$firstsolution = 0;
$maxtime = 0;
$dictionary="/usr/dict/words";

$|++; # unbuffer output

# if REQUEST_METHOD is defined we assume this is being run as a CGI script
$usecgi = $ENV{'REQUEST_METHOD'};

if ($usecgi) { cgi_init (); }
else {
  use Getopt::Long;

  # Parse arguments
  $Getopt::Long::autoabbrev = 1; # Allow unique abbreviations (default)
  $Getopt::Long::ignorecase = 0; # Do NOT ignore case (not default)
  GetOptions ("useplurals|P!" => \$useplurals,
	      "firstsolution|F|1!" => \$firstsolution,
	      "maxtime=i" => \$maxtime,
	      "version" => sub { print STDERR "$0 version $VERSION\n"; exit 0;},
	      "help" => \&usage,
	      "dictionary|d=s" => \$dictionary,
	     ) or usage ();

  usage () unless (@ARGV == 3);

  $start = shift;
  $result = shift;
  $steps = shift;
  $par = "\n";
}

# Check for errors in the input
$len = length ($start);
if ($len != length ($result)) {
  print_error ("Start word and end word must be the same length.");
  usage ();
}

unless ($steps =~ /^\d+$/) {
  print_error ("Number of steps ($steps) is not numeric.");
  usage ();
}


print "Reading dictionary . . . Ignoring capitals . . . ";
open DICT, "< $dictionary" or die "Could not open dictionary '$dictionary'";
while (<DICT>) {
  chomp;
  if (length ($_) == $len-1) {
    $shortwords{$_}='';
    next;
  }
  $words{$_} = '' if (length ($_) == $len and $_ =~ /^[a-z]+$/);
}
close DICT;
print ". . . Dictionary read.$par";

unless ($useplurals) {
  print "Removing plurals . . .$par";
  foreach $k (keys %words) {
    delete $words{$k} 
    if ($k =~ /s$/ and defined ($shortwords{substr($k,0,$len-1)}));
  }
}
undef %shortwords; # Free the memory?

unless (defined ($words{$start})) {
  print_error ("Start word '$start' NOT in dictionary\n");
  usage ();
}

unless (defined ($words{$result})) {
  print_error ("End word '$result' NOT in dictionary\n");
  usage ();
}

@words = keys %words;
@got = ();

print "There are ", scalar (keys %words), " words in the list$par$par";

# Abort gracefully on certain signals.
$SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = \&abort_search;
# Print status on HUP signal.
$SIG{'HUP'} = \&print_nsolutions;

# Use an alarm to abort after a fixed amount of real time.
if ($maxtime > 0) {
  $SIG{'ALRM'} = \&abort_search;
  alarm $maxtime;
}

$success = 0;

print "<PRE>\n" if ($usecgi);

while (testwd ($start, $steps+1, $result)) {
    $success++;
    print "$start @got $result$par";
    last if ($firstsolution);
}

print "\n";
print_nsolutions ();

cgi_end () if ($usecgi);


sub testwd {
  my ($wd, $level, $result, @have) = @_;
  --$level;

  if ($level < $len-1 ) { #test to see if this can possibly match
    my (@empty) = ();
    putDots ($len-$level, 0, $result, \@empty);
    $mustmatch = join "|", @empty;
    return 0 unless ($wd =~ /$mustmatch/);
  }
  
  push @have, $wd;
  @empty=();
  putDots (1, 0, $wd, \@empty);
  $regex = join "|", @empty;

  my (@list) = ();

  # Saves the list for future use
  if (!defined $grepped{$wd}) {
      @list  = grep /^$regex$/, @words;
     $grepped{$wd} = join ":", @list;
  } else {
     @list = split /:/, $grepped{$wd};
  }


  $regex = join "|", @have;
  @list = grep !/^$regex$/, @list;
  return scalar (grep /^$result$/, @list) if ($level == 1);

  @list = grep (!/^$result$/, @list); # if ($level != 1);

  # If there is anything in the got list use it to start the new search
  if (@got) {
    my $sword = shift @got;
    while (@list) { last if ($list[0] =~ /^$sword$/); shift @list; }
    shift @list if (@got == 0); # step past the last good word in chain
  }

  foreach $k (@list) {
    next if (vec ($words{$k}, $level, 2) & 1);
    if (testwd ($k, $level, $result, @have)) {
      vec ($words{$k}, $level, 2) = 2; # mark word as a solution
      unshift @got, $k;
      return 1;
    }
    vec ($words{$k}, $level, 2) = 1 # Prune word from this level 
      unless (vec ($words{$k}, $level, 2) & 2); # unless it was a prev soln
  }
  return 0;
}

sub usage () {
  if ($usecgi) { cgi_end ();}
  else {
    print STDERR "Usage: $0 [options] <start word> <end word> <number of steps>\n";
    print STDERR "   Options:\n\t--[no]useplurals, -P:\tAllow plurals in solution\n";
    print STDERR "\t--[no]firstsolution, -F, -1:\tOnly find first solution\n";
    print STDERR "\t--maxtime <seconds>:\tMaximum actual time for search (<=0 = forever)\n";
    print STDERR "\t--dictionary, -d <file>:\tFile to use as word list\n";
    print STDERR "\t--version, -v:\tPrint version information\n";
    print STDERR "\t--help, -h:\tThis help message\n";
    exit 1;
  } 
}


sub putDots {
  my($level,$pos,$word,$array_ref) = @_;
  --$level;
  ++$pos;
  
  $n = length($word);
      
  if ($level==-1) {
      push @$array_ref, $word;
      return $array_ref;
  } 

  my($i);
  for ($i = $pos; $i <= $n - $level; $i++){
      $tmpwd = $word;
      substr($tmpwd,$i-1,1) = ".";
      putDots($level,$i,$tmpwd,$array_ref);
  }
}


sub print_nsolutions {
  print $par, "A total of $success solution", ($success != 1 ? "s" : ""), " found!$par";
}

sub abort_search {
  print_nsolutions ();
  print ". . . Aborting\n";
  cgi_end () if ($usecgi);
  exit 0;
}

# Routine to print errors
sub print_error {
  my $err;
  foreach $err (@_) {
    if ($usecgi) { print "<P>ERROR<P>$err<P>ERROR<P>\n"; }
    else { print STDERR "\nError: $err\n\n"; }
  }
}


# Gets the html started and prints the form
sub cgi_form {
  print $query->header;
  print $query->start_html(-title=>'Toggle Solver',
                           -meta=>{'keywords'=>'word games dictionary'},
                           -author=>'cjc5@po.cwru.edu,pete@theory2.phys.cwru.edu');

  cgi_info ();

  print $query->startform(-method=>'get');
  print "Beginning Word: ";
  print $query->textfield(-name=>'start',
                  -default=>'loss',
                  -size=>20,
                  -maxlength=>20);
  print "  Ending Word: ";
  print $query->textfield(-name=>'result',
                  -default=>'gain',
                  -size=>20,
                  -maxlength=>20);
  print "  Number of Steps: ";
  print $query->textfield(-name=>'steps',
                  -default=>'6',
                  -size=>2,
                  -maxlength=>2);
  print $query->submit("submit","submit");
  print $query->endform();
  print "<p>Click submit to send your query, the solution will appear below.";
  print "<P><hr>";
}


# info about the game
sub cgi_info {
  print "<H1>Toggle (version $VERSION)</H1>\n";
  print <<'EOD';
<A HREF="http://erebus.phys.cwru.edu/~copi/">
Craig J Copi</a> and <a href="http://theory2.phys.cwru.edu/~pete/">
Pete Kernan</a> bring you the Toggle solver.<p>
You know the game. How many steps does it take to get from
one word to another by changing a single letter at a time?. Or put another
way, can you find out how to get from word <strong> a </strong> to
word <strong> b </strong> in <strong> x </strong> number of steps?
Here we find all the possible solutions, or at least as many as we 
want to waste cycles on.<p>
The <A HREF="http://www.perl.com">Perl</A> code for Toggle and 
other <a href="http://erebus.phys.cwru.edu/~copi/wordgames.html">word games</a>
is available 
so you can let it run for days...like we do! 
On a huge dictionary....like we do! Really, after finding that there were
more than 4.6 million ways to get from loss to gain in 10 steps, we
stopped the program (it took 18 hours to get that many).
Small dictionary here, sorry.<p>
Note that we prune plurals from the dictionary and abort the search after a 
fixed amount of time.  If you want to have more freedom in the choice of 
dictionary and be able to find all possible solutions then you better
<a HREF="http://erebus.phys.cwru.edu/~copi/wordgames.html">grab the code</A>
yourself.
<P><HR><P>
EOD
}

# initializes the CGI
sub cgi_init {
  use CGI;

  # set a low priority
  setpriority 0, 0, getpriority (0, 0) + 19;

  $query = new CGI;
  @names = $query->param;

  # get the html information started
  cgi_form ();

  # if there isn't anything in @names then end things now
  cgi_end () if (@names < 2);

  $maxtime = $query->param('maxtime');
  if (!$maxtime) {$maxtime = 60;}
  if ($maxtime > 60) {$maxtime = 60;}

  $start = $query->param('start');
  $result = $query->param('result');
  $steps = $query->param('steps');
  $par = "<br>";
}


sub cgi_end {
  print "</PRE><P><HR>\n";

  print $query->end_html;
  exit 0;
}