Robbie Hatley's Perl solutions to The Weekly Challenge 209

3 files changed, 204 insertions, 0 deletions

diff --git a/challenge-209/robbie-hatley/blog.txt b/challenge-209/robbie-hatley/blog.txt
new file mode 100644
index 0000000000..c81bca0fb3
--- /dev/null
+++ b/challenge-209/robbie-hatley/blog.txt
@@ -0,0 +1 @@
+https://hatley-software.blogspot.com/2023/03/robbie-hatleys-perl-solutions-to-weekly_22.html
\ No newline at end of file
diff --git a/challenge-209/robbie-hatley/perl/ch-1.pl b/challenge-209/robbie-hatley/perl/ch-1.pl
new file mode 100755
index 0000000000..010fe99536
--- /dev/null
+++ b/challenge-209/robbie-hatley/perl/ch-1.pl
@@ -0,0 +1,94 @@
+#! /bin/perl -CSDA
+
+=pod
+
+This is a 120-character-wide Unicode UTF-8 Perl-source-code text file with hard Unix line breaks ("\x0A").
+¡Hablo Español! Говорю Русский. Björt skjöldur. ॐ नमो भगवते वासुदेवाय. 看的星星，知道你是爱。 麦藁雪、富士川町、山梨県。
+=========|=========|=========|=========|=========|=========|=========|=========|=========|=========|=========|=========|
+
+  ----------------------------------------------------------------
+  | Robbie Hatley's Perl soultion to The Weekly Challenge 209-1. |
+  | Written Tue. Mar. 21, 2023, by Robbie Hatley.                |
+  ----------------------------------------------------------------
+
+PROBLEM DESCRIPTION:
+
+Task 1: Special Bit Characters
+Submitted by: Mohammad S Anwar
+You are given an array of binary bits that ends with 0. Valid sequences in the bit string are:
+[0] -decodes-to-> "a"
+[1, 0] -> "b"
+[1, 1] -> "c"
+Write a script to print 1 if the last character is an “a”, otherwise print 0.
+Example 1:   Input: @bits = (1, 0, 0)      Output: 1
+Example 2:   Input: @bits = (1, 1, 1, 0)   Output: 0
+
+INPUT/OUTPUT NOTES:
+
+Input is via built-in array of arrays or by @ARGV. If using @ARGV, input should be a single argument consisting of an
+array of arrays, in proper Perl syntax, surrounded by 'single quotes', like so: '([1,0,0,1,1],[1,1,0,1,0])'
+
+Output is to STDOUT and will be each input array, its decoding, and 1-or-0 (depending on whether-or-not the last
+character of the decoding is 'a').
+
+=cut
+
+# PRELIMINARIES:
+
+use v5.36;
+use strict;
+use warnings;
+use utf8;
+use Sys::Binmode;
+$"=', ';
+
+# DEFAULT INPUTS:
+
+my @arrays = ([1,0,0],[1,1,1,0]);
+
+# NON-DEFAULT INPUTS:
+
+if (@ARGV){
+   @arrays = eval($ARGV[0]);
+}
+
+# SUBROUTINES:
+
+# (none)
+
+# MAIN BODY OF SCRIPT:
+
+for (@arrays){
+   my @array = @{$_};            # Encoded version of string.
+   my $decoding = '';            # Decoded version of string.
+   state $state;                 # State. 0="between characters". 1="in middle of character".
+   $state = 0;                   # We're about to start a new input stream, so we're between characters.
+   for (@array){                 # For each bit of input stream,
+      if ( 0 == $state ){        # if we're between characters,
+         if ( 0 == $_ ){         # if current bit is 0, this is character 'a',
+            $decoding .= 'a';    # so tack an 'a' on the right end of $decoding.
+            $state = 0;          # We're done with current character and ready for next, so $state remains 0.
+         }
+         else{                   # If current bit is 1,
+            $state = 1;          # we're in middle of character so set $state to 1.
+         }
+      }
+      else{                      # If state is 1, current bit determines character.
+         if ( 0 == $_ ){         # If current bit is 0, this is character 'b',
+            $decoding .= 'b';    # so tack a 'b' on the right end of $decoding.
+            $state = 0;          # We're done with current character and ready for next, so set $state to 0.
+         }
+         else{                   # If current bit is 1, this is character 'c',
+            $decoding .= 'c';    # so tack a 'c' on the right end of $decoding.
+            $state = 0;          # We're done with current character and ready for next, so set $state to 0.
+         }
+      }
+   }
+   my $output = substr($decoding,-1) eq 'a' ? 1 : 0;
+   say '';
+   say "Encoded string: (@array)";
+   say "Decoded string: $decoding";
+   say "Output  code:   $output";
+}
+exit 0;
+__END__
diff --git a/challenge-209/robbie-hatley/perl/ch-2.pl b/challenge-209/robbie-hatley/perl/ch-2.pl
new file mode 100755
index 0000000000..0cc1a08279
--- /dev/null
+++ b/challenge-209/robbie-hatley/perl/ch-2.pl
@@ -0,0 +1,109 @@
+#! /bin/perl -CSDA
+
+=pod
+
+This is a 120-character-wide Unicode UTF-8 Perl-source-code text file with hard Unix line breaks ("\x0A").
+¡Hablo Español! Говорю Русский. Björt skjöldur. ॐ नमो भगवते वासुदेवाय. 看的星星，知道你是爱。 麦藁雪、富士川町、山梨県。
+=========|=========|=========|=========|=========|=========|=========|=========|=========|=========|=========|=========|
+
+  ----------------------------------------------------------------
+  | Robbie Hatley's Perl soultion to The Weekly Challenge 209-2. |
+  | Written Tue. Mar. 21, 2023, by Robbie Hatley.                |
+  ----------------------------------------------------------------
+
+PROBLEM DESCRIPTION:
+
+Task 2: Merge Account
+Submitted by: Mohammad S Anwar
+You are given an array of accounts i.e. name with list of email addresses. Write a script to merge the accounts where
+possible. The accounts can only be merged if they have at least one email address in common.
+Example 1: Input:  [['A', 'a1@a.com', 'a2@a.com'] , ['B', 'b1@b.com'] , ['A', 'a3@a.com', 'a1@a.com']]
+           Output: [['A', 'a1@a.com', 'a2@a.com', 'a3@a.com'], ['B', 'b1@b.com']]
+Example 2: Input:  [['A', 'a1@a.com', 'a2@a.com'], ['B', 'b1@b.com'], ['A', 'a3@a.com'], ['B', 'b2@b.com', 'b1@b.com']]
+           Output: [['A', 'a1@a.com', 'a2@a.com'], ['A', 'a3@a.com'], ['B', 'b1@b.com', 'b2@b.com']]
+
+INPUT/OUTPUT NOTES:
+
+Input is via built-in array of arrays of arrays, or by @ARGV. If using @ARGV, input should be a single argument
+consisting of an array of arrays of arrays, in proper Perl syntax, with each email address surrounded by 'single quotes'
+and with the entire array of arrays of arrays surrounded by "double quotes", like so:
+"([['麦','se@gop.com','麦藁@雪.com'],['T','2@38.com'],['藁','麦藁@雪.com','b@a.com']],[['B','f@g.com'],['S','h@i.com']])"
+
+Output is to STDOUT and will be each "raw" set of input arrays, followed by the "merged" set.
+
+=cut
+
+# PRELIMINARIES:
+
+use v5.36;
+use strict;
+use warnings;
+use utf8;
+use Sys::Binmode;
+use List::Util 'uniqstr';
+$" = ', ';
+
+# DEFAULT INPUTS:
+
+# Declare an Array of Arrays of Arrays called @aaa:
+my @array = 
+(
+   [
+      ['A', 'a1@a.com', 'a2@a.com'],
+      ['B', 'b1@b.com'],
+      ['A', 'a3@a.com', 'a1@a.com']
+   ],
+   [
+      ['A', 'a1@a.com', 'a2@a.com'],
+      ['B', 'b1@b.com'],
+      ['A', 'a3@a.com'],
+      ['B', 'b2@b.com', 'b1@b.com']
+   ],
+   [
+      ['麦','se@gop.com','麦藁@雪.com'],
+      ['T','2@38.com'],
+      ['藁','麦藁@雪.com','b@a.com']
+   ],
+   [
+      ['B','f@g.com'],['S','h@i.com']
+   ]
+);
+
+# NON-DEFAULT INPUTS:
+
+if (@ARGV) {@array = eval($ARGV[0])}
+
+# MAIN BODY OF SCRIPT:
+
+for my $set (@array){                          # Riffle through array of sets of accounts.
+   my @accts;                                  # Make an array to hold merged accounts.
+   my %emailhsh;                               # Hash of emails, keyed by email, value = account serial number.
+   my $na = 0;                                 # Next Available account serial number.
+   for (@{$set}){                              # For each account in this set.
+      my @copy = @{$_};                        # Store a COPY of current account in @copy.
+      my $alias = shift @copy;                 # Strip current account's alias from @copy and store separately.
+      my $eater = undef;                       # No eater is defined for this account (yet).
+      for my $email (@copy){                   # For each email address,
+         if (defined $emailhsh{$email}){       # If current email is in use by another account,
+            $eater = $emailhsh{$email};        # mark that account as being the eater of current account
+            last;}}                            # and stop riffling through emails.
+      if (defined $eater){                     # If this account is about to be eaten,
+         for my $email (@copy){                # record each of this account's emails
+            $emailhsh{$email} = $eater;}       # in %emailhsh as now belonging to the eater.
+         my $ealias =                          # Strip eater's alias from left end of emails
+            shift @{$accts[$eater]};           # and store in separate variable.
+         push @{$accts[$eater]}, @copy;        # Paste copy of current account's emails onto eater's emails.
+         @{$accts[$eater]}                     # Sort eater's emails
+            = uniqstr sort @{$accts[$eater]};  # and remove duplicates.
+         unshift @{$accts[$eater]}, $ealias;}  # Tack eater's alias back onto left end of eater's emails.
+      else{                                    # If this account is NOT about to be eaten, store it as a new account.
+         for my $email (@copy){                # Record the new account's emails in %emailhsh as belonging to
+            $emailhsh{$email} = $na;}          # this new account, using Next Available serial number.
+         unshift @copy, $alias;                # Tack alias back onto left end of emails.
+         push @accts, \@copy;                  # Push ref to copy of current account onto @accts.
+         ++$na;}}                              # Increment $na to Next Available serial number.
+   say '';                                     # Start new announcement block.
+   say "Accounts before merging:";             # Announce accounts before merging.
+   say "(@{$_})" for @{$set};                  # Print original set of accounts.
+   say "Accounts after merging:";              # Announce accounts after merging.
+   say "(@{$_})" for @accts;}                  # Print merged set of accounts.
\ No newline at end of file