Merge pull request #4198 from wlmb/challenges

Challenges

3 files changed, 33 insertions, 3 deletions

diff --git a/challenge-115/wlmb/perl/ch-1.pl b/challenge-115/wlmb/perl/ch-1.pl
index a2accad0fd..91d51b3195 100755
--- a/challenge-115/wlmb/perl/ch-1.pl
+++ b/challenge-115/wlmb/perl/ch-1.pl
@@ -1,6 +1,6 @@
 #!/usr/bin/env perl
 # Perl weekly challenge 115
-# Task 1: String Chain
+# 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;
@@ -14,7 +14,7 @@ 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;}
+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);
diff --git a/challenge-115/wlmb/perl/ch-1a.pl b/challenge-115/wlmb/perl/ch-1a.pl
index a1edad7c3e..afc99d62a4 100755
--- a/challenge-115/wlmb/perl/ch-1a.pl
+++ b/challenge-115/wlmb/perl/ch-1a.pl
@@ -1,6 +1,6 @@
 #!/usr/bin/env perl
 # Perl weekly challenge 115
-# Task 1: String Chain
+# Task 1: String Chain. Build the circle.
 #
 # See https://wlmb.github.io/2021/06/01/PWC115/#task-1-string-chain
 use strict;
@@ -23,21 +23,25 @@ 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
diff --git a/challenge-115/wlmb/perl/ch-1b.pl b/challenge-115/wlmb/perl/ch-1b.pl
new file mode 100755
index 0000000000..089024cb56
--- /dev/null
+++ b/challenge-115/wlmb/perl/ch-1b.pl
@@ -0,0 +1,26 @@
+#!/usr/bin/env perl
+# 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;