laurent_r

These are some answers to the Week 265, Task 2, 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 April 21, 2024 at 23:59). This blog post provides some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 2: Completing Word

You are given a string, $str containing alphanumeric characters and array of strings (alphabetic characters only), @str.

Write a script to find the shortest completing word. If none found return empty string.

A completing word is a word that contains all the letters in the given string, ignoring space and number. If a letter appeared more than once in the given string then it must appear the same number or more in the word.

Example 1

Input: $str = 'aBc 11c'
       @str = ('accbbb', 'abc', 'abbc')
Output: 'accbbb'

The given string contains following, ignoring case and number:
a 1 times
b 1 times
c 2 times

The only string in the given array that satisfies the condition is 'accbbb'.

Example 2

Input: $str = 'Da2 abc'
       @str = ('abcm', 'baacd', 'abaadc')
Output: 'baacd'

The given string contains following, ignoring case and number:
a 2 times
b 1 times
c 1 times
d 1 times

The are 2 strings in the given array that satisfies the condition:
'baacd' and 'abaadc'.

Shortest of the two is 'baacd'

Example 3

Input: $str = 'JB 007'
       @str = ('jj', 'bb', 'bjb')
Output: 'bjb'

The given string contains following, ignoring case and number:
j 1 times
b 1 times

The only string in the given array that satisfies the condition is 'bjb'.

The task specification does not state it explicitly, but the examples show that we should ignore case when comparing letters.

Completing Word in Raku

In Raku, we'll use a Bag, which is a collection of distinct elements that each have an integer weight assigned to them signifying how many copies of that element are considered "in the bag", to store a histogram of the letter frequencies, both for the input test string and the words to which it should be compared. The good thing about it is that we obtain directly a histogram of the input letter list, and that can use the ⊆ Subset of or equal to operator,infix%E2%8A%86) to check directly the completing condition.

sub complete-word  ($in-str, @in-words) {
    my $letters = $in-str.comb.map({ .lc}).grep( /<[a..z]>/).Bag;
    my @result;
    for @in-words -> $word {
        push @result, $word if $letters ⊆ $word.comb.map({ .lc }).Bag;
    }
    return min(@result, :by( { $_.chars } )); 
}

my @tests = ('aBc 11c', ('accbbb', 'abc', 'abbc')),
            ('Da2 abc', ('abcm', 'baacd', 'abaadc')),
            ('JB 007', ('jj', 'bb', 'bjb'));
for @tests -> @test {
    printf "%-8s - %-20s => ", @test[0], "@test[1]";
    say complete-word @test[0], @test[1];
}

This program displays the following output:

$ raku ./complete-wortd.raku
aBc 11c  - accbbb abc abbc      => accbbb
Da2 abc  - abcm baacd abaadc    => baacd
JB 007   - jj bb bjb            => bjb

Completing Word in Perl

This is a port to Perl of the above Raku program. We use a hash instead of a Bag to store the histogram of the input letters. The use of the subset operator is replaced by a simple loop to find out whether any letter of the input test string is missing (or in smaller number) in the input words.

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

sub complete_word {
    my ($in_str, @in_words) = @_;
    my %letters;
    $letters{$_}++ for grep { $_ =~ /[a-z]/ } map { lc } split //, $in_str;
    my @result;
    WORD: for my $word (@in_words) {
        my %word_let;
        $word_let{$_}++ for map { lc } split //, $word;
        for my $k (keys %letters) {
            next WORD unless exists $word_let{$k};
            next WORD if $letters{$k} > $word_let{$k};
        }   
        push @result, $word;
    }
    return (sort {length $a <=> length $b} @result)[0];
}

my @tests = ( ['aBc 11c', ['accbbb', 'abc', 'abbc']],
              ['Da2 abc', ['abcm', 'baacd', 'abaadc']],
              ['JB 007', ['jj', 'bb', 'bjb']]  );
for my $test (@tests) {
    printf "%-8s - %-10s => ", $test->[0], "$test->[1][0] ...";
    say complete_word $test->[0], @{$test->[1]};
}

This program displays the following output:

$ perl ./complete-wortd.pl
aBc 11c  - accbbb ... => accbbb
Da2 abc  - abcm ...   => baacd
JB 007   - jj ...     => bjb

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 April 28, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.