laurent_r

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

Challenge # 1: Square Number With At Least 5 Distinct Digits

Write a script that finds the first square number that has at least 5 distinct digits. This was proposed by Laurent Rosenfeld.

Again a challenge suggested by me. I swear that I did not try to solve any of the challenge proposals I sent to Mohammad before submitting these proposals to him. Even the special case of the perfect number challenge of last week is no exception, since, as I explained in my blog post on it, while it stemmed from a CS course assignment of 28 years ago that I solved at the time, the requirement I suggested was markedly different and significantly more difficult.

In the case of the challenge of this week, I think it is a quite simple one, which is IMHO fair, since my understanding is that Mohammad intended each week's first assignment to be "beginner oriented" (even though there may have been a couple of cases where the first challenge wasn't so easy).

There might be a slight ambiguity in the question (please don't tell me, I know I'm guilty for that). I consider that we want at least 5 distinct digits, but don't care if some of the digits have duplicates. For example, in my view, 105625 is the square of 325 and has at least 5 distinct digits and thus qualifies as a "square number that has at least 5 distinct digits" (except, of course, that it isn't the first one, but it would be a valid answer if it happened to be the first one). As it turns out, this possible ambiguity is immaterial, since the first number satisfying the requirement has only 5 digits anyway (and therefore no duplicate). The point, though, is that our code doesn't need to care about possible duplicate digits, provided we can count at least 5 distinct digits.

Anyway, let's get around to it without further ado.

Square Numbers in Perl 5

We need square numbers with 5 digits, so we'll loop on successive integers from 100 on and compute their square (since the squares of smaller integers are bound to have less that 5 digits). Then, the split builtin function will provide the individual digits, which we store in a hash to remove duplicate digits. As soon as the hash has 5 items, we can print the number.

This is simple enough to be done in a one-liner:

$ perl -E 'for (100..1000) { my %h = map {$_ => 1} split //, $_**2; say "$_ -> ", $_**2 and last if scalar %hash >= 5 }'
113 -> 12769

If you prefer to see a real script, here is what it could look like:

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

for my $integer (100..1000) {
    my $square = $integer ** 2;
    my @digits = split //, $square;
    my %unique_digits = map {$_ => 1} @digits;
    if (scalar keys %unique_digits >= 5) {
        say "$integer -> $square";
        last;
    }
}

Working on the Perl 6 version (see below) reminded me that the Perl 5 list::util core module has a uniq function to remove duplicates from a list. Furthermore, in scalar context, it returns the number of elements that would have been returned as a list, which is exactly what we need here. However, this requires a recent version (version 1.45 or above) of List::Util, so this one-liner might not work on your computer if you have older versions and it did not work for me on the first three boxes where I initially tried it (you probably need Perl 5.26 to have the right version of this core module out of the box):

$ perl -MList::Util=uniq -E 'for (100..1000) { say "$_ -> ", $_**2 and last if uniq (split //, $_**2) >= 5}'
113 -> 12769

One slight problem with these implementations is that we don't really know in advance how large the range of successive integer needs to be. In that case, it is often better to use an infinite loop (for example while (1) { ... }). Here, however, it seemed rather obvious to me that we would find a square with 5 distinct digits relatively quickly, so that for (100..1000) would certainly be a good enough approximation of an infinite range for our purpose (and, for some idiosyncratic reasons hard to explain, I tend to like for loops better than while loop).

Another possibility is to create an iterator. We'll cover that in another blog.

Square Numbers in Perl 6

Thinking about adapting the P5 one-liner, my first thought was to use a set instead of a hash to remove duplicate digits, but, just a few seconds later, it came to my mind that there is a built-in unique function to do just that.

$ perl6 -e 'say $_ ** 2 and last if ($_**2).comb.unique >= 5 for 100..*'
12769

Aside from the syntactic adjustments, the important difference is that we don't have to worry about the range upper bound: we just generate a lazy infinite list of successive integers larger than or equal to 100.

This could be also done by generating directly an infinite list of squares:

$ perl6 -e 'say $_ and last if .comb.unique >= 5 for map {$_ **2}, 100..*;'
12769

This is what it might look like if you prefer a full-fledged script:

use v6;

my @squares = map {$_ ** 2}, 100..*;   # lazy infinite list of squares
for @squares -> $square {
    if $square.comb.unique >= 5 {
        say $square;
        last;
    }
}

