Merge pull request #2168 from PerlMonk-Athanasius/branch-for-challenge-075

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

4 files changed, 788 insertions, 0 deletions

diff --git a/challenge-075/athanasius/perl/ch-1.pl b/challenge-075/athanasius/perl/ch-1.pl
new file mode 100644
index 0000000000..80426d36d0
--- /dev/null
+++ b/challenge-075/athanasius/perl/ch-1.pl
@@ -0,0 +1,165 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 075
+=========================
+
+Task #1
+-------
+*Coins Sum*
+
+Submitted by: Mohammad S Anwar
+
+You are given a set of coins _@C_, assuming you have infinite amount of each
+coin in the set.
+
+Write a script to find how many ways you make sum _$S_ using the coins from the
+set _@C_.
+
+Example:
+
+Input:
+    @C = (1, 2, 4)
+    $S = 6
+
+Output: 6
+There are 6 possible ways to make sum 6.
+a) (1, 1, 1, 1, 1, 1)
+b) (1, 1, 1, 1, 2)
+c) (1, 1, 2, 2)
+d) (1, 1, 4)
+e) (2, 2, 2)
+f) (2, 4)
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2020 PerlMonk Athanasius #
+#--------------------------------------#
+
+                                    # Exports:
+use strict;
+use warnings;
+use Const::Fast;                    # const()
+use Getopt::Long;                   # GetOptions()
+use Memoize;                        # memoize()
+use Regexp::Common qw( number );    # %RE{num}
+
+const my $USAGE =>
+"Usage:
+  perl $0 [-S=<Natural>] [<C> ...]
+
+    -S=<Natural>    Target coin sum
+    [<C> ...]       Non-empty set of coin denominations (Naturals <= S)\n";
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 075, Task #1: Coins Sum (Perl)\n\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    my ($S, @C) = parse_command_line();
+
+    # Ensure that @C is a *set* by removing any duplicate coin values; also sort
+    # the values
+
+    my %C = map  { $_  => undef } @C;
+       @C = sort { $a <=> $b    } keys %C;
+
+    # For non-trivial cases, memoization vastly decreases computation time
+
+    memoize('count_coin_combinations');
+
+    # Reversing the coin array -- so that the coins are processed in decreasing
+    # order, largest coins first, smallest coins last -- significantly reduces
+    # the total number of recursive calls to count_coin_combinations()
+
+    my $total = count_coin_combinations($S, reverse @C);
+
+    printf "There %s %s possible way%s to make the sum %s from the coin%s %s\n",
+            $total    == 1 ? 'is' : 'are',
+            add_commas($total),
+            $total    == 1 ? ''   : 's',
+            add_commas($S),
+            scalar @C == 1 ? ''   : 's',
+            join ', ', @C;
+}
+
+#-------------------------------------------------------------------------------
+sub count_coin_combinations                                 # Recursive function
+#-------------------------------------------------------------------------------
+{
+    my ($target, $coin, @coins) = @_;
+    my  $sum = 0;
+
+    if (scalar @coins)              # There are more coins to process
+    {
+        for my $i (0 .. int($target / $coin))
+        {
+            my $new_target = $target - ($i * $coin);
+
+            if ($new_target == 0)   # Base case 1: target already reached
+            {
+                ++$sum;
+            }
+            else                    # Recursive case
+            {
+                $sum += count_coin_combinations($new_target, @coins);
+            }
+        }
+    }
+    else                            # Base case 2: no more coins
+    {
+        $sum = 1 if $target % $coin == 0;
+    }
+
+    return $sum;
+}
+
+#-------------------------------------------------------------------------------
+sub parse_command_line
+#-------------------------------------------------------------------------------
+{
+    my $S;
+
+    GetOptions('S=i' => \$S)    or die $USAGE;
+
+    my @C = @ARGV;
+
+    scalar @C > 0               or die $USAGE;
+    is_natural($S)              or die $USAGE;
+    is_natural($_) && $_ <= $S  or die $USAGE for @C;
+
+    return ($S, @C);
+}
+
+#-------------------------------------------------------------------------------
+sub is_natural
+#-------------------------------------------------------------------------------
+{
+    my ($n) = @_;
+
+    return defined($n) && $n =~ / \A $RE{num}{int} \z /x && $n > 0;
+}
+
+#-------------------------------------------------------------------------------
+sub add_commas
+#-------------------------------------------------------------------------------
+{
+    my ($number) = @_;
+
+    # Regex from perlfaq5: "How can I output my numbers with commas added?"
+
+    return $number =~ s/(^\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1,/gr;
+}
+
+################################################################################
diff --git a/challenge-075/athanasius/perl/ch-2.pl b/challenge-075/athanasius/perl/ch-2.pl
new file mode 100644
index 0000000000..6bc930cc1b
--- /dev/null
+++ b/challenge-075/athanasius/perl/ch-2.pl
@@ -0,0 +1,241 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 075
+=========================
+
+Task #2
+-------
+*Largest Rectangle Histogram*
+
+Submitted by: Mohammad S Anwar
+
+You are given an array of positive numbers _@A_.
+
+Write a script to find the large[s]t rectangle histogram created by the given
+array.
+
+BONUS: Try to print the histogram as shown in the example, if possible.
+
+Example 1:
+
+Input: @A = (2, 1, 4, 5, 3, 7)
+
+     7           #
+     6           #
+     5       #   #
+     4     # #   #
+     3     # # # #
+     2 #   # # # #
+     1 # # # # # #
+     _ _ _ _ _ _ _
+       2 1 4 5 3 7
+
+Looking at the above histogram, the largest rectangle (4 x 3) is formed by
+columns (4, 5, 3 and 7).
+
+Output: 12
+
+Example 2:
+
+Input: @A = (3, 2, 3, 5, 7, 5)
+
+     7         #
+     6         #
+     5       # # #
+     4       # # #
+     3 #   # # # #
+     2 # # # # # #
+     1 # # # # # #
+     _ _ _ _ _ _ _
+       3 2 3 5 7 5
+
+Looking at the above histogram, the largest rectangle (3 x 5) is formed by
+columns (5, 7 and 5).
+
+Output: 15
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2020 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use Const::Fast;                        # Exports const()
+use List::MoreUtils qw( pairwise );
+use List::Util      qw( max );
+use Regexp::Common  qw( number );       # Exports %RE{num}
+
+const my $USAGE =>
+"Usage:
+  perl $0 [<A> ...]
+
+    [<A> ...]    Non-empty sequence of positive integers\n";
+
+const my $MAX_COLUMNS => 38;     # (For my particular command-line screen setup)
+const my $MAX_HEIGHT  => 31;     #  N.B.: The logic in print_histogram() below
+                                 #        assumes that $MAX_HEIGHT < 100
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 075, Task #2: Largest Rectangle Histogram (Perl)\n\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    my @A = parse_command_line();
+
+    print_histogram(@A);
+
+    my $rect = find_largest_rectangle(@A);
+
+    if ($rect->{area} == 0)
+    {
+        print  "\nThe histogram contains no rectangles\n\nArea: 0\n";
+    }
+    else
+    {
+        printf "\nThe largest rectangle (%d x %d) has corners at (C%d, R1) " .
+                 "and (C%d, R%d)\n\nArea: %d\n",
+                  @{$rect}{ qw( width row_r col_l col_r row_r area ) };
+    }
+}
+
+#===============================================================================
+=comment
+
+Assumptions
+-----------
+
+1. A single column (vertical bar) is a rectangle of width 1.
+2. If two or more rectangles have the maximum area, only the first to be found
+   is given as "the largest rectangle".
+
+Algorithm
+---------
+
+In a histogram, all bars are anchored in the first row, from which it follows
+that any candidate for largest rectangle must have 2 of its 4 corners in the
+first row. (If the rectangle is a single bar, its left and right lower corners
+are identical.) A rectangle can be uniquely specified by any 2 diagonally-
+opposite corners. In the solution below, these are the bottom left and top right
+corners.
+
+To check a given column C: for each row R in C, find the longest unbroken line
+of non-empty squares to the immediate right of (C, R). Suppose the line for row
+R ends in column D. Then the rectangle has corners (C, 1) and (D, R); the width
+is D - C + 1; and the height is R.
+
+Any column C to the right of the first needs to be checked iff A[c] > A[c-1],
+because otherwise it's already been included in a check for a previous column.
+By the same logic, if column C does need to be checked at all, only those rows >
+A[c-1] need be checked.
+
+=cut
+#===============================================================================
+
+#-------------------------------------------------------------------------------
+sub find_largest_rectangle
+#-------------------------------------------------------------------------------
+{
+    my @A    = @_;
+    my @keys = qw( col_l col_r row_r width area );
+    my %max  = map { $_ => 0 } @keys;
+
+    for my $col_l (0 .. $#A)
+    {
+        my $prev_row = $col_l ? $A[$col_l - 1] : 0;
+        my $this_row = $A[$col_l];
+
+        if ($col_l == 0 || $this_row > $prev_row)
+        {
+            for my $row ($prev_row + 1 .. $this_row)
+            {
+                my $width = 1;
+                my $col_r = $col_l;
+
+                INNER: for my $col ($col_l + 1 .. $#A)
+                {
+                    if ($A[$col] >= $row)
+                    {
+                        ++$col_r;
+                        ++$width;
+                    }
+                    else
+                    {
+                        last INNER;
+                    }
+                }
+
+                if ((my $area = $width * $row) > $max{area})
+                {
+                    my @new = ($col_l + 1, $col_r + 1, $row, $width, $area);
+                       %max = pairwise { $a => $b } @keys, @new;
+                }
+            }
+        }
+    }
+
+    return \%max;
+}
+
+#-------------------------------------------------------------------------------
+sub print_histogram
+#-------------------------------------------------------------------------------
+{
+    my @A          = @_;
+    my $columns    = scalar @A;
+    my $max_height = max @A;
+
+    if ($columns    <= $MAX_COLUMNS &&
+        $max_height <= $MAX_HEIGHT)
+    {
+        for my $row (reverse 1 .. $max_height)
+        {
+            printf " %2d", $row;
+            print  $_ >= $row ? ' #' : '  ' for @A;
+            print  "\n";
+        }
+
+        printf "  _%s\n", ' _' x $columns;
+
+        if ($max_height < 10)
+        {
+            printf "    %s\n", join ' ', @A;
+        }
+        else
+        {
+            printf "    %s\n", join ' ', map { int($_ / 10) || ' ' } @A;
+            printf "    %s\n", join ' ', map {     $_ % 10         } @A;
+        }
+    }
+    else
+    {
+        printf "The histogram is too %s to print on a single screen\n",
+                $columns > $MAX_COLUMNS ? 'wide' : 'tall';
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub parse_command_line
+#-------------------------------------------------------------------------------
+{
+    my @A = @ARGV;
+
+    scalar @A > 0                                 or die $USAGE;
+    defined($_) && /\A$RE{num}{int}\z/ && $_ >= 0 or die $USAGE for @A;
+
+    return @A;
+}
+
+################################################################################
diff --git a/challenge-075/athanasius/raku/ch-1.raku b/challenge-075/athanasius/raku/ch-1.raku
new file mode 100644
index 0000000000..ee196fe281
--- /dev/null
+++ b/challenge-075/athanasius/raku/ch-1.raku
@@ -0,0 +1,155 @@
+use v6d;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 075
+=========================
+
+Task #1
+-------
+*Coins Sum*
+
+Submitted by: Mohammad S Anwar
+
+You are given a set of coins _@C_, assuming you have infinite amount of each
+coin in the set.
+
+Write a script to find how many ways you make sum _$S_ using the coins from the
+set _@C_.
+
+Example:
+
+Input:
+    @C = (1, 2, 4)
+    $S = 6
+
+Output: 6
+There are 6 possible ways to make sum 6.
+a) (1, 1, 1, 1, 1, 1)
+b) (1, 1, 1, 1, 2)
+c) (1, 1, 2, 2)
+d) (1, 1, 4)
+e) (2, 2, 2)
+f) (2, 4)
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2020 PerlMonk Athanasius #
+#--------------------------------------#
+
+use Memoize;
+
+subset Natural of UInt where * > 0;
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    "\nChallenge 075, Task #1: Coins Sum (Raku)\n".put;
+}
+
+##==============================================================================
+sub MAIN
+(
+    Natural:D :$S,                            #= Target coin sum
+    *@C where { @C.elems > 0        &&        #= Non-empty set of coin
+                @C.all ~~ Natural:D &&        #=   denominations (Naturals <= S)
+                @C.all <= $S }
+)
+##==============================================================================
+{
+    # Ensure that @C is a *set* by removing any duplicate coin values; also sort
+    # the values
+
+    my Nil %C = @C.map: { $_ => Nil };
+
+    @C = %C.keys.sort( { .Int } ).map: { .UInt };
+
+    # For non-trivial cases, memoization vastly decreases computation time
+
+    memoize(&count-coin-combinations);
+
+    # Reversing the coin array -- so that the coins are processed in decreasing
+    # order, largest coins first, smallest coins last -- significantly reduces
+    # the total number of recursive calls to count_coin_combinations()
+
+    my UInt $total = count-coin-combinations($S, [ @C.reverse ]);
+
+    "There %s %s possible way%s to make the sum %s from the coin%s %s\n".printf:
+        $total   == 1 ?? 'is' !! 'are',
+        add-commas($total),
+        $total   == 1 ?? ''   !! 's',
+        add-commas($S),
+        @C.elems == 1 ?? ''   !! 's',
+        @C.join: ', ';
+}
+
+#-------------------------------------------------------------------------------
+sub count-coin-combinations
+(
+    Natural:D          $target,
+    Array:D[Natural:D] $coins,
+--> UInt:D
+)
+#-------------------------------------------------------------------------------
+{
+    my UInt $sum = 0;
+
+    my Natural $coin = $coins.shift;
+
+    if $coins.elems > 0             # There are more coins to process
+    {
+        for 0 .. floor($target / $coin) -> UInt $i
+        {
+            my UInt $new-target = $target - ($i * $coin);
+
+            if $new-target == 0     # Base case 1: target already reached
+            {
+                ++$sum;
+            }
+            else                    # Recursive case
+            {
+                # Note: $coins is an Array object, and therefore a reference; to
+                # pass it by value -- as required here -- it is necessary to
+                # make a copy (clone); otherwise, the effect of shift() above
+                # will propagate to recursive calls higher (i.e., earlier) in
+                # the call hierarchy, leaving $coins in an incorrect state when
+                # those calls are eventually made.
+
+                $sum += count-coin-combinations($new-target, $coins.clone);
+            }
+        }
+    }
+    else                            # Base case 2: no more coins
+    {
+        $sum = 1 if $target % $coin == 0;
+    }
+
+    return $sum;
+}
+
+#-------------------------------------------------------------------------------
+sub USAGE()
+#-------------------------------------------------------------------------------
+{
+    my Str $usage = $*USAGE;
+
+    $usage ~~ s/ ($*PROGRAM-NAME) /raku $0/;
+    $usage.put;
+}
+
+#-------------------------------------------------------------------------------
+sub add-commas(UInt:D $number --> Str:D)
+#-------------------------------------------------------------------------------
+{
+    # From https://rosettacode.org/wiki/Commatizing_numbers#Raku
+
+    return $number.subst: :1st,
+                          / <[ 1 .. 9 ]> <[ 0 .. 9 ]>* /,
+                          *.flip.comb( /<{ '. ** 1..3' }>/ ).join( ',' ).flip;
+}
+
+################################################################################
diff --git a/challenge-075/athanasius/raku/ch-2.raku b/challenge-075/athanasius/raku/ch-2.raku
new file mode 100644
index 0000000000..c13c132541
--- /dev/null
+++ b/challenge-075/athanasius/raku/ch-2.raku
@@ -0,0 +1,227 @@
+use v6d;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 075
+=========================
+
+Task #2
+-------
+*Largest Rectangle Histogram*
+
+Submitted by: Mohammad S Anwar
+
+You are given an array of positive numbers _@A_.
+
+Write a script to find the large[s]t rectangle histogram created by the given
+array.
+
+BONUS: Try to print the histogram as shown in the example, if possible.
+
+Example 1:
+
+Input: @A = (2, 1, 4, 5, 3, 7)
+
+     7           #
+     6           #
+     5       #   #
+     4     # #   #
+     3     # # # #
+     2 #   # # # #
+     1 # # # # # #
+     _ _ _ _ _ _ _
+       2 1 4 5 3 7
+
+Looking at the above histogram, the largest rectangle (4 x 3) is formed by
+columns (4, 5, 3 and 7).
+
+Output: 12
+
+Example 2:
+
+Input: @A = (3, 2, 3, 5, 7, 5)
+
+     7         #
+     6         #
+     5       # # #
+     4       # # #
+     3 #   # # # #
+     2 # # # # # #
+     1 # # # # # #
+     _ _ _ _ _ _ _
+       3 2 3 5 7 5
+
+Looking at the above histogram, the largest rectangle (3 x 5) is formed by
+columns (5, 7 and 5).
+
+Output: 15
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2020 PerlMonk Athanasius #
+#--------------------------------------#
+
+use List::UtilsBy <zip_by>;
+
+my UInt constant $MAX-COLUMNS = 38;     # (For my particular command-line setup)
+my UInt constant $MAX-HEIGHT  = 31;     #  N.B.: The logic in print-histogram()
+                                        #        below assumes $MAX-HEIGHT < 100
+
+#-------------------------------------------------------------------------------
+BEGIN
+#-------------------------------------------------------------------------------
+{
+    "\nChallenge 075, Task #2: Largest Rectangle Histogram (Raku)\n".put;
+}
+
+##==============================================================================
+sub MAIN
+(
+    *@A where { @A.elems > 0  &&      #= Non-empty sequence of positive integers
+                @A.all  ~~ UInt:D }
+)
+##==============================================================================
+{
+    print-histogram(@A);
+
+    my UInt %rect = find-largest-rectangle(@A);
+
+    if %rect<area> == 0
+    {
+        "\nThe histogram contains no rectangles\n\nArea: 0".put;
+    }
+    else
+    {
+        ("\nThe largest rectangle (%d x %d) has corners at " ~
+            "(C%d, R1) and (C%d, R%d)\n\nArea: %d\n").printf:
+                %rect<width row-r col-l col-r row-r area>;
+    }
+}
+
+#===============================================================================
+=begin comment
+
+Assumptions
+-----------
+
+1. A single column (vertical bar) is a rectangle of width 1.
+2. If two or more rectangles have the maximum area, only the first to be found
+   is given as "the largest rectangle".
+
+Algorithm
+---------
+
+In a histogram, all bars are anchored in the first row, from which it follows
+that any candidate for largest rectangle must have 2 of its 4 corners in the
+first row. (If the rectangle is a single bar, its left and right lower corners
+are identical.) A rectangle can be uniquely specified by any 2 diagonally-
+opposite corners. In the solution below, these are the bottom left and top right
+corners.
+
+To check a given column C: for each row R in C, find the longest unbroken line
+of non-empty squares to the immediate right of (C, R). Suppose the line for row
+R ends in column D. Then the rectangle has corners (C, 1) and (D, R); the width
+is D - C + 1; and the height is R.
+
+Any column C to the right of the first needs to be checked iff A[c] > A[c-1],
+because otherwise it's already been included in a check for a previous column.
+By the same logic, if column C does need to be checked at all, only those rows >
+A[c-1] need be checked.
+
+=end comment
+#===============================================================================
+
+#-------------------------------------------------------------------------------
+sub find-largest-rectangle(Array:D[UInt:D] $A --> Hash:D[UInt:D])
+#-------------------------------------------------------------------------------
+{
+    my Str  @keys = <col-l col-r row-r width area>;
+    my UInt %max  = @keys.map: { $_ => 0 };
+
+    for 0 .. $A.end -> UInt $col-l
+    {
+        my UInt $prev-row = $col-l ?? $A[$col-l - 1] !! 0;
+        my UInt $this-row = $A[$col-l];
+
+        if ($col-l == 0 || $this-row > $prev-row)
+        {
+            for $prev-row + 1 .. $this-row -> UInt $row
+            {
+                my UInt $width = 1;
+                my UInt $col-r = $col-l;
+
+                INNER: for $col-l + 1 .. $A.end -> UInt $col
+                {
+                    if $A[$col] >= $row
+                    {
+                        ++$col-r;
+                        ++$width;
+                    }
+                    else
+                    {
+                        last INNER;
+                    }
+                }
+
+                if (my UInt $area = $width * $row) > %max<area>
+                {
+                    %max = zip_by { |@_ }, @keys, ($col-l + 1, $col-r + 1, $row,
+                                                   $width, $area);
+                }
+            }
+        }
+    }
+
+    return %max;
+}
+
+#-------------------------------------------------------------------------------
+sub print-histogram(Array:D[UInt:D] $A)
+#-------------------------------------------------------------------------------
+{
+    my UInt $columns    = $A.elems;
+    my UInt $max-height = $A.max;
+
+    if $columns    <= $MAX-COLUMNS &&
+       $max-height <= $MAX-HEIGHT
+    {
+        for (1 .. $max-height).reverse -> UInt $row
+        {
+            ' %2d'.printf: $row;
+            ' %s' .printf: $_ >= $row ?? '#' !! ' ' for $A.list;
+            ''.put;
+        }
+
+        "  _%s\n".printf: ' _' x $columns;
+
+        if $max-height < 10
+        {
+            "    %s\n".printf: $A.join: ' ';
+        }
+        else
+        {
+            "    %s\n".printf: $A.map( { ($_ / 10).floor || ' ' } ).join: ' ';
+            "    %s\n".printf: $A.map( {  $_ % 10               } ).join: ' ';
+        }
+    }
+    else
+    {
+        "The histogram is too %s to print on a single screen\n".printf:
+            $columns > $MAX-COLUMNS ?? 'wide' !! 'tall';
+    }
+}
+
+#-------------------------------------------------------------------------------
+sub USAGE()
+#-------------------------------------------------------------------------------
+{
+    my Str $usage = $*USAGE;
+
+    $usage ~~ s/ ($*PROGRAM-NAME) /raku $0/;
+    $usage.put;
+}
+
+################################################################################