Perl Weekly Challenge 115.
My solutions (task 1, task 1a, task 1b, and task 2) to the The Weekly Challenge - 115.
Task 1: String Chain
Submitted by: Mohammad S Anwar
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.
I will assume that all the strings have to participate exactly once in the circle.
Connectivity matrix (almost correct)
There is a nice solution (see 1.4) to this task using matrices. I define a connectivity matrix Cij which has the value 0 if string i can follow string j and is zero otherwise. If I multiply this matrix by a column vector Kk which has the value 1 at position j=k and the value 0 elsewhere, then I obtain a vector with a 1 at the positions corresponding to each string that can be reached from the k-th string and 0 elsewhere. If I act with C on the result, I would get a vector with a 1 or a 2 at each position that may be reached by traveling two steps from string k, and zero elsewhere. The result 2 corresponds to those strings that may be reached following two different paths, and the result 1 to strings that can only be reached along a unique two-step path. Thus, the entry ij of the matrix C× C is the number of paths that can start at j and reach i in two steps. Analogously, C× C× C… repeated n times has entries ij showing the number of paths that start at j and end at i after n steps. A problem with this approach is that I may count paths that return to a starting position several times. To avoid this, I have to eliminate the diagonal elements before multiplication. Thus I define a set of new matrices as follows: D(1) is C after setting its diagonal elements to zero. Then I define recursively D(n) as E(n) with its diagonal elements set to zero, where E(n)=D(n-1)× D(1). I can make a cycle that visits every string if starting at any position j, give N-1 steps and return to j without having repeated any other site, that is, if E(N)jj≠ 0 for all j.
To manipulate the matrices I use the Perl Data Language.
To find out which string is connected to which other we just have to check their first and last letters.
# Perl weekly challenge 115
# Task 1: String Chain. Connectivity matrix solution. Not quite correct.
#
# See https://wlmb.github.io/2021/06/01/PWC115/#task-1-string-chain
use strict;
use warnings;
use v5.12;
use List::Util qw(reduce);
use PDL;
my @strings=@ARGV;
die "Usage ./ch-1.pl string1 [string2...]" unless @strings;
my $C=zeroes(long,scalar(@strings), scalar(@strings)); #connectivity matrix
map {my $f=$_;map {$C->slice("$f,$_").=follows($f, $_)}
(0..@strings-1)}(0..@strings-1);
my $R=reduce {map{$_->diagonal(0,1).=0}($a, $b); $b x $a;}
($C) x @strings;
say "Input: ", join " ", @strings;
say "Output: ", all($R->diagonal(0,1)>0);
sub follows {
my ($from, $to)=map {$strings[$_]} @_;
return substr($from,-1,1) eq substr($to,0,1);
}
Examples:
./ch-1.pl abc dea cd
./ch-1.pl ade cbd fgh
Results:
Input: abc dea cd
Output: 1
Input: ade cbd fgh
Output: 0
as expected from the description of the task.
Two cases with two short independent loops, inconmesurate in one case and conmesurate in the other:
./ch-1.pl ab bc ca de ed
./ch-1.pl ab bc ca de ef fd
Results:
Input: ab bc ca de ed
Output: 0
Input: ab bc ca de ef fd
Output: 0
In the first case, at the end of five steps no string went back to itself. In the second case, at the end of six steps all strings have gone back to themselves twice, but as the program eliminates early returns to the starting positions, the circle cannot be formed.
A similar case, connecting the loops:
./ch-1.pl ab bc ca de ed cd dc
Results:
Input: ab bc ca de ed cd dc
Output: 1
In the case, we do have a circle: ab-bc-cd-de-ed-dc-ca-repeat.
An example with just one string:
./ch-1.pl aa
Results:
Input: aa
Output: 1
as aa-repeat may be considered as a circle of length one. Note the trick
for this special case: reduce returns $C without further
processing, i.e., without zeroing the diagonal, when there is only one node.
An ambiguous case:
./ch-1.pl ab ba ab ba
Results:
Input: ab ba ab ba
Output: 1
as I didn’t demand unique strings, so I consider, for example, the
second ab as different from the first. Thus, I have the circle
ab1-ba1-ab2-ba2-repeat. If desired, it would be easy to filter out
repeated strings. If I demand unique strings, I can replace the
example above to
./ch-1.pl axb bxa ayb bya
Results:
Input: axb bxa ayb bya
Output: 1
Notice that in this case there is more than one circle:
axb-bxa-ayb-bya-repeat and axb-bya-ayb-bxa-repeat.
I found that it is actually unnecesary to remove the diagonal from
$b in the line
my $R=reduce {map{$_->diagonal(0,1).=0}($a, $b); $b x $a;}
($C) x @strings;
as it was meant to prevent returning immediately to the same string. Nevertheless, the program does allow returning to the same position after more than one step as long as it is not the starting position. It is for this reason that it is important to check that all the diagonal elements are non-zero. Otherwise, we would only check that there is a cycle of the correct length, but it may consist of more than one short circle and it may not visit all strings.
Build the actual circle
The program above doesn’t display the actual circle, it just states that it exists or that it doesn’t. If we want to display an actual circle we can build all viable paths of n+1 strings from those of n strings by adding all possible followers, pruning out early cycles.
# Perl weekly challenge 115
# Task 1: String Chain. Build the circle.
#
# See https://wlmb.github.io/2021/06/01/PWC115/#task-1-string-chain
use strict;
use warnings;
use v5.12;
use List::Util qw(first any);
my @strings=@ARGV;
die "Usage ./ch-1.pl string1 [string2...]" unless @strings;
my %followers;
map {my $f=$_;
$followers{$f}=[];
map {push @{$followers{$f}}, $_ if follows($f, $_)}@strings
} @strings;
my @paths=([$strings[0]]);
foreach (1..@strings-1){
@paths=grow(@paths);
}
say "Input: ", join " ", @strings;
my $path=first {follows($_->[-1], $_->[0])} @paths;
say "Output: ", defined $path?1:0;
say "Path: ", join "-", @$path if defined $path;
sub follows {
my ($from, $to)=@_;
return substr($from,-1,1) eq substr($to,0,1);
}
sub grow {
my @paths=@_;
my @new;
push @new, grow_one($_) for @paths;
return @new;
}
sub grow_one {
my $path=shift;
my @new=grep {defined $_} map {add_to($path, $_)} @{$followers{$path->[-1]}};
return @new;
}
sub add_to {
my ($path, $string)=@_;
return if any {$_ eq $string} @$path; # don't add duplicates
my @new=@$path; #copy
push @new, $string;
return [@new];
}
Examples:
./ch-1a.pl abc dea cd
./ch-1a.pl ade cbd fgh
./ch-1a.pl ab bc ca de ed
./ch-1a.pl ab bc ca de ef fd
./ch-1a.pl ab bc ca de ed cd dc
./ch-1a.pl aa
./ch-1a.pl ab ba ab ba
./ch-1a.pl axb bxa ayb bya
Results:
Input: abc dea cd
Output: 1
Path: abc-cd-dea
Input: ade cbd fgh
Output: 0
Input: ab bc ca de ed
Output: 0
Input: ab bc ca de ef fd
Output: 0
Input: ab bc ca de ed cd dc
Output: 1
Path: ab-bc-cd-de-ed-dc-ca
Input: aa
Output: 1
Path: aa
Input: ab ba ab ba
Output: 0
Input: axb bxa ayb bya
Output: 1
Path: axb-bxa-ayb-bya
Notice that this program agrees with the previous one except for the
case ab ba ab ba, as it doesn’t consider repeated strings to differ,
i.e., the second ab is eq to the first. The reason is that here
we refer to a string by its actual value, while in the former program we
refered to it through its index in the array of strings.
Königsberg bridges
The directed graphs corresponding to this problem have a peculiarity. The nodes may be grouped into equivalence classes according to the starting (or ending) letter. All nodes that connect to a member of a class, are also connected to all the remaining members of the class. Thus, I can make another graph where each node corresponds to an equivalence class, i.e., to a letter. A mathematician (my son) suggested that the problem could be mapped to that of the Königsberg (directed) bridges if I make a graph where the land areas (the nodes) correspond to the the first and last letters, and the bridges (the edges) correspond to the words that connect the first letter to the last. Then the circle could be found if, for each node, the number of incoming and outgoing edges coincide, and if the graph is not disjoint. The connectivity of the graph can be checked by multiplying the identity matrix by the connectivity matrix from 0 to N-1 times, where N is the number of nodes and checking that all matrix elements are non-zero in at least one of the resuling matrices.
# Perl weekly challenge 115
# Task 1: String Chain. Königsberg bridges solution
#
# See https://wlmb.github.io/2021/06/01/PWC115/#task-1-string-chain
use strict;
use warnings;
use v5.12;
use Exporter::Renaming; # prevent name clashes
use List::Util Renaming=>[uniq=>'lu_uniq', reduce=>'lu_reduce', reductions=>undef];
use PDL;
use PDL::NiceSlice;
my @strings=@ARGV;
die "Usage ./ch-1.pl string1 [string2...]" unless @strings;
my @letters=lu_uniq map{(substr($_,0,1), substr($_,-1,1))} @strings;
my %index;
@index{@letters}=(0..@letters-1);
my $C=zeroes(scalar(@letters), scalar(@letters)); #connectivity matrix
$C->($_->[0],$_->[1]).=$C->($_->[0],$_->[1])+1
foreach map { [$index{substr($_,0,1)},$index{substr($_,-1,1)}] } @strings;
my $balanced=all($C->sumover==$C->transpose->sumover);
my $final=lu_reduce {$a|$b} (reductions {$a x $b} (identity(scalar @letters), ($C) x (@letters-1)));
my $reachable=all($final!=0);
say "Input: ", join " ", @strings;
say "Output: ", $balanced &&$reachable? 1:0;
Examples:
./ch-1b.pl abc dea cd
./ch-1b.pl ade cbd fgh
./ch-1b.pl ab bc ca de ed
./ch-1b.pl ab bc ca de ef fd
./ch-1b.pl ab bc ca de ed cd dc
./ch-1b.pl aa
./ch-1b.pl axb bxa ayb bya
Results:
Input: abc dea cd
Output: 1
Input: ade cbd fgh
Output: 0
Input: ab bc ca de ed
Output: 0
Input: ab bc ca de ef fd
Output: 0
Input: ab bc ca de ed cd dc
Output: 1
Input: aa
Output: 1
Input: ab ba ab ba
Output: 1
Input: axb bxa ayb bya
Output: 1
The results agree with those of the previous solutions.
Counterexample
Actually, I was not completely sure my first solution would work for all possible inputs, but I couldn’t find an example where it failed. After submitting the first versions of my solutions, my mathematician son helped me find it. The following example with twelve words has two unconnected sets of words: those that start with a or b or c, and those that start with d or e or f. Thus it is impossible to make a circuit that visits all of the words. Nevertheless, each subset has trajectories that, starting from any word, loops around several times without returning to the initial word until after twelve steps, thus fooling my program.
./ch-1.pl axb ayb bxc byc cxa cya dxe dye exf eyf fxd fyd
./ch-1a.pl axb ayb bxc byc cxa cya dxe dye exf eyf fxd fyd
./ch-1b.pl axb ayb bxc byc cxa cya dxe dye exf eyf fxd fyd
Results:
Input: axb ayb bxc byc cxa cya dxe dye exf eyf fxd fyd
Output: 1
Input: axb ayb bxc byc cxa cya dxe dye exf eyf fxd fyd
Output: 0
Input: axb ayb bxc byc cxa cya dxe dye exf eyf fxd fyd
Output: 0
Clearly, the first program gives the wrong result.
Task 2: Largest Multiple
Submitted by: Mohammad S Anwar
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
This seems very simple. The least significant digit should be the smallest even number, as that makes the full number even. The rest of the digits should increase from least to most significant to get the largest digits multiplied by the largest powers of 10. I admit repeated digits.
# Perl weekly challenge 115
# Task 2: Largest Multiple
#
# See https://wlmb.github.io/2021/06/01/PWC115/#task-2-largest-multiple
use strict;
use warnings;
use v5.12;
use List::MoreUtils qw(first_index);
foreach(@ARGV){
die "Usage: ./ch-2.pl digits1 [digits2...]"
unless m/^\d+$/;
say "Input: $_";
my @digits=sort {$a<=>$b} split '', $_;
my $even_index=first_index {$_%2==0} @digits;
say("No even number may be constructed from input"), next
unless $even_index>=0;
my $last=splice @digits, $even_index,1;
say "Output: ", reverse(@digits), $last;
}
Examples
./ch-2.pl 1026 1428 4176 13579
Results:
Input: 1026
Output: 6210
Input: 1428
Output: 8412
Input: 4176
Output: 7614
Input: 13579
No even number may be constructed from input