We could also remove any for loop and if conditional by just building successively two infinite lists:

use v6;

my @squares = map {$_ ** 2}, 100..*;
my @candidates = grep { .comb.unique >= 5}, @squares;
say @candidates[0];

By the way, this idea of using infinite lists can be boiled down to another approach for a one-liner:

$ perl6 -e 'say (grep { .comb.unique >= 5}, map {$_ ** 2}, 100..*)[0];'
12769

Finally, another possible approach is to use chained method invocations:

$ perl6 -e 'say (100..*).map(* ** 2).grep(*.comb.unique >= 5).first;'
12769

Rankings

Write a script to perform different types of ranking as described below:

1. Standard Ranking (1224): Items that compare equal receive the same ranking number, and then a gap is left in the ranking numbers.

2. Modified Ranking (1334): It is done by leaving the gaps in the ranking numbers before the sets of equal-ranking items.

3. Dense Ranking (1223): Items that compare equally receive the same ranking number, and the next item(s) receive the immediately following ranking number.

For more information, please refer to wikipage.

Rankings in Perl 5

The first idea is to write three subroutines to perform each of the rankings. I tried to think about common code that could be shared to avoid repeating one-self, but could not come up with any obvious idea in this direction. So I thought: let's just write the three subroutines, and we'll see later if some things can be factored out.

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

sub standard {
    my %scores = @_;
    my ($prev_rank, $prev_val, $rank) = (0, 0, 0);
    say "Rank\tID\tScore";
    for my $key (sort { $scores{$a} <=> $scores{$b} } keys %scores) {
        $rank++;
        if ($scores{$key} > $prev_val) {
            say $rank, "\t$key\t$scores{$key}";
            $prev_rank = $rank;
        } else {
            say $prev_rank, "\t$key\t$scores{$key}";
        }
        $prev_val =  $scores{$key};
    }
}

sub modified {
    my %scores = @_;
    my ($prev_val, $rank) = (0, 0);
    my @buffer;
    say "Rank\tID\tScore";
    for my $key (sort { $scores{$a} <=> $scores{$b} } keys %scores) {
        $rank++;
        if ($scores{$key} > $prev_val) {
            say $rank - 1, $_ for @buffer;
            @buffer = ("\t$key\t$scores{$key}");
        } else {
            push @buffer, "\t$key\t$scores{$key}";
        }
        $prev_val =  $scores{$key};
    }
    say $rank, shift @buffer while @buffer;
}

sub dense { 
    my %scores = @_;
    my ($prev_rank, $prev_val, $rank) = (0, 0, 0);
    say "Rank\tID\tScore";
    for my $key (sort { $scores{$a} <=> $scores{$b} } keys %scores) {
        if ($scores{$key} > $prev_val) {
            $rank++;
            say $rank, "\t$key\t$scores{$key}";
            $prev_rank = $rank;
        } else {
            say $prev_rank, "\t$key\t$scores{$key}";
        }
        $prev_val =  $scores{$key};
    }
}

my %scores = (a => 4, b => 5, c => 3, d => 5, e => 1, f => 4, g => 6, h => 4, i =>6);
say "      Standard";
standard(%scores);
say "\n      Modified";
modified(%scores);
say "\n      Dense";
dense(%scores);

This duly displays the following:

      Standard
Rank    ID      Score
1       e       1
2       c       3
3       a       4
3       h       4
3       f       4
6       d       5
6       b       5
8       g       6
8       i       6

      Modified
Rank    ID      Score
1       e       1
2       c       3
5       a       4
5       h       4
5       f       4
7       d       5
7       b       5
9       g       6
9       i       6

      Dense
Rank    ID      Score
1       e       1
2       c       3
3       a       4
3       h       4
3       f       4
4       d       5
4       b       5
5       g       6
5       i       6

Phew, that seems like a lot of code for such seemingly simple task. Of course, we could certainly make it slightly more concise here or there, but nothing really significant. The code almost looks the same in the three subroutines, but it has enough small differences to make it difficult to take out some code and put it in a separate common subroutine. I have also been pondering about using code references, callback subroutines or a "function factory," but none of these solutions seemed to bring any significant advantage. Since there is no reason to make things more complicated or to use more advanced techniques when doing that does not bring any significant advantage, I'll leave it at that for now.

Rankings in Perl 6

