laurent_r

These are some answers to the Week 93 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a day or so. This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Max Points

You are given set of co-ordinates @N.

Write a script to count maximum points on a straight line when given co-ordinates plotted on 2-d plane.

Example 1:

|
|     x
|   x
| x
+ _ _ _ _

Input: (1,1), (2,2), (3,3)
Output: 3

Example 2:

|
|
| x       x
|   x
| x   x
+ _ _ _ _ _

Input: (1,1), (2,2), (3,1), (1,3), (5,3)
Output: 3

From the examples provided, it appears that the given co-ordinates will be integers, that the points of a straight line have to be immediate neighbors and that the lines can only be horizontal, vertical or diagonal. Because of that, I will not try to solve the task with math formulas, as it is somewhat impractical to deal with integers in geometric equations. Also, representing a vertical line with a math equation is a mess.

Max Points in Raku

With such a type of problem, the first thing I usually want to do is to make a graphical representation of the point cloud, so that I can visually verify the test results. This is done in the following display-points subroutine:

sub display-points (@points) {
    my @sorted = reverse sort 
        { $^a[0] <=> $^b[0] || $^b[1] <=> $^a[1] }, 
        map { $_.reverse }, @points;
    my $current = (@sorted.max({$_[0]}))[0];
    my $max_length = (@sorted.max({$_[1]}))[1];
    my $line = "";
    my $pos = 0;
    for @sorted -> $item {
        if $item[0] < $current {
            say $line;
            $pos = 0;
            $line = "";
            $current--;
        }
        while $item[0] < $current {
            say "$current |"; 
            $current--;
        }
        $line = "$current |" and $pos = 0 if $line eq "";
        $line ~=  " " x ~ ($item[1] - $pos - 1) ~ "x";
        $pos = $item[1];        
    }
    say $line;
    while $current-- > 0 { say "$current |" }; 
    say "_" x ($max_length + 3), "\n";
}

With the following set of points:

(1,1), (2,2), (5,2), (3,3), (3,1), (2,7);

the procedure first reverse sorts the points as well as their individual coordinates:

[(7 2) (3 3) (2 2) (2 5) (1 1) (1 3)]

This is the output of this subroutine:

7 | x
6 |
5 |
4 |
3 |  x
2 | x  x
1 |x x
0 |
________

