January 2021 Archives

Perl Weekly Challenge 97: Caesar Cipher and Binary Substrings

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

Task 1: Caesar Cipher

You are given string $S containing only the letters A..Z and a number $N.

Write a script to encrypt the given string $S using a Caesar Cipher with left shift of size $N.

Example:

Input: $S = "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG", $N = 3
Output: "QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD"

Plain:    ABCDEFGHIJKLMNOPQRSTUVWXYZ
Cipher:   XYZABCDEFGHIJKLMNOPQRSTUVW

Plaintext:  THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG
Ciphertext: QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD

A Caesar cypher is a weak form of encryption that involves “rotating” each letter of the input string by a fixed number of places. To rotate a letter means to shift it through the alphabet, wrapping around to the end if necessary. In the movie 2001: A Space Odyssey, the spaceship’s computer is called HAL, which is IBM left rotated by 1.

Note that the task description says that the input string contains only the letters A..Z, but the example provided also contains spaces which are not in the encrypted solution. So we need to handle spaces as a special case. Depending on the language, my solutions will either handle spaces as one special case, or decide not to convert any letter outside of the A..Z range in order, for example, to preserve also punctuation marks).

Caesar Cipher in Raku

I decided to implement the solution in a functional style (to make the porting to Scala easier). So almost everything is made in a map block that processes each letter in turn and returns a stream of converted letters that are then join into the cypher string. Note that in the Raku solution, we convert only the letters the A..Z range.

use v6;
constant $default = "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG";
constant $min = 'A'.ord;
constant $max = 'Z'.ord;

sub MAIN (Str $in-string = $default, Int $shift = 3) {
    say rotate($in-string.uc, $shift);
    #say $out;
}
sub rotate ($in, $shift) {
    return join "", 
        map { my $let= $_ - $shift; 
              $let +=  26 if $let < $min; 
              $min <= $_ <= $max ?? $let.chr !! $_.chr; 
            }, $in.comb>>.ord;
}

This script displays the following output:

$ raku caesar.raku
QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD

Note that there is a special case of Caesar cipher called ROT13, where each letter is rotated by 13 places. Since 13 is half of the number of letters in our alphabet, applying ROT13 twice returns the original string, so that the same code may be used to encode and decode a string. ROT13 was commonly used on the Internet to weakly hide potentially offensive jokes or solutions to puzzles. With a fixed shift of 13, the code might be much simpler and can be contained in a simple one-liner:

$ raku -e 'my $w = @*ARGS[0]; $w ~~ tr/A..MN..Z/N..ZA..M/; say $w;' FOOBAR
SBBONE

$ raku -e 'my $w = @*ARGS[0]; $w ~~ tr/A..MN..Z/N..ZA..M/; say $w;' SBBONE
FOOBAR

Caesar Cipher in Perl

This is essentially a port to Perl of the Raku program, except that, here, only the space character is handled differently:

use strict;
use warnings;
use feature "say";
use constant MIN => ord 'A';

my $in_string = shift // "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG";
my $shift = shift // 3;
say rotate(uc $in_string, $shift);

sub rotate {
    my ($in, $shift) = @_;
    return join "", 
        map { my $let = ord($_) - $shift; 
              $let +=  26 if $let < MIN; 
              $_ eq " " ? " " : chr $let 
            } split "", $in;
}

This script displays the following output:

$ perl  caesar.pl
QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD

In the specific case of ROT13 (Caesar cipher with a shift of 13 letters), we can also use a simple Perl one-liner:

$ perl -E '$w = shift; $w =~ tr/A-MN-Z/N-ZA-M/; say $w;' FOOBAR
SBBONE

$ perl -E '$w = shift; $w =~ tr/A-MN-Z/N-ZA-M/; say $w;' SBBONE
FOOBAR

Caesar Cipher in Scala

This a simple port to Scala of the Raku and Perl programs above.

object caesar extends App {
  val test = "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG"
  val shift = 3
  println( test.map(convert(_, shift)))

  def convert(c: Char, shift: Int): Char = {
    val min = 'A'.toByte
    val asc = c.toByte - shift;
    val conv = if (asc < min) asc + 26 else asc
    return if (c == ' ') ' ' else conv.toChar
  }
}

Output:

QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD

Caesar Cipher in Python

Again, a port to Python of the Raku and Perl programs above. Except that functional programming is much less easy in Python, so we use a more conventional procedural approach. Since Python makes it possible to chain comparison operators, it makes it simple to convert only the letters the A..Z range.

ALPHA_COUNT = 26
MIN = ord('A')

input_string = "THE QUICK BROWN FOR JUMPS OVER THE LAZY DOG"
shift = 3
out = ""
for char in input_string:
    if 'A' <= char <= 'Z':
        asc_code = ord(char) - shift
        if asc_code < MIN:
            asc_code += ALPHA_COUNT
        out += chr(asc_code)
    else:
        out += char
print(out)

This script displays the following output:

$ python3 caesar.py
QEB NRFZH YOLTK CLO GRJMP LSBO QEB IXWV ALD

Task #2: Binary Substrings

You are given a binary string $B and an integer $S.

Write a script to split the binary string $B into substrings of size $S and then find the minimum number of flips required to make all substrings the same.

Example 1:

Input: $B = “101100101”, $S = 3
Output: 1

Binary Substrings:
    "101": 0 flip
    "100": 1 flip to make it "101"
    "101": 0 flip

Example 2:

Input $B = “10110111”, $S = 4
Output: 2

Binary Substrings:
    "1011": 0 flip
    "0111": 2 flips to make it "1011"

It isn’t really necessary to actually split the input string. We can iterate over the substrings and, for each position, find the number of 1s (or 0s, it’s your draw). So, in each position, we sum the minimum of the number of 1s and the number of 0s.

Binary Substrings in Raku

With the above explanations, this is hopefully clear:

use v6;
subset Binstr of Str where /^<[01]>*$/;

sub MAIN (Binstr $in-string,  Int $size) {
    my $sub-str-len = $in-string.chars / $size;
    my $flips = 0;
    for 0..^$sub-str-len -> $i {
        my $ones = 0;
        for 0..^$size -> $j {
            my $idx = $j * $sub-str-len + $i;
            $ones++ if substr($in-string, $idx, 1) == 1
        }
        my $zeroes = $size - $ones;
        $flips += min ($zeroes, $ones)
    }
    say $flips;
}

Output:

$ ./raku bin-substrings.raku  101100101 3
1

$ ./raku bin-substrings.raku  10110111 4
2

Binary Substrings in Perl

This is the same idea as above for the Perl version:

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

my ($in_string, $size) = @ARGV;
my $sub_str_len = length($in_string) / $size;
my $flips = 0;
for my $i (0 .. $sub_str_len - 1) {
    my $ones = 0;
    for my $j (0 .. $size - 1) {
        my $idx = $j * $sub_str_len + $i;
        $ones++ if substr ($in_string, $idx, 1) == 1;
    }
    my $zeroes = $size - $ones;
    $flips += $zeroes > $ones ? $ones : $zeroes;
}
say $flips;

