Merge pull request #5430 from wlmb/challenges

Solve PWC145

3 files changed, 68 insertions, 0 deletions

diff --git a/challenge-145/wlmb/blog.txt b/challenge-145/wlmb/blog.txt
new file mode 100644
index 0000000000..4398ca2e08
--- /dev/null
+++ b/challenge-145/wlmb/blog.txt
@@ -0,0 +1 @@
+https://wlmb.github.io/2021/12/27/PWC145/
diff --git a/challenge-145/wlmb/perl/ch-1.pl b/challenge-145/wlmb/perl/ch-1.pl
new file mode 100755
index 0000000000..5d1b8fba5f
--- /dev/null
+++ b/challenge-145/wlmb/perl/ch-1.pl
@@ -0,0 +1,15 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 145
+# Task 1: Dot product
+#
+# See https://wlmb.github.io/2021/12/27/PWC145/#task-1-dot-product
+use v5.12;
+use warnings;
+use PDL;
+use List::Util;
+die "Usage: ./ch-1.pl 'x1 x2... xn' 'y1 y2... yn' to find dot product x.y"
+     unless @ARGV==2;
+my ($x,$y)=map pdl([split " ", $_]), @ARGV;
+die "Vectors should have the same positive length"
+     unless $x->nelem>0 && $y->nelem>0 && $x->nelem==$y->nelem;
+say "x=$x, y=$y, x.y=", $x->inner($y);
diff --git a/challenge-145/wlmb/perl/ch-2.pl b/challenge-145/wlmb/perl/ch-2.pl
new file mode 100755
index 0000000000..52bca78943
--- /dev/null
+++ b/challenge-145/wlmb/perl/ch-2.pl
@@ -0,0 +1,52 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 145
+# Task 2: Palindromic tree
+#
+# See https://wlmb.github.io/2021/12/27/PWC145/#task-1-palindromic-tree
+use v5.12;
+use warnings;
+use Text::Wrap qw(wrap $columns $break);
+
+$columns=62;
+$break=qr/\s/;
+
+die "Usage: ./ch-2.pl string to find palindrome substrings" unless @ARGV;
+my ($imaginary_root, $root, $current);
+my @letters;
+foreach(@ARGV){
+    $imaginary_root={size=>-1, edges=>{}};
+    $root={size=>0, edges=>{}};
+    $current=$root;
+    $_->{suffix}=$imaginary_root foreach($root, $imaginary_root);
+    @letters=grep {!/[[:punct]|\s/} split '', lc $_; #ignore spaces and case
+    foreach(0..@letters-1){
+	add_letter($_);
+    }
+    my $output=[()];
+    palindromes($imaginary_root->{edges}->{$_}, $_, $output)
+	foreach keys $imaginary_root->{edges}->%*;
+    palindromes($root, "", $output);
+    say "Input: $_\nOutput: ", wrap("", "        ", join ", ", sort {$a cmp $b} $output->@*);
+}
+sub add_letter {
+    my $index=shift;
+    my $letter=$letters[$index];
+    $current=$current->{suffix}
+        while $index-$current->{size}-1<0
+            || $letters[$index-$current->{size}-1] ne $letter;
+    $current=$current->{edges}{$letter}, return if defined $current->{edges}{letter};
+    my $suffix=$current;
+    $current=$current->{edges}->{$letter}={size=>$current->{size}+2, edges=>{}};
+    $current->{suffix}=$root, return if $current->{size}==1;
+    $suffix=$suffix->{suffix} while $letters[$index-$suffix->{size}-1] ne $letter;
+    $suffix=$suffix->{edges}->{$letter} if $suffix->{size}==-1;
+    $current->{suffix}=$suffix;
+    return;
+}
+
+sub palindromes {
+    my ($start, $center, $output)=@_;
+    push @$output, $center if $center; # ignore the blank string of $root
+    palindromes($start->{edges}->{$_}, $_.$center.$_, $output)
+        foreach keys $start->{edges}->%*;
+}