For finding the alignments, I used a dispatch table (%directions) defining four directions in which to move in order to find the next point: North, North-East, East, and South-East (the other four directions are just symmetric and are not necessary, since we will look for straight lines starting from every point in the set. We also build a %point-hash hash to store all points in the form of a string containing the abscissa and ordinate of every point (separated by a semi-colon). Then we loop over every point in the data set and loop over each of the four directions, and find in the hash whether there is a new point in that direction. We count the number of points found in that direction and keep track of the maximum count ($max-count).

sub find-alignments (@points) {
    my %directions = (
        N  => { $^a, $^b + 1 },
        NE => { $^a + 1, $^b + 1 },
        E  => { $^a + 1, $^b },
        SE => { $^a + 1, $^b - 1 }
    );
    my %point-hash = map { "$_[0];$_[1]" => True }, @points;
    my $max-count = 0;
    for @points -> $point {
        for %directions.keys -> $dir {
            my $count = 1;
            my $p = %directions{$dir}(|$point);
            while %point-hash{"$p[0];$p[1]"} {
                $p = %directions{$dir}(|$p);
                $count++;
            }
            $max-count = $count if $count > $max-count;
        }
    }
    say "Count: $max-count \n\n";          
}

Note that the code to find the alignments (i.e. to actually solve the task) contains only 22 code lines, and is thus shorter that the code to display the points (but it may be argued that it uses slightly more advanced techniques).

This is the full program:

use v6;

my @tests = ((1,1), (2,2), (5, 5), (5,2), (3,3), (3,1), (2,7), (4, 4)), 
            ((1,1), (2,2), (3,1), (1,3), (5,3)),
            ((1,1), (4,2), (1,3), (2,2), (1,2), (5,1), (1,4));
for @tests -> @points {
    display-points(@points);
    find-alignments(@points);
}

sub display-points (@points) {
    my @sorted = reverse sort 
        { $^a[0] <=> $^b[0] || $^b[1] <=> $^a[1] }, 
        map { $_.reverse }, @points;
    my $current = (@sorted.max({$_[0]}))[0];
    my $max_length = (@sorted.max({$_[1]}))[1];
    my $line = "";
    my $pos = 0;
    for @sorted -> $item {
        if $item[0] < $current {
            say $line;
            $pos = 0;
            $line = "";
            $current--;
        }
        while $item[0] < $current {
            say "$current |"; 
            $current--;
        }
        $line = "$current |" and $pos = 0 if $line eq "";
        $line ~=  " " x ~ ($item[1] - $pos - 1) ~ "x";
        $pos = $item[1];        
    }
    say $line;
    while $current-- > 0 { say "$current |" }; 
    say "_" x ($max_length + 3), "\n";
}

sub find-alignments (@points) {
    my %directions = (
        N  => { $^a, $^b + 1 },
        NE => { $^a + 1, $^b + 1 },
        E  => { $^a + 1, $^b },
        SE => { $^a + 1, $^b - 1 }
    );
    my %point-hash = map { "$_[0];$_[1]" => True }, @points;
    my $max-count = 0;
    for @points -> $point {
        for %directions.keys -> $dir {
            my $count = 1;
            my $p = %directions{$dir}(|$point);
            while %point-hash{"$p[0];$p[1]"} {
                $p = %directions{$dir}(|$p);
                 $count++;
            }
            $max-count = $count if $count > $max-count;
        }
    }
    say "Count: $max-count \n\n";          
}

This program displays the following output:

$ raku max-points.raku
7 | x
6 |
5 |    x
4 |   x
3 |  x
2 | x  x
1 |x x
0 |
________

Count: 5

3 |x   x
2 | x
1 |x x
0 |
________

Count: 3

4 |x
3 |x
2 |xx x
1 |x   x
0 |
________

Count: 4

Max Points in Perl

This is a port of the Raku program into Perl. Note that, for the sake of brevity, I will not show here the display_points subroutine as it is very similar to the equivalent code in Raku and is not very interesting. The test data sets are the same as in the Raku program, so you can look above to see the graphical representations of the point clouds. The find_alignments subroutine is similar to its counterpart in Raku and also uses a dispatch table with four directions in which to move to find the next point. Please refer to the Raku section above is you need additional explanations.

use strict;
use warnings;
use feature "say";

my @tests = ( [[1,1], [2,2], [5, 5], [5,2], [3,3], [3,1], [2,7], [4, 4]], 
              [[1,1], [2,2], [3,1], [1,3], [5,3]],
              [[1,1], [4,2], [1,3], [2,2], [1,2], [5,1], [1,4]],
            );
for my $point_set (@tests) {
    # display_points(@points);
    find_alignments(@$point_set);
}

sub find_alignments  {
    my @points = @_;
    my %directions = (
        N  => sub { $_[0]->[0]    ,  $_[0]->[1] + 1 },
        NE => sub { $_[0]->[0] + 1,  $_[0]->[1] + 1 },
        E  => sub { $_[0]->[0] + 1,  $_[0]->[1]     },
        SE => sub { $_[0]->[0] + 1,  $_[0]->[1] - 1 }
    );
    my %point_hash = map { my @a = @$_; "$$_[0];$$_[1]" => 1 } @points;
    my $max_count = 0;
    for my $point (@points) {
        for my $dir (keys %directions) {
            my $count = 1;
            my @p = $directions{$dir}->($point);
            while ($point_hash{"$p[0];$p[1]"}) {
                @p = $directions{$dir}->([@p]);
                $count++;
            }
            $max_count = $count if $count > $max_count;
        }
    }
    say  join " ", map { "(@{$_})" } @points;
    say "Count: $max_count \n";         
}

This program displays the following results:

$ perl  max-points.pl
(1 1) (2 2) (5 5) (5 2) (3 3) (3 1) (2 7) (4 4)
Count: 5

(1 1) (2 2) (3 1) (1 3) (5 3)
Count: 3

(1 1) (4 2) (1 3) (2 2) (1 2) (5 1) (1 4)
Count: 4

Task 2: Sum Path

You are given binary tree containing numbers 0-9 only.

Write a script to sum all possible paths from root to leaf.

Example 1:

Input:
     1
    /
   2
  / \
 3   4

Output: 13
as sum two paths (1->2->3) and (1->2->4)

Example 2:

Input:
     1
    / \
   2   3
  /   / \
 4   5   6

Output: 26
as sum three paths (1->2->4), (1->3->5) and (1->3->6)

Sum Path in Raku

For this task, I also used a display subroutine, which uses itself a bft (breadth-first traversal) recursive subroutine, but that’s not what was asked in the task and I have already covered that, so I’ll omit that from this post (see this blog post for an example), and only detail the dfs (depth-first search) recursive subroutine which does the work of going through all the path through the tree. The new-sum variable keep tasks of the total sum so far through the path and, when we reach a leaf (no subtree), we update the $*total-sum.

use v6;

my @tests = [1, [2, [3,], [4,]]], 
            [1, [2, [4,]], [3, [5], [6]]],
            [5, [4, [3, [7], [2]]], [8, [2], [9, [1]]]];

for @tests -> @tree {
    my $*total-sum = 0;
    say @tree;
    dfs(@tree, 0);
    say $*total-sum;
}

sub dfs (@node, $sum-so-far) {
    my $new-sum = $sum-so-far + @node[0];
    unless @node[1]:exists or @node[2]:exists {
        $*total-sum += $new-sum;
        return;
    }
    dfs(@node[1], $new-sum) 
        if defined @node[1];
    dfs(@node[2], $new-sum)
        if defined @node[2];
}

This produces the following output:

$ raku sum-path.raku
[1 [2 [3] [4]]]
13
[1 [2 [4]] [3 [5] [6]]]
26
[5 [4 [3 [7] [2]]] [8 [2] [9 [1]]]]
71

Sum Path in Perl

This is a port to Perl of the Raku program above, also with a dfs (depth-first search) recursive subroutine.

#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;

my @tests = ( [1, [2, [3,], [4,]]], 
              [1, [2, [4,]], [3, [5], [6, ]]],
              [5, [4, [3, [7], [2]]], [8, [2], [9, [1]]]]
            );
my $total_sum;
for my $tree (@tests) {
    $total_sum = 0;
    dfs($tree, 0);
    say $total_sum;
}

sub dfs {
    my ($node, $sum_so_far) = @_;
    my $new_sum = $sum_so_far + $node->[0];
    unless (exists $node->[1] or exists $node->[2]) {
        $total_sum += $new_sum;
        return;
    }
    dfs($node->[1], $new_sum) 
        if defined $node->[1];
    dfs($node->[2], $new_sum)
        if defined $node->[2];
}

This yields the same results as the Raku program:

$ perl sum-path.pl
13
26
71

Wrapping up

The next week Perl Weekly Challenge will start soon and will end next year, a year that we all hope will be better than this year. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, January 10, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.