October 2021 Archives

Perl Weekly Challenge 136: Two Friendly and Fibonacci Sequence

These are some answers to the Week 136 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 October 31, 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: Two Friendly

You are given 2 positive numbers, $m and $n.

Write a script to find out if the given two numbers are Two Friendly.

Two positive numbers, m and n are two friendly when gcd(m, n) = 2 ^ p where p > 0. The greatest common divisor (gcd) of a set of numbers is the largest positive number that divides all the numbers in the set without remainder.

Example 1:

Input: $m = 8, $n = 24
Output: 1

Reason: gcd(8,24) = 8 => 2 ^ 3

Example 2:

Input: $m = 26, $n = 39
Output: 0

Reason: gcd(26,39) = 13

Example 3:

Input: $m = 4, $n = 10
Output: 1

Reason: gcd(4,10) = 2 => 2 ^ 1

In other words, the greatest common divisor of two friendly numbers needs to be a power of two. Or, there must be a power of two for which, when both integers are divided by this power of two, the results are co-primes.

Two Friendly Numbers in Raku

Raku has a built-in gcd infix operator. So we just need to compute the GCD if the two input integers. If the GCD is 1 (numbers are co-primes) or less (one of the input integers was 0), then we return 0, as the integers are not two friendly numbers. (Note that it may be argued that 1 is a power of 2, i.e. 2 ^ 0, but I considered this to be a degenerate case, and that co-primes are not two-friendly; anyway, the task description is clear on the subject and specifies that “gcd(m, n) = 2 ^ p where p > 0”). Otherwise, we divide the GCD by two as long as the result is even. When we can no longer divide by two, the two input integers were two friendly numbers if the result of the final division is 1 (as the GCD was a power of two).

use v6;

sub is-friendly (Int $i, Int $j) {
    my $gcd = $i gcd $j;
    return 0 if $gcd <= 1;
    $gcd /= 2 while $gcd %% 2;
    return $gcd == 1 ?? 1 !! 0;
}
for 8, 24, 26, 39, 4, 10, 7, 5, 18, 0 {
    say "$^a, $^b => ", is-friendly $^a, $^b;
}

Note that Raku can take two numbers at a time from the input list in the for loop at the bottom, because the loop uses two parameters, which is quite convenient. In this case, we used placeholder variables aka self-declared positional parameters ($^a and $^b), but it would also work just as well with formal declared loop parameters, such as:

for 8, 24, 26, 39, 4, 10, 7, 5, 18, 0 -> $a, $b {
    say "$a, $b => ", is-friendly $a, $b;
}

This program yields the following results for the built-in input test integers:

$ raku ./friendly.raku
8, 24 => 1
26, 39 => 0
4, 10 => 1
7, 5 => 0
18, 0 => 0

Two Friendly Numbers in Perl

Just like in Raku, we divide the GCD by two as long as the result is even. When we can no longer divide by two, the two input integers were two friendly numbers is the result of the final division is 1. The main difference with Raku, though, is that Perl doesn’t have a built-in GCD function or operator. So we implement the gcd subroutine for that purpose, implementing a well-known method derived from the famous Euclidean algorithm.

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

sub gcd {
    my ($i, $j) = @_;
    return 0 if $i < 1 or $j < 1;
    while ($j) {
        ($i, $j) = ($j, $i % $j);
    }
    return $i;
}
sub is_friendly {
    my $gcd = gcd $_[0], $_[1];
    return 0 if $gcd <= 1;
    $gcd /= 2 while $gcd % 2 == 0;
    return $gcd == 1 ? 1 : 0;
}
for my $pair ([8, 24], [26, 39], [4, 10], [7, 5], [18, 0]) {
    say "@$pair => ", is_friendly @$pair;
}

This program displays the following output:

$ perl ./friendly.pl
8 24 => 1
26 39 => 0
4 10 => 1
7 5 => 0
18 0 => 0

Task 2: Fibonacci Sequence

You are given a positive number $n.

Write a script to find how many different sequences you can create using Fibonacci numbers where the sum of unique numbers in each sequence are the same as the given number.

Fibonacci Numbers: 1,2,3,5,8,13,21,34,55,89, …

Example 1:

Input:  $n = 16
Output: 4

Reason: There are 4 possible sequences that can be created using Fibonacci numbers
i.e. (3 + 13), (1 + 2 + 13), (3 + 5 + 8) and (1 + 2 + 5 + 8).

Example 2:

Input:  $n = 9
Output: 2

Reason: There are 2 possible sequences that can be created using Fibonacci numbers
i.e. (1 + 3 + 5) and (1 + 8).

Example 3:

Input:  $n = 15
Output: 2

Reason: There are 2 possible sequences that can be created using Fibonacci numbers
i.e. (2 + 5 + 8) and (2 + 13).

Fibonacci Sequence in Raku

I do not see any way to solve this problem other than listing all possible sequences of Fibonacci numbers less than or equal to the target number and counting those sequence whose sum is equal to the target number. We first initialize a list (a global variable) of the first 16 Fibonacci numbers using the sequence ... operator. The reason for doing this is that we don’t want to recompute the Fibonacci numbers for every input test integer. Of course, we would have to change this for input integers larger than 1597, but that’s good enough for our testing purpose.