Output:

$ perl  bin-substrings.pl 101100101 3
1

$ perl  bin-substrings.pl  10110111 4
2

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

Perl Weekly Challenge 96: Reverse Words and Edit Distance (and Decorators in Perl)

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (January 24, 2021). 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: Reverse Words

You are given a string $S.

Write a script to reverse the order of words in the given string. The string may contain leading/trailing spaces. The string may have more than one space between words in the string. Print the result without leading/trailing spaces and there should be only one space between words.

Example 1:

Input: $S = "The Weekly Challenge"
Output: "Challenge Weekly The"

Example 2:

Input: $S = "    Perl and   Raku are  part of the same family  "
Output: "family same the of part are Raku and Perl"

Reverse Words in Raku

we simply chain the words, reverse and join method invocations:

use v6;

my $input = @*ARGS[0] // "    Perl and   Raku are  part of the same family  ";
say $input.words.reverse.join(" ");

Example output:

$ raku reverse-words.raku
family same the of part are Raku and Perl
~
$ raku reverse-words.raku "Don't ask what your country can do for you, ask what you can do for   your country  "
country your for do can you what ask you, for do can country your what ask Don't

Of course, this short script can easily be transformed into a Raku one-liner:

$ raku -e '@*ARGS[0].words.reverse.join(" ").say;' "    Perl and   Raku are  part of the same family  "
family same the of part are Raku and Perl

Reverse Words in Perl

In Perl, we use the same idea, just chaining function calls instead of method invocations:

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

my $input = shift // "    Perl and   Raku are  part of the same family  ";
say join " ", reverse split /\s+/, $input;

Output:

$ perl reverse-words.pl
family same the of part are Raku and Perl

Of course, we could also make it as a Perl one-liner:

$ perl -E 'say join " ", reverse split /\s+/, shift' "    Perl and   Raku are  part of the same family  "
family same the of part are Raku and Perl

Reverse Words in Scala

Using the same idea as in Raku, i.e. chaining the split, reverse, and mkString method invocations:

object reverseWords extends App {
  val in = "    Perl and   Raku are  part of the same family  "
  println(in.split("\\s+").reverse.mkString(" "))
}

Output:

family same the of part are Raku and Perl

Reverse Words in Python

Whether using a function-call syntax (in Perl), or a method-invocation syntax (in Raku and Scala), our three programs above all use a functional programming approach chaining pure functions and using immutable data, more precisely a data flow or pipeline pattern. In this programming model, each piece of data is channeled through a series of successive transformations in which the returned data elements produced by one of the operations are fed to the next operation, and so on. This is possible because each operation of the pipeline is a “pure function” that takes an input and produces an output to be processed by the next operation.

This is not easily transposable in Python, because some operators acts are pure function as in the three other languages, and some others (such as reverse in our case) are not pure functions and modify the data in-place instead of sending back the modified data as a return value. It would certainly be possible to work around the limitation in Python (using for example maps), but this is much less natural than in the three other languages, and it probably doesn’t make much sense to try to force the data flow model into Python. Therefore, our Python implementation will use intermediate temporary variables, as in traditional procedural programming.

def reverse_words(in_str):
    words = in_str.split()
    words.reverse()
    return " ".join(words)

input = "    Perl and   Raku are  part of the same family  "
print(reverse_words(input))

Output:

$ python3 reverse-words.py
Perl and Raku are part of the same family

Task 2: Edit Distance

You are given two strings $S1 and $S2.

Write a script to find out the minimum operations required to convert $S1 into $S2. The operations can be insert, remove or replace a character. Please check out Wikipedia page for more information.

Example 1:

Input: $S1 = "kitten"; $S2 = "sitting"
Output: 3

Operation 1: replace 'k' with 's'
Operation 2: replace 'e' with 'i'
Operation 3: insert 'g' at the end

Example 2:

Input: $S1 = "sunday"; $S2 = "monday"
Output: 2

Operation 1: replace 's' with 'm'
Operation 2: replace 'u' with 'o'

In computer science, edit distance is a way of quantifying how dissimilar two strings (e.g., words) are to one another by counting the minimum number of operations (usually single character edits) required to transform one string into the other. When the operations permettied are insertion, deletion, or substitution of a character, edit distance is usually called Levenshtein distance, named after the Soviet mathematician Vladimir Levenshtein.

The Levenshtein distance between two strings a, b (of length |a| and |b| respectively) is given by lev ⁡ (*a*, *b*) where

levenstein_dist.jpg

where the tail of some string x is a string of all but the first character of x and *x*[*n*] is the nth character of the string x, starting with character 0.

Note that, in the above formula, the first element in the minimum corresponds to deletion, the second to insertion and the third to replacement.

This definition can lead directly to a naïve recursive implementation. The problem, though, is that such naïve implementation would have an exponential time complexity and would unusable even for moderately large strings (especially if the strings are markedly different). As an example, the naïve (not optimized) version of the Raku recursive subroutine implementation presented below for the pseudo random strings “LMIjkHFSAE” and “dmqkdjfERZG” takes more than one minute:

$ time raku edit-distance.raku
11 LMIjkHFSAE - dmqkdjfERZG
-
real    1m15,592s
user    0m0,015s
sys     0m0,046s

The reason for that is that the recursive subroutine is called many times with the same input in the process. If we can cache (or memoize) the results to avoid having to recompute again and again the same result, then the time to compute the Levenshtein distance falls dramatically and becomes roughly proportional to the product of the two string lengths. This still makes the process quite inefficient for very long strings (such as DNA strands), but it’s usually OK for strings representing words in common human languages.

The recursive approach is a form of top-down dynamic programming, i.e. it breaks a large problem into smaller and smaller subproblems, until the subproblems can be solved. Other solutions use bottom-up dynamic programming, i.e. start from small elementary problems and expand them to larger problems; they often use a matrix or table and iterate over the matrix to expand it. The bottom-up approach also as a time complexity roughly proportional to the product of the two string lengths. So, while the two approaches may not be equivalent (the bottom-up approach is likely to be faster), they have the same time complexity, which means that they essentially scale up essentially the same way when the size of the strings increase. Here, we will use the recursive (top-down) approach.

Note that our implementations will work the other way around, from right to left. The only reason for this is that I had written about four years ago an edit-distance program in Perl, and I found it easier to start from that implementation.

Edit Discance in Raku

We present two implementations of a cached implementation of the recursive solution.

Memoized Version (Raku)

First, we implement a “naïve” edit-distance recursive function and use the Raku Memoize module (written by my friend Elizabeth Mattijsen as a port of Mark-Jason Dominus’s equivalent Perl module) to automatically perform the caching of already computed distances:

use v6;
use Memoize;

