and Perl

This is my response to the Perl Weekly Challenge #113.

You are given a positive integer

Write a script to check if

Example:

File: represent-integer
`$N`

and a digit `$D`

.
Write a script to check if

`$N`

can be represented as a sum of positive
integers having `$D`

at least once. If check passes print 1 otherwise 0.
Example:

Input: $N = 25, $D = 7
Output: 0 as there are 2 numbers between 1 and 25 having the digit 7
i.e. 7 and 17. If we add up both we don't get 25.
Input: $N = 24, $D = 7
Output: 1

#! /usr/bin/env raku
unit sub MAIN (Int $N where $N > 0, # [1]
Int $D where $D.chars == 1, # [2]
:v($verbose));
my @candidates = (1 .. $N).grep( * ~~ /$D/); # [3]
say ": Candidates { @candidates.join(', ') }" if $verbose;
for @candidates.combinations(1..*) -> @comb # [4]
{
say ": Considering { @comb.join(' + ') }" if $verbose;
if @comb.sum == $N # [5]
{
say 1; # [5a]
exit; # [5b]
}
}
say 0; # [6]

[1] Ensure a positive integer.

[2] Ensure a single digit.

[3] All possible values we can add togeter, starting with every value between
`1`

and `$N`

.
Then we apply grep to get rid of values where the digit `$D`

does not
occur.

[4] For every combination of values from the candidate values
(where `(1..*)`

means every size from 1 to infinite; i.e. we skip the empty
list),

[5] Do the values sum up to `$N`

? If so, print `1`

[5a] and
exit [5b]. If not, the loop goes on.

[6] If we get here, it means that we did not find a match. Print `0`

.

See
docs.raku.org/routine/combinations
for more information about `combinations`

.

Running it:

$ ./represent-integer 25 7
0
$ ./represent-integer 24 7
1

With verbose mode:

./represent-integer -v 25 7
: Candidates 7, 17
: Considering 7
: Considering 17
: Considering 7 + 17
0
$ ./represent-integer -v 24 7
: Candidates 7, 17
: Considering 7
: Considering 17
: Considering 7 + 17
1

Looking good.

#! /usr/bin/env perl
use strict;
use feature 'say';
use Algorithm::Combinatorics 'combinations';
use List::Util 'sum';
use Getopt::Long;
my $verbose = 0;
GetOptions("verbose" => \$verbose);
my $N = shift(@ARGV) // die "Please specify an integer > 0";
die "Please specify an integer > 0" unless $N =~ /^[1-9]\d*$/;
my $D = shift(@ARGV) // die "Please specify a digit";
die "Please specify a digit" unless $D =~ /^\d$/;
my @candidates = grep { /$D/ } (1 .. $N);
say ": Candidates " . join(', ', @candidates) if $verbose;
for my $size (1 .. @candidates) # [1]
{
for my $comb (combinations(\@candidates, $size))
{
say ": Considering " . join(' + ', @$comb) if $verbose;
if (sum(@$comb) == $N)
{
say 1;
exit;
}
}
}
say 0;

[1] «Algorithm::Combinatorics::combinations» does not support multiple sizes, so we must add an outer loop to remedy that (and explicitly ask for a given size).

Running it gives the same result as the Raku version:

$ ./represent-integer-perl -v 25 7
: Candidates 7, 17
: Considering 7
: Considering 17
: Considering 7 + 17
0
$ ./represent-integer-perl -v 24 7
: Candidates 7, 17
: Considering 7
: Considering 17
: Considering 7 + 17
1

You are given a Binary Tree.

Write a script to replace each node of the tree with the sum of all the remaining nodes.

Example:

Input Binary Tree:

Write a script to replace each node of the tree with the sum of all the remaining nodes.

Example:

Input Binary Tree:

1
/ \
2 3
/ / \
4 5 6
\
7

Output Binary Tree:
27
/ \
26 25
/ / \
24 23 22
\
21

The expression «you are given a Binary Tree» beautifully glosses out the details of *how*
this tree is supposed to be given. The textual format presented in the example is readable for
a human, but not so for a program.

We do need a suitably compact (as in *command line
comapatible*) format. I have prsented that a couple of times before, and the most
recent one was Binary Linked Anagrams with Raku.
Scroll down to Challenge #094.2: Binary Tree to Linked List.

Let us start with that format, and do the whole operation on that format - without actually building a binary tree:

Note that we have to calculate the sum *before* we start messing about with the values.
(The challenge does not say that we are limitied to integers, so I allow anything with at
least one digit. This works as long as `sum`

is able to get a numeric value.

#! /usr/bin/env raku
unit sub MAIN (Str $tree = '1 | 2 3 | 4 * 5 6 | * 7', :v($verbose)); # [1]
my $sum = $tree.words.grep( * ~~ /\d/ ).sum; # [2]
say ": Sum: $sum" if $verbose;
my @elems; # [3]
for $tree.words -> $elem # [4]
{
$elem ~~ /\d/ # [4a]
?? @elems.push: $sum - $elem # [4b]
!! @elems.push: $elem; # [4c]
}
say @elems.join(" "); # [5]

[1] Note the format. We use `|`

to separate the rows, and spaces between the
values. Missing values are given as `*`

, but only when we need a gap in the
tree.

[2] Split the tree string into a list of values, get rid of the non-numeric ones, and get the sum of remaining values.

[3] The list of modified values will end up here.

[4] For each element (word) in the tree string, replace the value with the modified on [4b] if it is numeric. If not, keep the value [4c].

[5] Join the elements, giving a modified tree with the same syntax as given on the command line.

Running it:

$ ./recreate-binary-tree
27 | 26 25 | 24 * 23 22 | * 21
$ ./recreate-binary-tree -v '1 | 2 3 | 4 * 5 6 | * 7'
: Sum: 28
27 | 26 25 | 24 * 23 22 | * 21

Looking good.

Except that it does not look remotely like a tree. I&apo;ll get back to that, later.

#! /usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use Getopt::Long;
use List::Util qw(sum);
my $verbose = 0;
GetOptions("verbose" => \$verbose);
my $tree = shift(@$ARGV) // '1 | 2 3 | 4 * 5 6 | * 7';
my $sum = sum(grep(/\d/, split(/\s+/, $tree)));
say ": Sum: $sum" if $verbose;
my @elems;
for my $elem (split(/\s+/, $tree))
{
$elem =~ /\d/
? push(@elems, $sum - $elem)
: push(@elems, $elem);
}
say join(" ", @elems);

Running it gives the same result as the Raku version:

$ ./recreate-binary-tree-perl
27 | 26 25 | 24 * 23 22 | * 21
$ ./recreate-binary-tree-perl -v '1 | 2 3 | 4 * 5 6 | * 7'
: Sum: 28
27 | 26 25 | 24 * 23 22 | * 21

Printing a tree is a tricky business, so I have chosen to delegate that task to an external program; Vizgraph. See my Pokemon Chiao, Raku article for an introduction.

This is the resulting graph, where we clearly can see if the pointers are to a left or right child node:

The illustration uses *clustered nodes* which are
documented in e.g.
graphviz.gitlab.io/pdf/dotguide.pdf,
page 19 and 20.

We got the svg file by running these commands:

$ ./recreate-binary-tree-truly -g > tree1.dot
$ dot -Tsvg tree1.dot > tree1.svg

Then we can present the program, which is based on my invert-tree program from Challenge #57.1 Inverted Tree. It is quite long.

File: recreate-binary-tree-truly#! /usr/bin/env raku
unit sub MAIN (Str $tree = '1 | 2 3 | 4 * 5 6 | * 7', :v($verbose), :g(:$graph));
my $sum = $tree.words.grep( * ~~ /\d/ ).sum;
say ": Sum: $sum" if $verbose;
class BinaryNode # [1]
{
has Numeric $.value is rw;
has BinaryNode $.left is rw;
has BinaryNode $.right is rw;
}
my @btree = $tree.split("|")>>.words; # [2]
my @old-nodes;
my @new-nodes;
for @btree.reverse -> $row
{
my @current = @$row;
@old-nodes = @new-nodes;
@new-nodes = ();
for @current -> $value
{
if $value eq "*"
{
@new-nodes.push("*");
next;
}
my $left = @old-nodes.shift // "*"; $left = Nil if $left eq "*";
my $right = @old-nodes.shift // "*"; $right = Nil if $right eq "*";
@new-nodes.push(BinaryNode.new(value => $value.Int,
left => $left // Nil,
right => $right // Nil));
}
}
my $btree = @new-nodes[0];
say ": { $btree.raku }\n" if $verbose;
traverse($btree); # [3]
say ": { $btree.raku }\n" if $verbose;
graph($btree) if $graph; # [4]
sub traverse ($current) # [3]
{
$current.value = $sum - $current.value;
traverse($current.left) if $current.left.defined;
traverse($current.right) if $current.right.defined;
}
sub graph ($graph) # [4]
{
say 'digraph foogrph {';
say ' node [shape = record,height=.1];';
do-it($graph);
say '}';
sub do-it ($current)
{
say " node{ $current.value }[label = \"<left> |<center> { $current.value }|<right> \"];";
if $current.left.defined
{
say " \"node{ $current.value }\":left -> \"node{ $current.left.value }\":center;";
do-it($current.left);
}
if $current.right.defined
{
say " \"node{ $current.value }\":right -> \"node{ $current.right.value }\":center;";
do-it($current.right);
}
}
}

[1] The «BinaryNode» class, with three values (the value, and a left and right child node pointer). All the values are declared «is rw» so that we can change them later on. (We are only going to change the value in this program, though.)

[2] See the explanation of the «invert tree» program for details.

[3] This procedure modifies the values.

[4] This procedure generates the graph.

Running it:

$ ./recreate-binary-tree-truly

The program builds up the tree, modifies tha values, and exits. Not very exiting…

Using the «-g» (graph) option gives us a Vizgraph graph declaration, that can be converted to other formats (as e.g. «svg»9 as we saw above).

$ ./recreate-binary-tree-truly -g
digraph foogrph {
node [shape = record,height=.1];
node27[label = "<left> |<center> 27|<right> "];
"node27":left -> "node26":center;
node26[label = "<left> |<center> 26|<right> "];
"node26":left -> "node24":center;
node24[label = "<left> |<center> 24|<right> "];
"node24":right -> "node21":center;
node21[label = "<left> |<center> 21|<right> "];
"node27":right -> "node25":center;
node25[label = "<left> |<center> 25|<right> "];
"node25":left -> "node23":center;
node23[label = "<left> |<center> 23|<right> "];
"node25":right -> "node22":center;
node22[label = "<left> |<center> 22|<right> "];
}

You may have spotted the problem, by now. I have used the node *values* as
identifiers, and this will cause problems if we have duplicate values. E.g.

$ ./recreate-binary-tree-truly -g '1 | 2 3 | 4 * 5 6 | * 1' > tree2.dot
$ dot -Tsvg tree2.dot > tree2.svg

Oops indeed!

This is easy to fix.

File: recreate-binary-tree-truly2#! /usr/bin/env raku
unit sub MAIN (Str $tree = '1 | 2 3 | 4 * 5 6 | * 7', :v($verbose), :g(:$graph));
my $sum = $tree.words.grep( * ~~ /\d/ ).sum;
say ": Sum: $sum" if $verbose;
class BinaryNode
{
has Numeric $.value is rw;
has BinaryNode $.left is rw;
has BinaryNode $.right is rw;
method id # [1]
{
self.Str ~~ /(\d+)/; return $0.Str;
}
method sum # [2]
{
my $sum = self.value;
$sum += self.left.sum if self.left.defined;
$sum += self.right.sum if self.right.defined;
return $sum;
}
}
my @btree = $tree.split("|")>>.words;
my @old-nodes;
my @new-nodes;
for @btree.reverse -> $row
{
my @current = @$row;
@old-nodes = @new-nodes;
@new-nodes = ();
for @current -> $value
{
if $value eq "*"
{
@new-nodes.push("*");
next;
}
my $left = @old-nodes.shift // "*"; $left = Nil if $left eq "*";
my $right = @old-nodes.shift // "*"; $right = Nil if $right eq "*";
@new-nodes.push(BinaryNode.new(value => $value.Int,
left => $left // Nil,
right => $right // Nil));
}
}
my $btree = @new-nodes[0];
say ": Sum: { $btree.sum }" if $verbose;
say ": { $btree.raku }\n" if $verbose;
traverse($btree);
say ": { $btree.raku }\n" if $verbose;
graph($btree) if $graph;
sub traverse ($current)
{
$current.value = $sum - $current.value;
traverse($current.left) if $current.left.defined;
traverse($current.right) if $current.right.defined;
}
sub graph ($graph)
{
say 'digraph foogrph {';
say ' node [shape = record,height=.1];';
do-it($graph);
say '}';
sub do-it ($current)
{
say " node{ $current.id }[label = \"<left> |<center> { $current.value }|<right> \"];";
if $current.left.defined
{
say " \"node{ $current.id }\":left -> \"node{ $current.left.id }\":center;";
do-it($current.left);
}
if $current.right.defined
{
say " \"node{ $current.id }\":right -> \"node{ $current.right.id }\":center;";
do-it($current.right);
}
}
}

[1] This method gives a unique textual ID for each node, and we use that instead of the value when naming the nodes. This is based on the fact that Raku gives you the class name and a memory location (sort of) when you stringify an object (as discussed in Locate the Bell with Raku and Perl):

$ raku
> class ABC {}; my $a = ABC.new; say $a.Str;
ABC<94779351803648>

[2] At the same time, I rewrote the program to get the sum with this method (on the tree) instead of the initial string.

Running it:

$ ./recreate-binary-tree-truly -g '1 | 2 3 | 4 * 5 6 | * 1' > tree3.dot
$ dot -Tsvg tree3.dot > tree3.svg

Much better:

And that's it.