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.