Then, the fib-seq subroutine uses the built-in combinations method to generate all sequences of Fibonacci numbers and uses the builin grep and sum functions to keep the sequences whose sum is equal to the target input integer. And it returns the number of sequences matching this criterion.

Note that, although the task specification did not request that, I’ve decided to print out the matching sequences as this makes it much easier to check the result.

use v6;

my @fib = 1, 2, * + * ... * > 1000; # 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597

sub fib-seq (UInt $n) {
    my $count = 0;
    ++$count and .say for grep { $_.sum == $n }, @fib.grep({$_ <= $n }).combinations;
    return $count;
}
for 16, 9, 15, 89, 100 {
    say "Number of sequences for $_: ", fib-seq($_), "\n";
}

This programs prints out the following output:

$ raku ./main.raku
(3 13)
(1 2 13)
(3 5 8)
(1 2 5 8)
Number of sequences for 16: 4

(1 8)
(1 3 5)
Number of sequences for 9: 2

(2 13)
(2 5 8)
Number of sequences for 15: 2

(89)
(34 55)
(13 21 55)
(5 8 21 55)
(2 3 8 21 55)
Number of sequences for 89: 5

(3 8 89)
(1 2 8 89)
(3 8 34 55)
(1 2 3 5 89)
(1 2 8 34 55)
(3 8 13 21 55)
(1 2 3 5 34 55)
(1 2 8 13 21 55)
(1 2 3 5 13 21 55)
Number of sequences for 100: 9

Fibonacci Sequence in Perl

The Perl implementation is very similar to the Raku implementation, except that we need to code our own sum and combine subroutines to replace the equivalent Raku built-in methods.

Note that, as in Raku and although the task specification did not request that, I’ve decided to print out the matching sequences as this makes it much easier to check the result. Just comment out the penultimate code line of the fib_seq subroutine to avoid printing the sequences.

use strict;
use warnings;
use feature "say";
use Data::Dumper;

my @comb;
my @fib = qw /1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597/;

sub sum {
    my $sum = 0;
    $sum += $_ for @_;
    return $sum;
}

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


sub fib_seq {
    my $n = shift;
    my @short_fib = grep { $_ <= $n } @fib;
    my $count =  scalar @short_fib;
    @comb = ();
    combine $n, $count, [], [@short_fib];
    say "@$_" for @comb;
    return scalar @comb;
}

say "Number of sequences for $_: ", fib_seq $_ for 16, 9, 15, 89, 100;

This program displays the following output:

$ perl ./fib-seq.pl
1 2 5 8
1 2 13
3 5 8
3 13
Number of sequences for 16: 4
1 3 5
1 8
Number of sequences for 9: 2
2 5 8
2 13
Number of sequences for 15: 2
2 3 8 21 55
5 8 21 55
13 21 55
34 55
89
Number of sequences for 89: 5
1 2 3 5 13 21 55
1 2 3 5 34 55
1 2 3 5 89
1 2 8 13 21 55
1 2 8 34 55
1 2 8 89
3 8 13 21 55
3 8 34 55
3 8 89
Number of sequences for 100: 9

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

Perl Weekly Challenge 135: Middle 3-Digits and Validate SEDOL

These are some answers to the Week 135 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 October 24, 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: Middle 3-digits

You are given an integer.

Write a script find out the middle 3-digits of the given integer, if possible otherwise throw sensible error.

Example 1:

Input: $n = 1234567
Output: 345

Example 2:

Input: $n = -123
Output: 123

Example 3:

Input: $n = 1
Output: too short

Example 4:

Input: $n = 10
Output: even number of digits

Middle 3-Digits in Raku

This is pretty simple. We write a mid-three subroutine that returns an error message if the input number has an even number of digits or if it is too small (less than 3 digits). Once this is done, the subroutine finds the mid-point of the sting and returns the substring starting one digit earlier and ending one digit later.

sub mid-three (Int $in is copy) {
    $in = abs($in);
    my $length = $in.chars;
    return "Even number of digits" if $length %% 2;
    return "Too short" if $length < 3;
    my $mid-point = ($length - 1) /2;
    return substr($in, $mid-point - 1, 3);
}
for <1234567 -123 1 10 -54321> -> $n {
    say "$n -> ", mid-three $n;
}

This program displays the following output:

$ raku ./mid-three.raku
1234567 -> 345
-123 -> 123
1 -> Too short
10 -> Even number of digits
-54321 -> 432

Middle 3-Digits in Perl

Again, we have a mid_three subroutine that returns an error message if the input number has an even number of digits or if it is too small (less than 3 digits). Once this is done, the subroutine finds the mid-point of the sting and returns the substring starting one digit earlier and ending one digit later.

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

sub mid_three {
    my $in = abs $_[0];
    my $length = length $in;
    return "Even number of digits" unless $length % 2;
    return "Too short" if $length < 3;
    my $mid_point = ($length - 1) /2;
    return substr($in, $mid_point - 1, 3);
}
for my $n (qw<1234567 -123 1 10 -54321>) {
    say "$n -> ", mid_three $n;
}

This program displays the following output:

$ perl mid-three.pl
1234567 -> 345
-123 -> 123
1 -> Too short
10 -> Even number of digits
-54321 -> 432