sub edit-distance (Str $left, Str $right) {
    # If one of the substrings is empty, return the length of the other
    return $right.chars unless $left;
    return $left.chars unless $right;
    my $shortened-left  = substr $left,  0, *-1;
    my $shortened-right = substr $right, 0, *-1;

    # If the last chars are the same, we ignore them
    # and call edit-distance on shortened strings    
    return edit-distance $shortened-left, $shortened-right 
        if substr($left, *-1) eq substr($right, *-1);

    # Else find the minimum between the three operations
    return 1 + min(
        edit-distance($left,       $shortened-right), #insert
        edit-distance($shortened-left,  $right),      #remove
        edit-distance($shortened-left,  $shortened-right)  #replace
    );
}    

memoize("edit-distance");

my @test-pairs = (
    [ < kitten sitting >],
    [ < Monday Friday > ],
    [ < Sunday Saturday > ],
    [ < January February > ],
    [ < November December > ],
    [ < constitutionally anticonstitutional > ],
    [ < LMIjkHFSAE dmqkdjfERZG >],
);
for @test-pairs -> @test {
    my ($str1, $str2) = @test;
    print edit-distance($str1, $str2), " $str1 - $str2\n";
}

This program produces the following output:

$ time raku edit-distance.raku
3 kitten - sitting
3 Monday - Friday
3 Sunday - Saturday
4 January - February
3 November - December
6 constitutionally - anticonstitutional
11 LMIjkHFSAE - dmqkdjfERZG
-
real    0m1,452s
user    0m0,015s
sys     0m0,046s

Note how much faster this program is (1.45 seconds for 8 tests), compared to the non-optimized version with only the last test discussed above (about 1 min 15 sec for only one string pair).

Implementing A Cache Manually in Raku

I have often said that I eschew using off-the-shelf modules in the context of a programming challenge because I feel that it is sort of cheating. In the case of the above solution, I used the Memoize module because it wasn’t really part of the Levenshtein distance algorithm, but only a performance optimization. In that case in point, however, that performance optimization is crucial (making the difference between a usable and a not usable implementation), so that I feel it is necessary to show a solution that implements the cache manually. This might be more useful for a beginner or a student wishing to understand how caching or memoizing works:

use v6;

my %cache;

sub edit-distance (Str $left, Str $right) {
    sub cache-distance (Str $l, Str $r) {
        %cache{"$l;$r"} = edit-distance($l, $r) unless %cache{"$l;$r"}:exists;
        return %cache{"$l;$r"};
    }

    # If one of the substrings is empty, return the length of the other
    return $right.chars unless $left;
    return $left.chars unless $right;
    my $shortened-left  = substr $left,  0, *-1;
    my $shortened-right = substr $right, 0, *-1;
    # say " $shortened-left  $shortened-right";

    # If the last chars are the same, we ignore them
    # and call edit-distance on shortened strings
    if substr($left, *-1) eq substr($right, *-1) { 
        return cache-distance $shortened-left, $shortened-right;
    }

    # Else find the minimum between the three operations
    return 1 + min(
        cache-distance($left,       $shortened-right), #insert
        cache-distance($shortened-left,  $right),      #remove
        cache-distance($shortened-left, $shortened-right)  #replace
    );
}    

my @test-pairs = (
    [ < kitten sitting >],
    [ < Monday Friday > ],
    [ < Sunday Saturday > ],
    [ < January February > ],
    [ < November December > ],
    [ < constitutionally anticonstitutional > ],
    [ < LMIjkHFSAE dmqkdjfERZG >],
);
for @test-pairs -> @test {
    my ($str1, $str2) = @test;
    print edit-distance($str1, $str2), " $str1 - $str2\n";
}

Note that I have implemented the cache management as a separate lexically-scoped subroutine, cache-distance, because there were four recursive calls to edit-distance in the body of the edit-distance and I did not want to implement the cache management code four times.

This script displays the following output:

$ time raku edit-distance_cache.raku
3 kitten - sitting
3 Monday - Friday
3 Sunday - Saturday
4 January - February
3 November - December
6 constitutionally - anticonstitutional
11 LMIjkHFSAE - dmqkdjfERZG

real    0m0,398s
user    0m0,015s
sys     0m0,031s

We see another significant performance improvement, probably because it is more efficient to tailor a cache for a specific problem, compared to a general solution such as using the Memoize module (and perhaps also because it takes some time to compile the module, not quite sure).

Edit Distance in Perl

Memoized Version (Perl)

First, we implement a “naïve” edit-distance recursive function and use the core Perl Memoize module (written by Mark-Jason Dominus) to automatically perform the caching of already computed distances:

use strict;
use warnings;
use feature 'say';
use Memoize;

sub min {
    my $rv = shift;
    for my $tmp (@_) {
        $rv = $tmp if $tmp < $rv;
    }
    return $rv;
}

sub edit_distance {
    my ($left, $right) = @_;

    # If one of the substrings is empty, return the length of the other
    return length $right unless $left;
    return length $left  unless $right;

    my $shortened_left  = substr $left,  0, -1;
    my $shortened_right = substr $right, 0, -1;
    # In the last chars are the same, we ignore them
    # and call edit_distance on shortened strings
    return edit_distance ($shortened_left, $shortened_right) if substr($left, -1) eq substr($right, -1);

    # Else find the minimum between the three operations
    return 1 + min(
        edit_distance($left, $shortened_right), #insert
        edit_distance($shortened_left, $right), #remove
        edit_distance($shortened_left, $shortened_right) #replace
    );
}

memoize("edit_distance");

my @test_pairs = (
    [ qw<kitten sitting>],
    [ qw<Monday Friday> ],
    [ qw<Sunday Saturday> ],
    [ qw<January February> ],
    [ qw<November December > ],
    [ qw<constitutionally anticonstitutional > ],
    # [ qw<LMIjkHFSAE dmqkdjfERZG>],
);
for my $ar (@test_pairs) {
    my ($str1, $str2) = @$ar;
    say edit_distance($str1,$str2), " $str1 - $str2 ";
}

This program displays the following output and time measures:

$ time perl edit-distance.pl
3 kitten - sitting
3 Monday - Friday
3 Sunday - Saturday
4 January - February
3 November - December
6 constitutionally - anticonstitutional
11 LMIjkHFSAE - dmqkdjfERZG

real    0m0,103s
user    0m0,015s
sys     0m0,046s

Creating a Decorator in Perl

As I said before, I don’t like to use ready-made modules in programming challenges (which the reason why I also implemented myself the min subroutine). We could manually implement some form of wrapper around the naïve edit_distance subroutine, as we more or less did in Raku, to manage the cache. However, I thought it would be more fun to implement a decorator in order to modify the behavior of the edit_distance subroutine.

Originally, a decorator was a OO-programming design pattern making it possible to assign new properties or responsibilities to an object, without modifying that object’s class. The idea has later been expanded to other programming models. For example, PEP 318 in Python introduced decorators as functions that are designed to change the behavior of other functions without modifying the code of these other functions. This may be useful, for example, to modify the behavior of a legacy or complex function that you don’t want to change, or to modify in some specific case the behavior of a module that you otherwise don’t want to change because other programs may be using that module. It is this extended meaning of decorators that we mean here. So, let’s assume we don’t want to modify the code of our edit_distance subroutine (perhaps it’s complicated and I spent so much time debugging it that I want to leave it alone). Rather than changing the code of that subroutine, we will decorate it to add to it the caching functionality.

