Perl Weekly Challenge 130: Odd Number and Binary Search Tree

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.

Perl Weekly Challenge 128: Minimum Platforms

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

Note: very little time this week, so I only completed task 2.

You are given two arrays of arrival and departure times of trains at a railway station.

Write a script to find out the minimum number of platforms needed so that no train needs to wait.

Example 1:

Input: @arrivals   = (11:20, 14:30)
       @departures = (11:50, 15:00)
Output: 1

    The 1st arrival of train is at 11:20 and this is the only train at the station, so you need 1 platform.
    Before the second arrival at 14:30, the first train left the station at 11:50, so you still need only 1 platform.

Example 2:

Input: @arrivals   = (10:20, 11:00, 11:10, 12:20, 16:20, 19:00)
       @departures = (10:30, 13:20, 12:40, 12:50, 20:20, 21:20)
Output: 3

    Between 12:20 and 12:40, there would be at least 3 trains at the station, so we need minimum 3 platforms.

UPDATED [2021-08-30 23:30 UK TIME]: Corrected the between time description of the example 2. Thanks Peter Campbell Smith.

We need to perform a number of comparisons between arrival and departure times. We could write a dedicated compare subroutine (which would be quite simple). I decided however that I prefer to convert all the times into time stamps, namely the number of seconds elapsed since 00:00 a.m. that day, for which we can simply perform a numerical comparison. Our program then reads both arrays in parallel, always picking the smallest value. A size counter keeps track of the number of trains in the station at any given time, and $max-size keeps track of the maximum value reached by $size.

Minimum Platforms in Raku

Our program reads both arrays in parallel, always picking the smallest value. A size counter keeps track of the number of trains in the station at any given time, and $max-size keeps track of the largest size reached. When reading to sets of values in parallel, there are usually two edge cases when we reach the end of any of the datasets. If we reach the end of the arrival times, we can just exit the loop, since we will not increase the $size value beyond the maximum value so far. If we reach the end of the departure time array, then we need to increment the $max-size by one for any value left in the arrival time array.

my @arrivals   = <10:20 11:00 11:10 12:20 16:20 19:00>;
my @departures = <10:30 13:20 12:40 12:50 20:20 21:20>;
my @ts-arr = map { my ($m, $s) = split /\:/, $_; $m * 60 + $s;}, @arrivals;
my @ts-dep = map { my ($m, $s) = split /\:/, $_; $m * 60 + $s;}, @departures;
my $size = 0;
my $max-size = 0;
while @ts-arr.end != 0 {
    if @ts-dep.end == 0 {
        $max-size++;
    } elsif @ts-arr[0] <= @ts-dep[0] {
        shift @ts-arr;
        $size++;
        $max-size = $size if $size > $max-size;
        # say "$size $max-size";
    } else {
        shift @ts-dep;
        $size--;
    }
}
say $max-size;

With the built-in sample input data, the program displays the following output:

$ raku ./min-platforms.raku
3

Minimum Platforms in Perl

We’re basically porting the Raku program to Perl. Please refer to the above if you need explanations.

use strict;
use warnings;
use feature qw/say/;

my @arrivals   = qw<10:20 11:00 11:10 12:20 16:20 19:00>;
my @departures = qw<10:30 13:20 12:40 12:50 20:20 21:20>;
my @ts_arr = map { my ($m, $s) = split /:/, $_; $m * 60 + $s;} @arrivals;
my @ts_dep = map { my ($m, $s) = split /:/, $_; $m * 60 + $s;} @departures;
my $size = 0;
my $max_size = 0;
while (@ts_arr) {
    if ($#ts_dep == 0) {
        $max_size++;
    } elsif ($ts_arr[0] <= $ts_dep[0]) {
        shift @ts_arr;
        $size++;
        $max_size = $size if $size > $max_size;
        # say "$size $max-size";
    } else {
        shift @ts_dep;
        $size--;
    }
}
say $max_size;

Output:

$ perl min-platforms.pl
3

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 12, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 127: Disjoint Sets and Conflict Intervals

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

Task 1: Disjoint Sets

