Perl Weekly Challenge 149: Fibonacci Digit Sum and Largest Square

These are some answers to the Week 149 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 January 30, 2022 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: Fibonacci Digit Sum

Given an input $N, generate the first $N numbers for which the sum of their digits is a Fibonacci number.

Example:

f(20)=[0, 1, 2, 3, 5, 8, 10, 11, 12, 14, 17, 20, 21, 23, 26, 30, 32, 35, 41, 44]

Fibonacci Digit Sum in Raku

We first populate a Set (for fast look-up) with the Fibonacci numbers up to 1000. Note that we could choose a much smaller maximum value, but it doesn’t cost much and it will work with very large sequences.

To generate the Fibonacci numbers, we use the sequence operator, in which we provide the first two numbers of the Fibonacci sequence and a formula (* + *) to compute a Fibonacci number from the two previous ones. The last part of the code line is the stopping condition. This idiomatic construction makes the code very concise and fast. This is an example in a Raku one-liner:

$ raku -e 'say 0, 1, * + * ...^  * > 100'
(0 1 1 2 3 5 8 13 21 34 55 89)

Then, we use the gather / take construct to loop over successive integers and store those satisfying the criteria, and we stop when we reach the limit.

sub MAIN (Int $max = 20) {       # 20: default input value
    my $fibo = set(0, 1, * + * ...^  * > 1000);
    my $count = 0;
    my @numbers = gather {
        for 0 .. Inf -> $num {
            if $num.comb.sum (elem) $fibo {
                take $num;
                $count++;
                last if $count >= $max;
            }
        }
    }
    say @numbers;
}

This script displays the following output:

$ raku ./fib_digit_sum.raku
[0 1 2 3 5 8 10 11 12 14 17 20 21 23 26 30 32 35 41 44]

$ raku ./fib_digit_sum.raku 25
[0 1 2 3 5 8 10 11 12 14 17 20 21 23 26 30 32 35 41 44 49 50 53 58 62]

Fibonacci Digit Sum in Perl

The Perl solution follows essentially the same ideas as the Raku implementation, except that we use a plain while loop (instead of a sequence) to generate the Fibonacci numbers and we store them in a hash instead of a set for fast look-up.

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

sub fib_digit_sum {
    my $max = shift;
    my @fib = (0, 1);
    my $count = 1;
    while ($count < 100) {
        push @fib, $fib[-1] + $fib[-2];
        $count ++;
    }
    my %fibo = map { $_ => 1 } @fib;
    my @numbers;
    my $count_result = 0;
    my $i = 0;
    while ($count_result < $max) {
        my $sum = 0;
        $sum += $_ for split //, $i;
        if (exists $fibo{$sum}) {
            push @numbers, $i;
            $count_result++;
        }
        $i++
    }           
     say "@numbers";
}

fib_digit_sum(shift);

This program displays the following output:

$ perl ./fib_digit_sum.pl 20
0 1 2 3 5 8 10 11 12 14 17 20 21 23 26 30 32 35 41 44

$ perl ./fib_digit_sum.pl 50
0 1 2 3 5 8 10 11 12 14 17 20 21 23 26 30 32 35 41 44 49 50 53 58 62 67 71 76 80 85 94 100 101 102 104 107 110 111 113 116 120 122 125 131 134 139 140 143 148 152

Task 2: Largest Square

Given a number base, derive the largest perfect square with no repeated digits and return it as a string. (For base>10, use ‘A’..‘Z’.)

Example:

f(2)="1"
f(4)="3201"
f(10)="9814072356"
f(12)="B8750A649321"

Note that any program that I can think of for solving this task is bound to become very slow for large bases (especially some of them such as 13 in the case of the programs below).

Largest Square in Raku

We start with the largest number that can be expressed in $base digits in the given $base. We compute largest_root, the integer part of the root of that number. Then we iterate down one by one from largest_root and check whether the square of each such number has no duplicate digit when expressed in the input base.

sub largest ($base) {
    my $largest_num = $base ** $base - 1;
    my $largest_root = $largest_num.sqrt.Int;
    for (1..$largest_root).reverse -> $i {
        my $sq = $i².base($base);
        next if $sq.chars != $sq.comb.Set;
        say "f($base) = $sq" and last;
    }
}
for 1..14 -> $test { largest $test }

This program displays the following output:

$ raku ./largest_sq.raku
f(2) = 1
f(3) = 1
f(4) = 3201
f(5) = 4301
f(6) = 452013
f(7) = 6250341
f(8) = 47302651
f(9) = 823146570
f(10) = 9814072356
f(11) = A8701245369
f(12) = B8750A649321
f(13) = CBA504216873
f(14) = DC71B30685A924

Largest Square in Perl

This is essentially the same idea in Perl. We use two helper subroutines: has_unique_digits to discard squares having duplicate digits (using a hash), and base_to_b to convert a number into a string representing that number in the given base.

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

sub base_to_b {
    my ($n, $b) = @_;
    my $s = "";
    while ($n) {
        $s .= ('0'..'9','A'..'Z')[$n % $b];
        $n = int($n / $b);
    }
    scalar(reverse($s));
}

sub has_unique_digits {
    my $in = shift; 
    my %seen = map { $_ => 1 } split //,  $in;
    return length $in == scalar keys %seen;
}

sub largest {
    my $base = shift;
    my $largest_num = $base ** $base - 1;
    my $largest_root = int sqrt $largest_num;
    for my $i ( reverse 1..$largest_root) {
        my $sq = base_to_b ($i*$i, $base);
        next unless has_unique_digits $sq;
        say "f($base) = $sq" and last;
    }
}

largest $_ for 1..14;

This script displays the following output:

$ perl ./largest_sq.pl
f(2) = 1
f(3) = 1
f(4) = 3201
f(5) = 4301
f(6) = 452013
f(7) = 6250341
f(8) = 47302651
f(9) = 823146570
f(10) = 9814072356
f(11) = A8701245369
f(12) = B8750A649321
f(13) = CBA504216873
f(14) = DC71B30685A924

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

