« Perl Weekly Challenge 150. Perl Weekly Challenge 152. »

Perl Weekly Challenge 151.

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

Task 1: Binary Tree Depth

Submitted by: Mohammad S Anwar
You are given binary tree.

Write a script to find the minimum depth.

The minimum depth is the number of nodes from the root to the
nearest leaf node (node without any children).

Example 1:
Input: '1 | 2 3 | 4 5'

                1
               / \
              2   3
             / \
            4   5

Output: 2

Example 2:
Input: '1 | 2 3 | 4 *  * 5 | * 6'

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

One could solve this task by building the tree and then running through it breath-first until a leaf is found, or depth-first noting the minimum depth among subtrees. However, given the input format as a sequence of rows, the task is much easier, as it is already half solved. If a row has a pair of missing siblings, that row is beyond the tree’s minimum depth. Thus, I can solve the task with the following one liner.¹

perl -E 'for(@ARGV){@l=split /\s*\|\s*/; $d=0; foreach(@l){s/((\S)+)/$2/g; s/\s+//g;
$_.=("*" x(2**$d-length)); last if m/^(..)*(\*\*)/; ++$d;} say "In: $_\nOut: $d";}
' '1 | 2 3 | 4 5' '1 | 2 3 | 4 * * 5 | * 6'

Results:

In: 1 | 2 3 | 4 5
Out: 2
In: 1 | 2 3 | 4 * * 5 | * 6
Out: 3

I can better explain the program with its full version.

# Perl weekly challenge 151
# Task 1: Binary tree depth
#
# See https://wlmb.github.io/2022/02/07/PWC151/#task-1-binary-tree-depth
use v5.12;
use warnings;
use Try::Tiny;
die "Usage: ./ch-1.pl T1 [T2]...\n"
    . "where Ti are trees of the form 'R1 | R2...'\n"
    . "and each row consists of nodes (strings) or an asterisk * (empty node)\n"
    unless @ARGV;
for my $tree (@ARGV){
    my @rows=split /\s*\|\s*/, $tree; # separate into rows.
    my $depth=0;   # Depth of first row is 1. This is above the first row
    try {
        foreach(@rows){
            s/((\S)+)/$2/g; # replace contiguous characters by first
            s/\s+//g; # remove spaces
            die "\n" if length > 2**$depth; # row can't be larger than 2**depth
            $_.=("*" x(2**$depth-length)); # Fill row with asterisks if necessary
            # Two consecutive asterisks at even-odd position mean we are below a leave
            # so we have finished our search;
            last if m/^(..)*(\*\*)/;
            ++$depth;  # increase and iterate
        }
        say "Input: $tree\nOutput: $depth";
    }
    catch { say "A row is too long in $tree";}
}

The idea is to change each row into a string with single letters for each node and asterisks for empty nodes. I examine the nodes with a regular expression, two at a time. If both are asterisks, then the node immediately above is a leaf and we are beyond the minimum height of the tree. I iterate over all provided trees and use Try::Tiny to catch errors and skip to next tree.

Examples:

./ch-1.pl  '1 | 2 3 | 4 5' '1 | 2 3 | 4 * * 5 | * 6'

Results:

Input: 1 | 2 3 | 4 5
Output: 2
Input: 1 | 2 3 | 4 * * 5 | * 6
Output: 3

Examples with limit cases and errors (empty tree, just the root, balanced tree, extra separator and long rows):

./ch-1.pl  '' '1' '1|2 3| 3 4 5 6' '1|2 3| 3 4 5 6|' '1 2' '1| 2 3 4'

Results:

Input:
Output: 0
Input: 1
Output: 1
Input: 1|2 3| 3 4 5 6
Output: 3
Input: 1|2 3| 3 4 5 6|
Output: 3
A row is too long in 1 2
A row is too long in 1| 2 3 4

Another example:

./ch-1.pl   '1 | 2 3 | 4 *  * 5 | * 6 * * * * 7 8'

Results:

Input: 1 | 2 3 | 4 *  * 5 | * 6 * * * * 7 8
Output: 3

This is wrong! The correct result should have been 4. The problem is that there are missing nodes in level 3 which therefore have empty descendants. I should have also checked that descendants have a parent. Unfortunately, I didn’t realize the error until I read Colin’s review. In the new version, I check that when I find two asterisks that the corresponding char in the previous line was not an asterisk. Below is a four-liner solution.

perl -d -E 'for(@ARGV){@l=split /\s*\|\s*/;$d=0; $o="";ROW:foreach(@l){
s/((\S)+)/$2/g; s/\s+//g; $_.=("*" x(2**$d-length));$n=$_;
while(s/^((..)*)\*\*/$1../){last ROW unless substr($o,length($1)/2,1) eq "*";
} $o=$n; ++$d;} say "In: $_\nOut: $d";}
' '1 | 2 3 | 4 5' '1 | 2 3 | 4 * * 5 | * 6' '1 | 2 3 | 4 *  * 5 | * 6 * * * * 7 8'

