[SPOILER] Solution to Perl 'Expert' Quiz-of-the-Week #22

# QOTW 22 Expert

.sub _main
  .param PerlArray argv

  .local string from
  .local string to
  .local string dict
  from = shift argv
  from = shift argv
  to   = shift argv
  dict = shift argv

  # from and to must have the same length, check that.
  # Note: We *don't* check if from and to actually exist in the dictionary. Add
  # them manually, this implementation requires both words to exist in the
  # dict.
  .local int length1
  .local int length2
  length1 = length from
  length2 = length to
  if length1 == length2 goto OK_LENGTH
    print "'from' and 'to' must have the same length!\n"
    end
  OK_LENGTH:

  downcase from
  downcase to

  print "Loading wordlist...\n"
  
  .local ParrotIO dictfh
  dictfh = open dict, "<"
  
  .local PerlHash  words
  .local string    curword
  .local int       curlength
  .local int       wordlength
  words      = new .PerlHash
  wordlength = length1

  READ_A_WORD:
    curword    = readline dictfh
    chopn curword, 1
    curlength  = length curword
    if curlength == 0 goto END_OF_READ

    if curlength != wordlength goto READ_A_WORD
    downcase curword

    .local Iterator substs
    substs = substitutions(curword)
    INSERT_LOOP:
      unless substs goto READ_A_WORD
      .local string    aperm
      .local int       is_defined
      .local PerlArray neighbours
      aperm = shift substs
      is_defined = defined words[aperm]

      if is_defined goto INSERT_WORD
	neighbours = new .PerlArray
	words[aperm] = neighbours
      INSERT_WORD:
	neighbours = words[aperm]
	push neighbours, curword
      goto INSERT_LOOP
  END_OF_READ:

  .local PerlArray ladder
  ladder = genladder(from, to, words)
  if ladder goto DISPLAY_LADDER
    print "No wordladder found.\n"
    end
  DISPLAY_LADDER:
    if ladder goto DISPLAY_A_WORD
      print "\n"
      end
    DISPLAY_A_WORD:
      .local string aword
      aword = shift ladder
      print aword
      print " "
      goto DISPLAY_LADDER

  print "Searching for a wordladder from '"
  print from
  print "' to '"
  print to
  print "' using '"
  print dict
  print "'...\n"

  end
.end

.pcc_sub substitutions
  .param string word

  .local PerlArray perms
  perms = new .PerlArray

  .local int    pos
  .local int    wlength
  .local string old_char
  .local string cloned
  pos     = 0
  wlength = length word

  WHILE:
    cloned = clone word
    old_char = substr cloned, pos, 1, "_"
    push perms, cloned
    pos += 1
    if pos >= wlength goto END_OF_WHILE
      goto WHILE
  END_OF_WHILE:

  .local Iterator retiter
  retiter = iter perms
  
  .pcc_begin_return
    .return retiter
  .pcc_end_return
.end

.pcc_sub getneighbours
  .param string   word
  .param PerlHash words

  .local PerlArray neighs
  .local Iterator  substs

  neighs = new .PerlArray
  substs = substitutions(word)

  SUBST_LOOP:
    unless substs goto END_OF_SUBSTS

    .local string subst
    subst = shift substs

    .local PerlArray sneighs
    .local Iterator  sneighsiter
    sneighs     = words[subst]
    sneighsiter = iter sneighs

    NEIGH_LOOP:
      unless sneighsiter goto END_OF_NEIGH_LOOP
      .local string neigh
      neigh = shift sneighsiter
      .local int is_eq
      eq neigh, word, NEIGH_LOOP
      push neighs, neigh
      goto NEIGH_LOOP
    END_OF_NEIGH_LOOP:
      goto SUBST_LOOP
  END_OF_SUBSTS:

  .local Iterator neighsiter
  neighsiter = iter neighs

  .pcc_begin_return
    .return neighsiter
  .pcc_end_return
.end

