February 2023 Archives

Perl Weekly Challenge 206: Shortest Time and Array Pairings

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on March 5, 2023 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Shortest Time

You are given a list of time points, at least 2, in the 24-hour clock format HH:MM.

Write a script to find out the shortest time in minutes between any two time points.

Example 1

Input: @time = ("00:00", "23:55", "20:00")
Output: 5

Since the difference between "00:00" and "23:55" is the shortest (5 minutes).

Example 2

Input: @array = ("01:01", "00:50", "00:57")
Output: 4

Example 3

Input: @array = ("10:10", "09:30", "09:00", "09:55")
Output: 15

Shortest Time in Raku

If the hour parts of the time stamps are equal, then the shortest subroutine simply compares the minute parts (and returns the absolute value of the difference). Otherwise, it transforms the time stamps into minutes and compares the minutes values. If the difference found is larger than half a day, then it is subtracted from a full day to obtain a difference less than 12 hours.

In the main code, the program tests the time stamp against each other to find the smallest time duration.

sub shortest ($t1, $t2) { 
    my $mod = 60 * 12;    # half a day
    my ($h1, $m1) = split /\:/, $t1;
    my ($h2, $m2) = split /\:/, $t2;
    return abs ($m1 - $m2) if $h1 == $h2;
    my $delta = abs(($h1 * 60 + $m1) - ($h2 * 60 + $m2));
    $delta = $mod * 2 - $delta if $delta > $mod;
}

for ("00:00", "23:55", "20:00"), 
    ("01:01", "00:50", "00:57"), 
    ("10:10", "09:30", "09:00", "09:55") -> @test {
    my $min = Inf;
    for @test.combinations(2) -> @comb {
        my $diff = shortest @comb[0], @comb[1];
        $min = $diff if $diff < $min;
    }
    say "@test[]".fmt("%-25s => "), $min;
}

This program displays the following output:

$ raku ./shortest-time.raku
00:00 23:55 20:00         => 5
01:01 00:50 00:57         => 4
10:10 09:30 09:00 09:55   => 15

Shortest Time in Perl

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

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

sub shortest { 
    my $mod = 60 * 12;
    my ($h1, $m1) = split /:/, $_[0];
    my ($h2, $m2) = split /:/, $_[1];
    return abs ($m1 - $m2) if $h1 == $h2;
    my $delta = abs(($h1 * 60 + $m1) - ($h2 * 60 + $m2));
    $delta = $mod * 2 - $delta if $delta > $mod;
    return $delta
}

for my $test (["00:00", "23:55", "20:00"], 
              ["01:01", "00:50", "00:57"], 
              ["10:10", "09:30", "09:00", "09:55"]) {
    my $min = 10000;   # larger than any HH:MM time diff
    my @t = @$test;
    for my $i (0..$#t) {
        for my $j ($i+1..$#t) {
            my $diff = shortest $t[$i], $t[$j];
            $min = $diff if $diff < $min;
        }
    }
    printf "%-25s => %d\n", "@t", $min;
}

This program displays the following output:

$ perl  ./shortest-time.pl
00:00 23:55 20:00         => 5
01:01 00:50 00:57         => 4
10:10 09:30 09:00 09:55   => 15

Task 2: Array Pairings

You are given an array of integers having even number of elements.

Write a script to find the maximum sum of the minimum of each pairs.

Example 1

Input: @array = (1,2,3,4)
Output: 4

Possible Pairings are as below:
a) (1,2) and (3,4). So min(1,2) + min(3,4) => 1 + 3 => 4
b) (1,3) and (2,4). So min(1,3) + min(2,4) => 1 + 2 => 3
c) (1,4) and (2,3). So min(1,4) + min(2,3) => 2 + 1 => 3

So the maxium sum is 4.

Example 2

Input: @array = (0,2,1,3)
Output: 2