Perl Weekly Challenge 148: Eban Numbers and Cardano Triplets

These are some answers to the Week 148 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 January 23, 2022 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: Eban Numbers

Write a script to generate all Eban Numbers <= 100.

*An Eban number is a number that has no letter ‘e’ in it when the number is spelled in English (American or British).

Example:

2, 4, 6, 30, 32 are the first 5 Eban numbers.

The task asks us to list the Eban integers smaller than or equal to 100. To start with, 100 (“one hundred”) has two ‘e’, so it is not an Eban number. So we can limit our search to all Eban Numbers < 100, so that we can limit our search to integers with one or two digits.

For the single-digit integers and for the second digit of integers with two digits, we need to exclude: 1,3,5,7,8,and 9. For the first digit of two-digit integers (pronounced eleven, twelve, xxxxteen, twenty, thirty, etc. in English), wee need to exclude: 1x, 2x, 7x, 8x, 9x.

Eban Numbers in Raku

Implementing the exclusion rules detailed above is fairly easy with two regexes:

my @ebans = grep { ! /<[135789]>$/ and ! /<[12789]>\d/ }, 1..99;
say @ebans;

This script displays the following output:

$ raku ./eban.raku
[2 4 6 30 32 34 36 40 42 44 46 50 52 54 56 60 62 64 66]

This script is so simple that we can make it a Raku one-liner:

raku -e 'say grep { ! /<[135789]>$/ and ! /<[12789]>\d/ }, 1..99;'
(2 4 6 30 32 34 36 40 42 44 46 50 52 54 56 60 62 64 66)

Eban Numbers in Perl

We can implement the same exclusion rules in Perl:

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

my @ebans = grep { ! /[135789]$/ and ! /[12789]\d/ } 1..99;
say "@ebans";

This script displays the following output:

$ perl ./eban.pl
2 4 6 30 32 34 36 40 42 44 46 50 52 54 56 60 62 64 66

This can also be a Perl one-liner:

$ perl -E 'say join " ", grep { ! /[135789]$/ and ! /[12789]\d/ } 1..99;'
2 4 6 30 32 34 36 40 42 44 46 50 52 54 56 60 62 64 66

Task 2: Cardano Triplets

Write a script to generate first 5 Cardano Triplets.

A triplet of positive integers (a,b,c) is called a Cardano Triplet if it satisfies the below condition.

Cardano_triplets.jpg

Example:

(2,1,5) is the first Cardano Triplets.

In order to be able to generate the 5 first Cardano triplets, we would need to clarify what first means. In other words, we would need to establish an order relation on the Cardano triplets. Such order could be any of many things: order the triplets in accordance with the first integer of the triplet (a), or the second (b), or the third (c). It could also be the sum of the 3 triplets. Or some weighted average. Whatever. I will simply list the 5 first triplets that I find, which is as valid an order as any other.

Cardano Triplets in Raku

We implement a subroutine, is-cardano-triplet, to find whether a triplet of integers satisfies the criteria for Cardano triplets. Here we encountered an unexpected difficulty: the exponentiation operator (**) returns “Not a number” (NaN) when the base is negative and the power a (non-integer) rational number:

say (-2) ** (1/3);    # NaN

I don’t understand why, as I believe that this is a perfectly valid mathematical operation. I would definitely understand such a result for the square root of a negative number, but I don’t for the cubic root. The scientific calculator on my mobile phone and Excel both return proper values with such input.

In order for the above equation to hold, the second term has to be negative, as the first term will always be a positive number larger than 1. So, the subroutine returns false if the second term is positive. Then we can compute the cubic root of the absolute value of the second term, and change the addition of the two terms with a subtraction. In addition, we need to use the =~= approximately-equal operator to compare floating point numbers with an integer as 1.

use v6;
constant MAX = 5;

sub is-cardano-triplet (\a, \b, \c) {
    return False if a - b * c.sqrt > 0;
    my $val = ((a + b * c.sqrt) ** (1/3)) - ((- a + b * c.sqrt) ** (1/3));
    return $val =~= 1
}

my @values = 1..100;
my $count = 0;
OUT: for @values -> $i {
    for @values -> $j {
        for @values -> $k {
            if is-cardano-triplet $i, $j, $k {
                say "$i $j $k";
                $count++;
                last OUT if $count >= MAX;
            }
        }
    }
}
say "Duration: ", now - INIT now;

This program displays the following output:

$ raku ./cardano.raku
2 1 5
5 1 52
5 2 13
8 3 21
11 4 29
Duration: 6.621876

We have here used the first 100 integers as input. If we use integers between 1 and 200, we find another triplet with 8 as the first integer: 8, 1, 189. But again, we have no special order, we just take the first triplets that we find.

Cardano Triplets in Perl

This is essentially a port to Perl of the Raku program above. Just like in Raku, the exponentiation operator (**) returns “Not a number” (NaN) when the base if negative and the power a (non-integer) rational number. So we use the same method to work around this limitation. Also, since Perl does not have an approximately-equal (=~=) operator, we implement it manually: we check that the absolute value of the difference between the equation result and 1 is less than a given very small value (set here to 0.000001).

use strict;
use warnings;
use feature "say";
use constant MAX => 5;

sub is_cardano_triplet {
    my ($a, $b, $c) = @_;
    return 0 if $a - $b * sqrt($c) > 0;
    my $val = (($a + $b * sqrt($c)) ** (1/3)) - ((- $a + $b * sqrt($c)) ** (1/3));
    # say $val;
    return abs($val - 1) < 0.000001;
}

my @values = 1..100;
my $count = 0;
OUT: for my $i (@values) {
    for my $j (@values) {
        for my $k (@values) {
            if (is_cardano_triplet $i, $j, $k) {
                say "$i $j $k";
                $count++;
                last OUT if $count >= MAX;
            }
        }
    }
}

This program displays the following output:

$ time perl cardano.pl
2 1 5
5 1 52
5 2 13
8 3 21
11 4 29

