Rate limbic__2 solo____1 limbic__3 limbic__4 ieronim_1 limbic__1 limbic__2 6.48/s -- -45% -62% -90% -95% -96% solo____1 11.8/s 82% -- -31% -82% -92% -92% limbic__3 17.3/s 166% 46% -- -74% -88% -89% limbic__4 67.5/s 941% 471% 291% -- -53% -55% ieronim_1 143/s 2104% 1109% 728% 112% -- -5% limbic__1 150/s 2218% 1171% 771% 123% 5% -- #### #!/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() { 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 -t -d [-b -n ] [-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->{$word}}; } } } 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_pos, $src) : (\@tgt_rel, \%tgt_off, \%src_off, \%tgt_cnt, \$tgt_pos, $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->{$word}}; } 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 => "$dir-$_"}; $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 .. $#cur_path - 1] : join '-', @cur_path, @con_path[reverse 0 .. $#con_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}} || ! @{$search->{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->{$solve}}) . "\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, fie] ...) # %left and %right - indices 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{$leftstart}++ >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{$rightstart}++ > 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; }