Possible Pairings are as below:
a) (0,2) and (1,3). So min(0,2) + min(1,3) => 0 + 1 => 1
b) (0,1) and (2,3). So min(0,1) + min(2,3) => 0 + 2 => 2
c) (0,3) and (2,1). So min(0,3) + min(2,1) => 0 + 1 => 1

So the maximum sum is 2.

Array Pairings in Raku

Brute-Force Raku Solution

Our first implementation will just blindly follow the specifications: find all pairs, combine them 2 by 2 and find the largest sum of smaller items. To find all pairs, the pairings subroutine uses a combination of the permutationand rotor built-in methods. It then uses the combinations method to build the pairs of pairs and find the largest sum of mins.

sub pairings (@in) {
    my $max = - Inf;
    my @perms = @in.permutations;
    for @perms -> $perm {
        for $perm.rotor(2).combinations(2) -> $comb {
            my $sum = $comb[0].min + $comb[1].min;
            $max = $sum if $sum > $max
        }
    }
    return $max;
}
for <1 2 3 4>, <6 5 4 3 2 1>, <0 2 1 3> -> @test {
    say "@test[]".fmt("%-15s => "), pairings @test;
}

This program displays the following output:

$ raku ./pairings.raku
1 2 3 4         => 4
6 5 4 3 2 1     => 8
0 2 1 3         => 2

Improved Raku Solution

This is, however, quite inefficient, both from a coding perspective and from a performance standpoint. As soon as the input list grows a bit, the number of permutations will explode and the number of combinations of pairs generated from the permutations even more so. Since we are looking for maximum sums, we can look at the largest numbers. More specifically, since the numbers we will add have to be the minimum of a pair, we basically need the second and fourth largest integers of the input array. So, we simply sort the input and add the second and fourth integers of the sorted list.

This leads to a much simpler and much more efficient solution:

sub pairings (@in) {
    my @sorted = @in.sort.reverse;
    return @sorted[1] + @sorted[3];
}
for <1 2 3 4>, <6 5 4 3 2 1>, <0 2 1 3> -> @test {
    say "@test[]".fmt("%-15s => "), pairings @test;
}

This program displays the same output as the previous program.

Array Pairings in Perl

Porting the first (“brute-force”) Raku solution to Perl would have been a bit painful, because Perl doesn’t have built-in permutations, rotor, and combinations functions, so that they would have to be hand-rolled (since I usually eschew using CPAN modules in programming challenges). But, fortunately, it is quite easy to port the second (“improved”) solution to Perl:

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

sub pairings {
    my @sorted = sort { $b <=> $a } @_;
    return $sorted[1] + $sorted[3];
}

for my $test ([<1 2 3 4>], [<6 5 4 3 2 1>],
              [<0 2 1 3>], [<34 12 1 11>]) {
     printf "%-15s => %d\n", "@$test", pairings @$test;
}

This program displays the following output:

$ perl  ./pairings.pl
1 2 3 4         => 4
6 5 4 3 2 1     => 8
0 2 1 3         => 2
34 12 1 11      => 13

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 ans

wer the challenge before 23:59 BST (British summer time) on March 12, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 205: Third Highest and Maximum (Bit-Wise) XOR

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on February 26, 2023 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Third Highest

You are given an array of integers.

Write a script to find out the Third Highest if found otherwise return the maximum.

Example 1

Input: @array = (5,3,4)
Output: 3

First highest is 5. Second highest is 4. Third highest is 3.

Example 2

Input: @array = (5,6)
Output: 6

First highest is 6. Second highest is 5. Third highest is missing, so maximum is returned.

Example 2

Input: @array = (5,4,4,3)
Output: 3

First highest is 5. Second highest is 4. Third highest is 3.

Third Highest in Raku

The third-largest subroutine first sorts the input in descending order and then returns the third or the first item, depending on whether there are three items or more in the input, or less than that.

sub third-largest (@in) {
    my @s = @in.sort.reverse;
    return @s.elems >= 3 ?? @s[2] !! @s[0];
}
for <5 3 4>, <5 6>, <5 4 4 3>, <5 6 7 8 2 1> -> @test {
    say (~@test).fmt("%-12s => "), third-largest @test;
}

