laurent_r

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.