Current Ladder Code

ladder.pl

#!/usr/bin/env perl

use strict ;
use warnings ;
use feature qw{ say postderef signatures } ;
no warnings qw{ experimental } ;
use utf8 ;

use JSON ;
use List::Util qw{min} ;

$| = 1 ;
my $json     = JSON->new ;
my $word1    = 'source' ;
my $word2    = 'target' ;
my @wordlist = get_words(length $word1) ;

say qq{SOURCE: $word1} ;
say qq{TARGET: $word2} ;
my @output = dijkstra( \@wordlist, $word1, $word2 ) ;
say join ' > ', reverse @output ;

sub dijkstra ( $list, $source, $target ) {
    my %prev ;
    my %dist ;
    map { $dist{ $_ } = 1_000 } $list->@* ;
    $dist{ $source } = 0 ;
    my @words ;
    push @words, $source ;
    my @ladder ;
    my $c = 0 ;
    say 'START' ;
LOOP: while ( @words ) {
        my $word = shift @words ;
        my @new = grep { editdist( $word, $_ ) == 1 } $list->@* ;
        # print qq{ #$word#$dist{$word}#};
        for my $new ( @new ) {
            # print '+';
            next if $dist{ $new } < 1_000 ;
            $prev{ $new } = $word ;
            $dist{ $new } = $dist{ $word } + 1 ;
            if ( $new eq $target ) {
                my $curr = $target ;
                push @ladder, $curr ;
                while ( $prev{ $curr } ) {
                    $curr = $prev{ $curr } ;
                    push @ladder, $curr ;
                    }
                last LOOP;
                }
            push @words, $new ;
            }
        }
    say 'FINISH' ;
    return @ladder ;
    }

sub editdist ( $f, $g ) {
    my @a = split //, $f ;
    my @b = split //, $g ;
    my @d ;
    $d[ $_ ][ 0 ] = $_ for ( 0 .. @a ) ;
    $d[ 0 ][ $_ ] = $_ for ( 0 .. @b ) ;
    for my $i ( 1 .. @a ) {
        for my $j ( 1 .. @b ) {
            $d[ $i ][ $j ] = (
                  $a[ $i - 1 ] eq $b[ $j - 1 ]
                ? $d[ $i - 1 ][ $j - 1 ]
                : 1 + min(
                    $d[ $i - 1 ][ $j ],
                    $d[ $i ][ $j - 1 ],
                    $d[ $i - 1 ][ $j - 1 ]
                    )
                    ) ;
            }
        }
    return $d[ @a ][ @b ] ;
    }

sub get_words( $length ) {
    my $newfile = '/usr/share/dict/words' ;
    if ( -f $newfile && open my $fh, '<', $newfile ) {
        my @words =
            sort { rand 1 <=> rand 1 }
            grep { !/\W/ }
            grep { !/[A-Z]/ }
            grep { length == $length }
            map { chomp $_ ; $_ } <$fh> ;
        return @words ;
        }
    return [] ;
    }