Contrary to Python, Perl doesn’t have a specific syntax for decorators, but, as we will see, it is relatively easy to use higher-order functions and typeglobs to implement our own decorators.

First, we define a decorate subroutine which takes as input parameter a reference to the subroutine to be cached and returns an anonymous subroutine that checks the cache and returns the value in the cache if it exists, and else calls the subref it has received as a parameter:

sub decorate {
    my $coderef = shift;  # the argument is a ref to edit_distance
    my %cache;
    return sub {
        my ($l, $r) = @_;
        $cache{"$l;$r"} = $coderef->(@_) unless exists $cache{"$l;$r"};
        return $cache{"$l;$r"};
    }
}

Note that we define the %cache in the decorate subroutine. The anonymous subroutine thus acts as a closure and keeps its access to the cache.

Then, we replace the original edit_distance subroutine with the anonymous subroutine returned by decorate in the main symbol table:

{
    # local scope for the deactivation of the redefine warning
    no warnings 'redefine';
    # we replace the edit-distance subroutine by its 
    # decorated version in the main symbol table
    *main::edit_distance = decorate(\&edit_distance);
}

Here, *main::edit_distance is a typeglob representing the entry of the original edit_distance subroutine in the symbol table. Before that, we deactivate the redefine warning (to avoid a warning upon the subroutine definition, and we do that in a code block to limit the scope of the deactivation to this code line.

Now, whenever the code will call the edit_distance subroutine, it is the anonymous subroutine produced by the decorate subroutine that will be called instead. Thus, the edit_distance subroutine seen by the rest of the program is now memoized (the edit distances are cached), although we did not change anything to the code defining it. That subroutine is called recursively four times in its own code, but we don’t need to charge all these subroutine calls.

The overall program now looks like this:

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

sub min {
    my $rv = shift;
    for my $tmp (@_) {
        $rv = $tmp if $tmp < $rv;
    }
    return $rv;
}

sub edit_distance {
    my ($left, $right) = @_;

    # If one of the substrings is empty, return the length of the other
    return length $right unless $left;
    return length $left  unless $right;

    my $shortened_left  = substr $left,  0, -1;
    my $shortened_right = substr $right, 0, -1;
    # In the last chars are the same, we ignore them
    # and call edit_distance on shortened strings
    return edit_distance ($shortened_left, $shortened_right) if substr($left, -1) eq substr($right, -1);

    # Else find the minimum between the three operations
    return 1 + min(
        edit_distance($left, $shortened_right), #insert
        edit_distance($shortened_left, $right), #remove
        edit_distance($shortened_left, $shortened_right) #replace
    );
}

# The decorator returns the edit_distance subroutine wrapped in 
# code lines performing the caching of values
sub decorate {
    my $coderef = shift;
    my %cache;
    return sub {
        my ($l, $r) = @_;
        $cache{"$l;$r"} = $coderef->(@_) unless exists $cache{"$l;$r"};
        return $cache{"$l;$r"};
    }
}

{
    # local scope for the deactivation of the redefine warning
    no warnings 'redefine';
    # we replace the edit-distance subrouytine by its 
    # decorated version in the main symbol table
    *main::edit_distance = decorate(\&edit_distance);
}

my @test_pairs = (
    [ qw<kitten sitting> ],
    [ qw<Monday Friday> ],
    [ qw<Sunday Saturday> ],
    [ qw<January February> ],
    [ qw<November December > ],
    [ qw<constitutionally anticonstitutional > ],
    [ qw<LMIjkHFSAE dmqkdjfERZG>],
);
for my $ar (@test_pairs) {
    my ($str1, $str2) = @$ar;
    say edit_distance($str1,$str2), " $str1 - $str2 ";
}

This script produces the following output and execution times:

$ time perl  edit-distance_decorator.pl
3 kitten - sitting
3 Monday - Friday
3 Sunday - Saturday
4 January - February
3 November - December
6 constitutionally - anticonstitutional
11 LMIjkHFSAE - dmqkdjfERZG

real    0m0,064s
user    0m0,000s
sys     0m0,046s

Note that our manually decorated subroutine is slightly faster that the original memoized version.

Edit Distance in Python

I do not know whether there is something equivalent to the Memoize module in Python, so I will manage the cache manually (in the cached_distance subroutine):

cache = dict()

def cached_distance(left, right):
    key = left + ';' + right
    if key not in cache:
        cache[key] = edit_distance(left, right)  
    return cache[key]

def edit_distance(left, right):
    lr = len(right)
    ll = len(left)
    if not left: return lr
    if not right: return ll
    shortened_l = left[0:ll-1]
    shortened_r = right[0:lr-1]
    if left[ll-1] == right[lr-1]:
        return cached_distance(shortened_l, shortened_r)

    return 1 + min( cached_distance(left, shortened_r),     # Insert 
                    cached_distance(shortened_l, right),    # Remove 
                    cached_distance(shortened_l, shortened_r)  # Replace 
                  )     

tests = ( [ "kitten", "sitting" ], [ "Monday", "Friday" ], 
          [ "Sunday", "Saturday" ], [ "January", "February" ],
          [ "November", "December" ],
          [ "constitutionally", "anticonstitutional" ],
        )

for test in tests:
    print (test[0], test[1], edit_distance(test[0], test[1]  ))

This produces the following output:

$ time python3 edit-distance.py
kitten sitting 3
Monday Friday 3
Sunday Saturday 3
January February 4
November December 3
constitutionally anticonstitutional 6

real    0m0,114s
user    0m0,000s
sys     0m0,062s

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

Perl Weekly Challenge 95: Palindrome Numbers and Demo Stack

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

Spoiler Alert: This weekly challenge deadline is due in a few of days (January 17, 2021). 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: Palindrome Numbers

You are given a number $N.

Write a script to figure out if the given number is Palindrome. Print 1 if true otherwise 0.

Example 1:

Input: 1221
Output: 1

Example 2:

Input: -101
Output: 0, since -101 and 101- are not the same.

Example 3:

Input: 90
Output: 0

A palindrome is a word, number, phrase, or other sequence of characters which reads the same backward as forward, like “noon”, “madam”, or “redivider”.

Palindrome Numbers in Raku

This is fairly simple. We just compare the input with its reversed version:

use v6;

my $num = @*ARGS[0] // 1221;
say "$num: ", +($num eq $num.flip);

Note that the + sign in the second code line is aimed at numifying the value of the Boolean expression $num eq $num.flip (False or True) into 0 or 1.

This is the output with a few input values:

$ raku palindrome.raku
1221: 1

$ raku palindrome.raku 7337
7337: 1

$ raku palindrome.raku 8765
8765: 0

$ raku palindrome.raku -1221
-1221: 0

This is so simple that we can also do it as a one-liner script:

$ raku -e 'my $n = @*ARGS[0]; say "$n: ", +($n eq $n.flip);' 7337
7337: 1

Palindrome Numbers in Perl

Again, we just compare the input with its reversed version:

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

my $num = shift // 1221;
say "$num: ", $num eq (reverse $num) ? 1 : 0;

This is the output with a few input values:

$ perl palindrome.pl
1221: 1

$ perl palindrome.pl 7337
7337: 1

$ perl palindrome.pl 5678
5678: 0

$ perl palindrome.pl -101
-101: 0

We can also do a Perl one-liner:

$ perl -E '$n = shift; say "$n: ", $n eq (reverse $n) ? 1 : 0;' 1221
1221: 1

Palindrome Numbers in Scala

The Scala version uses essentially the same idea:

object Main {
  def main(args: Array[String]): Unit = {
    val num = args(0).toString
    if (num == num.reverse) {
      println(1)
    } else {
      println(0)
    }
  }
}

This Scala program produces the same results as the above Raku and Perl programs.

Task 2: Demo Stack

Write a script to demonstrate Stack operations like below:

push($n) - add $n to the stack
pop() - remove the top element
top() - get the top element
min() - return the minimum element

Example:

my $stack = Stack->new;
$stack->push(2);
$stack->push(-1);
$stack->push(0);
$stack->pop;       # removes 0
print $stack->top; # prints -1
$stack->push(0);
print $stack->min; # prints -1

There are already push and pop built-in functions in both Raku and Perl, so we will give our stack operations different names. The stack will be implemented as a simple array with the relevant stack operations.

Demo Stack in Raku

Functional Implementation

Implementing a stack is typical of a job for object-oriented programming. However, I will start with a more functional approach (as I prefer that). The push and pop stack operations are renamed put-in-stack and take-from-stack:

use v6;

sub put-in-stack (@stack, *@new-items) {
    push @stack, |@new-items;
}
sub take-from-stack (@stack where @stack.elems > 0) {
    return pop @stack;
}
sub top (@stack where @stack.elems > 0) {
    return @stack.tail;
}
sub minimum (@stack where @stack.elems > 0) {
    return @stack.min;
}
my @a-stack = 1..5;
say @a-stack;
put-in-stack @a-stack, 6..8;
say @a-stack;
say "Min: ", minimum @a-stack; 
say "Top: ", top @a-stack;
say "Take: ", take-from-stack @a-stack;
say @a-stack;

This displays the following output:

$ raku stack_oo.raku
[1 2 3 4 5]
[1 2 3 4 5 6 7 8]
Min: 1
Top: 8
Take: 8
[1 2 3 4 5 6 7]

Object-Oriented Implementation

If you prefer an object-oriented version, it could look like this:

use v6;

class Stack {
    has @.stack is rw;
    method is-empty {
        @!stack.elems > 0 ?? False !! True;
    }
    method put-in-stack (*@new-items) {
        push @!stack, |@new-items;
    }
    method take-from-stack {
        return pop @!stack;
    }
    method top {
        return @!stack.tail;
    }
    method minimum {
        return @!stack.min;
    }
}
my $a-stack = Stack.new( stack => 1..5);
say $a-stack.stack;
$a-stack.put-in-stack: 6..8;
say $a-stack.stack;
say "Min: ", $a-stack.minimum; 
say "Top: ", $a-stack.top;
say "Take: ", $a-stack.take-from-stack ;
say $a-stack.stack;

The code using the Stack class should really check that the stack is not empty (with the is-empty method) before calling the take-from-stack, top, or minimum methods to avoid an unhandled exception, and we may in that case raise an ad-hoc exception or print an error message or do something else, but since we have no specification on what to do in such a case, this is left as an exercise to the reader.

Output:

$ raku  stack_oo.raku
[1 2 3 4 5]
[1 2 3 4 5 6 7 8]
Min: 1
Top: 8
Take: 8
[1 2 3 4 5 6 7]

Demo Stack in Perl

In Perl, we will implement only the functional version:

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

sub is_empty {
    my $stack = shift;
    return @$stack > 0 ? 0 : 1;
}

sub put_in_stack {
    my ($stack, @new_items) = @_;
    push @$stack, @new_items;
}
sub take_from_stack  {
    my $stack = shift;
    return undef if is_empty $stack;
    return pop @$stack;
}
sub top {
    my $stack = shift;
    return undef if is_empty $stack;
    return $stack->[-1];
}
sub minimum {  # assuming stack of numeric values
    my $stack = shift;
    return undef if is_empty $stack;
    my $min = $stack->[0];
    for my $item (@$stack) {
        $min = $item if $item < $min;
    }
    return $min;
}
my $a_stack = [1..5];
say "@$a_stack";
put_in_stack $a_stack, 6..8;
say "@$a_stack";
say "Min: ", minimum $a_stack; 
say "Top: ", top $a_stack;
say "Take: ", take_from_stack $a_stack;
say "@$a_stack";

This displays the following output:

$ perl stack.pl
1 2 3 4 5
1 2 3 4 5 6 7 8
Min: 1
Top: 8
Take: 8
1 2 3 4 5 6 7

Demo Stack in Scala

Being a beginner in Scala, I don’t yet master passing function parameters by value or by reference. So I’ll make my stack a global variable to enable in-place modification. You don’t need to tell me it’s bad, I know. At this point, I’m only trying to make a program that works properly, I’ll hopefully implement better practices and write more idiomatic Scala code in a few months from now.

object stack extends App {
  var stack = Array(1, 2, 3, 4, 5)
  print_stack("Original stack") 
  push(Array(6, 7, 8))
  print_stack("Pushed stack")
  val popped = pop
  println(s"Popped: $popped")
  print_stack("Popped stack")
  val topped = top
  println(s"Top: $topped")
  val minimum = min
  println(s"Min: $minimum")
  def print_stack(caption: String) : Unit = {
    print(s"$caption: "); println( stack.mkString(" "))
  }
  def push(newItems: Array[Int]): Unit = {
    stack ++= newItems
  }
  def pop: Int = {
    val lastItem = stack.last
    stack = stack.dropRight(1)
    return lastItem
  }
  def top: Int = {
    return stack.last
  }
  def min: Int = {
    var min = stack(0);
    for (i <- 1 to (stack.length - 1)) {
      if (stack(i) < min) min = stack(i)
    }
    return min
  }
}

This displays the following output:

Original stack: 1 2 3 4 5
Pushed stack: 1 2 3 4 5 6 7 8
Popped: 8
Popped stack: 1 2 3 4 5 6 7
Top: 7
Min: 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 Sunday, January 17, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 94: Group Anagrams and Binary Tree to Linked List

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

Spoiler Alert: This weekly challenge deadline is due in a few of days (January 10, 2021). 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: Group Anagrams

You are given an array of strings @S.

Write a script to group Anagrams together in any random order.

An Anagram is a word or phrase formed by rearranging the letters of a different word or phrase, typically using all the original letters exactly once.

Example 1:

Input: ("opt", "bat", "saw", "tab", "pot", "top", "was")
Output: [ ("bat", "tab"),
          ("saw", "was"),
          ("top", "pot", "opt") ]

Example 2:

Input: ("x")
Output: [ ("x") ]

We want to avoid testing all possible letter permutations in two nested loops, as this would scale badly for larger input. The idea is to normalize input data, i.e. to find a common pattern to all anagram groups. A simple way to do that is to sort the letters of each word and to store the result in a hash with a key made of the sorted letters and a value containing the list of corresponding words.

Group Anagrams in Raku

In this program, the %words hash keys are the normalized (sorted letters) words and the values are the list of words having the same normalized version.

use v6;

my @test = @*ARGS.elems > 0 ?? @*ARGS !! < tops opt bat pots saw tab pot top stop opts was x>;

my %words;
for @test -> $w {
    push %words, ([~] $w.comb.sort), $w;
}
for keys %words -> $k {
    say '[' ~ "%words{$k}" ~ ']';
}

With the default input values, this program displays the following output:

$ raku anagrams.raku
[bat tab]
[opt pot top]
[tops pots stop opts]
[saw was]
[x]

And this is an example passing the list of words as parameters to the command line:

$ raku anagrams.raku opt bat pots saw tab pot top stop opts
[opt pot top]
[saw]
[bat tab]
[pots stop opts]

Group Anagrams in Perl

This is a port to Perl of the Raku program. The %words hash keys are the normalized (sorted letters) words and the values are the list of words having the same normalized version.

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

my @test = @ARGV > 0 ? @ARGV : qw < tops opt bat pots saw tab pot top stop opts was x>;

my %words;
for my $w (@test) {
    my $normalized = join "", sort split //, $w;
    push @{$words{$normalized}}, $w;
}
for my $k (keys %words) {
    say '[' . "@{$words{$k}}" . ']';
}

With the default input values, this displays the same output as the Raku program (except for the pseudo-random order of the lines):

$ perl anagrams.pl
[x]
[opt pot top]
[tops pots stop opts]
[bat tab]
[saw was]

The program can also work on parameters passed to it:

$ perl anagrams.pl tops opt bat pots saw tab pot top  was x
[tops pots]
[opt pot top]
[bat tab]
[saw was]
[x]

Group Anagrams in Scala

This is a port to Scala of the Raku or Perl program. The words map keys are the normalized (sorted letters) words and the values are the list of words having the same normalized version.

import scala.collection.mutable.Map
object anagrams extends App {
  val test =
    List("opt", "bat", "saw", "tab", "pot", "top", "was", "x")
  var words = Map.empty[String, Array[String]];
  for (word <- test) {
    val normalized = word.split("").sorted.mkString("")
    if (words contains normalized) {
      words(normalized) :+= word
    } else {
      words += (normalized -> Array(word))
    }
  }
  for (key <- words.keys) {
    println ("[" + words(key).mkString(" ") + "]")
  }
}

This program displays the following output:

[bat tab]
[opt pot top]
[saw was]
[x]

Task 2: Binary Tree to Linked List

You are given a binary tree.

Write a script to represent the given binary tree as an object and flatten it to a linked list object. Finally print the linked list object.

Example:

Input:

    1
   / \
  2   3
 / \
4   5
   / \
  6   7

Output:

    1 -> 2 -> 4 -> 5 -> 6 -> 7 -> 3

As I said already in the context of earlier Perl Weekly Challenges, I do not see any good reason to implement linked lists in Raku or in Perl, as the arrays in these languages natively provide support to most of the functionalities usually associated with linked lists. Actually, I even suspect that Perl and Raku arrays are in fact implemented as some form of linked list behind the scene. Having said that, I’ll nonetheless play by the rules of the task and implement a linked list.

For implementing binary trees and linked lists, it would make sense to define classes and use OO-programming. However, the requirement is quite simple and I feel that a full-fledged OO-program would be technological overkill. So I preferred to do it in a more functional way.

For all three implementations in Raku, Perl, and Scala below, we’ll use 3 trees for our test cases:

     1
    /
   2
  / \
 3   4

      1
    / \
   2   3
  /   / \
 4   5   6

      5
     / \
    4   8
   /   / \
  3    2  9
 /  \      \
7    2      1

Binary Tree to Linked List in Raku

For various reasons, it turned out to be simpler to flatten the tree into an array (flatten-it subroutine), and we could have just printed the array. But since the task asks us transform the tree into a linked list, I used the flat array to manufacture a linked list (list-to-linked-list subroutine). Then, we use the flatten-it subroutine once more to produce from the linked list the flat list to be printed out.

use v6;

my @tests = [1, [2, [3,], [4,]]], 
            [1, [2, [4,]], [3, [5], [6]]],
            [5, [4, [3, [7], [2]]], [8, [2], [9, [1]]]];

for @tests -> @tree {
    say @tree;
    my @flat-tree = flatten-it @tree;
    say "Flat tree", @flat-tree;
    my $ll-root = list-to-linked-list @flat-tree;
    say "Linked list: ", $ll-root;
    say "Flat linked list: ", flatten-it($ll-root), "\n";
}
sub flatten-it (@node)  {
    sub dfs (@node) {
        push @*flat-list, @node[0];
        dfs(@node[1]) if defined @node[1];
        dfs(@node[2]) if defined @node[2];
    }
    my @*flat-list;
    dfs @node;
    return @*flat-list
}   
sub list-to-linked-list (@list is copy) {
    my $last = pop @list;
    my $current = [$last, ];
    for @list.reverse -> $item {
        $current = [$item, $current];
    }
    return $current;
}

This program displays the following output:

$ raku bin-tree-2-list.raku
[1 [2 [3] [4]]]
Flat tree[1 2 3 4]
Linked list: [1 [2 [3 [4]]]]
Flat linked list: [1 2 3 4]

[1 [2 [4]] [3 [5] [6]]]
Flat tree[1 2 4 3 5 6]
Linked list: [1 [2 [4 [3 [5 [6]]]]]]
Flat linked list: [1 2 4 3 5 6]

[5 [4 [3 [7] [2]]] [8 [2] [9 [1]]]]
Flat tree[5 4 3 7 2 8 2 9 1]
Linked list: [5 [4 [3 [7 [2 [8 [2 [9 [1]]]]]]]]]
Flat linked list: [5 4 3 7 2 8 2 9 1]

Binary Tree to Linked List in Perl

As for the Raku program, it is simpler to flatten the tree into an array (flatten_it subroutine), and we could have just printed the array. But since the task asks us transform the tree into a linked list, I used the flat array to manufacture a linked list (list_to_linked_list subroutine). Then, we use the flatten-it subroutine once more to produce the flat list to be printed out.

To represent the binary tree and the linked list, I used the Data::Dumper module. However, in the code below, I commented out the two code lines using Dumper to reduce the size of the output.

For the first tree example, the binary tree gets displayed as follows;

$VAR1 = 1;
$VAR2 = [
          2,
          [
            3
          ],
          [
            4
          ]
        ];

and the linked list like so:

      1,
      [
        2,
        [
          3,
          [
            4
          ]
        ]
      ]
    ];