You are given two sets with unique integers.

Write a script to figure out if they are disjoint.

The two sets are disjoint if they don’t have any common members.

Example:

Input: @S1 = (1, 2, 5, 3, 4)
       @S2 = (4, 6, 7, 8, 9)
Output: 0 as the given two sets have common member 4.

Input: @S1 = (1, 3, 5, 7, 9)
       @S2 = (0, 2, 4, 6, 8)
Output: 1 as the given two sets do not have common member.

Disjoint Sets in Raku

Raku has built-in Set type and operators, which are perfect match for the task at hand, so that the code doing the work holds in just one code line. The is-disjoint subroutine receives two lists as parameters. The (&) set intersection operator coerces the two lists into Sets and generate a new Set with the common items. The is-disjoint subroutine the returns 1 if the new set is empty and 0 otherwise.

use v6;

sub is-disjoint ($s1, $s2) {
    return ($s1 (&) $s2).elems == 0 ?? 1 !! 0;
}
say is-disjoint (1, 2, 5, 3, 4), (4, 6, 7, 8, 9);
say is-disjoint (1, 3, 5, 7, 9), (0, 2, 4, 6, 8);

This script generates the following output:

raku ./disjoint.raku
0
1

Disjoint Sets in Perl

Perl doesn’t have Set operators, but we can use a hash to more or less the same effect. The is_disjoint subroutine in the program below populates a hash with the data from one of the input lists and then loops over the data of the other list to find common items, if any.

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

sub is_disjoint {
  my ($s1, $s2) = @_;
  my %h1 = map { $_ => 1 } @$s1;
  for my $d (@$s2) {
    return 0 if exists $h1{$d};
  }
  return 1;
}
say is_disjoint [1, 2, 5, 3, 4], [4, 6, 7, 8, 9];
say is_disjoint [1, 3, 5, 7, 9], [0, 2, 4, 6, 8];

This script generates the following output:

$ perl  ./disjoint.pl
0
1

Task 2: Conflict Intervals

You are given a list of intervals.

Write a script to find out if the current interval conflicts with any of the previous intervals.

Example:

Input: @Intervals = [ (1,4), (3,5), (6,8), (12, 13), (3,20) ]
Output: [ (3,5), (3,20) ]

    - The 1st interval (1,4) do not have any previous intervals to compare with, so skip it.
    - The 2nd interval (3,5) does conflict with previous interval (1,4).
    - The 3rd interval (6,8) do not conflicts with any of the previous intervals (1,4) and (3,5), so skip it.
    - The 4th interval (12,13) again do not conflicts with any of the previous intervals (1,4), (3,5) and (6,8), so skip it.
    - The 5th interval (3,20) conflicts with the first interval (1,4).

Input: @Intervals = [ (3,4), (5,7), (6,9), (10, 12), (13,15) ]
Output: [ (6,9) ]

    - The 1st interval (3,4) do not have any previous intervals to compare with, so skip it.
    - The 2nd interval (5,7) do not conflicts with the previous interval (3,4), so skip it.
    - The 3rd interval (6,9) does conflict with one of the previous intervals (5,7).
    - The 4th interval (10,12) do not conflicts with any of the previous intervals (3,4), (5,7) and (6,9), so skip it.
    - The 5th interval (13,15) do not conflicts with any of the previous intervals (3,4), (5,7), (6,9) and (10,12), so skip it.

One thing is not clear to me in the task description and associated examples: are (1,4) and (4, 6) conflicting intervals? They have one common item, but it may be considered that they don’t really overlap. I will consider that they are conflicting intervals, although it may also be argued that they are not.

Conflict Intervals in Raku

If you have a relatively large number of intervals, checking sequentially each interval with every preceding interval may turn out to be costly. So I preferred to implement a hash containing each value of the interval preceding ranges, since hash lookup is very efficient. Of course, this might be a problem for extremely large numbers of intervals (or extremely large intervals), as we may run out of memory. However, in real life situations, we can usually have an idea of the size of the input, and design our algorithm accordingly.

use v6;

