Jekyll2026-09-01T01:05:29+00:00http://em.fis.unam.mx/feed.xmlW. Luis Mochán. Blog.["Físico, investigador del ICF-UNAM.", "Physicist, researcher at ICF-UNAM."]Perl Weekly Challenge 389.2026-08-31T00:00:00+00:002026-08-31T00:00:00+00:00http://em.fis.unam.mx/2026/08/31/PWC389My solutions (task 1 and task 2 ) to the The Weekly Challenge - 389.

Task 1: Reorder Notes

Submitted by: Reinier Maliepaard

You are given an array [composer, notes, permutation],
reconstruct the melody by using each permutation value as
the destination position of the corresponding note. Use no
explicit for, foreach, or while loops. Output each result as
COMPOSER => reordered notes.

ASSUMPTION: Input is valid; the notes array and permutation
array have identical lengths, and the permutation contains
each position from 1 to N exactly once.

Example 1
Input: $melody = ['Bach', [qw(C D E F# G A B)], [7, 1, 6, 2, 5, 3, 4]]
Output: BACH => D F# A B G E C

Note 1 (C)  moves to position 7.
Note 2 (D)  moves to position 1.
Note 3 (E)  moves to position 6.
Note 4 (F#) moves to position 2.
Note 5 (G)  moves to position 5.
Note 6 (A)  moves to position 3.
Note 7 (B)  moves to position 4.

Example 2
Input: $melody = ['Beethoven', [qw(C D F# G Ab)], [1, 3, 5, 2, 4]]
Output: BEETHOVEN => C G D Ab F#

Note 1 (C)  stays at position 1.
Note 2 (D)  moves to position 3.
Note 3 (F#) moves to position 5.
Note 4 (G)  moves to position 2.
Note 5 (Ab) moves to position 4.

Example 3
Input: $melody = [ 'Brahms',
                 [qw(C Db Eb F G Ab Bb C D)],
                 [9, 3, 7, 1, 8, 5, 2, 6, 4] ]
Output: BRAHMS => F Bb Db D Ab C Eb G C

Example 4
Input: $melody = [ 'Bruckner',
                 [qw(G F# Bb C D Eb F)],
                 [4, 7, 2, 6, 1, 5, 3] ]
Output: BRUCKNER => D Bb F G Eb C F#

Example 5
Input: $melody = ['Berg', [qw(C#)], [1]]
Output: BERG => C#

Instead of explicit loops I could use tail recursion. I use a recursive function to walk over @ARGV, three terms at a time, taking advantage of the old parameter style, and I make another recursive function to build the output array, one note at a time. The result fits a two-liner.

Examples:

perl -E '
sub f{($C,$N,$P,@R)=@_;say("$C -> ",join " ",g([],map{[split" "]}$N,$P)->@*),
f(@R)if$C;}sub g($C,$N,$P){$C->[pop @$P]=pop@$N,g($C,$N,$P)if @$N;$C}f(@ARGV);
' 'Bach' 'C D E F# G A B' '7 1 6 2 5 3 4' \
  'Beethoven' 'C D F# G Ab' '1 3 5 2 4' \
  'Brahms' 'C Db Eb F G Ab Bb C D' '9 3 7 1 8 5 2 6 4' \
  'Bruckner' 'G F# Bb C D Eb F' '4 7 2 6 1 5 3' \
  'Berg' 'C#' '1'

Results:

Bach ->  D F# A B G E C
Beethoven ->  C G D Ab F#
Brahms ->  F Bb Db D Ab C Eb G C
Bruckner ->  D Bb F G Eb C F#
Berg ->  C#

The full code is:

 1  # Perl weekly challenge 389
 2  # Task 1:  Reorder Notes
 3  #
 4  # See https://wlmb.github.io/2026/08/31/PWC389/#task-1-reorder-notes
 5  use v5.36;
 6  use feature qw(try);
 7  use List::Util qw(all);
 8  die <<~"FIN" unless @ARGV and @ARGV%3==0;
 9      Usage: $0 C0 N0 P0 C1 N1 P1...
10      to arrange the notes Ni of the composition by composer Ci
11      applying the permutation Pi
12      FIN
13  
14  sub walk{
15      my ($composer, $notes, $permutations, @rest) = @_;
16      if($composer){
17              try {
18                  my @notes = split " ", $notes;
19                  my @permutations = split " ", $permutations;
20                  die "Number of notes should equal number of permutations"
21                      unless @notes==@permutations;
22                  die "Index out of range" unless all {1<=$_<=@permutations} @permutations;
23                  say "$composer -> ",
24                      join " ",
25                      permute_notes([], [@notes], [@permutations])->@*;
26              }
27              catch($e){
28                  warn "${e}Composer=$composer, Notes=$notes, Permutation=$permutations";
29              }
30              walk(@rest);
31      }
32  }
33  
34  sub permute_notes($current, $notes, $permutations){
35      if(@$notes){
36          my $note=pop @$notes;
37          my $place=pop @$permutations;
38          die "Repeated destination: $place" if defined $current->[$place-1];
39          $current->[$place-1]=$note;
40          permute_notes($current, $notes, $permutations)
41      }
42      return $current;
43  }
44  
45  walk(@ARGV);

Examples:

./ch-1.pl  'Bach' 'C D E F# G A B' '7 1 6 2 5 3 4' \
            'Beethoven' 'C D F# G Ab' '1 3 5 2 4' \
            'Brahms' 'C Db Eb F G Ab Bb C D' '9 3 7 1 8 5 2 6 4' \
            'Bruckner' 'G F# Bb C D Eb F' '4 7 2 6 1 5 3' \
            'Berg' 'C#' '1'

Results:

Bach -> D F# A B G E C
Beethoven -> C G D Ab F#
Brahms -> F Bb Db D Ab C Eb G C
Bruckner -> D Bb F G Eb C F#
Berg -> C#

Examples with errors:

./ch-1.pl 2>&1 'Bach' 'C D E F# G A B' '1 6 2 5 3 4' \
            'Beethoven' 'C D F# G Ab' '1 1 5 2 4' \
            'Brahms' 'C Db Eb F G Ab Bb C D' '10 3 7 1 8 5 2 6 4' \
            'Bruckner' 'G F# Bb C D Eb F' '0 7 2 6 1 5 3' \

Results:

Number of notes should equal number of permutations at ./ch-1.pl line 21.
Composer=Bach, Notes=C D E F# G A B, Permutation=1 6 2 5 3 4 at ./ch-1.pl line 29.
Repeated destination: 1 at ./ch-1.pl line 39.
Composer=Beethoven, Notes=C D F# G Ab, Permutation=1 1 5 2 4 at ./ch-1.pl line 29.
Index out of range at ./ch-1.pl line 23.
Composer=Brahms, Notes=C Db Eb F G Ab Bb C D, Permutation=10 3 7 1 8 5 2 6 4 at ./ch-1.pl line 29.
Index out of range at ./ch-1.pl line 23.
Composer=Bruckner, Notes=G F# Bb C D Eb F, Permutation=0 7 2 6 1 5 3 at ./ch-1.pl line 29.

Task 2: ZigZag Subarray

Submitted by: Roger Bell_West
You are given an array of integers.

Write a script to find the length of the longest contiguous
subarray where the numbers alternate between strictly
increasing and strictly decreasing (a ZigZag pattern).

A sequence of numbers $A = [a0, a1, …, ak]$ with length $k
>= 1 is considered a ZigZag sequence if every adjacent pair
alternates direction:

a_0 < a_1 > a_2 < a_3 > ...
OR
a_0 > a_1 < a_2 > a_3 < ...

NOTE: A single element (length 1) or any two distinct
elements (length 2) are automatically valid ZigZag
sequences. Equal adjacent numbers (e.g., 5, 5) break the
pattern.

Example 1
Input: @nums = (9, 4, 2, 10, 7, 8, 8, 1, 9)
Output: 5

ZigZag subarray: (4, 2, 10, 7, 8)

Example 2
Input: @nums = (1, 7, 4, 9, 2, 5)
Output: 6

ZigZag subarray: (1, 7, 4, 9, 2, 5)

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

ZigZag subarray: (1, 2)

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

Example 5
Input: @nums = (10, 20, 15, 12, 18)
Output: 3

ZigZag subarray: (10, 20, 15)

I use the spaceship operator <=> to compare succesive terms in the array. I change sign to each second comparison result. A zigzag sequence corresponds to a sequence of 1’s or of -1’s. Thus I count all such sequences and chose the largest using the max function from List::Util. The result fits a 2.5-liner.

Examples:

perl -MList::Util=max -E '
for(@ARGV){($c,@r)=split" ";push(@s,$c<=>($d=shift @r)),$c=$d while(@r);$s[2*$_]*=-1
for 0..(@s-1)/2;my @r;while(@s){$c=1;$d=shift@s;++$c if$d;++$c,shift @s while$s[0]*$d==1;
push@r,$c;}say "$_ -> ", max @r}
' "9 4 2 10 7 8 8 1 9"  "1 7 4 9 2 5" "1 2 3 4 5" "4 4 4" "10 20 15 12 18"

Results:

9 4 2 10 7 8 8 1 9 -> 5
1 7 4 9 2 5 -> 6
1 2 3 4 5 -> 2
4 4 4 -> 1
10 20 15 12 18 -> 3

The full code is:

 1  # Perl weekly challenge 389
 2  # Task 2:  ZigZag Subarray
 3  #
 4  # See https://wlmb.github.io/2026/08/31/PWC389/#task-2-zigzag-subarray
 5  use v5.36;
 6  use List::Util qw(max);
 7  die <<~"FIN" unless @ARGV;
 8      Usage: $0 S0 S1...
 9      to find the longest zigzag subsequence of the space separated
10      sequence Si="N0 N1..." where Nj are numbers.
11      FIN
12  
13  for(@ARGV){
14      my ($current, @rest)=split" ";
15      my @signs;
16      while(@rest){
17          push(@signs, $current <=> (my $next = shift @rest));
18          $current = $next;
19      }
20      $signs[2*$_] *= -1 for 0..(@signs-1)/2;
21      my @lengths;
22      while(@signs){
23          my $count = 1;
24          my $first_sign = shift @signs;
25          ++$count if $first_sign;
26          ++$count, shift @signs while @signs && $signs[0]*$first_sign==1;
27          push @lengths, $count;
28      }
29      say "$_ -> ", max @lengths;
30  }

Example:

./ch-2.pl "9 4 2 10 7 8 8 1 9"  "1 7 4 9 2 5" "1 2 3 4 5" "4 4 4" "10 20 15 12 18"

Results:

9 4 2 10 7 8 8 1 9 -> 5
1 7 4 9 2 5 -> 6
1 2 3 4 5 -> 2
4 4 4 -> 1
10 20 15 12 18 -> 3

/;

]]>Perl Weekly Challenge 388.2026-08-24T00:00:00+00:002026-08-24T00:00:00+00:00http://em.fis.unam.mx/2026/08/24/PWC388My solutions (task 1 and task 2 ) to the The Weekly Challenge - 388.

Task 1: Dyck Words

Submitted by: Roger Bell_West
A Dyck Word of order $n is a string of length 2x$n consisting of $n
‘U’ (Up) characters and $n ‘D’ (Down) characters such that no initial
prefix of the string contains more ‘D’s than ‘U’s.

Write a script to return a list of all valid Dyck words of length
2x$n, sorted in lexicographical (alphabetical) order.

Example 1
Input: $n = 1
Output: ("UD")

Example 2
Input: $n = 2
Output: ("UDUD","UUDD")

Example 3
Input: $n = 3
Output: ("UDUDUD", "UDUUDD", "UUDDUD", "UUDUDD", "UUUDDD")

Example 4
Input: $n = 0
Output: ("")

Example 5
Input: $n = 4
Output: ("UDUDUDUD", "UDUDUUDD", "UDUUDDUD", "UDUUDUDD", "UDUUUDDD",
         "UUDDUDUD", "UUDDUUDD", "UUDUDDUD", "UUDUDUDD", "UUDUUDDD",
         "UUUDDDUD", "UUUDDUDD", "UUUDUDDD", "UUUUDDDD")


I consider a function n,m->f(n,m) equal to the number of valid ways in which I can take n pairs of letters of the form UU UD DU and DD so that the excess of U’s over D’s is 2m. Take any of those strings and split off the last pair. It may be UU, in which case the remaining string would have n-1 pairs and an excess m-1; it may be DD so the remaining string would have an excess m+1, and it could be UD or DU, in which case, the remaining string would have an excess m. Any string with a negative excess would be invalid. Thus, we have a recursive relation, f(n,m)=f(n-1,m-1)+2f(n-1,m)+f(n-1,m+1). There is an exception if m=0, as the left to right count of U’s - D’s should never be negative, so f(n,0)=f(n-1,0)+f(n-1,1). Furthermore, we have the boundary conditions f(n,m)=0 if m>n or m<0, and f(0,0)=1. With this ingredients, we can build a recursive procedure to count how many valid strings there are. The program fits a two-liner

Examples:

perl -MMemoize -E '
memoize "f";for(@ARGV){say"$_ -> ", f($_,0)}sub f($n,$m){return 0 if $m<0||$m>$n;return
1 if$n==0;--$n;return f($n,0)+f($n,1) if $m==0;f($n,$m-1)+2*f($n,$m)+f($n,$m+1)}
' 1 2 3 0 4

Results:

1 -> 1
2 -> 2
3 -> 5
0 -> 1
4 -> 14

The numbers agree with the results in the problem statement.

Furthermore, I can generate the actual strings using a similar recursive procedure and appending “UU”, “UD”, “DU” or “DD” to the previously generated strings, according to the to the desired transition m-1->m, m->m or m+1->m. The result fits a three-liner.

Examples:

perl -MMemoize -E '
memoize "f";for(@ARGV){say"$_ -> ", join " ",f($_,0)}sub f($n,$m){return()if$m<0||$m>$n;
return("")if$n==0;--$n;return (map{$_."UD"}f($n,0)),(map{$_."DD"}f($n,1))if$m==0;
(map{$_."UU"}f($n,$m-1)),(map{$_."UD",$_."DU"}f($n,$m)),map{$_."DD"}f($n,$m+1)}
' 1 2 3 0 4

Results:

1 -> UD
2 -> UDUD UUDD
3 -> UDUDUD UUDDUD UDUUDD UUUDDD UUDUDD
0 ->
4 -> UDUDUDUD UUDDUDUD UDUUDDUD UUUDDDUD UUDUDDUD
     UDUDUUDD UUDDUUDD UDUUUDDD UDUUDUDD UUUDUDDD
     UUUDDUDD UUDUUDDD UUDUDUDD UUUUDDDD

I used memoize to avoid unnecessary recalculation of sets of strings.

The full code is:

 1  # Perl weekly challenge 388
 2  # Task 1:  Dyck Words
 3  #
 4  # See https://wlmb.github.io/2026/08/24/PWC388/#task-1-dyck-words
 5  use v5.36;
 6  use Memoize;
 7  use Text::Wrap qw(wrap $columns);
 8  die <<~"FIN" unless @ARGV;
 9      Usage: $0 N0 N1...
10      to find all words formed by Nm letters U and Nm letters D
11      so that no prefix has more D's than U's.
12      FIN
13  memoize "dyck";
14  $columns = 60;
15  for(@ARGV){
16      say wrap "", "\t", "$_ -> ", map {"\"". $_ ."\""}  dyck($_);
17  }
18  
19  sub dyck($n,$m=0){
20      return () if$m<0||$m>$n;
21      return("") if $n==0;
22      return ( map {$_ . "UD"} dyck( $n-1, 0) ),
23               map {$_ . "DD"} dyck( $n-1, 1)
24          if $m == 0;
25      return ( map {$_ . "UU"} dyck($n-1, $m-1) ),
26             ( map {$_ . "UD", $_ . "DU"} dyck($n-1, $m) ),
27               map {$_ . "DD" } dyck($n-1, $m+1);
28  }

Examples:

./ch-1.pl 1 2 3 0 4

Results:

1 -> "UD"
2 -> "UDUD" "UUDD"
3 -> "UDUDUD" "UUDDUD" "UDUUDD" "UUUDDD" "UUDUDD"
0 -> ""
4 -> "UDUDUDUD" "UUDDUDUD" "UDUUDDUD" "UUUDDDUD" "UUDUDDUD"
      "UDUDUUDD" "UUDDUUDD" "UDUUUDDD" "UDUUDUDD"
      "UUUDUDDD" "UUUDDUDD" "UUDUUDDD" "UUDUDUDD"
      "UUUUDDDD"

Task 2: Secret Santa

Submitted by: Roger Bell_West
A company with $n employees is running a Secret Santa exchange. Each
employee buys one gift and receives one gift.

Write a script to return the total number of valid gift assignments
where no employee receives the gift they originally bought (i.e.,
employee $i must not be assigned gift $i).

Example 1
Input: $n = 1
Output: 0

Only 1 participant exists. They would have to receive their own gift,
which is invalid.

Example 2
Input: $n = 2
Output: 1

Participants 1 and 2 must swap gifts ([2, 1]).

Example 3
Input: $n = 3
Output: 2

The 2 valid gift arrays where array[i] is who person i+1 receives from:
[2, 3, 1]
[3, 1, 2]

Example 4
Input: $n = 4
Output: 9

The 9 valid arrays are:
[2, 1, 4, 3], [2, 3, 4, 1], [2, 4, 1, 3],
[3, 1, 4, 2], [3, 4, 1, 2], [3, 4, 2, 1],
[4, 1, 2, 3], [4, 3, 1, 2], [4, 3, 2, 1],

Example 5
Input: $n = 5
Output: 44

There are 44 valid permutations out of 5! = 120 total possible arrangements.

A very lazy solution can be obtained using the derangements function from the Algorithm::Combinatorics package, which yields all reorderings of an array so that no element remains in its place. The code takes a half-liner:

perl -MAlgorithm::Combinatorics=derangements -E '
say "$_ -> ", $x=()=derangements([1..$_]) for @ARGV;
' 1 2 3 4 5

Results:

1 -> 0
2 -> 1
3 -> 2
4 -> 9
5 -> 44

Note the use of the Saturn operator.

For the full code I compute the number of derangements using a recursive formula d(n)=n*d(n-1)+(-1)**n with initial value d(0)=1, without computing the actual derangements.

 1  # Perl weekly challenge 388
 2  # Task 2:  Secret Santa
 3  #
 4  # See https://wlmb.github.io/2026/08/24/PWC388/#task-2-secret-santa
 5  use v5.36;
 6  use Memoize;
 7  sub derange($n){
 8      die "Argument should be non-negative: $n" if $n<0;
 9      return 1 if $n==0;
10      return $n*derange($n-1)+($n%2==0?1:-1);
11  }
12  die <<~"FIN" unless @ARGV;
13      Usage: $0 N0 N1...
14      to find the number of derangements of Ni elements
15      FIN
16  memoize qw(derange);
17  say "$_ -> ", join " ", derange $_ for @ARGV;

Example:

./ch-2.pl 1 2 3 4 5

Results:

1 -> 0
2 -> 1
3 -> 2
4 -> 9
5 -> 44
]]>Perl Weekly Challenge 387.2026-08-17T00:00:00+00:002026-08-17T00:00:00+00:00http://em.fis.unam.mx/2026/08/17/PWC387My solutions (task 1 and task 2 ) to the The Weekly Challenge - 387.

Task 1: Rearrange Binary String

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

Write a script to re-arrange the given binary string that
all occurrences of “01” are simultaneously replaced with
“10” until no occurrences of “01” exist. Finally return the
total steps needed.

Example 1
Input: $str = "111000"
Output: 0

The string already has all 1s on the left and 0s on the right.
There are no occurrences of "01", so zero step needed.

Example 2
Input: $str = "00011"
Output: 4

Step 1: "00101"
Step 2: "01010"
Step 3: "10100"
Step 4: "11000"

Example 3
Input: $str = "01011"
Output: 3

Step 1: "10101"
Step 2: "11010"
Step 3: "11100"

Example 4
Input: $str = "010101"
Output: 3

Step 1: "101010"
Step 2: "110100"
Step 3: "111000"

Example 5
Input: $str = "00001"
Output: 4

Step 1: "00010"
Step 2: "00100"
Step 3: "01000"
Step 4: "10000"

A very simple solution consists on applying the transformation until no longer possible and count the number of operations. This yields a 1-liner.

perl -E '
for(@ARGV){$i=$_; $c=0; ++$c while s/01/10/g; say "$i -> $c"}
' 111000 00011 01011 010101 00001

The /g flag makes as many transpositions in parallel as possible.

Results:

111000 -> 0
00011 -> 4
01011 -> 3
010101 -> 3
00001 -> 4

I guess there is a more sophisticated solution based on counting the sizes of groups of consecutive 0’s and consecutive 1’s and performing some calculation, but there are too many cases to consider, so I gave up.

The full code is:

 1  # Perl weekly challenge 387
 2  # Task 1:  Rearrange Binary String
 3  #
 4  # See https://wlmb.github.io/2026/08/17/PWC387/#task-1-rearrenge-binary-string
 5  use v5.36;
 6  use feature qw(try);
 7  die <<~"FIN" unless @ARGV;
 8      Usage: $0 B0 B1...
 9      to find hao many transpositions of 01 have to be done in parallel
10      to order all 1's before all 0's inbinary string Bn
11      FIN
12  for(@ARGV){
13      try{
14          die "Expected binary string: $_" unless /^(0|1)+$/;
15          my $in=$_;
16          my $count=0;
17          ++$count while s/01/10/g;
18          say "$in -> $count"
19      }
20      catch($e){warn $e}
21  }

Example:

./ch-1.pl  111000 00011 01011 010101 00001

Results:

111000 -> 0
00011 -> 4
01011 -> 3
010101 -> 3
00001 -> 4

Task 2: Chemical formulae

Submitted by: Mohammad Sajid Anwar
You are given a chemical formula with elements, numbers, and parentheses.

Write a script to count the total number of each type of
atom by expanding all grouped multipliers. Then, format and
return the final inventory as a single string sorted
alphabetically by element name, including the total count
only if it is greater than 1.

Example 1
Input: $formula = "((N2O)3(H2O)2)2"
Output: "H8N12O10"

Step 1: Expand the innermost parentheses
    (N2O)3 => N = 2*3 = 6, O = 1*3 = 3 => N6O3
    (H2O)2 => H = 2*2 = 4, O = 1*2 = 2 => H4O2

Step 2: Combine inside the outer parentheses
    Formula becomes: (N6O3 H4O2)2
    Sum up identical elements inside: (N6 H4 O5)2

Step 3: Apply the outer multiplier
    N = 6*2 = 12
    H = 4*2 = 8
    O = 5*2 = 10

Step 4: Sort alphabetically and format
    Alphabetical order: H, N, O
    Counts: H: 8, N: 12, O: 10

Example 2
Input: $formula = "Mg3(PO4)2"
Output: "Mg3O8P2"

Step 1: Parse ungrouped elements
    Mg3 => Mg = 3

Step 2: Expand parentheses (PO4)2
    P = 1*2 = 2
    O = 4*2 = 8

Step 3: Total up counts
    Mg = 3
    P  = 2
    O  = 8

Step 4: Sort alphabetically and format
    Alphabetical order: Mg, O, P
    Counts: Mg: 3, O: 8, P: 2

Example 3
Input: $formula = "(((H)2)3)4"
Output: "H24"

Step 1: Expand innermost level (H)2
    H = 1*2 = 2 => formula becomes ((H2)3)4

Step 2: Expand middle level (H2)3
    H = 2*3 = 6 => formula becomes (H6)4

Step 3: Expand outer level (H6)4
    H = 6*4 = 24

Step 4: Sort alphabetically and format
    Single element: H: 24

Example 4
Input: $formula = "NaCl3(O2(S10)2)2Mg"
Output: "Cl3MgNaO4S40"

Step 1: Expand innermost parentheses (S10)2
    S = 10*2 = 20 => inner formula becomes => O2S20

Step 2: Expand outer parentheses (O2S20)2
    O = 2*2  = 4
    S = 20*2 = 40

Step 3: Combine all parts
    Ungrouped start: Na (Na = 1), Cl3 (Cl = 3)
    Expanded middle: O = 4, S = 40
    Ungrouped end: Mg (Mg = 1)

Step 4: Sort alphabetically and format
    Alphabetical order: Cl (3), Mg (1), Na (1), O (4), S (40)
    Omit the number 1 for Mg and Na.

Example 5
Input: $formula = "Z2Y3(X2W)2"
Output: "W2X4Y3Z2"

Step 1: Parse ungrouped elements
    Z2 => Z = 2
    Y3 => Y = 3

Step 2: Expand parentheses (X2W)2
    X = 2*2 = 4
    W = 1*2 = 2

Step 3: Total up counts
    W = 2, X = 4, Y = 3, Z = 2

Step 4: Sort alphabetically and format
    Alphabetical order: W (2), X (4), Y (3), Z (2)

I use a recursive subroutine to parse the chemical formula and return the composition as a hash that maps element to count. I use Text::Balanced to parse nested parenthesized formulae, and multiply their composition by the repeat count.

 1  # Perl weekly challenge 387
 2  # Task 2:  Chemical formulae
 3  #
 4  # See https://wlmb.github.io/2026/08/17/PWC387/#task-2-chemical-formulae
 5  use v5.36;
 6  use Text::Balanced qw(extract_bracketed);
 7  use feature qw(try);
 8  
 9  die <<~"FIN" unless @ARGV;
10      Usage: $0 F0 F1...
11      to parse and simplify the chemical formula Fn removing
12      parenthesis
13      FIN
14  for(@ARGV){
15      try{
16          my %composition = parse($_, ());
17          $composition{$_}=""
18              for grep {$composition{$_}==1} keys %composition;
19          say "$_ -> ",
20              map {($_, $composition{$_})} sort keys %composition
21      }
22      catch($e){warn "Error in $_: $e"}
23  }
24  
25  sub parse($formula, %current){
26      for($formula){
27          while($_){
28              my $start=$_;
29              $current{$1} += $2||1
30                  if s/^([A-Z][a-z]*)(\d*)//; #found element
31              my ($subformula, $rest)=extract_bracketed;
32              if($subformula){
33                  my %subcomposition =
34                      parse(substr($subformula,1,
35                                   length($subformula)-2), ());
36                  $rest=~s/^(\d)*//;
37                  my $multiplier = $1 || 1;
38                  $current{$_} += $multiplier * $subcomposition{$_}
39                      for keys %subcomposition;
40                  $_ = $rest; # update topic
41              }
42              die "Malformed formula: $_" if $_ eq $start; # avoid infinite loop
43          }
44      }
45      return %current;
46  }

Example:

./ch-2.pl "((N2O)3(H2O)2)2" "Mg3(PO4)2" "(((H)2)3)4" \
          "NaCl3(O2(S10)2)2Mg" "Z2Y3(X2W)2"

Results:

((N2O)3(H2O)2)2 -> H8N12O10
Mg3(PO4)2 -> Mg3O8P2
(((H)2)3)4 -> H24
NaCl3(O2(S10)2)2Mg -> Cl3MgNaO4S40
Z2Y3(X2W)2 -> W2X4Y3Z2

/;

]]>Perl Weekly Challenge 386.2026-08-10T00:00:00+00:002026-08-10T00:00:00+00:00http://em.fis.unam.mx/2026/08/10/PWC386My solutions (task 1 and task 2 ) to the The Weekly Challenge - 386.

Task 1: Reverse Base

Submitted by: Mohammad Sajid Anwar
You are given a string representing a number, and an integer
specifying the base of that representation.

Write a function to convert this string to an integer. (For
bases greater than 10, use characters A-Z, a-z, + and / in
that order.)

Example 1
Input: $num = "101010", $base = 2
Output: 42

Example 2
Input: $num = "EEADEE", $base = 16
Output: 15642094

Example 3
Input: $num = "755", $base = 8
Output: 493

Example 4
Input: $num = "1BRJB", $base = 36
Output: 2228519

Example 5
Input: $num = "7MyqL", $base = 64
Output: 123456789


I start from N=0. Then, for every digit D, starting from the most significant, I update N=N*B+D, where B is the base. This yields a 2-liner.

Examples

perl -E '
@d=(0..9,"A".."Z","a".."z","+","/");$v{$d[$_]}=$_ for 0..@d-1;for
my($N,$B)(@ARGV){$r=0;$r=$r*$B+$v{$_} for split "",$N; say "$N, $B -> $r"}
' 101010 2 EEADEE 16 755 8 1BRJB 36 7MyqL 64

Results:

101010, 2 -> 42
EEADEE, 16 -> 15642094
755, 8 -> 493
1BRJB, 36 -> 2228519
7MyqL, 64 -> 123456789

The full code is:

 1  # Perl weekly challenge 386
 2  # Task 1:  Reverse Base
 3  #
 4  # See https://wlmb.github.io/2026/08/10/PWC386/#task-1-reverse-base
 5  use v5.36;
 6  use feature qw(try);
 7  die <<~"FIN" unless @ARGV and @ARGV%2==0;
 8      Usage: $0 N0 B0 N1 B1...
 9      to convert the number Ni from the base Bi to base 10.
10      FIN
11  my @digits=(0..9,"A".."Z","a".."z","+","/");
12  my %to_decimal;
13  $to_decimal{$digits[$_]}=$_ for 0..@digits-1;
14  
15  for my($num, $base)(@ARGV){
16      try {
17          die "Base should be a positive integer > 1: $base"
18              unless $base=~/^\d+$/ && $base > 1;
19          die "I can't handle bases larger than 64: $base"
20              unless $base <=64;
21          my $result = 0;
22          for(split "", $num){
23              die "Undefined digit: $_" unless defined(my $dec=$to_decimal{$_});
24              die "Undefined digit in base $base: $_" unless $dec < $base;
25              $result = $result*$base+$dec;
26          }
27          say "Num.= $num, base=$base -> $result";
28      }
29      catch($e){warn $e;}
30  }

Example:

./ch-1.pl 101010 2 EEADEE 16 755 8 1BRJB 36 7MyqL 64

Results:

Num.= 101010, base=2 -> 42
Num.= EEADEE, base=16 -> 15642094
Num.= 755, base=8 -> 493
Num.= 1BRJB, base=36 -> 2228519
Num.= 7MyqL, base=64 -> 123456789

Task 2: Rational Numbers

Submitted by: Mohammad Sajid Anwar
You are given two strings representing non-negative rational
numbers.

Write a script to return true if the two given rational
numbers are same otherwise false.

Example 1
Input: $rat1 = "0.(12)"
       $rat2 = "0.(121)"
Output: false

Expansion of "0.(12)"  = 0.12 12 12 12
Expansion of "0.(121)" = 0.121 121 121

Example 2
Input: $rat1 = "0.1(23)"
       $rat2 = "0.12(32)"
Output: true

Expansion of "0.1(23)"  = 0.1 23 23 23
Expansion of "0.12(32)" = 0.12 32 32 32

Example 3
Input: $rat1 = "0.1(234)"
       $rat2 = "0.12(342)"
Output: true

Expansion of "0.1(234)"  = 0.1 234 234 234
Expansion of "0.12(342)" = 0.12 342 342 342

Example 4
Input: $rat1 = "12.99(99)"
       $rat2 = "13."
Output: true

Example 5
Input: $rat1 = "0.(123)"
       $rat2 = "0.1(231)"
Output: true


Consider the rational number x=I.F(R) with integer part I, fractional part F and recurring part R. Its meaning is I+F 10^{-n}+10^{-n}R(10^{-m}+10^{-2m}+10^{-3m}...), where n is the number of digits in F and m the number of digits in R. The infinite sum is a geometrical sum 10-m+10-2m+10-3m…=1/(10m-1). Thus, x=I+F/10^n+R/(10^n*(10^m-1)), which can finally be written as x=N/D, where the numerator is N=(10^m-1)*(10^n*I+F)+R and the denominator is D=10^n*(10^m-1). Two fractions x=N_x/D_x and y=N_y/D_y are equal if and only if N_x D_y==N_y D_x. I need an auxiliary function to get the numerators and denominators of a list of numbers. The results fit a three-liner.

Examples

perl -E '
sub f(@x){map{/(\d*).(\d*)(\((\d+)\))?/;($n,$m)=map{length}$2,$4;[(10**$m-1)*
(10**$n*$1+$2)+$4, 10**$n*(10**$m-1)]}@x}for my($x,$y)(@ARGV){($p,$q)=f($x,$y);
say "$x, $y -> ", $p->[0]*$q->[1]==$p->[1]*$q->[0]?"T":"F";}
' "0.(12)" "0.(121)" "0.1(23)" "0.12(32)" "0.1(234)" "0.12(342)" \
     "12.99(99)" "13." "0.(123)" "0.1(231)"

Results:

0.(12), 0.(121) -> F
0.1(23), 0.12(32) -> T
0.1(234), 0.12(342) -> T
12.99(99), 13. -> T
0.(123), 0.1(231) -> T
10.1(23), 10.1(2323) -> T

The full code is:

 1  # Perl weekly challenge 386
 2  # Task 2:  Rational Numbers
 3  #
 4  # See https://wlmb.github.io/2026/08/10/PWC386/#task-2-rational-numbers
 5  use v5.36;
 6  use feature qw(try);
 7  sub to_num_den(@x){
 8      map {
 9          die "Not a rational: $_" unless /^(\d*).(\d*)(\((\d+)\))?$/;
10          my ($int, $frac, $rec) = map {$_||0} ($1, $2, $4);
11          my ($n, $m) = map {length} $2, $4;
12          [
13           (10**$m-1)*(10**$n*$int+$frac)+$rec,
14            10**$n*(10**$m-1)
15          ]
16      } @x
17  }
18  
19  for my($r1,$r2)(@ARGV){
20      try {
21          my ($nd1, $nd2) = to_num_den($r1, $r2);
22          say $r1,
23              $nd1->[0]*$nd2->[1]==$nd1->[1]*$nd2->[0]?" == ":" != ",
24              $r2;
25      }
26      catch($e){warn $e;}
27  }

Example:

./ch-2.pl "0.(12)" "0.(121)" "0.1(23)" "0.12(32)" "0.1(234)" "0.12(342)" \
     "12.99(99)" "13." "0.(123)" "0.1(231)"

Results:

0.(12) != 0.(121)
0.1(23) == 0.12(32)
0.1(234) == 0.12(342)
12.99(99) == 13.
0.(123) == 0.1(231)

/;

]]>Perl Weekly Challenge 385.2026-08-03T00:00:00+00:002026-08-03T00:00:00+00:00http://em.fis.unam.mx/2026/08/03/PWC385My solutions (task 1 and task 2 ) to the The Weekly Challenge - 385.

Task 1: Uncommon Words

Submitted by: Mohammad Sajid Anwar
You are given two sentences.

Write a script to return list of all uncommon words, order
is not important.

Example 1
Input: $sentence1 = "apple banana apple"
       $sentence2 = "banana orange"
Output: ("orange")

Example 2
Input: $sentence1 = "cat dog"
       $sentence2 = "bird fish"
Output: ("cat", "dog", "bird", "fish")

Example 3
Input: $sentence1 = "the quick brown fox"
       $sentence2 = "the quick"
Output: ("brown", "fox")

Example 4
Input: $sentence1 = "hello"
       $sentence2 = "hello"
Output: ()

Example 5
Input: $sentence1 = "blue blue red"
       $sentence2 = "red green green yellow"
Output: ("yellow")


I can use hashes to count the words in both sets. Uncommon words would have a count of 1. The code fits a 2-liner.

Examples:

perl -E '
for my($l, $m)(@ARGV){my%h;++$h{$_}for split" ","$l $m";@o=
grep{$h{$_}==1}keys %h;say "$l; $m -> @o"}
' "apple banana apple" "banana orange" "cat dog" "bird fish" \
  "the quick brown fox" "the quick" "hello" "hello" \
  "blue blue red" "red green green yellow"

Results:

apple banana apple; banana orange -> orange
cat dog; bird fish -> fish bird cat dog
the quick brown fox; the quick -> fox brown
hello; hello ->
blue blue red; red green green yellow -> yellow

The full code is

 1  # Perl weekly challenge 385
 2  # Task 1:  Uncommon Words
 3  #
 4  # See https://wlmb.github.io/2026/08/03/PWC385/#task-1-uncommon-words
 5  use v5.36;
 6  die <<~"FIN" unless @ARGV && @ARGV %2 == 0;
 7      Usage: $0 X0 Y0 X1 Y1...
 8      to find non-repeated words in the strings Xn and Yn.
 9      FIN
10  for my($sentence1, $sentence2)(@ARGV){
11      my %count;
12      ++$count{$_} for split" ","$sentence1 $sentence2";
13      my @out = grep{$count{$_}==1} keys %count;
14      say "$sentence1; $sentence2 -> (@out)";
15  }

Example:

./ch-1.pl "apple banana apple" "banana orange" "cat dog" "bird fish" \
          "the quick brown fox" "the quick" "hello" "hello" \
          "blue blue red" "red green green yellow"

Task 2: Outermost Parentheses

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

Write a script to return the string after removing the
outermost parentheses of every primitive string in the
primitive decomposition of the given string.

Example 1
Input: $str = "()()()"
Output: ""

Primitive Decomposition: "()" + "()" + "()"

Example 2
Input: $str = "(((())))"
Output: "((()))"

Primitive Decomposition: "(((())))"

Example 3
Input: $str = "(()())(())"
Output: "()()()"

Primitive Decomposition: "(()())" + "(())"

Example 4
Input: $str = "()((()))()"
Output: "(())"

Primitive Decomposition: "()" + "((()))" + "()"

Example 5
Input: $str = "(()(()))(()())"
Output: "()(())()()"

Primitive Decomposition: "(()(()))" + "(()())"

I make a Schwartzian transform to count the the depth of every parenthesis and remove those at depth 0. The results fits a 2-liner.

Examples:

perl -E '
for(@ARGV){@x=split"",$_;$c=0;say"$_ -> ",map{$_->[0]}grep
{$_->[1]>0}map{/\(/?[$_,$c++]:[$_,--$c]} split "",$_}
' "()()()" "(((())))" "(()())(())" "()((()))()" "(()(()))(()())"

Results:

()()() ->
(((()))) -> ((()))
(()())(()) -> ()()()
()((()))() -> (())
(()(()))(()()) -> ()(())()()

This worked as some hidden assumptions held, i.e., the count was never negative and no characters were present but opening and closing parenthesis.

A more robust solution may be obtained by using Text::Balanced= to extract balanced parenthesized sub-expressions, though the solution is much more complex.

 1  # Perl weekly challenge 385
 2  # Task 2:  Outermost Parentheses
 3  #
 4  # See https://wlmb.github.io/2026/08/03/PWC385/#task-2-outermost-parentheses
 5  use v5.36;
 6  use Text::Balanced qw(extract_bracketed);
 7  die <<~"FIN" unless @ARGV;
 8      Usage: $0 S0 S1...
 9      to extract the string Sn after removing the
10      outermost parentheses of every primitive string in the
11      primitive decomposition of the given string.
12      FIN
13  for(@ARGV){
14      my $remaining=$_;
15      my ($extracted, $before);
16      my $out="";
17      while(1){
18          ($extracted, $remaining, $before)=extract_bracketed($remaining,"()", "[^\(]*");
19          if(!defined $extracted){
20              $out.="(", next if $remaining=~s/^\(//; #skip opening parenthesis and try again
21              $out.=$remaining;
22              last;
23          }
24          $extracted=~s/^\(|\)$//g;
25          $out.="$before$extracted";
26      }
27      say "'$_' -> \"$out\"";
28  }
29

Examples:

./ch-2.pl "()()()" "(((())))" "(()())(())"  "()((()))()" "(()(()))(()())"

Results:

'()()()' -> ""
'(((())))' -> "((()))"
'(()())(())' -> "()()()"
'()((()))()' -> "(())"
'(()(()))(()())' -> "()(())()()"

Unbalanced examples:

./ch-2.pl "())" "(()" "(()(())(())"

Results:

'())' -> ")"
'(()' -> "("
'(()(())(())' -> "(()()"

/;

]]>Difficulties with Getopt::Long 2.572026-07-30T00:00:00+00:002026-07-30T00:00:00+00:00http://em.fis.unam.mx/2026/07/30/getoptYesterday I spent the whole day debugging a relatively elaborate program that produced wrong results compared to a very similar program that gave me the expected results with the same input. At the last moment I realized the problem was a floating point parameter obtained from @ARGV using the package Getopt::Long. The problem was that the parameter was 1.0e-4 in one program and 1e-4 in the other. The first was read as 0.0001; the second was misread as 1. I was using version 2.57. The error has been corrected in version 2.58.

]]>Perl Weekly Challenge 384.2026-07-27T00:00:00+00:002026-07-27T00:00:00+00:00http://em.fis.unam.mx/2026/07/27/PWC384My solutions (task 1 and task 2 ) to the The Weekly Challenge - 384.

Task 1: Base N

Submitted by: Mohammad Sajid Anwar
You are given a number and a base integer.

Write a script to convert the given number in the given base
integer.

Example 1
Input: $num = 42, $base = 2
Output: 101010

Example 2
Input: $num = 15642094, $base = 16
Output: EEADEE

Example 3
Input: $num = 493, $base = 8
Output: 755

Example 4
Input: $num = 2228519, $base = 36
Output: 1BRJB

Base 36 uses numbers 0-9 and letters A-Z.

Example 5
Input: $num = 123456789, $base = 64
Output: 7MyqL

Base 64 (using 0-9, A-Z, a-z, and extra symbols like +
and /)

The succesive digits of Dn of a number N=∑Dn Bn in base B may be obtained by setting N0=N and then iteratively setting Dn=Nn mod B and Nn+1=Nn/B. The iteration stops when the division yields 0. Then we can convert the value of each to its corresponding symbol using an array. The result takes a two-liner.

Examples:

perl -E '
$"="";@d=(0..9, "A".."Z", "a".."z", "+", "/");for my($N,$B)(@ARGV){$n=$N;
my @o;unshift(@o,$d[$n%$B]),$n=floor $n/$B while($n);say"$N, $B -> @o"}
' 42 2 15642094 16 493 8 2228519 36 123456789 64

Results:

42, 2 -> 101010
15642094, 16 -> EEADEE
493, 8 -> 755
2228519, 36 -> 1BRJB
123456789, 64 -> 7MyqL

The full code is:

 1  # Perl weekly challenge 384
 2  # Task 1:  Base N
 3  #
 4  # See https://wlmb.github.io/2026/07/27/PWC384/#task-1-base-n
 5  use v5.40;
 6  use feature qw(try);
 7  $"="";
 8  die <<~"FIN" unless @ARGV && @ARGV%2==0;
 9      Usage: $0 N0 B0 N1 B1...
10      to write the number Ni in base Bn.
11      FIN
12  my @digit=(0..9, "A".."Z", "a".."z", "+", "/");
13  my $maxbase=@digit;
14  for my($N,$B)(@ARGV){
15      try{
16          die "Base should an integer: $B" unless $B==floor $B;
17          die "Base should be larger than 1: $B" unless $B>1;
18          die "Base too large; can only handle up to $maxbase: $B"
19              unless $B<=$maxbase;
20          die "I only manage integer numbers: $N" unless floor $N==$N;
21          my $sign=$N<0?"-":"";
22          my $rest=$N<0?-$N:$N;
23          my @output;
24          while($rest){
25              unshift(@output, $digit[$rest%$B]);
26              $rest=floor $rest/$B;
27          }
28          my $output="@output";
29          say"$N, $B -> $output"
30      }
31      catch($e){ warn $e; }
32  }

Example:

./ch-1.pl 42 2 15642094 16 493 8 2228519 36 123456789 64

Results:

42, 2 -> 101010
15642094, 16 -> EEADEE
493, 8 -> 755
2228519, 36 -> 1BRJB
123456789, 64 -> 7MyqL

Task 2: Special Binary Substrings

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

Write a script to return all non-empty substrings (distinct)
that have the same number of 0’s and 1’s, and all the 0’s
and all the 1’s in these substrings are grouped
consecutively.

Example 1
Input: $binary = "0101"
Output: ("01", "10")

Example 2
Input: $binary = "000111"
Output: ("000111", "0011", "01")

Example 3
Input: $binary = "000011"
Output:  ("0011", "01")

Example 4
Input: $binary = "10011100"
Output: ("10", "0011", "01", "1100")

Example 5
Input: $binary = "00000"
Output: ()

I can look for a pattern of n zeroes followed by n ones or viceverse for every possible length, from 1 upto half the string length. This takes a 1.5-liner.

perl -E '
for(@ARGV){$s=$_;$l=length($s)/2;say"$_ -> ",join" ",map{$s=~
/(0{$_}1{$_})/,$s=~/(1{$_}0{$_})/} 1..$l}
' 0101 000111 000011 10011100 00000

Results:

0101 -> 01 10
000111 -> 01 0011 000111
000011 -> 01 0011
10011100 -> 01 10 0011 1100
00000 ->

I guess this could be done more compactly with a smarter match, but I didn’t pursue it.

The full code is:

 1  # Perl weekly challenge 384
 2  # Task 2:  Special Binary Substrings
 3  #
 4  # See https://wlmb.github.io/2026/07/27/PWC384/#task-2-special-binary-substrings
 5  use v5.36;
 6  die <<~"FIN" unless @ARGV;
 7      Usage: $0 S0 S1...
 8      to look for substrings of Sn of the form
 9      00...11... or 11...00... with the same number of
10      consecutive ones and zeroes.
11      FIN
12  for(@ARGV){
13      my $string=$_;
14      my $length=length($string)/2;
15      say"$_ -> (",(
16          join " ",
17          map {
18              $string=~/(0{$_}1{$_})/,
19              $string=~/(1{$_}0{$_})/
20          } 1..$length
21          ), ")";
22  }

Example:

./ch-2.pl 0101 000111 000011 10011100 00000

Results:

0101 -> (01 10)
000111 -> (01 0011 000111)
000011 -> (01 0011)
10011100 -> (01 10 0011 1100)
00000 -> ()

/;

]]>Perl Weekly Challenge 383.2026-07-20T00:00:00+00:002026-07-20T00:00:00+00:00http://em.fis.unam.mx/2026/07/20/PWC383My solutions (task 1 and task 2 ) to the The Weekly Challenge - 383.

