#!/usr/bin/perl -w
#
# lexmorph - change word1 to word2
# tchrist@perl.com
# Mon Jul 27 09:24:41 MDT 1998

use strict;

my $DEFWORDS = '/usr/dict/words';

$| = 1;

my %Seen = ();
my @Dict;
my $Prune;
my $Wordfile;

use Getopt::Std;

my %Opt;
getopts('dnfimw:p:', \%Opt) or die <<EOUSAGE;
usage: $0 [-d] [-n] [-f] [-i] [-m] [-w Wordfile] [-p prunelevel]
    w	select alternate word list (default $DEFWORDS)
    i	allow capital letters
    n	don't prune heuristically
    m	minimize to N changes for N-letter words
    f   fork to go at both ends at once
    p	set prune depth (number of changes)
    d	print out debugging info
EOUSAGE

$Wordfile = $Opt{'w'} || $DEFWORDS;

die "need two args" unless @ARGV == 2;

my($wfirst, $wlast) = @ARGV;

die "$0: length($wfirst) != length($wlast)"
   unless length $wfirst == length $wlast;

load_dict(length $wfirst, $Wordfile);

push @Dict, $wfirst unless grep /^$wfirst$/, @Dict;
push @Dict, $wlast  unless grep /^$wlast$/,  @Dict;  # XXX: fix 2*O(N)

$Prune = do {
    $Opt{'m'} 	&& length($wfirst)	# N changes for N letters
		||
    $Opt{'p'} 	&& $Opt{'p'}		# set prune depth explicitly
		||
	2 * length $wfirst		# guess 2N changes for N letters
}; 

if ($Opt{'f'}) { 
    if (fork) { 
	change($wfirst, $wlast, 0);
    } else {
	change($wlast,  $wfirst, 0);
    } 
    wait;
} else {
    change($wfirst, $wlast, 0);
} 

exit;

sub load_dict {
    my $len      = shift || die "need length";
    my $dictfile = shift || die "need dict";
    local *DF;
    open(DF, $dictfile) || die "open $dictfile: $!";
    my $iflag = $Opt{'i'} ? '(?i)' : '';
    while (<DF>) { 
	if (length() == $len + 1 && /^[a-z]+$iflag$/o) { 
	    chop;
	    push @Dict, $iflag ? lc : $_;
	}
    }
    close DF;
} 

sub change {
    my($src, $dst, $at, @path) = @_;
    my $found = 0;

    if ($src eq $dst) {
	print "FOUND: " if $Opt{'d'};
	print "@path $src\n";
	$Prune = @path unless $Opt{'n'};	# shorten tree depth
	delete $Seen{$src};  	 # functions need continue{}s
	return 1;
    } 

    return 0 if @path > $Prune;

    # see whether the number of changes between src and dst are
    # farther away than our prune depth.   $common is how many
    # characters are the same at corresponding possitions
    my $common = @{[ ($src ^ $dst) =~ /\0/g ] };
    if (@path + length($dst) - $common > $Prune) {
	print "prune @path + $dst - $common > $Prune" if $Opt{'d'};
	return 0;
    } 

    print +(" " x @path) ."CHANGE " .   "$src => $dst (@path)\n"
	if $Opt{'d'};

    my (@good, @bad);

    # shuffle forward to make quick progress on "next" letter
    my @indices = (0 .. length($src) - 1);
    for (my $i = 0; $i <= $at; $i++)  {
	push(@indices, shift @indices);
    }

    # find all matches at this level before descending.
    # that way we can separate the likely paths from the longer ones.
    for my $i (@indices) { 
	my $pat = substr($src, 0, $i) . "[a-z]" .  substr($src, 1 + $i);
	my @words = grep /^$pat$/, @Dict;
	my %done = ( $src => 1);
	for (@words) {
	    next if $done{$_}++;  # needed for dups in wordlist
	    unless ($Seen{$_}) {  # no loops back 
		if (substr($_, $i, 1) eq substr($dst, $i, 1)) {
		    push @{ $good[$i] }, $_;	# closer to dest
		} else {
		    push @{ $bad[$i] }, $_;	# random change
		} 
	    }
	}
    } 

    if ($Opt{'d'}) { 
	print "$src: ";
	print join " ", map { @{ $good[$_] || []} } @indices;
	print " + ";
	print join " ", map { @{ $bad[$_] || []} } @indices;
	print "\n";
    }

    # now recurse on the good list followed by the bad one.
    # the good list moves us immediately closer to the dest
    for my $ap ( \@good, \@bad ) { 
	for my $i (@indices) { 
	    my @res = @{ $ap->[$i] || [] };
	    for my $word (@res) {
		$Seen{$src} = 1;
		$found += change($word, $dst, $i, @path, $src);
		$Seen{$src} = 0;
	    } 
	}
    }

    return $found;
}