Hamilton Unchained
with Raku and Perl

by Arne Sommer

Hamilton Unchained with Raku and Perl

[131] Published 5. June 2021.

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

Challenge #115.1: String Chain

You are given an array of strings.

Write a script to find out if the given strings can be chained to form a circle. Print 1 if found otherwise 0.

A string $S can be put before another string $T in circle if the last character of $S is same as first character of $T.
Examples: 
Input: @S = ("abc", "dea", "cd")
Output: 1 as we can form circle e.g. "abc", "cd", "dea".

Input: @S = ("ade", "cbd", "fgh")
Output: 0 as we can't form circle.

A Directed Graph

This challange describes a directed graph, without using that name.

I have written a five-part article about (undirected) graphs. See Seven Bridges to Raku.

A Hamiltonian Circuit (also called Hamiltonian Circle) seems promising as an answer to what we are looking for (except that it is undirected, and we are dealing with a directed graph; e.g. abc -> cd -> dea -> abc). Part 3 of my article discusses Hamilton, as does en.wikipedia.org/wiki/Hamiltonian_path.

Let us follow the Seven Bridges, and see where we end up. (Preferably not in hot water...)

We can start by generating the configuration file used by the programs in the Seven Bridges articles (presented in part 1, and extended to support directed graphs in part 5). Then we can (re)use the programs from that article to test the graphs.

File: string-chain-7bridges 
#! /usr/bin/env raku

unit sub MAIN (*@S where @S.elems > 0);                              # [1]

die "Non-unique string not allowed" if @S.elems != @S.unique.elems;  # [2]

for @S -> $elem                                                      # [3]
{
  say "$elem: $elem";
}

for @S -> $first                                                      # [4]
{
  for @S -> $second                                                   # [4]
  {
    next if $second eq $first;                                        # [5]

    if $second.substr(*-1,1) eq $first.substr(0,1)                    # [6]
    {
      say "$second>$first {$first.substr(0,1)}";
    }
  }
}

[1] Ensure at least one string in the array. The challenge does not specify a lower limit, but this is the absolute minimum that can work. Sort of.