Task 2: Validate SEDOL

You are given 7-characters alphanumeric SEDOL.

Write a script to validate the given SEDOL. Print 1 if it is a valid SEDOL otherwise 0.

For more information about SEDOL, please checkout the Wikipedia page.

Example 1:

Input: $SEDOL = '2936921'
Output: 1

Example 2:

Input: $SEDOL = '1234567'
Output: 0

Example 3:

Input: $SEDOL = 'B0YBKL9'
Output: 1

Validate SEDOL in Raku

The sedol subroutine returns 0 if the input string contains a vowel or if it not made of 6 alphanumerical characters followed by 1 digit. After these checks, it splits the input string into a sequence of 6 characters and 1 digit (presumably the check digit). It then populates a %values hash with the numeric values for the 10 digits and 26 letters. It then computes the weighted sum of the input sequence of 6 characters and then computes the checksum. If the checksum thus calculated is equal to the checksum found in the input string (the last digit), then we have a valid Sedol and the subroutine can return 1. Otherwise the subroutine return 0.

sub sedol( Str $in ) {
    return 0 if $in  ~~ /<[AEIOU]>/;  # Vowels not allowed
    return 0 unless $in ~~ /^ <[0..9B..Z]>**6 <[0..9]> $/; # 6 alphanumericals + 1 digit
    my ($sedol, $check) = substr($in, 0, 6), substr($in, 6, 1);
    my %values; 
    my $count = 0;
    for ( 0..9, 'A'..'Z').flat -> $val {
        %values{$val} = $count++;
    }
    my @weights = 1, 3, 1, 7, 3, 9;
    my $sum = [+] @weights Z* map {%values{$_}}, $sedol.comb;
    my $check_digit = (10 - $sum % 10) % 10;
    return 1 if $check_digit == $check;
    0
}
for <456765 65AR345 2936921 1234567 B0YBKL9> -> $s {
    say "$s: ", sedol($s);
}

This program displays the following output:

$ raku ./sedol.raku
456765: 0
65AR345: 0
2936921: 1
1234567: 0
B0YBKL9: 1

Validate SEDOL in Perl

This is essentially the same algorithm as in the Raku solution above: the sedol subroutine returns 0 if the input string contains a vowel or if it not made of 6 alphanumerical characters followed by 1 digit. After these checks, it splits the input string into a sequence of 6 characters and 1 digit (presumably the check digit). It then populates a %values hash with the numeric values for the 10 digits and 26 letters. It then computes the weighted sum of the input sequence of 6 characters and then computes the checksum. If the checksum thus calculated is equal to the checksum found in the input string (the last digit), then we have a valid Sedol and the subroutine can return 1. Otherwise the subroutine return 0.

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

sub sedol {
    my $in = shift;
    return 0 if $in  =~ /[AEIOU]/i;  # Vowels not allowed
    return 0 unless $in =~ /^[A-Z0-9]{6}[0-9]$/; # 6 alphanumericals + 1 digit
    my ($sedol, $check) = (substr($in, 0, 6), substr($in, 6, 1));
    my %values; 
    my $count = 0;
    for my $val ( 0..9, 'A'..'Z') {
        $values{$val} = $count++;
    }
    my @weights = (1, 3, 1, 7, 3, 9);
    my $sum = 0;
    my @chars = split //, $sedol;
    for my $i (0..5) {
        $sum += $values{$chars[$i]} * $weights[$i];
    }
    my $check_digit = (10 - $sum % 10) % 10;
    return 1 if $check_digit == $check;
    0
}
for my $s (qw<456765 65AR345 2936921 1234567 B0YBKL9>) {
    say "$s: ", sedol($s);
}

This program displays the following output:

$ perl  ./sedol.pl
456765: 0
65AR345: 0
2936921: 1
1234567: 0
B0YBKL9: 1

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

Perl Weekly Challenge 134: Pandigital Numbers and Distinct Term Count

These are some answers for Week 134 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 October 17, 2021 at 23:59). 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: Pandigital Numbers

  • Write a script to generate first 5 Pandigital Numbers in base 10.*

As per the https://en.wikipedia.org/wiki/Pandigital_number, it says:

A pandigital number is an integer that in a given base has among 
its significant digits each digit used in the base at least once.

In base 10, a pandigital number ought to have 10 digits. The first (smallest) pandigital numbers will start with the smallest digits upfront, except that the zero cannot be the first first digit, as it would disappear as non significant. So, to get the first pandigital number we need to start with 1, continue with 0 and then proceed the other digits in increasing order, which leads to 1023456789. The next pandigital number will have its two last digits swapped: 1023456798.

Since we need to find the first five pandigital numbers, they will all start with the sequence 1023456, with the three last digits being the permutations of 7, 8, and 9 in the proper increasing order. There are 6 permutations of three distinct digits, so that will be enough to find the first 5 pandigital numbers.

Pandigital Numbers in Raku

Based on the explanations above, we can hard-code the first seven digits as "1023456" and compute the permutations of the last 3 digits:

use v6;

my $start = "1023456";
my @ends = <7 8 9>.permutations[0..4]>>.join("");
say $start ~ $_ for @ends;