Please uncomment these two commented-out print statements if you want to see these data structures for the other two examples.

The code is as follows:

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

my @tests = ( [1, [2, [3,], [4,]]], 
              [1, [2, [4,]], [3, [5], [6, ]]],
              [5, [4, [3, [7], [2]]], [8, [2], [9, [1]]]]
            );
my @flat_list;
for my $tree (@tests) {
    # say Dumper @$tree;
    my @flat_tree = flatten_it($tree);
    say "Flat tree; @flat_tree";
    my $ll_root = list_to_linked_list(@flat_tree);
    # say "Linked list: ", Dumper $ll_root;
    my @flatten_ll = flatten_it($ll_root);
    say "Flat linked list: @flatten_ll \n";
}
sub flatten_it {
    my $node = shift;
    @flat_list = ();
    dfs($node);
    return @flat_list
}
sub dfs {
    my $node = shift;
    push @flat_list, $node->[0];
    dfs($node->[1]) if defined $node->[1];
    dfs($node->[2]) if defined $node->[2];
}   
sub list_to_linked_list {
    my @list = @_;
    my $last = pop @list;
    my $current = [$last, ];
    for my $item (reverse @list) {
        $current = [$item, $current];
    }
    return $current;
}

The program displays the following output:

Flat tree; 1 2 3 4
Flat linked list: 1 2 3 4

