Perl 6 The Niven Ladder

by Arne Sommer

Perl 6 The Niven Ladder

Published 12. May 2019

This is my response to the Perl Weekly Challenge #7.

Challenge #7.1

«Print all the niven numbers from 0 to 50 inclusive, each on their own line. A niven number is a non-negative number that is divisible by the sum of its digits.»

File: niven
.say if $_ %% $_.comb.sum for 0 .. 50;

And that's it. A single line of code.

If you want a longer program (to impress a line counting manager, perhaps?), here it is:

File: niven-long
for 0 .. 50 
{
  if $_ %% $_.comb.sum   # [1]
  {
    .say;                # [2]
  }
}

[1] Is the current number («$_») divisible («%%») by the by the sum («.sum») of all the digits («.comb»)? If so, print it.

[2] A method invoked on nothing is actually invoked on «$_».

See docs.perl6.org/routine/%% for more information about the Divisibility operator «%%».

We can extend it so that the user can specify the upper limit. The default value is (still) 50:

File: niven-main
unit sub MAIN (Int $limit where $limit > 0 = 50);

.say if $_ %% $_.comb.sum for 1 .. $limit;

If you want the first 50 (or whatever number you specify on the commmand line) Niven numbers, we can use «gather»/«take» to set up a lazy Sequence (where the values are only computed when actually needed) like this:

File: niven-gather
unit sub MAIN (Int $limit where $limit > 0 = 50);

my $niven := gather
{
  for 0..Inf
  {
    take $_ if $_ %% $_.comb.sum;
  }
}

.say for $niven[^$limit];  # [1]

[1] The «^$limit» construct means every integer from 0 up to the value of «$limit», but not including it. If the value passed on the command line is 2, we get 0 and 1, which gives us the two first elements in the Sequence (which are evaluated when requested only).

See my Perl 6 gather, I take article for more information about gather/take.

Challenge #7.2: Word Ladder

A word ladder is a sequence of words [w0, w1, …, wn] such that each word wi in the sequence is obtained by changing a single character in the word wi-1. All words in the ladder must be valid English words.

Given two input words and a file that contains an ordered word list, implement a routine (e.g., find_shortest_ladder(word1, word2, wordlist)) that finds the shortest ladder between the two input words. For example, for the words cold and warm, the routine might return:

("cold", "cord", "core", "care", "card", "ward", "warm")

However, there’s a shortest ladder: (“cold”, “cord”, “card”, “ward”, “warm”).

Givens:
  1. All words in the list have the same length.
  2. All words contain only lowercase alphabetical characters.
  3. There are no duplicates in the word list.
  4. The input words aren’t empty and aren’t equal but they have the same length as any word in the word list.
Requirements:
  1. The routine must return a list of the words in the ladder if it exists. Otherwise, it returns an empty list.
  2. If any of the input words is the wrong length (i.e., its length is different to a random from the word list) or isn’t in the word list, return an empty list.

I'll start with the framework; a program where the user can either specify the wordlist on the command line, or give a file name. This dummy version doesn't do anything except loading the dictionary:

File: word-ladder-dummy
multi sub MAIN ($first, $second, *@wordlist)                         # [1]
{
  say-output(find_shortest_ladder($first, $second, @wordlist));      # [5]
}

multi sub MAIN ($first, $second, $dictionary                         # [2]
  where $dictionary.IO && $dictionary.IO.r)
{
  return unless $first.chars == $second.chars;                       # [3]
  
  my @wordlist = load-dictionary($dictionary, $first.chars);         # [4]
    # Only load the words with the correct length.

  say-output(find_shortest_ladder($first, $second, @wordlist));      # [5]
  
  sub load-dictionary ($file where $file.IO && $file.IO.r, $word-length)
  {
    return $file.IO.lines.grep({ .chars == $word-length }).lc.words; # [4]
  }
}

sub say-output(@list)                                                # [6]
{
  for (@list) -> $curr
  {
    say $curr;
  }
}

sub find_shortest_ladder ($word1, $word2, @wordlist)  # [7]
{
  return ("W1: $word1", "W2: $word2", "D: @wordlist[]");
}