real    0m0,175s
user    0m0,108s
sys     0m0,046s

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

Perl Weekly Challenge 147: Truncatable Primes and Pentagon Numbers

These are some answers to the Week 147 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 January 16, 2022 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: Truncatable Prime

Write a script to generate first 20 left-truncatable prime numbers in base 10.

In number theory, a left-truncatable prime is a prime number which, in a given base, contains no 0, and if the leading left digit is successively removed, then all resulting numbers are primes.

Example:

9137 is one such left-truncatable prime since 9137, 137, 37 and 7 are all prime numbers.

Truncatable Prime in Raku

We first build an infinite lazy list (@el-primes) of primes with no 0 digit. For each integer in the list, we then try to truncate the left-most digit and check whether the truncated number is prime, and so one until we get to the last digit. The process stops when 20 such primes have been generated.

my @truncatables;
my $count = 0;
my @el-primes = grep {.is-prime and not /0/}, 2..Inf;
for @el-primes -> $candidate {
    my $length = $candidate.chars;
    my $is-truncatable = True; 
    for 1..$length -> $i {
        my $truncated = substr $candidate, $length - $i;
        $is-truncatable = False, last unless $truncated.is-prime;
    }
    if $is-truncatable {
        push @truncatables, $candidate;
        $count++;
    }
    last if $count >= 20;
}
say @truncatables;

This program displays the following output:

raku ./truncatable.raku
[2 3 5 7 13 17 23 37 43 47 53 67 73 83 97 113 137 167 173 197]

Truncatable Prime in Perl

This Perl program is based on essentially the same idea as the Raku implementation, except that we build a hash of primes along the way. We need to check primality only when we meet a new number the first time: for the truncated numbers, we simply check their primality by looking up into the hash.

use strict;
use warnings;
use feature "say";
use constant MAX => 20;

my @primes = (2, 3, 5);
my %primes_h = map {$_ => 1} @primes;
my @truncatables = @primes;;
my $candidate = $primes[-1];
my $count = scalar @truncatables;;
while ($count < MAX) {
    $candidate += 2;
    my $not_prime = 0;
    next if $candidate =~ /0/;
    my $sq_cand = sqrt $candidate;
    for my $i (@primes) {
        $not_prime = 1, last unless $candidate % $i;
        last if $i > $sq_cand;
    }
    next if $not_prime;
    push @primes, $candidate;
    $primes_h{$candidate} = 1;
    # now check if truncatable prime
    my $length = length $candidate;
    my $is_truncatable = 1; 
    for my $i (1..$length) {
        my $truncated = substr $candidate, $length - $i;
        $is_truncatable = 0, last unless exists $primes_h{$truncated};
    }
    if ($is_truncatable) {
        push @truncatables, $candidate;
        $count++;
    }
}
say "@truncatables";

This program displays the following output:

$ perl  ./truncatable.pl
2 3 5 7 13 17 23 37 43 47 53 67 73 83 97 113 137 167 173 197

Truncatable Prime in Ring

I continue here my exploration of Ring, a quite recent programming language. The program below is a port to Ring of the Perl program above.

max = 20
primes = [2, 3, 5]
primes_h = []
count = len(primes)
for i = 1 to count
    primes_h[string(primes[i])] = i
next
truncatables = primes
candidate = primes[count]
while count < max
    candidate += 2
    not_prime = false
    pos = substr(string(candidate), "0")
    if pos > 0 loop ok
    sq_cand = floor(sqrt(candidate))
    for i in primes
        if candidate % i = 0
            not_prime = true
            exit
        ok
        if i > sq_cand exit ok
    next
    if not_prime loop ok
    add (primes, candidate)
    primes_h[string(candidate)] = 1
    // We've found a prime, now check if truncatable prime
    length = len(string(candidate))
    is_truncatable = true
    for i = 1 to length
        truncated = right(string(candidate), i)
        if isnull(primes_h[truncated])
            is_truncatable = false
            exit
        ok
    next
    if is_truncatable
        add(truncatables, candidate);
        count += 1
    ok

end
for val in truncatables see "" + val + " " next
see " " + nl

Output:

$ ring ./truncatable.ring
2 3 5 7 13 17 23 37 43 47 53 67 73 83 97 113 137 167 173 197

Task 2: Pentagon Numbers

Write a script to find the first pair of Pentagon Numbers whose sum and difference are also a Pentagon Number.

Pentagon numbers can be defined as P(n) = n(3n - 1)/2.

Example:

The first 10 Pentagon Numbers are: 1, 5, 12, 22, 35, 51, 70, 92, 117 and 145.

P(4) + P(7) = 22 + 70 = 92 = P(8)
but
P(4) - P(7) = |22 - 70| = 48 is not a Pentagon Number.

Pentagon Numbers in Raku

We’ve decided to use the built-in combinations method to generate the pairs of pentagon numbers. Note that we cannot use an infinite list of pentagon numbers because the combinations routine cannot operate on an infinite list. So I just tried various increasing values for the $max variable until I obtained a result satisfying the criteria. Note that I use a %penta hash to store the pentagon values, so the verifying whether and sum and the difference values are pentagon number is just a matter of a fast hash lookup.

my $max = 4000;
my @pentanums = map { (3 * $_² - $_)/2 }, 1..$max;
my %penta = map {@pentanums[$_] => $_+1}, 0..$max-1;
for @pentanums.combinations(2) -> $comb {
    next unless %penta{$comb.sum}:exists;
    next unless %penta{$comb[1]-$comb[0]}:exists;
    say $comb, " = Pentagon numbers N° %penta{$comb[0]} and %penta{$comb[1]}";
    say "Sum is ", $comb.sum, " (Pentagon number ", %penta{$comb.sum}, ")";
    say "Difference is ", $comb[1]-$comb[0], " (Pentagon number ", %penta{$comb[1]-$comb[0]}, ")";
    last;
}
say now - INIT now, " seconds";

This script displays the following output:

raku ./pentanums.raku
(1560090 7042750) = Pentagon numbers N° 1020 and 2167
Sum is 8602840 (Pentagon number 2395)
Difference is 5482660 (Pentagon number 1912)
101.7166579 seconds

This program is relatively slow (101 seconds execution time). I found that using two nested loops (as in the Perl program below) rather than the combinations routine make the program at least 20 times faster (only a few seconds). So it seems that the combinations routine is quite slow. This is a bit unfortunate as combinations is really useful and makes the code simpler and cleaner. I still prefer to present this version, but if you need better performance, then use two nested loops as in the Perl implementation below.

Pentagon Numbers in Perl

This is essentially the same idea as the Raku program above. However, as mentioned above, we don’t have combinations routine in Perl, so we use two nested loops to generate all the combinations. The advantage is that this runs much faster.

use strict;
use warnings;
use feature "say";
use constant MAX => 4000;

my @pentanums = map { $_ * (3 * $_ - 1)/2 } 1..MAX;
my %penta_h = map {$pentanums[$_] => $_+1 } 0..MAX-1;
# say Dumper \%penta_h;

OUTER: for my $i (0..MAX-1) {
    for my $j ($i+1..MAX-1) {
        my $sum = $pentanums[$i] + $pentanums[$j];
        next unless exists $penta_h{$sum};
        my $diff = $pentanums[$j] - $pentanums[$i];
        next unless exists $penta_h{$diff};
        say "First pair of pentagon numbers is $pentanums[$i] (rank ", $i+1, ") and $pentanums[$j] (rank ", $j+1, ")";
        say "Sum is $sum (rank $penta_h{$sum}) and difference is $diff (rank $penta_h{$diff})";
        last OUTER;
    }
}

This program displays the following output:

$ time perl  ./pentanums.pl
First pair of pentagon numbers is 1560090 (rank 1020) and 7042750 (rank 2167)
Sum is 8602840 (rank 2395) and difference is 5482660 (rank 1912)

real    0m2,043s
user    0m1,703s
sys     0m0,108s

Pentagon Numbers in Ring

Again a port to Ring of the Perl implementation:

max = 3000
pentanums = []
for i = 1 to max 
    add (pentanums,  i * (3 * i - 1) / 2)
next
// see pentanums + nl
penta_h = []
for i = 1 to max
    penta_h[ string(pentanums[i])] = i
next
for i = 1 to max
    for j = i+1 to max
        diff = pentanums[j] - pentanums[i]
        diff_s = string(diff)
        if isnull(penta_h[diff_s]) loop ok
        sum = pentanums[i] + pentanums[j]
        sum_s = string(sum)
        if isnull(penta_h[sum_s]) loop ok
        see "" + diff + " " + sum + " " + pentanums[i] + " " + pentanums[j] + nl
    next
next

Output:

$ ring ./pentanums.ring
5482660 8602840 1560090 7042750

Pentagon Numbers in Julia

max = 4000
pentanums = map((x) -> Int(x * (3 * x -1)/2), 1:max)
penta_h = Dict(map((x) -> Int(x * (3 * x -1)/2) => x, 1:max))
for i in 1:4000-1
    for j in (i + 1):4000-1
        sum = pentanums[i] + pentanums[j]
        if (haskey(penta_h, Int(sum)) == 0)
            continue
        end
        diff = pentanums[i] - pentanums[j]
        # if (haskey(penta_h, Int(diff)) == 0)
        #    continue
        # end
        println(i, " ", j, " ", pentanums[i], " ", pentanums[j], " ", sum)
    end
end

Output:

$ julia pentanums.jl
Indices 1020 and 2167 ; Pentanums: 1560090 7042750; Sum: 8602840; Diff: 5482660
1020 2167

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

Perl Weekly Challenge 146: Prime Numbers and Fraction Tree

These are some answers to the Week 146 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 January 9, 2022 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: 10001st Prime Number

Write a script to generate the 10001st prime number.

10001st Prime Number in Raku

Raku has a fast is-prime subroutine or method, using the Miller-Rabin algorithm, to test whether a integer is prime. We can just generate an infinite (lazy) list of prime numbers and look for the 10000st one.

use v6;

my @primes = grep { .is-prime }, (1, 2, 3, -> $a { $a + 2} ...Inf);
say @primes[10001 - 1];  # Subtract 1 because the array starts at 0

This script displays the following output:

$ raku ./10001prime.raku
104743

The Raku script is so simple that it can be implemented as a short Raku one-liner:

$ ./raku -e 'say (grep { .is-prime }, 1..Inf)[10000]'
104743

10001st Prime Number in Perl

Since Perl doesn’t have a built-in is-prime subroutine, we implement our own. As finding the first 10001 primes is an intensive computation, we implement three performance optimizations compared to the naive brute-force solution: first, with the exception of 2, we only check odd integers. Second, we limit the tested divisors to the square root of the integer being checked. Finally, rather than testing all possible divisors, we test only the primes that we have already found. With these three optimizations, the script runs in less than 0.2 second, much faster than I expected.

use strict;
use warnings;
use feature "say";
use constant MAX => 10_001;

sub primes {
    my $max = shift;
    my @primes = (2, 3, 5);
    my $count = 3;
    my $candidate = $primes[-1];
    while ($count <= $max) {
        $candidate += 2;
        my $not_prime = 0;
        my $sq_cand = sqrt $candidate;
        for my $i (@primes) {
            $not_prime = 1, last unless $candidate % $i;
            last if $i > $sq_cand;
        }
        next if $not_prime;
        push @primes, $candidate;
        $count ++;
    }
    return $primes[$max-1];
}
my $p = primes(MAX);
say "$p";

This script displays the following output:

$ time perl ./10001prime.pl
104743

real    0m0,192s
user    0m0,124s
sys     0m0,077s

10001st Prime Number in Ring

I continue my exploration of Ring, a recent programming language (the first version was issued in 2016). The Ring implementation below is essentially a port of the Perl program above (with same performance optimizations):

p = primes(10001)
see p + nl