Task 1: Similar List

Submitted by: Mohammad Sajid Anwar
You are given three list of strings.

Write a script to find out if the first two list are similar
with the help the third list. The third list contains the
similar words map.

Example 1
Input: $list1 = ("great", "acting")
       $list2 = ("fine", "drama")
       $list3 = (["great", "fine"], ["acting", "drama"])
Output: true

Example 2
Input: $list1 = ("apple", "pie")
       $list2 = ("banana", "pie")
       $list3 = (["apple", "peach"], ["peach", "banana"])
Output: false

Example 3
Input: $list1 = ("perl4", "python")
       $list2 = ("raku", "python")
       $list3 = (["perl4", "perl5", "raku"])
Output: true

Example 4
Input: $list1 = ("enjoy", "challenge")
       $list2 = ("love", "weekly", "challenge")
       $list3 = (["enjoy", "love"])
Output: false

Example 5
Input: $list1 = ("fast", "car")
       $list2 = ("quick", "vehicle")
       $list3 = (["quick", "fast"], ["vehicle", "car"])
Output: true


Example 2 shows that only one substitution is allowed and that words may appear in different lists. Example 3 shows that lists may contain more than two items. It seems that the number and order of words is relevant. I can make a hash with each possible replacement, including replacement by itself. Then, the result is true if every word of the second list equals some replacement of a word in the first list. The result fits a three-liner.