Results:

In: 1 | 2 3 | 4 5
Out: 2
In: 1 | 2 3 | 4 * * 5 | * 6
Out: 3
In: 1 | 2 3 | 4 *  * 5 | * 6 * * * * 7 8
Out: 4

So the problem seems to have been corrected.

A full version is

# Perl weekly challenge 151
# Task 1: Binary tree depth
#
# See https://wlmb.github.io/2022/02/07/PWC151/#task-1-binary-tree-depth
use v5.12;
use warnings;
use Try::Tiny;
die "Usage: ./ch-1a.pl T1 [T2]...\n"
    . "where Ti are trees of the form 'R1 | R2...'\n"
    . "and each row consists of nodes (strings) or an asterisk * (empty node)\n"
    unless @ARGV;
for my $tree (@ARGV){
    my @rows=split /\s*\|\s*/, $tree; # separate into rows.
    my $depth=0;   # Depth of first row is 1. This is above the first row
    try {
        my $old='';
      ROW:
        foreach(@rows){
            s/((\S)+)/$2/g; # replace contiguous characters by first
            s/\s+//g; # remove spaces
            die "A row is too long in $tree\n"
                if length > 2**$depth; # row can't be larger than 2**depth
            $_.=("*" x(2**$depth-length)); # Fill row with asterisks if necessary
            my $new=$_;
            # A non-empty node below an empty one is an error.
            while(s/^((\*\*)*)([^\*].|.[^\*])/$1\*\*/){
                die "An empty node may not have descendants in $tree\n"
                   if substr($old,length($1)/2,1) eq "*";
            }
            # Two empty nodes below a non-empty node mean the search is over.
            $_=$new;
            while(s/^((..)*)\*\*/$1../){
                last ROW unless substr($old,length($1)/2,1) eq "*";
            }
            $old=$new;
            ++$depth;
      }
        say "Input: $tree\nOutput: $depth";
    }
    catch { say $_;}
}

Examples:

./ch-1a.pl  '1 | 2 3 | 4 5' '1 | 2 3 | 4 * * 5 | * 6'

Results:

Input: 1 | 2 3 | 4 5
Output: 2
Input: 1 | 2 3 | 4 * * 5 | * 6
Output: 3

Examples with limit cases and errors (empty tree, just the root, balanced tree, extra separator and long rows):

./ch-1a.pl  '' '1' '1|2 3| 3 4 5 6' '1|2 3| 3 4 5 6|' '1 2' '1| 2 3 4'

Results:

Input:
Output: 0
Input: 1
Output: 1
Input: 1|2 3| 3 4 5 6
Output: 3
Input: 1|2 3| 3 4 5 6|
Output: 3
A row is too long in 1 2
A row is too long in 1| 2 3 4

An example with empty nodes with non-empty descendants:

./ch-1a.pl   '1 | 2 3 | 4 *  * 5 | * 6 7 * * 8 * 9 '

Results:

An empty node may not have descendants in 1 | 2 3 | 4 *  * 5 | * 6 7 * * 8 * 9

An example with empty nodes with empty descendants:

./ch-1a.pl   '1 | 2 3 | 4 *  * 5 | * 6 * * * * 7 8'

Results:

Input: 1 | 2 3 | 4 *  * 5 | * 6 * * * * 7 8
Output: 4

Task 2: Rob The House

Submitted by: Mohammad S Anwar
You are planning to rob a row of houses, always starting with
the first and moving in the same direction. However, you can’t
rob two adjacent houses.

Write a script to find the highest possible gain that can be
achieved.

Example 1:
Input: @valuables = (2, 4, 5);
Output: 7

If we rob house (index=0) we get 2 and then the only house we
can rob is house (index=2) where we have 5.
So the total valuables in this case is (2 + 5) = 7.

Example 2:
Input: @valuables = (4, 2, 3, 6, 5, 3);
Output: 13

The best choice would be to first rob house (index=0) then rob
house (index=3) then finally house (index=5).
This would give us 4 + 6 + 3 =13.

The problem can be solved recursively: To find the best way to rob a list L₀ of N houses 0..N-1 I first calculate the best way to rob the houses L₁=1..N-1 and L₂=2..N-1. I compare the bounty from list L₁ to that of L₂ plus the valuables of house 0 and then decide if I should skip or not house 0. This yields a simple oneliner:

perl -E 'sub r {my $x=shift; return 0 unless defined $x; return $x unless @_;
my ($y,$z)=(r(@_),$x+r(@_[1..@_-1])); $z>$y?$z:$y;} say "Input: ", join " ", @ARGV,
"\nOutput: ", r(@ARGV);' 2 4 5
perl -E 'sub r {my $x=shift; return 0 unless defined $x; return $x unless @_;
my ($y,$z)=(r(@_),$x+r(@_[1..@_-1])); $z>$y?$z:$y;} say "Input: ", join " ", @ARGV,
"\nOutput: ", r(@ARGV);' 4 2 3 6 5 3