This script displays the following output:

raku ./pandigital.raku
1023456789
1023456798
1023456879
1023456897
1023456978

This script is so simple that we can easily turn it to a Raku one-liner:

$ raku -e 'say "1023456" ~ $_ for (7..9).permutations[0..4]>>.join'
1023456789
1023456798
1023456879
1023456897
1023456978

Pandigital Numbers in Perl

Based on the explanations in the task description section above, we can hard code the first seven digits as "1023456" and compute the permutations of the last 3 digits. For this, since we don’t like using external packages for coding challenges, we implement our own recursive permute subroutine.

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

my @permutations;

sub permute {
    my ($str, @vals) = @_;
    if (scalar @vals == 0) {
        push @permutations, $str;
        return;
    }
    permute("$str" . $vals[$_], @vals[0..$_-1], @vals[$_+1..$#vals]) for 0..$#vals;
}
permute "", 7, 8, 9;
say "1023456" . $_ for @permutations[0..4];

This script displays the following output:

$ perl ./pandigital.pl
1023456789
1023456798
1023456879
1023456897
1023456978

Task 2: Distinct Terms Count

You are given 2 positive numbers, $m and $n.

Write a script to generate multiplication table and display count of distinct terms.

Example 1:

Input: $m = 3, $n = 3
Output:

   x | 1 2 3
   --+------
   1 | 1 2 3
   2 | 2 4 6
   3 | 3 6 9

Distinct Terms: 1, 2, 3, 4, 6, 9
Count: 6

Example 2:

Input: $m = 3, $n = 5
Output:

   x | 1  2  3  4  5
   --+--------------
   1 | 1  2  3  4  5
   2 | 2  4  6  8 10
   3 | 3  6  9 12 15

Distinct Terms: 1, 2, 3, 4, 5, 6, 8, 9, 10, 12, 15
Count: 11

Distinct Terms Count in Raku

There is nothing complex about this task. We need to loop over all values between 1 and $m and all values between 1 and $n, perform the multiplications and properly format the output. In addition, we use a SetHash to store the distinct computed terms, display them and count them.

use v6;

sub multiplication-table (Int $m, Int $n) {
    my SetHash $distinct;
    say "x |", join " ", map {.fmt("%3d")}, 1..$n;
    for 1..$m -> $i {
        my @res = map { $i * $_ }, 1..$n;
        $distinct{$_} = True for @res;
        say "$i |", join " ", map {.fmt("%3d")}, @res;
    }
    say "Distinct terms: ", $distinct.keys.sort.join(" ");
    say "Count: ", $distinct.keys.elems;
}
multiplication-table(7, 5);

This program displays the following output:

$ raku ./distinct-terms.raku
x |  1   2   3   4   5
1 |  1   2   3   4   5
2 |  2   4   6   8  10
3 |  3   6   9  12  15
4 |  4   8  12  16  20
5 |  5  10  15  20  25
6 |  6  12  18  24  30
7 |  7  14  21  28  35
Distinct terms: 1 2 3 4 5 6 7 8 9 10 12 14 15 16 18 20 21 24 25 28 30 35
Count: 22

Distinct Terms Count in Perl

This is a port to Perl of the Raku program above. In Perl, we use a hash to store the distinct terms.

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

sub multiplication_table {
    my ($m, $n) = @_;
    my %distinct;
    say "x |", join " ", map {sprintf "%3d", $_} 1..$n;
    for my $i (1..$m) {
        my @res = map $i * $_, 1..$n;
        $distinct{$_} = 1 for @res;
        say "$i |", join " ", map {sprintf "%3d", $_} @res;
    }
    say "Distinct terms: ", join " ", sort keys %distinct;
    say "Count: ", scalar keys %distinct;
}
multiplication_table(7, 5);

Output:

$ perl ./distinct-terms.pl
x |  1   2   3   4   5
1 |  1   2   3   4   5
2 |  2   4   6   8  10
3 |  3   6   9  12  15
4 |  4   8  12  16  20
5 |  5  10  15  20  25
6 |  6  12  18  24  30
7 |  7  14  21  28  35
Distinct terms: 1 10 12 14 15 16 18 2 20 21 24 25 28 3 30 35 4 5 6 7 8 9
Count: 22

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

Perl Weekly Challenge 133: Integer Square Roots and Smith Numbers

These are some answers for Week 133 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 October 10, 2021 at 23:59). 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: Integer Square Root

You are given a positive integer $N.

Write a script to calculate the integer square root of the given number.

Please avoid using built-in function. Find out more about it https://en.wikipedia.org/wiki/Integer_square_root.

Examples:

Input: $N = 10
Output: 3

Input: $N = 27
Output: 5

Input: $N = 85
Output: 9

Input: $N = 101
Output: 10

The standard method for calculating the square root of a number is the Newton method, a.k.a. Newton-Raphson method. For an integer square root, we may use a variation of that method called Heron’s method.

Integer Square Root in Raku

Using a Bisection Method

Before we implement the fairly fast standard method, let’s see what we can do with a bisection method, which is similar to a binary search algorithm on a list of values. If the input number is $N, then we look at the 1..$N interval and find the midpoint $est as the first estimate of the square root. If the square of the midpoint is larger than $N, then we continue with the 1..$est interval, else we continue with the $est..$N interval. We continue until the range is smaller than or equal to 1.

This is an implementation of this idea:

use v6;

sub sqroot (Int $a) {
    # Bisection approach
    my $start = 1;
    my $end = $a;
    my $est;
    loop {
        $est = ($start + $end) div 2;
        say "\tIntermediate values: $start, $est, and $end";
        my $est-sq = $est ** 2;
        last if abs($end-$start) <= 1;
        if $est ** 2 > $a {
            $end = $est;
        } else {
            $start = $est;
        }
    }
    return $est;
}
say "$_\t", sqroot $_ for 10, 27, 85, 101, 200_000_000;

This program displays the following output:

$ raku ./int_sqrt_bs.raku
    Intermediate values: 1, 5, and 10
    Intermediate values: 1, 3, and 5
    Intermediate values: 3, 4, and 5
    Intermediate values: 3, 3, and 4
10  3
    Intermediate values: 1, 14, and 27
    Intermediate values: 1, 7, and 14
    Intermediate values: 1, 4, and 7
    Intermediate values: 4, 5, and 7
    Intermediate values: 5, 6, and 7
    Intermediate values: 5, 5, and 6
27  5
    Intermediate values: 1, 43, and 85
    Intermediate values: 1, 22, and 43
    Intermediate values: 1, 11, and 22
    Intermediate values: 1, 6, and 11
    Intermediate values: 6, 8, and 11
    Intermediate values: 8, 9, and 11
    Intermediate values: 9, 10, and 11
    Intermediate values: 9, 9, and 10
85  9
    Intermediate values: 1, 51, and 101
    Intermediate values: 1, 26, and 51
    Intermediate values: 1, 13, and 26
    Intermediate values: 1, 7, and 13
    Intermediate values: 7, 10, and 13
    Intermediate values: 10, 11, and 13
    Intermediate values: 10, 10, and 11
101 10
    Intermediate values: 1, 100000000, and 200000000
    Intermediate values: 1, 50000000, and 100000000
    Intermediate values: 1, 25000000, and 50000000
    Intermediate values: 1, 12500000, and 25000000
    Intermediate values: 1, 6250000, and 12500000
    Intermediate values: 1, 3125000, and 6250000
    Intermediate values: 1, 1562500, and 3125000
    Intermediate values: 1, 781250, and 1562500
    Intermediate values: 1, 390625, and 781250
    Intermediate values: 1, 195313, and 390625
    Intermediate values: 1, 97657, and 195313
    Intermediate values: 1, 48829, and 97657
    Intermediate values: 1, 24415, and 48829
    Intermediate values: 1, 12208, and 24415
    Intermediate values: 12208, 18311, and 24415
    Intermediate values: 12208, 15259, and 18311
    Intermediate values: 12208, 13733, and 15259
    Intermediate values: 13733, 14496, and 15259
    Intermediate values: 13733, 14114, and 14496
    Intermediate values: 14114, 14305, and 14496
    Intermediate values: 14114, 14209, and 14305
    Intermediate values: 14114, 14161, and 14209
    Intermediate values: 14114, 14137, and 14161
    Intermediate values: 14137, 14149, and 14161
    Intermediate values: 14137, 14143, and 14149
    Intermediate values: 14137, 14140, and 14143
    Intermediate values: 14140, 14141, and 14143
    Intermediate values: 14141, 14142, and 14143
    Intermediate values: 14142, 14142, and 14143
200000000   14142

This works well, but isn’t very efficient because our first estimates of the square root are quite far away from the actual root. We can improve the process significantly by starting the process with an estimate which is much closer to the target. For example, we can use 2 ** (((log2 N)/2).Int + 1), which is the least power of 2 larger than the square root of N, as our first estimate. This improved version may look like this:

sub sqroot (Int $a) {
    # Bisection approach
    my $start = 1;
    my $end = $a;
    my $est = 2 ** (((log2 $a)/2).Int + 1);
    loop {
        say "\tIntermediate values: $start, $est, and $end";
        last if abs($end-$start) <= 1;
        if $est ** 2 > $a {
            $end = $est;
        } else {
            $start = $est;
        }
        $est = ($end + $start) div 2;
    }
    return $est;
}
say "$_\t", sqroot $_ for 85, 101, 200_000_000;

This improved version displays the following output:

$ raku ./int_sqrt_bs2.raku
    Intermediate values: 1, 16, and 85
    Intermediate values: 1, 8, and 16
    Intermediate values: 8, 12, and 16
    Intermediate values: 8, 10, and 12
    Intermediate values: 8, 9, and 10
    Intermediate values: 9, 9, and 10
85  9
    Intermediate values: 1, 16, and 101
    Intermediate values: 1, 8, and 16
    Intermediate values: 8, 12, and 16
    Intermediate values: 8, 10, and 12
    Intermediate values: 10, 11, and 12
    Intermediate values: 10, 10, and 11
101 10
    Intermediate values: 1, 16384, and 200000000
    Intermediate values: 1, 8192, and 16384
    Intermediate values: 8192, 12288, and 16384
    Intermediate values: 12288, 14336, and 16384
    Intermediate values: 12288, 13312, and 14336
    Intermediate values: 13312, 13824, and 14336
    Intermediate values: 13824, 14080, and 14336
    Intermediate values: 14080, 14208, and 14336
    Intermediate values: 14080, 14144, and 14208
    Intermediate values: 14080, 14112, and 14144
    Intermediate values: 14112, 14128, and 14144
    Intermediate values: 14128, 14136, and 14144
    Intermediate values: 14136, 14140, and 14144
    Intermediate values: 14140, 14142, and 14144
    Intermediate values: 14142, 14143, and 14144
    Intermediate values: 14142, 14142, and 14143
200000000   14142

Using Heron’s Method

This method looks iteratively for a solution to the x² - N = 0 equation. With Newton’s method which applies to general numbers (not only integers), if you start with almost any estimate, p, you can compute a better estimate q with the following formula: q = (p + a / x) / 2. Geometrically, this is like drawing a tangent to the curve at the point where the abscissa is the first estimate, and take the point where the tangent meets the x axis as the new estimate. As it can be seen, we quickly get closer to the searched value (the square root), which is where the curve intersects the x-axis.

Newton_method.jpg

For integer square roots, we essentially need to replace standard rational division by Euclidean division (or integer division).

We use again 2 ** (((log2 N)/2).Int + 1) as our first estimate (see above).

use v6;

sub sqroot (Int $a) {
    my $x = 2 ** (((log2 $a)/2).Int + 1);
    my $y;
    loop {
        say "\tIntermediate value: $x";
        $y = ($x + $a div $x) div 2;
        last if abs($x - $y) < 1;
        $x = $y;
    }
    return $y;
}
say "$_\t", sqroot $_ for 10, 27, 85, 101, 200_000_000;

This program displays the following output:

$ raku ./int_sqrt.raku
    Intermediate value: 4
    Intermediate value: 3
10  3
    Intermediate value: 8
    Intermediate value: 5
27  5
    Intermediate value: 16
    Intermediate value: 10
    Intermediate value: 9
85  9
    Intermediate value: 16
    Intermediate value: 11
    Intermediate value: 10
101 10
    Intermediate value: 16384
    Intermediate value: 14295
    Intermediate value: 14142
200000000   14142

As it can be seen, this method converges toward the root much faster than the bisection method.

Integer Square Root in Perl

Using a Bisection Method

We again start with a bisection method. Please refer to the Bisection Method sub-section in the Raku section above for further explanations.

Perl doesn’t have a div Euclidean division operator, but it is easy to replace it with a combination of the standard division operator / and the int built-in function. Similarly, there is no built-in log2 binary logarithm function in Perl, but we can easily do without it, since we have the following mathematical property: log2 x = log x / log 2 (where log is the logarithm in any base, including the natural or the decimal logarithm).

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

sub sqroot {
    # Bisection method
    my $c = shift;
    my $start = 1;
    my $end = $c;
    my $est = 2 ** (int((log($c)/log(2))/2) + 1);
    while (1) {
        say "\tIntermediate values: $start, $est, and $end";
        last if abs($end-$start) <= 1;
        if ($est ** 2 > $c) {
            $end = $est;
        } else {
            $start = $est;
        }
        $est = int (($end + $start) / 2);
    }
    return $est;
}
say "$_\t", sqroot $_ for 85, 101, 200_000_000;

This script displays the same output as the equivalent Raku script above, so, for brevity, we only show the beginning of the output:

$ perl int_sqrt_BS.pl
        Intermediate values: 1, 16, and 85
        Intermediate values: 1, 8, and 16
        Intermediate values: 8, 12, and 16
        Intermediate values: 8, 10, and 12
        Intermediate values: 8, 9, and 10
        Intermediate values: 9, 9, and 10
85      9
        Intermediate values: 1, 16, and 101
        Intermediate values: 1, 8, and 16
        Intermediate values: 8, 12, and 16
        Intermediate values: 8, 10, and 12
        Intermediate values: 10, 11, and 12
        Intermediate values: 10, 10, and 11
101     10
...

Using Heron’s Method

This is essentially a port to Perl of the Raku program above (please look there for further explanations):

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

sub sqroot {
    my $c = shift;  # my $x = 2 ** (int((log($c)/log(2))/2) + 1);
    my $x = 2 ** (int((log($c)/log(2))/2) + 1);
    my $y;
    while (1) {
        say "\tIntermediate value: $x";
        $y = int(($x + $c / $x) / 2);
        last if abs($x - $y) < 1;
        $x = $y;
    }
    return $y;
}
say "$_ -> ", sqroot $_ for 10, 27, 85, 101, 200_000_000;

Output:

$ perl int_sqrt.pl
        Intermediate value: 2
        Intermediate value: 3
10 -> 3
        Intermediate value: 4
        Intermediate value: 5
27 -> 5
        Intermediate value: 8
        Intermediate value: 9
85 -> 9
        Intermediate value: 8
        Intermediate value: 10
101 -> 10
        Intermediate value: 8192
        Intermediate value: 16303
        Intermediate value: 14285
        Intermediate value: 14142
200000000 -> 14142

Task 2: Smith Numbers

Write a script to generate first 10 Smith Numbers in base 10.

According to https://en.wikipedia.org/wiki/Smith_number, in number theory, a Smith number is a composite number for which, in a given number base, the sum of its digits is equal to the sum of the digits in its prime factorization in the given number base.

Smith Numbers in Raku

For this task, we use a prime-factors subroutine that performs a prime factorization of the input parameter. We then iterates over successive integers (except those that are prime) and push the integer on a @result array if the sum of its digits is equal to the sum of the digits of its prime factors

use v6;

my @primes = grep {.is-prime}, 1..*;

sub prime-factors (UInt $num-in) {
    my @factors;
    my $num = $num-in;
    for @primes -> $div {
        while ($num %% $div) {
            push @factors, $div;
            $num div= $div;
        }
        return @factors if $num == 1;
    }
    push @factors, $num unless $num == $num-in;
    return @factors;
}

my @result;
my $count = 0;
for 1..* -> $i {
    next if $i.is-prime; # we want composite numbers only
    my @factors = prime-factors $i;
    push @result, $i and ++$count if (|@factors).comb.sum == $i.comb.sum;
    last if $count >= 10;
}
say @result;

This program displays the following output:

$ raku ./smith_nums.raku
[4 22 27 58 85 94 121 166 202 265]

Smith Numbers in Perl

This is essentially the same algorithm as in Raku, except that we have to build our own prime-factors and add_digits subroutines and implement a loop to populate the @primes array.

#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;
use constant MAX => 400;

my @primes = (2, 3, 5, 7);
my $current = 9;
while (1) {
    my $prime = 1;
    for my $i (@primes) {
        my $i_sq = $i * $i;
        last if $i_sq > $current;
        $prime = 0, last if $current % $i == 0;  
    }
    push @primes, $current if $prime;;
    $current += 2;
    last if $current > MAX;
}
my %primes = map { $_ => 1} @primes;

sub prime_factors {
    my $num = shift;
    my $origin_num = $num;
    my @factors;
    for my $div (@primes) {
        while ($num % $div == 0) {
            push @factors, $div;
            $num /= $div;
        }
        return @factors if $num == 1;
    }
    push @factors, $num unless $num == $origin_num;
    return @factors;
}

sub add_digits {
my $sum = 0;
    for my $i (@_) {
        $sum += $_ for split //, $i;
    }
    return $sum;
}
# say join " ", prime_factors $_ for grep {not exists $primes{$_}} 2..50;

my @result;
my $count = 0;
my $i = 2;
while (1) {
    $i++;
    next if exists $primes{$i}; # we want composite numbers only
    my @factors = prime_factors $i;
    push @result, $i and $count++ if add_digits($i) == add_digits(@factors);
    last if $count >= 10;
}
say "@result";

The program displays the following output:

$ perl ./smith_nums.pl 4 22 27 58 85 94 121 166 202 265

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

Perl Weekly Challenge 132: Mirror Dates and Hash Join

These are some answers for Week 133 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 October 3, 2021 at 23:59). 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: Mirror Dates