Examples:

perl -MList::Util=all,any -E '
for my($f,$s,$t)(@ARGV){my %e;for(split/;\s*/,$t){@e=split " ";push$e{$_}->@*,@e
for @e;}@f=split " ",$f;@s=split " ",$s;push$e{$_}->@*,$_ for @f;$r=@f==@s&&all{
$x=$f[$_];$y=$s[$_];any{$_ eq $y}$e{$x}->@*}0..@f-1;say "$f\n$s\n$t\n-> ", $r?"T":"F"}
' "great acting" "fine drama" "great fine; acting drama" \
  "apple pie" "banana pie" "apple peach; peach banana" \
  "perl4 python" "raku python" "perl4 perl5 raku" \
  "enjoy challenge" "love weekly challenge" "enjoy love" \
  "fast car" "quick vehicle" "quick fast; vehicle car"

Results:

great acting
fine drama
great fine; acting drama
-> T
apple pie
banana pie
apple peach; peach banana
-> F
perl4 python
raku python
perl4 perl5 raku
-> T
enjoy challenge
love weekly challenge
enjoy love
-> F
fast car
quick vehicle
quick fast; vehicle car
-> T

The full code is:

 1  # Perl weekly challenge 383
 2  # Task 1:  Similar List
 3  #
 4  # See https://wlmb.github.io/2026/07/20/PWC383/#task-1-similar-list
 5  use v5.36;
 6  use List::Util qw(any all);
 7  die <<~"FIN" unless @ARGV and @ARGV%3==0;
 8      Usage: $0 F0 S0 E0 F1 S1 E1...
 9      to find if the list of words Sn is equivalent to the