my @intervals = (1,4), (3,5), (6,8), (12, 13), (3,20);
my %vals;
my @conflicts;
for @intervals -> $interv {
    my $overlap = False;
    my ($st, $end) = $interv[0,1];
    for $st..$end -> $i {
        $overlap = True and next if %vals{$i}:exists;
        %vals{$i} = 1;
    }
    push @conflicts, $interv if $overlap;
}
say @conflicts;

This script displays the following output:

$ raku ./conflict_intervals.raku
[(3 5) (3 20)]

Conflict Intervals in Perl

This Perl solution is a port to Perl of the Raku solution above and is based on the same assumptions regarding the size of the input data.

use strict;
use warnings;
use feature qw/say/;

my @intervals = ([1,4], [3,5], [6,8], [12, 13], [3,20]);
my %vals;
my @conflicts;
for my $interv (@intervals) {
    my $overlap = 0;
    my ($st, $end) =  @$interv[0..1];
    for my $i ($st..$end) {
        $overlap = 1, next if exists $vals{$i};
        $vals{$i} = 1;
    }
    push @conflicts, $interv if $overlap;
}
say join ", ", @$_ for @conflicts;

This script displays the following output:

$ perl ./conflict_intervals.pl 3, 5 3, 20

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 5, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 126: Count Numbers and Minesweeper Game

These are some answers to the Week 126 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 August 22, 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: Count Numbers

You are given a positive integer $N.

Write a script to print count of numbers from 1 to $N that don’t contain digit 1.

Example

Input: $N = 15
Output: 8

    There are 8 numbers between 1 and 15 that don't contain digit 1.
    2, 3, 4, 5, 6, 7, 8, 9.

Input: $N = 25
Output: 13

    There are 13 numbers between 1 and 25 that don't contain digit 1.
    2, 3, 4, 5, 6, 7, 8, 9, 20, 22, 23, 24, 25.

Count Numbers in Raku

This is quite simple. Our program simply loops over the integers in the 2..$N range and increments a counter for each integer not containing any 1.

sub check ( $n where { $n ~~ /^\d+$/} ) {
    my $count = 0;
    for 2..$n -> $i {
        $count++ unless $i ~~ /1/;
    }
    say "There are $count integers without a 1 in the 1..$n range.";
}
check @*ARGS[0] // 24;

This script displays the following output:

$ raku ./count_numbers.raku
There are 12 integers without a 1 in the 1..24 range.

$ raku ./count_numbers.raku 32
There are 19 integers without a 1 in the 1..32 range.

Count Numbers in Perl

To have a bit more fun, I decided to write a different, more functional, implementation, with a grep on the range of integers. All the real work is done in a single code line:

use strict;
use warnings;
use feature qw/say/;

my $n = shift // 24;
my $count = scalar grep {not /1/} 2..$n;
say "There are $count integers with no 1 in the 1..$n range";

This script displays the following output:

$ perl ./count_numbers.pl
There are 12 integers with no 1 in the 1..24 range

$ perl ./count_numbers.pl 32
There are 19 integers with no 1 in the 1..32 range

Count Numbers in Julia

Essentially a port of the Raku program to Julia:

function check(n)
    count = 0;
    for i in 2:n
        if ! contains("$i", "1")
            count += 1
        end
    end
    println("There are $count integers without a 1 in the 1..$n range.")
end
check(24);

Output:

$ julia ./count_numbers.jl
There are 12 integers without a 1 in the 1..24 range.

Task 2: Minesweeper Game

You are given a rectangle with points marked with either x or *. Please consider the x as a land mine.

Write a script to print a rectangle with numbers and x as in the Minesweeper game.

A number in a square of the minesweeper game indicates the number of mines within the neighbouring squares (usually 8), also implies that there are no bombs on that square.

Example:

Input:
    x * * * x * x x x x
    * * * * * * * * * x
    * * * * x * x * x *
    * * * x x * * * * *
    x * * * x * * * * x

Output:
    x 1 0 1 x 2 x x x x
    1 1 0 2 2 4 3 5 5 x
    0 0 1 3 x 3 x 2 x 2
    1 1 1 x x 4 1 2 2 2
    x 1 1 3 x 2 0 0 1 x