With large lists, using the sort routine may not be the most efficient solution in terms of performance (speed). However, in my humble opinion, this solution is better in terms of coding efficiency, because finding manually the third-largest item would require some form of circular buffer of the three largest elements, making the code significantly longer. Actually, the third-largest subroutine could boil down to a single line of code:

return @in.elems >= 3 ?? @in.sort[*-3] !! @in.sort[*-1];

but I did not do it, because it would lead to repeat the sorting statement, which is not the best programming practice.

This program displays the following output:

$ raku ./third-largest.raku
5 3 4        => 3
5 6          => 6
5 4 4 3      => 4
5 6 7 8 2 1  => 6

Third Highest in Perl

This is port to Perl of the above Raku program:

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


sub third_largest  {
    my @s = sort {$b <=> $a} @_;
    return scalar @s >= 3 ? $s[2] : $s[0];
}
for my $t ([<5 3 4>], [<5 6>], [<5 4 4 3>], 
           [<5 6 7 8 2 1>]) {
    printf "%-12s => %d \n", "@$t", third_largest @$t;
}

The comments about efficiency made in the Raku section above also apply to this Perl implementation.

This program displays the following output:

$ perl ./third-largest.pl
5 3 4        => 3
5 6          => 6
5 4 4 3      => 4
5 6 7 8 2 1  => 6

Task 2: Maximum XOR

You are given an array of integers.

Write a script to find the highest value obtained by XORing any two distinct members of the array.

Example 1

Input: @array = (1,2,3,4,5,6,7)
Output: 7

The maximum result of 1 xor 6 = 7.

Example 2

Input: @array = (2,4,1,3)
Output: 7

The maximum result of 4 xor 3 = 7.

Example 3

Input: @array = (10,5,7,12,8)
Output: 7

The maximum result of 10 xor 5 = 15.

First, there is a mistake in Example 3: the output should be 15, as shown in the output explanation. That’s just a typo.

We have another somewhat more serious problem. There is a xor operator both in Raku and in Perl. Both are actually logical operators. In Perl, for example, “binary ‘xor’ returns the exclusive-OR of the two surrounding expressions.” Looking at the examples provided, we can see that this is not the desired behavior. Obviously, what is wanted is the bit-wise xor, which is written +^ in Raku and ^ in Perl.

Maximum Bit-Wise XOR in Raku

The largest-xor subroutine uses the built-in combinations routine to test all input-array two-items combinations and returns the highest value obtained (together with the first combination that led to that value).

sub largest-xor (@in) {
    my $max = 0;
    my $max-i;
    for @in.combinations(2) -> $i {
        my $xor = $i[0] +^ $i[1];   # bitwise xor
        $max = $xor and $max-i = $i if $xor > $max
    }
    return "$max-i -- $max";
}

for (1,2,3,4,5,6,7), (2,4,1,3), (10,5,7,12,8) -> @test {
  say (~@test).fmt("%-15s => "), largest-xor @test;
}

This program dispàlays the following output:

$ raku ./max-xor.raku
1 2 3 4 5 6 7   => 1 6 -- 7
2 4 1 3         => 4 3 -- 7
10 5 7 12 8     => 10 5 -- 15

Maximum Bitwise XOR in Perl

This Perl implementation uses the same approach as the Raku program above, except that we find all 2-item combinations with two nested for loops, as there is no built-in combinations routine in core Perl.

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

sub largest_xor {
    my $max = 0;
    my @max_ij;
    for my $i (0..$#_) {
        for my $j ($i+1.. $#_) {
            my $xor = $_[$i] ^ $_[$j];    # bitwise xor
            if ($xor > $max) {
                $max = $xor;
                @max_ij = ($_[$i], $_[$j]) ;
            }
        }
    }
    return "@max_ij -- $max";
}

