Merge pull request #8713 from PerlMonk-Athanasius/branch-for-challenge-234

Perl & Raku solutions to Tasks 1 & 2 for Week 234

4 files changed, 855 insertions, 0 deletions

diff --git a/challenge-234/athanasius/perl/ch-1.pl b/challenge-234/athanasius/perl/ch-1.pl
new file mode 100644
index 0000000000..731f7fc64d
--- /dev/null
+++ b/challenge-234/athanasius/perl/ch-1.pl
@@ -0,0 +1,183 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 234
+=========================
+
+TASK #1
+-------
+*Common Characters*
+
+Submitted by: Mohammad S Anwar
+
+You are given an array of words made up of alphabetic characters only.
+
+Write a script to return all alphabetic characters that show up in all words
+including duplicates.
+
+Example 1
+
+  Input: @words = ("java", "javascript", "julia")
+  Output: ("j", "a")
+
+Example 2
+
+  Input: @words = ("bella", "label", "roller")
+  Output: ("e", "l", "l")
+
+Example 3
+
+  Input: @words = ("cool", "lock", "cook")
+  Output: ("c", "o")
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#===============================================================================
+=comment
+
+Assumptions
+-----------
+1. Matching is NOT case-sensitive.
+2. Characters in the output are listed in the order (and case) they have within
+   the first word.
+
+Interface
+---------
+If no command-line arguments are given, the test suite is run.
+
+=cut
+#===============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+use Test::More;
+
+const my $USAGE =>
+"Usage:
+  perl $0 [<words> ...]
+  perl $0
+
+    [<words> ...]    A non-empty list of alphabetic words\n";
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 234, Task #1: Common Characters (Perl)\n\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    if (scalar @ARGV == 0)
+    {
+        run_tests();
+    }
+    else
+    {
+        my @words = @ARGV;
+
+        / ^ [a-z]+ $ /ix or error( qq["$_" is not a valid word] )  for @words;
+
+        printf "Input:  \@words = (%s)\n", join ', ', map { qq["$_"] } @words;
+
+        my $common = find_common_characters( \@words );
+
+        printf "Output: (%s)\n",           join ', ', map { qq["$_"] } @$common;
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub find_common_characters
+#-------------------------------------------------------------------------------
+{
+    my ($words) = @_;
+    my  %common;
+      ++$common{ $_ } for split //, lc $words->[ 0 ];
+
+    for my $word (@$words[ 1 .. $#$words ])
+    {
+        my %next;
+         ++$next{ $_ } for split //, lc $word;
+
+        # Find the intersection
+
+        exists $next{ $_ } || delete $common{ $_ } for keys %common;
+
+        for my $chr (keys %next)
+        {
+            $common{ $chr } = $next{ $chr }
+                if exists $common{ $chr } && $next{ $chr } < $common{ $chr };
+        }
+    }
+
+    my @common;
+
+    for my $chr (split //, $words->[ 0 ])
+    {
+        my $key = lc $chr;
+
+        if (exists $common{ $key } && $common{ $key } > 0)
+        {
+            push @common, $chr;
+            --$common{ $key };
+        }
+    }
+
+    return \@common;
+}
+
+#-------------------------------------------------------------------------------
+sub run_tests
+#-------------------------------------------------------------------------------
+{
+    print "Running the test suite\n";
+
+    while (my $line = <DATA>)
+    {
+        chomp $line;
+
+        my  ($test_name, $words_str, $exp_str) = split / \| /x, $line;
+
+        for ($test_name, $words_str, $exp_str)
+        {
+            s/ ^ \s+   //x;
+            s/   \s+ $ //x;
+        }
+
+        my @words  = split / \s+ /x, $words_str;
+        my @exp    = split / \s+ /x, $exp_str;
+        my $common = find_common_characters( \@words );
+
+        is_deeply $common, \@exp, $test_name;
+    }
+
+    done_testing;
+}
+
+#-------------------------------------------------------------------------------
+sub error
+#-------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+################################################################################
+
+__DATA__
+Example 1 |java  javascript julia |j a
+Example 2 |bella label      roller|e l l
+Example 3 |cool  lock       cook  |c o
+Mixed case|JavA  javascript julia |J a
diff --git a/challenge-234/athanasius/perl/ch-2.pl b/challenge-234/athanasius/perl/ch-2.pl
new file mode 100644
index 0000000000..e3d35fb15a
--- /dev/null
+++ b/challenge-234/athanasius/perl/ch-2.pl
@@ -0,0 +1,234 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 234
+=========================
+
+TASK #2
+-------
+*Unequal Triplets*
+
+Submitted by: Mohammad S Anwar
+
+You are given an array of positive integers.
+
+Write a script to find the number of triplets (i, j, k) that satisfies num[i] !=
+num[j], num[j] != num[k] and num[k] != num[i].
+
+Example 1
+
+  Input: @ints = (4, 4, 2, 4, 3)
+  Output: 3
+
+  (0, 2, 4) because 4 != 2 != 3
+  (1, 2, 4) because 4 != 2 != 3
+  (2, 3, 4) because 2 != 4 != 3
+
+Example 2
+
+  Input: @ints = (1, 1, 1, 1, 1)
+  Output: 0
+
+Example 3
+
+  Input: @ints = (4, 7, 1, 10, 7, 4, 1, 1)
+  Output: 28
+
+  triplets of 1, 4, 7  = 3x2×2 = 12 combinations
+  triplets of 1, 4, 10 = 3×2×1 = 6  combinations
+  triplets of 4, 7, 10 = 2×2×1 = 4  combinations
+  triplets of 1, 7, 10 = 3x2x1 = 6  combinations
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#===============================================================================
+=comment
+
+Assumption
+----------
+A "positive" integer is greater than zero.
+
+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 default), the output is followed by
+   an explanation like that in Example 3.
+
+=cut
+#===============================================================================
+
+use strict;
+use warnings;
+use Algorithm::Combinatorics qw( combinations );
+use Const::Fast;
+use List::MoreUtils          qw( mesh );
+use Regexp::Common           qw( number );
+use Test::More;
+
+const my $PRODUCT => 6;
+const my $SIZE    => 3;
+const my $VERBOSE => 1;
+const my $USAGE   =>
+"Usage:
+  perl $0 [<ints> ...]
+  perl $0
+
+    [<ints> ...]    A non-empty list of positive integers\n";
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 234, Task #2: Unequal Triplets (Perl)\n\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    if (scalar @ARGV == 0)
+    {
+        run_tests();
+    }
+    else
+    {
+        my @ints = @ARGV;
+
+        for (@ints)
+        { 
+            / ^ $RE{num}{int} $ /x or error( qq["$_" is not a valid integer]  );
+            $_ > 0                 or error( qq[$_ is not a positive integer] );
+        }
+
+        printf "Input:  \@ints = (%s)\n", join ', ', @ints;
+
+        my @table;
+        my $count = count_unequal_triplets( \@ints, $VERBOSE, \@table );
+
+        print "Output: $count\n";
+
+        print_table( \@table ) if $VERBOSE && $count > 0;
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub count_unequal_triplets
+#-------------------------------------------------------------------------------
+{
+    my ($ints, $verbose, $table) = @_;
+    my  %dict;
+      ++$dict{ $_ } for @$ints;
+
+    my  $count = 0;
+    my  @keys  = sort { $a <=> $b } keys %dict;
+
+    if (scalar @keys >= $SIZE)
+    {
+        my $iter = combinations( \@keys, $SIZE );
+
+        while (my $comb = $iter->next)
+        {
+            my ($i, $j, $k) = @$comb;
+
+            my $ival = $dict{ $i };
+            my $jval = $dict{ $j };
+            my $kval = $dict{ $k };
+            my $prod = $ival * $jval * $kval;
+
+            $count += $prod;
+
+            push @$table, [ $i, $j, $k, $ival, $jval, $kval, $prod ]
+                if $verbose;
+        }
+    }
+
+    return $count;
+}
+
+#-------------------------------------------------------------------------------
+sub print_table
+#-------------------------------------------------------------------------------
+{
+    my ($table)  = @_;
+    my  $max_row = $#$table;
+    my  $max_col = scalar @{ $table->[ 0 ] } - 1;
+    my  @widths;
+
+    # Calculate maximum column widths
+
+    for my $col (0 .. $max_col)
+    {
+        $widths[ $col ] = length $table->[ 0 ][ $col ];
+
+        for my $row (1 .. $max_row)
+        {
+            my $new_len = length $table->[ $row ][ $col ];
+
+            $widths[ $col ] = $new_len if $new_len > $widths[ $col ];
+        }
+    }
+
+    # Print the table
+
+    print "\n";
+
+    for my $row_data (@$table)
+    {
+        my $prod = $row_data->[ $PRODUCT ];
+
+        printf 'Triplet (%*d, %*d, %*d) occurs in %*d×%*d×%*d = %*d ' .
+               "combination%s\n",
+                mesh( @widths, @$row_data ), $prod == 1 ? '' : 's';
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub run_tests
+#-------------------------------------------------------------------------------
+{
+    print "Running the test suite\n";
+
+    while (my $line = <DATA>)
+    {
+        chomp $line;
+
+        my  ($test_name, $int_str, $exp_str) = split / \| /x, $line;
+
+        for ($test_name, $int_str, $exp_str)
+        {
+            s/ ^ \s+   //x;
+            s/   \s+ $ //x;
+        }
+
+        my @ints  = split / \s+ /x, $int_str;
+        my $count = count_unequal_triplets( \@ints, 0, undef );
+
+        is $count, $exp_str, $test_name;
+    }
+
+    done_testing;
+}
+
+#-------------------------------------------------------------------------------
+sub error
+#-------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+################################################################################
+
+__DATA__
+Example 1|4 4 2  4 3      | 3
+Example 2|1 1 1  1 1      | 0
+Example 3|4 7 1 10 7 4 1 1|28
diff --git a/challenge-234/athanasius/raku/ch-1.raku b/challenge-234/athanasius/raku/ch-1.raku
new file mode 100644
index 0000000000..cd3441cbd6
--- /dev/null
+++ b/challenge-234/athanasius/raku/ch-1.raku
@@ -0,0 +1,199 @@
+use v6d;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 234
+=========================
+
+TASK #1
+-------
+*Common Characters*
+
+Submitted by: Mohammad S Anwar
+
+You are given an array of words made up of alphabetic characters only.
+
+Write a script to return all alphabetic characters that show up in all words
+including duplicates.
+
+Example 1
+
+  Input: @words = ("java", "javascript", "julia")
+  Output: ("j", "a")
+
+Example 2
+
+  Input: @words = ("bella", "label", "roller")
+  Output: ("e", "l", "l")
+
+Example 3
+
+  Input: @words = ("cool", "lock", "cook")
+  Output: ("c", "o")
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#===============================================================================
+=begin comment
+
+Assumptions
+-----------
+1. Matching is NOT case-sensitive.
+2. Characters in the output are listed in the order (and case) they have within
+   the first word.
+
+Interface
+---------
+If no command-line arguments are given, the test suite is run.
+
+=end comment
+#===============================================================================
+
+use Test;
+
+my regex Alpha { <[ A..Z a..z ]> };
+
+subset AlphaChr of Str where / ^ <Alpha>  $ /;
+subset AlphaStr of Str where / ^ <Alpha>+ $ /;
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    "\nChallenge 234, Task #1: Common Characters (Raku)\n".put;
+}
+
+#===============================================================================
+multi sub MAIN
+(
+    #| A non-empty list of alphabetic words
+
+    *@words where { .elems > 0 && .all ~~ AlphaStr:D }
+)
+#===============================================================================
+{
+    "Input:  \@words = (%s)\n".printf: @words.map( { qq["$_"] } ).join: ', ';
+
+    my AlphaChr @common = find-common-characters( @words );
+
+    "Output: (%s)\n".printf: @common.map( { qq["$_"] } ).join: ', ';
+}
+
+#===============================================================================
+multi sub MAIN()                                  # No input: run the test suite
+#===============================================================================
+{
+    run-tests();
+}
+
+#-------------------------------------------------------------------------------
+sub find-common-characters
+(
+    List:D[AlphaStr:D] $words where { .elems > 0 }
+--> List:D[AlphaChr:D]
+)
+#-------------------------------------------------------------------------------
+{
+    my UInt %common{AlphaChr};
+          ++%common{ $_ } for $words[ 0 ].lc.split: '', :skip-empty;
+
+    for $words[ 1 .. $words.end ] -> AlphaStr $word
+    {
+        my UInt %next{AlphaChr};
+              ++%next{ $_ } for $word.lc.split: '', :skip-empty;
+
+        # Find the intersection
+
+        %common{ $_ }:delete unless %next{ $_ }:exists for %common.keys;
+
+        for %next.keys -> AlphaChr $chr
+        {
+            %common{ $chr } = %next{ $chr }
+                if %common{ $chr }:exists && %next{ $chr } < %common{ $chr };
+        }
+    }
+
+    my AlphaChr @common;
+
+    for $words[ 0 ].split( '', :skip-empty ) -> AlphaChr $chr
+    {
+        my AlphaChr $key = $chr.lc;
+
+        if %common{ $key }:exists && %common{ $key } > 0
+        {
+            @common.push: $chr;
+            --%common{ $key };
+        }
+    }
+
+    return @common;
+}
+
+#-------------------------------------------------------------------------------
+sub run-tests()
+#-------------------------------------------------------------------------------
+{
+    'Running the test suite'.put;
+
+    for test-data.lines -> Str $line
+    {
+        my Str ($test-name, $words-str, $exp-str) =
+                $line.split: / \| /;
+
+        for     $test-name, $words-str, $exp-str
+        {
+            s/ ^ \s+   //;
+            s/   \s+ $ //;
+        }
+
+        my AlphaStr @words  = $words-str.split: / \s+ /, :skip-empty;
+        my AlphaChr @exp    = $exp-str\ .split: / \s+ /, :skip-empty;
+        my AlphaChr @common = find-common-characters( @words );
+
+        is-deeply @common, @exp, $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 |java  javascript julia |j a
+        Example 2 |bella label      roller|e l l
+        Example 3 |cool  lock       cook  |c o
+        Mixed case|JavA  javascript julia |J a
+        END
+}
+
+################################################################################
diff --git a/challenge-234/athanasius/raku/ch-2.raku b/challenge-234/athanasius/raku/ch-2.raku
new file mode 100644
index 0000000000..b603f82616
--- /dev/null
+++ b/challenge-234/athanasius/raku/ch-2.raku
@@ -0,0 +1,239 @@
+use v6d;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 234
+=========================
+
+TASK #2
+-------
+*Unequal Triplets*
+
+Submitted by: Mohammad S Anwar
+
+You are given an array of positive integers.
+
+Write a script to find the number of triplets (i, j, k) that satisfies num[i] !=
+num[j], num[j] != num[k] and num[k] != num[i].
+
+Example 1
+
+  Input: @ints = (4, 4, 2, 4, 3)
+  Output: 3
+
+  (0, 2, 4) because 4 != 2 != 3
+  (1, 2, 4) because 4 != 2 != 3
+  (2, 3, 4) because 2 != 4 != 3
+
+Example 2
+
+  Input: @ints = (1, 1, 1, 1, 1)
+  Output: 0
+
+Example 3
+
+  Input: @ints = (4, 7, 1, 10, 7, 4, 1, 1)
+  Output: 28
+
+  triplets of 1, 4, 7  = 3x2×2 = 12 combinations
+  triplets of 1, 4, 10 = 3×2×1 = 6  combinations
+  triplets of 4, 7, 10 = 2×2×1 = 4  combinations
+  triplets of 1, 7, 10 = 3x2x1 = 6  combinations
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#===============================================================================
+=begin comment
+
+Assumption
+----------
+A "positive" integer is greater than zero.
+
+Interface
+---------
+1. If no command-line arguments are given, the test suite is run. Otherwise:
+2. If $VERBOSE is set to True (the default), the output is followed by an
+   explanation like that in Example 3.
+
+=end comment
+#===============================================================================
+
+use Test;
+
+my UInt constant $PROD-IDX = 6;
+my UInt constant $SIZE     = 3;
+my Bool constant $VERBOSE  = True;
+
+subset Pos of Int where * > 0;
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    "\nChallenge 234, Task #2: Unequal Triplets (Raku)\n".put;
+}
+
+#===============================================================================
+multi sub MAIN
+(
+    #| A non-empty list of positive integers
+
+    *@ints where { .elems > 0 && .all ~~ Pos:D }
+)
+#===============================================================================
+{
+    "Input:  \@ints = (%s)\n".printf: @ints.join: ', ';
+
+    my (UInt $count, Array[Array[Pos]] $table) =
+        count-unequal-triplets( @ints, $VERBOSE );
+
+    "Output: $count".put;
+
+    print-table( $table ) if $VERBOSE && $count > 0;
+}
+
+#===============================================================================
+multi sub MAIN()                                  # No input: run the test suite
+#===============================================================================
+{
+    run-tests();
+}
+
+#-------------------------------------------------------------------------------
+sub count-unequal-triplets
+(
+    List:D[Pos:D] $ints,
+    Bool:D        $verbose = False
+--> List:D[ UInt:D, List:D[List:D[Pos:D]] ]
+)
+#-------------------------------------------------------------------------------
+{
+    my UInt %dict{Pos};
+          ++%dict{ $_ } for @$ints.map: { .Int };
+
+    my UInt              $count = 0;
+    my Pos               @keys  = %dict.keys.sort;
+    my Array[Array[Pos]] $table = Array[Array[Pos]].new;
+
+    for @keys.combinations: $SIZE
+    {
+        my Pos ($i, $j, $k) = @$_;
+
+        my Pos $ival = %dict{ $i };
+        my Pos $jval = %dict{ $j };
+        my Pos $kval = %dict{ $k };
+        my Pos $prod = $ival * $jval * $kval;
+
+        $count += $prod;
+
+        $table.push: Array[Pos].new: $i, $j, $k, $ival, $jval, $kval, $prod
+            if $verbose;
+    }
+
+    return $count, $table;
+}
+
+#-------------------------------------------------------------------------------
+multi sub print-table( List:D[List:D[Pos:D]] $table )
+#-------------------------------------------------------------------------------
+{
+    my UInt $max-row = $table.end;
+    my UInt $max-col = $table[ 0 ].end;
+    my UInt @widths;
+
+    # Calculate maximum column widths
+
+    for 0 .. $max-col -> UInt $col
+    {
+        @widths[ $col ] = $table[ 0; $col ].chars;
+
+        for 1 .. $max-row -> UInt $row
+        {
+            my UInt $new-len = $table[ $row; $col ].chars;
+
+            @widths[ $col ]  = $new-len if $new-len > @widths[ $col ];
+        }
+    }
+
+    # Print the table
+
+    put();
+
+    for @$table -> Array[Pos] $row-data
+    {
+        my $prod = $row-data[ $PROD-IDX ];
+
+        ('Triplet (%*d, %*d, %*d) occurs in %*d×%*d×%*d = %*d ' ~
+         "combination%s\n").printf: |(@widths Z @$row-data),
+                                      $prod == 1 ?? '' !! 's';
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub run-tests()
+#-------------------------------------------------------------------------------
+{
+    'Running the test suite'.put;
+
+    for test-data.lines -> Str $line
+    {
+        my Str ($test-name, $int-str, $exp-str) = $line.split: / \| /;
+
+        for     $test-name, $int-str, $exp-str
+        {
+            s/ ^ \s+   //;
+            s/   \s+ $ //;
+        }
+
+        my Array[Array[Pos]] $table = Array[Array[Pos]].new;
+
+        my Pos @ints = $int-str.split( / \s+ /, :skip-empty ).map: { .Int };
+
+        my (UInt $count, List) = count-unequal-triplets( @ints );
+
+        is $count, $exp-str.Int, $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|4 4 2  4 3      | 3
+        Example 2|1 1 1  1 1      | 0
+        Example 3|4 7 1 10 7 4 1 1|28
+        END
+}
+
+################################################################################