# Perl Weekly Challenge 145.

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 145.

``````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  #
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
``````

``````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  #
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){
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  }
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  #
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){
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  }
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,
e,
leh,
aleha,
dalehab,
``````

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  #
5  use v5.26;
6  use warnings;
7  use utf8;
9
10  class PNode {
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      }
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;
37
38      has @letters;
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;
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){
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
zaz
lal
ala
ee
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
1 I already paid the price trying to debug a stupid mistake (I forgot a `\$` sigil within `->{...}`)