[1] The first version of «MAIN» takes a word list (as a slurpy argument, as the words come as individual values on the command line.

[2] The second version of «MAIN» takes the name of a dictionary file.

[3] If the two words have different lenght, we abort. This test will be placed in «find_shortest_ladder», but it is a good to have it here before loading the dictionary as well.

[4] Load the dictionary. We pass it the length, and it only reads words with that length. Thw words are converted to lower case.

[5] Call «find_shortest_ladder» to do the job.

[6] In this dummy version all we do is printing the values. The word list is especially useful for debugging when loaded from a file.

Testing it:

$ perl6 word-ladder-dummy work moon /etc/dictionaries-common/words 
W1: work
W2: moon
D: Abby Abel Ac's Acts ....

$ perl6 word-ladder-dummy aaa bbb aaa aab abb bbb
W1: aaa
W2: bbb
D: aaa aab abb bbb

Then we can start implementing «find_shortest_ladder»:

File: word-ladder (partial)
sub find_shortest_ladder ($word1, $word2, @wordlist)
{
  my Set $dict = @wordlist.Set;       # [1]
  my @letters = "a" .. "z";           # [2]

  return unless $dict{$word1};        # [3]
  return unless $dict{$word2};        # [4]
  return unless $word1.chars == $word2.chars;            # [5]
  return unless all(@wordlist>>.chars) == $word1.chars;  # [6]
  say "OK";
}

[1] The dictionary, as a Set. This saves us some typing compared with a hash: my %dict = @wordslist.map({ $_ => True });

[2] Note that the alphabet means that we will not get words with special characters, such as «é». Or any letters in other languages (as «ß» in German or «Å» in Norwegian). I'll get back to that problem in the next section.

[3] We return (an empty list) if the first word doesn't exist,

[4] and the same for the second word.

[5] We return if the two words don't have the same length.

[6] We return if one or more words in the dictionary have a wrong length.

Non-English Letters

We have to adjust the list of legal letters (in «@letters»). This should be automated, and can be done by looping through the dictionary and noting the letters.

Staring with the word list, this can be done in at least two ways. And if we can also start with the dictionary:

my @letters = @wordlist.comb.unique.grep({ /<:L>/ });
my @letters = @wordlist.comb.grep({ /<:L>/ }).Set.keys;
my @letters = $dict.keys.comb.unique.grep({ /<:L>/ });

The first one is probably the fastest (based on an unscientific study of my gut feeling), so I'll use that:

File: word-ladder (changes only)
  # my @letters = "a" .. "z";
  my @letters = @wordlist.comb.unique.grep({ /<:L>/ });

Setting up a list of Next Words

I have chosen not to compute this list initially, as we probably would compute more next words than actually needed. So I'll compute them when needed.

But if you wonder how the code would have looked like; here it is:

  my %next;                                       # [1]
    
  check-word($_) for @wordlist;                   # [2]

  sub check-word ($word)                          # [3]
  { 
    for ^$word.chars -> $index                    # [4]
    {
      my $next = $word;                           # [5]
      for @letters -> $letter                     # [6]
      {
        $next.substr-rw($index, 1) = $letter;     # [7]
        next if $word eq $next;                   # [5]
        %next{$word}.push($next) if $dict{$next}; # [8]
      }
    }
  }
  say %next;                                      # [9]
}

[1] A hash, with a list of next words for each key.

[2] We check each word in the word list.

[3] «check-word» is placed inside «find_shortest_ladder», so that it have access to «%next» without the need for it to be a global variable.

[4] The «^» symbol in front of an integer (or something that can be coerced to an integer) gives a range from 0 up to the specified value (but not including it). If the word has 4 letters, we get the four values 0,1,2 and 3 - which just happens to be the indices for the individual characters in the string. The loop is used to iterate through each position in the word.

[5] Do the work on a copy of the original word, so that we can detect if we arrive back at the original word.

[6] Loop through the letters in the alphabet (as taken from the dictionary).

[7] Swap one letter (at the given position) with a new one. «substr-rw» is a version of «substr» (substring) that allows us to write to the substring.

