Perl Weekly Challenge 314.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 314.
Task 1: Equal Strings
Submitted by: Mohammad Sajid Anwar
You are given three strings.
You are allowed to remove the rightmost character of a string to make all equals.
Write a script to return the number of operations to make it equal otherwise -1.
Example 1
Input: $s1 = "abc", $s2 = "abb", $s3 = "ab"
Output: 2
Operation 1: Delete "c" from the string "abc"
Operation 2: Delete "b" from the string "abb"
Example 2
Input: $s1 = "ayz", $s2 = "cyz", $s3 = "xyz"
Output: -1
Example 3
Input: $s1 = "yza", $s2 = "yzb", $s3 = "yzc"
Output: 3
A simple solution consists in first making all strings the same length.
- If all strings are equal, end.
- Cut the last letter of each
- Repeat.
If the resulting strings have zero length, there is a failure so print -1. Otherwise, print the number of characters removed. The result fits a two-liner.
Example 1:
perl -MList::Util=min,uniq -E '
$m=min map {length}@x=@ARGV;s/^(.{,$m})(.*)$/$1/, $r+=length $2 for @x;
while(uniq(@x)>1){s/^(.*).$/$1/ for(@x);$r+=@x}say "@ARGV -> ", length $x[0]?$r:-1;
' abc abb ab
Results:
abc abb ab -> 2
Example 2:
perl -MList::Util=min,uniq -E '
$m=min map {length}@x=@ARGV;s/^(.{,$m})(.*)$/$1/, $r+=length $2 for @x;
while(uniq(@x)>1){s/^(.*).$/$1/ for(@x);$r+=@x}say "@ARGV -> ", length $x[0]?$r:-1;
' ayz cyz xyz
Results:
ayz cyz xyz -> -1
Example 3:
perl -MList::Util=min,uniq -E '
$m=min map {length}@x=@ARGV;s/^(.{,$m})(.*)$/$1/, $r+=length $2 for @x;
while(uniq(@x)>1){s/^(.*).$/$1/ for(@x);$r+=@x}say "@ARGV -> ", length $x[0]?$r:-1;
' yza yzb yzc
Results:
yza yzb yzc -> 3
An alternative would be to analyze the strings from the start. Remove the first character of each string if all are equal and iterate until at least one is different. The result is then the number of remaining characters. This solution is slightly shorter and fits a longish one-liner.
Example 1:
perl -MList::Util=all -E '
@x=@ARGV;while(all {$p=substr $x[0],0,1; /^$p/}@x){++$l;s/.(.*)/$1/ for @x}say $l?length join "",@x:-1;
' abc abb ab
Results:
2
Example 2:
perl -MList::Util=all -E '
@x=@ARGV;while(all {$p=substr $x[0],0,1; /^$p/}@x){++$l;s/.(.*)/$1/ for @x}say $l?length join "",@x:-1;
' ayz cyz xyz
Results:
-1
Example 3:
#+begin_src bash :results output
perl -MList::Util=all -E '
@x=@ARGV;while(all {$p=substr $x[0],0,1; /^$p/}@x){++$l;s/.(.*)/$1/ for @x}say $l?length join "",@x:-1;
' yza yzb yzc
Results:
3
The corresponding full code is:
1 # Perl weekly challenge 314
2 # Task 1: Equal Strings
3 #
4 # See https://wlmb.github.io/2025/03/24/PWC314/#task-1-equal-strings
5 use v5.36;
6 use List::Util qw(all sum0);
7 die <<~"FIN" unless @ARGV and @ARGV%3==0;
8 Usage: $0 S11 S12 S13 S21 S22 S23...
9 to find how many times the strings Sn1 Sn2 Sn3 have to be cut
10 from their end so they become equal.
11 FIN
12 for my ($x, $y, $z)(@ARGV){
13 my @orig = my @strings = ($x, $y, $z);
14 my $iterations = 0;
15 while(all {my $p=substr $strings[0],0,1; /^$p/} @strings){ # if first characters coincide
16 ++$iterations;
17 s/^.(.*)/$1/ for @strings; # remove them
18 }
19 say "@orig -> ", $iterations ? sum0 map {length} @strings : -1;
20 }
21
Examples:
./ch-1.pl abc abb ab ayz cyz xyz yza yzb yzc
Results:
abc abb ab -> 2
ayz cyz xyz -> -1
yza yzb yzc -> 3
Task 2: Sort Column
Submitted by: Mohammad Sajid Anwar
You are given a list of strings of same length.
Write a script to make each column sorted lexicographically by deleting any non sorted columns.
Return the total columns deleted.
Example 1
Input: @list = ("swpc", "tyad", "azbe")
Output: 2
swpc
tyad
azbe
Column 1: "s", "t", "a" => non sorted
Column 2: "w", "y", "z" => sorted
Column 3: "p", "a", "b" => non sorted
Column 4: "c", "d", "e" => sorted
Total columns to delete to make it sorted lexicographically.
Example 2
Input: @list = ("cba", "daf", "ghi")
Output: 1
Example 3
Input: @list = ("a", "b", "c")
Output: 0
I map the strings to a 2D array of ordinal numbers using ord and
store them in a ndarray using the Perl Data language PDL. I
transpose the array so that each letter position corresponds to a row,
I sort the rows and compare them to the unsorted array. I have to
delete a row if any of its elements differ from the corresponding
element of the sorted array. I sum how many rows are to be deleted and
report the result. The code fits a one-liner.
Example 1:
perl -MPDL -E '
$s=($p=pdl(map{[map{ord}split ""]}@ARGV)->mv(1,0))->qsort;say "@ARGV -> ",($p!=$s)->orover->sum;
' swpc tyad azbe
Results:
swpc tyad azbe -> 2
Example 2:
perl -MPDL -E '
$s=($p=pdl(map{[map{ord}split ""]}@ARGV)->mv(1,0))->qsort;say "@ARGV -> ",($p!=$s)->orover->sum;
' cba daf ghi
Results:
cba daf ghi -> 1
Example 3:
perl -MPDL -E '
$s=($p=pdl(map{[map{ord}split ""]}@ARGV)->mv(1,0))->qsort;say "@ARGV -> ",($p!=$s)->orover->sum;
' a b c
Results:
a b c -> 0
The full code adds a few tests and converts to lower case on input.
1 # Perl weekly challenge 314
2 # Task 2: Sort Column
3 #
4 # See https://wlmb.github.io/2025/03/24/PWC314/#task-2-sort-column
5 use v5.36;
6 use PDL;
7 die <<~"FIN" unless @ARGV;
8 $0 S1 S2...
9 to count how many columns of a matrix formed by the n-th character
10 Cnm of the m-th string Sm has to be deleted so that the remaining columns
11 are sorted.
12 FIN
13 die "All strings have to be of the same length" unless pdl(map {length} @ARGV)->uniq->nelem==1;
14 my $matrix = pdl(map {[map {ord lc} split ""]} @ARGV)->mv(1,0);
15 my $sorted = $matrix->qsort;
16 say "@ARGV -> ",($matrix != $sorted)->orover->sum;
Example:
./ch-2.pl swpc tyad azbe
./ch-2.pl cba daf ghi
./ch-2.pl a b c
Results:
swpc tyad azbe -> 2
cba daf ghi -> 1
a b c -> 0