You are given a date (yyyy/mm/dd).

Assuming, the given date is your date of birth. Write a script to find the mirror dates of the given date.

Dave Cross has built cool site that does something similar.

Assuming today is 2021/09/22.

Example 1:

Input: 2021/09/18
Output: 2021/09/14, 2021/09/26

On the date you were born, someone who was your current age, would have been born on 2021/09/14.
Someone born today will be your current age on 2021/09/26.

Example 2:

Input: 1975/10/10
Output: 1929/10/27, 2067/09/05

On the date you were born, someone who was your current age, would have been born on 1929/10/27.
Someone born today will be your current age on 2067/09/05.

Example 3:

Input: 1967/02/14
Output: 1912/07/08, 2076/04/30

On the date you were born, someone who was your current age, would have been born on 1912/07/08.
Someone born today will be your current age on 2076/04/30.

Even though I did the task a few days later, I’ll also assume today is 2021/09/22 in order to be able to compare my results with the examples provided in the task description.

Mirror Dates in Raku

Raku has rich built-in classes and/or roles (types) for dealing with dates. Here we only need to use the Date built-in data type. Date subtraction correctly computes the number of days between two dates, leading to very simple code:

use v6;

my $today =  Date.new("2021-09-22");
for "2021-09-18", "1975-10-10", "1967-02-14" -> $test {
    my $input = Date.new($test);
    my $time-diff = $today - $input;
    say "Mirror dates for $input are: ", 
        $input - $time-diff, " and ", $today + $time-diff;
}

