Perl Weekly Challenge 145.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 145.
Task 1: Dot Product
Submitted by: Mohammad S Anwar
You are given 2 arrays of same size, @a and @b.
Write a script to implement Dot Product.
Example:
@a = (1, 2, 3);
@b = (4, 5, 6);
$dot_product = (1 * 4) + (2 * 5) + (3 * 6) => 4 + 10 + 18 =>
32
This one is really simple using PDL, as it has an inner
method. I assume the inputs are in @ARGV as strings with space
separated numbers, so I just make ndarrays from them and ask
PDL to do the processing:
perl -MPDL -E '($x,$y)=map pdl([split " ", $_]), @ARGV; say "x=$x, y=$y, x.y=",
$x->inner($y)' "1 2 3" "4 5 6"
Results:
x=[1 2 3], y=[4 5 6], x.y=32
Otherwise, a solution could be built applying a reduction over the pairs of numbers, as in
perl -MList::MoreUtils=pairwise -MList::Util=sum0 -E '
($x,$y)=map [split " ", $_], @ARGV; $r=sum0 pairwise {$a*$b} @$x, @$y;
say "x=[",join(",", @$x),"], y=[", join(",", @$y),"], x.y=$r"' "1 2 3" "4 5 6"
Results:
x=[1,2,3], y=[4,5,6], x.y=32
The expanded solution is
1 # Perl weekly challenge 145
2 # Task 1: Dot product
3 #
4 # See https://wlmb.github.io/2021/12/27/PWC145/#task-1-dot-product
5 use v5.12;
6 use warnings;
7 use PDL;
8 use List::Util;
9 die "Usage: ./ch-1.pl 'x1 x2... xn' 'y1 y2... yn' to find dot product x.y"
10 unless @ARGV==2;
11 my ($x,$y)=map pdl([split " ", $_]), @ARGV;
12 die "Vectors should have the same positive length"
13 unless $x->nelem>0 && $y->nelem>0 && $x->nelem==$y->nelem;
14 say "x=$x, y=$y, x.y=", $x->inner($y);
Example:
./ch-1.pl "1 2 3" "4 5 6"
Results:
x=[1 2 3], y=[4 5 6], x.y=32
Task 2: Palindromic Tree
Submitted by: Mohammad S Anwar
You are given a string $s.
Write a script to create a Palindromic Tree for the given
string.
I found this [[https://medium.com/@alessiopiergiacomi/eertree-or-palindromic-tree-82453e75025b][blog]] exaplaining Palindromic Tree in detail.
Example 1:
Input: $s = 'redivider'
Output: r redivider e edivide d divid i ivi v
Example 2:
Input: $s = 'deific'
Output: d e i ifi f c
Example 3:
Input: $s = 'rotors'
Output: r rotor o oto t s
Example 4:
Input: $s = 'challenge'
Output: c h a l ll e n g
Example 5:
Input: $s = 'champion'
Output: c h a m p i o n
Example 6:
Input: $s = 'christmas'
Output: c h r i s t m a
I found several explanations, such as 1, 2, 3,
and 4, about palindrome trees and how to construct them. There
is one step I coudln’t figure out from their explanations (how
to get the suffix of a given node, see below) but
after thinking for some time, experimenting, and getting some sleep, I finally
found out. I should have used proper objects in the following
program, but the problem was simple enought that I used a
straightforward explicit hash representation for the tree
nodes.1
To each palindromic fragment within the given string there corresponds a
node (I use an anonimous hash for its representation)
with three entries, a size corresponding to the number of
characters of the fragment (0 for the null string and -1 for a
special imaginary node), a reference suffix to its largest
palindromic suffix and a hash edges of references indexed by
single letters pointing to larger palindromes built by
appending and prepending the corresponding letters. Thus if
there is a node $p corresponding to a palindromic fragment P and the
string contains a fragment Q=xPx where x is a single
letter, then the node $p for P would have an edge
$p->{edges}->{x} with value $q, the node corresponding to
Q. Furthermore, $q->{size} would equal
$p->{size}+2. Finally, $q->{suffix} is obtained by
following the suffix chain of $p until a palindrome R is
found, corresponding to a node $r such that xRx is
in the original string. As $r->{edge}->{x} corresponds
precisely to the palindrome xRx, which is the largest
palindromic suffix of Q, then $q->{suffix} should
be set to $r->{edge}->{x}. This is guaranteed to exist, as
xRx is also a palindromic prefix and must have been seen
before. There is a special treatment for the imaginary root
I of size -1, for which xIx is taken to mean x by itself
(of length -1+2=1).
1 # Perl weekly challenge 145
2 # Task 2: Palindromic tree
3 #
4 # See https://wlmb.github.io/2021/12/27/PWC145/#task-1-palindromic-tree
5 use v5.12;
6 use warnings;
7 use Text::Wrap qw(wrap $columns $break);
8
9 $columns=62;
10 $break=qr/\s/;
11
12 die "Usage: ./ch-2.pl string to find palindrome substrings" unless @ARGV;
13 my ($imaginary_root, $root, $current);
14 my @letters;
15 foreach(@ARGV){
16 $imaginary_root={size=>-1, edges=>{}};
17 $root={size=>0, edges=>{}};
18 $current=$root;
19 $_->{suffix}=$imaginary_root foreach($root, $imaginary_root);
20 @letters=grep {!/\s/} split '', lc $_; #ignore spaces and case
21 foreach(0..@letters-1){
22 add_letter($_);
23 }
24 my $output=[()];
25 palindromes($imaginary_root->{edges}->{$_}, $_, $output)
26 foreach keys $imaginary_root->{edges}->%*;
27 palindromes($root, "", $output);
28 say "Input: $_\nOutput: ", wrap("", " ",
29 join ", ", sort {length $a <=> length $b or $a cmp $b} $output->@*);
30 }
31 sub add_letter {
32 my $index=shift;
33 my $letter=$letters[$index];
34 $current=$current->{suffix}
35 while $index-$current->{size}-1<0
36 || $letters[$index-$current->{size}-1] ne $letter;
37 $current=$current->{edges}{$letter}, return
38 if defined $current->{edges}{$letter};
39 my $suffix=$current->{suffix};
40 $current=$current->{edges}->{$letter}
41 ={size=>$current->{size}+2, edges=>{}};
42 $current->{suffix}=$root, return if $current->{size}==1;
43 $suffix=$suffix->{suffix}
44 while $letters[$index-$suffix->{size}-1] ne $letter;
45 $current->{suffix}=$suffix->{edges}->{$letter};
46 return;
47 }
48
49 sub palindromes {
50 my ($start, $center, $output)=@_;
51 push @$output, $center if $center; # ignore the blank string of $root
52 palindromes($start->{edges}->{$_}, $_.$center.$_, $output)
53 foreach keys $start->{edges}->%*;
54 }
The implementation of the algorithm starts with a $root of zero length and an
$imaginary_root of length -1, with no edges and both pointing
to the $imaginary_root (lines 16-19). The last added node is kept in
$current and initialized to the $root (line 18). I
ignore spaces and case in
order to analyse palindromic phrases (line20). I
add_letter’s to the structure one by
one (line 22). In line 34 I follow the suffix chain of the current node
until I find a string from which to build a new palindromic
fragment present in the original string. If the fragment had
already been found, I update the
current fragment and return (line 37). Otherwise I setup a new node and
update the $current->{edges} and the new $current (line 40). Then I look for the proper
suffix for the new node starting from the previous
$current->{suffix} (line 39). Line 42 deals with the trivial
case. In line 43 we follow the suffix chain until we find an
appropriate one, which could be the $imaginary_root. The
sought after suffix for the new node is then obtained by
following the edge corresponding to the single
letter we are looking at (line 45).
To print the list of all palindromic fragments we follow the edges of
the roots recursively (line 52); the
odd-sized fragments starting from the $imaginary_root
(line 25) and the even-sized starting from the $root. When we
follow an edge with a given label x, we prepend and append
the label to the $center string to get the
new fragment. Finally, I sort all fragments by size and
alphabetically before printing.
Examples:
./ch-2.pl redivider deific rotors challenge champion christmas
Results:
Input: redivider
Output: d, e, i, r, v, ivi, divid, edivide, redivider
Input: deific
Output: c, d, e, f, i, ifi
Input: rotors
Output: o, r, s, t, oto, rotor
Input: challenge
Output: a, c, e, g, h, l, n, ll
Input: champion
Output: a, c, h, i, m, n, o, p
Input: christmas
Output: a, c, h, i, m, r, s, t
Another example, a classical palindrome in Spanish,
./ch-2.pl "Anita lava la tina"
Results:
Input: Anita lava la tina
Output: a, i, l, n, t, v, ala, ava, laval, alavala, talavalat,
italavalati, nitalavalatin, anitalavalatina
In order to apply the program to real texts I would have to remove punctuation. For analyzing palindromes in Spanish I would have to remove some diacritical marks. Thus, I prepared a modified program.
1 # Perl weekly challenge 145
2 # Task 2: Palindromic tree. Removing punctuation and diacritical marks
3 #
4 # See https://wlmb.github.io/2021/12/27/PWC145/#task-1-palindromic-tree
5 use v5.12;
6 use warnings;
7 use utf8;
8 use Encode qw(decode_utf8);
9 use Text::Wrap qw(wrap $columns $break);
10 use Text::Unidecode;
11
12 $columns=62;
13 $break=qr/\s/;
14
15 die "Usage: ./ch-2a.pl string to find palindrome substrings" unless @ARGV;
16 my ($imaginary_root, $root, $current);
17 my @letters;
18 foreach(@ARGV){ # assume utf8 in @ARGV
19 my $s=decode_utf8($_,9);
20 $imaginary_root={size=>-1, edges=>{}};
21 $root={size=>0, edges=>{}};
22 $current=$root;
23 $_->{suffix}=$imaginary_root foreach($root, $imaginary_root);
24 $s=~s/\p{Punct}//g; #remove punctuation
25 $s=~s/\s*//g; #remove spaces
26 @letters=split '', unidecode(lc $s); #ignore case, remove accents
27 foreach(0..@letters-1){
28 add_letter($_);
29 }
30 my $output=[()];
31 palindromes($imaginary_root->{edges}->{$_}, $_, $output)
32 foreach keys $imaginary_root->{edges}->%*;
33 palindromes($root, "", $output);
34 say "Input: $_\nOutput: ", wrap("", " ",
35 join ", ", sort {length $a <=> length $b or $a cmp $b} $output->@*);
36 }
37 sub add_letter {
38 my $index=shift;
39 my $letter=$letters[$index];
40 $current=$current->{suffix}
41 while $index-$current->{size}-1<0
42 || $letters[$index-$current->{size}-1] ne $letter;
43 $current=$current->{edges}{$letter}, return
44 if defined $current->{edges}{$letter};
45 my $suffix=$current->{suffix};
46 $current=$current->{edges}->{$letter}
47 ={size=>$current->{size}+2, edges=>{}};
48 $current->{suffix}=$root, return if $current->{size}==1;
49 $suffix=$suffix->{suffix}
50 while $letters[$index-$suffix->{size}-1] ne $letter;
51 $current->{suffix}=$suffix->{edges}->{$letter};
52
53 return;
54 }
55
56 sub palindromes {
57 my ($start, $center, $output)=@_;
58 push @$output, $center if $center; # ignore the blank string of $root
59 palindromes($start->{edges}->{$_}, $_.$center.$_, $output)
60 foreach keys $start->{edges}->%*;
61 }
Example, from Merlyna Acevedo’s book Relojes de Arena:
./ch-2a.pl "Alba helada: la luz azul al alba heríale. El aire
habla, ¡la luz azul alada le habla!"
Results:
Input: Alba helada: la luz azul al alba heríale. El aire
habla, ¡la luz azul alada le habla!
Output: a, b, d, e, h, i, l, r, u, z, ee, ada, ala, lal, zaz, leel,
ladal, lalal, uzazu, aleela, luzazul, ialeelai,
aluzazula, rialeelair, laluzazulal, erialeelaire,
alaluzazulala, herialeelaireh, aherialeelaireha,
baherialeelairehab, lbaherialeelairehabl,
albaherialeelairehabla, lalbaherialeelairehablal,
alalbaherialeelairehablala,
lalalbaherialeelairehablalal,
ulalalbaherialeelairehablalalu,
zulalalbaherialeelairehablalaluz,
azulalalbaherialeelairehablalaluza,
zazulalalbaherialeelairehablalaluzaz,
uzazulalalbaherialeelairehablalaluzazu,
luzazulalalbaherialeelairehablalaluzazul,
aluzazulalalbaherialeelairehablalaluzazula,
laluzazulalalbaherialeelairehablalaluzazulal,
alaluzazulalalbaherialeelairehablalaluzazulala,
dalaluzazulalalbaherialeelairehablalaluzazulalad,
adalaluzazulalalbaherialeelairehablalaluzazulalada,
ladalaluzazulalalbaherialeelairehablalaluzazulaladal,
eladalaluzazulalalbaherialeelairehablalaluzazulaladal
e,
heladalaluzazulalalbaherialeelairehablalaluzazulalada
leh,
aheladalaluzazulalalbaherialeelairehablalaluzazulalad
aleha,
baheladalaluzazulalalbaherialeelairehablalaluzazulala
dalehab,
lbaheladalaluzazulalalbaherialeelairehablalaluzazulal
adalehabl,
albaheladalaluzazulalalbaherialeelairehablalaluzazula
ladalehabla
Finally, I try my luck with object oriented programming using (for the
first time) Object::Pad to build my classes.
1 # Perl weekly challenge 145
2 # Task 2: Palindromic tree. Object based
3 #
4 # See https://wlmb.github.io/2021/12/27/PWC145/#task-1-palindromic-tree
5 use v5.26;
6 use warnings;
7 use utf8;
8 use Object::Pad;
9
10 class PNode {
11 has $size :param :reader;
12 has %edges;
13 has $suffix :param :accessor =undef;
14 method edge {
15 my $label=shift;
16 return $edges{$label};
17 }
18 method edges {
19 return keys %edges;
20 }
21 method add_edge {
22 my ($label, $target)=@_;
23 die "Duplicate edge" if defined $edges{$label};
24 $edges{$label}=$target;
25 }
26 BUILD {
27 %edges=();
28 }
29 };
30 class PTree {
31 use Encode qw(decode_utf8);
32 use Text::Unidecode;
33 has $string :param :reader;
34 has $imaginary_root :reader;
35 has $root :reader;
36 has $current :reader;
37
38 has @letters;
39 method $add_letter {
40 my $index=shift;
41 my $letter=$letters[$index];
42 $current=$current->suffix
43 while $index-$current->size-1<0
44 || $letters[$index-$current->size-1] ne $letter;
45 $current=$current->edge($letter), return
46 if defined $current->edge($letter);
47 my $suffix=$current->suffix;
48 my $found=$current;
49 $found->add_edge(
50 $letter,
51 $current=PNode->new(size=>$current->size+2, suffix=>$root));
52 return if $current->size==1;
53 $suffix=$suffix->suffix
54 while $letters[$index-$suffix->size-1] ne $letter;
55 $current->suffix($suffix->edge($letter));
56 }
57 method iterator {
58 my @queue=((map {[$imaginary_root->edge($_), $_]} $imaginary_root->edges), [$root, ""]);
59 sub {
60 {
61 return undef unless @queue;
62 my $element=shift @queue;
63 my ($node, $center)=$element->@*;
64 push @queue, (map {[$node->edge($_), $_.$center.$_]} $node->edges);
65 redo unless $center;
66 return $center;
67 }
68 }
69 }
70 BUILD {
71 $imaginary_root=PNode->new(size=>-1);
72 $imaginary_root->suffix($imaginary_root);
73 $root=PNode->new(size=>0, suffix=>$imaginary_root);
74 $current=$root;
75 my $s=decode_utf8($string,9);
76 $s=~s/\p{Punct}//g; #remove punctuation
77 $s=~s/\s*//g; #remove spaces
78 @letters=split '', unidecode(lc $s); #ignore case, remove accents
79 foreach(0..@letters-1){
80 $self->$add_letter($_);
81 }
82 }
83 };
84 foreach(@ARGV){
85 my $tree=PTree->new(string=>$_);
86 my $next=$tree->iterator;
87 while(my $p=$next->()){
88 say $p;
89 }
90 }
I define two classes PTree to represent a palindrome tree and
PNode to represent each of its nodes. Each PNode has a size, a
hash of its %edges and a $suffix. The PTree has a $root and an
$imaginary_root, a $string with which it is
initialized, and a $current node. The PNode has a method
to get the labels of all its edges, and a method edge to get a
succesor node from its label, and a method to add_edge’s. To BUILD the PTree I
basically copied the previous program, using a private method to
$add_letter’s. I added a method iterator that returns an anonimous
subroutine with which we can generate all the palindromic fragments.
I test the program with the previous example.
./ch-2b.pl "Alba helada: la luz azul al alba heríale. El aire
habla, ¡la luz azul alada le habla!"
and I confirm I obtain the same results.
u
z
d
i
h
a
r
b
l
e
ada
zaz
lal
ala
ee
ladal
uzazu
lalal
leel
luzazul
aleela
aluzazula
ialeelai
laluzazulal
rialeelair
alaluzazulala
erialeelaire
herialeelaireh
aherialeelaireha
baherialeelairehab
lbaherialeelairehabl
albaherialeelairehabla
lalbaherialeelairehablal
alalbaherialeelairehablala
lalalbaherialeelairehablalal
ulalalbaherialeelairehablalalu
zulalalbaherialeelairehablalaluz
azulalalbaherialeelairehablalaluza
zazulalalbaherialeelairehablalaluzaz
uzazulalalbaherialeelairehablalaluzazu
luzazulalalbaherialeelairehablalaluzazul
aluzazulalalbaherialeelairehablalaluzazula
laluzazulalalbaherialeelairehablalaluzazulal
alaluzazulalalbaherialeelairehablalaluzazulala
dalaluzazulalalbaherialeelairehablalaluzazulalad
adalaluzazulalalbaherialeelairehablalaluzazulalada
ladalaluzazulalalbaherialeelairehablalaluzazulaladal
eladalaluzazulalalbaherialeelairehablalaluzazulaladale
heladalaluzazulalalbaherialeelairehablalaluzazulaladaleh
aheladalaluzazulalalbaherialeelairehablalaluzazulaladaleha
baheladalaluzazulalalbaherialeelairehablalaluzazulaladalehab
lbaheladalaluzazulalalbaherialeelairehablalaluzazulaladalehabl
albaheladalaluzazulalalbaherialeelairehablalaluzazulaladalehabla
Footnotes
1 I already paid the price trying to debug a stupid mistake
(I forgot a $ sigil within ->{...})