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

2 files changed, 392 insertions, 0 deletions

diff --git a/challenge-197/athanasius/perl/ch-1.pl b/challenge-197/athanasius/perl/ch-1.pl
new file mode 100644
index 0000000000..4241711df6
--- /dev/null
+++ b/challenge-197/athanasius/perl/ch-1.pl
@@ -0,0 +1,165 @@
+#!perl
+
+###############################################################################
+=comment
+
+Perl Weekly Challenge 197
+=========================
+
+TASK #1
+-------
+*Move Zero*
+
+Submitted by: Mohammad S Anwar
+
+You are given a list of integers, @list.
+
+Write a script to move all zero, if exists, to the end while maintaining the
+relative order of non-zero elements.
+
+Example 1
+
+  Input:  @list = (1, 0, 3, 0, 0, 5)
+  Output: (1, 3, 5, 0, 0, 0)
+
+Example 2
+
+  Input: @list = (1, 6, 4)
+  Output: (1, 6, 4)
+
+Example 3
+
+  Input: @list = (0, 1, 0, 2, 0)
+  Output: (1, 2, 0, 0, 0)
+
+=cut
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=comment
+
+Interface
+---------
+If no command-line arguments are given, the test suite is run.
+
+Algorithm
+---------
+1. Traverse the input list, counting zero values but copying non-zero values to
+   the output list.
+2. Append the number of zero values encountered in the input list to the end of
+   the output list.
+   -- The repetition operator 'x' in list context "returns a list consisting of
+      the left operand list repeated the number of times specified by the right
+      operand" (https://perldoc.perl.org/perlop#Multiplicative-Operators).
+
+=cut
+#==============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+use Regexp::Common qw( number );
+use Test::More;
+
+const my $TEST_FIELDS => 3;
+const my $USAGE       =>
+"Usage:
+  perl $0 [<list> ...]
+  perl $0
+
+    [<list> ...]    A list of 1 or more integers\n";
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 197, Task #1: Move Zero (Perl)\n\n";
+}
+
+#==============================================================================
+MAIN:
+#==============================================================================
+{
+    my $args = scalar @ARGV;
+
+    if ($args == 0)
+    {
+        run_tests();
+    }
+    else
+    {
+        my @list = @ARGV;
+
+        for (@list)
+        {
+            / ^ $RE{num}{int} $ /x
+                or die qq[ERROR: "$_" is not a valid integer\n$USAGE];
+        }
+
+        printf "Input:  \@list = (%s)\n", join ', ',            @list;
+        printf "Output:         (%s)\n",  join ', ', move_zero( @list );
+    }
+}
+
+#------------------------------------------------------------------------------
+sub move_zero
+#------------------------------------------------------------------------------
+{
+    my @list  = @_;
+    my $count = 0;
+    my @moved;
+
+    for my $n (@list)
+    {
+        if ($n == 0)
+        {
+            ++$count;
+        }
+        else
+        {
+            push @moved, $n;
+        }
+    }
+
+    push @moved, (0) x $count;
+
+    return @moved;
+}
+
+#------------------------------------------------------------------------------
+sub run_tests
+#------------------------------------------------------------------------------
+{
+    print "Running the test suite\n";
+
+    while (my $line = <DATA>)
+    {
+        chomp $line;
+
+        my ($test_name, $input, $expected) = split /\|/, $line, $TEST_FIELDS;
+
+        $input    =~ s/ ^ \s* (.+?) \s* $ /$1/x;              # Trim whitespace
+        $expected =~ s/ ^ \s* (.+?) \s* $ /$1/x;
+        $expected =~ s/   \s+             / /gx;
+
+        my @list = split / , \s+ /x, $input;
+        my $got  = join ', ', move_zero( @list );
+
+        is $got, $expected, $test_name;
+    }
+
+    done_testing;
+}
+
+###############################################################################
+
+__DATA__
+Example 1| 1, 0,  3,  0, 0, 5    | 1,  3,  5,  0, 0, 0
+Example 2| 1, 6,  4              | 1,  6,  4
+Example 3| 0, 1,  0,  2, 0       | 1,  2,  0,  0, 0
+Negatives|-1, 0, -2, -3, 0, 0, -4|-1, -2, -3, -4, 0, 0, 0
diff --git a/challenge-197/athanasius/perl/ch-2.pl b/challenge-197/athanasius/perl/ch-2.pl
new file mode 100644
index 0000000000..729783ca11
--- /dev/null
+++ b/challenge-197/athanasius/perl/ch-2.pl
@@ -0,0 +1,227 @@
+#!perl
+
+###############################################################################
+=comment
+
+Perl Weekly Challenge 197
+=========================
+
+TASK #2
+-------
+*Wiggle Sort*
+
+Submitted by: Mohammad S Anwar
+
+You are given a list of integers, @list.
+
+Write a script to perform Wiggle Sort on the given list.
+
+
+    Wiggle sort would be such as list[0] < list[1] > list[2] < list[3]….
+
+
+Example 1
+
+  Input: @list = (1,5,1,1,6,4)
+  Output: (1,6,1,5,1,4)
+
+Example 2
+
+  Input: @list = (1,3,2,2,3,1)
+  Output: (2,3,1,3,1,2)
+
+=cut
+###############################################################################
+
+#--------------------------------------#
+# Copyright © 2023 PerlMonk Athanasius #
+#--------------------------------------#
+
+#==============================================================================
+=comment
+
+Interface
+---------
+If no command-line arguments are given, the test suite is run.
+
+Notes
+-----
+1. 'Wiggle sort' is also known as 'wave sort'.
+2. If no solution is possible for a given input, the output is '()', which
+   represents the empty list.
+3. The solution algorithm is described in [1].
+4. The algorithm for determining whether a given input list is wiggle-sortable
+   (by counting "medians") is given in [1], corrected in [2].
+
+References
+----------
+[1] John L., Answer to "How to wiggle sort an array in linear time complex-
+    ity?", Computer Science Stack Exchange (8 May, 2020), https://cs.stack
+    exchange.com/questions/125372/how-to-wiggle-sort-an-array-in-linear-time-
+    complexity
+
+[2] John L, Answer to "How to find wiggle sortable arrays? Did I misunderstand
+    John L.s' answer?" Computer Science Stack Exchange (25 April, 2022),
+    https://cs.stackexchange.com/questions/150886/how-to-find-wiggle-sortable-
+    arrays-did-i-misunderstand-john-l-s-answer
+
+=cut
+#==============================================================================
+
+use strict;
+use warnings;
+use Const::Fast;
+use POSIX          qw( ceil );
+use Regexp::Common qw( number );
+use Test::More;
+
+const my $TEST_FIELDS => 3;
+const my $USAGE       =>
+"Usage:
+  perl $0 [<list> ...]
+  perl $0
+
+    [<list> ...]    A list of 1 or more integers\n";
+
+#------------------------------------------------------------------------------
+BEGIN
+#------------------------------------------------------------------------------
+{
+    $| = 1;
+    print "\nChallenge 197, Task #2: Wiggle Sort (Perl)\n\n";
+}
+
+#==============================================================================
+MAIN:
+#==============================================================================
+{
+    if (scalar @ARGV == 0)
+    {
+        run_tests();
+    }
+    else
+    {
+        my @list = @ARGV;
+
+        for (@list)
+        {
+            / ^ $RE{num}{int} $ /x
+                or die qq[ERROR: "$_" is not a valid integer\n$USAGE];
+        }
+
+        printf "Input:  \@list = (%s)\n", join ', ',              @list;
+        printf "Output:         (%s)\n",  join ', ', wiggle_sort( @list );
+    }
+}
+
+#------------------------------------------------------------------------------
+sub wiggle_sort
+#------------------------------------------------------------------------------
+{
+    my @list   = @_;
+    my @sorted = ();
+
+    if (is_wiggle_sortable( @list ))
+    {
+        @list = sort { $a <=> $b } @list;
+
+        my $max_i = $#list;
+
+        for my $i (1 .. $max_i)
+        {
+            next  if $i % 2 == 0;
+            $sorted[ $i ] = pop @list;
+        }
+
+        for my $j (0 .. $max_i)
+        {
+            next  if $j % 2 == 1;
+            $sorted[ $j ] = pop @list;
+        }
+
+        is_wiggle_sorted( @sorted ) or die 'Wiggle sort failed';
+    }
+
+    return @sorted;
+}
+
+#------------------------------------------------------------------------------
+sub is_wiggle_sortable
+#------------------------------------------------------------------------------
+{
+    # Count "medians" (see [1] as corrected in [2])
+
+    my @list  = sort { $a <=> $b } @_;          # 1. Sort the list
+    my $n     = scalar @list;                   # 2. Find m, the ⌈n/2⌉-th entry
+    my $n2    = ceil( $n / 2 );
+    my $m     = $list[ $n2 - 1 ];
+    my $count = 0;                              # 3. Count entries equal to m
+    $_ == $m && ++$count for @list;
+
+    # 4. "The number of medians of A is no more than ⌈n/2⌉. Furthermore, if n
+    #     is odd and the number of medians is ⌈n/2⌉, the median must be the
+    #     smallest number of A." -- [2], with typo corrected
+
+    return ($count > $n2) ? 0 :
+           ($count < $n2) ? 1 :
+           ($n % 2 == 1)  ? ($m == $list[ 0 ]) : 1;
+}
+
+#------------------------------------------------------------------------------
+sub is_wiggle_sorted
+#------------------------------------------------------------------------------
+{
+    my @list = @_;
+
+    for my $i (0 .. $#list - 1)
+    {
+        if ($i % 2 == 0)
+        {
+            return 0 unless $list[ $i ] < $list[ $i + 1 ];
+        }
+        else
+        {
+            return 0 unless $list[ $i ] > $list[ $i + 1 ];
+        }
+    }
+
+    return 1;
+}
+
+#------------------------------------------------------------------------------
+sub run_tests
+#------------------------------------------------------------------------------
+{
+    print "Running the test suite\n";
+
+    while (my $line = <DATA>)
+    {
+        chomp $line;
+
+        my ($test_name, $input, $expected) =
+            split / \| /x, $line, $TEST_FIELDS;
+
+        s/ ^ \s* (.+?) \s* $ /$1/x                            # Trim whitespace
+            for $test_name, $input, $expected;
+
+        my @list   = split / , /x, $input;
+        my @sorted = wiggle_sort( @list );
+        my $got    = join ',', @sorted;
+
+        ok( is_wiggle_sorted( @sorted ), $test_name ) if $expected;
+        is( $got, $expected, $test_name );
+    }
+
+    done_testing;
+}
+
+###############################################################################
+
+__DATA__
+Example 1   |1,5,1,1,6,4|1,6,1,5,1,4
+Example 2   |1,3,2,2,3,1|2,3,1,3,1,2
+Short       |2,1,1      |1,2,1
+Not sortable|1,2,2      |
+Distinct    |5,4,3,2,1,0|2,5,1,4,0,3
+Single      |42         |42
+Negatives   |-1,-2,-3,-4|-3,-1,-4,-2