Perl Weekly Challenge #363

Task #1 is here: Perl Weekly Challenge 363, Task 1

#!/usr/bin/env perl

use v5.38;
use utf8;
use open ':std', ':encoding(UTF-8)';

=head1 COMMENTS

 Task 1: String Lie Detector

 You are given a string.

 Write a script that parses a self-referential string and determines whether
 its claims about itself are true.   The string will make statements about its
 own composition, specifically the number of vowels and consonants it contains.

=cut

my %examples = ( Example_1 => "aa — two vowels and zero consonants",
                 Example_2 => "iv — one vowel and one consonant",
	             Example_3 => "hello - three vowels and two consonants",
  	             Example_4 => "aeiou — five vowels and zero consonants",
		         Example_5 => "aei — three vowels and zero consonants"
	       );

# I decided to provide my own hash to map the numerals to their English
# language equivalents
my %numbers = ( 0 => 'zero',
		1 => 'one',
		2 => 'two',
		3 => 'three',
		4 => 'four',
		5 => 'five',
		6 => 'six',
		7 => 'seven',
		8 => 'eight',
		9 => 'nine',
	      );


foreach my $example ( sort keys %examples ) {
    # Not clear to me if this was deliberate (vs. unintentional copy-paste) but
    # most examples actually have em-dashes, but one has just a hyphen, so I had to
    # get slightly more sophisticated than I anticipated with my regex for this step
    # But this is EXCELLENT practice for real life data munging & data wrangling
    my ( $string, $fact, ) = split(/\s+(?:\x{2014}|-)\s+/, $examples{$example});
    my $status = q{};
    # Yadda-yadda-yadda, is there an O'Reilly book on the Perl Programming Language that
    # does NOT have this example of how to turn a string into an array of it's
    # substituent characters?
    my @letters = split(//, $string);
    # I want to count the number of vowels in the first string, and evaluating this statement
    # in a scalar context will give me that number
    my $vowels = grep { /[aeiou]/ } @letters;
    my $consonants = length($string) - $vowels;
    # Caveat emptor: some of the examples have a singular vowel, whilst others
    # have plural vowels
    my ( $v_fact, $c_fact ) = $fact =~ m/(.+) vowels? and (.+) consonant/;
    if ( $numbers{$vowels} eq $v_fact and $numbers{$consonants} eq $c_fact ) {
	    $status = 'true';
    }
    else {
	    $status = 'false';
    }
    
    print "$example\n";
    print "Input: \"", $examples{$example}, "\"\n";
    print "Output: ", $status, "\n\n";
}

__END__

OUTPUT from running this Script:

Example_1
Input: "aa — two vowels and zero consonants"
Output: true

Example_2
Input: "iv — one vowel and one consonant"
Output: true

Example_3
Input: "hello - three vowels and two consonants"
Output: false

Example_4
Input: "aeiou — five vowels and zero consonants"
Output: true

Example_5
Input: "aei — three vowels and zero consonants"
Output: true

Task #2 is here: Perl Weekly Challenge 363, Task 2

#!/usr/bin/env perl

use v5.38;
use utf8;
use open ':std', ':encoding(UTF-8)';
use Socket;

=head1 COMMENTS

 Task 2: Subnet Sheriff

 You are given an IPv4 address and an IPv4 network (in CIDR format).

 Write a script to determine whether both are valid and the address falls within
 the network. For more information see the Wikipedia article:
 https://en.wikipedia.org/wiki/IPv4 


=cut


my %examples = ( Example_1 => { ip_addr => "192.168.1.45",
                                domain  => "192.168.1.0/24",
                              },
		         Example_2 => { ip_addr => "10.0.0.256",
                                domain  => "10.0.0.0/24",
		                      },          
                 Example_3 => { ip_addr => "172.16.8.9",
                                domain  => "172.16.8.9/32",
		                      },
		         Example_4 => { ip_addr => "172.16.4.5",
                                domain  => "172.16.0.0/14",
		                      },
		         Example_5 => { ip_addr => "192.0.2.0",
                                domain  => "192.0.2.0/25",
		                      },
               );

		 
foreach my $example ( sort keys %examples ) {
    my $output = q{};
    my $subnet_mask = q{};
    my @octets = split(/\./, $examples{$example}{ip_addr});
    # Apparently the only allowed valid numbers are between
    # 0 and 255, so we'll test for that first.
    if ( grep { $_ > 255 } @octets ) {
	    $output = 'false';
    }
    else {
	    # If none of the octets exceed decimal 255 then we need to
	    # convert the IP addresse and the network into their binary equivalents
	    my $ip_addr = unpack('B32', inet_aton($examples{$example}{ip_addr}));
        my ( $domain, $suffix, ) = split(/\//, $examples{$example}{domain});
        $domain = unpack('B32', inet_aton($domain));

        # There is likely some slick way to do this that all the cool kids
	    # use, but I didn't even really grok why IP addresses are built up
        # in such a bizarro fashion until this particular Perl Weekly Challenge
	    # so I derived this algorithm on the fly:
        my $subnet_mask = q{};	
        for my $bit ( 1..32 ) {
            if ( $bit > $suffix ) {
		        $subnet_mask .= 0;
	        }
	        else {
		        $subnet_mask .= 1;
	        }
	    }

	    # I assumed, naively, that having decoded the decimal version of the
	    # octets into binary 1's and 0's that we were ready to use
	    # Perl's version of the bitwise AND operator to mask the
	    # bits in the IP address.  Not so.  Using bitwise AND on
	    # the 1's and 0's did not yield output at all like what I
        # was expecting.
	    # It turns out there is one more step; Perl interprets
	    # my 1's and 0's as strings of characters, NOT binary
	    # numbers, alas.  And thus we need to convert our 1's
	    # and 0's which are a binary strings into binary integers
	    # (are we having fun yet?):
	    my $ip_int   = oct("0b" . $ip_addr);
        my $mask_int = oct("0b" . $subnet_mask);
        my $network_int = oct("0b" . $domain);

	    # Finally starting with decimals, which we rendered as binary strings
	    # we end up with binary integers, which we hope is what we want.
	    # So that we can . . . 
        # Perform bitwise AND
        my $result_int = $ip_int & $mask_int;

        # Now we can compare the masked ip_addr to the network domain and see if
	    # this ip_addr is actually contained in this network (the original task)
        if ($result_int == $network_int) {
            $output = 'true';
        }
        else {
            $output = 'false'
        }
    }

    print $example, "\n";
    print "Input: ip_addr = \"", $examples{$example}{ip_addr}, "\"\n";
    print "       domain  = \"", $examples{$example}{domain}, "\"\n";
    print "Output: $output\n\n";
}    

__END__

OUTPUT from running this Script:

Example_1
Input: ip_addr = "192.168.1.45"
       domain  = "192.168.1.0/24"
Output: true

Example_2
Input: ip_addr = "10.0.0.256"
       domain  = "10.0.0.0/24"
Output: false

Example_3
Input: ip_addr = "172.16.8.9"
       domain  = "172.16.8.9/32"
Output: true

Example_4
Input: ip_addr = "172.16.4.5"
       domain  = "172.16.0.0/14"
Output: true

Example_5
Input: ip_addr = "192.0.2.0"
       domain  = "192.0.2.0/25"
Output: true

What Sort of Echo?

Task #1 is here: Perl Weekly Challenge 362, Task 1

#!/usr/bin/env perl

use v5.38;

my @words = qw/ abca xyz code hello a /;

foreach my $word ( @words ) {
    my @letters = split( '', $word );

    my $output = q{};

    foreach my $i ( 0..$#letters ) {
        $output .= $letters[$i] x ($i + 1);
    }

    print "Input: \"", $word, "\"\n";
    print "Output: \"", $output, "\"\n\n";

}

exit;

Task #2 is here: Perl Weekly Challenge 362, Task 2

#!/usr/bin/env perl

use v5.38;
use Lingua::EN::Numbers qw(num2en);

=head1 COMMENTS

Searching the internet told me that the Perl module in CPAN named
Lingua::EN::Numbers was designed to convert or transform numerals into
the english word for that number.

According to the modules POD the method 'num2en' should do what we
want.  I have never used this module previously, but it was
straightforward and easy to install.

=cut


my @inputs = ( [6, 7, 8, 9 ,10], [-3, 0, 1000, 99], [1, 2, 3, 4, 5], [0, -1, -2, -3, -4], [100, 101, 102], );

foreach my $input ( @inputs ) {

    # Since we want to convert each element in the array from a numeral into
    # its english language equivalent, we could use a for loop, but it is
    # convenient to use Perl's built-in map() function (less typing?)
    # Next the challenge asks us to sort the english language words
    # before printing out the newly sorted numerals in their new order.
    # To me, this screams for a Schwartzian Transform
    # It can be clearer to read the steps up from the bottom

                  # STEP_3: extract the second element in the anonymous array
                  # which contains the original numeral
    my @output =  map  { $_->[1] }

	              # STEP_2: use the first element in the anonymous array
	              # to sort the words lexicographically
	              sort { $a->[0] cmp $b->[0] }

		          # STEP_1: transform each element in our array from a numeral
		          # into an english word, and store them together in a new anonymous
		          # array (one anonymous array for each element in the starting array)
                  map  { [num2en($_), $_] } $input->@*;	

    print "Input: (", join(", ", $input->@*), ")\n";
    print "Output: (", join(", ", @output ), ")\n\n";
}

exit;

Was Fibonacci ever a Celebrity?

Task #1 is here: Perl Weekly Challenge 361, Task 1

#!/usr/bin/env perl

use v5.38;

my @inputs = ( 4, 12, 20, 96, 100, );

# We want to start with the largest Fibonacci numbers
# and work our way down, testing as we go, so I
# manually inverted the array
my @fibos = qw/89 55 34 21 13 8 5 3 2 1/;

foreach my $test_number ( @inputs ) {
    # Save a copy of current input for subsequent pretty-printing
    my $int = $test_number;

    # Don't waste time testing Fibonacci numbers unless they are 
    # less than or equal to the current input
    my @filtered = grep { $_ <= $test_number } @fibos;

    # When we find Fibonacci numbers we want to use then
    # we will stash them in here
    my @used = ();

    foreach my $fib ( @filtered ) {
        # Watch out; the value stored in $test_number changes
	    # each time we find another Fibonacci number
	    # to use
        my $diff = $test_number - $fib;

	    # First case: We found it, we're done; no need to test further
	    # stash this Fibonacci number and then get out of this
	    # inner foreach loop (so you can print the results for this input)
        if ( $diff == 0 ) {
            push( @used, $fib, );
	        last;
        }
	    # Second case: This Fibonacci number was too large to be used
	    # go get the next one, and keep searching
        elsif ( $diff < 0 ) {
            next;
        }
	    # Third case: Implicitly, $diff contains a number
	    # larger than zero
	    else {
	        # Two things, reset the value in $test_number,
	        # replacing it with the value in $diff
	        # AND, stash this Fibonacci number in the @used array,
	        # it's a keeper
            $test_number = $diff;
  	        push( @used, $fib, );
        }
    }

    print "Input: \$int = $int\n";
    print "Output: ";
    print join(",", @used), "\n\n";
    print "$int => ";
    print join(" + ", @used), "\n\n";

}

exit;

Task #2 is here: Perl Weekly Challenge 361, Task 2

#!/usr/bin/env perl

use v5.38;

# Each example is a community of people; some people know (or have heard of) other people, and some
# people are known by other people.  This data structure codes all of those relationships.
# Just because I know you, does not mean that you also know me.  The attribute of knowing is
# one-way, or assymetric.
# The challenge is to identify if a community contains a person with a specific pattern
# of such connections.  
my @communities = ( [[0, 0, 0, 0, 1, 0], [0, 0, 0, 0, 1, 0], [0, 0, 0, 0, 1, 0], [0, 0, 0, 0, 1, 0], [0, 0, 0, 0, 0, 0], [0, 0, 0, 0, 1, 0],],
                    [[0, 1, 0, 0], [0, 0, 1, 0], [0, 0, 0, 1], [1, 0, 0, 0]],
                    [[0, 0, 0, 0, 0], [1, 0, 0, 0, 0], [1, 0, 0, 0, 0], [1, 0, 0, 0, 0], [1, 0, 0, 0, 0]],
                    [[0, 1, 0, 1, 0, 1], [1, 0, 1, 1, 0, 0], [0, 0, 0, 1, 1, 0], [0, 0, 0, 0, 0, 0], [0, 1, 0, 1, 0, 0], [1, 0, 1, 1, 0, 0]],
                    [[0, 1, 1, 0], [1, 0, 1, 0], [0, 0, 0, 0], [0, 0, 0, 0]], 
                    [[0, 0, 1, 1], [1, 0, 0, 0], [1, 1, 0, 1], [1, 1, 0, 0]]
                  );

my $example = 1;

foreach my $community ( @communities ) {
    my @people = $community->@*;

    # In some communities there are no people who do not know anyone
    # In other communities there are more than 1 person who do not know anyone
    # We are going to keep track of the number of people in this community who
    # do not know anyone else
    my $celeb = 0;

    # If we find someone who knows nobody else, then we are going to
    # store their name
    my $knows_nobody = 'no candidate';

    # A person's name is the index of their element in the @people array
    # So the first person we evaluate is always named zero, then the names
    # autoincrements
    my $name = 0;

    # In parallel, we are also going to explicitly keep track of who each person
    # is known by (a count)
    my %known_by = ();
    my $community_size = q{};
    
    foreach my $person ( @people ) {
        # The @connections array is analogous to a bit vector that stores whether or not
	    # This $person "knows" any of the other people in this community
        my @connections = $person->@*;

	    # The number of people a person knows will be the sum of the
	    # positions that contain a '1'
        my $count = scalar( grep { $_ > 0 } @connections );

	    # If we find a person who doesn't know anybody else, then they are a
	    # candidate to be celebrity in this community
        if ( $count == 0 ) {
	        # So we store their name (this value might get clobbered)
	        $knows_nobody = $name;    
            # And we keep a count of the total number of celebrity candidates in this community
            $celeb++;
        }	

	    $community_size = scalar( @connections );

	    # The celebrity will be known by all of the other people in
	    # this community, or: the community_size - 1
	    # Here, we use each person's name to store the total
	    # number of different people who know them
	    foreach my $people (0..$#people) {
            if ( $connections[$people] > 0 ) {
	            $known_by{$name}++;
	        }
        }
        $name++;
    }
    print "Example $example\n";

    # The only way to determine if there is a celebrity is if everyone else knows them
    # and the celebrity doesn't know anyone else.  A community can only have one celebrity
    if ( $celeb != 1 ) {
        print "Output: -1; no celebrity candidates in this Example community\n\n";
    }
    else {
        if ( $known_by{$knows_nobody} = $community_size -1 ) {
            print "Output: $knows_nobody is a celebrity in this Example!\n\n";
	    }
        else {
            print "Output: -1; it turns out celebrity candidate is not actually known by everyone else\n\n";
	    }
    }
    $example++;
}

exit;

This is exactly the sort of justification that I was looking for.

Task #1 is here: Perl Weekly Challenge 360, Task 1

#!/usr/bin/env perl

use strict;
use warnings;

my @inputs = ( ["Hi", 5], ["Code", 10], ["Hello", 9], ["Perl", 4], ["A", 7], ["", 5]);

foreach my $input ( @inputs ) {
    my ( $output, $pad1, $pad2, );
    my ( $str, $width ) = ($input->[0], $input->[1]);
    my $diff = $width - length($str);

    # This approach methodically assembles the desired padded string step
    # by step using Perl's concatenation operator: '.' and stores the
    # manipulations in the $output variable

    # if the string is empty then the output consists solely of padding
    if ( length($str) == 0 ) {
        $output = "*" x $width;
    }
    else {
        # if the difference between the string length and the format width is
        # even then the padding is equal on each side of the string
        if ( $diff % 2 == 0 ) {
            $pad1 = $diff / 2;
            $pad2 = $pad1;
            $output = "*" x $pad1 . $str . "*" x $pad2;
        }
        # but if the difference is odd, then we need adjust the number of
        # padding characters on each side of the string output
        else {
            my $half = $diff / 2;
            ($pad1) = $half =~ m/(\d+)\./;
            $pad2 = $diff - $pad1;
            $output = "*" x $pad1 . $str . "*" x $pad2;
        }
    }

    # My approach to printing the output shown in the challenge example
    # is cumbersome, to say the least.  There may be more elegant, and
    # faster ways to decide what to print, and how to assemble the
    # desired elements

    print "Input: \$str = \"", $str, "\", \$width = ", $width, "\n";
    print "Output: \"", $output, "\"\n\n";
    if ( length($str) == 0 ) {
        print "Text length = ", length($str), ", Width = ", $width, "\n";
        print "Entire output is padding\n\n\n";
    }
    elsif ( length($str) == $width ) {
        print "No padding is needed\n\n\n";
    }
    else {
        print "Text length = ", length($str), ", Width = ", $width, "\n";
        print "Need ", $diff, " padding characters total\n";
        print "Left padding: ", $pad1;
        $pad1 > 1 ? print " stars" : print " star";
        print ", Right padding: ", $pad2;
        $pad2 > 1 ? print " stars" : print " star";
        print "\n\n\n";
    }

}

exit;    

Task #2 is here: Perl Weekly Challenge 360, Task 2

#!/usr/bin/env perl

use strict;
use warnings;


=head1 Context

This week for Task #2 we are using a minimalist, idiosyncratic Perl-ish approach
(which may, or may not be considered idiom).

For a Perl Pro this is probably a recognizable treatment of the problem.  If this is the
first time you've seen a Perl script, you'll probably get a headache.

First, we declare an array data structure named @sentences, where each
element in the array is a separate sentence from the examples in the task definition.

Instead of iterating over the array elements inside a { block } (a typical way),
we are placing the foreach iterator in the so-called post-fix location, after
our code statements.

Instead of explicitly declaring an iterator variable, we are using the default
Perl variable, "$_" (which I call dollar underscore) (also named "$ARGV").  "$_" can be thought of
as "It" (the thing that we are working on with our code statements).  NOTE: by default split(),
like many, many, Perl functions, uses the content of "$_", as its input,
even if we do not explicitly include "$_" inside the parentheses.
So the only place where we explicitly included "$_" in the single line of code is as one of the
targets of our print, so that the starting sentence gets displayed in the output.


Instead of using three separate statements, e.g.,

1. split this array element on one (or more) whitespace characters (and store it in a new array, right?),

2. sort the elements in the new array (using the custom sort ),

followed by

3. a print statement that uses a join(),

We are sorting the output of the split() manipulation in place, and immediately joining those sorted
elements back together for printing to STDOUT.

The rest is just pretty-printing (formatting), with a lot of backslashes to escape the double quotes I want,
and instead of using two sequential "print"s I combined them into a single one (there is an embedded newline
character so that the output for each example appears over two printed lines).


In summary, we have a list of different sentences.  We want to process the sentences in order,
one-by-one, and:

split the sentence on the whitespace between each word,
sort the words alphabetically,
join the sorted words back together,
print out the sorted version of the sentence


=cut

my @sentences = ( "The quick brown fox", "Hello    World!   How   are you?", "Hello", "Hello, World! How are you?", "I have 2 apples and 3 bananas!");

print "Input: \$str = \"", $_, "\"\n", "Output: \"", join(" ", sort { lc($a) cmp lc($b) } split(/\s+/)), "\"\n\n" foreach ( @sentences );

exit;

Kolakoski called, he wants his sequence back(!)

Task #1 is here: Perl Weekly Challenge 356, Task 1

#!/usr/bin/env perl

# https://theweeklychallenge.org/blog/perl-weekly-challenge-356/#TASK1

use strict;
use warnings;


=head1 Context

My new mantra is, "Just because you're really good at counting things
that doesn't mean you are good at math . . . "

Full disclosure, it took me a very long time to wrap my head around
whatever the heck this Kolakoski Sequence is (or does).  And even
then figuring out a satisfactory algorithm took a lot of tweaking.

As a bioinformatician, I think the key insight was to realize that
there are two separate but related processes taking place to
generate the correct sequence.

By analogy with a nucleotide sequence (i.e., a growing string
made up from "letters" in a defined alphabet), one activity,
or function, is like a reading head that proceeds along the
nucleotide sequence, one base at a time, and determines which
alphabet letter is there.  Then there is a separate function,
like a polymerase, that wants to add on to the end of the sequence
by adding new letters (or bases).  This synthesis activity
needs the information from the reading head to know
(A.) which letter to add on to the end, and
(B.) How many copies of that letter to add

In this Perl Weekly Challenge, there are no nucleotide bases
instead the alphabet is the set {1,2}, and the run lengths of
letters ("numbers") that you insert can be either one, or two.

So, '1', '2', '11, or '22' those are your only choices.


=cut


foreach my $n ( 4, 5, 6, 7, 8 ) {

    # This is probably "cheating", but I use the first three positions
    # as the seed, and the algorithm below works if you want to calculate
    # sequences that are 4 or higher in length
    my @sequence = (1,2,2);
    my $read_pos = 2; # This is where the reading head is pointing right now
    my $current_symbol = 1; # Next run will use this symbol
    my @out = ();

    # This is a hack to get my output to look like the example's output
    # I build up a separate array with the just these "patterns" to be printed out
    my @patterns = ( '1', '22',);

    for (my $i = $read_pos; $i < $n; $i++) {
        my $run_length = $sequence[$read_pos]; ## Run length can only be 1, or 2
        my $pattern = q{};

        if ( $run_length == 1 ) {
            if ( $current_symbol == 1 ) {
                @out = (1);
	        $pattern = '1';
            }
            else {
                @out = (2);
                $pattern ='2';
            }
        }
        else {
            if ( $current_symbol == 1 ) {
                @out = (1,1);
                $pattern = '11';
    	    }
            else {
                @out = (2,2);
                $pattern = '22';
            }
        }

        push( @sequence, @out );
        push( @patterns, $pattern);
    
        $current_symbol = ($current_symbol == 1) ? 2 : 1;
        $read_pos++;
    }


    # Array slice to print just the first n elements
    @sequence = @sequence[0..$n-1];

    my @ones = grep {/1/} @sequence;

    my $one_count = scalar( @ones );

    print "Input: \$int = $n\n";
    print "Output: $one_count\n\n";

    print '(', join( ")(", @patterns ), ') => ';
    print join('', @sequence), "\n\n";

}
    

__END__

Task #2 is here: Perl Weekly Challenge 356, Task 2

    
#!/usr/bin/env perl


# https://theweeklychallenge.org/blog/perl-weekly-challenge-356/#TASK2

use strict;
use warnings;

my @inputs = ( "HAHAHH", "HHHHHH", "HHHAHA", "HAHAAH", "HAAHAA", );

foreach my $input (@inputs) {

    # There are seven teams playing six games over three weeks
    # This data structure will eventually hold all of the information
    # about which of the seven teams were playing at home or away for each
    # game, and which team won.  Hash keys are the numbers of the
    # six games.  In the hashrefs the 'W' hash key will hold the number
    # of the team that won
    my %results = ( '1' => { H => 2,
			     A => 7,
			     W => undef,
			   },
                    '2' => { H => 3,
			     A => 6,
			     W => undef,
		           },
                    '3' => { H => 4,
			     A => 5,
			     W => undef,
			    },
                    '4' => { H => 1,
			     A => undef,
			     W => undef,
			   },
                    '5' => { H => undef,
			     A => undef,
			     W => undef,
			   },
		    '6' => { H => undef,
			     A => undef,
			     W => undef,
		           },
               );

    my @pattern = split(//, $input);

    # Process the results from the first three games played during Week 1
    for my $i (0..2) {						
	$results{$i+1}{W} = $pattern[$i] eq 'H' ? $results{$i+1}{H} : $results{$i+1}{A};
    }

    # Sort the three winning teams from Week 1 based on their original seeds
    my @winners = sort ( $results{1}{W}, $results{2}{W}, $results{3}{W} );

    # Populate the hashrefs for the two games played in Week 2
    $results{4}{A} = $winners[2];
    $results{5}{H} = $winners[0];
    $results{5}{A} = $winners[1];

    # Process the results from the second two games played during Week 2
    for my $i (3,4) {						
        $results{$i+1}{W} = $pattern[$i] eq 'H' ? $results{$i+1}{H} : $results{$i+1}{A};
    }

    # Sort the two winning teams from Week 2 based on their original seeds
    @winners = sort ( $results{4}{W}, $results{5}{W}, );

    # Populate the hashref for game 6 played during Week 3
    $results{6}{H} = $winners[0];
    $results{6}{A} = $winners[1];	
    $results{6}{W} = $pattern[5] eq 'H' ? $results{6}{H} : $results{6}{A};

    # Figure out the numbers of the winning and losing teams
    # from Week 3
    my $champ = $results{6}{W};
    my $loser = q{};

    if ( $results{6}{H} == $champ ) {
        $loser = $results{6}{A};
    }
    else {
        $loser = $results{6}{H};
    }

    print "Output: \"Team $champ defeated Team $loser\"\n";

} # close outer foreach loop

Climb every mountain . . .

Here are my two solutions to this week's Perl Weekly Challenge #355, explanatory comments are in situ:

(with apologies to Julie Andrews and Rodgers & Hammerstein, The Sound of Music)

#!/usr/bin/env perl

use v5.36;

# https://theweeklychallenge.org/blog/perl-weekly-challenge-355/#TASK1

my @examples = qw/123 1234 100000 1000000 1 12345/;    
    
foreach my $input ( @examples ) {
    my $output = q{};

    # Split the numbers up into individual digits and store them,
    # in order, in an array
    my @digits = split( //, $input );

    # Use Perl's built-in length operator to filter out numbers
    # too small to require a thousands comma separator
    if ( length( $input ) < 4 ) {
	$output = $input;
    }

    # Since there are 3 different types of numbers to handle, we can
    # distinguish between them using the remainder from 
    # Perl's modulo division operator
    elsif ( scalar( @digits ) % 3 == 0 ) {

        # The posted example data for this challenge did not include
	# any numbers in this category, so I added one to make
	# sure the code was working as intended
        $output = thousand_separator( \@digits, 3 );
    }
    elsif ( scalar( @digits ) % 3 == 2 ) {
        $output = thousand_separator( \@digits, 2 );
    }
    else {
	# We do not require a test here, there is only one
	# option left
	$output = thousand_separator( \@digits, 1 );
    }

    print "Input: \$int = " . $input ."\n";
    print "Output: \"" . $output . "\"\n\n";
}    

# After inspection I realized that my initial solution could be 
# substantially shortened by creating one subroutine to do all
# of the heavy lifting

sub thousand_separator ( $digits, $divisor ) {
    my $output = q{};
    my $count = 0;
    foreach my $digit ( $digits->@* ) {

	# Each time through this loop we concatenate the current
	# digit onto the end of the number we are building up, and
	# then we autoincrement the counter
        $output .= $digit;
	$count++;

	# This test avoids printing an undesired terminal comma
	last if scalar( $digits->@* ) == $count;

	# For each digit in the array, test to see if it is time
	# to add a comma to the number we are building up
        if ( $count == $divisor or $count % 3 == $divisor ) {
            $output .= ',';
	}
    }
    return $output;
}

Task #2:

#!/usr/bin/env perl

use strict;
use warnings;

# https://theweeklychallenge.org/blog/perl-weekly-challenge-355/#TASK2

while (  ) {
    my @row = split(/\t/, $_);
    chomp( @row );
    next if ( scalar( @row ) < 3 );
    print "Input: \@ints = (" . join(", ", @row), ")\n";

    # a priori pretend each record will pass the tests
    my $is_a_mountain = 'true'; 

    # To detect the desired pattern we are going to keep track of the
    # preceding element in the array.  Since there is no element before
    # index [0] we are going to check this now
    my $preceding_element_is = $row[0] > $row[1] ? 'higher' : 'lower';

    # If the current array matches the pattern then the value in
    # $preceding_element_is "switches" from 'lower' to 'higher' once
    # and exactly once, during the analysis loop, and we keep track to
    # see IF: it switches at all, AND, how many times it switches
    my $switch_count = 0;
    while ( my ( $i, $v ) = each( @row ) ) {

	# I decided to test this at the start of each iteration, I suspect
	# some folks would test it at the end of each cycle.
        last if $is_a_mountain eq 'false';

        # We already evaluated the value in $row[0]
        if ( $i > 0 ) {
	    if ( $row[$i-1] > $v ) {
		$switch_count++ if $preceding_element_is eq 'lower';
                $preceding_element_is = 'higher';
	    }
            elsif ( $row[$i-1] < $v ) {
		$switch_count++ if $preceding_element_is eq 'higher';
                $preceding_element_is = 'lower';
	    }
	    else {
                # The task does not permit a data record
		# where the value in two adjacent array elements are equivalent
		# so this condition immediately triggers failure
		$preceding_element_is = 'same';
                $is_a_mountain = 'false';
	    }
	}
	if ( $switch_count > 1 ) {

	    # If the pattern switches a second time
	    # it triggers a failure
            $is_a_mountain = 'false';
	}
    }

    print "Output: ";
    if ( $is_a_mountain eq 'true' and $switch_count == 1 ) {
        print "true\n\n";
    }
    else {
        print "false\n\n";
    }
}


=pod

=head1 COMMENTS

In order for an array of numbers to meet all of the criteria for a so-called
"Mountain Array" it must contain no adjacent repeated numbers, one
maximum value that is in neither the first nor the last element, and
each array element prior to the max must be larger than the preceding element.
Each element after the max must be smaller than the preceding element.

In this script, starting with the second element in the array, we
determine if it's value is either higher, lower, or the same as the
preceding element.  By applying these criteria, and monitoring
if and when that the results of the comparisons "switch" (in this case
from lower to higher), we can determine if the fields in the current
record match the desired pattern (or "shape") of the data.  Here are
two different depictions of the pattern.  In this case using an array
of seven elements from Example #3 in this weekly challenge.



 | index | value | preceding_element_is |
 |--------------------------------------|
 | 0     | 0     | --                   |
 | 1     | 2     | lower                |
 | 2     | 4     | lower                |
 | 3     | 6     | lower                |
 | 4     | 4     | higher               |
 | 5     | 2     | higher               |
 | 6     | 0     | higher               |


Here is an alternative, crude, visualization of what a
Mountain Array would "look" like:


                 lower
           lower       higher
     lower                   higher
 ---                                higher


=cut


__DATA__
1	2	3	4	5
0	2	4	6	4	2	0
5	4	3	2	1
1	3	5	5	4	2
1	3	2

Perl Weekly Challenge #354 Solutions, "These arrays are a-poppin'!"

Task #1 is here: Perl Weekly Challenge 354, Task 1

#!/usr/bin/env perl

use v5.36;

my @inputs = ( [4, 2, 1, 3], [10, 100, 20, 30], [-5, -2, 0, 3], [8, 1, 15, 3], [12, 5, 9, 1, 15], );

foreach my $input ( @inputs ) {
    # Sorting the input is not required, but might help when debugging(?)
    my @sorted = sort {$a <=> $b} $input->@*;

    # Let's use a hash to store the absolute minimum differences
    # between all of the pair combinations of numbers in each array.  The hash keys will be
    # the differences we calculate, and the hash value(s) will be an arrayref of the number pairs
    # that share the same absolute minimum difference
    my %number_pairs_of = ();
    foreach my $i (0..$#sorted) {

        # skip subtracting self from self, instead start with the
        # next array element
        foreach my $j ($i+1..$#sorted) {
            my $abs_min_diff = $sorted[$j] - $sorted[$i];

            # create an anonymous array containing the current pair, and push that onto
            # the hash values arrayref
            push(@{$number_pairs_of{$abs_min_diff}}, [$sorted[$i], $sorted[$j]]);
        }
    }

    # Now, we extract the keys from the %number_pairs_of hash, and sort them numerically
    # to identify the minimum distance for this $input
    my @differences = sort {$a <=> $b} keys %number_pairs_of;

    # The smallest difference will be in the first array element, so use that as a hash key to
    # select all of the pairs that differ by that amount, and pretty print them to STDOUT
    foreach my $pair ( $number_pairs_of{$differences[0]}->@* ) {
        print "[$pair->[0], $pair->[1]] ";
    }
    print "\n\n";
}

Task #2 is here: Perl Weekly Challenge 354, Task 2

#!/usr/bin/env perl

use v5.36;
use Data::Dumper;

my @inputs = ( [[1, 2, 3], [4, 5, 6], [7, 8, 9]], [[10, 20], [30, 40]], [[1, 2], [3, 4], [5, 6]], [[1, 2, 3], [4, 5, 6]], [[1, 2, 3, 4]] );

# These are the k values for the number of times we are going to shift each grid:
my @integers = ( 1, 1, 1, 5, 1 );

foreach my $matrix ( @inputs ) {
    my @matrix = $matrix->@*;

    # Each time through the loop we use the next "k", and remove it from the array
    my $k = shift @integers;

    # Initialize a variable we'll need soon, using Perl Best Practices syntax
    # (Am I the only Perl hacker in the world that uses this syntax for ''?)
    my $output = q{};

    # There are five Example matrices provided for this task.  Four of them get shifted once
    # but one Example gets shifted more than once.  To handle two different cases
    # use a conditional test, coupled with two alternative code blocks.
    # I assume a more skilled software developer would design the
    # subroutine to call itself recursively.
    if ( $k > 1 ) {

        # If we want to shift the matrix more than once, then we are going to use
        # a for loop with a counter variable and just keep feeding the output from the
        # previous subroutine call, into the input for the next subroutine call, until we
        # use up all the numbers
        for my $i (1..$k) {
            my $new_matrix = shift_grid( \@matrix );
            @matrix = $new_matrix->@*;
        }
    }
    else {
        $output = shift_grid( \@matrix );
        @matrix = $output->@*;
    }

    # The output from each example gets printed to STDOUT
    print Data::Dumper->new([\@matrix],[qw(*matrix)])->Indent(0)->Quotekeys(0)->Dump, "\n\n";
}

sub shift_grid ( $matrix ) {
    my @matrix = $matrix->@*;

    # For each matrix we use the Perl pop function to strip
    # off the terminal element of each array, and we are going to store those popped
    # values in this array (in order, we need to keep track of them)
    my @popped = ();

    # This loop pops them off and then stashes the contents them in the array
    foreach my $row ( @matrix ) {
        my $pop = pop $row->@*;
        push( @popped, $pop );
    }

    foreach my $row (0..$#matrix) {

        # Now we are going to use the Perl unshift function to
        # "paste" those popped array values onto the front of our
        # collection of shortened arrays.  But we wanted to keep
        # track because there are two different types of arrays:
        # The first one, and all the rest
        if ($row == 0 ) {

            # IF: the $row we are processing is the FIRST $row
            # THEN: we use the array index from the terminal arrayref
            # to select the last value we added to the @popped array
            # That is what we paste onto the front of the "shifted"
            # grid:
            unshift $matrix->[$row]->@*, $popped[$#matrix];
        }
        else {

            # Otherwise, we want the popped value from the previous $row
            # to paste onto the front of this $row (this is to satisfy all
            # three of the the rules)
            unshift $matrix->[$row]->@*, $popped[$row - 1];
        }
    }
    return \@matrix;
}