.pcc_sub genladder
  .param string   from
  .param string   to
  .param PerlHash words

  .local PerlArray candidates
  .local PerlHash  wordinfo
  .local PerlArray chain

  candidates = new .PerlArray
  wordinfo   = new .PerlHash
  chain      = new .PerlArray
  push candidates, from
  wordinfo[from] = chain

  WHILE:
    unless candidates goto END_OF_WHILE
    .local string word
    word = shift candidates

    eq word, to, WHILE
    .local int is_defined
    is_defined = defined wordinfo[word]
    if is_defined goto WORDINFO_EXISTS
      chain = new .PerlArray
      wordinfo[word] = chain
    WORDINFO_EXISTS:
      chain = wordinfo[word]
      .local int clength
      clength = chain
      clength += 1

      .local Iterator neighbours
      neighbours = getneighbours(word, words)
      FOREACH_SUCC:
	unless neighbours goto END_OF_SUCCS
	.local string succ
	succ = shift neighbours

	.local int winfo_exists
	winfo_exists = defined wordinfo[succ]
	unless winfo_exists goto ADD_WORD

	.local int slength
	slength = wordinfo[succ]
	lt clength, slength, ADD_WORD
	goto FOREACH_SUCC

	ADD_WORD:
	  chain = clone chain
	  push chain, word
	  wordinfo[succ] = chain
	  push candidates, succ
	  goto FOREACH_SUCC
      END_OF_SUCCS:
	goto WHILE
  END_OF_WHILE:

  .local PerlArray ladder

  is_defined = defined wordinfo[to]
  if is_defined goto PUT_LADDER
    ladder = new .PerlArray
    goto RET_LADDER
  PUT_LADDER:
    ladder = wordinfo[to]
    push ladder, to
    $S0 = shift ladder

  RET_LADDER:
    .pcc_begin_return
      .return ladder
    .pcc_end_return
.end

#!/usr/bin/perl

use warnings;
use strict;

# Wordladder $from $to using dictionary file $dict.
my ($from, $to, $dict) = @ARGV;
  $dict = "wordlist" unless defined $dict;

unless(defined $from and defined $to and length $from == length $to) {
  print STDERR <<USAGE;
Usage: $0 from to [dictionary]

Generates a wordladder from 'from' to 'to' using dictionary 'dictionary'
(defaults to 'words' in current directory).

'from' and 'to' need to have the same length.
USAGE
  exit;
}

# We work lowercase.
local $_;
$_ = lc $_ for $from, $to;

# $words{x} is true if 'x' exists in the dictionary.
my %words;
open my $in, "<", $dict or die "Couldn't open $dict for reading: $!\n";
  while(<$in>) {
    chomp;
    next unless length == length $from;
    $words{lc $_}++;
  }
close $in or die "Couldn't close $dict: $!\n";

$words{$from}++;
$words{$to}++;

foreach my $word (keys %words) {
  foreach my $subst (subst($word)) {
    $words{$subst} = [] unless ref $words{$subst};
    push @{ $words{$subst} }, $word;
  }
}

my @ladder = ladder($from, $to);
if(@ladder) {
  print "@ladder\n";
  print STDERR 0+@ladder, "\n";
  exit;
} else {
  print STDERR "No wordladder found.\n";
  exit 1;
}

sub subst {
  my ($word, @s) = (shift);

  for(my $i = 0; $i < length $word; $i++) {
    my $old = substr $word, $i, 1, "_";
    push @s, $word;
    substr($word, $i, 1) = $old;
  }

  return @s;
}

sub neighbours { local $_; grep { $_[0] ne $_ } map {@{ $words{$_} }} subst($_[0]) }

# Returns the wordladder from $src to $dest.
sub ladder {
  my ($src, $dest) = @_;

  my @candidates = ($src);
  my %wordinfo   = ($src => [] );

  while (@candidates) {
    my $word = shift @candidates;
    if ($word ne $dest) {
      my @chain  = @{ $wordinfo{$word} };
      my $length = 1 + @chain;
  
      foreach my $succ (neighbours($word)) {
	if($wordinfo{$succ} and $length >= @{ $wordinfo{$succ} }) {
	  # bad
	} else {
	  $wordinfo{$succ} = [ @chain, $word ];
	  push @candidates, $succ;
	}
      }
    }
  }

  return $wordinfo{$dest} ? (@{ $wordinfo{$dest} }, $dest) : ();
}