RabbitFarm
2025-05-18
Back to a Unique Evaluation
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Distinct Average
You are given an array of numbers with even length. Write a script to return the count of distinct average. The average is calculate by removing the minimum and the maximum, then average of the two.
Our solution will be pretty short, contained in just a single file that has the following structure.
The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version.
the main section is just some basic tests.
-
MAIN:{
say distinct_average 1, 2, 4, 3, 5, 6;
say distinct_average 0, 2, 4, 8, 3, 5;
say distinct_average 7, 3, 1, 0, 5, 9;
}
◇
-
Fragment referenced in 1.
All the work is done in the following subroutine. This problem is straightforward enough to not require much more code than this.
To describe the details of this subroutine sections of it are separated out into their own code sections.
Sample Run
$ perl perl/ch-1.pl 1 2 2
Part 2: Backspace Compare
You are given two strings containing zero or more #. Write a script to return true if the two given strings are same by treating # as backspace.
Our solution will have the following structure.
The main section is just some basic tests.
-
MAIN:{
say backspace_compare q/ab#c/, q/ad#c/;
say backspace_compare q/ab##/, q/a#b#/;
say backspace_compare q/a#b/, q/c/;
}
◇
-
Fragment referenced in 8.
The approach is to maintain two arrays (think of them as stacks), one for each string. As we process each string we will push a character onto the stack as each non-# character is encountered. We’ll pop a character from the stack for every # encountered. When both strings have been processed we’ll compare the two resulting stacks. This code seems to be well contained in a single subroutine.
-
sub backspace_compare{
my($s, $t) = @_;
my @s = split //, $s;
my @t = split //, $t;
my @u = ();
my @v = ();
{
my $s_ = shift @s || undef;
my $t_ = shift @t || undef;
push @u, $s_ if $s_ && $s_ ne q/#/;
push @v, $t_ if $t_ && $t_ ne q/#/;
pop @u if $s_ && $s_ eq q/#/;
pop @v if $t_ && $t_ eq q/#/;
redo if @s || @t;
}
return join(q//, @u) eq join(q//, @v)?q/true/:q/false/;
}
◇
-
Fragment referenced in 8.
Sample Run
$ perl perl/ch-2.pl true true false
References
posted at: 13:01 by: Adam Russell | path: /perl | permanent link to this entry
2025-05-10
Summit of Count Deviation
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Maximum Count
You are given an array of integers. Write a script to return the maximum between the number of positive and negative integers. Zero is neither positive nor negative.
Our solution will be pretty short, contained in just a single file that has the following structure.
The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version.
the main section is just some basic tests.
-
MAIN:{
say maximum_count -3, -2, -1, 1, 2, 3;
say maximum_count -2, -1, 0, 0, 1;
say maximum_count 1, 2, 3, 4;
}
◇
-
Fragment referenced in 1.
All the work is done in the following subroutine.
We do the filtering with a grep.
Sample Run
$ perl perl/ch-1.pl 3 2 4
Part 2: Sum Difference
You are given an array of positive integers. Write a script to return the absolute difference between digit sum and element sum of the given array.
Our solution will be pretty short, contained in just a single file that has the following structure.
The main section is just some basic tests.
-
MAIN:{
say sum_difference 1, 23, 4, 5;
say sum_difference 1, 2, 3, 4, 5;
say sum_difference 1, 2, 34;
}
◇
-
Fragment referenced in 7.
All the work is done in the following subroutine.
We compute the digit sum by splitting each element as a string and then summing the list of digits.
The element sum is a straightforward summing of the elements.
Sample Run
$ perl perl/ch-2.pl 18 0 27
References
posted at: 19:15 by: Adam Russell | path: /perl | permanent link to this entry
2025-05-04
In the Count of Common
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Word Count
You are given a list of words containing alphabetic characters only. Write a script to return the count of words either starting with a vowel or ending with a vowel.
Our solution will be pretty short, contained in just a single file that has the following structure.
The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version.
the main section is just some basic tests.
-
MAIN:{
say word_count qw/unicode xml raku perl/;
say word_count qw/the weekly challenge/;
say word_count qw/perl python postgres/;
}
◇
-
Fragment referenced in 1.
All the work is done in the count section which contains a single small subroutine.
For clarity we’ll break that vowel check into it’s own code section. It’s not too hard. We use the beginning and ending anchors (^, $) to see if there is a character class match at the beginning or end of the word.
Sample Run
$ perl perl/ch-1.pl 2 2 0
Part 2: Minimum Common
You are given two arrays of integers. Write a script to return the minimum integer common to both arrays. If none found return -1.
As in the first part, our solution will be pretty short, contained in just a single file that has the following structure.
(The preamble is going to be the same as before, we don’t need anything extra for this problem either.)
The main section just drives a few tests.
The subroutine that gets the bulk of the solution started is in this section.
The real work is done in this section. We determine the unique elements by creating two separate hashes and then, using the keys to each hash, count the number of common elements. We then sort the common elements, if there are any, and set $minimum to be the smallest one.
-
MAIN:{
say minimum_common [1, 2, 3, 4], [3, 4, 5, 6];
say minimum_common [1, 2, 3], [2, 4];
say minimum_common [1, 2, 3, 4], [5, 6, 7, 8];
}
◇
-
Fragment referenced in 6.
Sample Run
$ perl perl/ch-2.pl 3 2 -1
References
posted at: 12:25 by: Adam Russell | path: /perl | permanent link to this entry
2025-04-27
Group Position Reversals
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Group Position
You are given a string of lowercase letters. Write a script to find the position of all groups in the given string. Three or more consecutive letters form a group. Return “” if none found.
Here’s our one subroutine, this problem requires very little code.
-
sub groupings{
my($s) =@_;
my@groups;
my@group;
my($current, $previous);
my@letters = split //, $s;
$previous = shift@letters;
group = ($previous);
do {
$current = $_;
if($previous eq $current){
push@group, $current;
}
if($previous ne $current){
if(@group >= 3){
push@groups, [@group];
}
group = ($current);
}
$previous = $current;
} for@letters;
if(@group >= 3){
push@groups, [@group];
}
my@r = map {q/"/␣.␣join(q//,␣@{$_}) . q/"/␣}␣@groups;
return join(q/, /,@r) || q/""/;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some basic tests.
-
MAIN:{
say groupings q/abccccd/;
say groupings q/aaabcddddeefff/;
say groupings q/abcdd/;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl "cccc" "aaa", "dddd", "fff" ""
Part 2: Reverse Equals
You are given two arrays of integers, each containing the same elements as the other. Write a script to return true if one array can be made to equal the other by reversing exactly one contiguous subarray.
Here’s the process we’re going to follow.
- scan both arrays and check where and how often they differ
- if they differ in zero places return true!
- if they differ in one or more places check to see if the reversal makes the two arrays equal
Now let’s check and see how many differences were found.
-
return 1 if@{$indices_different} == 0;
$indices_different = [sort {$a <=> $b}@{$indices_different}];
my $last_i = $indices_different->[@{$indices_different} - 1];
my $length = 1 + $last_i - $indices_different->[0];
my@u_ = reverse@{$u}[$indices_different->[0] .. $last_i];
my@v_ = reverse@{$v}[$indices_different->[0] .. $last_i];
splice@{$u}, $indices_different->[0], $length,@u_;
splice@{$v}, $indices_different->[0], $length,@v_;
return 1 if join(q/,/,@{$u}) eq join(q/,/,@{$t});
return 1 if join(q/,/,@{$v}) eq join(q/,/,@{$s});
return 0;
◇
The rest of the code combines the previous steps and drives some tests.
-
MAIN:{
say reverse_equals [3, 2, 1, 4], [1, 2, 3, 4];
say reverse_equals [1, 3, 4], [4, 1, 3];
say reverse_equals [2], [2];
}
◇
-
Fragment referenced in 7.
Sample Run
$ perl perl/ch-2.pl 1 0 1
References
posted at: 19:21 by: Adam Russell | path: /perl | permanent link to this entry
2025-04-17
Acronyms Among Friends
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Acronyms
You are given an array of words and a word. Write a script to return true if concatenating the first letter of each word in the given array matches the given word, return false otherwise.
Here’s our one subroutine, this problem requires very little code.
-
sub acronyms{
my($word_list, $word) =@_;
my@first_letters = map{
(split //, $_)[0]
}@{$word_list};
return 1 if $word eq join q//,@first_letters;
return 0;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say acronyms([qw/Perl Weekly Challenge/], q/PWC/);
say acronyms([qw/Bob Charlie Joe/], q/BCJ/);
say acronyms([qw/Morning Good/], q/MM/);
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 1 1 0
Part 2: Friendly Strings
You are given two strings. Write a script to return true if swapping any two letters in one string match the other string, return false otherwise.
Here’s the process we’re going to follow.
- scan both words and check where and how often they differ
- if they differ in zero places return true!
- if they differ in one place or more than two places return false
- if they differ in two places and the two pairs of letters are the same return true
Now let’s check and see how many differences were found.
The rest of the code combines the previous steps and drives some tests.
-
MAIN:{
say friendly q/desc/, q/dsec/;
say friendly q/cat/, q/dog/;
say friendly q/stripe/, q/sprite/;
}
◇
-
Fragment referenced in 7.
Sample Run
$ perl perl/ch-2.pl 1 0 1
References
posted at: 20:08 by: Adam Russell | path: /perl | permanent link to this entry
2025-04-12
Going Around in Sequential Circles
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Circular
You are given a list of words. Write a script to find out whether the last character of each word is the first character of the following word.
This seems straightforward enough. One question is whether we need to only consider the words in their given order. We’ll assume so.
Here’s our one subroutine, this problem requires very little code.
-
sub circular{
my $current = shift@_;
my $current_last = (split //, $current)[length($current) - 1];
do{
my $previous_last = $current_last;
$current = $_;
my $current_first = (split //, $current)[0];
$current_last = (split //, $current)[length($current) - 1];
return 0 if $previous_last ne $current_first;
} for@_;
return 1;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say circular(qw/perl loves scala/);
say circular(qw/love the programming/);
say circular(qw/java awk kotlin node.js/);
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 1 0 1
Part 2: Subsequence
You are given two strings. Write a script to find out if one string is a subsequence of another.
A subsequence of a string is a new string that is formed from the original string by deleting some (can be none) of the characters without disturbing the relative positions of the remaining characters.
We’re going to do this in teh shortest way possible, via a regular expression.
We’re going to construct the regular expression dynamically each time
The shorter of the two strings will be what we test as the potential subsequence of the other longer one.
We’re going to have the work done in a single subroutine which determines which string to test, builds the regex, and runs it.
The rest of the code drives some tests.
-
MAIN:{
say subsequence q/uvw/, q/bcudvew/;
say subsequence q/aec/, q/abcde/;
say subsequence q/sip/, q/javascript/;
}
◇
-
Fragment referenced in 8.
Sample Run
$ perl perl/ch-2.pl 1 0 1
References
posted at: 22:58 by: Adam Russell | path: /perl | permanent link to this entry
2025-04-06
Finding a Third of the Words
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Find Words
You are given a list of words and a character. Write a script to return the index of word in the list where you find the given character.
This can be done in essentially one line. Rather than write a true Perl one-liner for the command line though, we’ll package this into a single subroutine.
Here’s our one subroutine.
-
sub find_words{
my($s, $c) =@_;
return grep {$s->[$_] =~ m/$c/} 0 ..@{$s} - 1;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say q/(/ . join(q/, /, find_words([q/the/, q/weekly/, q/challenge/], q/e/)). q/)/;
say q/(/ . join(q/, /, find_words([q/perl/, q/raku/, q/python/], q/p/)) . q/)/;
say q/(/ . join(q/, /, find_words([q/abc/, q/def/, q/bbb/, q/bcd/], q/b/)) . q/)/;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl (0, 1, 2) (0, 2) (0, 2, 3)
Part 2: Find Third
You are given a sentence and two words. Write a script to return all words in the given sentence that appear in sequence to the given two words.
Similar to the first part this will be a single short subroutine. We’re just going to loop over the words and match as we go. There are two small things to note here: we strip out any punctuation from our sentence and the empty string q// is considered by Perl to be a false value. The latter is only important in that is how we initialize $next.
-
sub find_third{
my ($s, $first, $second) =@_;
$s =~ s/[[:punct:]]//g;
my@thirds = ();
my($previous, $current, $next) = (q//, q//, q//);
do{
push@thirds, $_ if $next;
$current = $_;
$next = 1 if $previous eq $first && $current eq $second;
$next = 0 unless $previous eq $first && $current eq $second;
$previous = $current;
} for split q/\s+/, $s;
return@thirds;
}
◇
-
Fragment referenced in 6.
The rest of the code drives some tests.
-
MAIN:{
say q/(/ . join(q/, /, find_third(q/Perl is a my favourite language but Python is my favourite too./, q/my/, q/favourite/)). q/)/;
say q/(/ . join(q/, /, find_third(q/Barbie is a beautiful doll also also a beautiful princess./, q/a/, q/beautiful/)) . q/)/;
say q/(/ . join(q/, /, find_third(q/we will we will rock you rock you./, q/we/, q/will/)) . q/)/;
}
◇
-
Fragment referenced in 6.
Sample Run
$ perl perl/ch-2.pl (language, too) (doll, princess) (we, rock)
References
posted at: 17:29 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-27
Equally Sorted
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Equal Strings
You are given three strings. You are allowed to remove the rightmost character of a string to make all equals. Write a script to return the number of operations to make it equal otherwise -1.
The fact that we’re give exactly three strings makes things slightly easier. The approach we’ll take is to pop off the last letter of each and compare the remainders. If they are equal then we are done. Otherwise we’ll continue popping off letter until we’re done.
A special case to consider is when the strings are of unequal length. In that case we make sure to only pop off letters from equal length strings, although the untouched strings will still be used when checking to see if we are done.
Everything can be easily contained in one subroutine. I know that the do blocks with postfix if are not common, but to me they are the most aesthetic way to conditionally perform two short statements.
-
sub loop_pop_compare{
my($s, $t, $u) =@_;
my@s = split //, $s;
my@t = split //, $t;
my@u = split //, $u;
my $counter = 0;
{
my $max_size = (sort {$b <=> $a} (0 +@s, 0 +@t, 0 +@u))[0];
unless(join(q//,@s) eq join(q//,@t) &&
join(q//,@t) eq join(q//,@u)){
do{$counter++; pop@s} if@s == $max_size;
do{$counter++; pop@t} if@t == $max_size;
do{$counter++; pop@u} if@u == $max_size;
}
else{
return $counter;
}
redo unless@s == 0 ||@t == 0 ||@u == 0;
}
return -1;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say loop_pop_compare q/abc/, q/abb/, q/ab/;
say loop_pop_compare q/ayz/, q/cyz/, q/xyz/;
say loop_pop_compare q/yza/, q/yzb/, q/yzc/;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 2 -1 3
Part 2: Sort Column
You are given a list of strings of same length. Write a script to make each column sorted lexicographically by deleting any non sorted columns. Return the total columns deleted.
Unlike the first part, the strings here are guaranteed to be all of the same length and we do not know how many we will need to consider.
-
my $remaining = [grep {$string->[$_] if $_ != $i} 0 ..@{$string} - 1];
◇
-
Fragment never referenced.
-
Defines:
$remainingNever used. -
Uses:
$i8.
We’ll put everything together in a single subroutine.
The rest of the code drives some tests.
-
MAIN:{
say sort_columns qw/swpc tyad azbe/;
say sort_columns qw/cba daf ghi/;
say sort_columns qw/a b c/;
}
◇
-
Fragment referenced in 9.
Sample Run
$ perl perl/ch-2.pl 2 1 0
References
posted at: 18:14 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-23
Reverse Broken Keys for Letters
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Broken Keys
You have a broken keyboard which sometimes type a character more than once. You are given a string and actual typed string. Write a script to find out if the actual typed string is meant for the given string.
What we’re faced with here is a problem of removing consecutive duplicated letters. The trick is that some letters may be correctly duplicated in succession! For example “coffeescript”has two f’s and two e’s which are not in error. We’re given the correct version so wee need to track the current correct letter and find deviations.
Another special case to consider is when the deviations occur at the end of the string and we get all of the same repeated letters as in the “rrakuuuu”example. To address this we check if the repeated letters remaining match the last known good letter.
Our solution is to loop over the letters in the candidate string guided by the original word. We do this all in one subroutine, the code is not so unwieldy to need to be broken into smaller pieces.
-
sub loop_compare{
my($n, $s) =@_;
my@n = split //, $n;
my@s = split //, $s;
my $current_n = q//;
my $current_s = q//;
{
my $previous_n = $current_n;
$current_n = shift@n;
$current_s = shift@s;
if($current_s ne $current_n && $current_s eq $previous_n){
unshift@n, $current_n;
{
$current_s = shift@s;
redo if $current_s eq $previous_n &&@s > 0;
unshift@s, $current_s;
}
}
return 0 if $current_s ne $current_n && $current_s ne $previous_n;
redo if@n > 0 &&@s > 0;
}
return 1 if (@n == 0 &&@s ==0) || (@s == grep {$_ eq $current_s}@s);
return 0;
}
◇
-
Fragment referenced in 2.
We really just need one subroutine to co-ordinate the inputs and run the main loop that’s required.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say loop_compare q/perl/, q/perrrl/;
say loop_compare q/raku/, q/rrakuuuu/;
say loop_compare q/python/, q/perl/;
say loop_compare q/coffeescript/, q/cofffeescccript/;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 1 1 0 1
Part 2: Reverse Letters
You are given a string. Write a script to reverse only the alphabetic characters in the string.
First we separate the alphabetic characters from the string, then we reverse them, then we finish by recombining the reversed alphabetic characters with the non-alphabetic characters.
We’ll put everything together in a single subroutine.
The rest of the code drives some tests.
-
MAIN:{
say reverse_letters q/p-er?l/;
say reverse_letters q/wee-k!L-y/;
say reverse_letters q/_c-!h_all-en!g_e/;
}
◇
-
Fragment referenced in 9.
Sample Run
$ perl perl/ch-2.pl l-re?p yLk-e!e-w _e-!g_nel-la!h_c
References
posted at: 14:18 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-16
Minimum Time in the Box
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Minimum Time
You are given a typewriter with lowercase english letters a to z arranged in a circle. Typing a character takes 1 sec. You can move pointer one character clockwise or anti-clockwise. The pointer initially points at a. Write a script to return minimum time it takes to print the given string.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
All the work is in one subroutine. We use the ASCII values of each character to compute the new value.
-
sub minimum_time{
my($s) =@_;
my@c = split //, lc($s);
my $time = 0;
my $moves;
my $current = q/a/;
{
my $next = shift@c;
my($x, $y) = (ord($current) - 96, ord($next) - 96);
$moves = ($x + 26) - $y if $y >= ($x + 13);
$moves = $y - $x if $y <= ($x + 13) && $y >= $x;
$moves = ($y + 26) - $x if $x >= ($y + 13);
$moves = $x - $y if $x <= ($y + 13) && $x >= $y;
$time += $moves;
$time++;
$current = $next;
redo if@c > 0;
}
return $time;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say minimum_time q/abc/;
say minimum_time q/bza/;
say minimum_time q/zjpc/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 5 7 34
Part 2: Balls and Boxes
There are $n balls of mixed colors: red, blue or green. They are all distributed in 10 boxes labelled 0-9. You are given a string describing the location of balls. Write a script to find the number of boxes containing all three colors. Return 0 if none found.
We’re going to use Parse::Yapp for this problem. Writing parsers is fun! This problem is providing an excuse to write one. This approach has been used in past weeks, for example TWC 259 from this time last year. For simplicity, to start with, here is all the code that Parse::Yapp will use as it’s input.
"ch-2.yp" 5≡
-
%token LETTER
%token NUMBER
%{
my %boxes = ();
%}
%%
records: record {\%boxes}
| records record
;
record: LETTER NUMBER {push@{$boxes{qq/$_[2]/}}, $_[1]}
;
%%
sub lexer{
my($parser) =@_;
defined($parser->YYData->{INPUT}) or return(’’, undef);
##
# send tokens to parser
##
for($parser->YYData->{INPUT}){
s/^([0-9])// and return (q/NUMBER/, $1);
s/^([A-Z])// and return (q/LETTER/, $1);
}
}
sub error{
exists $_[0]->YYData->{ERRMSG}
and do{
print $_[0]->YYData->{ERRMSG};
return;
};
print "syntax␣error\n";
}
sub parse{
my($self, $input) =@_;
$input =~ tr/\t/ /s;
$input =~ tr/ //s;
$self->YYData->{INPUT} = $input;
my $result = $self->YYParse(yylex => \&lexer, yyerror => \&error);
return $result;
}
◇
To solve this problem we are going to pass the input string to the parser. The parser is going to return a hash reference which we’ll check to see which boxes contain all the balls, as described in the problem statement.
-
sub parse_boxes{
my($record) =@_;
my $parser = Ch2->new();
my $boxes = $parser->parse($record);
my $full = 0;
for my $box (keys %{$boxes}){
$full++ if 1 <= (grep { $_ eq q/R/ }@{$boxes->{$box}}) &&
1 <= (grep { $_ eq q/G/ }@{$boxes->{$box}}) &&
1 <= (grep { $_ eq q/B/ }@{$boxes->{$box}});
}
return $full;
}
◇
-
Fragment referenced in 6.
Finally, we need to confirm everything is working right.
Sample Run
$ yapp -m Ch2 perl/ch-2.yp; mv Ch2.pm perl $ perl -I perl perl/ch-2.pl G0B1R2R0B0 1 $ perl -I perl perl/ch-2.pl G1R3R6B3G6B1B6R1G3 3 $ perl -I perl perl/ch-2.pl B3B2G1B3 0
References
posted at: 01:29 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-08
Lower the Upper Sums!
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Upper Lower
You are given a string consists of english letters only. Write a script to convert lower case to upper and upper case to lower in the given string.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
All the work is in one subroutine. We use the ASCII values of each character to compute the new value.
-
sub upper_lower{
my($s) =@_;
my@c = split //, $s;
return join q//, map{
my $x = ord($_);
if($x >= 65 && $x <= 90){
chr($x + 32);
}
elsif($x >= 97 && $x <= 122){
chr($x - 32);
}
}@c;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say upper_lower q/pERl/;
say upper_lower q/rakU/;
say upper_lower q/PyThOn/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl PerL RAKu pYtHoN
Part 2: Group Digit Sum
You are given a string, $str, made up of digits, and an integer, $int, which is less than the length of the given string. Write a script to divide the given string into consecutive groups of size $int (plus one for leftovers if any). Then sum the digits of each group, and concatenate all group sums to create a new string. If the length of the new string is less than or equal to the given integer then return the new string, otherwise continue the process.
To solve this problem we need to do the following
- 1.
- divide the list into groups of the given size
- 2.
- compute the sums
- 3.
- recombine
- 4.
- repeat as needed
Let’s look at each of those pieces individually and then combine them together into one subroutine.
-
my $g = [];
my $groups;
for my $i (0 ..@{$c} - 1){
my $n = $i % $size;
if($n == 0){
$g = [];
push@{$g}, $c->[$i];
}
elsif($n == $size - 1){
push@{$g}, $c->[$i];
push@{$groups}, $g;
$g = [];
}
else{
push@{$g}, $c->[$i];
}
}
push@{$groups}, $g if@{$g} > 0;
◇
With that work take care of, let’s combine all these pieces into one subroutine.
Finally, here’s a few tests to confirm everything is working right.
-
MAIN:{
say group_digit_sum q/111122333/, 3;
say group_digit_sum q/1222312/, 2;
say group_digit_sum q/100012121001/, 4;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl perl/ch-2.pl 359 76 162
References
posted at: 22:30 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-01
Arrays Intersect in Odd Ways
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Arrays Intersection
You are given a list of array of integers. Write a script to return the common elements in all the arrays.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
We’ll take the arrays in pairs and build up a list of common elements. First we compute the common elements of the first two arrays and then proceed to check these against the remaining arrays. If any of these initial common elements are not found in subsequent arrays they are not included in future checks. Finally the remaining common elements are returned. If there are no common elements we return n/a.
-
sub array_intersections{
my@common_elements;
my $x = shift@_;
my $y = shift@_;
if($x && $y){
my@common = map {
my $x = $_;
grep {$x == $_}@{$y}
}@{$x};
push@common_elements,@common;
}
{
$x = shift@_;
my@common = map {
my $x = $_;
grep {$x == $_}@{$y}
}@common_elements;
common_elements =@common;
redo if@_ > 1;
}
return (join q/, /,@common_elements) || q#n/a#;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say array_intersections [1, 2, 3, 4], [4, 5, 6, 1], [4, 2, 1, 3];
say array_intersections [1, 0, 2, 3], [2, 4, 5];
say array_intersections [1, 2, 3], [4, 5], [6];
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 1, 4 2 n/a
Part 2: Sort Odd Even
You are given an array of integers. Write a script to sort odd index elements in decreasing order and even index elements in increasing order in the given array.
To solve this problem we need to do the following
- 1.
- seperate the odd and even numbers
- 2.
- sort the two lists as directed
- 3.
- combine the results
Much of this work can be written concisely using map and grep.
-
sub sort_odd_even{
my@i =@_;
my@odds = map { $i[$_] } grep {$_ % 2 != 0} 0 ..@_ - 1;
my@evens = map { $i[$_] } grep {$_ % 2 == 0} 0 ..@_ - 1;
my@odds_sorted = sort {$b <=> $a}@odds;
my@evens_sorted = sort {$a <=> $b}@evens;
my@common_elements;
do {
$common_elements[$_] = shift@odds_sorted if $_ % 2 != 0;
$common_elements[$_] = shift@evens_sorted if $_ % 2 == 0;
} for 0 ..@_ - 1;
return@common_elements;
}
◇
-
Fragment referenced in 5.
Finally, here’s a few tests to confirm everything is working right.
-
MAIN:{
say join q/, /, sort_odd_even 4, 1, 2, 3;
say join q/, /, sort_odd_even 3, 1;
say join q/, /, sort_odd_even 5, 3, 2, 1, 4;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl perl/ch-2.pl 2, 3, 4, 1 3, 1 2, 3, 4, 1, 5
References
posted at: 22:17 by: Adam Russell | path: /perl | permanent link to this entry
2025-02-23
Gap Minimizations
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Min Gap
You are given an array of integers, @ints, increasing order. Write a script to return the element before which you find the smallest gap.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
Let’s not even store anything. Instead go down the list and update two variables: one to store the current minimum gap, and the other to store the element before the current smallest gap found.
I use a small trick here. A way of saying The Maximum Integer is 0 + q/inf/.
-
sub min_gap{
my($min_gap, $element_min_gap) = (0 + q/inf/, 0 + q/inf/);
{
my $x = shift@_;
my $y = shift@_;
if($x && $y){
my $gap = $y - $x;
if($gap < $min_gap){
$min_gap = $gap;
$element_min_gap = $y;
}
}
unshift@_, $y;
redo if@_ > 1;
}
return $element_min_gap;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say min_gap 2, 8, 10, 11, 15;
say min_gap 1, 5, 6, 7, 14;
say min_gap 8, 20, 25, 28;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 11 6 28
Part 2: Min Diff
You are given an array of integers, @ints. Write a script to find the minimum difference between any two elements.
From Part 1 we know that if we sort the list we know we need to only check adjacent elements to find the minimum difference.
-
sub min_diff{
my $min_gap = 0 + q/inf/;
my@i = sort {$a <=> $b}@_;
{
my $x = shift@i;
my $y = shift@i;
if($x && $y){
my $gap = $y - $x;
$min_gap = $gap if $gap < $min_gap;
}
unshift@i, $y;
redo if@i > 1;
}
return $min_gap;
}
◇
-
Fragment referenced in 5.
Finally, here’s a few tests to confirm everything is working right.
Sample Run
$ perl ch-2.pl 1 2
References
posted at: 19:58 by: Adam Russell | path: /perl | permanent link to this entry
2024-12-01
Contiguous and Semi-Ordered
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Contiguous Array
You are given an array of binary numbers, @binary.
Write a script to return the maximum length of a contiguous subarray with an equal number of 0 and 1.
Let’s not concern ourselves with any particular efficiencies and just analyze all the subsets of the given numbers!
The main loop for iterating over all the contiguous sub-arrays.
We really just need one subroutine to co-ordinate the inputs and run the main loop that’s required.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say contiguous_array 1, 0;
say contiguous_array 0, 1, 0;
say contiguous_array 0, 0, 0, 0, 0;
say contiguous_array 0, 1, 0, 0, 1, 0;
}
◇
-
Fragment referenced in 3.
Sample Run
$ perl perl/ch-1.pl 2 2 0 4
Part 2: Semi-Ordered Permutation
You are given permutation of $n integers, @ints. Write a script to find the minimum number of swaps needed to make the @ints a semi-ordered permutation.
A permutation is called semi-ordered if the first number is 1 and the last number equals n. That means we need to count the number of swaps needed to move 1 to the beginning and $n to the end.
At first thought, I wonder if there’s a catch? Does the swapping end up moving 1 or $n further from its destination? That doesn’t seem to be the case even if they were adjacent to each other. That is because they are moving in opposite directions. 1 is always moving left and $n is always moving right. Although they may swap with each other it will always be of benefit to them both.
Let’s start with the code for swapping left and and right to move 1 and $n in their respective directions.
We’ll put everything together in a subroutine.
The rest of the code drives some tests.
-
MAIN:{
say semi_ordered 2, 1, 4, 3;
say semi_ordered 2, 4, 1, 3;
say semi_ordered 1, 3, 2, 4, 5;
}
◇
-
Fragment referenced in 9.
Sample Run
$ perl perl/ch-2.pl 2 3 0
References
posted at: 23:34 by: Adam Russell | path: /perl | permanent link to this entry
2024-11-25
String Together a Square
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: String Compression
You are given a string of alphabetic characters, $chars. Write a script to compress the string with run-length encoding.
A compressed unit can be either a single character or a count followed by a character.
BONUS: Write a decompression function.
After working so much with recursion for the previous challenge, TWC 295, this time around we’ll use a simple loop mechanism available in Perl: a redo block.
The main loop for iterating over the characters one by one.
Here’s a subroutine which co-ordinates encoding: splits the string, invokes the loop, and returns the compressed format.
The BONUS seems to be fairly doable. Given an encoded string we can expand it back to the original by a similar process as the encoding. In fact, let’s use the same sort of loop.
As before we’ll define a subroutine which co-ordinates decoding.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say encoding q/abbc/;
say encoding q/aaabccc/;
say encoding q/abcc/;
say q//;
say decoding encoding q/abbc/;
say decoding encoding q/aaabccc/;
say decoding encoding q/abcc/;
}
◇
-
Fragment referenced in 6.
Sample Run
$ perl perl/ch-1.pl a2bc 3ab3c ab2c abbc aaabccc abcc
Part 2: Matchstick Square
You are given an array of integers, @ints. Write a script to find if it is possible to make one square using the sticks as in the given array @ints where $ints[$i] is the length of ith stick.
First let’s notice that the lengths must all sum to a number evenly divisible by four, so that’ll be an initial filter on the list. If that first test passes we divide the sum by four (to get the side length) and determine if we can get four subsets which all sum to that side length.
If we have a sum of lengths evenly divisible by four we’ll then check if if we have four subsets which sum to the computed side length. To do this we’ll compute the powerset (all subsets) of the list and check the sums.
The rest of the code drives some tests.
-
MAIN:{
say boolean is_square 1, 2, 2, 2, 1;
say boolean is_square 2, 2, 2, 4;
say boolean is_square 2, 2, 2, 2, 4;
say boolean is_square 3, 4, 1, 4, 3, 1;
}
◇
-
Fragment referenced in 12.
Sample Run
$ perl perl/ch-2.pl 1 0 0 1
References
posted at: 00:31 by: Adam Russell | path: /perl | permanent link to this entry
2024-11-24
Jump into a Word Game
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Word Break
You are given a string, $str, and list of words, @words.
Write a script to return true or false whether the given string can be segmented into a space separated sequence of one or more words from the given list.
This can be brute forced rather easily: just try every concatenated combination from the list and see if we get a match. It is not too much work to add a bit more efficiency though. Our approach will be:
- Put the list of words into a hash keyed by the first letter.
- Start with the first letter of the string, find a match in the hash.
- Remove the word from the string and move onto the next letter.
- Repeat until, if possible, all parts of the string are found in the list.
Since there may be many words which start with the same letter we will use a recursive implementation which will make sure to check each of them.
Here’s how we construct the hash of words keyed by their first letter. Nothing especially clever, just an ordinary loop over the words.
The biggest chunk of word is here in this subroutine, where we recursively explore all possibilities of matching words. If at any point we find all components of the string we return true. In cases where the string cannot be composed of words from the list then the recursion just simply ends and, by default, returns undef.
Here’s a subroutine which co-ordinates everything: invokes the hash construction and recursion. The boolean function is used to make sure something nicely printable is returned.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say word_break q/weeklychallenge/, [q/challenge/, q/weekly/];
say word_break q/perlrakuperl/, [q/raku/, q/perl/];
say word_break q/sonsanddaughters/,[q/sons/, q/sand/, q/daughters/];
}
◇
-
Fragment referenced in 4.
Sample Run
$ perl perl/ch-1.pl 1 1 0
Part 2: Jump Game
You are given an array of integers, @ints. Write a script to find the minimum number of jumps to reach the last element. $ints[$i] represents the maximum length of a forward jump from the index $i. In case last element is unreachable then return -1.
We always start at the array index 0. From there we can recursively explore the possible paths that may be taken. Keep in mind that at each step $i we can only move as many as $ints[$i] positions.
In many ways this is similar to the first part of this week’s challenge!
If at any point we detect we have reached list’s end then we save the number of moves made. At the end we sort the list of moves and return the smallest number of moves. If this list is empty then we return -1.
The rest of the code drives some tests.
-
MAIN:{
say jump_game 2, 3, 1, 1, 4;
say jump_game 2, 3, 0, 4;
say jump_game 2, 0, 0, 4;
}
◇
-
Fragment referenced in 9.
Sample Run
$ perl perl/ch-2.pl 2 2 -1
References
posted at: 19:22 by: Adam Russell | path: /perl | permanent link to this entry
2024-10-14
Double Luhn
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Double Exist
You are given an array of integers, @ints. Write a script to find if there exist two indices $i and $j such that:
- $i≠$j
- 0 ≥ $i < size @ints and 0 ≥ $j < size @ints
- $ints[$i] = 2 ∗ $ints[$j]
The majority of the work can be done in a few lines. If there is a more elegant way to do this, it escaped me when I was writing this code!
-
sub double_exist{
my(@a) =@_;
do{
my $i = $_;
do{
my $j = $_;
if($i != $j){
return 1 if $a[$i] == 2 * $a[$j];
}
} for 0 ..@a - 1;
} for 0 ..@a - 1;
return 0;
}
◇
-
Fragment referenced in 2.
The rest of the code just tests this function.
-
MAIN:{
say double_exist 6, 2, 3, 3;
say double_exist 3, 1, 4, 13;
say double_exist 2, 1, 4, 2;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 1 0 1
Part 2: Luhn’s Algorithm
You are given a string $str containing digits (and possibly other characters which can be ignored). The last digit is the payload; consider it separately. Counting from the right, double the value of the first, third, etc. of the remaining digits. For each value now greater than 9, sum its digits. The correct check digit is that which, added to the sum of all values, would bring the total mod 10 to zero. Return true if and only if the payload is equal to the correct check digit.
This can also be done in relatively few lines. There are no real special cases here.
-
sub luhn{
my($digits) =@_;
my@digits = $digits =~ m/([0-9])/g;
my $sum = 0;
my $check = pop@digits;
{
my $x = pop@digits;
my $y = pop@digits;
if(defined $x && defined $y){
$sum += $y + sum_digits 2 * $x;
}
else{
$sum += sum_digits 2 * $x;
}
redo if@digits;
}
return 1 if 0 == ($sum + $check) % 10;
return 0;
}
◇
-
Fragment referenced in 7.
For convenience we’ll put the summing of digits for numbers > 10 in a separate function.
-
sub sum_digits{
my($x) =@_;
if($x >= 10){
my@a = split //, $x;
return $a[0] + $a[1];
}
return $x;
}
◇
-
Fragment referenced in 7.
The rest of the code drives some tests.
-
MAIN:{
say luhn q/17893729974/;
say luhn q/4137 8947 1175 5904/;
say luhn q/4137 8974 1175 5904/;
}
◇
-
Fragment referenced in 7.
Sample Run
$ perl perl/ch-2.pl 1 1 0
References
posted at: 01:19 by: Adam Russell | path: /perl | permanent link to this entry
2024-10-05
Maximum Jumble
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Third Maximum
You are given an array of integers, @ints. Write a script to find the third distinct maximum in the given array. If a third maximum doesn’t exist then return the maximum number.
The majority of the work can be done in a couple of lines. We need only sort the distinct integers in the list and then return either the third largest number or, if none exists, the largest.
-
sub third_maximum{
my %h;
do{ $h{$_} = undef } for@_;
my@sorted = sort {$b <=> $a} keys %h;
return $sorted[2] if@sorted >= 3;
return $sorted[0];
}
◇
-
Fragment referenced in 2.
The rest of the code just tests this function.
-
MAIN:{
say third_maximum 5, 6, 4, 1;
say third_maximum 4, 5;
say third_maximum 1, 2, 2, 3;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 4 5 1
Part 2: Jumbled Letters
Your task is to write a program that takes English text as its input and outputs a jumbled version
The rules for jumbling are given as follows:
- The first and last letter of every word must stay the same.
- The remaining letters in the word are scrambled in a random order (if that happens to be the original order, that is OK).
- Whitespace, punctuation, and capitalization must stay the same.
- The order of words does not change, only the letters inside the word.
Looking closer at these rules the main thing we need to concern ourselves with is jumbling the letters with the exception of the first and last. The use of map will ensure the words are processed in order. To make sure the first/last letters are unchanged also depends on detecting punctuation.
Punctuation is determined by a regex. We’ll keep track of the locations so we can add them back later, after jumbling.
Now that we have the punctuation accounted for let’s do the jumble. We’ll do this by generating permutations and randomly select one.
-
my $p = Algorithm::Permute->new(
[@{$stripped}[1 ..@{$stripped} - 2]]
);
my@p;
if(@{$stripped} > 2){
my@r = $p->next();
{
push@p, [@r];
r = $p->next();
redo if@r;
}
$stripped = [$stripped->[0] ,
{$p[rand@p]} ,
$stripped->[@{$stripped} - 1]];
}
$stripped = join q//,@{$stripped};
◇
Finally, add the punctuation back in.
The rest of the code drives some tests.
-
MAIN:{
say q/in the ASCII range match all non-controls./;
say jumble qw/in the ASCII range match all non-controls./;
say q//;
say q/This handy module makes performing permutation.../;
say jumble qw/This handy module makes performing permutation.../;
}
◇
-
Fragment referenced in 9.
Sample Run
$ perl perl/ch-2.pl in the ASCII range match all non-controls. in the AISCI range macth all non-rloncots. This handy module makes performing permutation... Tihs handy mloude mkaes prifnremog prtaoimetun...
References
posted at: 21:02 by: Adam Russell | path: /perl | permanent link to this entry
2024-08-12
It’s Good To Change Keys
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
File Index
Part 1: Good Integer
You are given a positive integer, $int, having 3 or more digits. Write a script to return the Good Integer in the given integer or -1 if none found.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
A good integer is exactly three consecutive matching digits.
-
sub good_integer{
my($x) =@_;
return qq/$1$2/ if $x =~ m/([0-9])(\1{2,})/ &&
length qq/$1$2/ == 3;
return -1;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say good_integer q/12344456/;
say good_integer q/1233334/;
say good_integer q/10020003/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 444 -1 000
Part 2: Changing Keys
You are given an alphabetic string, $str, as typed by user. Write a script to find the number of times user had to change the key to type the given string. Changing key is defined as using a key different from the last used key. The shift and caps lock keys won’t be counted.
-
sub count_key_changes{
my($s) =@_;
my $count = 0;
my@s = split //, lc $s;
{
my $x = shift@s;
my $y = shift@s;
$count++ if $x && $y && $x ne $y;
unshift@s, $y if $y;
redo if@s;
}
return $count;
}
◇
-
Fragment referenced in 5.
Finally, here’s a few tests to confirm everything is working right.
-
MAIN:{
say count_key_changes(q/pPeERrLl/);
say count_key_changes(q/rRr/);
say count_key_changes(q/GoO/);
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl ch-2.pl 3 0 1
References
posted at: 14:51 by: Adam Russell | path: /perl | permanent link to this entry
2024-08-10
Checking Out the Knight’s Moves
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
File Index
Part 1: Check Color
You are given coordinates, a string that represents the coordinates of a square of the chessboard. Write a script to return true if the square is light, and false if the square is dark.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
The color of a given square is determined by calculating its color number. If the color number is positive the square is dark. If the color number is negative then it is light.
We determine the color number in the following code fragment. Here we compute $n as -1 raised tot he power of the letter’s index. In this way we get alternating -1/1 starting with ’a’. We do the same with the second part of the co-rdinate to get an alternating -1/1 for the chessboard row. These are multiplied together to get the color number.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say check_color q/d3/;
say check_color q/g5/;
say check_color q/e6/;
say check_color q/b1/;
say check_color q/b8/;
say check_color q/h1/;
say check_color q/h8/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl true false true true false true false
Part 2: Knight’s Move
A Knight in chess can move from its current position to any square two rows or columns plus one column or row away. Write a script which takes a starting position and an ending position and calculates the least number of moves required.
The bulk of the code is just setting up the main data structure, a graph. For each square of the chessboard we add an edge to all the squares that are reachable by a knight.
-
sub build_graph{
my $graph = Graph->new();
do {
my $c = $_;
do {
my $r = $_;
my($s, $t);
##
# up
##
$s = $r + 2;
$t = chr(ord(qq/$c/) - 1);
$t = chr(ord(qq/$c/) + 1);
##
# down
##
$s = $r - 2;
$t = chr(ord(qq/$c/) - 1);
$t = chr(ord(qq/$c/) + 1);
##
# left
##
$s = $r - 1;
$t = chr(ord(qq/$c/) - 2);
$s = $r + 1;
##
# right
##
$s = $r - 1;
$t = chr(ord(qq/$c/) + 2);
$s = $r + 1;
} for 1 .. 8;
} for q/a/ .. q/h/;
return $graph;
}
◇
For convenience I use a little bit of nuweb hackery instead of a new subroutine to seperate out this code which is repeated in the final generated code file.
After we go through the work of setting up the graph the result can be easily gotten via use of Djikstra’s shortest path algorithm.
Finally, here’s a few tests to confirm everything is working right.
Sample Run
$ perl ch-2.pl g2 ---> a8 4: g2 -> e3 -> c4 -> b6 -> a8 g2 ---> h2 3: g2 -> e1 -> f3 -> h2
References
The Weekly Challenge 281
Generated Code
Graph.pm
Knight’s Tours
posted at: 16:52 by: Adam Russell | path: /perl | permanent link to this entry
2024-08-04
Asterisks Appear Twice
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
File Index
Part 1: Twice Appearance
You are given a string, $str, containing lowercase English letters only. Write a script to print the first letter that appears twice.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
-
sub twice_appearance{
my($s) =@_;
my@a = ();
do{
$a[ord($_)]++;
return $_ if $a[ord($_)] == 2;
} for split //, $s;
return undef;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say twice_appearance q/acbddbca/;
say twice_appearance q/abccd/;
say twice_appearance q/abcdabbb/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl d c a
Part 2: Count Asterisks
You are given a string, $str, where every two consecutive vertical bars are grouped into a pair. Write a script to return the number of asterisks, *, excluding any between each pair of vertical bars.
This is our principal function. As can be seen, it’s very short! The logic here is simple: peel off pairs and use a regex to find the asterisks.
-
sub count_asterisks{
my($s) = shift;
my $score = 0;
my@asterisks = ();
my@s = split /\|/, $s;
{
my $x = shift@s;
my $y = shift@s;
my@a = $x =~ m/(\*)/g if $x;
push@asterisks,@a if@a > 0;
redo if@s >= 1;
}
return 0 +@asterisks;
}
◇
-
Fragment referenced in 5.
Finally, here’s a few tests to confirm everything is working right.
-
MAIN:{
say count_asterisks q/p|*e*rl|w**e|*ekly|/;
say count_asterisks q/perl/;
say count_asterisks q/th|ewe|e**|k|l***ych|alleng|e/;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl ch-2.pl 13 30 37
References
posted at: 16:57 by: Adam Russell | path: /perl | permanent link to this entry
2024-06-08
Defanged and Scored
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
File Index
Part 1: Defang IP Address
You are given a valid IPv4 address. Write a script to return the defanged version of the given IP address. A defanged IP address replaces every period “.” with “[.]".
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
First, let’s consider how we know to make string substitutions. Regular Expressions are an obvious choice. Maybe a little too obvious to be fun. We could also convert the string to a list of characters and then loop over the list making adjustments as necessary. That sounds nicer. Instead of some ordinary loop though let’s add a little recursive spice!
-
sub defang{
my($c, $defanged) =@_;
$defanged = [] if !$defanged;
return $defanged if@{$c} == 0;
my $x = shift@{$c};
if($x eq q/./){
push@{$defanged}, q/[.]/;
}
else{
push@{$defanged}, $x;
}
defang($c, $defanged);
}
◇
-
Fragment referenced in 1.
-
Defines:
$defangedNever used.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say join(q//,@{defang([split //, q/1.1.1.1/])});
say join(q//,@{defang([split //, q/255.101.1.0/])});
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 1[.]1[.]1[.]1 255[.]101[.]1[.]0
Part 2: String Score
You are given a string, $str. Write a script to return the score of the given string. The score of a string is defined as the sum of the absolute difference between the ASCII values of adjacent characters.
We’ll contain the solution in a single function. The completed solution will just have that function plus a few tests. Instead of recursion this time we’ll use a redo block.
This is our principal function. As can be seen, it’s very short! The logic here is simple: peel off characters until there’s just one left. Calculate the string score each time through. Well, to simplify things we’ll first actually convert the characters to their ascii values. That’s what the map at the start of the function does.
-
sub string_score{
my($s) = shift;
my $score = 0;
my@s = map {ord $_} split //, $s;
{
my $x = shift@s;
my $y = shift@s;
$score += abs($x - $y) if $x && $y;
unshift@s, $y;
redo if@s > 1;
}
return $score;
}
◇
-
Fragment referenced in 5.
Finally, here’s a few tests to confirm everything is working right.
-
MAIN:{
say string_score q/hello/;
say string_score q/perl/;
say string_score q/raku/;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl ch-2.pl 13 30 37
References
posted at: 00:14 by: Adam Russell | path: /perl | permanent link to this entry
2024-03-23
These Elements, They’re Multiplying!
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
File Index
Part 1: Element Digit Sum
You are given an array of integers, @integers. Write a script to evaluate the absolute difference between every element and the digit sum of the entire given array.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
First, let’s consider how we compute the digit sum for an array of integers. If we we make sure that all multi-digit numbers are expanded into lists of digits then this is the sum of the concatenation of all such lists, along with single digit numbers.
The expansion of multi-digit numbers is handled by map, and the sum is taken with unpack and the resulting final array. A key thing to remember here is that Perl will flatten all lists inside the array so all the results from the map will be in a list of single digits.
The element sum is the same procedure as the digit sum, but just without the map.
Finally, we have a few lines of code for running some tests.
-
MAIN:{
say element_digit_sum 1, 2, 3, 45;
say element_digit_sum 1, 12, 3;
say element_digit_sum 1, 2, 3, 4;
say element_digit_sum 236, 416, 336, 350;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 36 9 0 1296
Part 2: Multiply by Two
You are given an array of integers, @integers and an integer $start. Write a script to do the following:
a) Look for $start in the array @integers, if found multiply the number by 2.
b) If not found stop the process, otherwise repeat.
In the end return the final value.
We’ll contain the solution in a single recursive function. The completed solution will just have that function plus a few tests.
This is our principal function. As can be seen, it’s very short! The logic here is simple: for each recursive call check for $start in the array and, if found, double $start and keep recursing. Otherwise, return $start.
-
sub search_multiply{
my($start) = shift;
return $start if 0 == grep {$start == $_}@_;
search_multiply($start + $start,@_);
}
◇
-
Fragment referenced in 7.
Finally, here’s a few tests to confirm everything is working right.
-
MAIN:{
say search_multiply 3, 5, 3, 6, 1, 12;
say search_multiply 1, 1, 2, 3, 4;
say search_multiply 2, 5, 6, 7;
}
◇
-
Fragment referenced in 7.
Sample Run
$ perl ch-2.pl 24 8 2
References
posted at: 20:34 by: Adam Russell | path: /perl | permanent link to this entry
2024-03-16
This Week a Ranking Occurred!
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
File Index
Part 1: Unique Occurrences
You are given an array of integers, @ints. Write a script to return 1 if the number of occurrences of each value in the given array is unique or 0 otherwise.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re specifying to use the current version of Perl, for all the latest features. We’re also using the boolean module, for the convenience of returning and displaying the return values.
This fragment is also used in Part 2.
Here we have a single function which does essentially all the work. First we loop through the array of numbers and count occurrences. Then the counts are themselves used as hash keys to eliminate duplicates. If no duplicates are removed then the number of these new keys is equal to the number of original count values.
-
sub unique_occurrences{
my %occurrences;
do{
$occurrences{$_}++;
} for@_;
my %h;
do{$h{$_} = undef} for values %occurrences;
return boolean(values %occurrences == keys %h);
}
◇
-
Fragment referenced in 1.
Finally, we have a few lines of code for running some tests.
-
MAIN:{
say unique_occurrences 1, 2, 2, 1, 1, 3;
say unique_occurrences 1, 2, 3;
say unique_occurrences -2, 0, 1, -2, 1, 1, 0, 1, -2, 9;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 1 0 1
Part 2: Dictionary Rank
You are given a word, $word. Write a script to compute the dictionary rank of the given word.
The solution to the second part of this week’s challenge is a little more complex than the first part. In the solution file we define our own function for computing all permutations of an array, which is then used to determine the dictionary rank.
This function is a recursive implementation of Heap’s algorithm. A lot has been written on this algorithm, so I won’t go into much detail here.
-
sub permutations{
my($a, $k, $permutations) =@_;
if($k == 1){
push@{$permutations}, [@{$a}];
return true;
}
else{
permutations($a, $k - 1, $permutations);
for my $i (0 .. $k - 2){
if($k & 1){
($a->[0], $a->[$k - 1]) = ($a->[$k - 1], $a->[0]);
}
else{
($a->[$i], $a->[$k - 1]) = ($a->[$k - 1], $a->[$i]);
}
permutations($a, $k - 1, $permutations);
}
}
}
◇
-
Fragment referenced in 5.
Now that we have a way to compute all permutations we will use that to determine the dictionary rank. There is a trick here. Keep in mind that dictionaries do not have multiple entries for repeated words! In the case of words with repeated letters than there will be permutations that are effectively equal in that they contain the same letters. Although they are created by permuting equal (but different) letters for ranking purposes we will consider them the same.
-
sub dictionary_rank{
my($word) =@_;
my $permutations = [];
permutations [split //, $word], length($word), $permutations;
my %h;
do {$h{join q//,@{$_}} = undef} for@{$permutations};
my@permutations = sort {$a cmp $b} keys %h;
return (
grep {$permutations[$_] eq $word} 0 ..@permutations - 1
)[0] + 1;
}
◇
-
Fragment referenced in 5.
-
MAIN:{
say dictionary_rank q/CAT/;
say dictionary_rank q/GOOGLE/;
say dictionary_rank q/SECRET/;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl ch-2.pl 3 88 255
References
posted at: 20:39 by: Adam Russell | path: /perl | permanent link to this entry
2024-03-10
Banking Left Into the Parser Zone
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Banking Day Offset
You are given a start date and offset counter. Optionally you also get bank holiday date list. Given a number (of days) and a start date, return the number (of days) adjusted to take into account non-banking days. In other words: convert a banking day offset to a calendar day offset.
Non-banking days are:
- (a)
- Weekends
- (b)
- Bank holidays
Using Time::Piece the work can be contained in a single function. Really the main piece of logic required of sub count_days() is for us to check if a day is a weekend or bank holiday.
-
sub count_days{
my($start, $offset, $holidays) =@_;
$start = Time::Piece->strptime($start, q/%Y-%m-%d/);
my $t = $start;
my $end = $start;
{
$t += ONE_DAY;
unless(⟨The day is a weekend. 2 ⟩||⟨The day is a bank holiday. 3 ⟩){
$end = $t;
$offset--;
}
redo if $offset > 0;
}
return $end->strftime(q/%Y-%m-%d/);
}
◇
-
Fragment referenced in 4.
-
1 == grep {$t->strftime(q/%Y-%m-%d/) eq $_}@{$holidays}
◇
-
Fragment referenced in 1.
The rest of the code just tests this function.
-
MAIN:{
say count_days q/2018-06-28/, 3, [q/2018-07-03/];
say count_days q/2018-06-28/, 3;
}
◇
-
Fragment referenced in 4.
Sample Run
$ perl perl/ch-1.pl 2018-07-04 2018-07-03
Part 2: Line Parser
You are given a line like below:
{% id field1=“value1”field2=“value2”field3=42 %}
Where
- (a)
- “id”can be \w+.
- (b)
- There can be 0 or more field-value pairs.
- (c)
- The name of the fields are \w+.
- (d)
- The values are either number in which case we don’t need double quotes or string in which case we need double quotes around them.
The line parser should return a structure like:
{ name => id, fields => { field1 => value1, field2 => value2, field3 => value3, } }
It should be able to parse the following edge cases too:
{% youtube title="Title␣\"quoted\"␣done" %}
and
{% youtube title="Title␣with␣escaped␣backslash␣\\" %}
Most of the work is done in a parser constructed using Parse::Yapp.
ch-2.pl
First off, before we get into the parser, here is a small bit of code for driving the tests.
-
sub print_record{
my($record) =@_;
say q/{/;
say qq/\tname => / . $record->{name};
say qq/\tfields => {/;
for my $field (sort {$a cmp $b} keys %{$record->{fields}}){
say qq/\t\t$field => / . q/ / . $record->{fields}->{$field};
}
say qq/\t}/;
say q/}/;
}
◇
-
Fragment referenced in 8.
The rest of the code drives some tests.
-
use v5.38;
use Ch2;
use constant TEST0 => q/{% id field1="value1" field2="value2" field3=42 %}/;
use constant TEST1 => q/{% youtube title="Title␣\"quoted\"␣done" %}/;
use constant TEST2 => q/{% youtube title="Title␣with␣escaped␣backslash␣\\\\" %}/;
◇
-
Fragment referenced in 8.
-
MAIN:{
my $parser = Ch2->new();
say TEST0;
print_record($parser->parse(TEST0));
say TEST1;
print_record($parser->parse(TEST1));
say TEST2;
print_record($parser->parse(TEST2));
}
◇
-
Fragment referenced in 8.
The Parser
Here is where the work is really done. Parse::Yapp is given the following grammar. A parser is generated, contained in it’s own module.
First off is the grammar’s header. Here we define the symbols used in the rules which follow. We also add a small code block which contains a hash for holding the structure obtained from the parsed text.
-
%token NUMBER
%token START
%token END
%token WORD
%token QUOTE
%token ESCAPED_QUOTE
%{
my %record = (fields => {});
%}
◇
-
Fragment referenced in 17.
Here is the most important section, the rules for processing the input! For some rules we have also added action code blocks. We want to construct a data structure from the given input and in these action code blocks that final result is accumulated. Remember, the first rule is going to be called last, when the input is complete, so there we give a reference to a hash containing the result. This is the return value for the parse function found in the grammar’s footer.
-
file: START id fields END {$record{name} = $_[2]; \%record;}
;
id: WORD
;
words: WORD
| words WORD
| words ESCAPED_QUOTE WORD ESCAPED_QUOTE
;
field: WORD ’=’ NUMBER {$record{fields}->{$_[1]} = $_[3]}
| WORD ’=’ QUOTE words QUOTE {$record{fields}->{$_[1]} = $_[4]}
;
fields: field
| fields field
;
◇
-
Fragment referenced in 17.
The footer contains additional Perl code for the lexer, error handing, and a parse function which provides the main point of execution from code that wants to call the parser that has been generated from the grammar.
The lexer function is called repeatedly for the entire input. Regular expressions are used to identify symbols (the ones declared in the header) and pass them along for the rules processing.
-
sub lexer{
my($parser) =@_;
$parser->YYData->{INPUT} or return(’’, undef);
$parser->YYData->{INPUT} =~ s/^[ \t]//g;
##
# send tokens to parser
##
for($parser->YYData->{INPUT}){
s/^([0-9]+)// and return ("NUMBER", $1);
s/^({%)// and return ("START", $1);
s/^(%})// and return ("END", $1);
s/^(\w+)// and return ("WORD", $1);
s/^(=)// and return ("=", $1);
s/^(")//␣and␣return␣("QUOTE",␣$1);
s/^(\\")//␣and␣return␣("ESCAPED_QUOTE",␣$1);
s/^(\\\\)// and return ("WORD", $1);
}
}
◇
-
Fragment referenced in 16.
The parse function is for the convenience of calling the generated parser from other code. yapp will generate a module and this will be the module’s method used by other code to execute the parser against a given input.
Notice here that we are squashing white space, both tabs and spaces, using tr. This reduces all repeated tabs and spaces to a single one. The eases further processing since extra whitespace is just ignored, according to the rules we’ve been given.
Also notice the return value from parsing. In the rules section we provide a return value, a hash reference, in the final action code block executed.
-
sub parse{
my($self, $input) =@_;
$input =~ tr/\t/ /s;
$input =~ tr/ //s;
$self->YYData->{INPUT} = $input;
my $result = $self->YYParse(yylex => \\&lexer, yyerror => \\&error);
return $result;
}
◇
-
Fragment referenced in 16.
This is really just about the most minimal error handling function there can be! All this does is print “syntax error”when the parser encounters a problem.
-
sub error{
exists $_[0]->YYData->{ERRMSG}
and do{
print $_[0]->YYData->{ERRMSG};
return;
};
print "syntax␣error\n";
}
◇
-
Fragment referenced in 16.
Sample Run
$ yapp -m Ch2 perl/ch-2.yp; mv Ch2.pm perl; perl -I. ch-2.pl {% id field1="value1" field2="value2" field3=42 %} { name => id fields => { field1 => value1 field2 => value2 field3 => 42 } } {% youtube title="Title␣\"quoted\"␣done" %} { name => youtube fields => { field1 => value1 field2 => value2 field3 => 42 title => Title } } {% youtube title="Title␣with␣escaped␣backslash␣\\" %} { name => youtube fields => { field1 => value1 field2 => value2 field3 => 42 title => Title } }
File Index
References
posted at: 23:41 by: Adam Russell | path: /perl | permanent link to this entry
2024-03-03
Count Sumofvaluacula
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Count Even Digits Number
You are given an array of positive integers, @ints. Write a script to find out how many integers have even number of digits.
The majory of the work can be done in a single line. Conveniently the tr function returns the number of characters effected by the command. For our purposes that means telling tr to delete all numerals. We then check if the number of numerals removed is even inside of a grep block. The number of matches is then returned. Note the one catch, in order to use tr we need to assign $_ to a temporary value, $x. Otherwise we would get an error Modification of a read-only value.
-
sub count_even_digits{
return 0 +
grep {
my $x = $_; $x =~ tr/[0-9]//d % 2 == 0
}@_;
}
◇
-
Fragment referenced in 2.
The rest of the code just tests this function.
-
MAIN:{
say count_even_digits 10, 1, 111, 24, 1000;
say count_even_digits 111, 1, 11111;
say count_even_digits 2, 8, 1024, 256;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 3 0 1
Part 2: Sum of Values
You are given an array of integers, @int and an integer $k. Write a script to find the sum of values whose index binary representation has exactly $k number of 1-bit set.
First, let’s concern ourselves with counting set bits. Here we can re-use some code that we’ve used before. This is a pretty standard way to count bits. This procedure is to do a bitwise AND operation for the least significant bit and check if it is set. We then right shift and repeat until no bits remain. This code is actually a modification of code used in TWC 079!
-
sub count_bits{
my($x) =@_;
my $total_count_set_bit = 0;
while($x){
my $b = $x & 1;
$total_count_set_bit++ if $b;
$x = $x >> 1;
}
return $total_count_set_bit;
}
◇
-
Fragment referenced in 7.
With that necessary work taken care of we need to loop over the given array of integers and (1) check to see if the index contains the correct number of set bits and, if that is the case, add to the rolling sum. Finally, return the sum.
-
sub sum_of_values{
my $k = shift;
my(@n) =@_;
my $sum;
do{
$sum += $_[$_] if count_bits($_) == $k;
} for 0 ..@n - 1;
return $sum;
}
◇
-
Fragment referenced in 7.
The rest of the code drives some tests.
-
MAIN:{
say sum_of_values 1, 2, 5, 9, 11, 3;
say sum_of_values 2, 2, 5, 9, 11, 3;
say sum_of_values 0, 2, 5, 9, 11, 3;
}
◇
-
Fragment referenced in 7.
Sample Run
$ perl perl/ch-2.pl 17 11 2
posted at: 16:52 by: Adam Russell | path: /perl | permanent link to this entry
2023-12-03
Sleeping Threads Reveal the Largest of Three
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given two array of languages and its popularity. Write a script to sort the language based on popularity.
Solution
use Thread;
sub sort_language{
my @language = @{$_[0]};
my @popularity = @{$_[1]};
my @threads;
do{
push @threads, Thread->new(
sub{sleep($popularity[$_]); say $language[$_]}
);
} for 0 .. @popularity - 1;
do{$_ -> join()} for @threads;
}
MAIN:{
sort_language [qw/perl c python/], [2, 1, 3];
}
Sample Run
$ perl perl/ch-1.pl
c
perl
python
Notes
This is the most ridiculous solution I could imagine for this problem!
The sorting by popularity is done by way of a Sleep Sort. Sleep Sort is
a very silly thing where you sleep for the values being sorted and
then as the sleeps finish the solution comes together.
For added fun I used Perl's threading mechanism. A convenient wrapper
for Perl's threads (which are properly called iThreads, and are
basically the same construct as, say, JavaScript's workers) is
use Thread which used to be an entirely different sort of threading
model but is now just a handy set of functions around the current model.
Be sure to read the documentation before using, for simple thread tasks
it is perfectly fine! Just be aware of any issues with data sharing
between threads, which is of no concern to us here.
For each array element of @popularity we create a new thread which is
then pushed into an array for tracking all the threads we create. Each
thread does nothing more than sleep and then print the corresponding
language. Note that we do need to administer our threads in the end by
looping over them and executing a join() to ensure they complete
properly. We could just skip that, but doing so will cause Perl to warn
us that not all threads may have properly completed, although in this
case we wouldn't necessarily care since the program has completed
executing anyway. Still, it's better to maintain the good practice of
making sure everything is cleaned up!
Sleep Sort was the subject of a previous challenge
Part 2
You are given an array of integers >= 0. Write a script to return the largest number formed by concatenating some of the given integers in any order which is also multiple of 3. Return -1 if none found.
Solution
use v5.38;
use Algorithm::Permute;
sub largest_of_three{
my @digits = @_;
my $largest = -1;
do{
my $indices = $_;
my @sub_digits = @digits[grep{vec($indices, $_, 1) == 1} 0 .. @digits - 1];
my $permutor = Algorithm::Permute->new([@sub_digits]);
while(my @permutation = $permutor->next()){
my $d = join q//, @permutation;
$largest = $d if $d > $largest && $d % 3 == 0;
}
} for 1 .. 2**@digits - 1;
return $largest;
}
MAIN:{
say largest_of_three 8, 1, 9;
say largest_of_three 8, 6, 7, 1, 0;
say largest_of_three 1;
}
Sample Run
$ perl perl/ch-2.pl
981
8760
-1
Notes
I am not sure I have a whole lot to write about this one! My approach here is to take sublists and permute each one, checking at each step for divisibility by three. This works very well for small sets of digits but I cannot think of a more scaleable solution. Suppose we are given a million digits, is it possible to make some statement on the size of the number of digits we can use to compose a number as required? I suspect this problem is hitting on deeper complexities than I considered at first.
References
posted at: 13:34 by: Adam Russell | path: /perl | permanent link to this entry
2023-11-26
Counting the Smallest Embiggens the Group Hero
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of integers. Write a script to calculate the number of integers smaller than the integer at each index.
Solution
use v5.38;
sub count_smaller{
my @integers = @_;
my @integers_sorted = sort {$a <=> $b} @integers;
return map {
my $x = $_;
(grep { $integers[$x] == $integers_sorted[$_]} 0 .. @integers_sorted - 1)[0];
} 0 .. @integers - 1;
}
MAIN:{
say join q/, /, count_smaller qw/8 1 2 2 3/;
say join q/, /, count_smaller qw/6 5 4 8/;
say join q/, /, count_smaller qw/2 2 2/;
}
Sample Run
$ perl perl/ch-1.pl
4, 0, 1, 1, 3
2, 1, 0, 3
0, 0, 0
Notes
I'll admit this is a little convoluted. Since we already have a nested
loop with the map and grep this is not any more efficient than if I
had just searched and summed the smaller elements.
The idea here is to sort the array of integers and then for each element in the original array find it's position in the sorted array. The number of elements preceding the sought after element in the sorted list are the number of elements which are smaller than it.
This approach may have a performance benefit in the case of extremely large lists coupled with early termination of the inner loop.
Part 2
You are given an array of integers representing the strength. Write a script to return the sum of the powers of all possible combinations; power is defined as the square of the largest number in a sequence, multiplied by the smallest.
Solution
use v5.38;
sub group_hero{
my @group = @_;
my $group_hero = 0;
do{
my $indices = $_;
my @hero = sort {$a <=> $b} @group[grep{vec($indices, $_, 1) == 1} 0 .. @group - 1];
$group_hero += ($hero[@hero - 1]**2 * $hero[0]);
} for 1 .. 2**@group - 1;
return $group_hero;
}
MAIN:{
say group_hero qw/2 1 4/;
}
Sample Run
$ perl perl/ch-2.pl
141
Notes
A core part of this problem is to compute the Power Set, set of all
subsets, of the original array. To do this we use the well known trick
of mapping the set bits of the numbers from 1 .. N^2, where N is the
size of the array, to the array indices.
@group[grep{vec($indices, $_, 1) == 1} 0 .. @group - 1] examines which
bit within each number $_ in 1 .. 2**@group - 1 are set and then
uses them as the indices to @group. The elements from within @group
that are found this way are then sorted to obtain the maximum and
minimum needed for the final calculation.
References
posted at: 14:30 by: Adam Russell | path: /perl | permanent link to this entry
2023-11-19
Reverse Pairs on the Floor
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of integers. Write a script to return the number of reverse pairs in the given array.
Solution
use v5.38;
sub reverse_pairs{
my @integers = @_;
my @reverse_pairs;
do{
my $i = $_;
do{
my $j = $_;
push @reverse_pairs, [$i, $j] if $integers[$i] > $integers[$j] + $integers[$j];
} for $i + 1 .. @integers - 1;
} for 0 .. @integers - 1;
return 0 + @reverse_pairs;
}
MAIN:{
say reverse_pairs 1, 3, 2, 3, 1;
say reverse_pairs 2, 4, 3, 5, 1;
}
Sample Run
$ perl perl/ch-1.pl
2
3
Notes
A reverse pair is a pair (i, j) where:
a) 0 <= i < j < nums.length
and
b) nums[i] > 2 * nums[j].
I've been on a bit of a recursion kick recently, but I didn't have the appetite for it this week. A nested loop and we're done!
Part 2
You are given an array of positive integers (>=1). Write a script to return the floor sum.
Solution
use v5.38;
use POSIX;
sub floor_sum{
my @integers = @_;
my $floor_sum;
do{
my $i = $_;
do{
my $j = $_;
$floor_sum += floor($integers[$i] / $integers[$j]);
} for 0 .. @integers - 1;
} for 0 .. @integers - 1;
return $floor_sum;
}
MAIN:{
say floor_sum 2, 5, 9;
say floor_sum 7, 7, 7, 7, 7, 7, 7;
}
Sample Run
$ perl perl/ch-2.pl
10
49
Notes
See above comment about not being as recursive this week!
References
posted at: 17:18 by: Adam Russell | path: /perl | permanent link to this entry
2023-11-11
Missing Flips
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given two arrays of integers. Write a script to find out the missing members in each other arrays.
Solution
use v5.38;
use boolean;
use Data::Dump q/pp/;
sub missing_members{
my @r;
my($a0, $a1) = @_;
my $missing0 = [];
missing_members_r([@{$a0}], [@{$a1}], $missing0);
my $missing1 = [];
missing_members_r([@{$a1}], [@{$a0}], $missing1);
push @r, $missing0 if @{$missing0} > 0;
push @r, $missing1 if @{$missing1} > 0;
return @r;
}
sub missing_members_r{
my($a0, $a1, $missing, $seen) = @_;
$seen = [] if !defined($seen);
my $x = shift @{$a0};
push @{$missing}, $x if missing_r($x, [@{$a1}]) && !seen_r($x, $seen);
push @{$seen}, $x;
missing_members_r($a0, $a1, $missing, $seen) if @{$a0} > 0;
}
sub missing_r{
my($x, $a0) = @_;
return true if @{$a0} == 0;
if(@{$a0}){
my $y = shift @{$a0};
if($x == $y){
return false;
}
}
return missing_r($x, $a0);
}
sub seen_r{
my($x, $seen) = @_;
return false if @{$seen} == 0;
my $y = shift @{$seen};
if($x == $y){
return true;
}
return seen_r($x, $seen);
}
MAIN:{
my @array1 = (1, 2, 3);
my @array2 = (2, 4, 6);
say pp missing_members \@array1, \@array2;
@array1 = (1, 2, 3, 3);
@array2 = (1, 1, 2, 2);
say pp missing_members \@array1, \@array2;
}
Sample Run
$ perl perl/ch-1.pl
([1, 3], [4, 6])
[3]
Notes
So, yeah, this could just be a nice quick use of grep, but where is the fun in that!?!?
Just looping over the arrays is not that exciting of an alternative, what other options
are there? I know, how about a whole lot of recursion! That was pretty much my thought
process here.
Really, all this code is doing is looping over the two arrays and looking for which
elements are not contained in each. The looping, such as it is, happens recursively in
missing_members_r() and missing_r(). Duplicates are possible and we avoid these, again
recursively, using seen_r() rather than, say, grep or hash keys.
Part 2
You are given n x n binary matrix. Write a script to flip the given matrix as below.
Solution
use v5.38;
use Data::Dump q/pp/;
sub flip_matrix{
return map {
my $row = $_;
[map {~$_ & 1} reverse @{$row}]
} @_;
}
MAIN:{
my @matrix = ([1, 1, 0], [1, 0, 1], [0, 0, 0]);
say pp flip_matrix @matrix;
@matrix = ([1, 1, 0, 0], [1, 0, 0, 1], [0, 1, 1, 1], [1, 0, 1, 0]);
say pp flip_matrix @matrix;
}
Sample Run
$ perl perl/ch-2.pl
([1, 0, 0], [0, 1, 0], [1, 1, 1])
([1, 1, 0, 0], [0, 1, 1, 0], [0, 0, 0, 1], [1, 0, 1, 0])
Notes
After all the recursive exitment in part 1 of this week's challenge I just went with a
quick nested map for part 2.
References
posted at: 21:43 by: Adam Russell | path: /perl | permanent link to this entry
2023-11-05
Recursive Loops and Code Re-Use
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array (3 or more members) of integers in increasing order and a positive integer. Write a script to find out the number of unique Arithmetic Triplets satisfying the given rules.
Solution
use v5.38;
sub arithmetic_triplets{
my $counter = 0;
my $difference = shift;
arithmetic_triplets_r($difference, \$counter, [@_[0 .. @_ -1]], [@_[1 .. @_ -1]], [@_[2 .. @_ -1]]);
return $counter;
}
sub arithmetic_triplets_r{
my $difference = $_[0];
my $counter = $_[1];
my @i = @{$_[2]};
my @j = @{$_[3]};
my @k = @{$_[4]};
if(@i > 0 && @j > 0 && @k > 0){
$$counter++ if $j[0] - $i[0] == $difference && $k[0] - $j[0] == $difference;
arithmetic_triplets_r($difference, $counter, [@i], [@j], [@k[1 .. @k - 1]]);
}
elsif(@i > 0 && @k == 0 && @j > 0){
arithmetic_triplets_r($difference, $counter, [@i], [@j[1 .. @j - 1]], [@j[2 .. @j - 1]]);
}
elsif(@i > 0 && @k == 0 && @j == 0){
arithmetic_triplets_r($difference, $counter, [@i[1 .. @i - 1]], [@i[2 .. @i - 1]], [@i[3 .. @i - 1]]);
}
}
MAIN:{
my $difference;
$difference = 3;
say arithmetic_triplets $difference, 0, 1, 4, 6, 7, 10;
$difference = 2;
say arithmetic_triplets $difference, 4, 5, 6, 7, 8, 9;
}
Sample Run
$ perl perl/ch-1.pl
2
2
Notes
The rules for arithmetic triples are a) i < j < k b) nums[j] - nums[i] == diff and c) nums[k] - nums[j] == diff, where diff is a provided parameter. The code above implements these rules somewhat in the obvious way, looping thricely over the list, but recursively.
Part 2
You are given an array of unique positive integers greater than 2. Write a script to sort them in ascending order of the count of their prime factors, tie-breaking by ascending value.
Solution
use v5.38;
sub prime_factor{
my $x = shift(@_);
my @factors;
for (my $y = 2; $y <= $x; $y++){
next if $x % $y;
$x /= $y;
push @factors, $y;
redo;
}
return @factors;
}
sub prime_order{
my %factor_i = map{($_, 0 + prime_factor($_))} @_;
my $factor_sorter = sub{
my $c = $factor_i{$a} <=> $factor_i{$b};
return $c unless !$c;
return $a <=> $b;
};
return sort $factor_sorter @_;
}
MAIN:{
say join q/, /, prime_order 11, 8, 27, 4;
}
Sample Run
$ perl perl/ch-2.pl
11, 4, 8, 27
Notes
This code borrows from two previous challenges: The prime factor code has been used several times, but in this case I referred to the Attractive Number challenge from TWC 041. The sorting is a variant of the frequency sort from TWC 233. If you write enough code you don't need GitHub Copilot, you can just re-use your own work!
References
posted at: 18:19 by: Adam Russell | path: /perl | permanent link to this entry
2023-10-29
ABA (Acronym Build Array)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of strings and a check string. Write a script to find out if the check string is the acronym of the words in the given array.
Solution
use v5.38;
use boolean;
sub acronym{
my($strings, $acronym) = @_;
return boolean(join(q//, map {(split //, lc $_)[0]} @{$strings}) eq lc $acronym);
}
MAIN:{
say acronym [qw/Perl Python Pascal/], q/ppp/;
say acronym [qw/Perl Raku/], q/rp/;
say acronym [qw/Oracle Awk C/], q/oac/;
}
Sample Run
$ perl perl/ch-1.pl
1
0
1
Notes
I really wracked my brain to try and come up with a simpler solution and I couldn't!
Part 2
You are given an array of integers. Write a script to create an array such that new[i] = old[old[i]] where 0 <= i < new.length.
Solution
use v5.38;
sub build_array{
push @{$_[0]}, $_[$_[@{$_[0]} + 1] + 1];
return $_[0] if @{$_[0]} == @_ - 1;
goto __SUB__;
}
MAIN:{
say join q/, /, @{build_array([], 0, 2, 1, 5, 3, 4)};
say join q/, /, @{build_array([], 5, 0, 1, 2, 3, 4)};
}
Sample Run
$ perl perl/ch-2.pl
0, 1, 2, 4, 5, 3
4, 5, 0, 1, 2, 3
Notes
First off, yes, this code is a bit obfuscated! Writing obfuscated code is not usually something I strive to do, but I was sort of forced down this road. See, what happened is that I read E. Choroba's solution on Discord despite the spoiler warnings! Now, I didn't want his solution to influence mine so I forced myself to come up with something which would be as different as possible.
build_array uses recursion to accumulate the result in the first argument, an array
reference. We use the length of the array reference as the index used to look up, and
assign elements, from the original array. The original array is present as all remaining
arguments in the subroutine call, so we'll need to adjust the indices by 1 to allow for
the array reference accumulator as the first argument. The recursion is created using
goto __SUB__ which by default retains the original array arguments. Since our
accumulator is an array reference and none of the other arguments change then we can make
use of this as a convenience. The recursion ends when the accumulated array is of the same
length as the original array, then we know that all elements have been processed.
References
posted at: 14:57 by: Adam Russell | path: /perl | permanent link to this entry
2023-10-23
Same Consistent Strings
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given two arrays of strings. Write a script to find out if the word created by concatenating the array elements is the same.
Solution
use v5.36;
use boolean;
sub same_string{
my($a1, $a2) = @_;
return boolean(join(q//, @{$a1}) eq join(q//, @{$a2}));
}
MAIN:{
say same_string [qw/ab c/], [qw/a bc/];
say same_string [qw/ab c/], [qw/ac b/];
say same_string [qw/ab cd e/], [qw/abcde/];
}
Sample Run
$ perl perl/ch-1.pl
1
0
1
Notes
I really wracked my brain to try and come up with a simpler solution and I couldn't!
Part 2
You are given an array of strings and allowed string having distinct characters. A string is consistent if all characters in the string appear in the string allowed. Write a script to return the number of consistent strings in the given array.
Solution
use v5.36;
sub is_consistent{
my($s, $allowed) = @_;
$s =~ s/[$allowed]//g;
return $s eq q//;
}
sub consistent_strings{
my($strings, $allowed) = @_;
my @consistent = grep { is_consistent $_, $allowed } @{$strings};
return 0 + @consistent;
}
MAIN:{
say consistent_strings [qw/ad bd aaab baa badab/], q/ab/;
say consistent_strings [qw/a b c ab ac bc abc/], q/abc/;
say consistent_strings [qw/cc acd b ba bac bad ac d/], q/cad/;
}
Sample Run
$ perl perl/ch-2.pl
2
7
4
Notes
To check if a string is consistent using the given definition, all the allowed
characters are removed from the given string. If the result is the empty string then we
know the string meets the requirements. Here this is broken out to the is_consistent
function. That in turn is called from within a grep which checks the entire list of
strings.
References
posted at: 00:24 by: Adam Russell | path: /perl | permanent link to this entry
2023-10-01
Exact Array Loops
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are asked to sell juice each costs $5. You are given an array of bills. You can only sell ONE juice to each customer but make sure you return exact change back. You only have $5, $10 and $20 notes. You do not have any change in hand at first. Write a script to find out if it is possible to sell to each customers with correct change.
Solution
use v5.38;
use boolean;
use constant COST_JUICE => 5;
sub exact_change{
my @bank;
my $current_customer = shift;
{
push @bank, $current_customer if $current_customer == COST_JUICE;
if($current_customer > COST_JUICE){
my $change_due = $current_customer - COST_JUICE;
my @bank_sorted = sort {$a <=> $b} @bank;
my @bank_reserved;
{
my $bill = pop @bank_sorted;
push @bank_reserved, $bill if $change_due < $bill;
$change_due -= $bill if $change_due >= $bill;
redo if @bank_sorted;
}
return false if $change_due != 0;
@bank = @bank_reserved;
push @bank, $current_customer;
}
$current_customer = shift;
redo if $current_customer;
}
return true;
}
MAIN:{
say exact_change 5, 5, 5, 10, 20;
say exact_change 5, 5, 10, 10, 20;
say exact_change 5, 5, 5, 20;
}
Sample Run
$ perl perl/ch-1.pl
1
0
1
Notes
Making change is easy as long as we preferentially use larger bills first. To do so all we
need to do is sort any accumulated payments and then pop off the change as required by
the current transaction, if possible.
Part 2
You are given an array of unique integers. Write a script to determine how many loops are in the given array. To determine a loop: Start at an index and take the number at array[index] and then proceed to that index and continue this until you end up at the starting index.
Solution
use v5.38;
use boolean;
sub loop_counter{
my @integers = @_;
my @loops;
do{
my @loop;
my $loop_found = false;
my $start = $_;
my $next = $integers[$start];
push @loop, $start, $next;
my $counter = 1;
{
if($next == $start){
shift @loop;
if(@loops == 0 || @loop == 2){
push @loops, \@loop;
my @loop;
$loop_found = true;
}
else{
my $loop_duplicate = false;
my @s0 = sort @loop;
do {
my @s1 = sort @{$_};
$loop_duplicate = true if((@s0 == @s1) && (0 < grep {$s0[$_] == $s1[$_]} 0 .. @s0 - 1));
} for @loops;
if(!$loop_duplicate){
$loop_found = true;
push @loops, \@loop;
}
else{
$counter = @integers + 1;
}
}
}
else{
$next = $integers[$next];
push @loop, $next;
$counter++;
}
redo unless $loop_found || $counter > @integers;
}
} for 0 .. @integers - 1;
return @loops + 0;
}
MAIN:{
say loop_counter 4, 6, 3, 8, 15, 0, 13, 18, 7, 16, 14, 19, 17, 5, 11, 1, 12, 2, 9, 10;
say loop_counter 0, 1, 13, 7, 6, 8, 10, 11, 2, 14, 16, 4, 12, 9, 17, 5, 3, 18, 15, 19;
say loop_counter 9, 8, 3, 11, 5, 7, 13, 19, 12, 4, 14, 10, 18, 2, 16, 1, 0, 15, 6, 17;
}
Sample Run
$ perl perl/ch-2.pl
3
6
1
Notes
When I first approached this problem I didn't appreciate that many loops are just cycles of each other. In those cases we need to identify if such cyclical duplicates exit. Much of the code here, then, is for examining such cases. The detection is done by comparing each loop to the existing loops, in sorted order. if there are any equivalents we know we have a duplicate.
The line shift @loop; is to remove to starting point, which is convenient to maintain up
until storing in the @loops array.
References
posted at: 17:54 by: Adam Russell | path: /perl | permanent link to this entry
2023-09-07
What's the Similar Frequency, Kenneth?
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of words made up of alphabets only. Write a script to find the number of pairs of similar words. Two words are similar if they consist of the same characters.
Solution
use v5.38;
use boolean;
sub is_similar{
my($s0, $s1) = @_;
my(%h0, %h1);
do { $h0{$_} = undef } for split //, $s0;
do { $h1{$_} = undef } for split //, $s1;
return false if keys %h0 != keys %h1;
do { return false if !exists $h1{$_} } for keys %h0;
return true;
}
sub similar_words_pairs_count{
my @words = @_;
my @similar;
do{
my $word_index = $_;
my @similar_temp = grep { $words[$word_index] ne $words[$_] &&
is_similar $words[$word_index], $words[$_] } $word_index + 1 .. @words - 1;
push @similar, @words[@similar_temp] if @similar_temp > 0;
} for 0 .. @words - 1;
return @similar + 0;
}
MAIN:{
say similar_words_pairs_count qw/aba aabb abcd bac aabc/;
say similar_words_pairs_count qw/aabb ab ba/;
say similar_words_pairs_count qw/nba cba dba/;
}
Sample Run
$ perl perl/ch-1.pl
2
3
0
Notes
The core of this problem is to count up the number of pairs of similar words. A clearly
good use of grep, but how to do that exactly? Well, here we define a subroutine
is_similar that returns a true/false value depending on if the words meet the definition
of similar given in the problem. That's done by expanding the words into arrays of
characters, stuffing those characters into hash key slots in order to force uniqueness,
and then seeing if the two key sets are equal.
Once we have the logic to determine similarity worked out we can then use it in grep and
count up the results.
Part 2
You are given an array of integers. Write a script to sort the given array in increasing order based on the frequency of the values. If multiple values have the same frequency then sort them in decreasing order.
Solution
use v5.38;
sub frequency_sort{
my(@numbers) = @_;
my %frequency;
do{$frequency{$_}++} for @numbers;
my $frequency_sorter = sub{
my $c = $frequency{$a} <=> $frequency{$b};
return $c unless !$c;
return $b <=> $a;
};
return sort $frequency_sorter @numbers;
}
MAIN:{
say join q/, /, frequency_sort 1, 1, 2, 2, 2, 3;
say join q/, /, frequency_sort 2, 3, 1, 3, 2;
say join q/, /, frequency_sort -1, 1, -6, 4, 5, -6, 1, 4, 1
}
Sample Run
$ perl perl/ch-2.pl
3, 1, 1, 2, 2, 2
1, 3, 3, 2, 2
5, -1, 4, 4, -6, -6, 1, 1, 1
Notes
This problem ended up being a bit more complex than it seemed after the first reading.
Perl makes this sort of complexity easy to manage though! sort can take a custom sorting
subroutine as an argument. That is what is done here, with the requirements of the
frequency sort for this problem implemented within the subroutine referenced by
$frequency_sorter. This is written as an anonymous subroutine in order to obtain a
closure around %frequency. Finally, observe that we can use the scalar reference
directly with sort. sort is flexible enough to know how to use the reference.
References
posted at: 17:08 by: Adam Russell | path: /perl | permanent link to this entry
2023-08-21
Not the MinMax Count
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of distinct integers. Write a script to find all elements that is neither minimum nor maximum. Return -1 if you can’t.
Solution
use v5.38;
sub not_min_max{
my($minimum, $maximum);
do{
$minimum = $_ if !$minimum || $_ < $minimum;
$maximum = $_ if !$maximum || $_ > $maximum;
} for @_;
my @r = grep { $_ ^ $minimum && $_ ^ $maximum } @_;
return @r ^ 0 ? @r : -1;
}
MAIN:{
say join q/, /, not_min_max 3, 2, 1, 4;
say join q/, /, not_min_max 3, 1;
say join q/, /, not_min_max 2, 1, 3;
}
Sample Run
$ perl perl/ch-1.pl
3, 2
-1
2
Notes
Once we find the maximum and minimum values, we need to remove them. Just to be different
I used the XOR ^ operator instead of !=. The effect is the same, a false (zero) value
is returned if the values are identical, true (one) otherwise.
Part 2
You are given a list of passenger details in the form “9999999999A1122”, where 9 denotes the phone number, A the sex, 1 the age and 2 the seat number. Write a script to return the count of all senior citizens (age >= 60).
Solution
use v5.38;
sub count_senior_citizens{
my $count = 0;
do{
my @a = unpack q/A10A1A2A2/, $_;
$count++ if $a[2] >= 60;
} for @_;
return $count;
}
MAIN:{
say count_senior_citizens qw/7868190130M7522 5303914400F9211 9273338290F4010/;
say count_senior_citizens qw/1313579440F2036 2921522980M5644/;
}
Sample Run
$ perl perl/ch-2.pl
2
0
Notes
It isn't all that often you find a nice clean use of unpack! This seems to be a very
nice opportunity: each passenger string has fixed field lengths.
The passenger strings themselves are just Perl scalar values. They are not, say, specially
constructed strings via pack. To unpack an ordinary scalar we can just use As in the
template string.
References
posted at: 20:27 by: Adam Russell | path: /perl | permanent link to this entry
2023-08-20
Separate and Count
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of positive integers. Write a script to separate the given array into single digits.
Solution
use v5.38;
sub separate_digits{
return separater([], @_);
}
sub separater{
my $seperated = shift;
return @{$seperated} if @_ == 0;
my @digits = @_;
push @{$seperated}, split //, shift @digits;
separater($seperated, @digits);
}
MAIN:{
say join q/,/, separate_digits 1, 34, 5, 6;
}
Sample Run
$ perl perl/ch-1.pl
1,3,4,5,6
Notes
It has been a while since I wrote recursive Perl code, this week's TWC offered two nice
chances to do so. The first call to separate_digits invokes the call to the recursive
subroutine separater, adding an array reference for the convenience of accumulating the
individual digits at each recursive step.
Within separater each number in the array is taken one at a time and expanded to its
individual digits. The digits are pushed into the accumulator. When we run of digits we
return the complete list of digits.
Part 2
You are given an array of words made up of alphabetic characters and a prefix. Write a script to return the count of words that starts with the given prefix.
Solution
use v5.38;
sub count_words{
return counter(0, @_);
}
sub counter{
my $count = shift;
my $prefix = shift;
return $count if @_ == 0;
my $word = shift;
$count++ if $word =~ m/^$prefix/;
counter($count, $prefix, @_);
}
MAIN:{
say count_words qw/at pay attention practice attend/;
say count_words qw/ja janet julia java javascript/;
}
Sample Run
$ perl perl/ch-2.pl
2
3
Notes
The exact same approach used for Part 1 is used here in the second part. Instead of accumulating am array of digits instead we increment the counter of words which start with the prefix characters.
References
posted at: 21:40 by: Adam Russell | path: /perl | permanent link to this entry
2023-07-23
Shuffled Operations
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a string and an array of indices of same length as string. Write a script to return the string after re-arranging the indices in the correct order.
Solution
use v5.38;
sub shuffle_string{
my($s, $indices) = @_;
my @s = split(//, $s);
my @t;
do { $t[$_] = shift @s } for @{$indices};
return join(q//, @t);
}
MAIN:{
say shuffle_string(q/lacelengh/, [3, 2, 0, 5, 4, 8, 6, 7, 1]);
say shuffle_string(q/rulepark/, [4, 7, 3, 1, 0, 5, 2, 6]);
}
Sample Run
$ perl perl/ch-1.pl
challenge
perlraku
Notes
I had to think of this one a bit! What we need to do is take each letter, from left to
right, and assign it a new position. It's not often you see a shift within another loop
but here that is the key to getting everything working.
Part 2
You are given an array of non-negative integers, @ints. Write a script to return the minimum number of operations to make every element equal zero.
Solution
use v5.38;
sub zero_array{
my $operations = 0;
do{
return $operations if 0 == unpack(q/%32I*/, pack(q/I*/, @_));
my $minimum = (sort { $a <=> $b } grep { $_ > 0 } @_)[0];
@_ = map { $_ > 0 ? $_ - $minimum : 0 } @_;
$operations++;
} for @_;
}
MAIN:{
say zero_array 1, 5, 0, 3, 5;
say zero_array 0;
say zero_array 2, 1, 4, 0, 3
}
Sample Run
$ perl perl/ch-2.pl
3
0
4
Notes
Usually I assign function arguments new names, even if I am just passing in a single array
of values like in this example. I decided this time to not do it, I don't think
readability is sacrificed. Provided the reader actually knows what @_ is I think for a
short function such as this it's fine. In fact, I think an argument could be made that
readability is actually enhanced since lines such as the one with both a sort and a
grep are kept to a shorter length.
References
posted at: 20:55 by: Adam Russell | path: /perl | permanent link to this entry
2023-07-13
Sentenced To Compute Differences
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a list of sentences. Write a script to find out the maximum number of words that appear in a single sentence.
Solution
use v5.38;
sub max_sentence_length{
my(@sentences) = @_;
my $max_words = -1;
do{
my @word_matches = $_ =~ m/(\w+)/g;
$max_words = @word_matches if @word_matches > $max_words;
} for @sentences;
return $max_words;
}
MAIN:{
my @list;
@list = ("Perl and Raku belong to the same family.", "I love Perl.",
"The Perl and Raku Conference.");
say max_sentence_length(@list);
@list = ("The Weekly Challenge.", "Python is the most popular guest language.",
"Team PWC has over 300 members.");
say max_sentence_length(@list);
}
Sample Run
$ perl perl/ch-1.pl
8
7
Notes
This is the perfect job for a regular expression! In fact \w is a special character
sequence which matches word characters, so they heart of the solution is to apply it
to the given sentences and count the matches.
The expression my @word_matches = $_ =~ m/(\w+)/g may look a little weird at first. What
is happening here is that we are collecting all groups of matchs (enclosed in parentheses
in the regex) into a single array. In this way, we immediately know the number of words
in each sentence, it is just the size of the array.
Part 2
You are given an array of integers. Write a script to return left right sum difference array.
Solution
use v5.38;
sub left_right_sum{
return unpack("%32I*", pack("I*", @_));
}
sub left_right_differences{
my(@left_sum, @right_sum);
for(my $i = 0; $i < @_; $i++){
push @left_sum, left_right_sum(@_[0 .. $i - 1]);
push @right_sum, left_right_sum(@_[$i + 1 .. @_ - 1]);
}
return map { abs($left_sum[$_] - $right_sum[$_]) } 0 .. @_ - 1;
}
MAIN:{
say join(q/, /, left_right_differences 10, 4, 8, 3);
say join(q/, /, left_right_differences 1);
say join(q/, /, left_right_differences 1, 2, 3, 4, 5);
}
Sample Run
$ perl perl/ch-2.pl
15, 1, 11, 22
0
14, 11, 6, 1, 10
Notes
The problem statement may be a little confusing at first. What we are trying to do here is to get two lists the prefix sums and suffix sums, also called the left and right sums. We then pairwise take the absolute values of each element in these lists to get the final result. Iterating over the list the prefix sums are the partial sums of the list elements to the left of the current element. The suffix sums are the partial sums of the list elements to the right of the current element.
With that understanding in hand the solution becomes much more clear! We iterate over the
list and then using slices get the prefix and suffix arrays for each element. Using my
favorite way to sum a list of numbers, left_right_sum() does the job with pack/unpack.
Finally, a map computes the set of differences.
References
posted at: 17:17 by: Adam Russell | path: /perl | permanent link to this entry
2023-02-05
Into the Odd Wide Valley
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of integers. Write a script to print 1 if there are THREE consecutive odds in the given array otherwise print 0.
Solution
use v5.36;
use boolean;
sub three_consecutive_odds{
my @numbers = @_;
my $consecutive_odds = 0;
{
my $x = pop @numbers;
$consecutive_odds++ if 1 == ($x & 1);
$consecutive_odds = 0 if 0 == ($x & 1);
return true if 3 == $consecutive_odds;
redo if @numbers;
}
return false;
}
MAIN:{
say three_consecutive_odds(1, 5, 3, 6);
say three_consecutive_odds(2, 6, 3, 5);
say three_consecutive_odds(1, 2, 3, 4);
say three_consecutive_odds(2, 3, 5, 7);
}
Sample Run
$ perl perl/ch-1.pl
1
0
0
1
Notes
Part 2
Given a profile as a list of altitudes, return the leftmost widest valley. A valley is defined as a subarray of the profile consisting of two parts: the first part is non-increasing and the second part is non-decreasing. Either part can be empty.
Solution
use v5.36;
use boolean;
use FSA::Rules;
sub widest_valley_rules{
my @altitudes = @_;
my @downslope;
my @upslope;
my $fsa = FSA::Rules->new(
move => {
do => sub{ my $state = shift;
$state->machine->{altitude} = [] if(!$state->machine->{altitude});
$state->machine->{plateau} = [] if(!$state->machine->{plateau});
$state->machine->{downslope} = [] if(!$state->machine->{downslope});
$state->machine->{upslope} = [] if(!$state->machine->{upslope});
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
move => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
@{$previous_altitudes} == 1;
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}else{false}
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
],
},
plateau => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, @{$state->machine->{plateau}};
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
$state->machine->{plateau} = [];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, @{$state->machine->{plateau}};
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
$state->machine->{plateau} = [];
}
}
],
},
downslope => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
#pop @{$state->machine->{downslope}};true;
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
$state->machine->{upslope} = [];
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
],
},
upslope => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
$previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2];
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
],
},
done => {
do => sub { my $state = shift;
say q/Valley: / . join(q/, /, @{$state->machine->{downslope}}, @{$state->machine->{upslope}});
}
},
);
return $fsa;
}
sub widest_valley{
my $rules = widest_valley_rules(@_);
$rules->start;
$rules->switch until $rules->at(q/done/);
my $graph_viz = $rules->graph();
}
MAIN:{
widest_valley 1, 5, 5, 2, 8;
widest_valley 2, 6, 8, 5;
widest_valley 2, 1, 2, 1, 3;
}
Sample Run
$ perl perl/ch-2.pl
Valley: 5, 5, 2, 8
Valley: 2, 6, 8
Valley: 2, 1, 2
Notes
References
posted at: 18:39 by: Adam Russell | path: /perl | permanent link to this entry