Flat tree; 1 2 4 3 5 6
Flat linked list: 1 2 4 3 5 6

Flat tree; 5 4 3 7 2 8 2 9 1
Flat linked list: 5 4 3 7 2 8 2 9 1

Binary Tree to Linked List in Scala

As I said in previous PWC blogs, I am a beginner in Scala and I am not yet really able to figure out alone how to deal with composite data structures. Part of the code below (especially the code of the dfs function and nested loop function) has been found on the Internet.

import scala.collection.mutable.Queue

object tree2List extends App {
  case class Tree[T](value: T, children: List[Tree[T]])
  val tests = List(
    Tree(1, List(Tree(2, List(Tree(3, Nil), Tree(4, Nil))))),
    Tree(
      1,
      List(
        Tree(2, List(Tree(4, Nil))),
        Tree(3, List(Tree(5, Nil), Tree(6, Nil)))
      )
    ),
    Tree(
      5,
      List(
        Tree(4, 
          List(Tree(3, List(Tree(7, Nil), Tree(2, Nil))))),
        Tree(8, 
          List(Tree(2, Nil), Tree(9, List(Tree(1, Nil)))))
      )
    )
  )

  def dfs[T, S](tree: Tree[T], f: T => S): Queue[S] = {
    def loop(g: Tree[T], output: Queue[S]): Queue[S] = g match {
      case Tree(v, c) =>
        c.foldLeft(output.enqueue(f(v))) { case (acc, n) => loop(n, acc) }
    }
    loop(tree, Queue.empty[S])
  }

