Perl solution to Task 1, and Perl & Raku solutions to Tasks 1 & 2, of the Perl Weekly Challenge 143

3 files changed, 686 insertions, 0 deletions

diff --git a/challenge-143/athanasius/perl/ch-1.pl b/challenge-143/athanasius/perl/ch-1.pl
new file mode 100644
index 0000000000..6133d96344
--- /dev/null
+++ b/challenge-143/athanasius/perl/ch-1.pl
@@ -0,0 +1,274 @@
+#!perl
+
+###############################################################################
+=comment
+
+Perl Weekly Challenge 143
+=========================
+
+TASK #1
+-------
+*Calculator*
+
+Submitted by: Mohammad S Anwar
+
+You are given a string, $s, containing mathematical expression.
+
+Write a script to print the result of the mathematical expression. To keep it
+simple, please only accept + - * ().
+
+Example 1:
+
+     Input: $s = "10 + 20 - 5"
+     Output: 25
+
+Example 2:
+
+     Input: $s = "(10 + 20 - 5) * 2"
+     Output: 50
+
+=cut
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=comment
+
+Algorithm
+---------
+Evaluation of the given expression is performed in 3 stages:
+
+1. Tokenize the input string
+   -------------------------
+   Tokenization is implemented using the CPAN module HOP::Lexer, which is based
+   on code from the book "Higher-Order Perl" (2005) by Mark Jason Dominus [1].
+
+2. Parse the token stream
+   ----------------------
+   The expression is converted from infix notation to Reverse Polish notation
+   (RPN) using the Shunting-yard algorithm invented by Edsger W Dijkstra, as
+   detailed in [2]. Note that parentheses in the token stream determine the
+   order of evaluation in the RPN queue; they do not appear explicitly in the
+   latter.
+
+3. Evaluate the RPN queue
+   ----------------------
+   Create an empty stack
+   FOR each item in the queue
+       IF the item is a number THEN
+           push it onto the stack
+       ELSE {the item is a binary operator}
+           pop 2 (numerical) operands off the stack
+           perform the given operation on the 2 operands
+           push the result onto the stack
+       ENDIF
+   END FOR
+   There should now be exactly one number on the stack, viz., the result of
+   evaluating the mathematical expression $s.
+
+Caveat
+------
+From [2]: "The shunting yard algorithm will correctly parse all valid infix
+expressions, but does not reject all invalid expressions. For example, "1 2 +"
+is not a valid infix expression, but would be parsed as "1 + 2". The algorithm
+can however reject expressions with mismatched parentheses."
+
+References
+----------
+[1] https://hop.perl.plover.com/
+[2] https://en.wikipedia.org/wiki/Shunting-yard_algorithm
+
+=cut
+#==============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+use HOP::Lexer     qw( string_lexer );
+use Regexp::Common qw( number );
+
+const my %PREC =>       # Operator precedence
+(
+    '+' => 1,
+    '-' => 1,
+    '*' => 2,
+);
+
+const my $USAGE =>
+"Usage:
+  perl $0 <s>
+
+    <s>    String: a mathematical expression with numbers and + - * ()\n";
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 143, Task #1: Calculator (Perl)\n\n";
+}
+
+#==============================================================================
+MAIN:
+#==============================================================================
+{
+    my $args   = scalar @ARGV;
+       $args == 1 or error( "Expected 1 command line argument, found $args" );
+
+    my $s      = $ARGV[ 0 ];
+    my $tokens = tokenize( $s );
+
+    print qq[Input:  \$s = "$s"\n];
+
+    my $queue  = parse   ( $tokens );
+    my $result = evaluate( $queue  );
+
+    print "Output: $result\n";
+}
+
+#------------------------------------------------------------------------------
+sub tokenize
+#------------------------------------------------------------------------------
+{
+    my ($s) = @_;
+  
+    my @input_tokens =
+    (
+        [ NUMBER   => qr/ $RE{num}{real} /x             ],
+        [ OPERATOR => qr/ [+\-*]         /x             ],
+        [ L_PAREN  => qr/ \(             /x             ],
+        [ R_PAREN  => qr/ \)             /x             ],
+        [ SPACE    => qr/ \s*            /x, sub { () } ],
+    );
+  
+    my $lexer = string_lexer( $s, @input_tokens );
+    my @tokens;
+
+    while (my $token = $lexer->())
+    {
+        ref $token eq 'ARRAY' or error( qq[Unrecognized token "$token"] );
+        push @tokens, $token;
+    }
+
+    return \@tokens;
+}
+
+#------------------------------------------------------------------------------
+# See https://en.wikipedia.org/wiki/Shunting-yard_algorithm
+#
+sub parse
+#------------------------------------------------------------------------------
+{
+    my ($tokens) = @_;
+    my  @output_queue;
+    my  @op_stack;
+
+    for my $token (@$tokens)
+    {
+        if    ($token->[ 0 ] eq 'NUMBER')
+        {
+            push @output_queue, $token->[ 1 ];
+        }
+        elsif ($token->[ 0 ] eq 'OPERATOR')
+        {
+            push @output_queue, pop @op_stack
+                while exists $op_stack[ -1 ]               &&
+                             $op_stack[ -1 ] eq 'OPERATOR' &&
+                      $PREC{ $op_stack[ -1 ] } >= $PREC{ $token->[ 1 ] };
+
+            push @op_stack, $token->[ 1 ];
+        }
+        elsif ($token->[ 0 ] eq 'L_PAREN')
+        {
+            push @op_stack, $token->[ 0 ];
+        }
+        elsif ($token->[ 0 ] eq 'R_PAREN')
+        {
+            scalar @op_stack > 0
+                or die 'ERROR: Mismatched parentheses';
+
+            while ($op_stack[ -1 ] ne 'L_PAREN')
+            {
+                push @output_queue, pop @op_stack;
+
+                scalar @op_stack > 0
+                    or die "ERROR: Mismatched parentheses";
+            }                 
+
+            $op_stack[ -1 ] eq 'L_PAREN'
+                or die 'ERROR: Left parenthesis missing';
+
+            pop @op_stack;    # Discard left parenthesis
+        }
+        else
+        {
+            die qq[ERROR: Unrecognized token "$token"];
+        }
+    }
+
+    while (scalar @op_stack > 0)
+    {
+        $op_stack[ 0 ] eq 'L_PAREN'
+            and die 'ERROR: Mismatched parentheses';
+
+        push @output_queue, pop @op_stack;
+    }
+
+    return \@output_queue;
+}
+
+#------------------------------------------------------------------------------
+sub evaluate
+#------------------------------------------------------------------------------
+{
+    my ($queue) = @_;
+    my  @stack;
+
+    for my $item (@$queue)
+    {
+        if    ($item eq '*')
+        {
+            my $n2 = pop @stack;
+            my $n1 = pop @stack;
+
+            push @stack, $n1 * $n2;
+        }
+        elsif ($item eq '+')
+        {
+            my $n2 = pop @stack;
+            my $n1 = pop @stack;
+
+            push @stack, $n1 + $n2;
+        }
+        elsif ($item eq '-')
+        {
+            my $n2 = pop @stack;
+            my $n1 = pop @stack;
+
+            push @stack, $n1 - $n2;
+        }
+        else    # $item is a number
+        {
+            push @stack, $item;
+        }
+    }
+
+    scalar @stack == 1
+        or die sprintf 'ERROR: %d items on stack', scalar @stack;
+
+    return $stack[ 0 ];
+}
+
+#------------------------------------------------------------------------------
+sub error
+#------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+###############################################################################
diff --git a/challenge-143/athanasius/perl/ch-2.pl b/challenge-143/athanasius/perl/ch-2.pl
new file mode 100644
index 0000000000..eb34dc59cf
--- /dev/null
+++ b/challenge-143/athanasius/perl/ch-2.pl
@@ -0,0 +1,225 @@
+#!perl
+
+###############################################################################
+=comment
+
+Perl Weekly Challenge 143
+=========================
+
+TASK #2
+-------
+*Stealthy Number*
+
+Submitted by: Mohammad S Anwar
+
+You are given a positive number, $n.
+
+Write a script to find out if the given number is Stealthy Number.
+
+    A positive integer N is stealthy, if there exist positive integers a, b, c,
+    d such that a * b = c * d = N and a + b = c + d + 1.
+
+Example 1
+
+ Input: $n = 36
+ Output: 1
+
+ Since 36 = 4 (a) * 9 (b) = 6 (c) * 6 (d) and 4 (a) + 9 (b) = 6 (c) + 6 (d) +
+ 1.
+
+Example 2
+
+ Input: $n = 12
+ Output: 1
+
+ Since 2 * 6 = 3 * 4 and 2 + 6 = 3 + 4 + 1
+
+Example 3
+
+ Input: $n = 6
+ Output: 0
+
+ Since 2 * 3 = 1 * 6 but 2 + 3 != 1 + 6 + 1
+
+=cut
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=comment
+
+Interface
+---------
+Set $VERBOSE to a true value (the default) to display an explanation of the
+result when the output is 1. The explanation is modelled on Example 2.
+
+Algorithm
+---------
+The subroutine get_factors() returns the factors of n as pairs (p, q) where
+p * q = n. Each factor pair is summed, and the pairs are then sorted in ascend-
+ing order of their sums. For example, if n = 36 then the sorted pairs are as
+follows:
+            -----------
+             p   q sum
+            -----------
+             6   6  12
+             4   9  13
+             3  12  15
+             2  18  20
+             1  36  37
+            -----------
+
+A search is then conducted on the sums to find 2 sums which differ by exactly
+1. In the above example, the search immediately finds 12 and 13, and the output
+is 1, meaning 36 is a stealthy number. If no two sums differ by exactly 1, the
+output is 0.
+
+=cut
+#==============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+use Regexp::Common qw( number );
+
+const my $VERBOSE => 1;
+const my $USAGE   =>
+"Usage:
+  perl $0 <n>
+
+    <n>    A positive integer\n";
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 143, Task #2: Stealthy Number (Perl)\n\n";
+}
+
+#==============================================================================
+package FactorPair
+#==============================================================================
+{
+    #--------------------------------------------------------------------------
+    sub new                                                       # Constructor
+    #--------------------------------------------------------------------------
+    {
+        my ($class, $p, $q) = @_;
+
+        my %self =
+        (
+            p   => $p,
+            q   => $q,
+            sum => $p + $q,
+        );
+
+        return bless \%self, $class;
+    }
+
+    #--------------------------------------------------------------------------
+    # Read-only accessors
+    #--------------------------------------------------------------------------
+    
+    sub p   { $_[ 0 ]->{ p   }; }
+    sub q   { $_[ 0 ]->{ q   }; }
+    sub sum { $_[ 0 ]->{ sum }; }
+}
+
+#==============================================================================
+MAIN:
+#==============================================================================
+{
+    my $n = parse_command_line();
+
+    print "Input:  \$n = $n\n";
+
+    my $pairs = get_factors( $n );
+      @$pairs = sort { $a->sum <=> $b->sum } @$pairs;
+
+    my  $is_stealthy = 0;
+    my ($factor1, $factor2);
+
+    L_OUTER:
+    for my $idx_i (0 .. $#$pairs - 1)
+    {
+        for my $idx_j ($idx_i + 1 .. $#$pairs)
+        {
+            if ($pairs->[ $idx_i ]->sum + 1 == $pairs->[ $idx_j ]->sum)
+            {
+                $factor1     = $pairs->[ $idx_j ];
+                $factor2     = $pairs->[ $idx_i ];
+                $is_stealthy = 1;
+                last L_OUTER;
+            }
+        }
+    }
+
+    printf "Output: %d\n", $is_stealthy ? 1 : 0;
+
+    explain( $n, $factor1, $factor2 ) if $VERBOSE && $is_stealthy;
+}
+
+#------------------------------------------------------------------------------
+sub get_factors
+#------------------------------------------------------------------------------
+{
+    my ($n) = @_;
+    my  @pairs;
+
+    for my $i (1 .. int sqrt $n)
+    {
+        if ($n % $i == 0)
+        {
+            push @pairs, FactorPair->new( $i, $n / $i );
+        }
+    }
+
+    return \@pairs;
+}
+
+#------------------------------------------------------------------------------
+sub explain
+#------------------------------------------------------------------------------
+{
+    my ($n, $factor1, $factor2) = @_;
+    my  $p1 = $factor1->p;
+    my  $p2 = $factor2->p;
+    my  $q1 = $factor1->q;
+    my  $q2 = $factor2->q;
+
+    printf "\nSince %d * %d = %d * %d = %d and " .
+                   "%d + %d = %d + %d + 1 = %d\n",
+            $p1, $q1, $p2, $q2, $n, $p1, $q1, $p2, $q2, $factor1->sum;
+}
+
+#------------------------------------------------------------------------------
+sub parse_command_line
+#------------------------------------------------------------------------------
+{
+    my $args = scalar @ARGV;
+       $args == 1 or error( "Expected 1 command line argument, found $args" );
+
+    my $n = $ARGV[ 0 ];
+
+    $n =~ / ^ $RE{num}{int} $ /x
+                  or error( qq["$n" is not a valid integer] );
+
+    $n > 0        or error( qq["$n" is not positive] );
+
+    return $n;
+}
+
+#------------------------------------------------------------------------------
+sub error
+#------------------------------------------------------------------------------
+{
+    my ($message) = @_;
+
+    die "ERROR: $message\n$USAGE";
+}
+
+###############################################################################
diff --git a/challenge-143/athanasius/raku/ch-2.raku b/challenge-143/athanasius/raku/ch-2.raku
new file mode 100644
index 0000000000..1bff6450eb
--- /dev/null
+++ b/challenge-143/athanasius/raku/ch-2.raku
@@ -0,0 +1,187 @@
+use v6d;
+
+###############################################################################
+=begin comment
+
+Perl Weekly Challenge 143
+=========================
+
+TASK #2
+-------
+*Stealthy Number*
+
+Submitted by: Mohammad S Anwar
+
+You are given a positive number, $n.
+
+Write a script to find out if the given number is Stealthy Number.
+
+    A positive integer N is stealthy, if there exist positive integers a, b, c,
+    d such that a * b = c * d = N and a + b = c + d + 1.
+
+Example 1
+
+ Input: $n = 36
+ Output: 1
+
+ Since 36 = 4 (a) * 9 (b) = 6 (c) * 6 (d) and 4 (a) + 9 (b) = 6 (c) + 6 (d) +
+ 1.
+
+Example 2
+
+ Input: $n = 12
+ Output: 1
+
+ Since 2 * 6 = 3 * 4 and 2 + 6 = 3 + 4 + 1
+
+Example 3
+
+ Input: $n = 6
+ Output: 0
+
+ Since 2 * 3 = 1 * 6 but 2 + 3 != 1 + 6 + 1
+
+=end comment
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2021 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=begin comment
+
+Interface
+---------
+Set $VERBOSE to True (the default) to display an explanation of the result when
+the output is 1. The explanation is modelled on Example 2.
+
+Algorithm
+---------
+The subroutine get-factors() returns the factors of n as pairs (p, q) where
+p * q = n. Each factor pair is summed, and the pairs are then sorted in ascend-
+ing order of their sums. For example, if n = 36 then the sorted pairs are as
+follows:
+            -----------
+             p   q sum
+            -----------
+             6   6  12
+             4   9  13
+             3  12  15
+             2  18  20
+             1  36  37
+            -----------
+
+A search is then conducted on the sums to find 2 sums which differ by exactly
+1. In the above example, the search immediately finds 12 and 13, and the output
+is 1, meaning 36 is a stealthy number. If no two sums differ by exactly 1, the
+output is 0.
+
+=end comment
+#==============================================================================
+
+my Bool constant $VERBOSE = True;
+
+subset Pos of Int where * > 0;
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    "\nChallenge 143, Task #2: Stealthy Number (Raku)\n".put;
+}
+
+#==============================================================================
+class FactorPair
+#==============================================================================
+{
+    has Pos $.p;
+    has Pos $.q;
+    has Pos $.sum;
+
+    #--------------------------------------------------------------------------
+    submethod BUILD( Pos:D :$!p, Pos:D :$!q )
+    #--------------------------------------------------------------------------
+    {
+        $!sum = $!p + $!q;
+    }
+}
+
+#==============================================================================
+sub MAIN
+(
+    Pos:D $n                       #= A positive integer
+)
+#==============================================================================
+{
+    "Input:  \$n = $n".put;
+
+    my FactorPair @pairs = get-factors( $n );
+
+    @pairs.=sort: *.sum;
+
+    my Bool $is-stealthy = False;
+    my FactorPair ($factor1, $factor2);
+
+    L-OUTER:
+    for 0 .. @pairs.end - 1 -> UInt $idx-i
+    {
+        for $idx-i + 1 .. @pairs.end -> UInt $idx-j
+        {
+            if @pairs[ $idx-i ].sum + 1 == @pairs[ $idx-j ].sum
+            {
+                $factor1     = @pairs[ $idx-j ];
+                $factor2     = @pairs[ $idx-i ];
+                $is-stealthy = True;
+                last L-OUTER;
+            }
+        }
+    }
+
+    "Output: %d\n".printf: $is-stealthy ?? 1 !! 0;
+
+    explain( $n, $factor1, $factor2 ) if $VERBOSE && $is-stealthy;
+}
+
+#------------------------------------------------------------------------------
+sub get-factors( Pos:D $n --> Array:D[FactorPair:D] )
+#------------------------------------------------------------------------------
+{
+    my FactorPair @pairs;
+
+    for 1 .. $n.sqrt.floor -> Pos $i
+    {
+        if $n %% $i
+        {
+            @pairs.push: FactorPair.new: p => $i, q => $n div $i;
+        }
+    }
+
+    return @pairs;
+}
+
+#------------------------------------------------------------------------------
+sub explain( Pos:D $n, FactorPair:D $factor1, FactorPair:D $factor2 )
+#------------------------------------------------------------------------------
+{
+    my Pos $p1 = $factor1.p;
+    my Pos $p2 = $factor2.p;
+    my Pos $q1 = $factor1.q;
+    my Pos $q2 = $factor2.q;
+
+    ("\nSince %d * %d = %d * %d = %d " ~
+         "and %d + %d = %d + %d + 1 = %d\n").printf:
+            $p1, $q1, $p2, $q2, $n, $p1, $q1, $p2, $q2, $factor1.sum;
+}
+
+#------------------------------------------------------------------------------
+sub USAGE()
+#------------------------------------------------------------------------------
+{
+    my Str $usage = $*USAGE;
+
+    $usage ~~ s/ ($*PROGRAM-NAME) /raku $0/;
+    $usage.put;
+}
+
+##############################################################################