#!/usr/bin/perl
use strict;
use warnings;
use Getopt::Std;
use Storable;
my %opt;
get_args(\%opt);
build_db(\%opt) if $opt{b};
my $db = retrieve $opt{d};
our $list = slice_db(\%opt, $db);
die $list if ! ref $list;
use Benchmark ':all';
our ($src, $tgt) = @opt{qw/f t/};
# So solo is not penalized for compiling wordlist
use List::Compare;
our $length = length($src);
our $wordlist;
open(FH,'2of12.txt') or die $!;
while(<FH>) {
chomp;
undef($wordlist->{lc $_}) if length($_) == $length;
}
print find_path1($src, $tgt, $list), "\n";
print find_path2($src, $tgt, $list), "\n";
print find_path3($src, $tgt, $list), "\n";
print find_path4($src, $tgt, $list), "\n";
print find_path5($src, $tgt);
print find_path6($src, $tgt, $list), "\n";
cmpthese( -3, {
'limbic__1' => 'my $path = find_path1($src, $tgt, $list)',
'limbic__2' => 'my $path = find_path2($src, $tgt, $list)',
'limbic__3' => 'my $path = find_path3($src, $tgt, $list)',
'limbic__4' => 'my $path = find_path4($src, $tgt, $list)',
'solo____1' => 'my $path = find_path5($src, $tgt)',
'ieronim_1' => 'my $path = find_path6($src, $tgt, $list)',
} );
sub build_db {
my $opt = shift @_;
my (%data, $db);
open(my $dict, '<', $opt->{n}) or die "Unable to open '$opt->{n}'
+for reading: $!";
while (<$dict>) {
chomp;
push @{$data{length()}}, $_;
}
for my $len (keys %data) {
my $end = $#{$data{$len}};
for my $i (0 .. $end - 1) {
my $word = $data{$len}[$i];
for my $j ($i + 1 .. $end) {
my $test = $data{$len}[$j];
! exists $db->{$len}{$_} and $db->{$len}{$_} = [] for
+$word, $test;
if (distance($word, $test) == 1) {
push @{$db->{$len}{$word}}, $test;
push @{$db->{$len}{$test}}, $word;
}
}
}
}
store $db, $opt->{d};
}
sub distance {
no warnings 'redefine';
eval { require Text::LevenshteinXS; };
*main::distance = ! $@ ? \&Text::LevenshteinXS::distance : sub {
my ($src, $tgt) = @_;
my $cnt;
substr($src, $_, 1) ne substr($tgt, $_, 1) && ++$cnt for 0 ..
+length($src) - 1;
return $cnt;
};
&distance;
}
sub get_args {
my $opt = shift @_;
my $Usage = qq{Usage: $0 -f <from> -t <to> -d <database> [-b -n <f
+ile>] [-l]
-h : This help message.
-f : The word you want to build the bridge (f)rom
-t : The word you want to build the bridge (t)o
-d : The name of the (d)atabase file
-b : Instruct for database to be (b)uild # optional
-f : The file (n)ame to build database from # required with -b
-l : Allow (l)leniency in the -f and -t words not being in the
+ database
} . "\n";
getopts('hf:t:d:bn:l', $opt) or die $Usage;
die $Usage if $opt->{h};
die $Usage if ! $opt->{f} || ! $opt->{t} || ! $opt->{d};
die $Usage if $opt->{b} && ! $opt->{n};
}
sub slice_db {
my ($opt, $db) = @_;
my $len = length($opt->{t});
return "Unequal length of end-points" if $len != length($opt->{f}
+);
return "No words of length $len found" if ! exists $db->{$len};
my $list = $db->{$len};
if ($opt->{l}) {
for my $word ($opt->{f}, $opt->{t}) {
if (! exists $list->{$word}) {
for (grep distance($_, $word) == 1, keys %$list) {
push @{$list->{$word}}, $_;
push @{$list->{$_}}, $word;
}
return "Unable to work with $word" if ! @{$list->{$wor
+d}};
}
}
}
return $list;
}
sub find_path1 {
my ($src, $tgt, $list) = @_;
my @src_rel = [$src];
my @tgt_rel = [$tgt];
my %src_off = ($src => 0);
my %tgt_off = ($tgt => 0);
my ($src_pos, $tgt_pos, %src_cnt, %tgt_cnt) = (0, 0);
while (1) {
for my $dir (qw/src tgt/) {
my ($rel, $off, $opp, $cnt, $pos, $val) = $dir eq 'src'
? (\@src_rel, \%src_off, \%tgt_off, \%src_cnt, \$src_p
+os, $src)
: (\@tgt_rel, \%tgt_off, \%src_off, \%tgt_cnt, \$tgt_p
+os, $tgt);
my $end = $#$rel;
return "Unable to work with $val" if $cnt->{$$pos}++ > 2;
for my $i ($$pos .. $#$rel) {
my @prefix = @{$rel->[$i]};
my $search = pop @prefix;
push @prefix, $i;
for my $word (@{$list->{$search}}) {
next if $off->{$word};
push @$rel, [@prefix, $word];
$off->{$word} = $#$rel;
return solution($word, \%src_off, \@src_rel, \%tgt
+_off, \@tgt_rel) if defined $opp->{$word};
}
}
$$pos = $end + 1;
}
}
}
sub find_path2 {
my ($src, $tgt, $list, $seen, $work) = @_;
@$work = map {key => $_ => path => "$src-$_"}, @{$list->{$src}} if
+ ! defined $work;
my $next = [];
for (@$work) {
my ($word, $path) = @{$_}{qw/key path/};
next if $seen->{$word}++;
return $path if $word eq $tgt;
push @$next, map {key => $_, path => "$path-$_"}, @{$list->{$w
+ord}};
}
return find_path2($src, $tgt, $list, $seen, $next) if @$next;
return 'path not found';
}
sub find_path3 {
my ($src, $tgt, $list, $search) = @_;
for my $pos (qw/src tgt/) {
my $dir = $pos eq 'src' ? $src : $tgt;
my $opp = $pos eq 'src' ? 'tgt' : 'src';
if (! defined $search->{$pos}{work}) {
for (@{$list->{$dir}}) {
push @{$search->{$pos}{work}}, {key => $_, path => "$d
+ir-$_"};
$search->{$pos}{term}{$_} = $search->{$pos}{work}[-1];
}
$search->{$pos}{term}{$dir} = {key => $dir, path => $dir};
}
my ($work, $next) = ($search->{$pos}{work}, []);
while (@$work) {
my $node = shift @$work;
my ($word, $path) = @{$node}{qw/key path/};
next if $search->{$pos}{seen}{$word}++;
if ($search->{$opp}{term}{$word}) {
my @cur_path = split /-/, $path;
my @con_path = split /-/, $search->{$opp}{term}{$word}
+{path};
return $pos eq 'tgt'
? join '-', @con_path, @cur_path[reverse 0 .. $#cu
+r_path - 1]
: join '-', @cur_path, @con_path[reverse 0 .. $#co
+n_path - 1];
}
for (@{$list->{$word}}) {
push @$next, {key => $_, path => "$path-$_"};
$search->{$pos}{term}{$_} = $next->[-1];
}
}
$search->{$pos}{work} = $next;
}
return 'path not found' if ! @{$search->{src}{work}} || ! @{$searc
+h->{tgt}{work}};
return find_path3($src, $tgt, $list, $search);
}
use constant SRC => 0;
use constant TGT => 1;
sub find_path4 {
my ($src, $tgt, $list) = @_;
my (@src_work, @tgt_work, %path);
for my $dir (SRC, TGT) {
my ($word, $work) = $dir == SRC ? ($src, \@src_work) : ($tgt,
+\@tgt_work);
$path{$word}[$dir] = -1;
for (@{$list->{$word}}) {
push @$work, $_;
$path{$_}[$dir] = $word;
}
}
while (1) {
for my $dir (SRC, TGT) {
my @next;
my $work = $dir == SRC ? \@src_work : \@tgt_work;
for my $word (@$work) {
return build_path(\%path, $word) if $path{$word}[abs($
+dir - 1)];
for (@{$list->{$word}}) {
next if $path{$_}[$dir];
push @next, $_;
$path{$_}[$dir] = $word;
}
}
@$work = @next;
}
return 'Path not found' if ! @src_work && ! @tgt_work;
}
}
sub build_path {
my ($tree, $node) = @_;
my $path = "-$node";
for my $dir (SRC, TGT) {
my $word = $tree->{$node}[$dir];
while ($word ne '-1') {
$path = $dir == SRC ? "-$word$path" : "$path-$word";
$word = $tree->{$word}[$dir];
}
}
return substr($path, 1);
}
sub find_path5 {
my ( $rdepth,$ldepth,$rex,$lex ) = (0,0,1,1);
my $left = { $_[0] => [$_[0]] };
my $right = { $_[1] => [$_[1]] };
while ( 1 ) {
# compare the intersection of the leaf nodes
my $lc = List::Compare->new( {
lists => [ [keys %$left], [keys %$right] ],
accelerated => 1,
unsorted => 1,
} );
my @int = $lc->get_intersection();
if ( @int ) {
my $solve = shift @int;
pop @{$right->{$solve}};
return join("-", @{$left->{$solve}}, reverse @{$right->{$s
+olve}}) . "\n";
}
# pick a side to expand the search in
if ( $lex && $rdepth > $ldepth ) {
$lex = expandTree($left,++$ldepth);
}
elsif ( $rex ) {
$rex = expandTree($right,++$rdepth);
}
else {
return "No solution.";
}
}
}
sub expandTree {
my ($tree, $depth) = @_;
my ($word, $path, $expanded);
while ( ($word, $path) = each %$tree ) {
if ( @$path == $depth ) {
for my $i (0..(length($word)-1) ) {
for my $letter ( 'a'..'z' ) {
my $try = $word;
substr($try,$i,1) = $letter;
next if exists $tree->{$try};
if ( exists $wordlist->{$try} ) {
$tree->{$try} = [ @{$tree->{$word}}, $try ];
$expanded = 1;
}
}
}
}
}
return $expanded;
}
sub find_path6 {
my $left = shift;
my $right = shift;
my $list = shift;
my (@left, %left, @right, %right); # @left and @right- arrays
+ containing word relation trees: ([foo], [0, foe], [0, fou], [0, 1, f
+ie] ...)
# %left and %right - indic
+es containing word offsets in arrays @left and @right
$left[0] = [$left];
$right[0] = [$right];
$left{$left} = 0;
$right{$right} = 0;
my $leftstart = 0;
my $rightstart = 0;
my @way;
my (%leftstarts, %rightstarts);
SEARCH:
for (;;) {
my @left_ids = $leftstart..$#left;
+ # choose array of indices of new words
$leftstart = $#left;
die "Cannot solve! Bad word '$left' :(\n" if $leftstarts{$left
+start}++ >2; # finish search if the way could not be found
for my $id (@left_ids) {
+ # come through all new words
my @prefix = @{$left[$id]};
my $searched = pop @prefix;
push @prefix, $id;
foreach my $word (@{$list->{$searched}}) {
next if $left{$word};
+ # skip words which are already in the tree
push @left, [@prefix, $word];
$left{$word} = $#left; #
+add new word to array and index
#print join " ", @{$left[-1]}, "\n"; #debugging
if ( defined(my $r_id = $right{$word}) ) { #
+and check if the word appears in right index. if yes...
my @end = reverse(print_rel($r_id, \@right));
shift @end;
@way = (print_rel($#left, \@left), @end); #
+build the way between the words
last SEARCH; #
+and finish the search
}
}
}
my @right_ids = $rightstart..$#right;
+ # all the same :) the tree is build from both ends to speed up the
+process
$rightstart = $#right;
die "Cannot solve! Bad word '$right' :(\n" if $rightstarts{$ri
+ghtstart}++ > 2;
for my $id (@right_ids) { # build right relational table
my @prefix = @{$right[$id]};
my $searched = pop @prefix;
push @prefix, $id;
foreach my $word (@{$list->{$searched}}) {
next if $right{$word};
push @right, [@prefix, $word];
$right{$word} = $#right;
# print join " ", @{$right[-1]}, "\n"; #debugging
if ( defined(my $l_id = $left{$word}) ) {
my @end = reverse print_rel($#right, \@right);
shift @end;
@way = (print_rel($l_id, \@left), @end);
last SEARCH;
}
}
}
}
return join '-', @way;
}
sub print_rel {
my $id = shift;
my $ary = shift;
my @line;
my @rel = @{$ary->[$id]};
push @line, (pop @rel);
foreach my $ref_id (reverse @rel) {
unshift @line, $ary->[$ref_id]->[-1];
}
return wantarray ? @line : join "\n", @line, "";
}
sub printway {
my @way = @{+shift};
print join "-", @way;
print "\n";
}
sub solution {
my ($word, $src_off, $src_rel, $tgt_off, $tgt_rel) = @_;
my @tgt_pth = @{$tgt_rel->[$tgt_off->{$word}]};
my @src_pth = @{$src_rel->[$src_off->{$word}]};
my $path = pop @tgt_pth;
my $i = @tgt_pth;
$path .= "-" . $tgt_rel->[$tgt_pth[$i]]->[-1] while $i--;
pop @src_pth;
$i = @src_pth;
$path = $src_rel->[$src_pth[$i]][-1] . "-$path" while $i--;
return $path;
}