Challenge 219 solutions in Perl by Matthias Muth

4 files changed, 336 insertions, 0 deletions

diff --git a/challenge-219/matthias-muth/perl/TestExtractor.pm b/challenge-219/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..dce3669930
--- /dev/null
+++ b/challenge-219/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,215 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       The Test Data Extraction Machine (tm).
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+package TestExtractor;
+use Exporter 'import';
+our @EXPORT = qw( run_tests $verbose %options vsay pp );
+
+use Data::Dump qw( pp );
+use Getopt::Long;
+use Cwd qw( abs_path );
+use File::Basename;
+use Test2::V0;
+no warnings 'experimental::signatures';
+
+our ( $verbose, %options );
+sub vsay { say @_ if $verbose };
+
+sub run_tests {
+
+    $| = 1;
+
+    GetOptions(
+        "v|verbose!" => \$verbose,
+    ) or do { say "usage!"; exit 2 };
+
+    my $dir = dirname abs_path $0;
+    my ( $challenge, $task ) =
+        abs_path( $0 ) =~ m{challenge-(\d+) .* (\d+)[^[/\\]*$}x;
+    unless ( $challenge && $task ) {
+        say STDERR "ERROR: ",
+            "Cannot determine challenge number or task number. Exiting.";
+        exit 1;
+    }
+
+    my $local_tests;
+    ( undef, $local_tests ) = read_task( *::DATA )
+	if fileno *::DATA;
+
+    my ( $task_title, $task_description ) =
+        read_task( "$dir/challenge-${challenge}.txt", $task );
+    vsay $task_title;
+
+    my @tests = (
+        $local_tests      ? extract_tests( $local_tests )      : (),
+	$task_description ? extract_tests( $task_description ) : (),
+    );
+    vsay pp( @tests );
+
+    ( my $sub_name = lc $task_title ) =~ s/\W+/_/g;
+    my $sub = \&{"::$sub_name"};
+
+    do {
+        my @input_params =
+	    @{$_->{INPUT}} == 1
+	    ? ( ref $_->{INPUT}[0] eq 'ARRAY'
+		&& ! grep( ref $_, @{$_->{INPUT}[0]} ) )
+		? @{$_->{INPUT}[0]}
+		: $_->{INPUT}[0]
+	    : @{$_->{INPUT}};
+	my $expected = $_->{OUTPUT};
+	my $diag = 
+	    "$sub_name( " . pp( @input_params ) . " ) == "
+	    . pp( @{$_->{OUTPUT}} );
+	    # . pp(
+		# @{$_->{OUTPUT}} == 1 && ref $_->{OUTPUT}[0] eq 'ARRAY' && 
+		# ? @{$_->{OUTPUT}}
+		# : $_->{OUTPUT} );
+
+	my $name = "$_->{TEST}";
+	$name .= ": $diag"
+	    if $_->{TEST} =~ /^(Test|Example)\s+\d+$/;
+	$diag = "test: $diag";
+
+	my @output = $sub->( @input_params );
+	    
+	is \@output, $expected, $name, $diag // ();
+
+        vsay "";
+
+    } for @tests;
+
+    done_testing;
+}
+
+sub read_task( $fd_or_filename, $wanted_task = undef ) {
+
+    my $fd;
+    if ( ref \$fd_or_filename eq 'SCALAR' ) {
+        open $fd, "<", $fd_or_filename
+            or die "ERROR: cannot open '$fd_or_filename': $!\n";
+    }
+    else {
+        # non-SCALARs, like __DATA__ GLOB.
+        $fd = $fd_or_filename;
+    }
+
+    my ( $task, $task_title, $task_text ) = ( -1, undef );
+    while ( <$fd> ) {
+        /^Task (\d+):\s*(.*?)\s*$/ and do {
+            $task = $1;
+            $task_title = $2
+                if $wanted_task && $task == $wanted_task;
+            next;
+        };
+
+        next
+            if $wanted_task && $task != $wanted_task;
+
+	$task_text .= $_;
+    }
+
+    return $task_title, $task_text;
+}
+
+sub extract_tests( $task_text ) {
+    # vsay "extract_tests( ", pp( $task_text ), " )";
+
+    # These regular expressions are used for extracting input or output
+    # test data.
+    my $var_name      = qr/ [\@\$]\w+ /x;
+    my $literal       = qr/ ".*?" | '.*?' | [+-]?\d+ | undef /x;
+    my $bracketed     = qr/ \[ [^\[]*? \] /xs;
+    my $parenthesized = qr/ \( [^\[]*? \) /xs;
+    my $entry         = qr/ $literal | $bracketed | $parenthesized /x;
+    my $list          = qr/ $entry (?: \s*,\s* $entry )* \s*,? /xs;
+
+    # The combination of what we expect as input or output data.
+    # Capture unparenthesized lists for special handling.
+    my $data_re = qr/ (?<lit>      $literal )
+		    | (?<br_list>     \[ \s* (?:$list)? \s* \] )
+		    | (?<par_list>    \( \s* (?:$list)? \s* \) )
+		    | (?<no_paren> $list ) /x;
+
+    my @tests;
+    while ( $task_text =~
+	/^((?:Example|Test).*?)\s*:?\s*$ .*?
+	    ^Input: \s* ( .*? ) \s*
+	    ^Output: \s* ( .*? ) \s*? (?=(?: ^$ | ^\S | \Z ))
+	/xmsg )
+    {
+	my ( $test, $input, $output) = ( $1, $2, $3 );
+
+	push @tests, { TEST => $test };
+
+	for ( $input, $output ) {
+	    # To avoid misinterpretations of '@' or '$' when the data is
+	    # 'eval'ed, we turn all double quotes into single quotes.
+	    s/"/'/g;
+
+	    # We convert 'barewords' into quoted strings.
+	    # We search for these patterns, but we just skip them without
+	    # changing them:
+	    #  * 'Input:', 'Output:' at the beginning of the string,
+	    #  * quoted strings,
+	    #  * variable names having a $ or @ sigil.
+	    # After we are sure it's none of those, we also check unquoted
+	    # 'barewords' (here: combinations of letters, digits or underscores,
+	    # starting with a letter) and enclose them in single quotes.
+	    my $bareword = qr/ \b (?!undef) [a-z_][a-z0-9_]* \b /ix;
+	    while ( / ^Input: | ^Output: | '.*?' | [\$\@]$bareword
+		    | ( $bareword ) /xg )
+	    {
+		if ( $1 ) {
+		    my $p = pos();
+		    substr $_, $p - length( $1 ), length( $1 ), "'$1'";
+		    pos = $p + 2;
+		}
+	    }
+
+	    # As all arrays will be stored as array references, so we just
+	    # convert parentheses (...) to angle brackets [...].
+	    # s/\(/\[/g;
+	    # s/\)/\]/g;
+
+	    # Add missing commas between literals.
+	    while ( s/($literal)\s+($literal)/$1, $2/ ) {}
+	}
+
+	while ( $input =~ / ($var_name) \s* = \s* ($data_re) /xg ) {
+	    push @{$tests[-1]{VARIABLE_NAMES}}, $1;
+	    push @{$tests[-1]{INPUT}},
+		eval( ( $+{no_paren} || $+{par_list} ) ? "[ $2 ]" : $2 );
+        };
+
+	while ( $output =~ /^\s* ($data_re) $/xg ) {
+	    local $_ = $1;
+	    # vsay "\$_: <$_>";
+	    # Special case:  (1,2),(3,4),(5,6)
+	    # should become: [1,2],[3,4],[5,6] ]
+	    if ( $+{no_paren} && /$parenthesized/ ) {
+		# vsay "found special case <$_>";
+		s/\(/\[/g;
+		s/\)/\]/g;
+	    }
+	    push @{$tests[-1]{OUTPUT}},
+		eval( $+{no_paren} ? "( $_ )" : $_ );
+        };
+    }
+    return @tests;
+}
+
+1;
diff --git a/challenge-219/matthias-muth/perl/ch-1.pl b/challenge-219/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..4d243b0b0b
--- /dev/null
+++ b/challenge-219/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 219 Task 1: Sorted Squares
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use lib '.';
+use TestExtractor;
+
+sub sorted_squares {
+    return sort { $a <=> $b } map { $_ ** 2 } @_;
+}
+
+run_tests;
diff --git a/challenge-219/matthias-muth/perl/ch-2.pl b/challenge-219/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..7b3234b92d
--- /dev/null
+++ b/challenge-219/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 219 Task 2: Travel Expenditure
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( min );
+
+my @durations = ( 1, 7, 30 );
+
+sub travel_expenditure {
+    my ( $costs, $days ) = @_;
+    return 0
+        if @$days == 0;
+    return min(
+        map {
+	    my $duration = $durations[$_];
+	    $costs->[$_]
+		+ travel_expenditure( $costs,
+		    [ grep $_ >= $days->[0] + $duration, @$days ] );
+	} 0..$#{$costs}
+    );
+}
+
+run_tests;
diff --git a/challenge-219/matthias-muth/perl/challenge-219.txt b/challenge-219/matthias-muth/perl/challenge-219.txt
new file mode 100644
index 0000000000..158764bca9
--- /dev/null
+++ b/challenge-219/matthias-muth/perl/challenge-219.txt
@@ -0,0 +1,63 @@
+The Weekly Challenge - 219
+Monday, May 29, 2023
+
+
+Task 1: Sorted Squares
+Submitted by: Mohammad S Anwar
+
+You are given a list of numbers.
+Write a script to square each number in the list and return the sorted list, increasing order.
+Example 1
+
+Input: @list = (-2, -1, 0, 3, 4)
+Output: (0, 1, 4, 9, 16)
+
+Example 2
+
+Input: @list = (5, -4, -1, 3, 6)
+Output: (1, 9, 16, 25, 36)
+
+
+Task 2: Travel Expenditure
+Submitted by: Mohammad S Anwar
+
+You are given two list, @costs and @days.
+The list @costs contains the cost of three different types of travel cards you can buy.
+For example @costs = (5, 30, 90)
+Index 0 element represent the cost of  1 day  travel card.
+Index 1 element represent the cost of  7 days travel card.
+Index 2 element represent the cost of 30 days travel card.
+
+The list @days contains the day number you want to travel in the year.
+For example: @days = (1, 3, 4, 5, 6)
+The above example means you want to travel on day 1, day 3, day 4, day 5 and day 6 of the year.
+
+Write a script to find the minimum travel cost.
+Example 1:
+
+Input: @costs = (2, 7, 25)
+       @days  = (1, 5, 6, 7, 9, 15)
+Output: 11
+
+On day 1, we buy a one day pass for 2 which would cover the day 1.
+On day 5, we buy seven days pass for 7 which would cover days 5 - 9.
+On day 15, we buy a one day pass for 2 which would cover the day 15.
+
+So the total cost is 2 + 7 + 2 => 11.
+
+Example 2:
+
+Input: @costs = (2, 7, 25)
+       @days  = (1, 2, 3, 5, 7, 10, 11, 12, 14, 20, 30, 31)
+Output: 20
+
+On day 1, we buy a seven days pass for 7 which would cover days 1 - 7.
+On day 10, we buy a seven days pass for 7 which would cover days 10 - 14.
+On day 20, we buy a one day pass for 2 which would cover day 20.
+On day 30, we buy a one day pass for 2 which would cover day 30.
+On day 31, we buy a one day pass for 2 which would cover day 31.
+
+So the total cost is 7 + 7 + 2 + 2 + 2 => 20.
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 4th June 2023.