[8] Save the word (as a next word, if it is a legal word (in the dictionary).

[9] Testing that it does what we think it should (and it does).

See docs.perl6.org/routine/substr-rw for more information about «substr-rw».

Running it:

$ perl6 word-ladder aaa bbb aaa aab abb bbb
{aaa => [aab], aab => [abb aaa], abb => [bbb]}

$ perl6 word-ladder work moon /etc/dictionaries-common/words 
{abed => [awed aced abel], abel => [abed abet], abet => [abel abut],
abut => [abet], aced => [abed iced aged], aces => [ices ayes],
ache => [acre ashe], achy => [ashy], acid => [amid arid],
acme => [acne acre], acne => [anne acme], acre => [acme ache],
acts => [arts ants], adam => [adan edam] ...

When Not to Recurse

A recursive search for the ladder is not the thing here, as it would find the longest candidate first.

Just for fun, here it is as a recursive function (without explanation):

File: word-ladder-recursive (partial)

  check-path($word1, $word2, List.new, Hash.new);

  sub check-path($start, $stop, @path is copy, %seen is copy )
  {
    %seen{$start} = True;
    @path.push: $start;
    for @(%next{$start}) -> $candidate
    {
      next if %seen{$candidate};
      
      if $candidate eq $stop
      {
        say-output(@path.push: $candidate);
	last;
      }
      else
      {
        check-path($candidate, $stop, @path, %seen) unless %seen{$candidate};
      }
    }
  }
}

sub say-output (@path)
{
  say '("', @path.join('","'), '")';
}

Running it (and I show the first two lines only):

perl6 word-ladder-recursive let bee /etc/dictionaries-common/words 
("let","bet","get","jet","met","net","pet","set","vet","wet","yet","yea","lea",
 "pea","sea","tea","tee","bee")
("let","bet","get","jet","met","net","pet","set","vet","wet","yet","yea","lea",
 "pea","sea","tea","ten","den","fen","hen","ken","men","pen","wen","yen","yon",
 "con","don","eon","ion","non","son","ton","won","wan","ban","can","fan","man",
 "pan","ran","tan","van","vat","bat","cat","eat","fat","hat","mat","oat","pat",
 "rat","sat","tat","tit","bit","fit","hit","kit","lit","nit","pit","sit","wit",
 "zit","zip","dip","hip","lip","nip","pip","rip","sip","tip","yip","yap","cap",
 "gap","lap","map","nap","pap","rap","sap","tap","top","bop","cop","fop","hop",
 "lop","mop","pop","sop","sup","cup","pup","yup","yep","hep","pep","rep","red",
 "bed","fed","led","wed","wad","bad","cad","dad","fad","gad","had","lad","mad",
 "pad","sad","tad","tab","cab","dab","gab","jab","lab","nab","nib","bib","fib",
 "jib","lib","rib","rob","bob","cob","fob","gob","hob","job","lob","mob","sob",
 "sub","cub","dub","hub","nub","pub","rub","tub","tug","bug","dug","hug","jug",
 "lug","mug","pug","rug","rag","bag","fag","gag","hag","jag","lag","nag","sag",
 "tag","wag","wig","big","dig","fig","gig","jig","pig","rig","rid","aid","bid",
 "did","hid","kid","lid","mid","mod","cod","god","hod","nod","pod","rod","sod",
 "sol","pol","pal","gal","gel","eel","ell","all","ill","ilk","ink","irk","ark",
 "ask","auk","yuk","yak","oak","oaf","off","oft","aft","act","ant","apt","opt",
 "out","but","cut","gut","hut","jut","nut","put","rut","rot","cot","dot","got",
 "hot","jot","lot","not","pot","sot","tot","wot","woe","doe","foe","hoe","roe",
 "toe","tee","bee")

The first one is not so bad, at least compared to the second one. The correct (shortest) answer is either «let lee bee» or «let bet bee».

Using a Queue

The solution is width first search. This cannot be done with a recursive procedure, so we use a queue (a list). This has the benefit that the first solution we find, will be the shortest possible. (It may be one of many equally long, but we'll cope with that as well.)

This is part of «find_shortest_ladder»:

File: word-ladder (partial)
  # say "OK";
  my @solutions;                            # [1]
  my $solution-found = False;               # [2]
  my $solution-found-size = 0;              # [3]
  
  my @deferred = ($word1);                  # [4]

  loop
  {
    my $current = @deferred.shift // last;  # [5]
    check-path($current, $word2);           # [6]
  }

[1] We store the solutions when we encounter them.

[2] This is set when we have found a solution.

[3] The number of steps taken to find a solution.

[4] We start by adding the start word to the list.

[5] As long as there are items in the list, take the first one

[6] and run «check-path» on it.

This is also part of «find_shortest_ladder»:

File: word-ladder (partial)
  sub check-path($path, $stop)                         # [1]
  {
    my @path = $path.split(";");                       # [2]
    my $seen = @path.Set;                              # [3]
    
    if $solution-found
    {
      return if $solution-found-size == @path.elems;   # [4]
    }

    my $current = @path[*-1];                          # [5]

    my $next-word := gather                            # [6]
    {
      for ^$current.chars -> $index
      {
        my $next = $current;
        for @letters -> $letter
        {
          $next.substr-rw($index, 1) = $letter;
          next if $current eq $next;
          take $next if $dict{$next};
        }
      }
    }

    for $next-word -> $candidate                      # [6]
    {    
      next if $seen{$candidate};                      # [7]

      if $candidate eq $stop                          # [8]
      {
        @solutions.push("$path;$candidate");          # [8a]
	$solution-found = True;                       # [8b]
        $solution-found-size = @path.elems + 1;       # [8c]
      }
      else
      {
        @deferred.push("$path;$candidate");           # [9]
      }
    }
  }
  return @solutions;
}

[1] «check-path» gets the current path (on the form «word1» or «word1;word2).

[2] It splits the path on the semicoolons, giving a list of words.

[3] And sets up a Set of words in the path (so that we can avoid repeating them; in [7]).

[4] If we have found a solution, stop processing new ones with size one higher. But continue processing with the same size, so that we get all the ladders with the minimum size.

[5] The current word (the last one in the path).

[6] The next word is set up with «gather»/«take» to make it easier to use the values.

[7] Avoid repeating words already in the path.

[8] If we have reached the stop word:

[8a] • save the path.

[8b] • Flag that we have found a solution.

[8c] • Set the size.

[9] If not, push the candidate (ending with a legal word that isn't the stop word) to the list.

And finally the output. The challenge stated the format for the output, but I have cheated slightly and done it here instead:

File: word-ladder (partial)
sub say-output(@list)
{
  for (@list) -> $curr                             # [1]
  {
    say '("', $curr.split(";").join('","'), '")';  # [2]
  }
}

[1] The result is a list (with one or more values).

[2] Swap the semicolons by commas, and nicify the output.

Running it:

$ perl6 word-ladder let bee /etc/dictionaries-common/words
("let","bet","bee")
("let","lee","bee")

$ perl6 word-ladder work moon /etc/dictionaries-common/words
("work","worn","morn","moon")

$ perl6 word-ladder cold warm /etc/dictionaries-common/words
("cold","cord","word","ward","warm")
("cold","cord","word","worm","warm")
("cold","cord","card","ward","warm")
("cold","cord","corm","worm","warm")

Note that we get all the solutions with the same number of steps. The challenge asked for one, so I'll fix that (but retain the possibility to get all with the «-all» (or «--all») command line option):

File: word-ladder (changes only)
multi sub MAIN ($first, $second, *@wordlist, :$all)
{
  say-output(find_shortest_ladder($first, $second, @wordlist, $all));
}

multi sub MAIN ($first, $second, $dictionary
  where $dictionary.IO && $dictionary.IO.r, :$all)
{
  ...
  say-output(find_shortest_ladder($first, $second, @wordlist, $all));
}

  loop
  {
    my $current = @deferred.shift // last;
    check-path($current, $word2);

    last if $solution-found && !$show-all;
  }
  

Testing it:

$ perl6 word-ladder let bee /etc/dictionaries-common/words
("let","bet","bee")

$ perl6 word-ladder --all let bee /etc/dictionaries-common/words
("let","bet","bee")
("let","lee","bee")

$ perl6 word-ladder cold warm /etc/dictionaries-common/words
("cold","cord","word","ward","warm")

$ perl6 word-ladder -all cold warm /etc/dictionaries-common/words
("cold","cord","word","ward","warm")
("cold","cord","word","worm","warm")
("cold","cord","card","ward","warm")
("cold","cord","corm","worm","warm")

The Full Program

File: word-ladder
multi sub MAIN ($first, $second, *@wordlist, :$all)
{
  say-output(find_shortest_ladder($first, $second, @wordlist, $all));
}

multi sub MAIN ($first, $second, $dictionary
  where $dictionary.IO && $dictionary.IO.r, :$all)
{
  return unless $first.chars == $second.chars;
  
  my @wordlist = load-dictionary($dictionary, $first.chars);
    # Only load the words with the correct length.
  
  sub load-dictionary ($file where $file.IO && $file.IO.r, $word-length)
  {
    return $file.IO.lines.grep({ .chars == $word-length }).lc.words;
  }
  
  say-output(find_shortest_ladder($first, $second, @wordlist, $all));
}

sub say-output(@list)
{
  for (@list) -> $curr
  {
    say '("', $curr.split(";").join('","'), '")';
  }
}

sub find_shortest_ladder ($word1, $word2, @wordlist)
{
  my Set $dict := @wordlist.Set;
  my @letters = @wordlist.comb.unique.grep({ /<:L>/ });

  return unless $dict{$word1};
  return unless $dict{$word2};
  return unless $word1.chars == $word2.chars;
  return unless all(@wordlist>>.chars) == $word1.chars;

  my @solutions;
  my $solution-found = False;
  my $solution-found-size = 0;
  
  my @deferred = ($word1);

  loop
  {
    my $current = @deferred.shift // last;   
    check-path($current, $word2);
    last if $solution-found && !$show-all;
  }
  
  sub check-path($path, $stop)
  {
    my @path = $path.split(";");
    my $seen = @path.Set;
    
    if $solution-found
    {
      return if $solution-found-size == @path.elems;
    }

    my $current = @path[*-1];

    my $next-word := gather
    {
      for ^$current.chars -> $index
      {
        my $next = $current;
        for @letters -> $letter
        {
          $next.substr-rw($index, 1) = $letter;
          next if $current eq $next;
          take $next if $dict{$next};
        }
      }
    }

    for $next-word -> $candidate
    {
      next if $seen{$candidate};

      if $candidate eq $stop
      {
        @solutions.push("$path;$candidate");
	$solution-found = True;
        $solution-found-size = @path.elems + 1;
      }
      else
      {
        @deferred.push("$path;$candidate");
      }
    }
  }
  return @solutions;
}

And that's it.