Perl & Raku solutions to Task 1, and Perl solution to Task 2, for Week 209

9 files changed, 636 insertions, 0 deletions

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;
+                    }
+                }
+            }
+
+            push @merged, [ $name, @$_ ] for @$accounts;
+        }
+    }
+
+    return \@merged;
+}
+
+#-------------------------------------------------------------------------------
+sub read_accounts_file
+#-------------------------------------------------------------------------------
+{
+    my ($filename) = @_;
+    -e  $filename or error( qq[File "$filename" not found] );
+
+    my @accounts;
+    my $csv = Text::CSV->new(
+                                {
+                                    allow_loose_quotes => 1,
+                                    auto_diag          => 1,
+                                    binary             => 1,
+                                }
+                            );
+
+    open( my $fh, '<', $filename )
+        or die "Cannot open file $filename for reading, stopped";
+
+    while (my $row = $csv->getline( $fh ))
+    {
+        push @accounts, $row;
+    }
+
+    close $fh
+        or die "Cannot close file $filename, stopped";
+
+    return \@accounts;
+}
+
+#-------------------------------------------------------------------------------
+sub format_accounts
+#-------------------------------------------------------------------------------
+{
+    my ($header, $accounts) = @_;
+
+    return sprintf "$header =\n%s[\n%s\n%s]\n",
+        $INDENT,
+        join
+        (
+            ",\n",
+            map
+            {
+                $INDENT . '  [' . join( ', ', map { qq["$_"] } @$_ ) . ']'
+
+            } @$accounts
+        ),
+        $INDENT;
+}
+
+#-------------------------------------------------------------------------------
+sub run_tests
+#-------------------------------------------------------------------------------
+{
+    print "Running the test suite\n";
+
+    while (my $line = <DATA>)
+    {
+        chomp $line;
+
+        my ($test_name, $in_file, $out_file) = split / \| /x, $line;
+        my  $got = merge_accounts( read_accounts_file( $in_file  ) );
+        my  $expected =            read_accounts_file( $out_file );
+
+        is_deeply $got, $expected, $test_name;
+    }
+
+    done_testing;
+}
+
+#-------------------------------------------------------------------------------
+sub error
+#-------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+################################################################################
+
+__DATA__
+Example 1 |Example_1.txt |Example_1_answer.txt
+Example 2 |Example_2.txt |Example_2_answer.txt
+Transitive|Transitive.txt|Transitive_answer.txt
diff --git a/challenge-209/athanasius/raku/ch-1.raku b/challenge-209/athanasius/raku/ch-1.raku
new file mode 100644
index 0000000000..ca374cb8bc
--- /dev/null
+++ b/challenge-209/athanasius/raku/ch-1.raku
@@ -0,0 +1,181 @@
+use v6d;
+
+################################################################################
+=begin 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.
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#===============================================================================
+=begin comment
+
+Interface
+---------
+1. If no command-line arguments are given, the test suite is run. Otherwise:
+2. If $VERBOSE is True, the required output (1 or 0) is followed by the decoded
+   text.
+
+=end comment
+#===============================================================================
+
+use Test;
+
+my Bool constant $VERBOSE = True;
+
+subset Bit of Int where 0 | 1;
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    "\nChallenge 209, Task #1: Special Bit Characters (Raku)\n".put;
+}
+
+#===============================================================================
+multi sub MAIN
+(
+    Str:D $bits where / ^ <[01]>* 0 $ /   #= A string of binary bits ending in 0
+)
+#===============================================================================
+{
+    my Bit @bits = $bits.split( '', :skip-empty ).map: { .Int };
+
+    "Input:  \@bits = (%s)\n".printf: @bits.join: ', ';
+
+    my (Str $text, Bit $output) = decode( @bits );
+
+    "Output: $output".put;
+
+    "\nDecoded string: $text".put if $VERBOSE;
+}
+
+#===============================================================================
+multi sub MAIN()                                  # No input: run the test suite
+#===============================================================================
+{
+    run-tests();
+}
+
+#-------------------------------------------------------------------------------
+sub decode( List:D[Bit:D] $bits --> List:D[Str:D, Bit:D] )
+#-------------------------------------------------------------------------------
+{
+    my Bit @bits = @$bits;        # Make a copy
+    my Str $text;
+
+    while @bits
+    {
+        my Bit $bit0 = @bits.shift;
+
+        if $bit0 == 0
+        {
+            $text ~= 'a';
+        }
+        else
+        {
+            my Bit $bit1 = @bits.shift;
+
+            $text ~= $bit1 == 0 ?? 'b' !! 'c';
+        }
+    }
+
+    return $text, $text ~~ / a $ / ?? 1 !! 0;
+}
+
+#-------------------------------------------------------------------------------
+sub run-tests()
+#-------------------------------------------------------------------------------
+{
+    'Running the test suite'.put;
+
+    for test-data.lines -> Str $line
+    {
+        my Str ($test-name, $input, $expected) = $line.split: / \| /;
+
+        $test-name ~~ s/ \s+ $ //;
+        $input     ~~ s/ \s+ $ //;
+
+        my  Bit @bits = $input.split( '', :skip-empty ).map: { .Int };
+        my (Str $text,
+            Bit $out) = decode( @bits );
+        my  Str $got  = "$text=$out";
+
+        is $got, $expected, $test-name;
+    }
+
+    done-testing;
+}
+
+#-------------------------------------------------------------------------------
+sub error( Str:D $message )
+#-------------------------------------------------------------------------------
+{
+    "ERROR: $message".put;
+
+    USAGE();
+
+    exit 0;
+}
+
+#-------------------------------------------------------------------------------
+sub USAGE()
+#-------------------------------------------------------------------------------
+{
+    my Str $usage = $*USAGE;
+
+    $usage ~~ s:g/ ($*PROGRAM-NAME) /raku $0/;
+
+    $usage.put;
+}
+
+#-------------------------------------------------------------------------------
+sub test-data( --> Str:D )
+#-------------------------------------------------------------------------------
+{
+    return q:to/END/;
+        Example 1|100           |ba=1
+        Example 2|1110          |cb=0
+        Longer   |11101001101000|cbbacabaa=1
+        END
+}
+
+################################################################################