This program displays the following output:

$ raku ./mirror-dates.raku
Mirror dates for 2021-09-18 are: 2021-09-14 and 2021-09-26
Mirror dates for 1975-10-10 are: 1929-10-27 and 2067-09-05
Mirror dates for 1967-02-14 are: 1912-07-08 and 2076-04-30

Mirror Dates in Perl

As usual, I don’t want, for a programming challenge, to use external modules. So I’ll be using only the core Time::Local module. This leads to some complexities compare to the Raku version. In particular, the program has a compute_time function to transform a date string into a standard Posix time stamp, and a convert_date function to perform the reciprocal conversion (time stamp to string). Besides that, the Perl program works the same way as the Raku program.

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

sub compute_time {
    my ($y, $mo, $d) = split /-/, shift;
    my ($h, $mi, $s) = (0, 0, 0);
    $mo -= 1; # months are 0-indexed
    # $y -= 1900; # timegm works better with real year
    # say $y;
    return timegm($h, $mi, $s, $d, $mo, $y);
} 
sub convert_date {
    my $time_stamp = shift;
    my ($d, $m, $y) = (gmtime $time_stamp)[3, 4, 5];
    $d = sprintf "%02d", $d;
    $m = sprintf "%02d", $m+1;
    $y += 1900;
    return "$y-$m-$d";
}