func primes max
    primes = [2, 3, 5]
    count = len(primes)
    candidate = primes[count]
    while count < max
        candidate += 2
        is_prime = True
        sqrt_cand = sqrt(candidate)
        for i in primes
            if candidate % i = 0
                is_prime = False
                exit
            ok
            if i > sqrt_cand exit ok
        next
        if is_prime 
            add(primes, candidate)
            count ++
        ok
    end
    return primes[max]

This program displays the following output:

$ ring ./10001prime.ring
104743

Note that Ring lists start with subscript 1, so we use index 10001 for finding the 10001 ptime number.

10001st Prime Number in Julia

function getprimes(max)
    primes = [2, 3, 5]
    count = 3
    candidate = 5
    while (count <= max)
        candidate += 2
        not_prime = false
        sq_cand = sqrt(candidate)
        for i in primes
            if (candidate % i == 0)
                not_prime = true
                break
            end
            i > max && break
        end
        not_prime && continue
        push!(primes, candidate)
        count += 1
    end
    return primes[max] # Julia arrays start with index 1
end

p = getprimes(10001)
println(p)

This program displays the following output:

$ julia 10001prime.jl
104743

Task 2: Curious Fraction Tree

Consider the following Curious Fraction Tree:

curious_fraction_146.png

You are given a fraction, member of the tree created similar to the above sample.

Write a script to find out the parent and grandparent of the given member.

Example 1:

Input: $member = '3/5';
Output: parent = '3/2' and grandparent = '1/2'

Example 2:

Input: $member = '4/3';
Output: parent = '1/3' and grandparent = '1/2'

The first problem is to understand how this tree is constructed.

Each fraction has two children. It is easy to see that the left child is always a number smaller than 1 and the right child is always a number larger than 1. But how are the values generated?

Well, it is probably not so difficult to find out, but I must confess that I did not try very hard to find the constructing rules, but found them on the Curious Fraction Tree Web page. They are explained in this diagram:

curious_fraction_tree_pwc146.png

In other words, we have the following rules:

  • For any node, the left child is less than 1 et the right child larger than 1;
  • For node a/b, left child is a/(a+b) and right node is (a+b)/b.

From these two rules, it is easy to derive the reciprocal rules for finding the parent of a node:

  • For a node x/y with a fraction less than 1, the parent is x/(y-x);
  • For a node x/y with a fraction larger than 1, the parent is (x-y)/x.

It is now very easy to implement these rules in various programming languages.

There is, however, one little last problem. The task specifications do not tell us what to do about invalid input. For example, if the input is (1, 1) (the root to the tree), we will not be able to find a parent. Similarly, if we are given (1/2) as input, we will find (1, 1) as the parent, and will not be able to the grand-parent. We would have a problem if one of the values is 0. It is fairly easy to detect these problems, but I still wouldn’t know what to do about it. In many of the implementations below, I have decided that we must be given a valid input and will not try to validate the input. In some others, I have decided to detect some of these invalid input problems and tried to do something reasonable about them.

Curious Fraction Tree in Raku

We’re just implementing the rules above. Here, I do not try to validate the input.

Note that I was first tempted to implement the fraction as a Rat type of value, since it implements it as a numerator/denominator pair. I finally decided not to do that (because there may be some cases where the fraction might be reduced to their simplest form, division by 0 errors, and other such problems). So I decided to implement the fractions as integer pairs.

use v6;

# for a node x/y less than 1, parent is x/(y-x)
# for a node x/y larger than 1, parent is (x-y)/x

sub parent (\num, \denom) {
    return num < denom ?? (num, denom - num) !! (num - denom, denom);
}
for (5, 2), (2, 5), (3, 4), (3, 5) -> $fraction {
    my $parent = parent |$fraction[0,1];
    my $gd-parent = parent |$parent[0,1];
    say "for child $fraction, parent is $parent and gd-parent is $gd-parent"; 
}

With the test fractions provided in the code, this program displays the following output:

raku ./fraction-tree.raku
for child 5 2, parent is 3 2 and gd-parent is 1 2
for child 2 5, parent is 2 3 and gd-parent is 2 1
for child 3 4, parent is 3 1 and gd-parent is 2 1
for child 3 5, parent is 3 2 and gd-parent is 1 2

Curious Fraction Tree in Perl

This program implements the rules described above. Here, we have made some effort to validate the input, just as an example: we write an error value if we get pas the root node.

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

# for a node x/y less than 1, parent is x/(y-x)
# for a node x/y larger than 1, parent is (x-y)/x

sub parent {
    my ($num, $denom) = @{$_[0]};
    return ["Error"] if $num == $denom;
    return $num < $denom ? [$num, $denom - $num] : [$num - $denom, $denom];
}

for my $fraction ([5, 2], [2, 5], [3, 4], [3, 5], [2, 1], [1, 1]) {
    die "Invalid input node @$fraction" if $$fraction[0] == $$fraction[1];
    my $parent = parent $fraction;
    my $gd_parent = parent $parent;
    say "for child @$fraction, parent is @$parent and gd-parent is @$gd_parent"; 
}

This program displays the following output:

$ perl ./fraction-tree.pl
for child 5 2, parent is 3 2 and gd-parent is 1 2
for child 2 5, parent is 2 3 and gd-parent is 2 1
for child 3 4, parent is 3 1 and gd-parent is 2 1
for child 3 5, parent is 3 2 and gd-parent is 1 2
for child 2 1, parent is 1 1 and gd-parent is Error
Invalid input node 1 1 at fraction-tree.pl line 15.

Curious Fraction Tree in Some Other Programming Languages

In Ring

Again the same rules as before, with an attempt to handle gracefully some of the exceptions:

# for a node x/y less than 1, parent is x/(y-x)
# for a node x/y larger than 1, parent is (x-y)/x

for test in [ [5, 2], [2, 5], [3, 4], [3,5], [6, 2], [1, 2] ]
    parent = find_parent(test[1], test[2])
    gd_parent = find_parent(parent[1], parent[2])
    see "Node " + to_str(test) + " has parent " + to_str(parent) + 
        " and grand-parent " + to_str(gd_parent) + nl