  for (tree <- tests) {
    val traversal = dfs(tree, identity[Int])
    println(traversal.mkString(", "))
  }
}

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

Perl Weekly Challenge 93: Max Points and Sum Path

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

Spoiler Alert: This weekly challenge deadline is due in a day or so. 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: Max Points

You are given set of co-ordinates @N.

Write a script to count maximum points on a straight line when given co-ordinates plotted on 2-d plane.

Example 1:

|
|     x
|   x
| x
+ _ _ _ _

Input: (1,1), (2,2), (3,3)
Output: 3

Example 2:

|
|
| x       x
|   x
| x   x
+ _ _ _ _ _

Input: (1,1), (2,2), (3,1), (1,3), (5,3)
Output: 3

From the examples provided, it appears that the given co-ordinates will be integers, that the points of a straight line have to be immediate neighbors and that the lines can only be horizontal, vertical or diagonal. Because of that, I will not try to solve the task with math formulas, as it is somewhat impractical to deal with integers in geometric equations. Also, representing a vertical line with a math equation is a mess.

Max Points in Raku

With such a type of problem, the first thing I usually want to do is to make a graphical representation of the point cloud, so that I can visually verify the test results. This is done in the following display-points subroutine:

sub display-points (@points) {
    my @sorted = reverse sort 
        { $^a[0] <=> $^b[0] || $^b[1] <=> $^a[1] }, 
        map { $_.reverse }, @points;
    my $current = (@sorted.max({$_[0]}))[0];
    my $max_length = (@sorted.max({$_[1]}))[1];
    my $line = "";
    my $pos = 0;
    for @sorted -> $item {
        if $item[0] < $current {
            say $line;
            $pos = 0;
            $line = "";
            $current--;
        }
        while $item[0] < $current {
            say "$current |"; 
            $current--;
        }
        $line = "$current |" and $pos = 0 if $line eq "";
        $line ~=  " " x ~ ($item[1] - $pos - 1) ~ "x";
        $pos = $item[1];        
    }
    say $line;
    while $current-- > 0 { say "$current |" }; 
    say "_" x ($max_length + 3), "\n";
}

With the following set of points:

(1,1), (2,2), (5,2), (3,3), (3,1), (2,7);

the procedure first reverse sorts the points as well as their individual coordinates:

[(7 2) (3 3) (2 2) (2 5) (1 1) (1 3)]

This is the output of this subroutine:

7 | x
6 |
5 |
4 |
3 |  x
2 | x  x
1 |x x
0 |
________