my $today =  compute_time("2021-09-22");  # timestamp for the date arbitrarily chosen as "today"
for my $test ("2021-09-18", "1975-10-10", "1967-02-14") {
    my $input = compute_time ($test);
    my $time_diff = $today - $input;
    my @output = ($input - $time_diff, $today + $time_diff);
    say "Mirror dates for $test are: ", convert_date($output[0]), " and ", convert_date($output[1]);
}

This program displays the following output:

$ perl ./mirror-dates.pl
Mirror dates for 2021-09-18 are: 2021-09-14 and 2021-09-26
Mirror dates for 1975-10-10 are: 1929-10-27 and 2067-09-05
Mirror dates for 1967-02-14 are: 1912-07-08 and 2076-04-30

Task2: Hash Join

Write a script to implement Hash Join algorithm as suggested by https://en.wikipedia.org/wiki/Hash_join#Classic_hash_join.

  1. For each tuple r in the build input R 1.1 Add r to the in-memory hash table 1.2 If the size of the hash table equals the maximum in-memory size: 1.2.1 Scan the probe input S, and add matching join tuples to the output relation 1.2.2 Reset the hash table, and continue scanning the build input R
  2. Do a final scan of the probe input S and add the resulting join tuples to the output relation

Example:

Input:

    @player_ages = (
        [20, "Alex"  ],
        [28, "Joe"   ],
        [38, "Mike"  ],
        [18, "Alex"  ],
        [25, "David" ],
        [18, "Simon" ],
    );

    @player_names = (
        ["Alex", "Stewart"],
        ["Joe",  "Root"   ],
        ["Mike", "Gatting"],
        ["Joe",  "Blog"   ],
        ["Alex", "Jones"  ],
        ["Simon","Duane"  ],
    );

