Merge pull request #5437 from wlmb/challenges

Challenges

2 files changed, 73 insertions, 8 deletions

diff --git a/challenge-145/wlmb/perl/ch-2.pl b/challenge-145/wlmb/perl/ch-2.pl
index 52bca78943..4b0d431cb1 100755
--- a/challenge-145/wlmb/perl/ch-2.pl
+++ b/challenge-145/wlmb/perl/ch-2.pl
@@ -18,7 +18,7 @@ foreach(@ARGV){
     $root={size=>0, edges=>{}};
     $current=$root;
     $_->{suffix}=$imaginary_root foreach($root, $imaginary_root);
-    @letters=grep {!/[[:punct]|\s/} split '', lc $_; #ignore spaces and case
+    @letters=grep {!/\s/} split '', lc $_; #ignore spaces and case
     foreach(0..@letters-1){
 	add_letter($_);
     }
@@ -26,7 +26,8 @@ foreach(@ARGV){
     palindromes($imaginary_root->{edges}->{$_}, $_, $output)
 	foreach keys $imaginary_root->{edges}->%*;
     palindromes($root, "", $output);
-    say "Input: $_\nOutput: ", wrap("", "        ", join ", ", sort {$a cmp $b} $output->@*);
+    say "Input: $_\nOutput: ", wrap("", "        ",
+        join ", ", sort {length $a <=> length $b or $a cmp $b} $output->@*);
 }
 sub add_letter {
     my $index=shift;
@@ -34,13 +35,15 @@ sub add_letter {
     $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=$current->{edges}{$letter}, return
+        if defined $current->{edges}{$letter};
+    my $suffix=$current->{suffix};
+    $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;
+    $suffix=$suffix->{suffix}
+        while $letters[$index-$suffix->{size}-1] ne $letter;
+    $current->{suffix}=$suffix->{edges}->{$letter};
     return;
 }
 
diff --git a/challenge-145/wlmb/perl/ch-2a.pl b/challenge-145/wlmb/perl/ch-2a.pl
new file mode 100755
index 0000000000..fda194080f
--- /dev/null
+++ b/challenge-145/wlmb/perl/ch-2a.pl
@@ -0,0 +1,62 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 145
+# Task 2: Palindromic tree. Removing punctuation and diacritical marks
+#
+# See https://wlmb.github.io/2021/12/27/PWC145/#task-1-palindromic-tree
+use v5.12;
+use warnings;
+use utf8;
+use Encode qw(decode_utf8);
+use Text::Wrap qw(wrap $columns $break);
+use Text::Unidecode;
+
+$columns=62;
+$break=qr/\s/;
+
+die "Usage: ./ch-2a.pl string to find palindrome substrings" unless @ARGV;
+my ($imaginary_root, $root, $current);
+my @letters;
+foreach(@ARGV){ # assume utf8 in @ARGV
+    my $s=decode_utf8($_,9);
+    $imaginary_root={size=>-1, edges=>{}};
+    $root={size=>0, edges=>{}};
+    $current=$root;
+    $_->{suffix}=$imaginary_root foreach($root, $imaginary_root);
+    $s=~s/\p{Punct}//g; #remove punctuation
+    $s=~s/\s*//g; #remove spaces
+    @letters=split '', unidecode(lc $s); #ignore case, remove accents
+    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 {length $a <=> length $b or $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->{suffix};
+    $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;
+    $current->{suffix}=$suffix->{edges}->{$letter};
+
+    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}->%*;
+}