Merge branch 'manwar:master' into master

41 files changed, 2591 insertions, 62 deletions

diff --git a/challenge-209/0rir/raku/ch-1.raku b/challenge-209/0rir/raku/ch-1.raku
new file mode 100644
index 0000000000..0cc411ea05
--- /dev/null
+++ b/challenge-209/0rir/raku/ch-1.raku
@@ -0,0 +1,136 @@
+#!/usr/bin/env raku
+# :vim ft=raku sw=4 expandtab  # 🦋 ∅∪∩∋∈∉ ≡ ≢ «␤ » ∴
+use v6.d;
+use lib $?FILE.IO.parent(2).add("lib");
+use Test;
+
+=begin comment
+209-1: Special Bit Characters       Submitted by: Mohammad S Anwar
+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
+
+The given array bits can be decoded as 2-bits character (10) followed by 1-bit character (0).
+Example 2
+
+Input: @bits = (1, 1, 1, 0)
+Output: 0
+
+Possible decode can be 2-bits character (11) followed by 2-bits character (10) i.e. the last character is not 1-bit character.
+
+=end comment
+
+=begin comment
+A […,0,0] indicates a final 'a'.
+A […,1,0] is ambiguous. That _one_ can be considered the end of a sequence of
+ones. The sequence's length being odd or even, determines if the one belongs
+to a final 'b' or a penultimate 'c'.
+=end comment
+
+constant $V-end = 'a';
+
+my @Data = do for 1..10000 {
+    my $w = .base(3);
+    ($w ~~ tr/0..2/a..c/).Str;
+}
+
+# validate input word
+sub abc-a-valid( $str --> Bool ) {
+    so $str ~~ / ^ <[abc]>* $V-end $/;
+}
+
+# convert a test word to array of 1's and 0's
+sub abc-encode( $str is copy --> Array ) {
+    $str.=subst( 'c', '11', :g);
+    $str.=subst( 'b', '10', :g);
+    $str.=subst( 'a',  '0', :g);
+    $str.comb.Array;
+}
+
+enum State <SizeQ Small Large DoneQ Done>;
+
+# For empirical verification. Not the solution.
+sub abc-decode ( @bit --> Str ) {
+
+    # STATE vars
+    my $return;
+    my $idx = 0;
+
+    my %transition  = 
+        SizeQ => -> { @bit[$idx] == 0 ?? "Small" !! "Large" },  # First state.
+        Small => -> { $return ~= 'a';  ++$idx; "DoneQ" },
+        Large => -> { 
+            $return ~= @bit[$idx+1] == 0 ?? 'b' !! 'c';
+            die 'ilformed input' if $idx > @bit.end;
+            $idx += 2;
+            'DoneQ';
+        },
+        DoneQ => -> { if $idx ≤ @bit.end { "SizeQ" } else { 'Done' }},
+        Done  => "End marker for the state machine.",
+    ;
+
+    my $state = 'SizeQ';
+    while $state ne 'Done' {
+        $state = %transition{$state}();
+    }
+    $return;
+}
+
+# calc correct answer
+sub abc-expect( $str --> Bool) {
+    when $str ~~ / a $/  { True  }
+    False;
+}
+
+multi sub ends-with-a( @bit where @bit.end < 3 --> Bool ) {
+    given @bit { 
+            # a, aa, ba, aaa, ca
+        when [[0],   [0,0], [1,0,0], [0,0,0], [1,1,0],].any { True }
+            # b,  c, ab, a,c
+        when [[1,0], [1,1], [0,1,0], [0,1,1],         ].any { False }
+            # splat
+        when [ [], [1], [0,1], [0,0,1], [1,0,1], [1,1,1],].any { fail }
+    }
+}
+
+multi sub ends-with-a( @bit --> Bool ) {
+
+    fail if @bit.tail ≠ 0;
+
+    return True if @bit[*-2] == 0;
+
+    return so (
+         @bit.end - 1
+        -
+        ( @bit[0..*-2].first( * !~~ 1, :k, :end) // -1)
+    ) %% 2;
+}
+
+my @Test = @Data.grep: *  ~~ / a $ /;
+
+plan 2 × @Test;
+
+for @Test -> $in {
+    my $exp = abc-expect( $in);
+    my @bit = abc-encode( $in);
+    my $uncode = abc-decode( @bit);
+    is $uncode, $in, "$in to bits and back";
+    is ends-with-a(@bit), $exp, "$uncode -> @bit[] -> $exp";
+}
+done-testing;
+
+my @bit = 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 0;
+
+say "\nInput: @bits = @bit[]\nOutput: ", &ends-with-a( @bit) ?? 1 !! 0;
+
+exit;
+
diff --git a/challenge-209/0rir/raku/ch-2.raku b/challenge-209/0rir/raku/ch-2.raku
new file mode 100644
index 0000000000..90b9cae440
--- /dev/null
+++ b/challenge-209/0rir/raku/ch-2.raku
@@ -0,0 +1,125 @@
+#!/usr/bin/env raku
+# :vim ft=raku sw=4 expandtab  # 🦋 ∅∪∩∋∈∉ ≡ ≢ «␤ » ∴
+use v6.d;
+use Test;
+
+=begin comment  
+209-Task 2: Merge Account           Submitted by: Mohammad S Anwar
+Given an array of accounts i.e. name with list of email addresses,
+merge the accounts where possible. Accounts can only be merged if
+they have at least one email address in common.
+
+Example 1:
+
+Input: @accounts = [ ["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: @accounts = [ ["A", "a1@a.com", "a2@a.com"],
+                     ["B", "b1@b.com"],
+                     ["A", "a3@a.com"],
+                     ["B"m "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"] ]
+
+=end comment
+
+
+subset Accno of Any where m/ ^ <:Lu> \d \d $ /;
+subset Addr  of Any where m/^ (<:Ll>  \d ** 3) | (<:Lu> ** 4) $/;
+
+sub dsay(*@a ) {;};
+
+my @Data =
+    # a/c  addr ...
+    [< A01 a010 a011 CCCC >],
+    [< A02 a020 a022 BBBB >],
+    [< A03 a030 >],
+    [ 'A04', ],
+    [< A07 BBBB >],
+    [< A08 a070 a071 >],
+    [< A09 a080 a081 CCCC>],
+    [< A10 a101 >],
+    [< A11 a111 CCCC>],
+;
+
+sub MAIN () { 
+    say "Input: @accounts = [";
+    say "    ", $_.raku for @Data; 
+    say "                  ]";
+    say "Output: [";
+    say "    ", $_.raku for combine-accounts( @Data);
+    say "        ]";
+}
+
+#  Combine all possible a/c.
+sub combine-accounts( @database --> Array ) {
+
+    my (%by-ac, %by-addr, %ac2expand, %ac2drop);
+
+    # Hash each a/c.
+    for @database -> @d {
+        %by-ac{@d.head} = [ @d.tail(*-1)]; # XXX Simpler put all in values.
+    }
+
+    # Invert a/c to key by address.
+    %by-addr.append: %by-ac.invert;
+
+    for %by-addr.keys -> $k {
+        when %by-addr{ $k} ~~ Str {      # Address has only one acct so
+            %by-addr{$k}:delete;         # no work.
+        }
+
+        my $key = choose-ac-to-expand( %by-addr{$k});  
+        %ac2expand{$key} = %by-addr{$k}.values.grep(* !~~ $key).Array;
+
+        for %by-addr{$k}.values.grep(* !~~ $key).Array {
+            %ac2drop{ $_ }++ ;
+    }   }
+
+    my @expanded = merge-acs( %ac2expand, %by-ac);
+    for @expanded -> ( :key($k), :value($v) ) {
+        %by-ac{$k} = $v;
+    }
+    for %ac2drop.keys -> $k {
+        %by-ac{$k}:delete;
+    }
+
+    my @new;
+    for %by-ac.keys.sort -> $k {
+        @new.push: [$k, |%by-ac{$k}] ; # | %by-ac{$k} ];
+    }
+    return @new;
+}
+
+# Merge all accts that need combining.
+sub merge-acs( %keepers, %by-ac --> Array ) {
+    my @updated;
+    for %keepers.pairs -> $kp {
+        @updated.push: expand-ac( $kp, %by-ac);
+    }
+    return @updated;
+}
+
+# Merge accounts into the a/c indicated by the Pair $keep.
+sub expand-ac( $keep, %by-ac --> Pair ) {
+    my $key = $keep.key;
+    my @value = $keep.value.Array ;
+
+    for [$key, | $keep.value] -> $pack-me {
+        @value.push: | %by-ac{$pack-me};
+    }
+    $key => @value.unique.Array;
+}
+
+# Choose which a/c to expand vs. consume.
+sub choose-ac-to-expand( @ac --> Accno) { @ac.min( :by( &[leg])); }
+
+
diff --git a/challenge-209/2colours/raku/ch-1.raku b/challenge-209/2colours/raku/ch-1.raku
new file mode 100755
index 0000000000..3b4a2ac689
--- /dev/null
+++ b/challenge-209/2colours/raku/ch-1.raku
@@ -0,0 +1,17 @@
+#!/usr/bin/env raku
+
+
+my token bit { <[01]> };
+subset BitList of Str where /^ '(' <bit>* % ',' ')' $/;
+
+sub MAIN(Str $bits) {
+  die 'Please supply a valid list of bits.' unless $bits.subst(/\s/, '', :g) ~~ BitList;
+  my Str() @bits = $<bit>;
+  die 'The last bit must be zero!' unless @bits[*-1] == 0;
+  my $bit-string = @bits.join;
+  $bit-string
+    .trans: <0 10 11> => <a b c> andthen
+    .substr(*-1) eq 'a' andthen
+    .Int
+    .say;
+}
diff --git a/challenge-209/2colours/raku/ch-2.raku b/challenge-209/2colours/raku/ch-2.raku
new file mode 100755
index 0000000000..3a6ce5e96d
--- /dev/null
+++ b/challenge-209/2colours/raku/ch-2.raku
@@ -0,0 +1,54 @@
+#!/usr/bin/env raku
+
+use Email::Valid; # zef install Email::Valid
+my $email = Email::Valid.new;
+
+# Constraints:
+# - the name can't have quotation marks
+
+my token name { '"' <( .*? )> '"' }
+my token email { '"' <( .*? )> '"' <?{ $email.validate($/.Str) }> }
+my token account { '[' <name> [ ',' <email>+ % ',' ]? ']' }
+subset AccountList of Str where /^ '[' <account>* % ',' ']' $/;
+
+use MONKEY-TYPING;
+augment class Array {
+  proto method unify-transitive is nodal {*}
+  multi method unify-transitive([]:) { [] }
+  multi method unify-transitive([@emails-head, **@rest]:) {
+    my @unified-rest = @rest.unify-transitive;
+    my @result;
+    @result.push: @emails-head;
+    for @unified-rest -> @emails-current {
+      given @result.head {
+        if $_ (&) @emails-current {
+          .append: keys(@emails-current (-) $_);
+        }
+        else {
+          @result.push: @emails-current;
+        }
+      }
+    }
+    @result
+  }
+}
+
+sub build-account-str($name, @mails) {
+  my $mails-part = @mails.map('"' ~ * ~ '"').join(', ');
+  qq:to/END/.chomp
+  ["$name"{", $_" if .so given $mails-part}]
+  END
+}
+
+sub MAIN(Str $accounts) {
+  die 'Please supply a valid list of accounts.' unless $accounts.subst(/\s/, '', :g) ~~ AccountList;
+  my @accounts <==
+    $<account>.map: { .<name>.Str => .<email>>>.Str };
+  @accounts
+    .classify: *.key, as => *.value andthen
+    .duckmap: *.unify-transitive andthen
+    .map: {slip(.key X[&build-account-str] .value[])} andthen
+    .join: ', ' andthen
+    "[$_]" andthen
+    .say;
+}
diff --git a/challenge-209/athanasius/perl/Example_1.txt b/challenge-209/athanasius/perl/Example_1.txt
new file mode 100644
index 0000000000..2cc2ad4af9
--- /dev/null
+++ b/challenge-209/athanasius/perl/Example_1.txt
@@ -0,0 +1,3 @@
+"A","a1@a.com","a2@a.com"
+"B","b1@b.com"
+"A","a3@a.com","a1@a.com"
diff --git a/challenge-209/athanasius/perl/Example_1_answer.txt b/challenge-209/athanasius/perl/Example_1_answer.txt
new file mode 100644
index 0000000000..b5f95b0c63
--- /dev/null
+++ b/challenge-209/athanasius/perl/Example_1_answer.txt
@@ -0,0 +1,2 @@
+"A","a1@a.com","a2@a.com","a3@a.com"
+"B","b1@b.com"
diff --git a/challenge-209/athanasius/perl/Example_2.txt b/challenge-209/athanasius/perl/Example_2.txt
new file mode 100644
index 0000000000..50751d8755
--- /dev/null
+++ b/challenge-209/athanasius/perl/Example_2.txt
@@ -0,0 +1,4 @@
+"A","a1@a.com","a2@a.com"
+"B","b1@b.com"
+"A","a3@a.com"
+"B","b2@b.com","b1@b.com"
diff --git a/challenge-209/athanasius/perl/Example_2_answer.txt b/challenge-209/athanasius/perl/Example_2_answer.txt
new file mode 100644
index 0000000000..1123c1be79
--- /dev/null
+++ b/challenge-209/athanasius/perl/Example_2_answer.txt
@@ -0,0 +1,3 @@
+"A","a1@a.com","a2@a.com"
+"A","a3@a.com"
+"B","b1@b.com","b2@b.com"
diff --git a/challenge-209/athanasius/perl/Transitive.txt b/challenge-209/athanasius/perl/Transitive.txt
new file mode 100644
index 0000000000..b830322e4b
--- /dev/null
+++ b/challenge-209/athanasius/perl/Transitive.txt
@@ -0,0 +1,7 @@
+"A","a1@a.com","a2@a.com"
+"B","b1@b.com"
+"A","a3@a.com","a4@a.com"
+"B","b2@b.com","b3@b.com"
+"A","a4@a.com","a5@a.com"
+"B","b2@b.com","b1@b.com"
+"A","a5@a.com","a1@a.com"
diff --git a/challenge-209/athanasius/perl/Transitive_answer.txt b/challenge-209/athanasius/perl/Transitive_answer.txt
new file mode 100644
index 0000000000..ba7b303db9
--- /dev/null
+++ b/challenge-209/athanasius/perl/Transitive_answer.txt
@@ -0,0 +1,2 @@
+"A","a1@a.com","a2@a.com","a3@a.com","a4@a.com","a5@a.com"
+"B","b1@b.com","b2@b.com","b3@b.com"
diff --git a/challenge-209/athanasius/perl/ch-1.pl b/challenge-209/athanasius/perl/ch-1.pl
new file mode 100644
index 0000000000..7f88a063be
--- /dev/null
+++ b/challenge-209/athanasius/perl/ch-1.pl
@@ -0,0 +1,187 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 209
+=========================
+
+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
+
+  The given array bits can be decoded as 2-bits character (10) followed by 1-bit
+  character (0).
+
+Example 2
+
+  Input: @bits = (1, 1, 1, 0)
+  Output: 0
+
+  Possible decode can be 2-bits character (11) followed by 2-bits character (10)
+  i.e. the last character is not 1-bit character.
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#===============================================================================
+=comment
+
+Interface
+---------
+1. If no command-line arguments are given, the test suite is run. Otherwise:
+2. If $VERBOSE is set to a true value, the required output (1 or 0) is followed
+   by the decoded text.
+
+=cut
+#===============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+use Test::More;
+
+const my $VERBOSE => 1;
+const my $USAGE   =>
+"Usage:
+  perl $0 <bits>
+  perl $0
+
+    <bits>    A string of binary bits ending in 0\n";
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 209, Task #1: Special Bit Characters (Perl)\n\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    my $args = scalar @ARGV;
+
+    if    ($args == 0)
+    {
+        run_tests();
+    }
+    elsif ($args == 1)
+    {
+        my $bits = parse_command_line( $ARGV[ 0 ] );
+
+        printf "Input:  \@bits = (%s)\n", join ', ', @$bits;
+
+        my ($text, $output) = decode( $bits );
+
+        print "Output: $output\n";
+        print "\nDecoded string: $text\n" if $VERBOSE;
+    }
+    else
+    {
+        error( "Expected 1 or 0 command line arguments, found $args");
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub decode
+#-------------------------------------------------------------------------------
+{
+    my ($bits) = @_;
+    my  $text;
+
+    while (@$bits)
+    {
+        my $bit0 = shift @$bits;
+
+        if ($bit0 == 0)
+        {
+            $text .= 'a';
+        }
+        else
+        {
+            my $bit1 = shift @$bits;
+
+            $text .= $bit1 == 0 ? 'b' : 'c';
+        }
+    }
+
+    return ($text, $text =~ / a $ /x ? 1 : 0);
+}
+
+#-------------------------------------------------------------------------------
+sub parse_command_line
+#-------------------------------------------------------------------------------
+{
+    my ($bits) = @_;
+
+    $bits =~ / ^ [01]* 0 $ /x
+        or error( 'Invalid input string' );
+
+    my @bits = split //, $bits;
+
+    return \@bits;
+}
+
+#-------------------------------------------------------------------------------
+sub run_tests
+#-------------------------------------------------------------------------------
+{
+    print "Running the test suite\n";
+
+    while (my $line = <DATA>)
+    {
+        chomp $line;
+
+        my ($test_name, $input, $expected) = split / \| /x, $line;
+
+        $test_name =~ s/ \s+ $ //x;
+        $input     =~ s/ \s+ $ //x;
+
+        my  @bits        = split //, $input;
+        my ($text, $out) = decode( \@bits );
+        my  $got         = "$text=$out";
+
+        is $got, $expected, $test_name;
+    }
+
+    done_testing;
+}
+
+#-------------------------------------------------------------------------------
+sub error
+#-------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+################################################################################
+
+__DATA__
+Example 1|100           |ba=1
+Example 2|1110          |cb=0
+Longer   |11101001101000|cbbacabaa=1
diff --git a/challenge-209/athanasius/perl/ch-2.pl b/challenge-209/athanasius/perl/ch-2.pl
new file mode 100644
index 0000000000..760eebd716
--- /dev/null
+++ b/challenge-209/athanasius/perl/ch-2.pl
@@ -0,0 +1,247 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 209
+=========================
+
+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: @accounts = [ ["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: @accounts = [ ["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"] ]
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#===============================================================================
+=comment
+
+Interface
+---------
+If no command-line arguments are given, the test suite is run.
+
+Assumptions
+-----------
+1. Accounts OF THE SAME NAME can be merged only if they have at least one email
+   address in common.
+2. "Having an email address in common" is a transitive relation, so two accounts
+   with the same name but with no addresses in common can be merged if each has
+   an address in common with (say) a third account of the same name.
+
+Note
+----
+No attempt is made to verify the format of email addresses.
+
+=cut
+#===============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+use Set::Scalar;
+use Test::More;
+use Text::CSV;
+
+const my $INDENT => ' ' x 8;
+const my $USAGE  =>
+"Usage:
+  perl $0 <file>
+  perl $0
+
+    <file>    Name of accounts file\n";
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 209, Task #2: Merge Account (Perl)\n\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    my $args = scalar @ARGV;
+
+    if    ($args == 0)
+    {
+        run_tests();
+    }
+    elsif ($args == 1)
+    {
+        my $accounts = read_accounts_file( $ARGV[ 0 ] );
+
+        print format_accounts( "Input:  \@accounts", $accounts ), "\n";
+
+        my $merged   = merge_accounts( $accounts );
+
+        print format_accounts( "Output: \@merged",   $merged );
+    }
+    else
+    {
+        error( "Expected 1 or 0 command line arguments, found $args" );
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub merge_accounts
+#-------------------------------------------------------------------------------
+{
+    my ($accounts) = @_;
+    my (%name2accounts, @merged);
+
+    for my $account (@$accounts)
+    {
+        my ($name, @addresses) = @$account;
+        push @{ $name2accounts{ $name } }, \@addresses;
+    }
+
+    for my $name (sort keys %name2accounts)
+    {
+        L_LOOP:
+        {
+            my $accounts = $name2accounts{ $name };
+
+            for my $i (0 .. $#$accounts - 1)
+            {
+                my $s = Set::Scalar->new( @{ $accounts->[ $i ] } );
+
+                for my $j ($i + 1 .. $#$accounts)
+                {
+                    my $t   = Set::Scalar->new( @{ $accounts->[ $j ] } );
+                    my $int = $s->intersection( $t );
+
+                    if ($int->size > 0)
+                    {
+                        $accounts->[ $i ] = [ sort $s->union( $t )->members ];
+                        splice @$accounts, $j, 1;
+                        redo L_LOOP;