laurent_r

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on September 19, 2021 at 24:00). 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: Odd Number

You are given an array of positive integers, such that all the numbers appear even number of times except one number.

Write a script to find that integer.

Example 1:

Input: @N = (2, 5, 4, 4, 5, 5, 2)
Output: 5 as it appears 3 times in the array where as all other numbers 2 and 4 appears exactly twice.

Example 2:

Input: @N = (1, 2, 3, 4, 3, 2, 1, 4, 4)
Output: 4

Even though I have duly noted that the task specification states that only one number appears an odd number of time, I’ll expand slightly the task to find all the integers appearing an odd number of times, in the event that there is more than one.

Odd Number in Raku

In Raku, a Bag is a built-in immutable collection of distinct elements in no particular order that each have an integer weight assigned to them signifying how many copies of that element are considered “in the bag”. This is the perfect data structure to implement an histogram from a list of input values: just converting the input list into a bag, i.e. a list of unique key-values with the value being the frequency of the key. We then just need to filter out keys whose values are even to obtain the desired result.

my $bag = (2, 5, 4, 4, 5, 5, 2).Bag;
say grep { $bag{$_} % 2 }, $bag.keys;

This script displays the following output:

raku ./odd_number.raku
(5)

Adding a 2 to the input list will make the 2-count odd:

$ raku ./odd_number.raku
(5 2)

Odd Number in Perl

Perl doesn’t have a built-in Bag type, but it is almost as easy to implement an histogram using a hash. The algorithm is otherwise essentially the same:

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

my %histo;
$histo{$_}++ for (2, 5, 4, 4, 5, 5, 2);
say join " ", grep { $histo{$_} % 2 } keys %histo;

This script displays the following output:

$ perl odd_number.pl
5

Adding a 2 to the input list will make the 2-count odd:

$ perl odd_number.pl
2 5

Task 2: Binary Search Tree

You are given a tree.

Write a script to find out if the given tree is Binary Search Tree (BST).

According to Wikipedia, the definition of BST:

A binary search tree is a rooted binary tree, whose internal nodes each store a key (and optionally, an associated value), and each has two distinguished sub-trees, commonly denoted left and right. The tree additionally satisfies the binary search property: the key in each node is greater than or equal to any key stored in the left sub-tree, and less than or equal to any key stored in the right sub-tree. The leaves (final nodes) of the tree contain no key and have no structure to distinguish them from one another.

Example 1:

Input:
        8
       / \
      5   9
     / \
    4   6

Output: 1 as the given tree is a BST.

Example 2:

Input:
        5
       / \
      4   7
     / \
    3   6

Output: 0 as the given tree is a not BST.

We’ll implement the binary tree as a nested hash of hashes, in which the keys are val (the current node value), lc (left child node), and rc (right child node).

Binary Search Tree in Raku

we implement a recursive dft (depth-first traversal) subroutine to explore the tree. We return 0 when any value is larger than any previous value, except that a right child is larger than its immediate parent node.

use v6;

sub dft (%t, $min) {
    my $value = %t<val>;
    my $new-min = $value < $min ?? $value !! $min ;
    # say "$max $min $value $new-max $new-min";    
    if %t<lc>:exists {
        # say "%t<lc><val> $min";
        return 0 if %t<lc><val> > $value;
        return 0 if %t<lc><val> > $min;
        return 0 unless dft %t<lc>, $new-min;
    }
    if %t<rc>:exists {
        # say "%t<rc><val> $min";
        return 0 if %t<rc><val> < $value;
        return 0 if %t<rc><val> > $min;
        return 0 unless dft %t<rc>, $new-min;
    }
    return 1;
}
my %tree1 = (
    val => 8, 
    lc => { val => 5, 
            lc => {val => 4}, 
            rc => {val => 6}
          },
    rc => {val => 9}
);
#       8
#      / \
#     5   9
#    / \
#   4   6
say (dft %tree1, Inf), "\n";

my %tree2 = (val => 5, 
    lc => { val => 4, 
            lc => {val => 3}, 
            rc => {val => 6}
           },
    rc => {val => 7});
#       5
#      / \
#     4   7
#    / \
#   3   6
say dft %tree2, Inf;

This displays the following output:

$ raku ./bst.raku
1

0

Binary Search Tree in Perl

We also use a recursive dft (depth-first traversal) subroutine, with the same rules as above.

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

sub dft {
    my ($t, $min) = @_;
    my $value = $t->{val};
    my $new_min = $value < $min ? $value : $min ;
    # say " $min $value $new_min";    
    if (exists $t->{lc}) {
        # say "%t<lc><val> $min";
        return 0 if $t->{lc}{val} > $value;
        return 0 if $t->{lc}{val} > $min;
        return 0 unless dft($t->{lc}, $new_min);
    }
    if (exists $t->{rc}) {
        # say "%t<rc><val> $max $min";
        return 0 if $t->{rc}{val} < $value;
        return 0 if $t->{rc}{val} > $min;
        return 0 unless dft($t->{rc}, $new_min);
    }
    return 1;
}
my %tree1 = (
    val => 8, 
    lc => { val => 5, 
            lc => {val => 4}, 
            rc => {val => 6}
          },
    rc => {val => 9}
);
#       8
#      / \
#     5   9
#    / \
#   4   6
say "tree1: ", dft(\%tree1, 1e9), "\n";

my %tree2 = (val => 5, 
    lc => { val => 4, 
            lc => {val => 3}, 
            rc => {val => 6}
           },
    rc => {val => 7});
#       5
#      / \
#     4   7
#    / \
#   3   6
say "tree2: ", dft \%tree2, 1e9;

This displays the following output:

$ perl  bst.pl
tree1: 1

tree2: 0

Wrapping up

The next week Perl Weekly Challenge will start soon. 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 September 26, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.