next

func find_parent num, denom
    if num < denom
        return [num, denom - num]
    but denom < num
        return [num - denom, denom]
    else 
        return ["Error", ""]
    ok

func to_str input
    return "" + input[1] + " " + input[2]

This script displays the following output:

$ ring ./fraction-tree.ring
Node 5 2 has parent 3 2 and grand-parent 1 2
Node 2 5 has parent 2 3 and grand-parent 2 1
Node 3 4 has parent 3 1 and grand-parent 2 1
Node 3 5 has parent 3 2 and grand-parent 1 2
Node 6 2 has parent 4 2 and grand-parent 2 2
Node 1 2 has parent 1 1 and grand-parent Error

In Python

No attempt here to validate the input.

# for a node x/y less than 1, parent is x/(y-x)
# for a node x/y larger than 1, parent is (x-y)/x

def find_parent(num, denom):
    return [num, denom - num] if num < denom else [num - denom, denom]

for test in ([5, 2], [2, 5], [3, 4], [3, 5]):
    parent = find_parent(test[0], test[1])
    gd_parent = find_parent(parent[0], parent[1])
    print("Node", test, "has parent", parent, "and grand-parent", gd_parent)

Output:

$ python3 ./fraction-tree.py
Node [5, 2] has parent [3, 2] and grand-parent [1, 2]
Node [2, 5] has parent [2, 3] and grand-parent [2, 1]
Node [3, 4] has parent [3, 1] and grand-parent [2, 1]
Node [3, 5] has parent [3, 2] and grand-parent [1, 2]

In Julia

Limited attempt to validate the input (catching only some of the exceptions).

function find_parent(num, denom)
    return num < denom ? [num, denom - num] :
           num > denom ? [num - denom, denom] :
           ("Error on node $num $denom");
end

for test in [ [5, 2], [2, 5], [3, 4], [3, 5], [1, 2] ]
    parent = find_parent(test[1], test[2])
    gd_parent = find_parent(parent[1], parent[2])
    println("Node $test has parent $parent and grand-parent $gd_parent")
end

Output:

# Node [5, 2] has parent [3, 2] and grand-parent [1, 2]
# Node [2, 5] has parent [2, 3] and grand-parent [2, 1]
# Node [3, 4] has parent [3, 1] and grand-parent [2, 1]
# Node [3, 5] has parent [3, 2] and grand-parent [1, 2]
# Node [1, 2] has parent [1, 1] and grand-parent Error on node

In Awk:

# Run for example as:
# echo ' 5/2
# 2/5
# 3/5' | awk -f fraction-tree.awk
function parent() 
{
    if (a < b) {
        b = b - a
    } else {
        a = a - b
    }
}
BEGIN {
    a = 0
    b = 0
    FS = "/"
}
{
    a = $1
    b = $2
    printf "Node = %d/%d: ", a, b
    parent()
    printf "Parent = %d/%d; ", a, b
    parent()
    printf "Grand-parent = %d/%d\n", a, b
}

Output:

$ echo ' 5/2
2/5
3/4
3/5
6/2 ' | awk -f fraction-tree.awk
Node = 5/2: Parent = 3/2; Grand-parent = 1/2
Node = 2/5: Parent = 2/3; Grand-parent = 2/1
Node = 3/4: Parent = 3/1; Grand-parent = 2/1
Node = 3/5: Parent = 3/2; Grand-parent = 1/2
Node = 6/2: Parent = 4/2; Grand-parent = 2/2

In Ruby

# For a node `x/y` with a fraction less than 1, the parent is `x/(y-x)`;
# For a node `x/y` with a fraction larger than 1, the parent is `(x-y)/x`.

def get_parent (pair)
    num = pair[0]
    denom = pair[1]
  return num < denom ? [num, denom - num] : [num - denom, denom];
end

tests = [ [5, 2], [2, 5], [3, 4], [3,5] ]
for test in tests
    parent = get_parent(test)
    gd_parent = get_parent(parent)
    print("Node #{test} - Parent: #{parent} - Grand-Parent: #{gd_parent}\n")
end

Output:

Node 5,2 - Parent: 3,2 - Grand-Parent: 1,2
Node 2,5 - Parent: 2,3 - Grand-Parent: 2,1
Node 3,4 - Parent: 3,1 - Grand-Parent: 2,1
Node 3,5 - Parent: 3,2 - Grand-Parent: 1,2

In Lua

-- For a node `x/y` with a fraction less than 1, the parent is `x/(y-x)`;
-- For a node `x/y` with a fraction larger than 1, the parent is `(x-y)/x`.

local function get_parent(pair)
    num = pair[1]
    denom = pair[2]
    -- no ternary operator in Lua, we can simulate it with and / or:
    return num < denom and {num, denom - num} or {num - denom, denom}
end

local function to_str(pair)
    -- return pair[1] .. "/" .. pair[2]
    return table.concat(pair, "/")
end

local tests = { {5, 2}, {2, 5}, {3, 4}, {3,5} }
for _, test in pairs(tests) do
    parent = get_parent(test)
    gd_parent = get_parent(parent)
    print("Node " .. to_str(test) .. " - Parent: " .. to_str(parent)
        .. " - Grand-Parent: " .. to_str(gd_parent))
end

Output:

$ lua ./fraction-tree.lua
Node 5/2 - Parent: 3/2 - Grand-Parent: 1/2
Node 2/5 - Parent: 2/3 - Grand-Parent: 2/1
Node 3/4 - Parent: 3/1 - Grand-Parent: 2/1
Node 3/5 - Parent: 3/2 - Grand-Parent: 1/2

In Kotlin

fun find_parent(pair: IntArray): IntArray {
    val num = pair[0]
    val denom = pair[1]
    return if (num < denom) intArrayOf(num, denom - num) else intArrayOf(num - denom, denom)
}

fun n2str (pair: IntArray): String {
    return "${pair[0]}/${pair[1]}"
}