Results:

Input: 2 4 5
Output:  7
Input: 4 2 3 6 5 3
Output:  13

Here the subroutine r receives as argument a list of houses and recursively determines the largest value that can be obtained.

With a small additional effort I can also print the sequence of houses to visit.

perl -E '@v=@ARGV; ($v,@c)=r(0); say "Input: ", join(" ", @v) ,"\nOutput: $v Houses: "
, join ", ", @c;sub r{my $c0=shift; my $v0=$v[$c0]; return (0) if $c0>=@v;
return ($v[$c0], $c0) if $c0==@v-1; my ($v1, @c1)=r($c0+1); my ($v2, @c2)=r($c0+2);
my $v3=$v0+$v2;  $v3>$v1?($v3, $c0, @c2):($v1, @c1);} ' 2 4 5
perl -E '@v=@ARGV; ($v,@c)=r(0); say "Input: ", join(" ", @v) ,"\nOutput: $v Houses: "
, join ", ", @c;sub r{my $c0=shift; my $v0=$v[$c0]; return (0) if $c0>=@v;
return ($v[$c0], $c0) if $c0==@v-1; my ($v1, @c1)=r($c0+1); my ($v2, @c2)=r($c0+2);
my $v3=$v0+$v2;  $v3>$v1?($v3, $c0, @c2):($v1, @c1);} ' 4 2 3 6 5 3

Results:

Input: 2 4 5
Output: 7 Houses: 0, 2
Input: 4 2 3 6 5 3
Output: 13 Houses: 0, 3, 5

In this case I pass as argument to the routine r the index of the first remaining house to consider, instead of a list of remaining houses. The return value is the sum of the robbed valuables and the list of visited houses.

The full version of the last program would be

# Perl weekly challenge 151
# Task 2: Rob the house
#
# See https://wlmb.github.io/2022/02/07/PWC151/#task-2-rob-the-house
use v5.12;
use warnings;
use Memoize;
memoize("optimize");
die "Usage: ./ch-1.pl V0 [V1]...\n"
    . "to optimize the robery of houses 0, 1,... with valuables V0, V1..."
    unless @ARGV;
my @values=@ARGV;
my ($value,@houses)=optimize(0);
say "Input: ", join ", ", @values;
say "Output: $value";
say "Houses: ", join ", ", @houses;
sub optimize {
    my $first=shift;
    my $value=$values[$first];
    return (0) if $first >= @values; # No more houses
    return ($value, $first) if $first==@values-1; # Only one house left
    my ($v1, @h1)=optimize($first+1); # what if I skip first house?
    my ($v2, @h2)=optimize($first+2,); # what if I rob first and skip next?
    my $v3=$value+$v2;
    $v3>$v1 # which option is best?
        ?($v3, $first, @h2) # First one and skip next
        :($v1, @h1); # or skip first one
}

Examples:

./ch-2.pl 2 4 5
./ch-2.pl 4 2 3 6 5 3

Results:

Input: 2, 4, 5
Output: 7
Houses: 0, 2
Input: 4, 2, 3, 6, 5, 3
Output: 13
Houses: 0, 3, 5

In the case of a large list of houses, there are many repeated calls to optimize with the same argument. To avoid duplicate calculations I use the Memoize module. For just 30 houses it yields a speed increase of about a hundred-fold, and for 36 houses it is more than a thousand-fold.

Large example:

perl -E 'say sprintf "%.0f", 100*rand for(0..99)'|xargs ./ch-2.pl

Results (formatted):

Input: 76, 19, 48, 24, 28, 41, 13, 49, 59, 53, 87, 69, 93, 13, 74,
       58, 14, 83, 52, 29, 71, 95, 91, 67, 73, 32, 38, 63,
       3, 75, 71, 3, 34, 38, 65, 4, 90, 35, 44, 44, 93, 68,
       28, 36, 73, 58, 80, 71, 40, 86, 67, 46, 75, 69, 48,
       49, 18, 82, 33, 35, 37, 68, 0, 25, 65, 33, 4, 52, 72,
       78, 84, 52, 90, 52, 7, 52, 77, 84, 32, 8, 13, 51, 36,
       28, 27, 66, 71, 76, 42, 55, 85, 39, 54, 59, 39, 60,
       99, 26, 68, 84
Output: 2917
Houses: 0, 2, 5, 8, 10, 12, 14, 17, 20, 22, 24, 27, 29, 32, 34,
        36, 38, 40, 42, 44, 46, 49, 51, 53, 55, 57, 59, 61, 64, 66,
        68, 70, 72, 75, 77, 79, 81, 83, 85, 87, 90, 92, 94, 96, 99

After reading Colin’s review I realized that an alternative meaning of starting with the first is to always rob the house with index 0 (and then, to never rob that with index 1). I did interpret that phrase as start to consider which houses to rob starting with index 0.

Footnotes

¹ There is a mistake. See below

Written on February 7, 2022