Challenge 220 solutions in Perl by Matthias Muth

7 files changed, 458 insertions, 0 deletions

diff --git a/challenge-220/matthias-muth/README-220.md b/challenge-220/matthias-muth/README-220.md
new file mode 100644
index 0000000000..80fa178889
--- /dev/null
+++ b/challenge-220/matthias-muth/README-220.md
@@ -0,0 +1,31 @@
+# Challenge 220 tasks: Common Characters - Squareful
+**Challenge 220 solutions in Perl by Matthias Muth**
+
+## Task 1: Common Characters
+
+> You are given a list of words.<br/>
+> Write a script to return the list of common characters (sorted alphabeticall) found in every word of the given list.<br/>
+
+Lore ipsum...
+
+```perl
+sub task_1() {
+    return undef;
+}
+```
+
+## Task 2: Squareful
+
+> You are given an array of integers, @ints.<br/>
+> An array is squareful if the sum of every pair of adjacent elements is a perfect square.<br/>
+> Write a script to find all the permutations of the given array that are squareful.<br/>
+
+Lorem ipsum...
+
+```perl
+sub task_2() {
+    return undef;
+}
+```
+
+#### **Thank you for the challenge!**
diff --git a/challenge-220/matthias-muth/README-no-blog.md b/challenge-220/matthias-muth/README-no-blog.md
new file mode 100644
index 0000000000..83441c4968
--- /dev/null
+++ b/challenge-220/matthias-muth/README-no-blog.md
@@ -0,0 +1,5 @@
+**Challenge 220 solutions in Perl by Matthias Muth**
+<br/>
+(no blog post this time...)
+
+**Thank you for the challenge!**
diff --git a/challenge-220/matthias-muth/blog.txt b/challenge-220/matthias-muth/blog.txt
new file mode 100644
index 0000000000..d5d8b54e9c
--- /dev/null
+++ b/challenge-220/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-220/challenge-220/matthias-muth#readme
diff --git a/challenge-220/matthias-muth/perl/TestExtractor.pm b/challenge-220/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..5ead60cf52
--- /dev/null
+++ b/challenge-220/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,222 @@
+#
+#       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 List::Util qw( any );
+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} ? "( $_ )" : $_ );
+        };
+    }
+
+    # Use array refs for all OUTPUT lists if at least one of tests does.
+    if ( any { ref $_->{OUTPUT}[0] } @tests ) {
+	$_->{OUTPUT} = [ $_->{OUTPUT} ]
+	    for grep { ! ref $_->{OUTPUT}[0] } @tests;
+    }
+
+    return @tests;
+}
+
+1;
diff --git a/challenge-220/matthias-muth/perl/ch-1.pl b/challenge-220/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..914f688cfc
--- /dev/null
+++ b/challenge-220/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,79 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 220 Task 1: Common Characters
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( reduce any );
+use Data::Dump qw( pp );
+
+sub common_characters_reduce {
+    my ( @words ) = map lc( $_ ), @_;
+    my $result_set =
+        reduce { [ grep( $b =~ /$_/, @$a ) ] }
+            [ $words[0] =~ /./g ], @words[1..$#words];
+    # return sort @$result_set;
+}
+
+sub common_characters_for_words {
+    my ( @words ) = map lc( $_ ), @_;
+    my @results = split "", $words[0];
+    for my $word ( @words[1..$#words] ) {
+        @results = grep $word =~ /$_/, @results;
+    }
+    return sort @results;
+}
+
+sub common_characters_for_index {
+    my ( @words ) = map lc( $_ ), @_;
+    my @results = split "", $words[0];
+    for my $i ( 1..$#words ) {
+        @results = grep $words[$i] =~ /$_/, @results;
+    }
+    return sort @results;
+}
+
+sub common_characters_while_shift {
+    my ( @words ) = map lc( $_ ), @_;
+    my @results = split "", shift @words;
+    while ( my $word = shift @words ) {
+        @results = grep { $word =~ /$_/ } @results;
+    }
+    return sort @results;
+}
+
+sub common_characters {
+    common_characters_for_words( @_ );
+}
+
+sub benchmark {
+    use Benchmark qw( timethese cmpthese );
+
+    my @bench_data = ( "love", "live", "leave", "Perl", "Rust", "Raku" );
+
+    cmpthese( 0, {
+        # reduce_chars => sub { common_characters_reduce_chars( @bench_data ); },
+        # reduce       => sub { common_characters_reduce( @bench_data ); },
+        # for_index    => sub { common_characters_for_index( @bench_data ); },
+        for_words    => sub { common_characters_for_words( @bench_data ); },
+        selected     => sub { common_characters( @bench_data ); },
+        # while_shift  => sub { common_characters_while_shift( @bench_data ); },
+    } );
+}
+
+run_tests;
+
+benchmark;
+
+1;
\ No newline at end of file
diff --git a/challenge-220/matthias-muth/perl/ch-2.pl b/challenge-220/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..1020536078
--- /dev/null
+++ b/challenge-220/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,77 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 220 Task 2: Squareful
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( sum min max );
+
+sub is_perfect_square {
+    my $sqrt = sqrt( $_[0] );
+    return int( $sqrt ) == $sqrt;
+}
+
+$| = 1;
+
+my $indent = "";
+
+sub squareful {
+    my ( @ints ) = @_;
+    vsay $indent, "squareful( @ints )";
+    $indent .= "    ";
+
+    if ( @ints == 1 ) {
+        vsay $indent, "returning ( [ @ints ] )";
+        substr $indent, -4, 4, "";
+        return [ @ints ];
+    }
+
+    my %frequencies;
+    $frequencies{$_}++
+        for @ints;
+    vsay $indent, "frequencies: ", pp \%frequencies;
+
+    my %first_positions;
+    $first_positions{$ints[$_]} //= $_
+        for 0..$#ints;
+    vsay $indent, "first_positions: ", pp \%first_positions;
+
+    my @results;
+    for my $int ( sort keys %frequencies ) {
+        vsay $indent, "trying to start with $int";
+        my @remaining_ints = @ints;
+        splice @remaining_ints, $first_positions{$int}, 1, ();
+        vsay $indent, "remaining_ints: ( @remaining_ints )";
+        my @squareful_subsets = squareful( @remaining_ints );
+        vsay $indent, "squareful_subsets: ", pp( @squareful_subsets );
+        push @results,
+            map [ $int, @{$squareful_subsets[$_]} ],
+                grep {
+		    my $perfect =
+			is_perfect_square( $int + $squareful_subsets[$_][0] );
+		    vsay $indent, "$int + $squareful_subsets[$_][0] = ",
+		        $int + $squareful_subsets[$_][0], " is",
+			$perfect ? " a" : " no", " perfect square";
+		    $perfect
+		} 0..$#squareful_subsets;
+        vsay $indent, "\@results now: ", pp @results;
+    }
+
+    vsay $indent, "returning ", pp @results;
+    substr $indent, -4, 4, "";
+    return @results;
+}
+
+# @ARGV = qw( -v );
+run_tests;
diff --git a/challenge-220/matthias-muth/perl/challenge-220.txt b/challenge-220/matthias-muth/perl/challenge-220.txt
new file mode 100644
index 0000000000..520d875561
--- /dev/null
+++ b/challenge-220/matthias-muth/perl/challenge-220.txt
@@ -0,0 +1,43 @@
+The Weekly Challenge - 220
+Sunday, Jun 4, 2023
+
+
+Task 1: Common Characters
+Submitted by: Mohammad S Anwar
+
+You are given a list of words.
+Write a script to return the list of common characters (sorted alphabeticall) found in every word of the given list.
+Example 1
+
+Input: @words = ("Perl", "Rust", "Raku")
+Output: ("r")
+
+Example 2
+
+Input: @words = ("love", "live", "leave")
+Output: ("e", "l", "v")
+
+
+Task 2: Squareful
+Submitted by: Mohammad S Anwar
+
+You are given an array of integers, @ints.
+An array is squareful if the sum of every pair of adjacent elements is a perfect square.
+Write a script to find all the permutations of the given array that are squareful.
+Example 1:
+
+Input: @ints = (1, 17, 8)
+Output: (1, 8, 17), (17, 8, 1)
+
+(1, 8, 17) since 1 + 8 => 9, a perfect square and also 8 + 17 => 25 is perfect square too.
+(17, 8, 1) since 17 + 8 => 25, a perfect square and also 8 + 1 => 9 is perfect square too.
+
+Example 2:
+
+Input: @ints = (2, 2, 2)
+Output: (2, 2, 2)
+
+There is only one permutation possible.
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 11th June 2023.