fun main() {
val tests  = arrayOf(intArrayOf(5,2), intArrayOf(2,5), intArrayOf(3,4))
    for (test in tests) {
        val parent = find_parent(test)
        val gd_parent = find_parent(parent)
        print(n2str(test) + " - Parent: " + n2str(parent))
        println(" - Grand-parent: " + n2str(gd_parent))
    }
}

Output:

5/2 - Parent: 3/2 - Grand-parent: 1/2
2/5 - Parent: 2/3 - Grand-parent: 2/1
3/4 - Parent: 3/1 - Grand-parent: 2/1

In C

#include <STDIO>
void parent(int *a, int *b) {
    if (*a < *b) {
        *b -= *a;
    } else {
        *a -= *b;
    }
}

int main (void) {
    int num, denom;

    while (scanf ("%d/%d", &num, &denom) == 2) {
        printf("%d/%d - ", num, denom);
        parent(&num, &denom);
        printf("Parent: %d/%d - ", num, denom);
        parent(&num, &denom);
        printf("Grand-parent: %d/%d \n", num, denom); 
    }
    return (0);
}

Output:

$ echo ' 5/2
2/5
3/4
3/5' | ./a.out
5/2 - Parent: 3/2 - Grand-parent: 1/2
2/5 - Parent: 2/3 - Grand-parent: 2/1
3/4 - Parent: 3/1 - Grand-parent: 2/1
3/5 - Parent: 3/2 - Grand-parent: 1/2

In Scala

object fraction_tree extends App {

  def findParent(pair: List[Int]): List[Int] = {
    val num = pair(0)
    val denom = pair(1)
    return if (num < denom) List(num, denom - num) else List(num - denom, denom)
  }
  def n2str(pair: List[Int]): String = {
    return s"${pair(0)}" + "/" + s"${pair(1)}"
  }

  val tests: List[List[Int]] = List(List(5, 2), List(2, 5), List(3, 4))
  for (test <- tests) {
    val parent = findParent(test)
    val gd_parent = findParent(parent)
    println(n2str(test) + " - Parent: " + n2str(parent) + " - Grand-parent: " + n2str(gd_parent))
  }
}

Output:

5/2 - Parent: 3/2 - Grand-parent: 1/2
2/5 - Parent: 2/3 - Grand-parent: 2/1
3/4 - Parent: 3/1 - Grand-parent: 2/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 January 16, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 145: Palindromes

These are some answers to the Week 145 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 January 2, 2022 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: Dot Product

This first task of this week’s challenge was covered in this blog post.

Task 2: Palindromic Tree

You are given a string $s.

Write a script to create a Palindromic Tree for the given string.

I found this blog explaining Palindromic Tree in detail.

Example 1:

Input: $s = 'redivider'
Output: r redivider e edivide d divid i ivi v

Example 2:

Input: $s = 'deific'
Output: d e i ifi f c

Example 3:

Input: $s = 'rotors'
Output: r rotor o oto t s

Example 4:

Input: $s = 'challenge'
Output: c h a l ll e n g

Example 5:

Input: $s = 'champion'
Output: c h a m p i o n

Example 6:

Input: $s = 'christmas'
Output: c h r i s t m a

The blog explaining palindromic trees is in my humble opinion somewhat unclear and quite difficult to follow.

If we look at the examples provided, the aim is to find all palindromes that can be formed from fragments of a word. For example, for the word redivider, the palindromic fragments are: r redivider e edivide d divid i ivi v. Note that a single letter is considered to be a palindrome, even though it is sort of a trivial solution. Also note that each palindrome appears only once in the output, so the algorithm somehow removes any duplicates. Finally, the palindromes are ordered by their place of occurrence in the input string.

With these properties in mind, we can write a much simpler algorithm to find all palindromes and generate exactly the requested output.

The point about the palindromic tree algorithm is that it is supposed to be efficient. Well, I’m not even sure that a proper palindromic tree implementation would run faster than my implementations below with the input examples provided. As Donald Knuth wrote in The Art of Computer Programming, “premature optimization is the root of all evil (or at least most of it) in programming.” So, before spending a lot of time and energy on implementing a fairly complicated algorithm, let’s see how a much simpler naive implementation behaves.

Well, with the six input words provided in the task specification, the Perl program below is timed as follows on my laptop (a relatively good computer, but certainly not a racing horse):

real    0m0,048s
user    0m0,015s
sys     0m0,030s

In other words, it runs in less than 50 milliseconds (compile time included). This is fairly good, isn’t it? Why, for heaven’s sake, would you want to optimize this? I certainly don’t want to spend hours on a complicated algorithm just to possibly scrap a few milliseconds.

Admittedly, for very long input strings, the palindromic tree algorithm may perform faster, but palindromes are normally used on actual words, which rarely have more than a dozen letters.

And, as we shall see, our output is exactly what is requested from us in the task specification. So, why bother?

Palindromes in Raku

We just use two nested loops to generate all fragments of the input words. Then we filter out fragments that are not palindromes and palindromes that have already been seen previously for the same input (to avoid duplicates).

use v6;

sub is-palindrome (Str $in) { return $in eq $in.flip; }

sub find-all-palindromes ($input) {
    print "$input: ";
    my BagHash $seen;
    for 0..$input.chars -> $start {
        for 1..$input.chars - $start -> $length {
            my $candidate = substr $input, $start, $length;
            next unless is-palindrome $candidate.Str;
            next if $seen{$candidate};
            $seen{$candidate}++;
            print "$candidate ";
        }
    }
    say " ";
}

for <redivider deific rotors challenge
    champion christmas> ->  $test {
        find-all-palindromes $test;
}

This program displays the following output:

$ raku ./palindromes.raku
redivider: r redivider e edivide d divid i ivi v
deific: d e i ifi f c
rotors: r rotor o oto t s
challenge: c h a l ll e n g
champion: c h a m p i o n
christmas: c h r i s t m a

Palindromes in Perl

This is a port to Perl of the above Raku program. Please refer to the explanations above if needed.

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