In principle, this is quite easy, except that there are a number of edge cases (in the literal sense of the word edge), namely the edges and corners of the minesweeper grid.

Solving the edge cases might be as easy as dis-activating the “uninitialized” warnings, but I eschew doing that. Another way might be to add fictitious lines and columns (with no mine) around the grid and removing them at the end after the computations. I doubt though that it leads to a really simpler solution. Anyway, I decided to implement it “the hard way”, i.e. to check whether the position being examined is on a border or a corner.

Minesweeper Game in Raku

The get-count subroutine does the hard work: for an input position in the grid, it checks which adjacent positions are defined and then computes the number of such adjacent position where there is a mine. The rest of the program is populating the grid (an array of arrays) and looping on every position of the grid to get the number of neighboring mines. Note that we’re using some dynamic scope variables to avoid passing them around.

use v6;

sub get-count (\i, \j) {
    my $count = 0;
    my @positions;
    for -1, 0, +1 -> $k {
        for -1, 0, +1 -> $m {
            push @positions, (i + $k, j + $m) unless $k == $m == 0;
        }
    }
    my $count-mines = 0;
    for @positions -> $pos {
        next if $pos[0] | $pos[1] < 0;
        next if $pos[0] > $*max-i or $pos[1] > $*max-j;
        $count-mines++ if @*mine-field[$pos[0]][$pos[1]] eq 'x';
    }
    return $count-mines;
}

my @in-str = 
    "x * * * x * x x x x",  
    "* * * * * * * * * x", 
    "* * * * x * x * x *", 
    "* * * x x * * * * *", 
    "x * * * x * * * * x";

my @*mine-field;
# Populating an AoA from the array of strings
for @in-str -> $line {
    push @*mine-field, [split /\s+/, $line];
}
say join "\n", @*mine-field, "\n";
my $*max-i = @*mine-field.end;
my $*max-j = @*mine-field[0].end;
for 0..$*max-i -> $i {
    for 0..$*max-j -> $j {
        next if @*mine-field[$i][$j] eq 'x';
        @*mine-field[$i][$j] = get-count $i, $j;
    }
}
say join "\n", @*mine-field;

This program displays the following output:

$ raku ./mine-sweeper.raku
x * * * x * x x x x
* * * * * * * * * x
* * * * x * x * x *
* * * x x * * * * *
x * * * x * * * * x
-
-
x 1 0 1 x 2 x x x x
1 1 0 2 2 4 3 5 5 x
0 0 1 3 x 3 x 2 x 2
1 1 1 x x 4 1 2 2 2
x 1 1 3 x 2 0 0 1 x

Minesweeper Game in Perl

This is essentially a port to Perl of the above Raku program. The get_count subroutine does the hard work: for an input position in the grid, it checks which adjacent positions are defined and then computes the number of such adjacent position where there is a mine. The rest of the program is populating the grid (an array of arrays) and looping on every position of the grid to get the number of neighboring mines.

use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;

my (@mine_field, $max_i, $max_j);

sub get_count {
    my ($i, $j) = @_;
    my $count = 0;
    my @positions;
    for my $k (-1, 0, +1) {
        for my $m (-1, 0, +1) {
            push @positions, [$i + $k, $j + $m] unless $k == 0 and $m == 0;
        }
    }
    my $count_mines = 0;
    for my $pos (@positions) {
        next if $pos->[0] <0 or $pos->[1] < 0;
        next if $pos->[0] > $max_i or $pos->[1] > $max_j;
        $count_mines++ if $mine_field[$pos->[0]][$pos->[1]] eq 'x';
    }
    return $count_mines;
}

sub print_grid {
    say "@$_" for @_; say "";
}

my @in_str = 
    ( "x * * * x * x x x x",  
      "* * * * * * * * * x", 
      "* * * * x * x * x *", 
      "* * * x x * * * * *", 
      "x * * * x * * * * x" );

# Populating an AoA from the array of strings
for my $line (@in_str) {
    push @mine_field, [split /\s+/, $line];
}