For finding the alignments, I used a dispatch table (%directions) defining four directions in which to move in order to find the next point: North, North-East, East, and South-East (the other four directions are just symmetric and are not necessary, since we will look for straight lines starting from every point in the set. We also build a %point-hash hash to store all points in the form of a string containing the abscissa and ordinate of every point (separated by a semi-colon). Then we loop over every point in the data set and loop over each of the four directions, and find in the hash whether there is a new point in that direction. We count the number of points found in that direction and keep track of the maximum count ($max-count).

sub find-alignments (@points) {
    my %directions = (
        N  => { $^a, $^b + 1 },
        NE => { $^a + 1, $^b + 1 },
        E  => { $^a + 1, $^b },
        SE => { $^a + 1, $^b - 1 }
    );
    my %point-hash = map { "$_[0];$_[1]" => True }, @points;
    my $max-count = 0;
    for @points -> $point {
        for %directions.keys -> $dir {
            my $count = 1;
            my $p = %directions{$dir}(|$point);
            while %point-hash{"$p[0];$p[1]"} {
                $p = %directions{$dir}(|$p);
                $count++;
            }
            $max-count = $count if $count > $max-count;
        }
    }
    say "Count: $max-count \n\n";          
}

Note that the code to find the alignments (i.e. to actually solve the task) contains only 22 code lines, and is thus shorter that the code to display the points (but it may be argued that it uses slightly more advanced techniques).

This is the full program:

use v6;

my @tests = ((1,1), (2,2), (5, 5), (5,2), (3,3), (3,1), (2,7), (4, 4)), 
            ((1,1), (2,2), (3,1), (1,3), (5,3)),
            ((1,1), (4,2), (1,3), (2,2), (1,2), (5,1), (1,4));
for @tests -> @points {
    display-points(@points);
    find-alignments(@points);
}

sub display-points (@points) {
    my @sorted = reverse sort 
        { $^a[0] <=> $^b[0] || $^b[1] <=> $^a[1] }, 
        map { $_.reverse }, @points;
    my $current = (@sorted.max({$_[0]}))[0];
    my $max_length = (@sorted.max({$_[1]}))[1];
    my $line = "";
    my $pos = 0;
    for @sorted -> $item {
        if $item[0] < $current {
            say $line;
            $pos = 0;
            $line = "";
            $current--;
        }
        while $item[0] < $current {
            say "$current |"; 
            $current--;
        }
        $line = "$current |" and $pos = 0 if $line eq "";
        $line ~=  " " x ~ ($item[1] - $pos - 1) ~ "x";
        $pos = $item[1];        
    }
    say $line;
    while $current-- > 0 { say "$current |" }; 
    say "_" x ($max_length + 3), "\n";
}

sub find-alignments (@points) {
    my %directions = (
        N  => { $^a, $^b + 1 },
        NE => { $^a + 1, $^b + 1 },
        E  => { $^a + 1, $^b },
        SE => { $^a + 1, $^b - 1 }
    );
    my %point-hash = map { "$_[0];$_[1]" => True }, @points;
    my $max-count = 0;
    for @points -> $point {
        for %directions.keys -> $dir {
            my $count = 1;
            my $p = %directions{$dir}(|$point);
            while %point-hash{"$p[0];$p[1]"} {
                $p = %directions{$dir}(|$p);
                 $count++;
            }
            $max-count = $count if $count > $max-count;
        }
    }
    say "Count: $max-count \n\n";          
}

This program displays the following output:

$ raku max-points.raku
7 | x
6 |
5 |    x
4 |   x
3 |  x
2 | x  x
1 |x x
0 |
________

Count: 5

3 |x   x
2 | x
1 |x x
0 |
________

Count: 3

4 |x
3 |x
2 |xx x
1 |x   x
0 |
________

Count: 4

Max Points in Perl

This is a port of the Raku program into Perl. Note that, for the sake of brevity, I will not show here the display_points subroutine as it is very similar to the equivalent code in Raku and is not very interesting. The test data sets are the same as in the Raku program, so you can look above to see the graphical representations of the point clouds. The find_alignments subroutine is similar to its counterpart in Raku and also uses a dispatch table with four directions in which to move to find the next point. Please refer to the Raku section above is you need additional explanations.

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

my @tests = ( [[1,1], [2,2], [5, 5], [5,2], [3,3], [3,1], [2,7], [4, 4]], 
              [[1,1], [2,2], [3,1], [1,3], [5,3]],
              [[1,1], [4,2], [1,3], [2,2], [1,2], [5,1], [1,4]],
            );
for my $point_set (@tests) {
    # display_points(@points);
    find_alignments(@$point_set);
}

sub find_alignments  {
    my @points = @_;
    my %directions = (
        N  => sub { $_[0]->[0]    ,  $_[0]->[1] + 1 },
        NE => sub { $_[0]->[0] + 1,  $_[0]->[1] + 1 },
        E  => sub { $_[0]->[0] + 1,  $_[0]->[1]     },
        SE => sub { $_[0]->[0] + 1,  $_[0]->[1] - 1 }
    );
    my %point_hash = map { my @a = @$_; "$$_[0];$$_[1]" => 1 } @points;
    my $max_count = 0;
    for my $point (@points) {
        for my $dir (keys %directions) {
            my $count = 1;
            my @p = $directions{$dir}->($point);
            while ($point_hash{"$p[0];$p[1]"}) {
                @p = $directions{$dir}->([@p]);
                $count++;
            }
            $max_count = $count if $count > $max_count;
        }
    }
    say  join " ", map { "(@{$_})" } @points;
    say "Count: $max_count \n";         
}

This program displays the following results:

$ perl  max-points.pl
(1 1) (2 2) (5 5) (5 2) (3 3) (3 1) (2 7) (4 4)
Count: 5

(1 1) (2 2) (3 1) (1 3) (5 3)
Count: 3

(1 1) (4 2) (1 3) (2 2) (1 2) (5 1) (1 4)
Count: 4

Task 2: Sum Path

You are given binary tree containing numbers 0-9 only.

Write a script to sum all possible paths from root to leaf.

Example 1:

Input:
     1
    /
   2
  / \
 3   4

Output: 13
as sum two paths (1->2->3) and (1->2->4)

Example 2:

Input:
     1
    / \
   2   3
  /   / \
 4   5   6

Output: 26
as sum three paths (1->2->4), (1->3->5) and (1->3->6)

Sum Path in Raku

For this task, I also used a display subroutine, which uses itself a bft (breadth-first traversal) recursive subroutine, but that’s not what was asked in the task and I have already covered that, so I’ll omit that from this post (see this blog post for an example), and only detail the dfs (depth-first search) recursive subroutine which does the work of going through all the path through the tree. The new-sum variable keep tasks of the total sum so far through the path and, when we reach a leaf (no subtree), we update the $*total-sum.

use v6;

my @tests = [1, [2, [3,], [4,]]], 
            [1, [2, [4,]], [3, [5], [6]]],
            [5, [4, [3, [7], [2]]], [8, [2], [9, [1]]]];

for @tests -> @tree {
    my $*total-sum = 0;
    say @tree;
    dfs(@tree, 0);
    say $*total-sum;
}

sub dfs (@node, $sum-so-far) {
    my $new-sum = $sum-so-far + @node[0];
    unless @node[1]:exists or @node[2]:exists {
        $*total-sum += $new-sum;
        return;
    }
    dfs(@node[1], $new-sum) 
        if defined @node[1];
    dfs(@node[2], $new-sum)
        if defined @node[2];
}

This produces the following output:

$ raku sum-path.raku
[1 [2 [3] [4]]]
13
[1 [2 [4]] [3 [5] [6]]]
26
[5 [4 [3 [7] [2]]] [8 [2] [9 [1]]]]
71

Sum Path in Perl

This is a port to Perl of the Raku program above, also with a dfs (depth-first search) recursive subroutine.

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

my @tests = ( [1, [2, [3,], [4,]]], 
              [1, [2, [4,]], [3, [5], [6, ]]],
              [5, [4, [3, [7], [2]]], [8, [2], [9, [1]]]]
            );
my $total_sum;
for my $tree (@tests) {
    $total_sum = 0;
    dfs($tree, 0);
    say $total_sum;
}

sub dfs {
    my ($node, $sum_so_far) = @_;
    my $new_sum = $sum_so_far + $node->[0];
    unless (exists $node->[1] or exists $node->[2]) {
        $total_sum += $new_sum;
        return;
    }
    dfs($node->[1], $new_sum) 
        if defined $node->[1];
    dfs($node->[2], $new_sum)
        if defined $node->[2];
}

This yields the same results as the Raku program:

$ perl sum-path.pl
13
26
71

Wrapping up

The next week Perl Weekly Challenge will start soon and will end next year, a year that we all hope will be better than this year. 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 Sunday, January 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.