10      list Fn using the list of equivalences En. Fn and Sn are
11      space separated lists of words and En are semicolon
12      separated lists of space separated equivalent words.
13      FIN
14  for my($first, $second, $equivalence)(@ARGV){
15      my %equivalences;
16      for(split/;\s*/,$equivalence){
17          my @equivalent = split " ";
18          push $equivalences{$_}->@*, @equivalent for @equivalent;
19      }
20      my @first_words = split " ", $first;
21      my @second_words= split " ", $second;
22      push $equivalences{$_}->@*, $_ for @first_words;
23      my $result = @first_words == @second_words
24          &&
25          all{
26              my $f=$first_words[$_];
27              my $s=$second_words[$_];
28              any{$_ eq $s} $equivalences{$f}->@*
29          }0..@first_words-1;
30      say "First: $first\nSecond: $second\nEquivalences: $equivalence\n-> ", $result?"True":"False", "\n";
31  }

Example:

./ch-1.pl "great acting" "fine drama" "great fine; acting drama" \
          "apple pie" "banana pie" "apple peach; peach banana" \
          "perl4 python" "raku python" "perl4 perl5 raku" \
          "enjoy challenge" "love weekly challenge" "enjoy love" \
          "fast car" "quick vehicle" "quick fast; vehicle car"

