Perl Weekly Challenge 116: Number Sequence and Sum of Squares

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (June 13, 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: Number Sequence

  • You are given a number $N >= 10.*

  • Write a script to split the given number such that the difference between two consecutive numbers is always 1 and it shouldn’t have leading 0.*

Print the given number if it impossible to split the number.

Example:

Input: $N = 1234
Output: 1,2,3,4

Input: $N = 91011
Output: 9,10,11

Input: $N = 10203
Output: 10203 as it is impossible to split satisfying the conditions.

Number Sequence in Raku

One way to see it is to say that we want to partition the digits of the input number in such a way that each partition (with one or several digits) is a number one more than the preceding one.

In Raku, my first idea was to use the combinations built-in method to generate the particions, but this turned out to be impractical. So I decided to use a completely different route: in Raku, the regex sub-language has an exhaustive (or ex for short) adverb which generate all possible matches between a string and the searches pattern. With this adverb and a pattern such as (\d+)+, we can generate all possible combinations of digits of an input number. This leads to the following program:

use v6;

sub num-seq (Int $in) {
    MATCH: for $in ~~ m:ex/^(\d+)+$/ -> $m {
        my @match = $m[0].map({~$_}); # stringify the match object
        next MATCH if @match.elems < 2; 
        for 1..@match.end -> $i {
            next MATCH if @match[$i] ~~ /^0/ or # remove a match starting with 0
                @match[$i] - @match[$i - 1] != 1;
        }
        return @match;
    }
    return $in
}

for <1234 91011 10203> -> $test {
    say join ', ', num-seq $test;
}

This program displays the following output:

raku ./num-seq.raku
1, 2, 3, 4
9, 10, 11
10203

Number Sequence in Perl

Perl regexes don’t have a functionality for exhaustive pattern matching. So our Perl solution will be entirely different.

We use a num_seq recursive subroutine to potentially generate all possible partitions, except that we don’t really generate all partitions, as we filter out early in the process beginnings of partitions that cannot yield a solution,

use strict;
use warnings;
use feature "say";
my $end_result;

sub num_seq {
    my $cur_val = shift; 
    my $result = shift;
    my @digits = @_;

    my $len = length $cur_val;
    return if scalar @digits < $len;
    $cur_val = $digits[0] - 1 unless $cur_val;
    for my $i ($len - 1 .. $#digits) {
        my $new_val = join "", @digits[0..$i];
        next if $new_val - $cur_val != 1 or $new_val =~ /^0/;
        push @{$result}, join "", @digits[0..$i];
        # say "@$result";
        if (scalar @digits > $len) {
            num_seq($new_val, $result, @digits[$i+1..$#digits]);
        } else {
            $end_result = $result;
            return;
        }
    }
}

for my $test (qw<1234 91011 10203>) {
    $end_result = "";
    num_seq 0, [], split "", $test;
    if ($end_result) { 
        say join ", ", @$end_result;
    } else {
        say $test;
    }
}

This script displays the following output:

$ perl  num-seq.pl
1, 2, 3, 4
9, 10, 11
10203

Task 2: Sum of Squares

You are given a number $N >= 10.

Write a script to find out if the given number $N is such that sum of squares of all digits is a perfect square. Print 1 if it is otherwise 0.

Example:

Input: $N = 34
Ouput: 1 as 3^2 + 4^2 => 9 + 16 => 25 => 5^2

Input: $N = 50
Output: 1 as 5^2 + 0^2 => 25 + 0 => 25 => 5^2

Input: $N = 52
Output: 0 as 5^2 + 2^2 => 25 + 4 => 29

Note that all multiples of ten until 100 satisfy the perfect square condition, as well as all multiples of 100 until 1000 (and so on). Also note that since 34 satisfies the condition, as shown in the example above, then its anagram 43 also does.

Sum of Squares in Raku

Just straight forward: for every number in the test input range, we check whether the sum of digit squares is a perfect square.

use v6;

sub sum-squares (Int $n where * >= 10) {
    my $sum-sq = [+] $n.comb.map({$_²});
    my $sqrt-int = $sum-sq.sqrt.Int;
    return $sqrt-int² == $sum-sq ?? 1 !! 0;
}
say "$_: ", sum-squares $_ for 10..71;

This program displays the following output:

$ raku  ./sum-squares.raku
10: 1
11: 0
12: 0
13: 0
14: 0
15: 0
16: 0
17: 0
18: 0
19: 0
20: 1
21: 0
22: 0
23: 0
24: 0
25: 0
26: 0
27: 0
28: 0
29: 0
30: 1
31: 0
32: 0
33: 0
34: 1
35: 0
36: 0
37: 0
38: 0
39: 0
40: 1
41: 0
42: 0
43: 1
44: 0
45: 0
46: 0
47: 0
48: 0
49: 0
50: 1
51: 0
52: 0
53: 0
54: 0
55: 0
56: 0
57: 0
58: 0
59: 0
60: 1
61: 0
62: 0
63: 0
64: 0
65: 0
66: 0
67: 0
68: 1
69: 0
70: 1
71: 0

Sum of Squares in Raku

This is a port to Perl of the Raku program above:

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

sub sum_squares {
    my $n = shift;
    my $sum_sq = 0;
    $sum_sq += $_ ** 2 for split //, $n;
    my $sqrt_int = int sqrt $sum_sq;
    return $sqrt_int ** 2 == $sum_sq ? 1 : 0;
}
say "$_: ", sum_squares $_ for 10..71;

This program displays the same output as the Raku program above:

$ perl  ./sum-squares.pl
10: 1
11: 0
12: 0
13: 0
14: 0
15: 0
16: 0
17: 0
18: 0
19: 0
20: 1
21: 0
22: 0
23: 0
24: 0
25: 0
26: 0
27: 0
28: 0
29: 0
30: 1
31: 0
32: 0
33: 0
34: 1
35: 0
36: 0
37: 0
38: 0
39: 0
40: 1
41: 0
42: 0
43: 1
44: 0
45: 0
46: 0
47: 0
48: 0
49: 0
50: 1
51: 0
52: 0
53: 0
54: 0
55: 0
56: 0
57: 0
58: 0
59: 0
60: 1
61: 0
62: 0
63: 0
64: 0
65: 0
66: 0
67: 0
68: 1
69: 0
70: 1
71: 0

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, June 20, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 115: String Chain and Largest Multiple

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (June 6, 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: String Chain

You are given an array of strings.

Write a script to find out if the given strings can be chained to form a circle. Print 1 if found otherwise 0.

A string $S can be put before another string $T in circle if the last character of $S is same as first character of $T.

Examples:

Input: @S = ("abc", "dea", "cd")
Output: 1 as we can form circle e.g. "abc", "cd", "dea".

Input: @S = ("ade", "cbd", "fgh")
Output: 0 as we can't form circle.

I interpreted the task as follows: find a string chain among the input strings. In other words, I looked for a possible chain among the input strings, even if some of the input strings are not part of the circular string. Reading again the task specification, it appears that the circular chain should contain all input strings (or perhaps the task was updated after I originally read it). Anyway, the task as described above is significantly easier than what I did, but I have no time this week to redo it.

String Chains in Raku

Since we’re looking for possible partial circular chains, we need to look at all combinations of strings. The find-circle subroutine uses the combinations and permutations built-in methods of Raku and for each permutation generated, the test-chain subroutine checks that they form a circle. There can be several solutions, but since we’re only required to print O or 1, we stop as soon as we’ve found one solution.

my @s = "abc", "dea", "cd";

sub test-chain (@input) {
    return False if (substr @input[0], 0, 1) 
        ne substr @input[*-1], (@input[*-1]).chars - 1, 1;
    for 1..@input.end -> $i {
        return False if (substr @input[$i], 0, 1)
            ne substr @input[$i-1], (@input[$i-1]).chars -1, 1;
    }
    True;
}

sub find-circle (@in) {
    for @in.combinations(2..@in.elems) -> $combin {
        for $combin.permutations -> $permute {
            next unless test-chain $permute;
            say $permute;
            return 1;
        }
    }
    return 0;
}

say find-circle @s;

This program displays the following output:

$ raku chain-str.raku
(abc cd dea)
1

I admit that I lazily used a brute-force approach here, that wouldn’t scale up too well for a large number of input string. There are better ways to solve the task, as we will see in the Perl implementation.

String Chains in Perl

Looking at porting the above program into Perl, my first idea was to implement the Raku built-in combinations/permutations methods in Perl. Nothing complicated, but a bit of a pain in the neck. Thinking about that, however, another idea came to me: in a circular chain of strings, the list of first letters is the same as the list of last letters. So, if we can make a list of first letters that are also last letters, then we have a solution.

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

my @s = ("abc", "dea", "cd", "xyz");

sub find_circle {
    # remove useless strings starting and ending with the same letter
    my @s = grep { not /^(\w)\w+$0$/} @_;
    my %first = map { (substr $_, 0, 1) => 1 } @s;
    say Dumper \%first;
    my %last = map { (substr $_, -1, 1) => 1 } grep { exists $first{substr $_, -1, 1 }}  @s;
    return scalar keys %last > 1 ? 1 : 0;
}
say find_circle @s;

Output:

$ perl chain-str.pl
1

Task 2: Largest multiple

You are given a list of positive integers (0-9), single digit.

Write a script to find the largest multiple of 2 that can be formed from the list.

Examples:

Input: @N = (1, 0, 2, 6)
Output: 6210

Input: @N = (1, 4, 2, 8)
Output: 8412

Input: @N = (4, 1, 7, 6)
Output: 7614

I think that the simplest way to get the largest number from a list of digits is to sort the digits in descending order and concatenate them. Since we additionally need the number to be even, we can, if needed, swap the last digit with the last even digit. Note that the problem has no solution if all digits are odd.

Largest Multiple in Raku

This is a Raku implementation of the algorithm described above:

sub find-largest (@in) {
    my @sorted = @in.sort.reverse;
    return @sorted if @sorted[*-1] %% 2;
    for (0..@in.end).reverse -> $i {
        # swap smallest even digit with last digit
        if @sorted[$i] %% 2 {
            @sorted[$i, *-1] = @sorted[*-1, $i];
            return @sorted;
        }
    }
    return (); # Failed, no even digit
}
for <1 0 2 6>, <1 3 2 6>, 
    <1 3 5 7>, <1 4 2 8> -> @test {
    my @result = find-largest @test;
    print @test, ": ";
    if @result.elems > 0 {
        say "Solution: ", @result.join('');
    } else {
        say "No solution"; 
    }
}

This program displays the following output for the given test cases:

$ raku ./mult-of-2.raku
1 0 2 6: Solution: 6210
1 3 2 6: Solution: 6312
1 3 5 7: No solution
1 4 2 8: Solution: 8412

Largest Multiple in Perl

This is an implementation of the same algorithm in Perl:

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

sub find_largest {
    my @sorted = reverse sort @_;
    return @sorted if $sorted[-1] % 2 == 0;
    for my $i (reverse 0..$#sorted) {
        # swap smallest even digit with last digit
        if ($sorted[$i] % 2 == 0) {
            @sorted[$i, -1] = @sorted[-1, $i];
            return @sorted;
        }
    }
    return (); # Failed, no even digit
}
for my $test ( [qw<1 0 2 6>], [qw<1 3 2 6>], 
               [qw<1 3 5 7>], [qw<1 4 2 8>] ) {
    my @result = find_largest(@$test);
    print @$test, ": ";
    if (@result > 0) {
        say "Solution: ", join '', @result;
    } else {
        say "No solution"; 
    }
}

This program displays the following output for given test cases:

$ perl  multiple-of2.pl
1026: Solution: 6210
1326: Solution: 6312
1357: No solution
1428: Solution: 8412

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

Perl Weekly Challenge 114: Next Palindrome Number and Higher Integer Set Bits

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

Spoiler Alert: This weekly challenge deadline is due in a few days (May 30, 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: Next Palindrome Number

You are given a positive integer $N.

Write a script to find out the next Palindrome Number higher than the given integer $N.

Example:

Input: $N = 1234
Output: 1331

Input: $N = 999
Output: 1001

Next Palindrome Number in Raku

In theory, we could build directly the next palindrome number from the current one. But there are different situations to cover, depending for example on whether the input number has an odd or even number of digits. Also, there are various edge cases. It is not so easy to be sure you’ve covered all possible cases. The alternative is to check each number in ascending order until you get a match. This brute force approach is much easier and in fact quite efficient for small and moderately large input numbers, as it is in most cases quite fast to find a palindrome larger than a given input number. We’ll use this second approach. We assume here that the input is a correct integer.

use v6;

my $input = @*ARGS[0] // 1234;
for $input .. Inf -> $candidate {
    next unless $candidate eq $candidate.flip;
    say $candidate;
    last;
}

This program displays the following output:

$ raku ./palin.raku
1331
$ raku ./palin.raku 3445
3553

Next Palindrome Number in Perl

We use the same algorithm, except that we use a while loop instead of a for because it is not possible to define an infinite range in Perl.

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

my $num = shift // 1234;
$num =~ s/^0+//; # remove leading 0s just in case
while (++ $num) {
    say $num and last if $num eq reverse $num;
}

This program displays the following output:

$ perl palin.pl
1331

$ perl palin.pl 3554
3663

$ perl palin.pl 075
77

Next Palindrome in Scala

Scala doesn’t have a last or break statement (there is a break method, but it is not very practical). So we will use a while loop with an explicit value incrementation.

object palindrome extends App {
  var num = 1234
  var found = 0
  while (found == 0) {
    if (num.toString == num.toString.reverse) {
      println(num)
      found = 1
    }
    num += 1
  }
}

This program duly prints 1331.

Next Palindrome in Python

import sys

num = int(sys.argv[1])
while (1):
    if str(num) == str(num)[::-1]:
        print(num)
        break
    num += 1

Output:

$ python3 palin.py 1234
1331

Task 2: Higher Integer Set Bits

You are given a positive integer $N.

Write a script to find the next higher integer having the same number of 1 bits in binary representation as $N.

Example:

Input: $N = 3
Output: 5

Binary representation of $N is 011. There are two 1 bits. So the next higher integer is 5 having the same the number of 1 bits i.e. 101.

Input: $N = 12
Output: 17

Binary representation of $N is 1100. There are two 1 bits. 
So the next higher integer is 17 having the same number of 1 bits i.e. 10001.

It is easy to show that we can always find one such number with the same number of bits set to 1 for any strictly positive integer (you can just add a 1 at the front of the binary representation of the number and set any other 1 bit to 0, but that of course does not necessarily yields the next higher integer).

Higher Integer Set Bits in Raku

To count the number of 1 bits, we just add all digits of the binary representation of the input number (in the number_of_1 subroutine). Then we just test all successive numbers larger than the input number until we find one that has the same number of bits set to 1.

use v6;

sub number_of_1 (Int $in) {
    my $count = [+] $in.base(2).comb;
}

my $input = @*ARGS[0] // 3;
my $target = number_of_1 $input.Int;
for $input ^.. Inf -> $candidate {
    next unless $candidate.Int.&number_of_1 == $target;
    say $candidate;
    last;
}

This program displays the following output for a few input values:

$ raku ./nextbin.raku 5

$ raku ./nextbin.raku 12 17

$ raku ./nextbin.raku 123 125

Higher Integer Set Bits in Perl

This is essentially a port to Perl of the above Raku program with just a couple of changes: we use a loop to count the bits set to 1 and we use a while loop instead of a for loop

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

sub number_of_1 {
    my $in = shift;
    my $count = 0;
    $count += $_ for split //, sprintf "%b", $in;
    return $count;
}

my $num = shift // 3;
my $target = number_of_1 $num;
while (++ $num) {
    say $num and last if $target == number_of_1 $num;
}

This program displays the following output for a few input values:

$ perl nextbin.pl
5

$ perl nextbin.pl 111
119

$ perl nextbin.pl 256
512

Higher Integer Set Bits in Scala

object nextbin extends App {

  def number_of_1(in: Int): Int = {
    val binlist = in.toBinaryString.toList
    var count = 0
    for (char <- binlist) {
      if (char == '1') count += 1
    }
    return count
  }
  var num = 111
  val target = number_of_1(num)
  var found = 0
  while (found == 0) {
    num += 1
    if (number_of_1(num) == target) {
      println(num)
      found = 1
    }
  }
}

This program duly prints 119.

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

Perl Weekly Challenge 113: Represent Integer and Recreate Binary Tree

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

Task 1: Represent Integer

You are given a positive integer $N and a digit $D.

Write a script to check if $N can be represented as a sum of positive integers having $D at least once. If check passes print 1 otherwise 0.

Example:

Input: $N = 25, $D = 7
Output: 0 as there are 2 numbers between 1 and 25 having the digit 7 i.e. 7 and 17. If we add up both we don't get 25.

Input: $N = 24, $D = 7
Output: 1

I’m very late and have very little time this week, so I’ll implement this task only in Raku.

Represent Integer in Raku

This script first populates the @candidates array with numbers between 1 and the input positive integer where the target digit is present. It then uses the combinations built-in routine to generate all combinations of the numbers in @candidates and checks whether the sum of the number in the combination is equal to the input positive integer.

use v6;

sub sum-int (Int $num, Int $digit where 1 <= $digit <= 9) {
    my @candidates = grep { /$digit/ }, 1..$num;
    for @candidates.combinations -> $comb {
        if $num == [+] $comb {
            # say $comb;
            return 1;
        }
    }
    return 0;
}
for 1..30 -> $test {
    say "$test: ", sum-int $test, 7;
}

The script performs the test for all numbers between 1 and 30 with a targhet digit of 7:

$ raku sum-int.raku
1: 0
2: 0
3: 0
4: 0
5: 0
6: 0
7: 1
8: 0
9: 0
10: 0
11: 0
12: 0
13: 0
14: 0
15: 0
16: 0
17: 1
18: 0
19: 0
20: 0
21: 0
22: 0
23: 0
24: 1
25: 0
26: 0
27: 1
28: 0
29: 0
30: 0

Task 2: Recreate Binary Tree

You are given a Binary Tree.

Write a script to replace each node of the tree with the sum of all the remaining nodes.

Example:

Input Binary Tree

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

Output Binary Tree

        27
       /  \
      26  25
     /   /  \
    24  23  22
     \
     21

Binary trees can be stored in breadth-first order as an array with an implicit data structure. This is similar to what is commonly done for binary heaps (i.e. a binary tree that keeps a partial order). Here, we’re not interested with partial order, but the idea is to use an array with the following properties. The item with subscript 0 is the value of the root node. The index of an element is used to compute the index of its parent and the indices of its children. The basic idea is that, for any node, the index of its parent is about half the index of the current node, and, conversely, the indices of the children are about twice the index of the current node. More precisely, for a tree starting at index 0, the exact formulas for a node with index $n are commonly as follows:

  • parent: int( ($n-1)/2 )
  • left child: 2*$n + 1
  • right child: 2*$n + 2

The root node is at index 0, and its children are at positions 1 and 2. The children of item with index 1 are at positions 3 and 4 and the children of 2 are at positions 5 and 6.

These rules may seem a bit complicated (and it is a bit tedious to compute these things manually), but they’re in fact quite easy to implement in a program. For example, in Perl:

sub children { my $i = shift; 2*$i + 1, 2*$i + 2 }
sub parent { my $i = shift; ($i-1) / 2; }

These children and parent subroutines are provided here for the purpose of completeness, they are not needed in our program.

Note that it is very easy to populate the binary-heap-like array from a graphical representation: you just need to perform a breadth-first traversal (and provide empty slots for missing nodes if any, but we will only be dealing with full binary trees for the sake of simplification). For example, this binary tree:

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

can be encoded as:

my $tree = [1 , 2, 3, 4, 5, 6, 7];

or even:

my $tree = [1 .. 7];

Now, the required task becomes very simple, as we can just manipulate the flat array.

We also provide a bft and a display subroutines for the purpose of displaying a graphical ASCII representation of the data in a tree format.

Recreate Binary Tree in Raku

We’re using a flat array to store the binary tree data structure, as described above:

use v6;

sub children (Int $i) { 2*$i+1, 2*$i+2 }  # not needed here
sub parent (Int $i) { ($i-1)/2; }         # not needed here

sub display ($tree) {
    my @bft_tree = bft($tree);
    my $start = (@bft_tree[*-1]).elems;
    my $sep_val = (2 * $start) - 1;
    for @bft_tree -> @line {
        my $sep = " " x $sep_val;
        say " " x $start, join $sep, @line;
        $start /= 2;
        $sep_val = ($sep_val - 1) / 2;
    }
}
sub bft ($tree) {               # Breadth First Traversal
    my ($index, $level) = (0, 0);
    my @bft_tree;
    while ($index <= $tree.end) {
        my $new_index = $index + 2 ** $level - 1;
        (@bft_tree[$level++]).append($tree[$index .. $new_index]);
        $index = $new_index + 1;
    }
    return @bft_tree;
}

my @tree = 1..7;
say "Tree before change:";
display @tree;
my $sum = [+] @tree;
my @new-tree = map { $sum - $_ }, @tree;
say "\nTree after change:";
display @new-tree;

Note that the performing the task requires only two lines of code:

my $sum = [+] @tree;
my @new-tree = map { $sum - $_ }, @tree;

It is the code to display the data in a tree format that takes most of the code.

This program displays the following output:

$ raku bin-tree.raku
Tree before change:
    1
  2   3
 4 5 6 7

Tree after change:
    27
  26   25
 24 23 22 21

Recreate Binary Tree in Perl

We’re again using a flat array to store the binary tree data structure, as described above:

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

sub children { my $i = shift; 2*$i+1, 2*$i+2 }
sub parent { my $i = shift; ($i-1)/2; }  # not needed here

sub display {
    my $bft_tree = bft(shift);
    my $start = scalar @{$bft_tree->[-1]};
    my $sep_val = (2 * $start) - 1;
    for my $line (@$bft_tree) {
        my $sep = " " x $sep_val;
        say " " x $start, join $sep, @$line;
        $start /= 2;
        $sep_val = ($sep_val - 1) / 2;
    }
}
sub bft {               # Breadth First Traversal
    my $tree = shift;
    my ($index, $level) = (0, 0);
    my @bft_tree;
    while ($index < scalar @$tree) {
        my $new_index = $index + 2 ** $level - 1;
        push @{$bft_tree[$level++]}, @{$tree}[$index .. $new_index];
        $index = $new_index + 1;
    }
    return \@bft_tree;
}

my $tree = [ 1..7 ];
say "\nTree before change:";
display $tree;
my $sum = 0;
$sum += $_ for @$tree;
my $new_tree = [ map $sum - $_, @$tree ];
say "\nNew tree";
display $new_tree;

This program displays the following output:

$ perl bin-tree.pl

Tree before change:
    1
  2   3
 4 5 6 7

New tree
    27
  26   25
 24 23 22 21

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

Perl Weekly Challenge 112: Canonical Path and Climb Stairs

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

Spoiler Alert: This weekly challenge deadline is due in a few days (May 16, 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: Canonical Path

You are given a string path, starting with a slash ‘/’.

Write a script to convert the given absolute path to the simplified canonical path.

In a Unix-style file system:

- A period ‘.’ refers to the current directory

- A double period ‘..’ refers to the directory up a level

- Multiple consecutive slashes (‘//’) are treated as a single slash ‘/’

The canonical path format:

- The path starts with a single slash ‘/’.

- Any two directories are separated by a single slash ‘/’.

- The path does not end with a trailing ‘/’.

- The path only contains the directories on the path from the root directory to the target file or directory

Example:

Input: "/a/"
Output: "/a"

Input: "/a/b//c/"
Output: "/a/b/c"

Input: "/a/b/c/../.."
Output: "/a"

Although it can surely be done differently, this is obviously a job for regular expressions or regexes.

Canonical Path in Raku

It would certainly make sense to write a grammar for performing the necessary transformations, but this is simple enough for a few regexes to do the job. It is in fact probably possible to do everything with a single regex, but I usually find it more legible to transform the input string step by step.

Note that I’m not trying to validate the input paths, with just one exception: if there are too many /../ compared to the previous path items, the script dies, rather than printing something incorrect.

use v6

my @tests = </a/ /a/b//c/ /a/b/c/../.. /a/../../b/>;
for @tests <-> $path {
    my $p = $path;
    $path ~~ s:g|'//'+|/|;
    $path ~~ s:g!^'/' | '/'$!!;
    my @path-items;
    for split /'/'+/, $path -> $item {
        next if $item eq '.';
        if $item eq '..' {
            die "Invalid path $p" unless @path-items;
            pop @path-items;
        } else {
            push @path-items, $item;
        }
    };
    say "$p => /", @path-items.join('/');
}

The script displays the following output:

$ raku ./paths.raku
/a/ => /a
/a/b//c/ => /a/b/c
/a/b/c/../.. => /a
Invalid path /a/../../b/
  in block  at ./main.raku line 12
  in block <unit> at ./main.raku line 4

Canonical Path in Perl

This a port to Perl of the Raku program above, except that when there are too many /../ compared to the previous path items, the script issues a warning instead of dying, does not print any canonical path and proceeds with the next items.

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

my @tests = ('/a/', '/a/b//c/', '/a/b/c/../..', '/a/../../b/', '/a/././b/');
TEST: for my $path (@tests) {
    my $p = $path;
    $path =~ s|\/\/+|/|g;
    $path =~ s!^\/|\/$!!g;
    my @path_items;
    for my $item (split /\/+/, $path) {
        next if $item eq '.';
        if ($item eq '..') {
            warn "Invalid path $p" and next TEST unless @path_items;
            pop @path_items;
        } else {
            push @path_items, $item;
        }
    };
    say "$p => /", join '/', @path_items;
}

The script displays the following output:

$ perl paths.pl
/a/ => /a
/a/b//c/ => /a/b/c
/a/b/c/../.. => /a
Invalid path /a/../../b/ at paths.pl line 14.
/a/././b/ => /a/b

Task 2: Climb Stairs

You are given $n steps to climb.

Write a script to find out the distinct ways to climb to the top. You are allowed to climb either 1 or 2 steps at a time.

Example:

Input: $n = 3
Output: 3

    Option 1: 1 step + 1 step + 1 step
    Option 2: 1 step + 2 steps
    Option 3: 2 steps + 1 step

Input: $n = 4
Output: 5

    Option 1: 1 step + 1 step + 1 step + 1 step
    Option 2: 1 step + 1 step + 2 steps
    Option 3: 2 steps + 1 step + 1 step
    Option 4: 1 step + 2 steps + 1 step
    Option 5: 2 steps + 2 steps

It is not clear to me whether the output should contain all the information above, or just the number of possibilities, but since the assignment asks us “to find out the distinct ways to climb to the top”, I have decided to output the result in the format given above, although this leads to quite a bit of uninteresting boiler plate code.

Climb Stairs in Raku

I’ve decided to use a try-steps recursive subroutine to explore all possibilities. The script uses a @*result dynamic variable to store the various winning combinations of steps and to print them at the end.

use v6;

sub print-result {
    my $count = 0;  
    for  @*result -> @solution {
        print "\tOption ", ++$count, ": ";
        my @step_list;
        push @step_list, "$_ " ~ ($_ ~~ /1/ ?? "step " !! "steps") for @solution;
        say join " + ", @step_list;
    }
    say "";
}

sub try-steps ($nb-steps, @curr) {
    for 1, 2 -> $new-step {
        my @new-cur = (|@curr, $new-step);
        my $sum = [+] @new-cur;
        next if $sum > $nb-steps;
        if $sum == $nb-steps {
            push @*result, @new-cur;
            last;
        } else {
            try-steps $nb-steps, @new-cur;
        }
    }
}

for 3, 4, 5 -> $target {
    my @*result;
    try-steps $target, [];
    say 'Input: $n = ', $target;
    say "Output: ", @*result.elems;
    # say @*result;
    print-result;
}

The script displays the following output:

$ raku ./steps.raku
Input: $n = 3
Output: 3
    Option 1: 1 step  + 1 step  + 1 step 
    Option 2: 1 step  + 2 steps
    Option 3: 2 steps + 1 step 

Input: $n = 4
Output: 5
    Option 1: 1 step  + 1 step  + 1 step  + 1 step 
    Option 2: 1 step  + 1 step  + 2 steps
    Option 3: 1 step  + 2 steps + 1 step 
    Option 4: 2 steps + 1 step  + 1 step 
    Option 5: 2 steps + 2 steps

Input: $n = 5
Output: 8
    Option 1: 1 step  + 1 step  + 1 step  + 1 step  + 1 step 
    Option 2: 1 step  + 1 step  + 1 step  + 2 steps
    Option 3: 1 step  + 1 step  + 2 steps + 1 step 
    Option 4: 1 step  + 2 steps + 1 step  + 1 step 
    Option 5: 1 step  + 2 steps + 2 steps
    Option 6: 2 steps + 1 step  + 1 step  + 1 step 
    Option 7: 2 steps + 1 step  + 2 steps
    Option 8: 2 steps + 2 steps + 1 step

Note that, if you don’t want this verbose output, you can just remove the print-result subroutine definition, comment out the last line (with the print-result subroutine call), and uncomment the previous code line:

    say @*result;
    # print-result;

and obtain the following output:

$ raku ./steps.raku
Input: $n = 3
Output: 3
[[1 1 1] [1 2] [2 1]]
Input: $n = 4
Output: 5
[[1 1 1 1] [1 1 2] [1 2 1] [2 1 1] [2 2]]
Input: $n = 5
Output: 8
[[1 1 1 1 1] [1 1 1 2] [1 1 2 1] [1 2 1 1] [1 2 2] [2 1 1 1] [2 1 2] [2 2 1]]

Climb Stairs in Perl

This is a port to Perl of the above Raku program, with a try_steps recursive subroutine:

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

my @result;

sub print_result {
    my $count = 0;
    for  my $solution (@result) {
        print "\tOption ", ++$count, ": ";
        my @step_list;
        push @step_list, "$_ " . ($_ =~ /1/ ? "step " : "steps") for @$solution;
        say join " + ", @step_list;
    }
    say "";
}

sub try_steps  {
    my ($nb_steps, $sum, @curr) = @_;
    for my $new_step (1, 2) {
        my $new_sum =  $sum + $new_step;
        next if $new_sum > $nb_steps;
        my @new_cur = (@curr, $new_step);
        if ($new_sum == $nb_steps) {
            push @result, \@new_cur;
            last;
        } else {
            try_steps($nb_steps, $new_sum, @new_cur);
        }
    }
}

for my $target (3, 4, 5) {
    @result = ();
    try_steps $target, 0, ();
    say 'Input: $n = ', $target;
    say "Output: ", scalar @result;
    print_result;
}

This script displays the following output:

$ perl  ./steps.pl
Input: $n = 3
Output: 3
        Option 1: 1 step  + 1 step  + 1 step
        Option 2: 1 step  + 2 steps
        Option 3: 2 steps + 1 step

Input: $n = 4
Output: 5
        Option 1: 1 step  + 1 step  + 1 step  + 1 step
        Option 2: 1 step  + 1 step  + 2 steps
        Option 3: 1 step  + 2 steps + 1 step
        Option 4: 2 steps + 1 step  + 1 step
        Option 5: 2 steps + 2 steps

Input: $n = 5
Output: 8
        Option 1: 1 step  + 1 step  + 1 step  + 1 step  + 1 step
        Option 2: 1 step  + 1 step  + 1 step  + 2 steps
        Option 3: 1 step  + 1 step  + 2 steps + 1 step
        Option 4: 1 step  + 2 steps + 1 step  + 1 step
        Option 5: 1 step  + 2 steps + 2 steps
        Option 6: 2 steps + 1 step  + 1 step  + 1 step
        Option 7: 2 steps + 1 step  + 2 steps
        Option 8: 2 steps + 2 steps + 1 step

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