for my $t ([1,2,3,4,5,6,7], [2,4,1,3], [10,5,7,12,8]) {
    printf "%-15s => %-10s \n", "@$t", largest_xor @$t;
}

This program displays the following output:

$ perl  ./max-xor.pl
1 2 3 4 5 6 7   => 1 6 -- 7
2 4 1 3         => 4 3 -- 7
10 5 7 12 8     => 10 5 -- 15

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

Perl Weekly Challenge 204: Monotonic Arrays and Reshape Matrix

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on February 19, 2023 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Monotonic Array

You are given an array of integers.

Write a script to find out if the given array is Monotonic. Print 1 if it is otherwise 0.

An array is Monotonic if it is either monotone increasing or decreasing.

Monotone increasing: for i <= j , nums[i] <= nums[j]

Monotone decreasing: for i <= j , nums[i] >= nums[j]

Example 1

Input: @nums = (1,2,2,3)
Output: 1

Example 2

Input: @nums (1,3,2)
Output: 0

Example 3

Input: @nums = (6,5,5,4)
Output: 1

Monotonic Array in Raku

In Raku, the [] meta-operator used together with the >= or <= can check whether the comparison operator holds for all values of the input list or array. So we end up with a very simple program:

sub is-monotonic (@in) {
    [>=] @in or [<=] @in;
}

for <1 2 2 3>, <1 3 2>, <6 5 5 4> -> @test {
    say (~@test).fmt("%-10s => "), + is-monotonic @test;
}

This script displays the following output:

$ raku ./monotonic.raku
1 2 2 3    => 1
1 3 2      => 0
6 5 5 4    => 1

The solution is so concise that it can be changed to a simple one-liner:

$ raku -e 'say +([>=] @*ARGS or [<=] @*ARGS)' 3 7 7 9
1

After I prepared the above solution, I came across a blog post by Andrew Shitov, who asked ChatGPT to solve the problem. Not only did ChatGPT manage to write a correct program at the first try, but with a little guidance from my friend Andrew, it also managed to iteratively simplify the code and ended up to write a very raku-ish solution almost identical to my solution above:

sub is-monotonic(@nums) {
    [>=] @nums || [<=] @nums;
}

my @nums = (1, 2, 2, 3);
say +is-monotonic(@nums);

I found this almost unbelievable (and somewhat frightening). In my humble opinion, you should really read Andrew’s blog post.

Monotonic Array in Perl

The is_monotonic subroutine sets an ascending flag and a descending flag to a true value. It then uses a for loop to iterate over the input array and sets the relevant flag to a false value when it finds items pairs not ascending or not descending. At the end, the input array is monotonic if either of the flags is still true.

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

sub is_monotonic {
    my @in = @_;
    my ($ascending, $descending) = (1, 1);
    for my $i (1..$#in) {
        $ascending  = 0 if $in[$i] < $in[$i-1];
        $descending = 0 if $in[$i] > $in[$i-1]
    }
    return $ascending || $descending;
}
for my $test ([<1 2 2 3>], [<1 3 2>], [<6 5 5 4>]) {
    printf "%-10s => %d\n", "@$test", is_monotonic @$test;
}

This script displays the following output:

$ perl  ./monotonic.pl
1 2 2 3    => 1
1 3 2      => 0
6 5 5 4    => 1

Task 2: Reshape Matrix

You are given a matrix (m x n) and two integers (r) and (c).

Write a script to reshape the given matrix in form (r x c) with the original value in the given matrix. If you can’t reshape print 0.

Example 1

Input: [ 1 2 ]
       [ 3 4 ]

       $matrix = [ [ 1, 2 ], [ 3, 4 ] ]
       $r = 1
       $c = 4

Output: [ 1 2 3 4 ]

Example 2

Input: [ 1 2 3 ]
       [ 4 5 6 ]

       $matrix = [ [ 1, 2, 3 ] , [ 4, 5, 6 ] ]
       $r = 3
       $c = 2

Output: [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ]

        [ 1 2 ]
        [ 3 4 ]
        [ 5 6 ]