sub is_palindrome { return $_[0] eq reverse $_[0]; }

sub find_all_palindromes {
    my $input = shift;
    print "$input: ";
    my %seen;
    my $str_length = length $input;
    for my $start (0..$str_length) {
        for my $length (1.. $str_length - $start) {
            my $candidate = substr $input, $start, $length;
            next unless is_palindrome $candidate;
            next if $seen{$candidate};
            $seen{$candidate} = 1;
            print "$candidate ";
        }
    }
    say " ";
}

for my $test (qw <redivider deific rotors 
              challenge champion christmas>) {
        find_all_palindromes $test;
}

This program displays the following output:

$ perl palindromes.pl
redivider: r redivider e edivide d divid i ivi v
deific: d e i ifi f c
rotors: r rotor o oto t s
challenge: c h a l ll e n g
champion: c h a m p i o n
christmas: c h r i s t m a

Update (Jan 2, 2022): Added the new section below with 6 languages.

Palindromes in 6 Other Programming languages

In Python

def is_palindrome (str):
    return str == str[::-1]

def find_all_palindromes (input):
    seen = {}
    result = f'{input} : '
    for start in range (0, len(input)):
        for endstr in range(1, (len(input) + 1)):
            candidate = input[start : endstr]
            if is_palindrome(candidate) and not candidate in seen:
                result = result + " " + candidate
                seen[candidate] = 1
    print(result)

for test in ("redivider", "deific", "rotors", "challenge"): 
    find_all_palindromes(test);

Output:

$ python3 ./palindromes.py
redivider :  r redivider  e edivide d divid i ivi v
deific :  d  e i ifi f c
rotors :  r rotor  o oto t s
challenge :  c h a l ll e n g

In Julia

function is_palin(instr)
    return instr == reverse(instr)
end

function find_all_palindromes(input)
    print("$input: ")
    seen = Dict()
    for startstr in 1:length(input)
        for endstr in startstr:length(input)
            cand = input[startstr:endstr]  # candidate
            if is_palin(cand) && cand ∉ keys(seen)
                print("$cand ")
                seen[cand] = 1
            end
        end
    end
    print("\n")
end

for test in ("redivider", "rotors", "deific", "challenge")
    find_all_palindromes(test)
end

Output:

redivider: r redivider e edivide d divid i ivi v 
rotors: r rotor o oto t s 
deific: d e i ifi f c 
challenge: c h a l ll e n g

In Rust

use std::collections::HashSet;

fn is_palindrome (instr : &str) -> bool {
    return instr == instr.chars().rev().collect::<String>()
}

fn find_palindromes (input : &str) {
    print!("{}: ", input);
    let mut seen = HashSet::new();
    for start in 0..input.len() {
        for endstr in start+1..=input.len() {
            let cand = &input[start .. endstr];
            if is_palindrome(&cand) && !seen.contains(&cand) {
                print!("{} ", cand);
                seen.insert(cand);
            }
        }
    }
    println!(" ");
}

fn main () {
    let tests = vec!["redivider", "rotors", "challenge"];
    for test in tests.into_iter() {
        find_palindromes(test);
    }
}

Output:

redivider: r redivider e edivide d divid i ivi v  
rotors: r rotor o oto t s  
challenge: c h a l ll e n g

In Ruby

def is_palindrome (instr)
    return instr == instr.reverse
end

def find_palindromes (input)
    print input, ": "
    seen = {}
    for start in 0 .. input.length - 1 do
        for endstr in start .. input.length - 1 do
            cand = input[start .. endstr]
            if is_palindrome(cand) and not seen[cand] then
                print cand, " "
                seen[cand] = 1
            end
        end
    end
    puts " "
end

for test in ["redivider", "rotors", "challenge"] do
    find_palindromes(test)
end

Output:

$ ruby palindrome.rb
redivider: r redivider e edivide d divid i ivi v  
rotors: r rotor o oto t s  
challenge: c h a l ll e n g

In Lua

local function is_palindrome (instr)
    return instr == string.reverse(instr)
end

local function find_palindromes (input) 
    io.write (input, ": ")
    local seen = {}
    for startstr = 1, #input do
        for endstr = startstr, #input do
            local cand = string.sub (input, startstr, endstr)
            if is_palindrome(cand) and not seen[cand] then
                io.write(cand, " ")
                seen[cand] = 1
            end
        end
    end
print(" ")
end

local tests = {"redivider", "rotors", "challenge"}
for _, test in pairs(tests) do
    find_palindromes(test)
end

Output:

$ lua ./dot-product.lua
redivider: r redivider e edivide d divid i ivi v  
rotors: r rotor o oto t s  
challenge: c h a l ll e n g

In Ring

Ring is a new programming language. Well, it is at least completely new to me (I had never heard about it until this morning of Jan 2, 2022), but it was released for the first time in January 2016. Its documentation states:

The Ring is an Innovative and practical general-purpose multi-paradigm scripting language that can be embedded in C/C++ projects, extended using C/C++ code and/or used as standalone language. The supported programming paradigms are Imperative, Procedural, Object-Oriented, Functional, Meta programming, Declarative programming using nested structures, and Natural programming.

I thought it would be interesting to get a gist of it by using it as a guest language in the Perl Weekly Challenge. Here we go.

tests = ["redivider", "rotors", "challenge"]
for test in tests
    find_palindromes(test)
next

func find_palindromes input
    see input + " : " 
    seen = []
    for start = 1 to len(input)
        for length = 1 to len(input) - start
            cand = substr(input, start, length)
            if is_palindrome(cand) and not seen[cand]
                see cand + " "
                add(seen, cand)
            ok
        next
    next
    see " " + nl

func is_palindrome instr
    reverse = ""
    for i = len(instr) to 1 step -1
        reverse = reverse + instr[i]
    next
    return reverse = instr

Using the Ring online compiler, I obtain the following output:

redivider : r e edivide d divid i ivi v i d e
rotors : r rotor o oto t o r
challenge : c h a l ll l e n g

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