Results:

First: great acting
Second: fine drama
Equivalences: great fine; acting drama
-> True

First: apple pie
Second: banana pie
Equivalences: apple peach; peach banana
-> False

First: perl4 python
Second: raku python
Equivalences: perl4 perl5 raku
-> True

First: enjoy challenge
Second: love weekly challenge
Equivalences: enjoy love
-> False

First: fast car
Second: quick vehicle
Equivalences: quick fast; vehicle car
-> True

Task 2: Nearest RGB

Submitted by: Mohammad Sajid Anwar
You are given a 6-digit hex color.

Write a script to round the RGB channels to the nearest
web-safe value and return the nearest RGB color.

00 (0), 33 (51), 66 (102), 99 (153), CC (204) and FF (255)

Example 1
Input: $color = "#F4B2D1"
Output: "#FF99CC"

Red: F4 (Decimal 244), closer to 255 => FF
Green: B2 (Decimal 178), closer to 153 => 99
Blue: D1 (Decimal 209), closer to 204 => CC
So the nearest RGB: "#FF99CC"

Example 2
Input: $color = "#15E6E5"
Output: "#00FFCC"

Red: 15 (Decimal 21), closer to 0 => 00
Green: E6 (Decimal 230), closer to 255 => FF
Blue: E5 (Decimal 229), closer to 204 => CC