Example 3

Input: [ 1 2 ]

       $matrix = [ [ 1, 2 ] ]
       $r = 3
       $c = 2

Output: 0

Reshape Matrix in Raku

The reshape subroutine first determines the number of rows and columns of the input matrix, and returns 0 if the product of these values is not the same as the product $r x $c (since reshaping would not be possible in that case). It then flattens the input matrix into a one-dimension vector and iteratively picks $c items of the flattened array to populate the rows of the target array.

sub reshape (@matrix, $r, $c) {
    my @result;
    my $rows = @matrix.elems;
    my $cols = @matrix[0].elems;
    return 0 if $r * $c != $rows * $cols;
    my @flattened = | @matrix.map({| $_ });
    for 0..^$r -> $i {
        push @result, @flattened[$i*$c .. $i*$c + $c -1 ]
    }
    return @result;
}
sub display-result (@mat, $rc) {
    say @mat.gist.fmt("%-18s - "), "$rc => ", 
        reshape(@mat, | $rc);
}

my @test = ((1, 2), (3, 4));
for <1 4>, <4 1>, <2 2>, <3 4> -> $rc {
    display-result @test, $rc;
}
@test = ((1, 2, 3), (4, 5, 6));
for <3 2>, <2 3>, <1 6>, <6 1>, <6 3> -> $rc {
    display-result @test, $rc;
}

This program displays the following output:

$ raku ./reshape.raku
[(1 2) (3 4)]      - 1 4 => [(1 2 3 4)]
[(1 2) (3 4)]      - 4 1 => [(1) (2) (3) (4)]
[(1 2) (3 4)]      - 2 2 => [(1 2) (3 4)]
[(1 2) (3 4)]      - 3 4 => 0
[(1 2 3) (4 5 6)]  - 3 2 => [(1 2) (3 4) (5 6)]
[(1 2 3) (4 5 6)]  - 2 3 => [(1 2 3) (4 5 6)]
[(1 2 3) (4 5 6)]  - 1 6 => [(1 2 3 4 5 6)]
[(1 2 3) (4 5 6)]  - 6 1 => [(1) (2) (3) (4) (5) (6)]
[(1 2 3) (4 5 6)]  - 6 3 => 0

Reshape Matrix in Perl

This is a port to Perl of the above Raku program, using the same method. Note that this is a bit more difficult in Perl because of the need to use array references and to explicitly dereference these references in order to access the data, whereas Raku essentially manages most of these chores for us.

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

sub reshape {
    my @matrix = @{$_[0]};
    my ($r, $c) = @{$_[1]};
    my @result;
    my $rows = scalar @matrix;
    my $cols = scalar @{$matrix[0]};
    return [0] if $r * $c != $rows * $cols;
    my @flat = map { @$_ } @matrix;
    for my $i (0..$r - 1) {
        push @result, [ @flat[$i*$c .. $i*$c + $c -1 ] ];
    }
    return @result;
}
sub display_result {
    my ($mat, $rc) = @_;
    printf "%-15s - %-3s => ", join ("", 
        map ("[@$_]",  @$mat)), "@$rc";
    say map "[@$_]", reshape($mat, $rc);;
}

my @test = ([1, 2], [3, 4]);
for my $rc ([<1 4>], [<4 1>], [<2 2>], [<3 4>]) {
    display_result \@test, $rc;
}
@test = ([1, 2, 3], [4, 5, 6]);
for my $rc ([<3 2>], [<2 3>], [<1 6>], [<6 1>], [<6 3>]) {
    display_result \@test, $rc;
}

This program displays the following output:

$ perl  ./reshape.pl
[1 2][3 4]      - 1 4 => [1 2 3 4]
[1 2][3 4]      - 4 1 => [1][2][3][4]
[1 2][3 4]      - 2 2 => [1 2][3 4]
[1 2][3 4]      - 3 4 => [0]
[1 2 3][4 5 6]  - 3 2 => [1 2][3 4][5 6]
[1 2 3][4 5 6]  - 2 3 => [1 2 3][4 5 6]
[1 2 3][4 5 6]  - 1 6 => [1 2 3 4 5 6]
[1 2 3][4 5 6]  - 6 1 => [1][2][3][4][5][6]
[1 2 3][4 5 6]  - 6 3 => [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 February 26, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 203: Special Quadruplets and Copy Directory (Functional Programming Approach)

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days from now (on February 12, 2023 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Special Quadruplets

You are given an array of integers.

Write a script to find out the total special quadruplets for the given array.

Special Quadruplets are such that satisfies the following 2 rules. 1) nums[a] + nums[b] + nums[c] == nums[d] 2) a < b < c < d

Example 1

Input: @nums = (1,2,3,6)
Output: 1

Since the only special quadruplets found is $nums[0] + $nums[1] + $nums[2] == $nums[3].

Example 2

Input: @nums = (1,1,1,3,5)
Output: 4

$nums[0] + $nums[1] + $nums[2] == $nums[3]
$nums[0] + $nums[1] + $nums[3] == $nums[4]
$nums[0] + $nums[2] + $nums[3] == $nums[4]
$nums[1] + $nums[2] + $nums[3] == $nums[4]

Example 3

Input: @nums = (3,3,6,4,5)
Output: 0

Special Quadruplets in Raku

I do not see any simple way to avoid heavily nested loops (we could certainly use the combinations built-in routine to generate all the index or value combinations, but that wouldn’t make things simpler or faster), . That’s okay with small input list, but might lead to performance issues with longer input lists because of the combinational nightmare with such large lists.

sub find-quadruplets (@in) {
    my $count = 0;
    my $last = @in.end;
    for 0..$last-3 -> $i {
        for $i^..$last-2 -> $j {
            for $j^..$last-1 -> $k {
                my $target = [+] @in[$i, $j, $k];
                for $k^..$last -> $m {
                    $count++ if @in[$m] == $target;
                }
            }
        }
    }
    return $count;
}
for <1 2 3 6>, <1 1 1 3 5>, <1 1 1 3 5 5>, <3 3 6 4 5>,
    <3 3 6 12 21> -> @test {
        say "@test[]".fmt("%-15s -> "), find-quadruplets @test;
}

This program displays the following output:

$ raku quadruplets.raku
1 2 3 6         -> 1
1 1 1 3 5       -> 4
1 1 1 3 5 5     -> 7
3 3 6 4 5       -> 0
3 3 6 12 21     -> 3

Special Quadruplets in Perl

This is a port to Perl of the Raku program. One small change, though: I replaced the last (most inside) loop by a grep in scalar context counting the number of remaining items matching the computed sum of the first three items.

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

sub find_quadruplets {
    my $count = 0;
    my $last = $#_;
    for my $i (0..$last-3) {
        for my $j ($i+1..$last-2) {
            for my $k ($j+1..$last-1) {
                my $target = $_[$i] + $_[$j] + $_[$k];
                $count += grep { $_ == $target } 
                    @_[$k+1..$last];

            }
        }
    }
    return $count;
}

for my $test ([<1 2 3 6>], [<1 1 1 3 5>], [<1 1 1 3 5 5>],
    [<3 3 6 4 5>], [<3 3 6 12 21>], [<1 1 1 3 5 9>]) {
    printf "%-15s -> %d\n", "@$test", find_quadruplets @$test;
}

This program displays the following output:

$ perl ./quadruplets.pl
1 2 3 6         -> 1
1 1 1 3 5       -> 4
1 1 1 3 5 5     -> 7
3 3 6 4 5       -> 0
3 3 6 12 21     -> 3
1 1 1 3 5 9     -> 7

Task 2: Copy Directory

You are given path to two folders, $source and $target.

Write a script that recursively copy the directory from $source to $target except any files.

Example

Input: $source = '/a/b/c' and $target = '/x/y'

Source directory structure:

├── a
│   └── b
│       └── c
│           ├── 1
│           │   └── 1.txt
│           ├── 2
│           │   └── 2.txt
│           ├── 3
│           │   └── 3.txt
│           ├── 4
│           └── 5
│               └── 5.txt

Target directory structure:

├── x
│   └── y

Expected Result:

├── x
│   └── y
|       ├── 1
│       ├── 2
│       ├── 3
│       ├── 4
│       └── 5

For this, I’ve decided to try to create generic subroutines to parse the input directory tree, using functional programming techniques such as higher-order functions, call-back functions, closures, code references, function factories and even, in a certain way, currying.

Since my example is more complete in Perl, I’ll start with that language.

Copy Directory in Perl (Functional Programming Approach)

There exist some modules to copy files, directories or even entire directory tree.

File::Copy implements copying of files, but not directories. File::Path also doesn’t quite fit the need. File::Copy::Recursive implements copying directory trees, but it copies directory and files. There are many others, but I haven’t seen any that would copy a directory tree without copying also the files.

So I decided to write a recursive generic subroutine to navigate through the input directory tree.

sub traverse_dir {
    my ($code_f, $code_d, $path) = @_;
    my @dir_entries = glob("$path/*");
    for my $entry (@dir_entries) {
        $code_f->($entry) if -f $entry;
        $code_d->($entry) and 
            traverse_dir($code_f, $code_d, $entry) 
            if -d $entry;
    }
}

The traverse_dir subroutine receives three arguments: two code references and the path. The code-references are call-back functions, $code_f to handle files, and $code_d to handle directories. This makes it possible to use traverse_dir for a number of different tasks involving directory-tree traversal. The call back functions will be defined by the user of this subroutine.

Before we get to the copy directory task, let’s side-step a bit and see how we can use this subroutine to measure the size of the files in a directory tree.

Using the Generic Subroutine for Computing the Size of a Directory Tree

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

sub traverse_dir {
    my ($code_f, $code_d, $path) = @_;
    my @dir_entries = glob("$path/*");
    for my $entry (@dir_entries) {
        $code_f->($entry) if -f $entry;
        $code_d->($entry) and 
            traverse_dir($code_f, $code_d, $entry) 
            if -d $entry;
    }
}

sub create_size_code_ref {
    my $total_size = 0;
    return (sub {
        my $file = shift;
        my $size = -s $file;
        $total_size += $size;
        printf "%-15s -> %d\n", $file, $size,;
    }, sub {return $total_size;});
}
my $dir = shift;
my ($code_ref, $glob_size) = create_size_code_ref();
traverse_dir ($code_ref, sub {1}, $dir);
say "Total size = ", $glob_size->();

The create_size_code_ref subroutine generates and returns two other subroutines (actually code references), which also happen to be closures (they close on the total_size variable): one to compute and print the size of each file in the directory tree and the other to return the total computed size. This program might display the following output:

$ perl ./file-size.pl
./arithmetic-slices.pl -> 683
./arithmetic-slices.raku -> 533
# Lines omitted for brevity
./seven_segments.raku -> 2670
./three-odds.pl -> 456
./three-odds.raku -> 402
./widest-valley.raku -> 1125
Total size = 60153

When computing the size of a directory tree, we don’t need to do anything special about directory entries (except recursively traversing them), so the $code_d subroutine reference does nothing useful and simply returns a true value (1).

We will now use the generic traverse_dir subroutine to solve the task at hand.

Using the Generic Subroutine to Copy a Directory Tree

We can now use the same traverse_dir subroutine to solve the copy directory task.

There are some limitations, though. First, our code will work well in *nix-like environments, probably not in others. Second, the traverse_dir subroutine handles properly directories and normal files, but may not work properly with symbolic links, device files, pipes, sockets, and FIFOs. I don’t know what to do with these, so I simply ignore them, except for symbolic links, which may lead to endless loops and should therefore be excluded from the recursive calls. That’s my only change to the traverse-dir subroutine. Here, we don’t do anything with files, so the $code_f callback function does nothing, except returning a true value (1). The create_dir_code_ref routine creates a directory in the target path, unless it already exists (to avoid an error in such a case).

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

