This is my response to the Perl Weekly Challenge #145.
@a and @b.
Dot Product.
@a = (1, 2, 3);
@b = (4, 5, 6);
$dot_product = (1 * 4) + (2 * 5) + (3 * 6) => 4 + 10 + 18 => 32
#! /usr/bin/env raku
unit sub MAIN ($a = '1 2 3', $b = '4 5 6'); # [1]
my @a = $a.words; # [2]
my @b = $b.words; # [2a]
die '@a and @b must have the same size' unless @a.elems == @b.elems; # [3]
say (^@a.elems).map({ @a[$_] * @b[$_] }).sum; # [4]
[1] Note the input format; two strings with space separated values.
[2] Get the individual values.
[3] Ensure that the two arrays have the same size. Note that a zero size is ok.
[4] For each index in the arrays ((^@a.elems)), get the sum of the
field with that index in the two arrays and multiply them
(.map({ @a[$_] * @b[$_] })). And finally get the sum of all those
values (.sum).
Running it:
$ ./dot-product
32
$ ./dot-product "1 2 3" "4 5 6"
32
Using map on an index like this is perfectly fine, but we can
do it much shorter with the infix zip operator Z (that merges the two lists). That would
give us a list of Pair values, which we would need to multiply together before the
final sum. But this operator has a meta version that uses the specified operator to
reduce the Pair to a single value. Multiplication is just a matter of writing
Z*.
See
docs.raku.org/routine/Z
for more information about the infix zip operator Z.
#! /usr/bin/env raku
unit sub MAIN ($a = '1 2 3', $b = '4 5 6');
my @a = $a.words;
my @b = $b.words;
die '@a and @b must have the same size' unless @a.elems == @b.elems;
say (@a Z* @b).sum;
The result of running it is the same as the previous version:
$ ./dot-product-Z "1 2 3" "4 5 6"
32
#! /usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use List::Util 'sum';
my $a = shift(@ARGV) // '1 2 3';
my $b = shift(@ARGV) // '4 5 6';
my @a = split(/\s+/, $a);
my @b = split(/\s+/, $b);
die '@a and @b must have the same size' unless @a == @b;
say sum(map { $a[$_] * $b[$_] } (0 .. @a -1));
Running it gives the same result as the Raku versions:
$ ./dot-product-perl "1 2 3" "4 5 6"
32
$s.
Palindromic Tree for the given string.
Palindromic Tree in detail.
Input: $s = 'redivider'
Output: r redivider e edivide d divid i ivi v
Input: $s = 'deific'
Output: d e i ifi f c
Input: $s = 'rotors'
Output: r rotor o oto t s
Input: $s = 'challenge'
Output: c h a l ll e n g
Input: $s = 'champion'
Output: c h a m p i o n
Input: $s = 'christmas'
Output: c h r i s t m a
There are several ways of doing this. Let us start with a hard (and extremely stupid) way:
File: palindromic-tree
#! /usr/bin/env raku
unit sub MAIN ($s is copy = 'redivider', :v(:$verbose));
my @result;
my %seen;
while ($s.chars) # [1]
{
my $letter = $s.substr(0,1); # [2]
@result.push: $letter unless %seen{$letter}; # [2a]
%seen{$letter} = True; # [3]
last if $s.chars == 1; # [4]
my $is-palindromic = is-palindromic($s); # [5]
if ($is-palindromic) # [6]
{
my $new = $s.substr(0, $is-palindromic); # [10]
@result.push: $new; # [11]
if ($is-palindromic == $s.chars) # [12]
{
$s = $s.substr(1, $is-palindromic -2); # [12a]
}
else
{
$s = $s.substr(1, $is-palindromic -1) ~ $s.substr($is-palindromic);
} # [13]
}
else
{
$s = $s.substr(1); # [14]
}
say "Result: @result[] | Todo: $s" if $verbose;
}
say @result.join(" "); # [15]
sub is-palindromic($string) # [5a]
{
for $string.chars ... 2 -> $end # [6]
{
my $partial = $string.substr(0, $end); # [7]
return $end if $partial eq $partial.flip; # [8]
}
return 0; # [9]
}
[1] As long as there are letters left in $s. We chop off the first one
in [12a], [13] and [14].
[2] The first letter in the current string (note the loop). Add it to the list if it is the first time we encounter it [2a].
[3] Now we have seen this letter.
[4] This one will actually kick in before the test in the while [1].
We are done when we have reached the very last letter, as we need at least two letters
to have a palindrome.
[5] Do we have a palindrome in the current string (or a part of it)?
[6] From the end,
[7] Get a substring, first the whole string and thereafter we chop off the last one - one by one.
[8] Return the length if we have a palindrome.
[9] No palindrome.
[10] We have a palindrome, get it.
[11] Add the palindrome to the list.
[12] Did the palindrome use all the characters? if so chop off the first and last character.
[13] If not, get rid of the palindrome part and add the rest of the string.
[14] Not palindromic, get rid of the first character.
[15] Print the result.
Running it:
$ ./palindromic-tree redivider
r redivider e edivide d divid i ivi v
$ ./palindromic-tree deific
d e i ifi f c
$ ./palindromic-tree rotors
r rotor o oto t s
$ ./palindromic-tree challenge
c h a l ll e n g
$ ./palindromic-tree champion
c h a m p i o n
$ ./palindromic-tree christmas
c h r i s t m a
Looking good.
We can simplify the program slightly, by replacing the housekeeping in [2a and 3] with
unique on the resulting array:
#! /usr/bin/env raku
unit sub MAIN ($s is copy = 'redivider', :v(:$verbose));
my @result;
while ($s.chars)
{
my $letter = $s.substr(0,1);
@result.push: $letter;
last if $s.chars == 1;
my $is-palindromic = is-palindromic($s);
if ($is-palindromic)
{
my $new = $s.substr(0, $is-palindromic);
@result.push: $new;
if ($is-palindromic == $s.chars)
{
$s = $s.substr(1, $is-palindromic -2);
}
else
{
$s = $s.substr(1, $is-palindromic -1) ~ $s.substr($is-palindromic);
}
}
else
{
$s = $s.substr(1);
}
say "Result: @result[] | Todo: $s" if $verbose;
}
say @result.unique.join(" ");
sub is-palindromic($string)
{
for $string.chars ... 2 -> $end
{
my $partial = $string.substr(0, $end);
return $end if $partial eq $partial.flip;
}
return 0;
}
Running it gives the same result.
We can indeed simplify this quite a lot. Here is a version that does what it should, as long as the order of the values does not matter:
File: palindromic-tree-unordered
#! /usr/bin/env raku
unit sub MAIN ($s is copy = 'redivider', :v(:$verbose));
my @result = $s.comb; # [1]
my $length = $s.chars; # [2]
for 0 .. $length -2 -> $start # [3]
{
for $start +1 .. $length -1 -> $stop # [4]
{
my $candidate = $s.substr($start, $stop - $start +1); # [5]
say ": [$start,$stop] $candidate" if $verbose;
@result.push: $candidate if $candidate.flip eq $candidate; # [6]
}
}
say @result.unique.join(" "); # [7]
[1] All the single letters should end up in the result, so add them.
[2] We need this for the loops.
[3] Start at every possible character, excluding the very last one (so that we get at least two characters when we start at that position).
[4] Stop at the very next position, up to the very end.
[5] Get the substring.
[6] Add it to the result if it is palindromic.
[7] Print the result, excluding duplicates.
Running it gives the correct result, albeit in a different order:
$ ./palindromic-tree-unordered redivider
r e d i v redivider edivide divid ivi
$ ./palindromic-tree-unordered deific
d e i f c ifi
$ ./palindromic-tree-unordered rotors
r o t s rotor oto
$ ./palindromic-tree-unordered challenge
c h a l e n g ll
$ ./palindromic-tree-unordered champion
c h a m p i o n
$ ./palindromic-tree-unordered christmas
c h r i s t m a
We can fix the order, by moving the push of the individual letters
inside the first loop:
#! /usr/bin/env raku
unit sub MAIN ($s is copy = 'redivider', :v(:$verbose));
my @result;
my $length = $s.chars;
for 0 .. $length -> $start
{
@result.push: $s.substr($start,1);
next if $start > $length -2;
for $start +1 .. $length -1 -> $stop
{
my $candidate = $s.substr($start, $stop - $start +1);
say ": [$start,$stop] $candidate" if $verbose;
@result.push: $candidate if $candidate.flip eq $candidate;
}
}
say @result.unique.join(" ");
Running it gives the output in the required order:
$ ./palindromic-tree-reordered redivider
r redivider e edivide d divid i ivi v
$ ./palindromic-tree-reordered deific
d e i ifi f c
$ ./palindromic-tree-reordered rotors
r rotor o oto t s
$ ./palindromic-tree-reordered challenge
c h a l ll e n g
$ ./palindromic-tree-reordered champion
c h a m p i o n
$ ./palindromic-tree-reordered christmas
c h r i s t m a
Verbose mode gives the substrings, if you want to have a closer look at what is going on:
$ ./palindromic-tree-reordered -v
: [0,1] re
: [0,2] red
: [0,3] redi
: [0,4] rediv
: [0,5] redivi
: [0,6] redivid
: [0,7] redivide
: [0,8] redivider
: [1,2] ed
: [1,3] edi
: [1,4] ediv
: [1,5] edivi
: [1,6] edivid
: [1,7] edivide
: [1,8] edivider
: [2,3] di
: [2,4] div
: [2,5] divi
: [2,6] divid
: [2,7] divide
: [2,8] divider
: [3,4] iv
: [3,5] ivi
: [3,6] ivid
: [3,7] ivide
: [3,8] ivider
: [4,5] vi
: [4,6] vid
: [4,7] vide
: [4,8] vider
: [5,6] id
: [5,7] ide
: [5,8] ider
: [6,7] de
: [6,8] der
: [7,8] er
r redivider e edivide d divid i ivi v
#! /usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use Getopt::Long;
use List::Util 'uniq';
my $verbose = 0;
GetOptions("verbose" => \$verbose);
my $s = $ARGV[0] // 'redivider';
my @result;
my $length = length($s);
for my $start (0 .. $length)
{
push(@result, substr($s, $start, 1));
next if $start > $length -2;
for my $stop ($start +1 .. $length -1)
{
my $candidate = substr($s, $start, $stop - $start +1);
say ": [$start,$stop] $candidate" if $verbose;
push(@result, $candidate) if reverse($candidate) eq $candidate;
}
}
say join(" ", uniq @result);
Running it gives the expected result:
$ ./palindromic-tree-perl redivider
r redivider e edivide d divid i ivi v
$ ./palindromic-tree-perl deific
d e i ifi f c
$ ./palindromic-tree-perl rotors
r rotor o oto t s
$ ./palindromic-tree-perl challenge
c h a l ll e n g
$ ./palindromic-tree-perl champion
c h a m p i o n
$ ./palindromic-tree-perl christmas
c h r i s t m a
And that's it. (Happy new year.)