Output:

    Based on index = 1 of @players_age and index = 0 of @players_name.

    20, "Alex",  "Stewart"
    20, "Alex",  "Jones"
    18, "Alex",  "Stewart"
    18, "Alex",  "Jones"
    28, "Joe",   "Root"
    28, "Joe",   "Blog"
    38, "Mike",  "Gatting"
    18, "Simon", "Duane"

I don’t quite understand the relationship between hash join algorithm as described in the Wikipedia article and the example provided. So, I’ll simply try to replicate the behavior described in the example.

Hash Join in Raku

The input is the two arrays of arrays (AoA), @player_ages and @player_names, provided in the task description example. We load @player_names into the %names hash of arrays (HoA). Then we loop over the other input array, @player_ages and look up the hash to complete the lines, which we eventually print out.

use v6;

my @player_ages = 
    [20, "Alex"  ],
    [28, "Joe"   ],
    [38, "Mike"  ],
    [18, "Alex"  ],
    [25, "David" ],
    [18, "Simon" ];

my @player_names = 
    ["Alex", "Stewart"],
    ["Joe",  "Root"   ],
    ["Mike", "Gatting"],
    ["Joe",  "Blog"   ],
    ["Alex", "Jones"  ],
    ["Simon","Duane"  ];

my %names;
for @player_names -> $name {
    push %names{$name[0]}, $name[1];
}
for @player_ages -> $pl_age {
    my ($age, $first_name) = $pl_age;
    next unless %names{$first_name}:exists;
    # say "$age  $first_name";
    for %names{$first_name}[] -> $name {
        say "$age $first_name $name";
    }
}

This script displays the following output:

raku ./hash-join.raku
20 Alex Stewart
20 Alex Jones
28 Joe Root
28 Joe Blog
38 Mike Gatting
18 Alex Stewart
18 Alex Jones
18 Simon Duane

Hash Join in Perl

The Perl version is essentially a port to Perl of the Raku version above. Please refer to the explanations above if needed.

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

my @player_names = (
    ["Alex", "Stewart"],
    ["Joe",  "Root"   ],
    ["Mike", "Gatting"],
    ["Joe",  "Blog"   ],
    ["Alex", "Jones"  ],
    ["Simon","Duane"  ],
    );

my %names;
for my $name (@player_names) {
    push @{$names{$name->[0]}}, $name->[1];
}
for my $pl_age (@player_ages) {
    my ($age, $first_name) = @$pl_age;
    next unless exists $names{$first_name};
    for my $name (@{$names{$first_name}}) {
        say "$age $first_name $name";
    }
}

This program displays the following output:

$ perl  ./hash-join.pl
20 Alex Stewart
20 Alex Jones
28 Joe Root
28 Joe Blog
38 Mike Gatting
18 Alex Stewart
18 Alex Jones
18 Simon Duane

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

About laurent_r

user-pic I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.