Example 3
Input: $color = "#191A65"
Output: "#003366"

Red: 19 (Decimal 25), closer to 0 => 00
Green: 1A (Decimal 26), closer to 51 => 33
Blue: 65 (Decimal 101), closer to 102 => 66

Example 4
Input: $color = "#2D5A1B"
Output: "#336633"

Red: 2D (Decimal 45), closer to 51 => 33
Green: 5A (Decimal 90), closer to 102 => 66
Blue: 1B (Decimal 27), closer to 51 => 33

Example 5
Input: $color = "#00FF66"
Output: "#00FF66"

Red: 00 (Decimal 0), closer to 0 => 00
Green: FF (Decimal 255), closer to 255 => FF
Blue: 66 (Decimal 102), closer to 102 => 66

I make a list of borders between the basins of each safe value. For each color coordinate, I get the index of the first border (from List::Util) not smaller than that coordinate and the corresponding hex number with which I build the output safe color. The result fits a two-liner.

Examples:

perl -MList::Util=first -E '
@s=qw(00 33 66 99 CC FF);@b=map{hex($_)+25}@s;say"$_ -> ",join"","\#",
map{$v=hex $_; $s[first{$v<=$b[$_]}0..@b-1]}s/\#//r=~/(..)/g for@ARGV;
' "#F4B2D1" "#15E6E5" "#191A65" "#2D5A1B" "#00FF66"