[2] We are using the strings as identifiers, so they have to be unique. (This may be a problem, but I'll come back to that later on.)

[3] Print all the strings; the nodes (or circles) in the graph. We use the string both as identifier and name, as it is unique.

[4] For each string, in a double loop.

[5] Skip the situation where both loops have the same string.

[6] Print a connection (edge) if the last letter of the first string (outer loop) is the same as the first letter of the second string (inner loop). Use the letter as the name.

Running it, redirecting the output to a file: 

$ ./string-chain-7bridges abc dea cd > example1.def
$ ./string-chain-7bridges ade cbd fgh > example2.def
File: example1.def 
abc: abc
dea: dea
cd: cd
dea>abc a
cd>dea d
abc>cd c
File: example2.def 
ade: ade
cbd: cbd
fgh: fgh

Then we can use the bridges3svg shell script wrapper around bridges-graphviz-directional, both copied from part 5 of the Seven Bridges, to generate the Graphviz «dot» file and the resulting graph as a SVG file in one go: 

$ ./bridges3svg example1.def 
: example1.def -> example1.dot
: example1.dot -> example1.svg

$ ./bridges3svg example2.def 
: example1.def -> example2.dot
: example1.dot -> example2.svg

The graphs:

example1.svg
example2.svg

We can clearly see that the first example forms a Hamiltonian Circuit (and the directionality business does not matter here), and the second one does not.

Hamilton's Revenge

Just for fun; here is a directed graph that does not form a circle, but it satisfies Hamilton if we make it undirected: 

$ ./string-chain-7bridges abc dex conyd cd > revenge.def
$ ./bridges3svg  revenge.def 
: revenge.def -> revenge.dot
: revenge.dot -> revenge.svg

That was kind of fun. But we were asked to write a program to tell us. We can use the «hamiltonian2» program from part 3 of the Seven Bridges. Except that it does not support directed graphs, which we do have. That is easily fixed though, and the resulting «hamiltonian-unchained» program is included in the zip file:

File: hamiltonian-unchained (changes only) 
  elsif $line ~~ /^(\w+) (<[\s\>]>) (\w+) \s (.*) /        # [1]
  {
    my ($from, $dir, $to, $name) = ($0, $1, $2, $3.trim);  # [2]
    die "No such node $from" unless %nodes{$from};
    die "No such node $to"   unless %nodes{$to};

    $name = $0.trim if $name ~~ /(.*?)\#/;
    
    %edges{$from}.push: $name;
    %edges{$to}.push: $name;
    %next{$from}.push: $to.Str;
    %next{$to}.push: $from.Str unless $dir eq ">";         # [3]
   }

[1] Accept either a space (\s) or a > as separator between the two nodes.

[2] Take note of the separator character. The other matches have been renumbered as a consequence.

[3] The second direction is only there for an undirectional connection (bridge).

Running it: 

$ ./hamiltonian-unchained example1.def
Eulerian path/trail & Eulerian cycle/circuit.
Hamiltonian path: abc -> cd -> dea

$ ./hamiltonian-unchained example2.def
Not an Eulerian path/trail nor a cycle/circuit (as we have at least two graphs).

The program does not explicitly say that the second graph is not a Hamiltonian path, but that follows from the fact that a Hamiltonian path is also a Eulerian graph (but not the other way round).

We can fix that. (Especially the part where we exclaim that it is a Hamiltonian Path, as it really is not.)

But perhaps not…

Let us take a step back, and reflect. The chosen approach does give us the solution to the challenge, but it is not very efficiently programmed. We can certainly do better (as in shorter).

Let us do just that.

File: string-chain 
#! /usr/bin/env raku

unit sub MAIN (*@S where @S.elems > 1,                # [1]
               :v(:$verbose),
               :n(:$no-duplicates));                  # [2]

die "Non-unique string not allowed"                   # [2a]
  if $no-duplicates && @S.elems != @S.unique.elems;

for @S.permutations -> @perm                          # [3]
{
  say ": perm: { @perm.join(", ") }" if $verbose;

  if is-circle(@perm)                                 # [4]
  {
    say 1;
    exit;
  }
}

say 0;                                                # [5]

sub is-circle (@list is copy)                                     # [6]
{
  my $first       = @list.shift;                                  # [7]
  my $first-start = $first.substr(0,1);                           # [8]
  my $second;                                                     # [9]

  while @list                                                     # [10]
  {
    $second = @list.shift;                                        # [10a]
    return False if $first.substr(*-1,1) ne $second.substr(0,1);  # [10b]
    $first  = $second;                                            # [10c]
  }
    
  return True if $first-start eq $second.substr(*-1,1);           # [11]
  return False;                                                   # [12]
}

[1] Ensure at least two words.

[2] Use this command line option if you want to disallow duplicate words. The program will fail if the list of words have shrunk after removing duplicates (with the unique method) [2a].

[3] This gives us all the permutations of the words (i.e. all the possible sorting order). E.g. will «a b c» result in «a b c», «a c b», «b a c», «b c a», «c a b» and «c b a» (shown here in sorted order).

[4] If the current permutation forms a circle, print «1» and exit.

[5] No match? Then print 0 and we are done.

[6] Do the given words form a circle, in the given order?

[7] We are handling two and two words at a time. The first one goes here.

[8] The first letter of the first word. We need this for comparison with the last letter of the last word in [11].

[9] The second one goes here.

[10] As long as we have more words, get the next one (in the second variable) [10a], return False if the two words do not match up (last letter to first letter) [10b]. Shuffle the secdond word to the first variable, ready for the next iteration [10c].

[11] See [8].

[12] No match.

See docs.raku.org/routine/permutations for more information about permutations.

Running it: 

$ ./string-chain -v abc dea cd
: perm: abc, dea, cd
: perm: abc, cd, dea
1

$ ./string-chain -v ade cbd fgh
: perm: ade, cbd, fgh
: perm: ade, fgh, cbd
: perm: cbd, ade, fgh
: perm: cbd, fgh, ade
: perm: fgh, ade, cbd
: perm: fgh, cbd, ade
0

Looking good.

Note that this program handles duplicates: 

$ ./string-chain -v axe axe eva elena 
: perm: axe, axe, eva, elena
: perm: axe, axe, elena, eva
: perm: axe, eva, axe, elena
1

Unless we tell it otherwise: 

$ ./string-chain -v -n axe axe eva elena 
Non-unique string not allowed
  in sub MAIN at ./string-chain line 5

The graph generating program should really cope with duplicate values. That is easy(ish) to fix by using incremental IDs for the nodes:

File: string-chain-7bridges-duplicates 
#! /usr/bin/env raku

unit sub MAIN (*@S where @S.elems > 0);

my %elems;                 # [1]
my $id = 0;

for @S -> $elem
{
  %elems{++$id} = $elem;  # [2]
  say "$id: $elem";       # [2a]
}

for 1 .. $id -> $first
{
  for 1 .. $id -> $second
  {
    next if $second eq $first;

    if %elems{$second}.substr(*-1,1) eq %elems{$first}.substr(0,1)  # [3]
    {
      say "$second>$first {%elems{$first}.substr(0,1)}";            # [4]
    }
  }
}

[1] The mapping between IDs and names. I have chosen a hash (instead of an array) so that it is possible to use another ID scheme later.

[2] Note the mapping between the ID and name, and print them [2a].

[3] Compare the names, and not the IDs.

[4] Use the IDs, but the first letter from the name (on the connection).

$./string-chain-7bridges-duplicates axe axe eva elena >duplicates.def

$ ./bridges3svg duplicates.def
: duplicates.def -> duplicates.dot
: duplicates.dot -> duplicates.svg
File: duplicates.def 
1: axe
2: axe
3: eva
4: elena
3>1 a
4>1 a
3>2 a
4>2 a
1>3 e
2>3 e
1>4 e
2>4 e

The resulting graph:

It is circular - even if it is hard to tell. We can show it, by highlighting the (or a) path with «-highlight» command line option. This is not supported by the shell script wrapper, so we must run the two commands manually: 

$ ./bridges-graphviz-directional --highlight="1 3 2 4 1" duplicates.def > duplicates-path.dot 
$ dot -Tsvg duplicates-path.dot > duplicates-path.svg

We got the node names (IDs, really) from the definition file, made sure we got the directions right when we chose the path to highlight - and that we closed the circle (by specifiying the same node as start and end):

File: duplicates.def 
1: axe
2: axe
3: eva
4: elena
3>1 a
4>1 a
3>2 a
4>2 a
1>3 e
2>3 e
1>4 e
2>4 e

A Perl Version

This is straight forward translation of the Raku version.

File: string-chain-perl 
#! /usr/bin/env perl

use strict;
use warnings;
use feature 'say';
use Getopt::Long;
use Algorithm::Combinatorics 'permutations';  # [1]
use feature 'signatures';

no warnings qw(experimental::signatures);

my $verbose = 0;

GetOptions("verbose" => \$verbose);

die "At least two strings" unless @ARGV > 1;

for my $list (permutations(\@ARGV))
{
  my @perm = @$list;

  say ": perm: " . join(", ", @perm) if $verbose;
  
  if (is_circle(@perm))
  {
    say 1;
    exit;
  }
}

say 0;

sub is_circle (@list)
{
  my $first       = shift(@list);
  my $first_start = substr($first, 0,1);
  my $second;

  while (@list)
  {
    $second = shift(@list);
    return 0 if substr($first,-1,1) ne substr($second,0,1);
    $first  = $second;
  }
    
  return 1 if $first_start eq substr($second,-1,1);
  return 0;
}

[1] Perl does not have a permutations function, but this module supplies one for us.

Running it gives the same result as the Raku version: 

$ ./string-chain-perl -v abc dea cd
: perm: abc, dea, cd
: perm: abc, cd, dea
1

$ ./string-chain-perl -v ade cbd fgh
: perm: ade, cbd, fgh
: perm: ade, fgh, cbd
: perm: cbd, ade, fgh
: perm: cbd, fgh, ade
: perm: fgh, ade, cbd
: perm: fgh, cbd, ade
0

I have dropped the duplicate suppresion code.

Challenge #115.2: Largest Multiple

You are given a list of positive integers (0-9), single digit.

Write a script to find the largest multiple of 2 that can be formed from the list.

Examples: 
Input: @N = (1, 0, 2, 6)
Output: 6210

Input: @N = (1, 4, 2, 8)
Output: 8412

Input: @N = (4, 1, 7, 6)
Output: 7614

«Multiple of 2» is another name for «even integers larger than 0».

File: largest-multiple 
#! /usr/bin/env raku

unit sub MAIN (*@N where @N.elems > 0 && all(@N) == any(0..9),           # [1]
               :v(:$verbose)); 

my @all = @N.permutations>>.join.grep(* ~~ / <[02468]> $/).sort.reverse; # [2]

say ": { @all.join(", ") }" if $verbose && @all;

say @all[0] if @all[0] && @all[0] != 0;                                  # [3]

[1] Ensure that the input list has at least one element, and that all of them are a single digit.

[2] Get all possible soring orders of the digits (with permutations), then join the digits for each permutation (with >>.join) so that we get a list of numbers. Keep the numbers ending with 0, 2, 4, 6 or 8 (as that gives an even number) (with grep). Then we sort the list, giving the lowest number first. Adding reverse gives the highest value first.

[3] Print the first value if it is defined and non-zero. (Defined as we could have ended up with nothing after getting rid of the odd numbers, and zero as we could end up with that number.

Running it: 

$ ./largest-multiple -v 1 0 2 6
: 6210, 6120, 6102, 6012, 2610, 2160, 2106, 2016, 1620, 1602, 1260, 1206, \
  1062, 1026, 0612, 0216, 0162, 0126
6210

$ ./largest-multiple -v 1 4 2 8
: 8412, 8214, 8142, 8124, 4812, 4218, 4182, 4128, 2814, 2418, 2184, 2148, \
  1842, 1824, 1482, 1428, 1284, 1248
8412

$ ./largest-multiple -v 4 1 7 6
: 7614, 7416, 7164, 7146, 6714, 6174, 4716, 4176, 1764, 1746, 1674, 1476
7614

Looking good.

Let us try the cases from comment [3]: 

$ ./largest-multiple -v 1 3 5 7

$ ./largest-multiple -v 0 0 0
: 000, 000, 000, 000, 000, 000

The first one does not print anything, not even in verbose mode. The second one ends up with the number 0, which is not a muliple of 2. So no answer here as well.

One more: 

$ ./largest-multiple -v 1 1 1 0
: 1110, 1110, 1110, 1110, 1110, 1110
1110

We could have removed the duplicates with unique (works all the time) or squish (works on sorted structures only), but it does not really matter.

See docs.raku.org/routine/unique for more information about unique.

See docs.raku.org/routine/squish for more information about squish.

Perl

This is a straight forward translation of the Raku version.

File: largest-multiple-perl 
#! /usr/bin/env perl

use strict;
use warnings;
use feature 'say';
use Getopt::Long;
use Algorithm::Combinatorics 'permutations';

my $verbose = 0;

GetOptions("verbose" => \$verbose);

my @all;

for my $list (permutations(\@ARGV))  # [1]
{
  my @candidate = @$list;
  my $value     = join("", @candidate);

  next unless $value =~ /[02468]$/;

  push(@all, $value);
}

@all = reverse sort @all;

say ": " . join(", ", @all) if $verbose && @all;

say $all[0] if $all[0] && $all[0] != 0;

[1] I have chosen to use a loop instead of method chaining (with e.g. grep as in the Raku version), as the number of steps in the original Raku code line (marked [2]) is quite large.

Running it gives the same result as the Raku version: 

$ ./largest-multiple-perl -v 1 0 2 6
: 6210, 6120, 6102, 6012, 2610, 2160, 2106, 2016, 1620, 1602, 1260, 1206, \
  1062, 1026, 0612, 0216, 0162, 0126
6210

$ ./largest-multiple-perl -v 1 4 2 8
: 8412, 8214, 8142, 8124, 4812, 4218, 4182, 4128, 2814, 2418, 2184, 2148, \
  1842, 1824, 1482, 1428, 1284, 1248
8412

$ ./largest-multiple-perl -v 4 1 7 6
: 7614, 7416, 7164, 7146, 6714, 6174, 4716, 4176, 1764, 1746, 1674, 1476
7614

$ ./largest-multiple-perl -v 1 3 5 7

$ ./largest-multiple-perl -v 0 0 0
: 000, 000, 000, 000, 000, 000

And that's it.

Links
 About me
 Keyword Index
Raku Courses
 Beginning Raku (book)
 RSS Feed
 Code (zip)
Reddit Comments