There is one thing that I don't like too much in my P5 solution above: I feel that my subroutines should probably not have printed the rankings, but rather returned a ranking string (or array) to be printed by the caller. I'm feeling too lazy to change it by now in the P5 solution, as this is secondary matter, but, at least, I'll not do that in the Perl 6 solution. Other than that (and leaving aside the small syntax changes), it will be essentially the same solution.

use v6;

sub standard (%scores) {
    my ($prev_rank, $prev_val, $rank, $rankings ) = 0, 0, 0, "";
    for sort {%scores{$_}}, keys %scores -> $key {
        $rank++;
        if (%scores{$key} > $prev_val) {
            $rankings ~= "$rank\t$key\t%scores{$key}\n";
            $prev_rank = $rank;
        } else {
            $rankings ~= "$prev_rank\t$key\t%scores{$key}\n";
        }
        $prev_val =  %scores{$key};
    }
    return $rankings;
}

sub modified (%scores) {
    my ($prev_val, $rank, @rankings, @buffer) = 0, 0;
    for sort {%scores{$_}}, keys %scores -> $key {
        $rank++;
        if (%scores{$key} > $prev_val) {
            push @rankings, ($rank - 1 ~ $_) for @buffer;
            @buffer = ("\t$key\t%scores{$key}");
        } else {
            push @buffer, "\t$key\t%scores{$key}";
        }
        $prev_val =  %scores{$key};
    }
    push @rankings, ($rank ~ $_) for @buffer;
    return join "\n", @rankings;
}

sub dense (%scores) { 
    my ($prev_rank, $prev_val, $rank, $rankings) = 0, 0, 0, "";
    for sort {%scores{$_}}, keys %scores -> $key {
        if (%scores{$key} > $prev_val) {
            $rank++;
            $rankings ~= "$rank\t$key\t%scores{$key}\n";
            $prev_rank = $rank;
        } else {
            $rankings ~= "$prev_rank\t$key\t%scores{$key}\n";
        }
        $prev_val =  %scores{$key};
    }
    return $rankings;
}

my %scores = a => 4, b => 5, c => 3, d => 5, e => 1, f => 4, g => 6, h => 4, i =>6;

my $head = "Rank\tID\tScore";
.say for  "      Standard", $head, standard(%scores);
.say for "\n      Modified", $head, modified(%scores);
.say for "\n      Dense", $head, dense(%scores);

This displays almost the same as the P5 script:

$ perl6 rankings.p6
      Standard
Rank    ID      Score
1       e       1
2       c       3
3       a       4
3       h       4
3       f       4
6       d       5
6       b       5
8       g       6
8       i       6


      Modified
Rank    ID      Score
1       e       1
2       c       3
5       a       4
5       h       4
5       f       4
7       d       5
7       b       5
9       g       6
9       i       6

      Dense
Rank    ID      Score
1       e       1
2       c       3
3       a       4
3       h       4
3       f       4
4       d       5
4       b       5
5       g       6
5       i       6

One syntactic change between P5 and P6 is interesting regarding the use of the sort built-in function. In Perl 6, when the first argument of the sort function is a code block (or a subroutine) taking only one parameter, then that code is not intended to be a comparison block, but a code object implementing the dereference or transformation operation to be applied to the items to be sorted before using the default cmp comparison subroutine. This not only makes the code slightly simpler, but it can also make it faster, since the values thus calculated are cached, so that the derefecencing or transformation is done only once for each value to be sorted (rather than having to do it for each comparison performed during the sort process). In other words, Perl 6 automatically performs a Schwartzian transform on the items to be sorted.

Wrapping up

There was a third challenge this week: Send email using Sparkpost API. For more information, visit the official page. This challenge was proposed by Gabor Szabo. The API challenge is optional and would love to see your solution.

As I already said last week, I know next to nothing about this kind of topic, so I won't undertake anything on that subject and even less blog about it. Please try this challenge and provide answers if you know more that I do on such topic.

As mentioned above, I'll make another blog on the same subject in the next days, covering these challenges with a functional programming approach, in which we will use iterators, closures, function factories and other somewhat exotic ways to solve these challenges.

The next week Perl Weekly Challenge is due to start very soon. If you're interested in participating in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 6 p.m. BST (British summer time) on next Sunday, June 2. And, please, also spread the word about the Perl Weekly Challenge if you can.