HEAD
bead
beat
boat
boot
FOOT

##</code><code>##

#!/usr/bin/perl
#ver 1.02

use warnings;
use strict;

my $dict  = '2of12.txt';
die <<HELP unless @ARGV == 2;
usage: transform.pl <word1> <word2>

The program finds a way from one word to other, like this:

% transform.pl love shit
love-lose-lost-loot-soot-shot-shit
HELP

my ($left, $right)  =  @ARGV[0,1];

for ($left, $right) {
    $_ = lc;
}

die "the length of given words is not equal!\n" if length($left) != length $right;
open DICT, $dict or die "Cannot open dictionary $dict: $!";

my @words;

while (<DICT>) {
    chomp;
    push @words, $_ if length == length $left;
}

eval {
    my @ways = ([transform($left, $right, \@words)], [reverse transform($right, $left, \@words)]);
    if (@{$ways[0]} != @{$ways[1]}) {
        printway( @{$ways[0]} > @{$ways[1]} ? $ways[0] : $ways[1] );
    }
    elsif (grep {$ways[0]->[$_] ne $ways[1]->[$_]} (0..(scalar(@{$ways[0]}) - 1) )) {
        printway($ways[0]);
        printway($ways[1]);
    }
    else {printway($ways[0])}
    1;
} or print $@;

sub transform {
    my $left = shift;
    my $right = shift;
    my @words = @{+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 @patterns = wordpattern(pop @prefix);                    # build patterns to find related words: foo -> (/^.oo$/,/^f.o$/, /^fo.$/)
            push @prefix, $id;
            foreach my $word (@words) {
                next if $left{$word};                                   # skip words which are already in the tree
                if (scalar grep {$word =~ /$_/} @patterns) {            # if matched... 
                    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 @patterns = wordpattern(pop @prefix);
            push @prefix, $id;
            foreach my $word (@words) {
                next if $right{$word};
                if (scalar grep {$word =~ /$_/} @patterns) {
                    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 @way;
}

sub wordpattern {
    my $word = shift;
    my @patterns;
    for my $i (0..(length($word)-1)) {
        substr((my $pat = $word), $i, 1, '.');
        push @patterns, qr/^$pat$/;
    }
    return @patterns;
}

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";
}

##</code><code>##

#!/usr/bin/perl
#ver 2.00

use warnings;
use strict;
use Storable;
use Text::LevenshteinXS 'distance';

my $dict  = '2of12.txt';
die <<HELP unless @ARGV == 2;
usage: transform.pl <word1> <word2>

The program finds a way from one word to other, like this:

% transform.pl love shit
love-lose-lost-loot-soot-shot-shit
HELP

my ($left, $right)  =  @ARGV[0,1];

for ($left, $right) {
    $_ = lc;
}

die "the length of given words is not equal!\n" if length($left) != length $right;

my $db = -e 'dictionary.db' ? retrieve('dictionary.db') : build_db();

my $len = length $left;

foreach my $word ($left, $right) {
    if (!$db->{$len}{$word}) {
        foreach my $test (keys %{$db->{$len}}) {
            if (distance($word, $test) == 1) {
                push @{$db->{$len}{$word}}, $test;
                push @{$db->{$len}{$test}}, $word;
            }
        }
    }
}

my $list = $db->{length($left)};

eval {
    printway([transform($left, $right, $list)]);
    1;
} or print $@;


sub transform {
    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 @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 build_db {                      #thanks to Limbic~Region, http://perlmonks.org/index.pl?node_id=180961
    open (my $dict, '<', '2of12.txt') or die "Unable to open '2of12.txt' for reading: $!";
    my ($db, %data);

    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];
                if (distance($word, $test) == 1) {
                    push @{$db->{$len}{$word}}, $test;
                    push @{$db->{$len}{$test}}, $word;
                }
            }
        }
    }
    store $db, 'dictionary.db';
    return retrieve('dictionary.db');
}