Perl Weekly Challenge 317.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 317.
Task 1: Acronyms
Submitted by: Mohammad Sajid Anwar
You are given an array of words and a word.
Write a script to return true if concatenating the first letter of each word
in the given array matches the given word, return false otherwise.
Example 1
Input: @array = ("Perl", "Weekly", "Challenge")
$word = "PWC"
Output: true
Example 2
Input: @array = ("Bob", "Charlie", "Joe")
$word = "BCJ"
Output: true
Example 3
Input: @array = ("Morning", "Good")
$word = "MM"
Output: false
I guess the easiest approach is to build the acronym and compare it to the tentative one. This fits a one-liner.
Example 1:
perl -E '
$x=shift; $y=join "",map{substr $_,0,1}@ARGV; say "W=$x, L=@ARGV -> ", $x eq $y?"True":"False";
' PWC Perl Weekly Challenge
Results:
W=PWC, L=Perl Weekly Challenge -> True
Example 2:
perl -E '
$x=shift; $y=join "",map{substr $_,0,1}@ARGV; say "W=$x, L=@ARGV -> ", $x eq $y?"True":"False";
' BCJ Bob Charlie Joe
Results:
W=BCJ, L=Bob Charlie Joe -> True
Example 3:
perl -E '
$x=shift; $y=join "",map{substr $_,0,1}@ARGV; say "W=$x, L=@ARGV -> ", $x eq $y?"True":"False";
' MM Morning Good
Results:
W=MM, L=Morning Good -> False
For the full code I add some checks and a normalization.
1 # Perl weekly challenge 317
2 # Task 1: Acronyms
3 #
4 # See https://wlmb.github.io/2025/04/14/PWC317/#task-1-acronyms
5 use v5.36;
6 die <<~"FIN" unless @ARGV >= 2;
7 Usage $0 T W1 W2...
8 to find if T is an acronym for the list of words W1 W2...
9 FIN
10 my $tentative=shift;
11 my $acronym=join "",map{substr $_,0,1}@ARGV;
12 say "Tentative=$tentative, Words=@ARGV -> ", lc $tentative eq lc $acronym?"True":"False";
Example:
./ch-1.pl PWC Perl Weekly Challenge
./ch-1.pl BCJ Bob Charlie Joe
./ch-1.pl MM Morning Good
Results:
Tentative=PWC, Words=Perl Weekly Challenge -> True
Tentative=BCJ, Words=Bob Charlie Joe -> True
Tentative=MM, Words=Morning Good -> False
Task 2: Friendly Strings
Submitted by: Mohammad Sajid Anwar
You are given two strings.
Write a script to return true if swapping any two letters in one
string match the other string, return false otherwise.
Example 1
Input: $str1 = "desc", $str2 = "dsec"
Output: true
Example 2
Input: $str1 = "fuck", $str2 = "fcuk"
Output: true
Example 3
Input: $str1 = "poo", $str2 = "eop"
Output: false
Example 4
Input: $str1 = "stripe", $str2 = "sprite"
Output: true
The two strings are friends if they have the same set of characters but there are exactly two differences between the strings, or they are equal but at least one character is duplicated, so it may be swapped with its duplicate without changing the string. Ignoring the last possibility yields a two-liner.
Example 1:
perl -E '
($p,$q)=@ARGV; @p=split "",$p; @q=split "",$q; $p[$_]eq$q[$_]||++$d for(0..@p-1);($r,$s)=
map{join "",sort{$a cmp $b}@$_}([@p],[@q]); say "@ARGV -> ", $r eq $s && $d==2?"True":"False";
' desc dsec
Results:
desc dsec -> True
Example 2:
perl -E '
($p,$q)=@ARGV; @p=split "",$p; @q=split "",$q; $p[$_]eq$q[$_]||++$d for(0..@p-1);($r,$s)=
map{join "",sort{$a cmp $b}@$_}([@p],[@q]); say "@ARGV -> ", $r eq $s && $d==2?"True":"False";
' fuck fcuk
Results:
fuck fcuk -> True
Example 3:
perl -E '
($p,$q)=@ARGV; @p=split "",$p; @q=split "",$q; $p[$_]eq$q[$_]||++$d for(0..@p-1);($r,$s)=
map{join "",sort{$a cmp $b}@$_}([@p],[@q]); say "@ARGV -> ", $r eq $s && $d==2?"True":"False";
' poo eop
Results:
poo eop -> False
Exmple 4:
perl -E '
($p,$q)=@ARGV; @p=split "",$p; @q=split "",$q; $p[$_]eq$q[$_]||++$d for(0..@p-1);($r,$s)=
map{join "",sort{$a cmp $b}@$_}([@p],[@q]); say "@ARGV -> ", $r eq $s && $d==2?"True":"False";
' stripe sprite
Results:
stripe sprite -> True
For the full code I add the degenerate case.
1 # Perl weekly challenge 317
2 # Task 2: Friendly Strings
3 #
4 # See https://wlmb.github.io/2025/04/14/PWC317/#task-2-friendly-strings
5 use v5.36;
6 use List::Util qw(uniq);
7 die <<~"FIN" unless @ARGV and @ARGV%2==0;
8 Usage: $0 S11 S12 S21 S22...
9 to find if strings Sn1 and Sn2 are friendly, i.e.,
10 match after one swap.
11 FIN
12 for my ($str1, $str2)(@ARGV){
13 my ($arr1, $arr2)=map {[split ""]}($str1, $str2);
14 my $differences=0;
15 $arr1->[$_] eq $arr2->[$_] || ++$differences for(0..$arr1->@*-1);
16 my ($sorted1, $sorted2) = map{join "",sort{$a cmp $b}@$_} ($arr1, $arr2);
17 my @uniq = uniq @$arr1;
18 my $result = ($sorted1 eq $sorted2 # same letters
19 &&
20 ($differences == 2 # exactly two differences
21 || ($differences == 0 && @uniq != @$arr1) # or repeated letter
22 )) ? "True" : "False";
23 say "$str1 $str2 -> $result";
24 }
Examples:
./ch-2.pl desc dsec fuck fcuk poo eop stripe sprite
Results:
desc dsec -> True
fuck fcuk -> True
poo eop -> False
stripe sprite -> True
Other examples:
./ch-2.pl Ah Ah Ahh Ahh
Results:
Ah Ah -> False
Ahh Ahh -> True
The last case is peculiar, in that we can swap the two h’s without changing the word, so both words agree after a single swap.
/;
Written on April 14, 2025