W. Luis Mochán. Blog.

Perl Weekly Challenge 377.

2026-06-08T00:00:00+00:00

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 377.

Task 1: Reverse Existence

Submitted by: Mohammad Sajid Anwar
You are given a string.

Write a script to find whether any substring of length 2 is
also present in the reverse of the given string.

Example 1
Input: $str = "abcba"
Output: true

Reverse of given string is "abcba".
The substring "ab" in original string is also present in the reverse string too.
￼
Example 2
Input: $str = "racecar"
Output: true

The substring "ce" is present in both.
￼
Example 3
Input: $str = "abcd"
Output: false
￼
Example 4
Input: $str = "banana"
Output: true

The substring "an" is present in both.
￼
Example 5
Input: $str = "hello"
Output: true

The substring "ll" is present in both.
￼

I use a regular expression to extract all two character subsequences, I reverse them and I test the original string against all. Any match yields a true" result. If all attempts fail, I get a =False result. The code fits a 1.5-liner.

Examples:

perl -E '
L:for(@ARGV){$s=$_;$s=~/$_/&&(say("$s -> T"),next L)for(map{"".reverse $_}
$s=~/(?=(..))/g);say "$s -> F";}
' abcba racecar abcd banana hello

Results:

abcba -> T
racecar -> T
abcd -> F
banana -> T
hello -> T

The full code is

# Perl weekly challenge 377
# Task 1:  Reverse Existence
#
# See https://wlmb.github.io/2026/06/08/PWC377/#task-1-reverse-existence
use v5.36;
die <<~"FIN" unless @ARGV;
    Usage: $0 S0 S1...
    to test if the reversed string Sn when reversed
    contains a two character substring of the original string.
    FIN
STRING: for my $string (@ARGV){
    for(map{"".reverse $_}      # reverse each substring
        $string=~/(?=(..))/g    # get all 2 char substrings
        ){
        say("$string -> True"), next STRING
            if $string=~/$_/;
    }
    say "$string -> False";
}

Example:

./ch-1.pl abcba racecar abcd banana hello

Results:

abcba -> True
racecar -> True
abcd -> False
banana -> True
hello -> True

Task 2: Prefix Suffix

Submitted by: Mohammad Sajid Anwar
You are given an array of strings.

Write a script to find if the two strings (str1, str2) in
the given array such that str1 is prefix and suffix of
str2. Return the total count of such pairs.

Example 1
Input: @array = ("a", "aba", "ababa", "aa")
Output: 4

$array[0], $array[1]: "a" is a prefix and suffix of "aba"
$array[0], $array[2]: "a" is a prefix and suffix of "ababa"
$array[0], $array[3]: "a" is a prefix and suffix of "aa"
$array[1], $array[2]: "aba" is a prefix and suffix of "ababa"
￼
Example 2
Input: @array = ("pa", "papa", "ma", "mama")
Output: 2

$array[0], $array[1]: "pa" is a prefix and suffix of "papa"
$array[2], $array[3]: "ma" is a prefix and suffix of "mama"
￼
Example 3
Input: @array = ("abao", "ab")
Output: 0
￼
Example 4
Input: @array = ("abab", "abab")
Output: 1

$array[0], $array[1]: "abab" is a prefix and suffix of "abab"
￼
Example 5
Input: @array = ("ab", "abab", "ababab")
Output: 3

$array[0], $array[1]: "ab" is a prefix and suffix of "abab"
$array[0], $array[2]: "ab" is a prefix and suffix of "ababab"
$array[1], $array[2]: "abab" is a prefix and suffix of "ababab"
￼
Example 6
Input: @array = ("abc", "def", "ghij")
Output: 0
￼

I can check if a string matches at the beginning and at the end of each of the strings and increment a counter each succesful match. As each string matches itself, I subtract the number of strings. I assume the arrays are input as space separated strings. The result fits a one-liner:

Examples:

perl -E '
for(@ARGV){my@s=split" ";my $c=0;for my $x(@s){/^$x/&&/$x$/&&++$c for@s};say"$_ -> ",$c - @s;}
'  "a aba ababa aa" "pa papa ma mama" "abao ab" "abab abab" \
   "ab abab ababab" "abc def ghij"

Results:

a aba ababa aa -> 4
pa papa ma mama -> 2
abao ab -> 0
abab abab -> 2 *
ab abab ababab -> 3
abc def ghij -> 0

There is certain ambiguity in the problem statement: Every string is a prefix and suffix of itself, but the examples show that doesn’t count. However, if we are given two equal strings $s1==$s2 then $s1 is a prefix and suffix of $s2 and $s2 is a prefix and suffix of $s1. So I expect a contribution of 2 to the count. But then, in example 3 the expected output is 1. This is confusing, as it could happen that three strings are equal, $s1==$s2==$s3. What would the expected solution be in this case? Even if example 3 is correct, the result is ambiguous. There are six ordered pairs of equal strings, 3 unordered pairs, so a result of 1 or 3 would be consistent with example 3. According to my approach, the result would be 6 and unambiguous. Thus, I keep that approach.

The full code is:

# Perl weekly challenge 377
# Task 2:  Prefix Suffix
#
# See https://wlmb.github.io/2026/06/08/PWC377/#task-2-prefix-suffix
use v5.36;
die <<~"FIN" unless @ARGV;
    Usage: $0 A0 A1...
    to find in how many pairs of space-separated substrings of the string An
    are the first is both prefix and suffix of the second.
    FIN

for(@ARGV){
    my @strings = split" ";
    my $count = 0;
    for my $str1(@strings){
        /^$str1/ && /$str1$/ && ++$count for @strings
    };
    say"$_ -> ", $count - @strings;
}

Example:

./ch-2.pl   "a aba ababa aa" "pa papa ma mama" "abao ab" \
            "abab abab" "ab abab ababab" "abc def ghij"

Results:

a aba ababa aa -> 4
pa papa ma mama -> 2
abao ab -> 0
abab abab -> 2 *
ab abab ababab -> 3
abc def ghij -> 0

Perl Weekly Challenge 376.

2026-06-01T00:00:00+00:00

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 376.

Task 1: Chessboard Squares

Submitted by: Mohammad Sajid Anwar
You are given two coordinates of a square on 8x8 chessboard.

Write a script to find the given two coordinates have the
same colour.

8 W B W B W B W B
7 B W B W B W B W
6 W B W B W B W B
5 B W B W B W B W
4 W B W B W B W B
3 B W B W B W B W
2 W B W B W B W B
1 B W B W B W B W
  a b c d e f g h

Example 1
Input: $c1 = "a7", $c2 = "f4"
Output: true

Example 2
Input: $c1 = "c1", $c2 = "e8"
Output: false

Example 3
Input: $c1 = "b5", $c2 = "h2"
Output: false

Example 4
Input: $c1 = "f3", $c2 = "h1"
Output: true

Example 5
Input: $c1 = "a1", $c2 = "g8"
Output: false

Two coordinates have the same colour if the number of horizontal and vertical steps to get from one of their corresponding positions to the other is an even number. For example, one can reach from a7 to f4 by taking ord(f)-ord(a)=5 horizontal steps and 7-4=3 vertical steps, and 5+3=8 is an even number. Thus, from the coordinates I have to get the horizontal components and subtract them, get the vertical components and subtract them, and finally, add both results and check their divisibility by 2. The results takes a 1.5-liner.

Examples:

perl -E '
for my($p,$q)(@ARGV){@c=map{split""}($q,$p);@c[0,2]=map{ord}@c[0,2];say "$p $q -> ",
($c[0]-$c[2]+$c[1]-$c[3])%2?"F":"T"}
' a7 f4 c1 e8 b5 h2 f3 h1 a1 g8

Results:

a7 f4 -> T
c1 e8 -> F
b5 h2 -> F
f3 h1 -> T
a1 g8 -> F

The full code is:

# Perl weekly challenge 376
# Task 1:  Chessboard Squares
#
# See https://wlmb.github.io/2026/06/01/PWC376/#task-1-chessboard-squares
use v5.36;
use feature qw(try);
die <<~"FIN" unless @ARGV and @ARGV%2==0;
    Usage: $0 P0 Q0 P1 Q1...
    to find if positions Pn Qn on a chess board have
    the same color.
    FIN
for my($p,$q)(@ARGV){
    try {
        do {die "Invalid position: $_" unless /^[a-h][1-8]/} for $p, $q;
        my ($horizontalP, $verticalP, $horizontalQ, $verticalQ)
            = map {split ""} ($p, $q);
        ($horizontalP, $horizontalQ) = map {ord} ($horizontalP, $horizontalQ);
        my $steps = $horizontalP-$horizontalQ+$verticalP-$verticalQ;
        say "$p $q -> ", $steps%2?"False":"True";
    }
    catch($e){warn $e}
}

Example:

./ch-1.pl a7 f4 c1 e8 b5 h2 f3 h1 a1 g8

Results:

a7 f4 -> True
c1 e8 -> False
b5 h2 -> False
f3 h1 -> True
a1 g8 -> False

Task 2: Doubled Words

Submitted by: Matt Martini
You are given a string (which may contain embedded newlines)
which is taken from a page on a website. The string will not
contain brackets qw{ [ ] }.

Write a script that will find doubled words (such as “this
this”) and highlight (wrap in brackets) each doubled word.

The script should:

- Work across lines, even finding situations where a word at
  the end of one line is repeated at the beginning of the
  next.

- Find doubled words despite capitalization differences,
  such as with 'The the...', as well as allow differing
  amounts of whitespace (spaces, tabs, newlines, and the
  like) to lie between the words.

- Find doubled words even when separated by HTML tags. For
  example, to make a word bold: '...it is very very
  important...'. Only show lines containing doubled words.

Adapted from Mastering Regular Expressions, Third Edition by Jeffrey E. F. Friedl

Example 1
Input: $str = "you're given the job of checking the pages on a\nweb server for doubled words (such as 'this this'), a common problem\nwith documents subject to heavy editing."
Output: "web server for doubled words (such as '[this] [this]'), a common problem"

Example 2
Input: $str = "Find doubled words despite capitalization differences, such as with 'The\nthe...', as well as allow differing amounts of whitespace (spaces,\ntabs, newlines, and the like) to lie between the words."
Output: "Find doubled words despite capitalization differences, such as with '[The]\n[the]...', as well as allow differing amounts of whitespace (spaces,"

Example 3
Input: $str = "to make a word bold: '...it is very very important...'."
Output: "to make a word bold: '...it is [very] [very] important...'."

Example 4
Input: $str = "Perl officially stands for Practical Extraction and Report Language, except when it doesn't."
Output: ""

Example 5
Input: $str = "There's more than one one way to do it.\nEasy things should be easy and hard things should be possible."
Output: "There's more than [one] [one] way to do it."

I split the input using a capturing pattern, so I produce an array with words and their separators: html tags, special characters, spaces or punctuation. I can highlight adjacent repeated words (from the examples, I guess repeated words that are not adjacent are not to be highlighted) and join the array to build the output. Finally, I print the lines that contain highlighted words.

# Perl weekly challenge 376
# Task 2:  Doubled Words
#
# See https://wlmb.github.io/2026/06/01/PWC376/#task-2-doubled-words
use v5.36;
die <<~"FIN" unless @ARGV;
    Usage: $0 S0 S1...
    to find, highlight and print doubled words in the string Sn
    FIN
for(@ARGV){
    my @parts=split /   # split on word separators
       (                # capture
        \s*             # leading spaces
        (               # group
          <\/?\w[^>]*?> # html tag
          |
          &.+?;         # html special character
          |
          \s            # space
          |
          [[:punct:]]   # punctuation
        )+              # arbitrarily repeated
        \s*             # trailing space
       )
       /xx;             # extended re syntax
    # As there are two capture groups, @parts contains word, sep, sep, word, sep, sep...
    for(grep{$_%3==0} 0..@parts-4){                      # for the actual words
        next unless (lc $parts[$_] eq lc $parts[$_+3]);  # check doubled words
        $parts[$_]="[$parts[$_]]";                       # and higlight them
        $parts[$_+3]="[$parts[$_+3]]";
    }

    my @lines =
        grep {/\[/}
        split "\n",
        join "", @parts[
            grep{$_%3!=2}0..@parts-1
        ],
        "\n";
    say "$_\n->";
    say $_ for @lines;
    say "---";
}

Example:

./ch-2.pl \
"you're given the job of checking the pages on a
web server for doubled words (such as 'this this'), a common problem
with documents subject to heavy editing." \
"Find doubled words despite capitalization differences, such as with 'The
the...', as well as allow differing amounts of whitespace (spaces,
tabs, newlines, and the like) to lie between the words." \
"to make a word bold: '...it is very very important...'." \
"Perl officially stands for Practical Extraction and Report Language, except when it doesn't." \
"There's more than one one way to do it.
Easy things should be easy and hard things should be possible."

Results:

you're given the job of checking the pages on a
web server for doubled words (such as 'this this'), a common problem
with documents subject to heavy editing.
->
web server for doubled words (such as '[this] [this]'), a common problem
---
Find doubled words despite capitalization differences, such as with 'The
the...', as well as allow differing amounts of whitespace (spaces,
tabs, newlines, and the like) to lie between the words.
->
Find doubled words despite capitalization differences, such as with '[The]
[the]...', as well as allow differing amounts of whitespace (spaces,
---
to make a word bold: '...it is very very important...'.
->
to make a word bold: '...it is [very] [very] important...'.
---
Perl officially stands for Practical Extraction and Report Language, except when it doesn't.
->
---
There's more than one one way to do it.
Easy things should be easy and hard things should be possible.
->
There's more than [one] [one] way to do it.
---

Perl Weekly Challenge 375.

2026-05-26T00:00:00+00:00

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 375.

Task 1: Single Common Word

Submitted by: Mohammad Sajid Anwar
You are given two array of strings.

Write a script to return the number of strings that appear
exactly once in each of the two given arrays. String
comparison is case sensitive.

Example 1
Input: @array1 = ("apple", "banana", "cherry")
       @array2 = ("banana", "cherry", "date")
Output: 2
￼
Example 2
Input: @array1 = ("a", "ab", "abc")
       @array2 = ("a", "a", "ab", "abc")
Output: 2

"a" appears once in @array1 but appears twice in @array2,
therefore, not counted.

Example 3
Input: @array1 = ("orange", "lemon")
       @array2 = ("grape", "melon")
Output: 0

Example 4
Input: @array1 = ("test", "test", "demo")
       @array2 = ("test", "demo", "demo")
Output: 0

Example 5
Input: @array1 = ("Hello", "world")
       @array2 = ("hello", "world")
Output: 1

String comparison is case sensitive.
￼

I’ll assume that the arrays are provided in @ARGV as space separated strings. Then I can split them, make hashes counting the number of appearances of each string in each array and filter the keys of one of them by checking both counts. The result fits a simple two-liner.

Examples:

perl -E '
for my($x,$y)(@ARGV){my(%c,%d);$c{$_}++for split" ",$x;$d{$_}++for
split" ",$y;say"\"$x\", \"$y\" -> ",0+grep{$c{$_}==$d{$_}==1}keys%c;}
' "apple banana cherry" "banana cherry date" "a ab abc" "a a ab abc" \
  "orange lemon" "grape melon" "test test demo" "test demo demo" \
  "Hello world" "hello world"

