laurent_r

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.