Perl Weekly Challenge 307.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 307.
Task 1: Check Order
Submitted by: Mohammad Sajid Anwar
You are given an array of integers, @ints.
Write a script to re-arrange the given array in an increasing order and return
the indices where it differs from the original array.
Example 1
Input: @ints = (5, 2, 4, 3, 1)
Output: (0, 2, 3, 4)
Before: (5, 2, 4, 3, 1)
After : (1, 2, 3, 4, 5)
Difference at indices: (0, 2, 3, 4)
Example 2
Input: @ints = (1, 2, 1, 1, 3)
Output: (1, 3)
Before: (1, 2, 1, 1, 3)
After : (1, 1, 1, 2, 3)
Difference at indices: (1, 3)
Example 3
Input: @ints = (3, 1, 3, 2, 3)
Output: (0, 1, 3)
Before: (3, 1, 3, 2, 3)
After : (1, 2, 3, 3, 3)
Difference at indices: (0, 1, 3)
I simply follow directions. I make ordered and unordered versions of the input, compare each element and push the indices of differing terms to an output array. The result fits a one-liner.
Example 1:
perl -E '
@o=sort {$a <=> $b} @i=@ARGV;$o[$_]!=$i[$_] && push @r, $_ for 0..@o-1;say "@i -> @r"
' 5 2 4 3 1
Results:
5 2 4 3 1 -> 0 2 3 4
Example 2:
perl -E '
@o=sort {$a <=> $b} @i=@ARGV;$o[$_]!=$i[$_] && push @r, $_ for 0..@o-1;say "@i -> @r"
' 1 2 1 1 3
Results:
1 2 1 1 3 -> 1 3
Example 3:
perl -E '
@o=sort {$a <=> $b} @i=@ARGV;$o[$_]!=$i[$_] && push @r, $_ for 0..@o-1;say "@i -> @r"
' 3 1 3 2 3
Results:
3 1 3 2 3 -> 0 1 3
The full code is almost identical:
1 # Perl weekly challenge 307
2 # Task 1: Check Order
3 #
4 # See https://wlmb.github.io/2025/02/02/PWC307/#task-1-check-order
5 use v5.36;
6 die <<~"FIN" unless @ARGV;
7 Usage: $0 N0 N1...
8 to find the indices where the array N0 N1... differs from its ordered self.
9 FIN
10 my @ordered = sort {$a <=> $b} @ARGV;
11 my @result;
12 $ordered[$_]!=$ARGV[$_] && push @result, $_ for 0..@ordered-1;
13 say "@ARGV -> @result";
Examples:
./ch-1.pl 5 2 4 3 1
./ch-1.pl 1 2 1 1 3
./ch-1.pl 3 1 3 2 3
Results:
5 2 4 3 1 -> 0 2 3 4
1 2 1 1 3 -> 1 3
3 1 3 2 3 -> 0 1 3
Task 2: Find Anagrams
Submitted by: Mohammad Sajid Anwar
You are given a list of words, @words.
Write a script to find any two consecutive words and if they are anagrams,
drop the first word and keep the second. You continue this until there is
no more anagrams in the given list and return the count of final list.
Example 1
Input: @words = ("acca", "dog", "god", "perl", "repl")
Output: 3
Step 1: "dog" and "god" are anagrams, so dropping "dog"
and keeping "god" => ("acca", "god", "perl", "repl")
Step 2: "perl" and "repl" are anagrams, so dropping "perl" and
keeping "repl" => ("acca", "god", "repl")
Example 2
Input: @words = ("abba", "baba", "aabb", "ab", "ab")
Output: 2
Step 1: "abba" and "baba" are anagrams, so dropping "abba" and keeping
"baba" => ("baba", "aabb", "ab", "ab")
Step 2: "baba" and "aabb" are anagrams, so dropping "baba" and keeping
"aabb" => ("aabb", "ab", "ab")
Step 3: "ab" and "ab" are anagrams, so dropping "ab" and keeping
"ab" => ("aabb", "ab")
I make a hash of letters of each word and their count. I convert the
hashes to strings of the form L0.N0.L1.N1… where each Li is a letter
and each Ni is the corresponding number of repetitions. Two words are
anagrams if their strings are equal. The description suggest removing
anagrams one by one, but I make a shortcut and get the final count by
counting unique strings. The result fits a oneliner using the uniq
subroutine from List::Util.
Example 1:
perl -MList::Util=uniq -E '
say "@ARGV -> ", 0+uniq map{my %h; $h{lc $_}++ for split "";join "", map {$_,$h{$_}} sort keys %h}@ARGV;
' acca dog god perl repl
Results:
acca dog god perl repl -> 3
Example 2:
perl -MList::Util=uniq -E '
say "@ARGV -> ", 0+uniq map{my %h; $h{lc $_}++ for split "";join "", map {$_,$h{$_}} sort keys %h}@ARGV;
' abba baba aabb ab ab
Results:
abba baba aabb ab ab -> 2
The full code is similar:
1 # Perl weekly challenge 307
2 # Task 2: Find Anagrams
3 #
4 # See https://wlmb.github.io/2025/02/02/PWC307/#task-2-find-anagrams
5 use v5.36;
6 die <<~"FIN" unless @ARGV;
7 Usage: $0 W0 W1 W2
8 to count anagram equivalence classes among the words Wi.
9 FIN
10 use List::Util qw(uniq);
11 say "@ARGV -> ",
12 0 + uniq
13 map {
14 my %hash;
15 $hash{lc $_}++ for split "";
16 join "", map {
17 $_, $hash{$_}
18 }sort keys %hash
19 } @ARGV;
Examples:
./ch-2.pl acca dog god perl repl
./ch-2.pl abba baba aabb ab ab
Results:
acca dog god perl repl -> 3
abba baba aabb ab ab -> 2
Note
Jo pointed out in a comment that the first of two consecutive anagrams is to be dropped. In my solutions above I didn’t care if they were or not consecutive. So I change slightly my solutions above. I increment a counter whenever I find a word that is not an anagram of the previous one, and I replace it for the next iteration.
Example 1:
perl -E '
($_ ne $l)&&(++$c),$l=$_ for map{my %h; $h{lc $_}++ for split "";join "", map {$_,$h{$_}} sort keys %h}@ARGV;
say "@ARGV -> $c";
' acca dog god perl repl
Results:
acca dog god perl repl -> 3
Example 2:
perl -E '
($_ ne $l)&&(++$c),$l=$_ for map{my %h; $h{lc $_}++ for split "";join "", map {$_,$h{$_}} sort keys %h}@ARGV;
say "@ARGV -> $c";
' abba baba aabb ab ab
Results:
abba baba aabb ab ab -> 2
I check that this works correctly for non-consecutive anagrams by permutting the first example:
perl -E '
($_ ne $l)&&(++$c),$l=$_ for map{my %h; $h{lc $_}++ for split "";join "", map {$_,$h{$_}} sort keys %h}@ARGV;
say "@ARGV -> $c";
' acca god perl repl dog
Results:
acca god perl repl dog -> 4
I similarly change the full code:
1 # Perl weekly challenge 307
2 # Task 2: Find Anagrams
3 #
4 # See https://wlmb.github.io/2025/02/02/PWC307/#task-2-find-anagrams
5 use v5.36;
6 die <<~"FIN" unless @ARGV;
7 Usage: $0 W0 W1 W2
8 to count anagram equivalence classes among the words Wi.
9 FIN
10 my $last;
11 my $count=0;
12 (!defined $last || $_ ne $last)&&++$count, $last = $_
13 for map {
14 my %hash;
15 $hash{lc $_}++ for split "";
16 join "", map {
17 $_, $hash{$_}
18 }sort keys %hash
19 } @ARGV;
20 say "@ARGV -> $count";
./ch-2a.pl acca dog god perl repl
./ch-2a.pl abba baba aabb ab ab
./ch-2a.pl acca god perl repl dog
Results:
acca dog god perl repl -> 3
abba baba aabb ab ab -> 2
acca god perl repl dog -> 4