$max_i = $#mine_field;
$max_j = $#{$mine_field[0]};
print_grid @mine_field;

for my $i (0..$max_i) {
    for my $j (0..$max_j) {
        next if $mine_field[$i][$j] eq 'x';
        $mine_field[$i][$j] = get_count $i, $j;
    }
}
print_grid @mine_field;

This program displays the following output:

$ perl ./mine-sweeper.pl
x * * * x * x x x x
* * * * * * * * * x
* * * * x * x * x *
* * * x x * * * * *
x * * * x * * * * x

x 1 0 1 x 2 x x x x
1 1 0 2 2 4 3 5 5 x
0 0 1 3 x 3 x 2 x 2
1 1 1 x x 4 1 2 2 2
x 1 1 3 x 2 0 0 1 x

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 August 29, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 125: Pythagorean Triples

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

Task 1: Pythagorean Triples

You are given a positive integer $N.

Write a script to print all Pythagorean Triples containing $N as a member. Print -1 if it can’t be a member of any.

Triples with the same set of elements are considered the same, i.e. if your script has already printed (3, 4, 5), (4, 3, 5) should not be printed.

The famous Pythagorean theorem states that in a right angle triangle, the length of the two shorter sides and the length of the longest side are related by a²+b² = c².

A Pythagorean triple refers to the triple of three integers whose lengths can compose a right-angled triangle.

Example:

Input: $N = 5
Output:
    (3, 4, 5)
    (5, 12, 13)

Input: $N = 13
Output:
    (5, 12, 13)
    (13, 84, 85)

Input: $N = 1
Output:
    -1

It has been known since Euclid and is quite easy to prove that any integer larger than 2 can be part of a Pythagorean triple. We’ll use that knowledge in our implementation.

On the other hand, I don’t really know how to be sure that you really produce an exhaustive list of triples for a given input value.

Pythagorean Triples in Raku

There are several possible ways to go for this task, but I decided to build a data structure with all Pythagorean triples within a certain range. This is probably efficient if we’re going to test many input values (as done in the script below), but probably not for one single value.

use v6;

my @squares = map { $_² }, 1..Inf;
my $max = 200;
my $square-set = @squares[0..$max];
my @square-triples = gather {
    for (@squares[0..$max]).combinations(2) -> $comb {
        my $sum = [+] $comb;
        take (|$comb, $sum) if $sum (elem) $square-set;
    }
}
# say @square-triples;
my %look-up = 0 => -1, 1 => -1, 2 => -1;
for @square-triples -> $triple {
    push %look-up, $triple[$_].sqrt => (map { $_.sqrt}, $triple[0..2]) for 0..2;
}
# say %look-up{13};
for 1..20 -> $test {
    say "$test:\t", %look-up{$test};
}

This program displays the following output:

$ raku ./pythagorean-triples.raku
1:      -1
2:      -1
3:      (3 4 5)
4:      (3 4 5)
5:      [(3 4 5) (5 12 13)]
6:      (6 8 10)
7:      (7 24 25)
8:      [(6 8 10) (8 15 17)]
9:      [(9 12 15) (9 40 41)]
10:     [(6 8 10) (10 24 26)]
11:     (11 60 61)
12:     [(5 12 13) (9 12 15) (12 16 20) (12 35 37)]
13:     [(5 12 13) (13 84 85)]
14:     (14 48 50)
15:     [(8 15 17) (9 12 15) (15 20 25) (15 36 39) (15 112 113)]
16:     [(12 16 20) (16 30 34) (16 63 65)]
17:     [(8 15 17) (17 144 145)]
18:     [(18 24 30) (18 80 82)]
19:     (19 180 181)
20:     [(12 16 20) (15 20 25) (20 21 29) (20 48 52) (20 99 101)]

Pythagorean Triples in Raku

Again, we produce a data structure with all Pythagorean triples within a certain range. This is probably efficient if we’re going to test many input values (as done in the script below), but probably not for one single value.

Perl don’t have a built-in combinations function. So, we could use again the recursive combine subroutine of last week’s challenge:

sub combine {
    my $count = shift;
    my @out = @{$_[0]};
    my @in  = @{$_[1]};
    if ($count == 0) {
        push @combinations, [@out];
        return;
    }
    for my $i (0..$#in) {
        combine ($count - 1, [@out, $in[$i]], [@in[0..$i -1], @in[$i+1..$#in]]);
    }
}

and call it thus:

combine 2, [], [2..20]; # populates @combinations

But, here, we only need to produce combinations of two items, and it is therefore simpler to generate them directly like this:

my @combinations;
for my $i (2..200) {
    push @combinations, [$i, $_] for $i+1 .. $max;
}

So, this is my Perl implementation of the task:

use strict;
use warnings;
use feature qw/say/;

my $max = 300;
my @squares = map  $_ * $_ , 1..$max;
my %square_hash = map { $_ => 1 } @squares;
my @combinations;
for my $i (2..200) {
    push @combinations, [$i, $_] for $i+1 .. $max;
}   
my @triples;
for my $comb (@combinations) {
    my $sum_sq = $comb->[0] ** 2 + $comb->[1] ** 2;
    push @triples, [ @$comb, 0 + $sum_sq ** 0.5 ] if exists $square_hash{$sum_sq};
}
my %look_up = (0 => " [ -1 ] ", 1 => " [ -1 ] ", 2 => " [ -1 ] " );
for my $triple (@triples) {
    for my $val (@$triple) {
        $look_up{$val} .= " [ @$triple ] " ;
    }
}
for my $test (1..30) {
    my $result = $look_up{$test};
    say "$test:\t $result";
}

This program displays the following output:

$ perl pythagorean-triples.pl
1:        [ -1 ]
2:        [ -1 ]
3:        [ 3 4 5 ]
4:        [ 3 4 5 ]
5:        [ 3 4 5 ]  [ 5 12 13 ]
6:        [ 6 8 10 ]
7:        [ 7 24 25 ]
8:        [ 6 8 10 ]  [ 8 15 17 ]
9:        [ 9 12 15 ]  [ 9 40 41 ]
10:       [ 6 8 10 ]  [ 10 24 26 ]
11:       [ 11 60 61 ]
12:       [ 5 12 13 ]  [ 9 12 15 ]  [ 12 16 20 ]  [ 12 35 37 ]
13:       [ 5 12 13 ]  [ 13 84 85 ]
14:       [ 14 48 50 ]
15:       [ 8 15 17 ]  [ 9 12 15 ]  [ 15 20 25 ]  [ 15 36 39 ]  [ 15 112 113 ]
16:       [ 12 16 20 ]  [ 16 30 34 ]  [ 16 63 65 ]
17:       [ 8 15 17 ]  [ 17 144 145 ]
18:       [ 18 24 30 ]  [ 18 80 82 ]
19:       [ 19 180 181 ]
20:       [ 12 16 20 ]  [ 15 20 25 ]  [ 20 21 29 ]  [ 20 48 52 ]  [ 20 99 101 ]
21:       [ 20 21 29 ]  [ 21 28 35 ]  [ 21 72 75 ]  [ 21 220 221 ]
22:       [ 22 120 122 ]
23:       [ 23 264 265 ]
24:       [ 7 24 25 ]  [ 10 24 26 ]  [ 18 24 30 ]  [ 24 32 40 ]  [ 24 45 51 ]  [ 24 70 74 ]  [ 24 143 145 ]
25:       [ 7 24 25 ]  [ 15 20 25 ]  [ 25 60 65 ]
26:       [ 10 24 26 ]  [ 26 168 170 ]
27:       [ 27 36 45 ]  [ 27 120 123 ]
28:       [ 21 28 35 ]  [ 28 45 53 ]  [ 28 96 100 ]  [ 28 195 197 ]
29:       [ 20 21 29 ]
30:       [ 16 30 34 ]  [ 18 24 30 ]  [ 30 40 50 ]  [ 30 72 78 ]  [ 30 224 226 ]

I’m very late and have no time this week for the second task.

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 August 22, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.