Robbie Hatley's solutions, in Perl, for The Weekly Challenge #307.

3 files changed, 194 insertions, 0 deletions

diff --git a/challenge-307/robbie-hatley/blog.txt b/challenge-307/robbie-hatley/blog.txt
new file mode 100644
index 0000000000..11f0f0f895
--- /dev/null
+++ b/challenge-307/robbie-hatley/blog.txt
@@ -0,0 +1 @@
+https://hatley-software.blogspot.com/2025/02/robbie-hatleys-solutions-in-perl-for.html
\ No newline at end of file
diff --git a/challenge-307/robbie-hatley/perl/ch-1.pl b/challenge-307/robbie-hatley/perl/ch-1.pl
new file mode 100755
index 0000000000..8e5012207f
--- /dev/null
+++ b/challenge-307/robbie-hatley/perl/ch-1.pl
@@ -0,0 +1,83 @@
+#!/usr/bin/env perl
+
+=pod
+
+--------------------------------------------------------------------------------------------------------------
+TITLE AND ATTRIBUTION:
+Solutions in Perl for The Weekly Challenge 307-1,
+written by Robbie Hatley on Mon Feb 03, 2024.
+
+--------------------------------------------------------------------------------------------------------------
+PROBLEM DESCRIPTION:
+Task 307-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)
+
+--------------------------------------------------------------------------------------------------------------
+PROBLEM NOTES:
+This is just a matter of numeric sort followed by compare.
+
+--------------------------------------------------------------------------------------------------------------
+IO NOTES:
+Input is via either built-in variables or via @ARGV. If using @ARGV, provide one argument which must be a
+single-quoted array of arrays of integers, in proper Perl syntax, like so:
+./ch-1.pl '([18,-42,36,5,17,84,-14],[-3,-2,-1,0,1,2,3],[2,8,18,14,24])'
+
+Output is to STDOUT and will be each input followed by the corresponding output.
+
+=cut
+
+# ------------------------------------------------------------------------------------------------------------
+# PRAGMAS, MODULES, AND SUBS:
+
+   sub check_order {
+      my ($aref1, $aref2) = @_;
+      my @different_indices = ();
+      for ( my $i = 0 ; $i <= $#$aref1 && $i <= $#$aref2 ; ++$i ) {
+         if ($$aref1[$i]!=$$aref2[$i]) {
+            push @different_indices, $i;
+         }
+      }
+      return @different_indices;
+   }
+
+# ------------------------------------------------------------------------------------------------------------
+# INPUTS:
+my @arrays = @ARGV ? eval($ARGV[0]) : ([5,2,4,3,1]  ,  [1,2,1,1,3]  ,  [3,1,3,2,3]);
+#                  Expected outputs : (0, 2, 3, 4)        (1, 3)        (0, 1, 3)
+
+# ------------------------------------------------------------------------------------------------------------
+# MAIN BODY OF PROGRAM:
+$"=', ';
+for my $aref (@arrays) {
+   print "\n";
+   my @original = @$aref;
+   my @sorted   = sort {$a<=>$b} @original;
+   my @indices  = check_order(\@original,\@sorted);
+   print "Original array    = (@original)\n";
+   print "Sorted   array    = (@sorted)\n";
+   print "Indices differing = (@indices)\n";
+}
diff --git a/challenge-307/robbie-hatley/perl/ch-2.pl b/challenge-307/robbie-hatley/perl/ch-2.pl
new file mode 100755
index 0000000000..497aa37b87
--- /dev/null
+++ b/challenge-307/robbie-hatley/perl/ch-2.pl
@@ -0,0 +1,110 @@
+#!/usr/bin/env -S perl -CSDA
+
+=pod
+
+--------------------------------------------------------------------------------------------------------------
+TITLE AND ATTRIBUTION:
+Solutions in Perl for The Weekly Challenge 307-2,
+written by Robbie Hatley on Mon Feb 03, 2024.
+
+--------------------------------------------------------------------------------------------------------------
+PROBLEM DESCRIPTION:
+Task 307-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")
+
+--------------------------------------------------------------------------------------------------------------
+PROBLEM NOTES:
+One simple way to solve this would be to sort the letters of the words, but I'll use a different approach:
+I'll make a "signature" for each word, using the method Newton used in his famous letter to Liebnitz.
+For example, sig("parrot") = "a1o1p1r2t1".
+
+--------------------------------------------------------------------------------------------------------------
+IO NOTES:
+Input is via either built-in variables or via @ARGV. If using @ARGV, provide one argument which must be a
+single-quoted array of arrays of double-quoted all-lower-case English words, in proper Perl syntax, like so:
+./ch-2.pl '(["rabbit", "tar", "rat", "mole"], ["green", "tab", "bat", "poop"])'
+
+Output is to STDOUT and will be each input followed by the corresponding output.
+
+=cut
+
+# ------------------------------------------------------------------------------------------------------------
+# PRAGMAS, MODULES, AND SUBS:
+
+   # Return the Newtonian signature of a word:
+   sub sig {
+      my $word = shift;
+      my @chrs = split //, $word;
+      my %hash;
+      for (@chrs) {
+         ++$hash{$_};
+      }
+      my $sig = '';
+      for (sort keys %hash) {
+         $sig .= $_;
+         $sig .= $hash{$_};
+      }
+      return $sig;
+   }
+
+   # Are two words anagrams of each other?
+   sub are_anagrams {
+      return(sig($_[0]) eq sig($_[1]));
+   }
+
+   # Remove the first of each pair of consecutive anagrams:
+   sub trim_anagrams {
+      my @wrds = @_;
+      for ( my $i = 0 ; $i <= $#wrds-1 ; ++$i ) {
+         if (are_anagrams($wrds[$i],$wrds[$i+1])) {
+            splice(@wrds, $i, 1);
+            --$i;
+         }
+      }
+      return @wrds;
+   }
+
+# ------------------------------------------------------------------------------------------------------------
+# INPUTS:
+my @arrays = @ARGV ? eval($ARGV[0]) :
+(
+   # Input:                                # Expected output:
+   ["acca", "dog", "god", "perl", "repl"], # 3
+   ["abba", "baba", "aabb", "ab", "ab"],   # 2
+);
+
+# ------------------------------------------------------------------------------------------------------------
+# MAIN BODY OF PROGRAM:
+$"=', ';
+for my $aref (@arrays) {
+   print "\n";
+   my @words = @$aref;
+   my @prune = trim_anagrams(@words);
+   my $psize = scalar(@prune);
+   print "Original array   = (@words)\n";
+   print "Without anagrams = (@prune)\n";
+   print "Pruned size      = $psize\n";
+}