Perl & Raku solutions to Tasks 1 & 2 of the Perl Weekly Challenge #122

4 files changed, 622 insertions, 0 deletions

diff --git a/challenge-122/athanasius/perl/ch-1.pl b/challenge-122/athanasius/perl/ch-1.pl
new file mode 100644
index 0000000000..428d23965d
--- /dev/null
+++ b/challenge-122/athanasius/perl/ch-1.pl
@@ -0,0 +1,93 @@
+#!perl
+
+###############################################################################
+=comment
+
+Perl Weekly Challenge 122
+=========================
+
+TASK #1
+-------
+*Average of Stream*
+
+Submitted by: Mohammad S Anwar
+
+You are given a stream of numbers, @N.
+
+Write a script to print the average of the stream at every point.
+
+Example
+
+ Input: @N = (10, 20, 30, 40, 50, 60, 70, 80, 90, ...)
+ Output:      10, 15, 20, 25, 30, 35, 40, 45, 50, ...
+
+ Average of first number is 10.
+ Average of first 2 numbers (10+20)/2 = 15
+ Average of first 3 numbers (10+20+30)/3 = 20
+ Average of first 4 numbers (10+20+30+40)/4 = 25 and so on.
+
+=cut
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use Const::Fast;
+use Regexp::Common qw( number );
+
+const my $USAGE =>
+"Usage:
+  perl $0 [<N> ...]
+
+    [<N> ...]    A stream of numbers\n";
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 122, Task #1: Average of Stream (Perl)\n\n";
+}
+
+#==============================================================================
+MAIN:
+#==============================================================================
+{
+    my @N = parse_command_line();
+
+    printf "Input: \@N = (%s)\n", join ', ', @N;
+    print  'Output:      ';
+
+    my $sum   = 0;
+    my $count = 0;
+
+    for my $n (@N)
+    {
+        $sum += $n;
+
+        my $average = $sum / ++$count;
+
+        print ', ' if $count > 1;
+        print $average;
+    }
+
+    print "\n";
+}
+
+#------------------------------------------------------------------------------
+sub parse_command_line
+#------------------------------------------------------------------------------
+{
+    for (@ARGV)
+    {
+        / ^ $RE{num}{real} $ /x
+            or die qq["$_" is not a valid number\n$USAGE];
+    }
+
+    return @ARGV;
+}
+
+###############################################################################
diff --git a/challenge-122/athanasius/perl/ch-2.pl b/challenge-122/athanasius/perl/ch-2.pl
new file mode 100644
index 0000000000..8de2c5a18c
--- /dev/null
+++ b/challenge-122/athanasius/perl/ch-2.pl
@@ -0,0 +1,239 @@
+#!perl
+
+###############################################################################
+=comment
+
+Perl Weekly Challenge 122
+=========================
+
+TASK #2
+-------
+*Basketball Points*
+
+Submitted by: Mohammad S Anwar
+
+You are given a score $S.
+
+You can win basketball points e.g. 1 point, 2 points and 3 points.
+
+Write a script to find out the different ways you can score $S.
+
+Example
+
+ Input: $S = 4
+ Output: 1 1 1 1
+         1 1 2
+         1 2 1
+         1 3
+         2 1 1
+         2 2
+         3 1
+
+ Input: $S = 5
+ Output: 1 1 1 1 1
+         1 1 1 2
+         1 1 2 1
+         1 1 3
+         1 2 1 1
+         1 2 2
+         1 3 1
+         2 1 1 1
+         2 1 2
+         2 2 1
+         2 3
+         3 1 1
+         3 2
+
+=cut
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=comment
+
+Algorithm
+---------
+1. Construct all possible combinations:
+   1a. For each multiple of 2 (including 0) <= S, add in 1s as needed to bring
+       the digit sum up to S
+   1b. For each non-zero multiple of 3 <= S, add in 1s and 2s as per 1a to
+       bring the digit sum up to S
+2. Find the distinct permutations of each combination
+   -- the algorithm is described below at sub get_next_permutation()
+3. Sort the permutations in ascending lexicographical order
+   -- compare strings formed by concatenating the elements of each permutation
+4. Display the results
+
+=cut
+#==============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+use Regexp::Common qw( number );
+
+use Data::Dump qw( dd pp );
+
+const my $USAGE =>
+"Usage:
+  perl $0 <S>
+
+    <S>    A basketball score\n";
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 122, Task #2: Basketball Points (Perl)\n\n";
+}
+
+#==============================================================================
+MAIN:
+#==============================================================================
+{
+    my $S = parse_command_line();
+
+    print "Input:  \$S = $S\n";
+
+    my @perms;
+
+    # 1. Construct all possible combinations
+
+    for my $comb (get_combinations( $S ))
+    {
+        # 2. Find the distinct permutations of each combination
+
+        do
+        {
+            push @perms, [ @$comb ];    # Make a copy
+
+        } while ($comb = get_next_permutation( $comb ));
+    }
+
+    # 3. Sort the permutations in ascending lexicographical order
+
+    @perms = sort { join( '', @$a ) cmp join( '', @$b ) } @perms;
+
+    # 4. Display the results
+
+    if (@perms && @{ $perms[ 0 ] })
+    {
+        printf "Output: %s\n",  join ' ', @{ shift @perms };
+        printf "        %s\n",  join ' ', @$_  for @perms;
+    }
+    else
+    {
+        print  "Output: <none>\n";
+    }
+}
+
+#------------------------------------------------------------------------------
+sub get_combinations
+#------------------------------------------------------------------------------
+{
+    my ($S)    = @_;
+    my  @combs = fill_with_2s( $S );          # Includes zero 2s (i.e., all 1s)
+
+    for my $threes (1 .. int( $S / 3 ))
+    {
+        for my $partition (fill_with_2s( $S - 3 * $threes ))
+        {
+            push @combs, [ @$partition, (3) x $threes ];
+        }
+    }
+
+    return @combs;
+}
+
+#------------------------------------------------------------------------------
+sub fill_with_2s
+#------------------------------------------------------------------------------
+{
+    my ($s) = @_;
+    my  @partitions;
+
+    for my $twos (0 .. int( $s / 2 ))
+    {
+        push @partitions, [ (1) x ($s - 2 * $twos), (2) x $twos ];
+    }
+
+    return @partitions;
+}
+
+#------------------------------------------------------------------------------
+# Algorithm adapted from:
+#   https://en.wikipedia.org/wiki/Permutation#Generation_in_lexicographic_order
+#
+#  "The following algorithm generates the next permutation lexicographically
+#   after a given permutation. It changes the given permutation in-place."
+#
+sub get_next_permutation
+#------------------------------------------------------------------------------
+{
+    my ($comb) = @_;
+
+    # 1. "Find the largest index k such that a[k] < a[k + 1]. If no such index
+    #     exists, the permutation is the last permutation."
+
+    my $k;
+
+    for my $i (0 .. $#$comb - 1)
+    {
+        $k = $i if $comb->[ $i ] < $comb->[ $i + 1 ];
+    }
+
+    return unless defined $k;
+
+    # 2. "Find the largest index l greater than k such that a[k] < a[l]."
+
+    my $l;
+
+    for my $i ($k + 1 .. $#$comb)
+    {
+        $l = $i if $comb->[ $k ] < $comb->[ $i ];
+    }
+
+    # 3. "Swap the value of a[k] with that of a[l]."
+
+    ($comb->[ $k ], $comb->[ $l ]) = ($comb->[ $l ], $comb->[ $k ]);
+
+    # 4. "Reverse the sequence from a[k + 1] up to and including the final
+    #     element a[n]."
+
+    return [ 
+                       @{ $comb }[ 0      .. $k      ],
+               reverse @{ $comb }[ $k + 1 .. $#$comb ]
+           ];
+}
+
+#------------------------------------------------------------------------------
+sub parse_command_line
+#------------------------------------------------------------------------------
+{
+    my $args = scalar @ARGV;
+       $args == 1 or error( "Expected 1 command line argument, found $args" );
+
+    my $S = $ARGV[ 0 ] + 0;    # Normalize
+
+       $S =~ / ^ $RE{num}{int} $ /x
+                  or error( qq["$S" is not a valid integer] );
+
+       $S >= 0    or error( qq["$S" is negative] );
+
+    return $S;
+}
+
+#------------------------------------------------------------------------------
+sub error
+#------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+###############################################################################
diff --git a/challenge-122/athanasius/raku/ch-1.raku b/challenge-122/athanasius/raku/ch-1.raku
new file mode 100644
index 0000000000..608df440f0
--- /dev/null
+++ b/challenge-122/athanasius/raku/ch-1.raku
@@ -0,0 +1,82 @@
+use v6d;
+
+###############################################################################
+=begin comment
+
+Perl Weekly Challenge 122
+=========================
+
+TASK #1
+-------
+*Average of Stream*
+
+Submitted by: Mohammad S Anwar
+
+You are given a stream of numbers, @N.
+
+Write a script to print the average of the stream at every point.
+
+Example
+
+ Input: @N = (10, 20, 30, 40, 50, 60, 70, 80, 90, ...)
+ Output:      10, 15, 20, 25, 30, 35, 40, 45, 50, ...
+
+ Average of first number is 10.
+ Average of first 2 numbers (10+20)/2 = 15
+ Average of first 3 numbers (10+20+30)/3 = 20
+ Average of first 4 numbers (10+20+30+40)/4 = 25 and so on.
+
+=end comment
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+my Bool constant $VERBOSE = True;
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    "\nChallenge 122, Task #1: Average of Stream (Raku)\n".put;
+}
+
+#==============================================================================
+sub MAIN
+(
+    *@N where { .all ~~ Real:D }                         #= A stream of numbers
+)
+#==============================================================================
+{
+    "Input: @N = (%s)\n".printf: @N.join: ', ';
+    'Output:      '.print;
+
+    my Real $sum   = 0;
+    my UInt $count = 0;
+
+    for @N
+    {
+        $sum += $_;
+
+        my Real $average = $sum / ++$count;
+
+        ', '.print if $count > 1;
+        $average.print;
+    }
+
+    put();
+}
+
+#------------------------------------------------------------------------------
+sub USAGE()
+#------------------------------------------------------------------------------
+{
+    my Str $usage = $*USAGE;
+
+    $usage ~~ s/ ($*PROGRAM-NAME) /raku $0/;
+
+    $usage.put;
+}
+
+##############################################################################
diff --git a/challenge-122/athanasius/raku/ch-2.raku b/challenge-122/athanasius/raku/ch-2.raku
new file mode 100644
index 0000000000..37e3a9ae70
--- /dev/null
+++ b/challenge-122/athanasius/raku/ch-2.raku
@@ -0,0 +1,208 @@
+use v6d;
+
+###############################################################################
+=begin comment
+
+Perl Weekly Challenge 122
+=========================
+
+TASK #2
+-------
+*Basketball Points*
+
+Submitted by: Mohammad S Anwar
+
+You are given a score $S.
+
+You can win basketball points e.g. 1 point, 2 points and 3 points.
+
+Write a script to find out the different ways you can score $S.
+
+Example
+
+ Input: $S = 4
+ Output: 1 1 1 1
+         1 1 2
+         1 2 1
+         1 3
+         2 1 1
+         2 2
+         3 1
+
+ Input: $S = 5
+ Output: 1 1 1 1 1
+         1 1 1 2
+         1 1 2 1
+         1 1 3
+         1 2 1 1
+         1 2 2
+         1 3 1
+         2 1 1 1
+         2 1 2
+         2 2 1
+         2 3
+         3 1 1
+         3 2
+
+=end comment
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=begin comment
+
+Algorithm
+---------
+1. Construct all possible combinations:
+   1a. For each multiple of 2 (including 0) <= S, add in 1s as needed to bring
+       the digit sum up to S
+   1b. For each non-zero multiple of 3 <= S, add in 1s and 2s as per 1a to
+       bring the digit sum up to S
+2. Find the distinct permutations of each combination
+   -- the algorithm is described below at sub get-next-permutation()
+3. Sort the permutations in ascending lexicographical order
+   -- compare strings formed by concatenating the elements of each permutation
+4. Display the results
+
+=end comment
+#==============================================================================
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    "\nChallenge 122, Task #2: Basketball Points (Raku)\n".put;
+}
+
+#==============================================================================
+sub MAIN
+(
+    UInt:D $S                      #= A basketball score
+)
+#==============================================================================
+{
+    "Input:  \$S = %s\n".printf: $S + 0;    # Normalize
+
+    my Array[UInt] @perms = Array[UInt].new;
+
+    # 1. Construct all possible combinations
+
+    for get-combinations( $S ) <-> Array[UInt] $comb
+    {
+        # 2. Find the distinct permutations of each combination
+
+        repeat
+        {
+            @perms.push: $comb.clone;       # Make a copy
+
+        } while $comb = get-next-permutation( $comb );
+    }
+
+    # 3. Sort the permutations in ascending lexicographical order
+
+    @perms = @perms.sort: { $^a.join cmp $^b.join };
+
+    # 4. Display the results
+
+    if @perms && @perms[ 0 ]
+    {
+        "Output: %s\n".printf: @perms.shift.join: ' ';
+        "        %s\n".printf: @$_\        .join: ' ' for @perms;
+    }
+    else
+    {
+        "Output: <none>".put;
+    }
+}
+
+#------------------------------------------------------------------------------
+sub get-combinations( UInt:D $S --> Array:D[Array:D[UInt:D]] )
+#------------------------------------------------------------------------------
+{
+    # Note: The combinations returned from fill-with-twos() include one with
+    #       zero 2s (i.e., all 1s)
+
+    my Array[UInt] @combs = fill-with-twos( $S );
+
+    for 1 .. floor( $S / 3 ) -> UInt $threes
+    {
+        for fill-with-twos( $S - 3 * $threes ) -> Array[UInt] $partition
+        {
+            @combs.push: Array[UInt].new( |$partition, |(3 xx $threes) );
+        }
+    }
+
+    return @combs;
+}
+
+#------------------------------------------------------------------------------
+sub fill-with-twos( UInt:D $s --> Array:D[Array:D[UInt:D]] )
+#------------------------------------------------------------------------------
+{
+    my Array[UInt] @partitions;
+
+    for 0 .. floor( $s / 2 ) -> UInt $twos
+    {
+        @partitions.push:
+            Array[UInt].new( |(1 xx ($s - 2 * $twos)), |(2 xx $twos) );
+    }
+
+    return @partitions;
+}
+
+#------------------------------------------------------------------------------
+# Algorithm adapted from:
+#   https://en.wikipedia.org/wiki/Permutation#Generation_in_lexicographic_order
+#
+#  "The following algorithm generates the next permutation lexicographically
+#   after a given permutation. It changes the given permutation in-place."
+#
+sub get-next-permutation( Array:D[UInt:D] $comb --> Array:D[UInt:D] )
+#------------------------------------------------------------------------------
+{
+    # 1. "Find the largest index k such that a[k] < a[k + 1]. If no such index
+    #     exists, the permutation is the last permutation."
+
+    my UInt $k;
+
+    for 0 .. $comb.end - 1 -> UInt $i
+    {
+        $k = $i if $comb[ $i ] < $comb[ $i + 1 ];
+    }
+
+    return Nil unless $k.defined;
+
+    # 2. "Find the largest index l greater than k such that a[k] < a[l]."
+
+    my UInt $l;
+
+    for $k + 1 .. $comb.end -> UInt $i
+    {
+        $l = $i if $comb[ $k ] < $comb[ $i ];
+    }
+
+    # 3. "Swap the value of a[k] with that of a[l]."
+
+    ($comb[ $k ], $comb[ $l ]) = ($comb[ $l ], $comb[ $k ]);
+
+    # 4. "Reverse the sequence from a[k + 1] up to and including the final
+    #     element a[n]."
+
+    return Array[UInt].new( |$comb[ 0      .. $k        ],
+                            |$comb[ $k + 1 .. $comb.end ].reverse );
+}
+
+#------------------------------------------------------------------------------
+sub USAGE()
+#------------------------------------------------------------------------------
+{
+    my Str $usage = $*USAGE;
+
+    $usage ~~ s:g/ ($*PROGRAM-NAME) /raku $0/;
+    $usage.put;
+}
+
+##############################################################################