Results:

#F4B2D1 -> #FF99CC
#15E6E5 -> #00FFCC
#191A65 -> #003366
#2D5A1B -> #336633
#00FF66 -> #00FF66

The full code is:

 1  # Perl weekly challenge 383
 2  # Task 2:  Nearest RGB
 3  #
 4  # See https://wlmb.github.io/2026/07/20/PWC383/#task-2-nearest-rgb
 5  use v5.36;
 6  use feature qw(try);
 7  use List::Util qw(first);
 8  
 9  die <<~"FIN" unless @ARGV;
10      Usage: $0 C0 C1...
11      to obtain the nearest RGB safe color corresponding to
12      the color Cn, expressed as an hexadecimal number preceeded
13      by a hash mark.
14      FIN
15  
16  my @safe = qw(00 33 66 99 CC FF);
17  my @boundaries = map{ hex($_) + 25} @safe;
18  for(@ARGV){
19      try{
20          die "Expected a hash followed by 6 hex digits: $_" unless /^\#[[:xdigit:]]{6}$/;
21          say "$_ -> ",
22          join "", "\#",
23          map{
24              my $value = hex $_;
25              $safe[
26                  first{$value <= $boundaries[$_]} 0..@boundaries-1
27              ]
28          }
29          s/\#//r    # remove leading hash
30              =~/(..)/g  # separate in pairs of digits
31      }
32      catch($e){warn $e;}
33  }

Example:

./ch-2.pl "#F4B2D1" "#15E6E5" "#191A65" "#2D5A1B" "#00FF66"

Results:

#F4B2D1 -> #FF99CC
#15E6E5 -> #00FFCC
#191A65 -> #003366
#2D5A1B -> #336633
#00FF66 -> #00FF66

/;

]]>Perl Weekly Challenge 382.2026-07-13T00:00:00+00:002026-07-13T00:00:00+00:00http://em.fis.unam.mx/2026/07/13/PWC382My solutions (task 1 and task 2 ) to the The Weekly Challenge - 382.

Task 1: Hamiltonian Cycle

Submitted by: Peter Campbell Smith
You are given a target number.

Write a script to arrange all the whole numbers from 1 up to
the given target number into a circle so that every pair of
side-by-side numbers adds up to a perfect square. Please
make sure, the last number and the first must also add up to
a square.

Example 1
Input: $n = 32
Output: 1, 8, 28, 21, 4, 32, 17, 19, 30, 6, 3, 13, 12, 24,
        25, 11, 5, 31, 18, 7, 29, 20, 16, 9, 27, 22, 14, 2,
        23, 26, 10, 15

1  + 8  = 9
8  + 28 = 36
28 + 21 = 49
21 + 4  = 25
4  + 32 = 36
32 + 17 = 49
17 + 19 = 36
19 + 30 = 49

so on, all the way through the sequence.

Example 2
Input: $n = 15
Output: ()

No valid circular list of numbers exists.

Example 3
Input: $n = 34
Output: 1, 8, 28, 21, 4, 32, 17, 19, 6, 30, 34, 15, 10, 26,
        23, 2, 14, 22, 27, 9, 16, 33, 31, 18, 7, 29, 20, 5,
        11, 25, 24, 12, 13, 3

[2026-07-13 11:45]: Output was incorrect, corrected by E. Choroba.

A very inneficient but simple solution is to keep a list of remaining numbers and try to recursively construct a list by adding unused numbers that add to a square until all numbers are used or failure is detected. The result fits a 3-liner.

Examples:

perl -E '
for(@ARGV){say"$_ -> @{f([1],[2..$_])}"}sub f($i, $r){my$l=$i->[-1];@$r||return
g($l+$i->[0])?$i:0;for(0..@$r-1){g($l+$r->[$_])||next;$o=f([@$i,$r->[$_]],
[@$r[0..$_-1,$_+1..@$r-1]]);return $o if $o;}0;}sub g($x){$x==floor(sqrt($x))**2}
' 32 15 34

Results:

32 -> 1 8 28 21 4 32 17 19 30 6 3 13 12 24 25 11 5 31 18 7 29 20 16 9 27 22 14 2 23 26 10 15
15 ->
34 -> 1 3 13 12 4 32 17 8 28 21 15 34 30 19 6 10 26 23 2 14 22 27 9 16 33 31 18 7 29 20 5 11 25 24

By the way, this problem has multiple solutions. My code shows the first one it finds.

The full code follows:

 1  # Perl weekly challenge 382
 2  # Task 1:  Hamiltonian Cycle
 3  #
 4  # See https://wlmb.github.io/2026/07/13/PWC382/#task-1-hamiltonian-cycle
 5  use v5.40;
 6  use feature qw(try);
 7  use Scalar::Util qw(looks_like_number);
 8  die <<~"FIN" unless @ARGV;
 9      Usage: $0 N0 N1...
10      to build a Hamiltonian cycle that visits all numbers 1..Nn
11      such that two consecutive numbers in the cycle add to a perfect square.
12      FIN
13  for(@ARGV){
14      try {
15  	die "Expected a number: $_"
16  	    unless looks_like_number $_;
17  	say"$_ -> (@{hamiltonian([1],[2..$_])||[]})"
18      }
19      catch($e){warn $e; }
20  }
21  sub hamiltonian($so_far, $rest){
22      my $last=$so_far->[-1];
23      return is_square($last + $so_far->[0])?
24  	$so_far : () unless @$rest; # all consumed
25      for(0..@$rest-1){
26  	next unless is_square($last + $rest->[$_]);
27  	my $result =
28  	    hamiltonian(
29  		[@$so_far, $rest->[$_]],
30  		[@$rest[0..$_-1, $_+1..@$rest-1]]
31  	    );
32  	return $result if $result;
33      }
34      return 0;
35  }
36  sub is_square($x){
37      $x==floor(sqrt($x))**2;
38  }

Examples:

./ch-1.pl 32 15 34

Results:

32 -> (1 8 28 21 4 32 17 19 30 6 3 13 12 24 25 11 5 31 18
       7 29 20 16 9 27 22 14 2 23 26 10 15)
15 -> ()
34 -> (1 3 13 12 4 32 17 8 28 21 15 34 30 19 6 10 26 23 2
       14 22 27 9 16 33 31 18 7 29 20 5 11 25 24)

A better solution might be to make a list of squares and to associate to each number a list of numbers that add to a square. That way we wouldn’t have to check if the sum is a square and we wouldn’t have as many possibilities when recursing.

 1  # Perl weekly challenge 382
 2  # Task 1:  Hamiltonian Cycle
 3  #
 4  # See https://wlmb.github.io/2026/07/13/PWC382/#task-1-hamiltonian-cycle
 5  use v5.40;
 6  use feature qw(try);
 7  use Scalar::Util qw(looks_like_number);
 8  die <<~"FIN" unless @ARGV;
 9      Usage: $0 N0 N1...
10      to build a Hamiltonian cycle that visits all numbers 1..Nn
11      such that two consecutive numbers in the cycle add to a perfect square.
12      FIN
13  my %follower;
14  for my $in (@ARGV){
15      try {
16  	die "Expected a number: $in"
17  	    unless looks_like_number $in;
18  	my @squares=map{$_**2}(2..floor(sqrt(2*$in-1)));
19  	for my $i(1..$in){
20  	    $follower{$i}=[grep {$_>0 && $_<=$in} map{$_-$i} @squares];
21  	}
22  	say "$in -> (@{hamiltonian([1],{1=>1}, $in-1)||[]})"
23      }
24      catch($e){warn $e; }
25  }
26  
27  sub hamiltonian($so_far, $used, $count){
28      my $last=$so_far->[-1];
29      return (grep {$_==1} $follower{$last}->@*)? $so_far : () unless $count--;
30      for($follower{$last}->@*){
31          next if $used->{$_};
32  	my $result = hamiltonian(
33  		[@$so_far, $_],
34  		{$used->%*, $_=>1},
35                  $count
36  	    );
37  	return $result if $result;
38      }
39      return ();
40  }

Examples:

./ch-1a.pl 32 15 34

Results:

32 -> (1 8 28 21 4 32 17 19 30 6 3 13 12 24 25 11 5 31 18 7 29 20 16
       9 27 22 14 2 23 26 10 15)
15 -> ()
34 -> (1 3 13 12 4 32 17 8 28 21 15 34 30 19 6 10 26 23 2 14 22 27 9
       16 33 31 18 7 29 20 5 11 25 24)

I obtained the same results, but it took the same time.