sub traverse_dir {
    my ($code_f, $code_d, $path) = @_;
    my @dir_entries = glob("$path/*");
    for my $entry (@dir_entries) {
        next if -l $entry;      # Exclude symlinks
        $code_f->($entry) and next if -f $entry;
        $code_d->($entry) and 
            traverse_dir($code_f, $code_d, $entry) 
            if -d $entry;
    }
}

sub create_dir_code_ref {
    my $target_path = shift;
    return sub {
        my $permissions = 0777;
        my $dir = shift;
        my $dir_name = (split '/', $dir)[-1];
        my $new_dir = "$target_path/$dir_name";
        if (-e $new_dir) {
            warn "Path $new_dir already exists. Omitted.";
            return 1;
        }
        mkdir $new_dir, $permissions or die "Unable to create $new_dir $!";
        say "Created $new_dir from $dir.";
    }
}
my $source = './a/b/c';
die "No such directory." unless -d $source;
mkdir './x' unless -d './x';
mkdir './x/y' unless -d './x/y';
my $code_ref_d = create_dir_code_ref('./x/y');
traverse_dir ( sub {1}, $code_ref_d, $source);

This program displays the following output:

$ perl ./copy-dir.pl
Created ./x/y/1 from ./a/b/c/1.
Created ./x/y/2 from ./a/b/c/2.
Created ./x/y/3 from ./a/b/c/3.
Created ./x/y/4 from ./a/b/c/4.
Created ./x/y/5 from ./a/b/c/5.

The ./x/y/ subdirectories have been duly created:

$ ls  ./x/y/
1  2  3  4  5

The file-size.pl program confirms that only directories, and not files, have been copied.

In the event some of the directories already existed in the target directory, the program gracefully handles this situation:

$ perl ./copy-dir.pl
Path ./x/y/1 already exists. Omitted. at copy-dir.pl line 24.
Created ./x/y/2 from ./a/b/c/2.
Path ./x/y/3 already exists. Omitted. at copy-dir.pl line 24.
Path ./x/y/4 already exists. Omitted. at copy-dir.pl line 24.
Created ./x/y/5 from ./a/b/c/5.

Copy Directory in Raku (Functional Programming Approach)

Please refer to the detailed explanations in the Perl section above if you need clarification on the Raku program below:

sub traverse_dir (&code_f, &code_d, $path) {
    # my @dir_entries = dir("$path");
    for dir "$path" -> $entry {
        next if $entry.l;       # exclude symlinks
        &code_f($entry) and next if $entry.f;
        &code_d($entry) and 
            traverse_dir(&code_f, &code_d, $entry) 
            if $entry.d;
    }
}
sub create_dir_code_ref ($target_path) {
    return sub ($dir) {
        my $dir_name = $dir.IO.basename;
        my $new_dir = "$target_path/$dir_name";
        if $new_dir.IO.e {
            note "Path $new_dir already exists. Omitted";
            return True;
        }
        mkdir $new_dir or die "Unable to create $new_dir $!";
        say "Created $new_dir from $dir.";
    }
}
my ($source, $target) = './a/b/c', './x/y';
die "No such directory." unless $source.IO.d;
mkdir ($target, 0o777) unless $target.IO.d;
my &code_ref_d = create_dir_code_ref $target;
my &code_ref_f = {True};
traverse_dir &code_ref_f, &code_ref_d, $source;

This program displays the following output:

$ raku  ./copy-dir.raku
Created ./x/y/1 from ./a/b/c/1.
Created ./x/y/2 from ./a/b/c/2.
Created ./x/y/3 from ./a/b/c/3.
Created ./x/y/4 from ./a/b/c/4.
Created ./x/y/5 from ./a/b/c/5.

And it created the desired directories:

$ ls ./x/y
1  2  3  4  5

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on February 19, 2023. 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.