#!perl -w

# settings

our $default_dictname = "/home/ambrus/a/qotw/e22/words-b";


# 0. Declarations

use warnings; use strict;
use IO::Handle;


# 1. Parse argv

our($dictname, $noproper, $word1o, $word2o, $debug, $unoptimize, $unoptimize2);
{
	use Getopt::Std;
	getopts "luUw", \my %switch;
	($noproper, $debug, $unoptimize, $unoptimize2) = @switch{qw(l w u U)};
	2<=@ARGV && @ARGV<=3 or die "Usage: ladder -d dictfile word1 word2";
	($word1o, $word2o, $dictname) = @ARGV;
	defined($dictname) or $dictname = $default_dictname;
}


# 2. Locale-dependent functions

{ 
use locale;
my $re = qr/\A[[:alpha:]]+\z/;
$noproper and $re = qr/\A[[:lower:]]+\z/;
sub checkword {	
	my($w) = @_;
	$w=~$re ? 1 : 0; 
}
# You might want to treat some letters the same (especially in French).
# In that case, change the following function accordingly.  The function must
# not change the lenght of the word or else the program will break.
sub normalize { 
	lc $_[0];
}
}

# 3. Do some simple checking on the words

our($length, $word1, $word2);

sub addword;
do {
	checkword($word1o) && checkword($word2o) or 
		die "one of the given words contain illegal characters";
	length($word1o)==length($word2o) or
		die "it is impossible to build a word ladder, as the two words are of different length\n";
	$length = length($word1o);
	$word1 = normalize($word1o);
	addword $word1, $word1o;
	$word2 = normalize($word2o);
	addword $word2, $word2o;
	$word1 eq $word2 and do {
		print $word1, "\n";
		exit 0;
		};
};

# 4. Read and process the dictionary
# this should be really simple, but the code somehow became a mess. 

our %word; # this hash contains the original forms of a word
our $dict; # a filehandle

sub addword;
do {
	open $dict, "<", $dictname or die qq{cannot open dictionary file "$dictname": $!};
	$debug and warn qq{dictionary file "$dictname" open};
};

sub addword { # $w should be eq normalize($o)
	my($w, $o) = @_;
	defined($word{$w}) or
		$word{$w} = $o;
	}

sub readdict {
	no locale;
	my($until) = @_;
	my($w, $l);
	$! = 0;
	while (defined($l = <$dict>)) {
		chomp $l;
		length($l)==$length or next;
		checkword $l or next;
		$w = normalize($l);
		$w lt $until or last;
		addword $w, $l;
		}
	error $dict and die qq{error readig dictionary file "$dictname": $!}; # see "http://www.perlmonks.com/?node_id=386996"
	$debug and warn "there are ", (0+keys(%word)), " words in the hash now";
}


# 5. Optimization: not to read the whole word list unless neccessary

our $phase;
sub seekpart; sub makepatts; sub dosearch; sub seekpart;

sub readpart {
	my($prefix) = @_;
	defined($prefix) or $prefix = "";
	seekpart $prefix;
	readdict $prefix . "\xff\xff\xff"; # yes, this is a kludge, but I hope no word will have a triple \xff in it.
}

sub seekpart {
	my($prefix) = @_;
	my($l, $w);
	my($a, $b) = (0, -s $dict);
	defined($b) or die qq{error fstating the dictionary file "$dictname": $!};
	until ($b-$a<=2048) {
		my $c = int(($a + $b)/2);
		seek $dict, $c, 0 or
			die qq{error seeking the dictionary file "$dictname" to $c during bsearch: $!};
		$! = 0;
		$l = <$dict>; # get aligned to a newline
		chomp($l = <$dict>) until
			checkword $l or !defined($l);
		error $dict and
			die qq{error reading the dictionary file "$dictname" during bsearch: $!};
		$w = defined($l) ? normalize($l) : ("\xff" x 6);
		($w gt $prefix) ? $b : $a = $c;
	}
	$debug and warn qq{bsearch done ("$prefix" $a)};
	seek $dict, $a, 0 or
		die qq{error seeking the dictionary file "dictname" to $a, during bsearch, final:
$!};
	$a>0 and do { # IMPORTANT!
		<$dict>;
		error $dict and 
			die qq{error reading the dictionary file "$dictname" during bsearch, final align:
$!}
		};
}