Task 2: Replace Question Mark

Submitted by: Simon Green
You are given a string that contains only 0, 1 and ? characters.

Write a script to generate all possible combinations when
replacing the question marks with a zero or one.

Example 1
Input: $str = "01??0"
Output: ("01000", "01010", "01100", "01110")

Example 2
Input: $str = "101"
Output: ("101")

Example 3
Input: $str = "???"
Output: ("000", "001", "010", "011", "100", "101", "110", "111")

Example 4
Input: $str = "1?10"
Output: ("1010", "1110")

Example 5
Input: $str = "1?1?0"
Output: ("10100", "10110", "11100", "11110")

A simple solution is recursively substituting each question mark by 1 and by 0 until there are no more question marks. I use the option r to return the susbtitutions leaving the original string untouched. This yields a two-liner.

Examples:

perl -E '
for(@ARGV){say "$_ -> ", join " ", f($_);}sub f($s){for($s){
return ($_) unless /\?/;return (f(s/\?/0/r), f(s/\?/1/r));}}
' 01??0 101 ??? 1?10 1?1?0

Results:

01??0 -> 01000 01010 01100 01110
101 -> 101
??? -> 000 001 010 011 100 101 110 111
1?10 -> 1010 1110
1?1?0 -> 10100 10110 11100 11110

I guess there might be some more efficient solution in which the regular expression machine could perform the recursive replacements, but I didn’t pursue it.

The full code is

 1  # Perl weekly challenge 382
 2  # Task 2:  Replace Question Mark
 3  #
 4  # See https://wlmb.github.io/2026/07/13/PWC382/#task-2-replace-question-mark
 5  use v5.36;
 6  use feature qw(try);
 7  die <<~"FIN" unless @ARGV;
 8      Usage: $0 S0 S1...
 9      to substitute the each question mark (?) by 0 and by 1
10      in the strings Sn.
11      FIN
12  for(@ARGV){
13      try {
14  	die "Only 1, 0 and ? are allowed: $_" unless /^[01\?]*$/;
15  	say "$_ -> (", join(" ", replace($_)), ")";
16      }
17      catch($e){warn $e}
18  }
19  sub replace ($s){
20      for($s){
21  	return ($_) unless /\?/;
22  	return (replace(s/\?/0/r), replace(s/\?/1/r));
23      }
24  }

Example:

./ch-2.pl 01??0 101 ??? 1?10 1?1?0

Results:

01??0 -> (01000 01010 01100 01110)
101 -> (101)
??? -> (000 001 010 011 100 101 110 111)
1?10 -> (1010 1110)
1?1?0 -> (10100 10110 11100 11110)

/;

]]>Perl Weekly Challenge 381.2026-07-06T00:00:00+00:002026-07-06T00:00:00+00:00http://em.fis.unam.mx/2026/07/06/PWC381My solutions (task 1 and task 2 ) to the The Weekly Challenge - 381.

Task 1: Same Row Column

Submitted by: Mohammad Sajid Anwar

You are given a n x n matrix containing integers from 1 to
n.

Write a script to find if every row and every column
contains all the integers from 1 to n.

Example 1
Input: @matrix = ([1, 2, 3, 4],
                  [2, 3, 4, 1],
                  [3, 4, 1, 2],
                  [4, 1, 2, 3],)
Output: true

Example 2
Input: @matrix = ([1])
Output: true

Example 3
Input: @matrix = ([1, 2, 5],
                  [5, 1, 2],
                  [2, 5, 1],)
Output: false

Elements are out of range 1..3.

Example 4
Input: @matrix = ([1, 2, 3],
                  [1, 2, 3],
                  [1, 2, 3],)
Output: false

Example 5
Input: @matrix = ([1, 2, 3],
                  [3, 1, 2],
                  [3, 2, 1],)
Output: false


I use the Perl Data Language PDL to read and manipulate matrices. I can sort all rows and columns and compare them to the sequence 1..n, i.e., the result is true if the given matrix and its transpose, agree after sorting with the sequence. This takes a two-liner.

Examples:

perl -MPDL -E '
for(@ARGV){$m=pdl$_;$s=1+sequence($m->dim(0));say "$m-> ",
pdl(map{($_->qsort==$s)->all}$m, $m->transpose)->all?"T":"F";}
' "[[1 2 3 4][2 3 4 1][3 4 1 2][4 1 2 3]]" \
  "[[1]]" \
  "[[1 2 5][5 1 2][2 5 1]]" \
  "[[1 2 3][1 2 3][1 2 3]]" \
  "[[1 2 3][3 1 2][3 2 1]]"

Results:

[
 [1 2 3 4]
 [2 3 4 1]
 [3 4 1 2]
 [4 1 2 3]
]
-> T

[
 [1]
]
-> T

[
 [1 2 5]
 [5 1 2]
 [2 5 1]
]
-> F

[
 [1 2 3]
 [1 2 3]
 [1 2 3]
]
-> F

[
 [1 2 3]
 [3 1 2]
 [3 2 1]
]
-> F

The full code is:

 1  # Perl weekly challenge 381
 2  # Task 1:  Same Row Column
 3  #
 4  # See https://wlmb.github.io/2026/07/06/PWC381/#task-1-same-row-column
 5  use v5.36;
 6  use feature qw(try);
 7  use PDL;
 8  die <<~"FIN" unless @ARGV;
 9      Usage: $0 M0 M1...
10      to find if all rows and columns of the NxN matrix Mn contain
11      all the numbers 1..N.
12      Mn are strings that may be interpreted by PDL as matrices.
13      FIN
14  for(@ARGV){
15      try {
16          my $matrix = pdl $_;
17          die "Matrix must be square" unless
18              $matrix->ndims==2 && $matrix->dim(0)==$matrix->dim(1);
19          my $seq = 1 + sequence($matrix->dim(0));
20          say "$matrix-> ",
21              pdl(
22                  map{($_->qsort==$seq)->all}$matrix, $matrix->transpose
23              )->all?"True":"False";
24      }
25      catch($e) {warn $e;}
26  }

Example:

./ch-1.pl "[[1 2 3 4][2 3 4 1][3 4 1 2][4 1 2 3]]" \
          "[[1]]" \
          "[[1 2 5][5 1 2][2 5 1]]" \
          "[[1 2 3][1 2 3][1 2 3]]" \
          "[[1 2 3][3 1 2][3 2 1]]"

Task 2: Smaller Greater Element

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

Write a script to find the number of elements that have both
a strictly smaller and greater element in the given array.

Example 1
Input: @int = (2,4)
Output: 0

Not enough elements in the array.

Example 2
Input: @int = (1, 1, 1, 1)
Output: 0

Example 3
Input: @int = (1, 1, 4, 8, 12, 12)
Output: 2

The elements are 4 and 8.

Example 4
Input: @int = (3, 6, 6, 9)
Output: 2

Both instances of 6.

Example 5
Input: @int = (0, -5, 10, -2, 4)
Output: 3

The elements are 0, -2, and 4.

Though it may be overkill, I use the Perl Data Language PDL to read the arrays, find their minimum and maximum, selecting the elements that are not equal to those minimum and maximum and count the resulting number of elements. The result takes a one-liner.

Examples

perl -MPDL -E '
for(@ARGV){$p=pdl$_;($x,$y)=$p->minmax;say "$_ -> ",$p->where(($p!=$x)&($p!=$y))->nelem}
' "[2 4]" "[1 1 1 1]" "[1 1 4 8 12 12]" "[3 6 6 9]" "[0 -5 10 -2 4]"

Results:

[2 4] -> 0
[1 1 1 1] -> 0
[1 1 4 8 12 12] -> 2
[3 6 6 9] -> 2
[0 -5 10 -2 4] -> 3

The full code is:

 1  # Perl weekly challenge 381
 2  # Task 2:  Smaller Greater Element
 3  #
 4  # See https://wlmb.github.io/2026/07/06/PWC381/#task-2-smaller-greater-element
 5  use v5.36;
 6  use feature qw(try);
 7  use PDL;
 8  die <<~"FIN" unless @ARGV;
 9      Usage: $0 A0 A1...
10      to count the elements of the array An that are both strictly larger
11      and smaller than some other elements. An is a string that can be
12      fed to PDL as an array
13      FIN
14  for(@ARGV){
15      try {
16          my $array = pdl $_;
17          die "Expected a 1D array; $_" unless $array->ndims==1;
18          my ($min, $max) = $array->minmax;
19          say "$_ -> ", $array->where(($array != $min) & ($array != $max))->nelem;
20      }
21      catch($e){ warn $e; }
22  }

Example:

./ch-2.pl "[2 4]" "[1 1 1 1]" "[1 1 4 8 12 12]" "[3 6 6 9]" "[0 -5 10 -2 4]"

Results:

[2 4] -> 0
[1 1 1 1] -> 0
[1 1 4 8 12 12] -> 2
[3 6 6 9] -> 2
[0 -5 10 -2 4] -> 3

/;

]]>