Results:

"apple banana cherry", "banana cherry date" -> 2
"a ab abc", "a a ab abc" -> 2
"orange lemon", "grape melon" -> 0
"test test demo", "test demo demo" -> 0
"Hello world", "hello world" -> 1

The full code is:

# Perl weekly challenge 375
# Task 1:  Single Common Word
#
# See https://wlmb.github.io/2026/05/26/PWC375/#task-1-single-common-word
use v5.36;
die <<~"FIN" unless @ARGV and @ARGV%2==0;
    Usage: $0 X0 Y0 X1 Y1...
    to find those space separated words that appear exactly once
    in strings Xn and Yn
    FIN
for my ($x,$y) (@ARGV){
    my(%count_x, %count_y);
    $count_x{$_}++ for split " ", $x;
    $count_y{$_}++ for split" ", $y;
    say"\"$x\", \"$y\" -> ",0+grep{($count_x{$_}//0) == ($count_y{$_}//0) == 1}
        keys %count_x;
}

Notice that I used the // operator to avoid comparing undefined values.

Examples:

./ch-1.pl "apple banana cherry" "banana cherry date" \
          "a ab abc" "a a ab abc" \
          "orange lemon" "grape melon" \
          "test test demo" "test demo demo" \
          "Hello world" "hello world"

Results:

"apple banana cherry", "banana cherry date" -> 2
"a ab abc", "a a ab abc" -> 2
"orange lemon", "grape melon" -> 0
"test test demo", "test demo demo" -> 0
"Hello world", "hello world" -> 1

Task 2: Find K-Beauty

Submitted by: Mohammad Sajid Anwar
You are given a number and a digit (k).

Write a script to find the K-Beauty of the given number. The
K-Beauty of an integer number is defined as the number of
substrings of given number when it is read as a string has
length of ‘k’ and is a divisor of given number.

Example 1
Input: $num = 240, $k = 2
Output: 2

Substring with length 2:
24: 240 is divisible by 24
40: 240 is divisible by 40
￼
Example 2
Input: $num = 1020, $k = 2
Output: 3

Substring with length 2:
10: 1020 is divisible by 10
02: 1020 is divisible by 2
20: 1020 is divisible by 20
￼
Example 3
Input: $num = 444, $k = 2
Output: 0

Substring with length 2:
First "44": 444 is not divisible by 44
Second "44": 444 is not divisible by 44
￼
Example 4
Input: $num = 17, $k = 2
Output: 1

Substring with length 2:
17: 17 is divisible by 17
￼
Example 5
Input: $num = 123, $k = 1
Output: 2

Substring with length 1:
1: 123 is divisible by 1
2: 123 is not divisible by 2
3: 123 is divisible by 3

I use a regular expression to produce all substrings of the given length. I filter them according to their divisibility and then I count them. The result fits a one liner.

Examples:

perl -E '
for my($n, $k)(@ARGV){say"num=$n  k=$k -> ", 0+grep{$n%$_==0}$n=~/(?=(\d{$k}))/g;}
' 240 2  1020 2 444 2 17 2 123 1

Results:

num=240  k=2 -> 2
num=1020  k=2 -> 3
num=444  k=2 -> 0
num=17  k=2 -> 1
num=123  k=1 -> 2

The regular expression matches and captures repeatedly (/g) a sequence of $k digits (\d{$k}), but the capture is enclosed in a zero width lookahead assertion /(?=(\d{$k}))/ so that the position doesn’t advance. The /g modifier advances it one step to avoid an infinite loop, so the match produces a list of all substrings of digits of length $k.

The full code is almost identical:

# Perl weekly challenge 375
# Task 2:  Find K-Beauty
#
# See https://wlmb.github.io/2026/05/26/PWC375/#task-2-find-k-beauty
use v5.36;
die <<~"FIN" unless @ARGV and @ARGV%2==0;
    Usage: $0 N0 K0 N1 K1...
    to find how many substrings of Nn of length Kn divide Nn.
    FIN
for my ($n, $k) (@ARGV) {
    say"num=$n  k=$k -> ", 0+grep{ $n%$_ == 0} $n=~/(?=(\d{$k}))/g;
}

Example:

./ch-2.pl 240 2  1020 2 444 2 17 2 123 1

Results:

num=240  k=2 -> 2
num=1020  k=2 -> 3
num=444  k=2 -> 0
num=17  k=2 -> 1
num=123  k=1 -> 2

Perl Weekly Challenge 374.

2026-05-22T00:00:00+00:00

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 374.

Task 1: Count Vowel

Submitted by: Mohammad Sajid Anwar
You are given a string.

Write a script to return all possible vowel substrings in
the given string. A vowel substring is a substring that only
consists of vowels and has all five vowels present in it.

Example 1
Input: $str = "aeiou"
Output: ("aeiou")
￼
Example 2
Input: $str = "aaeeeiioouu"
Output: ("aaeeeiioou", "aaeeeiioouu", "aeeeiioou", "aeeeiioouu")

NOTE: Updated output [2025-05-18]
￼
Example 3
Input: $str = "aeiouuaxaeiou"
Output: ("aeiou", "aeiou", "eiouua", "aeiouu", "aeiouua")

NOTE: Updated output [2025-05-18]
￼
Example 4
Input: $str = "uaeiou"
Output: ("aeiou", "uaeio", "uaeiou")
￼
Example 5
Input: $str = "aeioaeioa"
Output: ()
￼

I can separate each string into continuous pieces with no consonant. For each piece, I repeatedly truncate it until it misses some vowel. The code takes a 2.5-liner.

Examples:

perl -E '
sub t($x){$x=~/$_/||return 0 for(split "","aeiou");1}for(@ARGV){my@r;for my$i(/([aeiou]+)/g)
{$l=length$i;for(0..$l){t $r=substr$i,$_ or last;push @r,$r;for(1..$l){t $s=substr$r,0,-$_ or
last;push@r,$s}}}say"$_ -> (@r)";}
' aeiou aaeeeiioouu aeiouuaxaeiou uaeiou aeioaeioa

Results:

aeiou -> (aeiou)
aaeeeiioouu -> (aaeeeiioouu aaeeeiioou aeeeiioouu aeeeiioou)
aeiouuaxaeiou -> (aeiouua aeiouu aeiou eiouua aeiou)
uaeiou -> (uaeiou uaeio aeiou)
aeioaeioa -> ()

A slightly shorter, slightly more inefficient version is:

perl -E '
sub t($x){$x=~/$_/||return 0 for split"","aeiou";1}for(@ARGV){say "$_ -> (", join(", ",map
{$l=length($i=$_);grep{t($_)}map{($j=$_,map {substr $j,0,-$_}(1..$l))}map{substr$i,$_}(0..$l)}
/([aeiou]+)/g), ")";}
' aeiou aaeeeiioouu aeiouuaxaeiou uaeiou aeioaeioa

Results:

aeiou -> (aeiou)
aaeeeiioouu -> (aaeeeiioouu, aaeeeiioou, aeeeiioouu, aeeeiioou)
aeiouuaxaeiou -> (aeiouua, aeiouu, aeiou, eiouua, aeiou)
uaeiou -> (uaeiou, uaeio, aeiou)
aeioaeioa -> ()

The full code is:

# Perl weekly challenge 374
# Task 1:  Count Vowel
#
# See https://wlmb.github.io/2026/05/22/PWC374/#task-1-count-vowel
use v5.36;
use feature qw(try);
die <<~"FIN" unless @ARGV;
    Usage: $0 S0 S1...
    to find all substrings of Sn containing only vowels, and all of them.
    FIN
for(@ARGV){
    try{
        die "Expected a lowercase string: $_" unless $_ eq lc $_;
        my @results;
        for my $noconsonant(/([aeiou]+)/g){
            my $maxlength = length $noconsonant;
            for(0..$maxlength){
                # truncate from the start
                test(my $tentative = substr $noconsonant, $_) || last;
                push @results, $tentative;
                for(1..$maxlength){
                    # truncate from the end
                    test(my $truncated = substr $tentative, 0, -$_) || last;
                    push @results, $truncated;
                }
            }
        }
        say "$_ -> (@results)";
    }
    catch($e){warn $e}
}
sub test($x){
    $x=~/$_/||return 0 for(split "","aeiou");
    return 1;
}

Examples:

./ch-1.pl aeiou aaeeeiioouu aeiouuaxaeiou uaeiou aeioaeioa

Results:

aeiou -> (aeiou)
aaeeeiioouu -> (aaeeeiioouu aaeeeiioou aeeeiioouu aeeeiioou)
aeiouuaxaeiou -> (aeiouua aeiouu aeiou eiouua aeiou)
uaeiou -> (uaeiou uaeio aeiou)
aeioaeioa -> ()

Notice that I shouldn’t worry about truncating too much, as the test would fail anyway.

Task 2: Largest Same-digits Number

Submitted by: Mohammad Sajid Anwar
You are given a string containing 0-9 digits only.

Write a script to return the largest number with all digits
the same in the given string.

Example 1
Input: $str = "6777133339"
Output: 3333
￼
Example 2
Input: $str = "1200034"
Output: 4
￼
Example 3
Input: $str = "44221155"
Output: 55
￼
Example 4
Input: $str = "88888"
Output: 88888
￼
Example 5
Input: $str = "11122233"
Output: 222

In all the examples the same digits are contiguous. Thus, I guess I can split the string into substrings of contiguous digits and take the largest one. This yields a half liner.

Examples:

perl -MList::Util=max -E '
say "$_ -> ", max /((\d)\2*)/g for(@ARGV);
' 6777133339 1200034 44221155 88888 11122233

Results:

6777133339 -> 3333
1200034 -> 4
44221155 -> 55
88888 -> 88888
11122233 -> 222

Notice that /((\d)\2*)/g produces a list of repeated digits alternating with the single digits that are repeated. That doesn’t alter the result, as the single digits are not larger than the repeated digits.

The full code is:

# Perl weekly challenge 374
# Task 2:  Largest Same-digits Number
#
# See https://wlmb.github.io/2026/05/22/PWC374/#task-2-largest-same-digits-number
use v5.36;
use List::Util qw(max);
die <<~"FIN" unless @ARGV;
    Usage: $0 S0 S1...
    to find the largest number made of repetitions of
    a single digit within the string Sn
    FIN
say "$_ -> ", max /((\d)\2*)/g for(@ARGV);

Example:

./ch-2.pl 6777133339 1200034 44221155 88888 11122233

Results:

6777133339 -> 3333
1200034 -> 4
44221155 -> 55
88888 -> 88888
11122233 -> 222

Perl Weekly Challenge 373.

2026-05-11T00:00:00+00:00

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 373.

Task 1: Equal List

Submitted by: Mohammad Sajid Anwar
You are given two arrays of strings.

Write a script to return true if the two given array
represent the same strings otherwise false.

Example 1
Input: @arr1 = ("a", "bc")
       @arr2 = ("ab", "c")
Output: true

Array 1: "a" + "bc" = "abc"
Array 2: "ab" + "c" = "abc"

Example 2
Input: @arr1 = ("a", "b", "c")
       @arr2 = ("a", "bc")
Output: true

Array 1: "a" + "b" + "c" = "abc"
Array 2: "a" + "bc" = "abc"

Example 3
Input: @arr1 = ("a", "bc")
       @arr2 = ("a", "c", "b")
Output: false

Array 1: "a" + "bc" = "abc"
Array 2: "a" + "c" + "b" = "acb"

Example 4
Input: @arr1 = ("ab", "c", "")
       @arr2 = ("", "a", "bc")
Output: true

Array 1: "ab" + "c" + "" = "abc"
Array 2: ""  + "a" + "bc" = "abc"

Example 5
Input: @arr1 = ("p", "e", "r", "l")
       @arr2 = ("perl")
Output: true

Array 1: "p" + "e" + "r" + "l" = "perl"
Array 2: "perl"
￼

Well, this seems very simple. Join both sets of strings into two strings and compare them. The result takes a one-liner.

Examples:

perl -E '
for my($x,$y)(@ARGV){say"$x; $y -> ",f($x)eq f($y)?"T":"F";}sub f($x){join"",split/\s*,\s*/,$x}
' "a, bc" "ab, c" "a, b, c" "a, bc" "a, bc" "a, c, b" "ab, c, " ", a, bc" "p, e, r, l" "perl"

Results:

a, bc; ab, c -> T
a, b, c; a, bc -> T
a, bc; a, c, b -> F
ab, c, ; , a, bc -> T
p, e, r, l; perl -> T

The full code is:

# Perl weekly challenge 373
# Task 1:  Equal List
#
# See https://wlmb.github.io/2026/05/11/PWC373/#task-1-equal-list
use v5.36;
die <<~"FIN" unless @ARGV and @ARGV%2==0;
    Usage: $0 S0a S0b S1a S1b ...
    to compare the set of comma separated strings Sna with Snb.
    FIN

for my($x,$y)(@ARGV){
    say "$x; $y -> ", join_split($x) eq join_split($y)? "True":"False";
}

sub join_split($x){
    join "", split /\s*,\s*/, $x
}


Example:

./ch-1.pl "a, bc"      "ab, c" \
          "a, b, c"    "a, bc" \
          "a, bc"      "a, c, b" \
          "ab, c, "    ", a, bc" \
          "p, e, r, l" "perl"

Results:

a, bc; ab, c -> True
a, b, c; a, bc -> True
a, bc; a, c, b -> False
ab, c, ; , a, bc -> True
p, e, r, l; perl -> True

Task 2: List Division

Submitted by: Mark Anderson
You are given a list and a non-negative integer.

Write a script to divide the given list into given
non-negative integer equal parts. Return -1 if the integer
is more than the size of the list.

Example 1
Input: @list = (1,2,3,4,5), $n = 2
Output: ((1,2,3), (4,5))

5 / 2 = 2 remainder 1.
The extra element goes into the first chunk.

Example 2
Input: @list = (1,2,3,4,5,6), $n = 3
Output: ((1,2), (3,4), (5,6))

6 / 3 = 2 remainder 0.

Example 3
Input: @list = (1,2,3), $n = 2
Output: ((1,2), (3))

Example 4
Input: @list = (1,2,3,4,5,6,7,8,9,10), $n = 5
Output: ((1,2), (3,4), (5,6), (7,8), (9,10))

Example 5
Input: @list = (1,2,3), $n = 4
Output: -1

Example 6
Input: @list = (72,57,89,55,36,84,10,95,99,35), $n = 7;
Output: ((72,57), (89,55), (36,84), (10), (95), (99), (35))￼

I assume the input is a space separated list followed by the integer. I split the list, take its size, divide it by the integer and get the remainder. I repeatedly splice the list joining the first $n elements, and adding one of the remaining terms until they are exhausted. The code takes a two-liner.

Examples:

perl -E '
for my($l,$n)(@ARGV){$s=(@l=split" ",$l)/$n; $r=@l%$n;say "$l, $n -> ",
$n>@l?-1:map{"(".join(" ",splice(@l,0,$s+($_<=$r))).")"}(1..$n)}
' "1 2 3 4 5" 2 "1 2 3 4 5 6" 3 "1 2 3" 2 "1 2 3 4 5 6 7 8 9 10"  5 \
  "1 2 3" 4 "72 57 89 55 36 84 10 95 99 35" 7

Results:

2 3 4 5, 2 -> (1 2 3)(4 5)
2 3 4 5 6, 3 -> (1 2)(3 4)(5 6)
2 3, 2 -> (1 2)(3)
2 3 4 5 6 7 8 9 10, 5 -> (1 2)(3 4)(5 6)(7 8)(9 10)
2 3, 4 -> -1
57 89 55 36 84 10 95 99 35, 7 -> (72 57)(89 55)(36 84)(10)(95)(99)(35)

The full code is:

# Perl weekly challenge 373
# Task 2:  List Division
#
# See https://wlmb.github.io/2026/05/11/PWC373/#task-2-list-division
use v5.36;
use feature qw(try);
die <<~"FIN" unless @ARGV and @ARGV%2==0;
    Usage: $0 L0 N0 L1 N1...
    to split the space separated list Ln into Nn (almost) equal parts.
    FIN
for my ($list, $pieces)(@ARGV){
    try {
        die "Number of pieces must be >= 1: $pieces" unless $pieces >= 1;
        my @list = split " ", $list;
        my $size = @list / $pieces;
        my $remainder = @list % $pieces;
        my @result = $pieces > @list
            ? -1
            : map{
                "("
                    . join(" ", splice(@list, 0, $size + ($_<=$remainder)))
                    .")"
              } (1 .. $pieces);
        say "$list, $pieces -> @result";
    }
    catch($e){ warn $e }
}

Example:

./ch-2.pl "1 2 3 4 5" 2 "1 2 3 4 5 6" 3 "1 2 3" 2 "1 2 3 4 5 6 7 8 9 10"  5 \
          "1 2 3" 4 "72 57 89 55 36 84 10 95 99 35" 7

Results:

2 3 4 5, 2 -> (1 2 3) (4 5)
2 3 4 5 6, 3 -> (1 2) (3 4) (5 6)
2 3, 2 -> (1 2) (3)
2 3 4 5 6 7 8 9 10, 5 -> (1 2) (3 4) (5 6) (7 8) (9 10)
2 3, 4 -> -1
57 89 55 36 84 10 95 99 35, 7 -> (72 57) (89 55) (36 84) (10) (95) (99) (35)

Perl Weekly Challenge 372.

2026-05-04T00:00:00+00:00

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 372.

Task 1: Rearrange Spaces

Submitted by: Mohammad Sajid Anwar

You are given a string text of words that are placed among
number of spaces.

Write a script to rearrange the spaces so that there is an
equal number of spaces between every pair of adjacent words
and that number is maximised. If you can’t distribute, place
the extra spaces at the end. Finally return the string.

Example 1
Input: $str = "  challenge  "
Output: "challenge    "

We have 4 spaces and 1 word. So all spaces go to the end.
￼
Example 2
Input: $str = "coding  is  fun"
Output: "coding  is  fun"

We have 4 spaces and 3 words (2 gaps). So 2 spaces per gap.
￼
Example 3
Input: $str = "a b c  d"
Output: "a b c d "

We have 4 spaces and 4 words (3 gaps). So 1 space per gap
and 1 remainder.
￼
Example 4
Input: $str = "  team      pwc  "
Output: "team          pwc"

We have 10 spaces and 2 words (1 gap). So 10 spaces per gap.
￼
Example 5
Input: $str = "   the  weekly  challenge  "
Output: "the    weekly    challenge "

We have 9 spaces and 3 words (2 gaps). So 4 spaces per gap
and 1 remainder.
￼

I can find the words by splitting on space. The number of gaps is one less than the number of words. The interword space is the number of spaces divided by the number of gaps. At the end I add the residual spaces, obtained using modular arithmetic. The code fits a two liner.

Examples:

perl -E '
for(@ARGV){$i=$_;@w=split" ";$l=0;$l+=length$1 while s/(\s+)//;($s,$r)=@w>1?
($l/(@w-1),$l%(@w-1)):(0,$l);$j=" "x$s;say "\"$i\" -> \"", join($j,@w)," "x$r,"\"";}
'    "  challenge  " "coding  is  fun" "a b c  d" \
     "  team      pwc  " "   the  weekly  challenge  "

Results:

"  challenge  " -> "challenge    "
"coding  is  fun" -> "coding  is  fun"
"a b c  d" -> "a b c d "
"  team      pwc  " -> "team          pwc"
"   the  weekly  challenge  " -> "the    weekly    challenge "

The full code is:

# Perl weekly challenge 372
# Task 1:  Rearrange Spaces
#
# See https://wlmb.github.io/2026/05/04/PWC372/#task-1-rearrange-spaces
use v5.36;
die <<~"FIN" unless @ARGV;
    Usage: $0 S0 S1...
    to rearrange the spaces in string Sn leaving equal gaps
    between words.
    FIN
for(@ARGV){
    my $input = $_;
    my @words = split" ";
    my $length = 0;
    $length += length $1 while s/(\s+)//;
    my ($spaces, $rest) = @words > 1
       ? ($length / (@words-1), $length % (@words-1))
       : (0,$length);
    my $sep = " " x $spaces;
    say "\"$input\" -> \"", join($sep, @words), " "x$rest, "\"";
}

Example:

./ch-1.pl "  challenge  " "coding  is  fun" "a b c  d" \
          "  team      pwc  " "   the  weekly  challenge  "

Results:

"  challenge  " -> "challenge    "
"coding  is  fun" -> "coding  is  fun"
"a b c  d" -> "a b c d "
"  team      pwc  " -> "team          pwc"
"   the  weekly  challenge  " -> "the    weekly    challenge "

Task 2: Largest Substring

Submitted by: Mohammad Sajid Anwar
You are given a string.

Write a script to return the length of the largest substring
between two equal characters excluding the two
characters. Return -1 if there is no such substring.

Example 1
Input: $str = "aaaaa"
Output: 3

For character "a", we have substring "aaa".

Example 2
Input: $str = "abcdeba"
Output: 5

For character "a", we have substring "bcdeb".

Example 3
Input: $str = "abbc"
Output: 0

For character "b", we have substring "".

Example 4
Input: $str = "abcaacbc"
Output: 4

For character "a", we have substring "bca".
For character "b", we have substring "caac".
For character "c", we have substring "aacb".

Example 5
Input: $str = "laptop"
Output: 2

For character "p", we have substring "to".

For each character $_ in the input, I try to match against /$_(.*)$_/. If succesful, I add the length of the matched substring to a list, and if unsuccesful I add -1. The result is the max (from List::Util) of the list. The result fits a one-liner.

Examples:

perl -MList::Util=max -E '
for(@ARGV){$i=$_;say "$_ -> ", max map {$i=~m/$_(.*)$_/?length($1):-1} split "";}
' aaaaa abcdeba abbc abcaacbc laptop

Results:

aaaaa -> 3
abcdeba -> 5
abbc -> 0
abcaacbc -> 4
laptop -> 2

Output: 3 Output: 5 Output: 0 Output: 4 Output: 2

The full code is similar. I use uniq from List::Util to avoid redundant work.

# Perl weekly challenge 372
# Task 2:  Largest Substring
#
# See https://wlmb.github.io/2026/05/04/PWC372/#task-2-largest-substring
use v5.36;
use List::Util qw(max uniq);
die <<~"FIN" unless @ARGV;
    Usage: $0 S0 S1...
    to find the length of the largest substring of Sn
    between equal characters
    FIN
for(@ARGV){
    my $input = $_;
    say "$_ -> ",
        max
        map {$input =~ m/$_(.*)$_/?length($1):-1;}
        uniq
        split "";
}

Examples:

./ch-2.pl aaaaa abcdeba abbc abcaacbc laptop

Results:

aaaaa -> 3
abcdeba -> 5
abbc -> 0
abcaacbc -> 4
laptop -> 2

Mail

2026-04-28T00:00:00+00:00

How to compose and send customized emails to a list of recipients using Perl and Mail::Message.

Yesterday I made an invitation to a concert and sent it to a longish list of friends. To that end I made a table with the needed fields for each correspondent and a program similar to the following. I post them here for my own reference, but they may prove useful to someone else.

#+name: list

formal	name	emails	Intro	custom	Extra
A Very Long Name	Shorty	,	Hi	something	1
Prof. First Second Last	Last		Dear Prof.	anything

#+name: invite
#+begin_src perl -n :results output :var list=list

use v5.36;
use Mail::Message;
use Encode;
my $count=0;
my $time=0;
for($list->@*){
    my ($formal, $short, $emails, $intro, $custom, $extra)=@$_;
    my $to = "$formal $emails";
    my $extra_text=$extra?"You can selectively interpolate additional text\n":"";
    my $body = decode("UTF8", <<~"END");
    $Intro $name,
    This is the main text of the email, in which I can interpolate $custom.
    $extra_text
    Regards,
    Myself
    Attachment: Some image
    END

    my $msg = Mail::Message->build(
	From    => 'My Name ',
	To      => $to,
	Subject => 'Subject',
	data => $body,
	file => "$ENV{HOME}/path/to/image.png"
	);
    $msg->send;
    my $delta_t=1+ rand(1);
    sleep $delta_t;
    $time += $delta_t;
    ++$count;
    say "$count $time $formal";
}

I use the var mechanism of emacs’ org-mode to import the table as a nested array reference into the program. For each line I make a customized email. Notice that in order to attach a file such as an image it is enough to include a line like 24. I asked chatgpt about adding attachments to Mail::Message objects. I got several contradictory and wrong answers, but I finally read the manual. Mail::Message figures out all the mime magick. Furthermore, I used decode from Encode in order to use UTF-8 characters such as accented characters in the body of the message. It seems not to be necessary for the names of the recipients nor the sender. I added some random sleep time after each message (lines 27 and 28), actually, much longer than shown here, in order not to abuse the network and not to appear to be a spammer.

Perl Weekly Challenge 371.

2026-04-27T00:00:00+00:00

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 371.

Task 1: Missing Letter

Submitted by: Reinier Maliepaard
You are given a sequence of 5 lowercase letters, with one
letter replaced by ‘?’. Each letter maps to its position in
the alphabet (‘a = 1’, ‘b = 2’, …, ‘z = 26’). The sequence
follows a repeating pattern of step sizes between
consecutive letters. The pattern is either a constant step
(e.g., ‘+2, +2, +2, +2’) or a simple alternating pattern of
two distinct steps (e.g., ‘+2, +3, +2, +3’).

Example 1
Input: @seq = qw(a c ? g i)
Output: e

The pattern of the sequence is +2,+2,+2,+2.
1: a
3: c
5: e
7: g
9: i
￼
Example 2
Input: @seq = qw(a d ? j m)
Output: g

The pattern of the sequence is +3,+3,+3,+3.
1: a
4: d
7: g
10: j
13: m
￼
Example 3
Input: @seq = qw(a e ? m q)
Output: i

The pattern of the sequence is +4,+4,+4,+4.
1: a
5: e
9: i
13: m
17: q
￼
Example 4
Input: @seq = qw(a c f ? k)
Output: h

The pattern of the sequence is +2,+3,+2,+3.
1: a
3: c
6: f
8: h
11: k
￼
Example 5
Input: @seq = qw(b e g ? l)
Output: j

The pattern of the sequence is +3,+2,+3,+2.
2: b
5: e
7: g
10: j
12: l
￼

The simple pattern, with spacing m, is a particular case of the alternating pattern, with spacings m and n. Assuming the input is well formed, I need two consecutive values to get both n and m. For example, if the question mark is at position 0, I can use the intervals between positions 1 and 2, and between positions 2 and 3, i.e., the intervals starting at 1 and at 2, as they are unrelated to the unknown element at 0. Similarly, if the question mark is at position 2, I could use the intervals 3-4 and 0-1. Notice that 0 and 3 have opposite parity, so they information yielded by the two intervals is not redundant. I make a small table to illustrate this.

Position of ?	Interval 1	Interval 2
0	1-2	2-3
1	2-3	3-4
2	3-4	0-1
3	0-1	1-2
4	1-2	2-3

Notice that in all cases, if the question mark is at position k, I can use the intervals starting at k+1 and k+2, both modulo 4. Finally, after finding both n and m I can reconstruct the character at position k from that at position k-1 or that at position k+1. This yields a 2-liner.

Examples:

perl -E '
for(@ARGV){/^(.*)\?.*$/;$k=length($1);@x=map{ord}split"";@s=map{$x[$_+1]-$x[$_]}
map{$_%4}($k+1,$k+2);say "$_ -> ", chr($k?$x[$k-1]+$s[0]:$x[$k+1]-$s[1]);}
' ac?gi ad?jm ae?mq acf?k beg?l

Results:

ac?gi -> e
ad?jm -> g
ae?mq -> i
acf?k -> h
beg?l -> j

For the full code I add a couple of tests.

# Perl weekly challenge 371
# Task 1:  Missing Letter
#
# See https://wlmb.github.io/2026/04/27/PWC371/#task-1-missing-letter
use v5.36;
use feature qw(try);
die <<~"FIN" unless @ARGV;
    Usage: $0 S0 S1...
    to find the missing letter in string Sn.
    The strings should contain four lower case English letters a-z and
    exactly one question mark, and they should be compatible with
    a simple or an alternating sequence.
    FIN
my $length=5;
for(@ARGV){
    try {
        die "Wrong length: $_" unless length$_ == $length;
        die "Only lowercase English letters or question marks allowed: $_" unless /^([a-z]|\?)*$/;
        die "Expected only one question mark: $_" if /\?(.*)\?/;
        die "Expected a question mark: $_" unless /^(.*)\?(.*)$/;
        my $unknown = length($1);
        my @codes = map{ord} split "";
        my @separations = map{$codes[$_+1]-$codes[$_]}
                          map {$_% ($length-1)}
                          ($unknown+1, $unknown+2);
        my @newcodes;
        $newcodes[0] = $unknown?$codes[0]:$codes[1]-$separations[1];
        @newcodes[$_]=$newcodes[$_-1] + $separations[($unknown+$_)%2] for 1..$length-1;
        die "Replacement out of range: $_" unless ord("a") <= $newcodes[$unknown] <= ord("z");
        my $newstring = join "", map {chr} @newcodes;
        my $re=s/^(.*)\?(.*)$/$1.$2/r;
        die "Inconsistent string: $_" unless $newstring=~/$re/;
        say "$_ -> ", chr $newcodes[$unknown];
    }
    catch($e) { warn $e; }
}

Examples:

./ch-1.pl ac?gi ad?jm ae?mq acf?k beg?l

Results:

ac?gi -> e
ad?jm -> g
ae?mq -> i
acf?k -> h
beg?l -> j

Other examples:

./ch-1.pl 2>&1 abc a?c AB?DE a?c?e abcde ?abcd wxyz? ab?ef

Results:

Wrong length: abc at ./ch-1.pl line 18.
Wrong length: a?c at ./ch-1.pl line 18.
Only lowercase English letters or question marks allowed: AB?DE at ./ch-1.pl line 19.
Expected only one question mark: a?c?e at ./ch-1.pl line 20.
Expected a question mark: abcde at ./ch-1.pl line 21.
Replacement out of range: ?abcd at ./ch-1.pl line 30.
Replacement out of range: wxyz? at ./ch-1.pl line 30.
Inconsistent string: ab?ef at ./ch-1.pl line 33.

Task 2: Subset Equilibrium

Submitted by: Mohammad Sajid Anwar
You are given an array of numbers.

Write a script to find all proper subsets with more than one
element where the sum of elements equals the sum of their
indices.

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

Subset 1: (2, 1)
Values: 2 + 1 = 3
Positions: 1 + 2 = 3

Subset 2: (1, 4)
Values: 1 + 4 = 5
Positions: 2 + 3 = 5

Subset 3: (4, 3)
Values: 4 + 3 = 7
Positions: 3 + 4 = 7

Subset 4: (2, 3)
Values: 2 + 3 = 5
Positions: 1 + 4 = 5
￼
Example 2
Input: @nums = (3, 0, 3, 0)
Output: (3, 0), (3, 0, 3)

Subset 1: (3, 0)
Values: 3 + 0 = 3
Positions: 1 + 2 = 3

Subset 2: (3, 0, 3)
Values: 3 + 0 + 3 = 6
Positions: 1 + 2 + 3 = 6
￼
Example 3
Input: @nums = (5, 1, 1, 1)
Output: (5, 1, 1)

Subset 1: (5, 1, 1)
Values: 5 + 1 + 1 = 7
Positions: 1 + 2 + 4 = 7
￼
Example 4
Input: @nums = (3, -1, 4, 2)
Output: (3, 2), (3, -1, 4)

Subset 1: (3, 2)
Values: 3 + 2 = 5
Positions: 1 + 4 = 5

Subset 2: (3, -1, 4)
Values: 3 + (-1) + 4 = 6
Positions: 1 + 2 + 3 = 6
￼
Example 5
Input: @nums = (10, 20, 30, 40)
Output: ()

The examples show that the same numbers at different positions are to be considered as different set elements. There is a small notational error in example 5 above, as it seems to imply that the empty subset is the answer, while it is meant that the set of answers is empty. This could be fixed by using extra parenthesis in the answers of all the previous examples. I use subsets from Algorithm::Combinatorics to build all proper subsets and I filter them to keep those that are in equilibrium and have the appropriate length. I also use sum from List::Util to check the balance. The problem setup is based on one-based arrays, so in Perl I have to add the number of indices to the sum of indices. The result fits a two-liner.

Examples:

perl -MAlgorithm::Combinatorics=subsets -MList::Util=sum -E '
for(@ARGV){@d=split" ";@i=0..@d-1;@r=map{"[@d[@$_]]"}grep{1<@$_<@d
&&sum(@$_)+@$_==sum @d[@$_]}subsets(\@i);say"$_ -> [ @r ]";}
' -- "2 1 4 3" "3 0 3 0" "5 1 1 1" "3 -1 4 2" "10 20 30 40"

Results:

1 4 3 -> [ [4 3] [2 3] [1 4] [2 1] ]
0 3 0 -> [ [3 0 3] [3 0] ]
1 1 1 -> [ [5 1 1] ]
-1 4 2 -> [ [3 2] [3 -1 4] ]
20 30 40 -> [  ]

The full code is:

# Perl weekly challenge 371
# Task 2:  Subset Equilibrium
#
# See https://wlmb.github.io/2026/04/27/PWC371/#task-2-subset-equilibrium
use v5.36;
use feature qw(try);
use Algorithm::Combinatorics qw(subsets);
use List::Util qw(all sum);
use Scalar::Util qw(looks_like_number);
die <<~"FIN" unless @ARGV;
    Usage: $0 S0 S1...
    to find the subsets of the space separated sets of numbers
    Sn whose sum equal the sum of their indices (one-based).
    FIN
for(@ARGV){
    try {
        my @numbers = split " ";
        die "Expected space separated numbers: $_"
            unless all {looks_like_number $_} @numbers;
        my @indices = 0..@numbers-1;
        my @results = map{
            "[@numbers[@$_]]"
        } grep {
            1 < @$_ < @numbers                  #check length of subset
            && sum(@$_)+@$_== sum @numbers[@$_] # check sums
        }
        subsets(\@indices);
        say"$_ -> [ @results ]";
    }
    catch($e){ warn $e; }
}

Example:

./ch-2.pl "2 1 4 3" "3 0 3 0" "5 1 1 1" "3 -1 4 2" "10 20 30 40"

Results:

1 4 3 -> [ [4 3] [2 3] [1 4] [2 1] ]
0 3 0 -> [ [3 0 3] [3 0] ]
1 1 1 -> [ [5 1 1] ]
-1 4 2 -> [ [3 2] [3 -1 4] ]
20 30 40 -> [  ]

Notice that if large arrays are expected, then subsets can be used as an iterator, to generate and process the subsets one by one in a loop, instead of using grep and map.

Euclidea

2026-04-23T00:00:00+00:00

Problem β-4: Find a tangent to a circle at a point.

Solution

Draw a circle with center at O and the given point p.
Draw an arbitrary point q on the circle.
Draw a circle centered on q through p,
This defines a second intersection r between the circles. Draw a circle centered on p through r.
This intersects the second circle at s. Finally, the line ps is the desired tangent to the first circle at p.

Proof

Draw the radius Op of the first circle and the lines pr, pq, ps, qr, qs, rs and the angles α (pOq), β (prq), γ (qpr), δ (qps), ε (rpO), and φ (Oqp).

As p and q are on a circle centered at O, and r is another point on the same circle, then β=α/2. As p and r are also in a circle centered at q, the triangle pqr is isosceles. Therefore, γ=β=α/2. The sides of triangle pqs are the same as those of rqp; both triangles are congruent. Thus, δ=γ=α/2. The triangle pOq is isosceles, and therefore, the angle φ =ε+γ is (π-α)/2 and ε=π/2-α. Finally, the angle between the radius Op and the line ps is ε+γ+δ=(π/2-α)+(α/2)+(α/2)=π/2. As ps is orthogonal to the radius Op, it is tangent at p to the circle of radius Op, qed.

Perl Weekly Challenge 370.

2026-04-20T00:00:00+00:00

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 370.

Task 1: Popular Word

Submitted by: Mohammad Sajid Anwar
You are given a string paragraph and an array of the banned words.

Write a script to return the most popular word that is not
banned. It is guaranteed there is at least one word that is
not banned and the answer is unique. The words in paragraph
are case-insensitive and the answer should be in
lowercase. The words can not contain punctuation symbols.

Example 1
Input: $paragraph = "Bob hit a ball, the hit BALL flew far after it was hit."
       @banned = ("hit")
Output: "ball"

After removing punctuation and converting to lowercase, the
word "hit" appears 3 times, and "ball" appears 2 times.
Since "hit" is on the banned list, we ignore it.

Example 2
Input: $paragraph = "Apple? apple! Apple, pear, orange, pear, apple, orange."
       @banned = ("apple", "pear")
Output: "orange"

"apple"  appears 4 times.
"pear"   appears 2 times.
"orange" appears 2 times.

"apple" and "pear" are both banned.
Even though "orange" has the same frequency as "pear", it is
the only non-banned word with the highest frequency.

Example 3
Input: $paragraph = "A. a, a! A. B. b. b."
       @banned = ("b")
Output: "a"

"a" appears 4 times.
"b" appears 3 times.

The input has mixed casing and heavy punctuation.
The normalised, "a" is the clear winner, since "b" is
banned, "a" is the only choice.

Example 4
Input: $paragraph = "Ball.ball,ball:apple!apple.banana"
       @banned = ("ball")
Output: "apple"

Here the punctuation acts as a delimiter.
"ball"   appears 3 times.
"apple"  appears 2 times.
"banana" appears 1 time.

Example 5
Input: $paragraph = "The dog chased the cat, but the dog was faster than the cat."
       @banned = ("the", "dog")
Output: "cat"

"the" appears 4 times.
"dog" appears 2 times.
"cat" appears 2 times.

"chased", "but", "was", "faster", "than" appear 1 time each.
"the" is the most frequent but is banned.
"dog" is the next most frequent but is also banned.
The next most frequent non-banned word is "cat".

I assume @ARGV is of the form P0 B0 P1 B1… where Pn is a paragraph and Bn a space separated list of banned words. First I split the banned words a use them to build a hash. I split the lowercased paragraph into (alphabetical) words, grep out the valid words using the banned hash, count the frequency of each valid word and find their max_by frequency (from List::UtilsBy). The result fits a two-liner.

Examples:

perl -MList::UtilsBy=max_by -E '
for my($p,$b)(@ARGV){my(%b,%w);++$b{$_} for split" ",$b;++$w{$_}for grep
{!$b{$_}}split/[^a-z]+/,lc $p;say "p=$p b=$b -> ", max_by{$w{$_}}keys %w;}
' \
"Bob hit a ball, the hit BALL flew far after it was hit." "hit" \
"Apple? apple! Apple, pear, orange, pear, apple, orange." "apple pear" \
"A. a, a! A. B. b. b." "b" \
"Ball.ball,ball:apple!apple.banana" "ball" \
"The dog chased the cat, but the dog was faster than the cat." "the dog"

Results:

p=Bob hit a ball, the hit BALL flew far after it was hit. b=hit -> ball
p=Apple? apple! Apple, pear, orange, pear, apple, orange. b=apple pear -> orange
p=A. a, a! A. B. b. b. b=b -> a
p=Ball.ball,ball:apple!apple.banana b=ball -> apple
p=The dog chased the cat, but the dog was faster than the cat. b=the dog -> cat

The full code is:

# Perl weekly challenge 370
# Task 1:  Popular Word
#
# See https://wlmb.github.io/2026/04/20/PWC370/#task-1-popular-word
use v5.36;
use List::UtilsBy qw(max_by);
die <<~"FIN" unless @ARGV and @ARGV%2==0;
    Usage: $0 P0 B0 P1 B1...
    where Pn is a paragraph and Bn is a space separated list
    if banned words, to find the most frequent permitted word
    of each paragraph.
    FIN
for my($paragraph, $banned)(@ARGV){
    my %banned;
    my %words;
    ++$banned{$_} for split " ", $banned;
    ++$words{$_} for
        grep {!$banned{$_}}
        split/[^a-z]+/,
        lc $paragraph;
    print <<~"END";
        Paragraph="$paragraph";
        banned="$banned"
        END
    say "    -> ", max_by{$words{$_}} keys %words;
}

Example:

./ch-1.pl \
"Bob hit a ball, the hit BALL flew far after it was hit." "hit" \
"Apple? apple! Apple, pear, orange, pear, apple, orange." "apple pear" \
"A. a, a! A. B. b. b." "b" \
"Ball.ball,ball:apple!apple.banana" "ball" \
"The dog chased the cat, but the dog was faster than the cat." "the dog"

Results:

Paragraph="Bob hit a ball, the hit BALL flew far after it was hit.";
banned="hit"
    -> ball
Paragraph="Apple? apple! Apple, pear, orange, pear, apple, orange.";
banned="apple pear"
    -> orange
Paragraph="A. a, a! A. B. b. b.";
banned="b"
    -> a
Paragraph="Ball.ball,ball:apple!apple.banana";
banned="ball"
    -> apple
Paragraph="The dog chased the cat, but the dog was faster than the cat.";
banned="the dog"
    -> cat

Task 2: Scramble String

Submitted by: Roger Bell-West
You are given two strings A and B of the same length.

Write a script to return true if string B is a scramble of
string A otherwise return false.

String B is a scramble of string A if A can be transformed
into B by a single (recursive) scramble operation.

A scramble operation is:

- If the string consists of only one character, return the string.
- Divide the string X into two non-empty parts.
- Optionally, exchange the order of those parts.
- Optionally, scramble each of those parts.
- Concatenate the scrambled parts to return a single string.

Example 1
Input: $str1 = "abc", $str2 = "acb"
Output: true

"abc"
split: ["a", "bc"]
split: ["a", ["b", "c"]]
swap: ["a", ["c", "b"]]
concatenate: "acb"

Example 2
Input: $str1 = "abcd", $str2 = "cdba"
Output: true

"abcd"
split: ["ab", "cd"]
swap: ["cd", "ab"]
split: ["cd", ["a", "b"]]
swap: ["cd", ["b", "a"]]
concatenate: "cdba"

Example 3
Input: $str1 = "hello", $str2 = "hiiii"
Output: false

A fundamental rule of scrambled strings is that they must be anagrams.

Example 4
Input: $str1 = "ateer", $str2 = "eater"
Output: true

"ateer"
split: ["ate", "er"]
split: [["at", "e"], "er"]
swap: [["e", "at"], "er"]
concatenate: "eater"

Example 5
Input: $str1 = "abcd", $str2 = "bdac"
Output: false

I do a recursive sub to check if two words are scrambled versions of each other. The result is trivial if the strings are identical or if they contain different sets of letters. If not, then I split the first string into a pairs of different lengths, and compare each of the substrings with the correspondingly sized substrings of the other string before and if necessary after transposing them until I succeed. If every splitting fails, the whole test fails. The result can be fitted to a 4-liner, not that it makes much sense.

Examples:

perl -MList::Util=none -E '
for my($v,$w)(@ARGV){say "$v, $w -> ",c($v, $w)?"T":"F";}sub f($x,$y,$z){substr($x,$y,$z)}sub c($v,
$w){return 1if$v eq$w;my%l;++$l{$_}for split"",$v;--$l{$_}for split"",$w;return 0unless none{$_}
values %l;my$s=length$v;for my$i(1..$s-1){return 1if(c(f($v,0,$i),f($w,0,$i))&&c(f($v,$i,$s-$i),
f($w,$i,$s-$i)))||(c(f($v,$i,$s-$i),f($w,0,$s-$i))&&c(f($v,0,$i),f($w,$s-$i,$i)));}return 0;}
' abc acb abcd cdba hello hiiii ateer eater abcd bdac

Results:

abc, acb -> T
abcd, cdba -> T
hello, hiiii -> F
ateer, eater -> T
abcd, bdac -> F

By the way, trying to compact the above program I learned that intrinsic functions such as substr may not be called using the goto & syntax nor using @arrays instead of spelling out all arguments.

The full code is:

# Perl weekly challenge 370
# Task 2:  Scramble String
#
# See https://wlmb.github.io/2026/04/20/PWC370/#task-2-scramble-string
use v5.36;
use List::Util qw(none);
die <<~"FIN" unless @ARGV && @ARGV%2==0;
    Usage: $0 A0 B0 A1 B1...
    to check if string Bn may be obtained by scrambling string An.
    FIN

for my ($word1, $word2)(@ARGV){
    say "$word1, $word2 -> ", check($word1, $word2)?"True":"False";
}

sub check($word1, $word2){
    return 1 if $word1 eq $word2;
    my %letters;
    ++$letters{$_} for split "", $word1;
    --$letters{$_} for split "", $word2;
    return 0 unless none {$_} values %letters;
    my $length = length $word1;
    for my $i(1..$length-1){
        return 1
            if (check(substr($word1, 0, $i), substr($word2,0,$i))
                && check(substr($word1,$i,$length-$i), substr($word2,$i,$length-$i)))
            || (check(substr($word1, $i, $length-$i), substr($word2,0,$length-$i))
                && check(substr($word1,0, $i), substr($word2,$length-$i,$i)))
            ;
    }
    return 0;
}

Example:

./ch-2.pl  abc acb abcd cdba hello hiiii ateer eater abcd bdac

Results:

abc, acb -> True
abcd, cdba -> True
hello, hiiii -> False
ateer, eater -> True
abcd, bdac -> False