note
Limbic~Region
[Ieronim],
<br />
I have taken the best parts of all the versions and re-written them in what I believe to be relatively clean code. I have not yet benchmarked this but I expect it to be very close to your current best. Here is a list of features:
<ul>
<li>Command line argument parsing</li>
<li>Ability to handle non-dictionary words (configurable)</li>
<li>Ability to handle absense of [cpan://Text::LevenshteinXS] (automatic)</li>
<li>Ability to use different compiled databases (configurable)</li>
<li>Ability to create new compiled databases (configurable)</li>
<li>Speed and non-duplicated code</li>
</ul>
<READMORE>
<CODE>
#!/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};
my $list = slice_db(\%opt, $db);
die $list if ! ref $list;
my $path = find_path($opt{f}, $opt{t}, $list);
print $path;
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 find_path {
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 get_args {
my $opt = shift @_;
my $Usage = qq{Usage: $0 -f <from> -t <to> -d <database> [-b -n <file>] [-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 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;
}
</CODE>
</READMORE>
<div class="pmsig"><div class="pmsig-180961">
<p>
Cheers - [Limbic~Region|L~R]
</p>
</div></div>
558342
558413