our %readpart;
sub condreadpart {
	my($l) = @_;
	unless ($readpart{$l}) {
		$debug and warn qq{processing prefix "$l" from the dictionary};
		readpart $l;
		$readpart{$l} = 1;
	}
}

ALL: {
	if (!$unoptimize) {
		if (!$unoptimize2) {
			$phase = 2;
			condreadpart substr($word1, 0, 2);
			condreadpart substr($word2, 0, 2);
			condreadpart substr($word1, 0, 1) . substr($word2, 1, 1);
			condreadpart substr($word2, 0, 1) . substr($word1, 1, 1);
			makepatts;
			dosearch;
		}
		$phase = 1;
		condreadpart substr($word1, 0, 1);
		condreadpart substr($word2, 0, 1);
		makepatts;
		dosearch;
	}
	$phase = 0;
	$debug and warn "processing the whole dictionary";
	readpart "";
	makepatts;
	close $dict or die qq{error closing dictionary file "$dictname": $!};
	dosearch;
}


# 6. Create helper table so that we can find adjacent words faster

our %patt;

sub makepatts {
	%patt = ();
	for my $w (keys %word) {
		for my $n (0..length($w)-1) {
			my $p = substr($w, 0, $n) . "." . substr($w, $n+1);
			push @{$patt{$p}}, $w;
		}
	}
	$debug and warn "there are ", (0+keys(%word)), " patterns in the hash now";
}

# 7. Do the actual search

our @qu; # the queue needed for the bsearch
our %seen; # what nodes were seen in the bsearch and from where
sub visit; sub visit1; sub success; sub neighbours; sub failure;

sub cleansearch {
	%seen = ();
}

sub dosearch {
	PHASE: {
	cleansearch;
	@qu = (
		[$word1, 1, undef],
		1,
		[$word2, 2, undef],
		2,
		);
	while (my $e = shift @qu) {
		if (ref $e) {
			visit @$e;
		} else {
			push @qu, $e;
			!ref($qu[0]) and failure ($e);
			$debug and warn "$e\n";
		}
		}
	die "internal error: the markers have somehow disappeared";
	}
}

sub visit {
	my($w, $dir, $from) = @_;
	my $s = $seen{$w}[0];
	$s && $s!=$dir and
		success $w, $dir, $from;
	$s and return;
	$seen{$w} = [$dir, $from];
	neighbours $w, sub 
		{ push @qu, [$_[0], $dir, $w]; };
}

# 8. Find the neighbours of a given word

sub neighbours {
	my($w, $cb) = @_;
	for my $n (0..length($w)-1) {
		my $p = substr($w, 0, $n) . "." . substr($w, $n+1);
		@{$patt{$p}}<=1 and next;
		for my $x (@{$patt{$p}}) {
			&$cb($x) unless $x eq $w;
		}
	}
}

	
# 9. Output the result, either word ladder or failure

sub failure {
	$debug and warn "phase $phase failed, word$_[0] was more isolated,";
	$phase or do {
		die "no word ladder found\n";
	};
	no warnings "exiting";
	next PHASE; # :-)
}

sub printladder1; sub printladder2;
sub success {
	$debug and warn "about to print solution";
	my($pn, $dir, $po) = @_;
	my($p1, $p2) = $dir==1 ? ($po, $pn) : ($pn, $po);
	printladder1 $p1;
	printladder2 $p2;
	no warnings "exiting";
	last ALL;
}

sub printladder1 {
	my $r = $word{$_[0]};
	my $n = $seen{$_[0]}[1];
	$n and printladder1 $n;
	print $r, "\n";
}
sub printladder2 {
	my $r = $word{$_[0]};
	my $n = $seen{$_[0]}[1];
	print $r, "\n";
	$n and printladder2 $n;
}

