RabbitFarm

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:

  1. $i≠$j
  2. 0 $i < size @ints and 0 $j < size @ints
  3. $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!

nested loop to determine if the conditions hold 1 ⟩≡


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.

"ch-1.pl" 2


preamble 3
nested loop to determine if the conditions hold 1
main 4

preamble 3 ⟩≡


use v5.40;

Fragment referenced in 2, 7.

main 4 ⟩≡


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.

loop and evaluate the check sum 5 ⟩≡


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.

sum digits for numbers > 10 6 ⟩≡


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.

"ch-2.pl" 7


preamble 3
sum digits for numbers > 10 6
loop and evaluate the check sum 5
main 8

main 8 ⟩≡


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

The Weekly Challenge 290
Generated Code

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.

sort and return the third largest (or just the largest) 1 ⟩≡


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.

"ch-1.pl" 2


preamble 3
sort and return the third largest (or just the largest) 1
main 4

preamble 3 ⟩≡


use v5.40;

Fragment referenced in 2, 9.

main 4 ⟩≡


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:

  1. The first and last letter of every word must stay the same.
  2. The remaining letters in the word are scrambled in a random order (if that happens to be the original order, that is OK).
  3. Whitespace, punctuation, and capitalization must stay the same.
  4. 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.

strip punctuation 5 ⟩≡


my $stripped = [];
my $punctuation = [];
do{
$punctuation->[$_] = $w->[$_] if $w->[$_] =~ m/[[:punct:]]/;
push @{$stripped}, $w->[$_] if $w->[$_] !~ m/[[:punct:]]/;
} for 0 .. @{$w} - 1;

Fragment referenced in 8.

Defines: $punctuation 7, $stripped 6, 7.

Uses: $w 8.

Now that we have the punctuation accounted for let’s do the jumble. We’ll do this by generating permutations and randomly select one.

permutate the letters 6 ⟩≡


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};

Fragment referenced in 8.

Uses: $stripped 5.

Finally, add the punctuation back in.

add punctuation back 7 ⟩≡


do{
substr $stripped, $_, 0, $punctuation->[$_]
if $punctuation->[$_];
} for 0 .. @{$punctuation} - 1;
$stripped . q/ /;

Fragment referenced in 8.

Uses: $punctuation 5, $stripped 5.

jumble the list of words 8 ⟩≡


sub jumble{
return map {
my $w = [split //, $_];
strip punctuation 5
permutate the letters 6
add punctuation back 7
} @_;
}

Fragment referenced in 9.

Defines: $w 5.

The rest of the code drives some tests.

"ch-2.pl" 9


preamble 3
use Algorithm::Permute;
jumble the list of words 8
main 10

main 10 ⟩≡


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

The Weekly Challenge 289
Generated Code

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

"ch-1.pl" Defined by 1.

"ch-2.pl" Defined by 5.

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.

"ch-1.pl" 1


preamble 2
good integer? if so, return it, else return -1 3
main 4

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.

preamble 2 ⟩≡


use v5.38;

Fragment referenced in 1, 5.

A good integer is exactly three consecutive matching digits.

good integer? if so, return it, else return -1 3 ⟩≡


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 4 ⟩≡


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.

"ch-2.pl" 5


preamble 2
count the number of key changes 6
main 7

count the number of key changes 6 ⟩≡


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 7 ⟩≡


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

The Weekly Challenge 282
Generated Code

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

"ch-1.pl" Defined by 1.

"ch-2.pl" Defined by 6.

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.

"ch-1.pl" 1


preamble 2
check the color of a given square 3
main 5

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.

preamble 2 ⟩≡


use v5.38;

Fragment referenced in 1, 6.

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.

check the color of a given square 3 ⟩≡


sub check_color{
my($s) = @_;
my $a = [split //, $s];
convert co-ordinates to a number 4
return q/true/ if $color_number < 0;
return q/false/;
}

Fragment referenced in 1.

Defines: $a 4.

Uses: $color_number 4.

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.

convert co-ordinates to a number 4 ⟩≡


my $n = (-1) ** (ord($a->[0]) - ord(q/‘/));
my $color_number = $n * ((-1) ** join q//, @{$a}[1 .. @{$a} - 1]);

Fragment referenced in 3.

Defines: $color_number 3, $n Never used.

Uses: $a 3.

Now all we need are a few lines of code for running some tests.

main 5 ⟩≡


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.

"ch-2.pl" 6


preamble 2
use Graph;
build knight’s graph 7
shortest path a knight needs to traverse from $start to $end 9
main 10

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.

build knight’s graph 7 ⟩≡


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);
add edge if legal move 8
$t = chr(ord(qq/$c/) + 1);
add edge if legal move 8
##
# down
##
$s = $r - 2;
$t = chr(ord(qq/$c/) - 1);
add edge if legal move 8
$t = chr(ord(qq/$c/) + 1);
add edge if legal move 8
##
# left
##
$s = $r - 1;
$t = chr(ord(qq/$c/) - 2);
add edge if legal move 8
$s = $r + 1;
add edge if legal move 8
##
# right
##
$s = $r - 1;
$t = chr(ord(qq/$c/) + 2);
add edge if legal move 8
$s = $r + 1;
add edge if legal move 8
} for 1 .. 8;
} for q/a/ .. q/h/;
return $graph;
}

Fragment referenced in 6.

Defines: $c Never used, $graph 8, 9, 10, $r 8.

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.

add edge if legal move 8 ⟩≡


$graph->add_edge(qq/$c$r/, qq/$t$s/) if $s >= 1 &&
$s <= 8 &&
$t =~ m/[a-h]/;

Fragment referenced in 7.

Uses: $graph 7, $r 7.

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.

shortest path a knight needs to traverse from $start to $end 9 ⟩≡


sub shortest_knight_path{
my($graph, $start, $end) = @_;
my @path = $graph->SP_Dijkstra($start, $end);
say qq/$start ---> $end/;
print @path - 1 . q/: /;
say join q/ -> /, @path;
}

Fragment referenced in 6.

Uses: $graph 7.

Finally, here’s a few tests to confirm everything is working right.

main 10 ⟩≡


MAIN:{
my $graph = build_graph;
shortest_knight_path($graph, q/g2/, q/a8/);
shortest_knight_path($graph, q/g2/, q/h2/);
}

Fragment referenced in 6.

Uses: $graph 7.

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

"ch-1.pl" Defined by 1.

"ch-2.pl" Defined by 5.

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.

"ch-1.pl" 1


preamble 2
twice appearance 3
main 4

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.

preamble 2 ⟩≡


use v5.38;

Fragment referenced in 1, 5.

twice appearance 3 ⟩≡


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 4 ⟩≡


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.

"ch-2.pl" 5


preamble 2
count asterisks 6
main 7

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.

count asterisks 6 ⟩≡


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 7 ⟩≡


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

The Weekly Challenge 280
Generated Code

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

"ch-1.pl" Defined by 1.

"ch-2.pl" Defined by 5.

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.

"ch-1.pl" 1


preamble 2
defang recursively 3
main 4

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.

preamble 2 ⟩≡


use v5.38;

Fragment referenced in 1, 5.

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!

defang recursively 3 ⟩≡


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: $defanged Never used.

Now all we need are a few lines of code for running some tests.

main 4 ⟩≡


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.

"ch-2.pl" 5


preamble 2
string score 6
main 7

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.

string score 6 ⟩≡


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 7 ⟩≡


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

The Weekly Challenge 272
Generated Code

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

"ch-1.pl" Defined by 1.

"ch-2.pl" Defined by 7.

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.

"ch-1.pl" 1


preamble 2
element digit sum 5
main 6

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.

preamble 2 ⟩≡


use v5.38;

Fragment referenced in 1, 7.

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.

compute digit sum 3 ⟩≡


my $digit_sum = unpack(q/%32I*/, pack(
q/I*/, map {split //, $_} @{$integers})
);

Fragment referenced in 5.

Defines: $digit_sum 5.

Uses: $integers 5.

The element sum is the same procedure as the digit sum, but just without the map.

compute element sum 4 ⟩≡


my $element_sum = unpack(q/%32I*/, pack q/I*/, @{$integers});

Fragment referenced in 5.

Defines: $element_sum 5.

Uses: $integers 5.

element digit sum 5 ⟩≡


sub element_digit_sum{
my($integers) = [@_];
compute digit sum 3
compute element sum 4
return abs($element_sum - $digit_sum)
}

Fragment referenced in 1.

Defines: $integers 3, 4.

Uses: $digit_sum 3, $element_sum 4.

Finally, we have a few lines of code for running some tests.

main 6 ⟩≡


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.

"ch-2.pl" 7


preamble 2
search and multiply 8
main 9

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.

search and multiply 8 ⟩≡


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 9 ⟩≡


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

The Weekly Challenge 261
Generated Code

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

"ch-1.pl" Defined by 1.

"ch-2.pl" Defined by 5.

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.

"ch-1.pl" 1


preamble 2
unique occurrences 3
main 4

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.

preamble 2 ⟩≡


use v5.38;
use boolean;

Fragment referenced in 1, 5.

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.

unique occurrences 3 ⟩≡


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 4 ⟩≡


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.

"ch-2.pl" 5


preamble 2
Compute all valid permutations with Heap’s algorithm. 6
Determine the dictionary rank. 7
main 8

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.

Compute all valid permutations with Heap’s algorithm. 6 ⟩≡


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.

Determine the dictionary rank. 7 ⟩≡


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 8 ⟩≡


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

The Weekly Challenge 260
Generated Code
Heap’s Algorithm

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.

count days 1 ⟩≡


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.

The day is a weekend. 2 ⟩≡


$t->wday >= 6

Fragment referenced in 1.

The day is a bank holiday. 3 ⟩≡


1 == grep {$t->strftime(q/%Y-%m-%d/) eq $_} @{$holidays}

Fragment referenced in 1.

The rest of the code just tests this function.

"perl/ch-1.pl" 4


preamble 5
count days 1
main 6

preamble 5 ⟩≡


use v5.38;
use Time::Piece;
use Time::Seconds;

Fragment referenced in 4.

main 6 ⟩≡


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="Titlewithescapedbackslash\\" %}
    

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.

print the parser results 7 ⟩≡


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.

"perl/ch-2.pl" 8


preamble 9
print the parser results 7
main 10

preamble 9 ⟩≡


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 10 ⟩≡


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.

header 11 ⟩≡


%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.

rules 12 ⟩≡


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.

lexer 13 ⟩≡


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.

parse function 14 ⟩≡


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.

error handler 15 ⟩≡


sub error{
exists $_[0]->YYData->{ERRMSG}
and do{
print $_[0]->YYData->{ERRMSG};
return;
};
print "syntax␣error\n";
}

Fragment referenced in 16.

footer 16 ⟩≡


lexer 13
error handler 15
parse function 14

Fragment referenced in 17.

"perl/ch-2.yp" 17


header 11
%%
rules 12
%%
footer 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="Titlewithescapedbackslash\\" %} 
{ 
        name => youtube 
        fields => { 
                field1 =>  value1 
                field2 =>  value2 
                field3 =>  42 
                title =>  Title 
        } 
}
    

File Index

"perl/ch-1.pl" Defined by 4.

"perl/ch-2.pl" Defined by 8.

"perl/ch-2.yp" Defined by 17.

References

The Weekly Challenge 259
Generated Code

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.

count even digits 1 ⟩≡


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.

"perl/ch-1.pl" 2


preamble 3
count even digits 1
main 4

preamble 3 ⟩≡


use v5.38;

Fragment referenced in 2, 7.

main 4 ⟩≡


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!

count set bits 5 ⟩≡


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.

sum of value 6 ⟩≡


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.

"perl/ch-2.pl" 7


preamble 3
count set bits 5
sum of value 6
main 8

main 8 ⟩≡


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

Thread

Sleep Sort

Challenge 245

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

Power Set

Challenge 244

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

Challenge 243

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

Challenge 242

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

Challenge 241

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

Challenge 240

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

Challenge 239

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

Challenge 236

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

Challenge 233

What's the Frequency, Kenneth?

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

pack/unpack Templates

Challenge 231

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

Challenge 230

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

Challenge 226

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

Challenge 225

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

Challenge 202

posted at: 18:39 by: Adam Russell | path: /perl | permanent link to this entry

2023-01-29

How Many Missing Coins?

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given an array of unique numbers. Write a script to find out all missing numbers in the range 0..$n where $n is the array size.

Solution


use v5.36;
use boolean;
sub missing_numbers{
    my @numbers = @_;
    my %h;
    do { $h{$_} = undef } for @numbers;
    my @missing = grep { !exists($h{$_}) } 0 .. @numbers;
    return @missing;
}

MAIN:{
    say q/(/ . join(q/, /, missing_numbers(0, 1, 3)) . q/)/;
    say q/(/ . join(q/, /, missing_numbers(0, 1)) . q/)/;
    say q/(/ . join(q/, /, missing_numbers(0, 1, 2, 2)) . q/)/;
}

Sample Run


$ perl perl/ch-1.pl 
(2)
(2)
(3, 4)

Notes

This problem was a nice refresh on exists, which is often confused with defined. Here we want to see if the hash key exists at all and so the use is appropriate. If we had wanted to see if the value keyed was defined, well, that is the use for defined!

Part 2

You are given an integer, $n > 0. Write a script to determine the number of ways of putting $n pennies in a row of piles of ascending heights from left to right.

Solution


use v5.36;
use AI::Prolog;
use Hash::MultiKey;

MAIN:{
    my $S = $ARGV[0];
    my $C = "[" . $ARGV[1] . "]";

    my $prolog = do{
        local $/;
        <DATA>;
    }; 
    $prolog =~ s/_COINS_/$C/g;
    $prolog =~ s/_SUM_/$S/g;
    $prolog = AI::Prolog->new($prolog); 
    $prolog->query("sum(Coins).");
    my %h;
    tie %h, "Hash::MultiKey";
    while(my $result = $prolog->results){
        my @s = sort @{$result->[1]};
        $h{\@s} = undef;
    }
    for my $k ( sort { @{$b} <=> @{$a} } keys %h){
        print "(" . join(",", @{$k}) . ")";
        print "\n";
    }
}

__DATA__
member(X,[X|_]).
member(X,[_|T]) :- member(X,T).

coins(_COINS_).

sum(Coins):-
    sum([], Coins, 0).

sum(Coins, Coins, _SUM_). 

sum(Partial, Coins, Sum):-   
    Sum < _SUM_, 
    coins(L),
    member(X,L),
    S is Sum + X,
    sum([X | Partial], Coins, S). 

Sample Run


$ perl perl/ch-2.pl 5 1,2,3,4,5
(1,1,1,1,1)
(1,1,1,2)
(1,2,2)
(1,1,3)
(1,4)
(2,3)
(5)

Notes

The approach here is the same that I used for the Coins Sum problem from TWC 075. The only change is the added sort by the length of the "piles".

References

Challenge 201

posted at: 18:30 by: Adam Russell | path: /perl | permanent link to this entry

2023-01-15

Multiple Goods

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a list of integers, @list. Write a script to find the total count of Good airs.

Solution


use v5.36;
sub good_pairs{
    my(@numbers) = @_;
    my @pairs;  
    do{ 
        my $i = $_;
        do{
            my $j = $_;
            push @pairs, [$i, $j] if $numbers[$i] == $numbers[$j] && $i < $j;  
        } for 0 .. @numbers - 1;
    } for 0 .. @numbers - 1;
    return 0 + @pairs;  
}

MAIN:{
    say good_pairs 1, 2, 3, 1, 1, 3;
    say good_pairs 1, 2, 3;
    say good_pairs 1, 1, 1, 1;
}

Sample Run


$ perl perl/ch-1.pl 
4
0
6

Notes

First off, a pair (i, j) is called good if list[i] == list[j] and i < j. Secondly, I have never written a nested loop with this mix of do blocks and postfix for, and I am greatly entertained by it! Perl fans will know that it really isn't all that different from the more standard looking do/while construct. A do block is not really a loop, although it can be repeated, and so you cannot use last, redo, or next within the block. But this is exactly the same case as within a map, which is what we are trying to replicate here, a map in void context without actually using map.

Imagine a nested map, that is basically the same thing as this, but with the more clear focus on side effects versus a return value.

Part 2

You are given an array of integers, @array and three integers $x,$y,$z. Write a script to find out total Good Triplets in the given array.

Solution


use v5.36;
use Math::Combinatorics;
sub good_triplets{
    my($numbers, $x, $y, $z) = @_;
    my $combinations = Math::Combinatorics->new(count => 3, data => [0 .. @{$numbers} - 1]);
    my @combination = $combinations->next_combination;  
    my @good_triplets;
    {
        my($s, $t, $u) = @combination;
        unless($s >= $t || $t >= $u || $s >= $u){
            push @good_triplets, [@{$numbers}[$s, $t, $u]] if(abs($numbers->[$s] - $numbers->[$t]) <= $x && 
                                                              abs($numbers->[$t] - $numbers->[$u]) <= $y &&  
                                                              abs($numbers->[$s] - $numbers->[$u]) <= $z);  

    }
        @combination = $combinations->next_combination;  
        redo if @combination;
    }
    return 0 + @good_triplets;
}

MAIN:{
    say good_triplets([3, 0, 1, 1, 9, 7], 7, 2, 3);
    say good_triplets([1, 1, 2, 2, 3], 0, 0, 1);
}

Sample Run


$ perl perl/ch-2.pl
4
0

Notes

The approach here is the same that I used for the Magical Triples problem from TWC 187. The module Math::Combinatorics is used to generate all possible triples of indices. These are then filtered according to the criteria for good triplets.

References

Challenge 199

posted at: 11:22 by: Adam Russell | path: /perl | permanent link to this entry

2023-01-08

Prime the Gaps!

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a list of integers, @list. Write a script to find the total pairs in the sorted list where 2 consecutive elements has the max gap. If the list contains less then 2 elements then return 0.

Solution


use v5.36;
sub largest_gap{
    my(@numbers) = @_;
    my $gap = -1;
    map{ $gap = $numbers[$_] - $numbers[$_ - 1] if $numbers[$_] - $numbers[$_ - 1] > $gap } 1 .. @numbers - 1;  
    return $gap;
}

sub gap_pairs{
    my(@numbers) = @_;
    return 0 if @numbers < 2; 
    my $gap = largest_gap(@numbers);
    my $gap_count;
    map { $gap_count++ if $numbers[$_] - $numbers[$_ - 1] == $gap } 1 .. @numbers - 1;  
    return $gap_count;

}

MAIN:{
    say gap_pairs(3);    
    say gap_pairs(2, 5, 8, 1);    
}

Sample Run


$ perl perl/ch-1.pl 
0
2

Notes

Probably these two subroutines could be combined into one without too much trouble, but it still seems cleaner to me this way.

  1. Do an initial pass over the list to determine the largest gap.

  2. Perform a second pass over the list and count up all pairs which have the maximum gap.

An interesting issue came up. I've been trying to avoid the use of a map in a void context. This is just due to the general principal to use map as a function and use its return value rather than rely on side effects.

As part of this reformative effort I have been doing more with for in a postfix position. I discovered this when working this problem:

{say $_ if $_ % 2 == 0} for 0 .. 9 will not work. Perl gets confused by the postfix if within the block, apparently.

But there is a work around! Add do and all is well.

do {say $_ if $_ % 2 == 0} for 0 .. 9

Of course the equivalent map works just fine as you'd expect map {say $_ if $_ % 2 == 0} 0 .. 9)

E. Choroba pointed out this is due to postfix for being a statement modifier which doesn't know what to do with blocks. But why does do fix this? I am still unclear on why that is. Even with the do it's still a block! Apparently perl will view it as a statement, for the purposes of the postfix for?

UPDATE: Turns out that the do {} construct qualifies as a Simple Statement. From the perldoc: Note that there are operators like eval {}, sub {}, and do {} that look like compound statements, but aren't--they're just TERMs in an expression--and thus need an explicit termination when used as the last item in a statement.

Part 2

You are given an integer $n > 0. Write a script to print the count of primes less than $n.

Solution


use v5.36;
use Math::Primality q/is_prime/;

sub prime_count{
    return 0 + grep { is_prime $_ } 2 .. $_[0] - 1;  
}

MAIN:{
    say prime_count(10);  
    say prime_count(15);  
    say prime_count(1);  
    say prime_count(25);  
}

Sample Run


$ perl perl/ch-2.pl
4
6
0
9

Notes

The Math::Primality module makes this quite easy! In fact, I am not sure there is that much to elaborate on. Check primality using is_prime() and we're done!

References

Challenge 198

posted at: 19:30 by: Adam Russell | path: /perl | permanent link to this entry

2022-12-18

Especially Frequent Even

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a positive integer, $n > 0. Write a script to print the count of all special integers between 1 and $n.

Solution


use v5.36;
use boolean;  
sub is_special{
    my($x) = @_;
    my %h; 
    my @digits = split(//, $x);
    map{ $h{$_} = undef } @digits; 
    return keys %h == @digits; 
}

MAIN:{
    say q// . grep{ is_special($_) } 1 .. $ARGV[0];  
}

Sample Run


$ perl perl/ch-1.pl 15
14
$ perl perl/ch-1.pl 35
32

Notes

The definition of a special integer for this problem is an integer whose digits are unique. To determine this specialness we define is_special() which splits any given number into an array of digits. Each of the digits are added to a hash as the keys. If any digits are not unique then they will not be duplicated as a hash key and the test will return false.

Once is_special() is set all we need to do is to map over the given range and count up the results!

Part 2

You are given a list of numbers, @list. Write a script to find most frequent even numbers in the list. In case you get more than one even numbers then return the smallest even integer. For all other case, return -1.

Solution


use v5.36;
sub most_frequent_even{
    my @list = @_;
    @list = grep { $_ % 2 == 0 } @list; 
    return -1 if @list == 0;  
    my %frequencies;
    map { $frequencies{$_}++ } @list;
    my @sorted = sort { $frequencies{$b} <=> $frequencies{$a} } @list; 
    return $sorted[0] if $frequencies{$sorted[0]} != $frequencies{$sorted[1]};   
    my @tied = grep { $frequencies{$_} == $frequencies{$sorted[0]} } @list;
    return (sort { $a <=> $b } @tied)[0];       
}

MAIN:{
    my @list;
    @list = (1, 1, 2, 6, 2); 
    say most_frequent_even(@list);    
    @list = (1, 3, 5, 7); 
    say most_frequent_even(@list);    
    @list = (6, 4, 4, 6, 1); 
    say most_frequent_even(@list);    
}

Sample Run


$ perl perl/ch-2.pl
2
-1
4

Notes

map and grep really do a lot to make this solution pretty succinct. First grep is used to extract just the even numbers. Then map is used to count up the frequencies. In the case of ties grep is used to identify the numbers with a tied frequency. The tied numbers are then sorted with the lowest one being returned, as specified.

References

Challenge 195

posted at: 00:53 by: Adam Russell | path: /perl | permanent link to this entry

2022-12-03

The Weekly Challenge 193

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given an integer, $n > 0. Write a script to find all possible binary numbers of size $n.

Solution


use v5.36;
sub binary_numbers_size_n{
    my($n) = @_;
    my @numbers = map {
        sprintf("%0${n}b", $_)
    } 0 .. 2**$n - 1;
    return @numbers;
}

MAIN:{
    say join(", ", binary_numbers_size_n(2));
    say join(", ", binary_numbers_size_n(3));
    say join(", ", binary_numbers_size_n(4));
}

Sample Run


$ perl perl/ch-1.pl
00, 01, 10, 11
000, 001, 010, 011, 100, 101, 110, 111
0000, 0001, 0010, 0011, 0100, 0101, 0110, 0111, 1000, 1001, 1010, 1011, 1100, 1101, 1110, 1111

Notes

I think it's fair to say that sprintf is doing most of the work here! For those unfamiliar, the format string "%0${n}b" means print the number as binary of length $n, left pad with 0s.

Part 2

You are given a list of strings of same length, @s. Write a script to find the odd string in the given list. Use positional alphabet values starting with 0, i.e. a = 0, b = 1, ... z = 25.

Solution


use v5.36;
sub odd_string{
    my(@strings) = @_;
    my %differences;
    for my $string (@strings){
        my $current;
        my $previous;
        my @differences;
        map {
            unless($previous){
                $previous = $_;
            }
            else{
                $current = $_;
                push @differences, ord($current) - ord($previous);
                $previous = $current;
            }        
        } split(//, $string);
        my $key = join(",", @differences);
        my $size_before = keys %differences;
        $differences{$key} = undef;
        my $size_after = keys %differences;
        return $string if $size_before > 0 && $size_after - $size_before == 1;
    }
    return undef;
}

MAIN:{
    say odd_string(qw/adc wzy abc/);
    say odd_string(qw/aaa bob ccc ddd/);
    say odd_string(qw/aaaa bbbb cccc dddd/) || "no odd string found";
    say odd_string(qw/aaaa bbob cccc dddd/);
}

Sample Run


$ perl perl/ch-2.pl
abc
bob
no odd string found
bbob

Notes

There is one main assumption here and that is that the list of strings is going to be of length three or more. If the array has length one then can we say that single string is "odd" in and of itself? And if we have only two strings and they aren't the same which is the the odd one?

The basic steps of this solution are:

1) For each string split it into an array of characters.

2) Compute the differences. This is done in the map. I'll concede that this is a somewhat unusual use of map!

3) Transform the differences into a single string to be used as a hash key using join.

4) If we add this differences based key to the hash and the hash size changes by 1 (assuming it is a non-empty hash) then we know we have found the unique "odd string" which is then returned.

References

Challenge 193

posted at: 19:04 by: Adam Russell | path: /perl | permanent link to this entry

2022-11-27

Flipping to Redistribute

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a positive integer, $n. Write a script to find the binary flip.

Solution


use v5.36;
sub int2bits{
    my($n) = @_;
    my @bits;
    while($n){
        my $b = $n & 1;
        unshift @bits, $b;
        $n = $n >> 1;
    }
    return @bits
}

sub binary_flip{
    my($n) = @_;
    my @bits = int2bits($n);
    @bits = map {$_^ 1} @bits;
    return oct(q/0b/ . join(q//, @bits));
}

MAIN:{
    say binary_flip(5);
    say binary_flip(4);
    say binary_flip(6);
}

Sample Run


$ perl perl/ch-1.pl
2
3
1

Notes

There was once a time when I was positively terrified of bitwise operations. Anything at that level seemed a bit like magic. Especially spooky were the bitwise algorithms detailed in Hacker's Delight! Anyway, has time has gone on I am a bit more confortable with these sorts of things. Especially when, like this problem, the issues are fairly straightforward.

The code here does the following:

Part 2

You are given a list of integers greater than or equal to zero, @list. Write a script to distribute the number so that each members are same. If you succeed then print the total moves otherwise print -1.

Solution


use v5.36;
use POSIX;

sub equal_distribution{
    my(@integers) = @_;
    my $moves;
    my $average = unpack("%32I*", pack("I*",  @integers)) / @integers; 
    return -1 unless floor($average) ==  ceil($average);
    {
        map{
            my $i = $_;
            if($integers[$i] > $average && $integers[$i] > $integers[$i+1]){$integers[$i]--; $integers[$i+1]++; $moves++}
            if($integers[$i] < $average && $integers[$i] < $integers[$i+1]){$integers[$i]++; $integers[$i+1]--; $moves++}
        } 0 .. @integers - 2;
        redo unless 0 == grep {$average != $_} @integers;
    }
    return $moves;
}

MAIN:{
    say equal_distribution(1, 0, 5);
    say equal_distribution(0, 2, 0);
    say equal_distribution(0, 3, 0);
}

Sample Run


$ perl perl/ch-2.pl
4
-1
2

Notes

The rules that must be followed are:

1) You can only move a value of '1' per move

2) You are only allowed to move a value of '1' to a direct neighbor/adjacent cell.

First we compute the average of the numbers in the list. Provided that the average is a non-decimal (confirmed by comparing floor to ceil) we know we can compute the necessary "distribution".

The re-distribution itself is handled just by following the rules and continuously looping until all values in the list are the same.

References

oct

Challenge 192

posted at: 19:04 by: Adam Russell | path: /perl | permanent link to this entry

2022-11-20

Twice Largest Once Cute

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given list of integers, @list. Write a script to find out whether the largest item in the list is at least twice as large as each of the other items.

Solution


use v5.36;
use strict;
use warnings;

sub twice_largest{
    my(@list_integers) = @_;
    my @sorted_integers = sort {$a <=> $b} @list_integers;
    for my $i (@sorted_integers[0 .. @sorted_integers - 1]){
        unless($sorted_integers[@sorted_integers - 1] == $i){
            return -1 unless $sorted_integers[@sorted_integers - 1] >= 2 * $i; 
        }
    }
    return 1;
}

MAIN:{
    say twice_largest(1, 2, 3, 4);
    say twice_largest(1, 2, 0, 5);
    say twice_largest(2, 6, 3, 1);
    say twice_largest(4, 5, 2, 3);
}

Sample Run


$ perl perl/ch-1.pl
-1
1
1
-1

Notes

For Part 1 I at first couldn't see how to avoid a basic O(n^2) nested for loop. After I took a nap I think the best approach is what I have here:

  1. sort the list O(n log n)

  2. get the max element from the sorted list O(1)

  3. iterate over the sorted list, stop and return false if at any point an element times two is not less then max. return true if all elements (other than $max itself) pass the test. O(n)

So total worst case dominated by the sort O(n log n).

(And the nap was required because I was on an overnight camping trip with my son's Cub Scout pack the previous day and barely slept at all!)

Part 2

You are given an integer, 0 < $n <= 15. Write a script to find the number of orderings of numbers that form a cute list.

Solution


use v5.36;
use strict;
use warnings;

use Hash::MultiKey;

sub cute_list{
    my($n) = @_;
    my %cute;
    tie %cute, "Hash::MultiKey";
    for my $i (1 .. $n){
        $cute{[$i]} = undef;
    }
    my $i = 1;
    {
        $i++;
        my %cute_temp;
        tie %cute_temp, "Hash::MultiKey";
        for my $j (1 .. $n){
            for my $cute (keys %cute){
                if(0 == grep {$j == $_} @{$cute}){
                    if(0 == $j % $i || 0 == $i % $j){
                        $cute_temp{[@{$cute}, $j]} = undef;
                    }    
                }
            }
        }
        %cute = %cute_temp;
        untie %cute_temp;
        redo unless $i == $n;
    }
    return keys %cute;
}

MAIN:{
    say cute_list(2) . q//;
    say cute_list(3) . q//;
    say cute_list(5) . q//;
    say cute_list(10) . q//;
    say cute_list(11) . q//;
    say cute_list(15) . q//;
}

Sample Run


$ perl perl/ch-2.pl
2
3
10
700
750
24679

Notes

This solution with a dynamic programming style approach seems to work pretty well. cute(11) runs in less than a second (perl 5.34.0, M1 Mac Mini 2020) which is pretty good compared to some other reported run times that have been posted to social media this week.

Some may notice that the solution here bears a striking resemblance to the one for TWC 117! The logic there was a bit more complicated, since multiple paths could be chosen. The overall idea is the same though: as we grow the possible lists we are able to branch and create new lists (paths).

References

Challenge 191

posted at: 21:50 by: Adam Russell | path: /perl | permanent link to this entry

2022-11-13

Capital Detection Decode

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a string with alphabetic characters only: A..Z and a..z. Write a script to find out if the usage of Capital is appropriate if it satisfies at least one of the rules.

Solution


use v5.36;
use strict;
use warnings;

use boolean;

sub capital_detection{
    {my($s) = @_; return true if length($s) == $s =~ tr/A-Z//d;}
    {my($s) = @_; return true if length($s) == $s =~ tr/a-z//d;}
    {
        my($s) = @_; 
        $s =~ m/(^.{1})(.*)$/;
        my $first_letter = $1;
        my $rest_letters = $2;
        return true if $first_letter =~ tr/A-Z//d == 1 &&
                       length($rest_letters) == $rest_letters =~ tr/a-z//d;
    }
    return false;
}

MAIN:{
    say capital_detection(q/Perl/);
    say capital_detection(q/TPF/);
    say capital_detection(q/PyThon/);
    say capital_detection(q/raku/);
}

Sample Run


$ perl perl/ch-1.pl
1
1
0
1

Notes

The rules to be satisfied are:

1) Only first letter is capital and all others are small.

2) Every letter is small.

3) Every letter is capital.

I did a bit of experimenting with tr this week. Somewhat relatedly I also reminded myself of scope issues in Perl.

The tr function has a nice feature where it returns the number of characters changed, or as was the case here, deleted. Here we delete all upper or lower case letters and if the number of letters deleted is equal to original length we know that the original contained all upper/lower case letters as required by the rules. One catch is that tr when used this way alters the original string. One way around that would be to use temporary variables. Another option is to contain each of these rules checks in their own block!

Part 2

You are given an encoded string consisting of a sequence $s of numeric characters: 0..9. Write a script to find the all valid different decodings in sorted order.

Solution


use v5.36;
use strict;
use warnings;

use AI::Prolog;
use Hash::MultiKey;

my $prolog_code;
sub init_prolog{
    $prolog_code = do{
        local $/;
        <DATA>;
    };
}

sub decoded_list{
    my($s) = @_;
    my $prolog = $prolog_code;
    my @alphabet = qw/A B C D E F G H I J K L M N O P Q R S T U V W X Y Z/;
    my @encoded;
    my @decoded;
    my $length = length($s);
    $prolog =~ s/_LENGTH_/$length/g;
    $prolog = AI::Prolog->new($prolog); 
    $prolog->query("sum(Digits).");
    my %h;
    tie %h, "Hash::MultiKey";
    while(my $result = $prolog->results){
        $h{$result->[1]} = undef;
    }
    for my $pattern (keys %h){
        my $index = 0;
        my $encoded = [];
        for my $i (@{$pattern}){
            push @{$encoded}, substr($s, $index, $i);
            $index += $i;
        }
        push @encoded, $encoded if 0 == grep { $_ > 26 } @{$encoded};
    }
    @decoded = sort { $a cmp $b } map { join("", map { $alphabet[$_ - 1] } @{$_}) } @encoded;
}

MAIN:{
    init_prolog;
    say join(", ", decoded_list(11));
    say join(", ", decoded_list(1115));
    say join(", ", decoded_list(127));
}

__DATA__
member(X,[X|_]).
member(X,[_|T]) :- member(X,T).

digits([1, 2]).

sum(Digits):-
    sum([], Digits, 0).

sum(Digits, Digits, _LENGTH_). 

sum(Partial, Digits, Sum):-   
    Sum < _LENGTH_, 
    digits(L),
    member(X,L),
    S is Sum + X,
    sum([X | Partial], Digits, S). 

Sample Run


$ perl perl/ch-2.pl
AA, K
AAAE, AAO, AKE, KAE, KO
ABG, LG

Notes

There is an element of this task which reminded me of a much older problem presented back in TWC 075. In brief, the question was how many ways could coins be used in combination to form a target sum. My solution used a mix of Prolog and Perl since Prolog is especially well suited for elegant solutions to these sorts of combinatorial problems.

I recognized that this week we have a similar problem in how we may separate the given encoded string into different possible chunks for decoding. Here we know that no chunk may have value greater than 26 and so we can only choose one or two digits at a time. How many ways we can make these one or two digit chunks is the exact same problem, somewhat in hiding, as in TWC 075!

I re-use almost the exact same Prolog code as used previously. This is used to identify the different combinations of digits for all possible chunks. Once that is done we need only map the chunks to letters and sort.

References

Scoping in Perl

Challenge 190

posted at: 21:12 by: Adam Russell | path: /perl | permanent link to this entry

2022-11-06

To a Greater Degree

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given an array of characters (a..z) and a target character. Write a script to find out the smallest character in the given array lexicographically greater than the target character.

Solution


use v5.36;
use strict;
use warnings;

sub greatest_character{
    my($characters, $target) = @_;
    return [sort {$a cmp $b} grep {$_ gt $target} @{$characters}]->[0] || $target;
}

MAIN:{
    say greatest_character([qw/e m u g/], q/b/);
    say greatest_character([qw/d c e f/], q/a/);
    say greatest_character([qw/j a r/],   q/o/);
    say greatest_character([qw/d c a f/], q/a/);
    say greatest_character([qw/t g a l/], q/v/);
}

Sample Run


$ perl perl/ch-1.pl
e
c
r
c
v

Notes

Practically a one liner! Here we use grep to filter out all the characters greater than the target. The results are then sorted and we return the first one. If all that yields no result, say there are no characters greater than the target, the just return the target.

Part 2

You are given an array of 2 or more non-negative integers. Write a script to find out the smallest slice, i.e. contiguous subarray of the original array, having the degree of the given array.

Solution


use v5.36;
use strict;
use warnings;

sub array_degree{
    my(@integers) = @_;
    my @counts;
    map { $counts[$_]++ } @integers;
    @counts = grep {defined} @counts;
    return [sort {$b <=> $a} @counts]->[0];
}

sub least_slice_degree{
    my(@integers) = @_;
    my @minimum_length_slice;
    my $minimum_length = @integers;
    my $array_degree = array_degree(@integers);
    for my $i (0 .. @integers - 1){
        for my $j ($i + 1 .. @integers - 1){
            if(array_degree(@integers[$i .. $j]) == $array_degree && @integers[$i .. $j] < $minimum_length){
                @minimum_length_slice = @integers[$i .. $j];
                $minimum_length = @minimum_length_slice;
            }
        }
    }
    return @minimum_length_slice;
}

MAIN:{
    say "(" . join(", ", least_slice_degree(1, 3, 3, 2)) . ")";
    say "(" . join(", ", least_slice_degree(1, 2, 1)) . ")";
    say "(" . join(", ", least_slice_degree(1, 3, 2, 1, 2)) . ")";
    say "(" . join(", ", least_slice_degree(1, 1 ,2 ,3, 2)) . ")";
    say "(" . join(", ", least_slice_degree(2, 1, 2, 1, 1)) . ")";
}

Sample Run


$ perl perl/ch-2.pl
(3, 3)
(1, 2, 1)
(2, 1, 2)
(1, 1)
(1, 2, 1, 1)

Notes

I view this problem in two main pieces:

  1. Compute the degree of any given array.

  2. Generate all contiguous slices of the given array and looking for a match on the criteria.

So, with that in mind we perform (1) in sub array_degree and then think of how we might best compute all those contiguous slices. Here we use a nested for loop. Since we also need to check to see if any of the computed slices have an array degree equal to the starting array we just do that inside the nested loop as well. This way we don't need to use any extra storage. Instead we just track the minimum length slice with matching array degree. Once the loops exit we return that minimum length slice.

References

Challenge 189

posted at: 18:58 by: Adam Russell | path: /perl | permanent link to this entry

2022-10-30

Pairs Divided by Zero

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given list of integers @list of size $n and divisor $k. Write a script to find out count of pairs in the given list that satisfies a set of rules.

Solution


use v5.36;
use strict;
use warnings;

sub divisible_pairs{
    my($numbers, $k) = @_;
    my @pairs;
    for my $i (0 .. @{$numbers} - 1){
        for my $j ($i + 1 .. @{$numbers} - 1){
            push @pairs, [$i, $j] if(($numbers->[$i] + $numbers->[$j]) % $k == 0);
        }
    }
    return @pairs;
}

MAIN:{
    my @pairs;
    @pairs = divisible_pairs([4, 5, 1, 6], 2);
    print @pairs . "\n";
    @pairs = divisible_pairs([1, 2, 3, 4], 2);
    print @pairs . "\n";
    @pairs = divisible_pairs([1, 3, 4, 5], 3);
    print @pairs . "\n";
    @pairs = divisible_pairs([5, 1, 2, 3], 4);
    print @pairs . "\n";
    @pairs = divisible_pairs([7, 2, 4, 5], 4);
    print @pairs . "\n";
}

Sample Run


$ perl perl/ch-1.pl
2
2
2
2
1

Notes

The rules, if not clear from the above code are : the pair (i, j) is eligible if and only if

While certainly possible to develop a more complicated looking solution using map and grep I found myself going with nested for loops. The construction of the loop indices takes care of the first condition and the second is straightforward.

Part 2

You are given two positive integers $x and $y. Write a script to find out the number of operations needed to make both ZERO.

Solution


use v5.36;
use strict;
use warnings;

sub count_zero{
    my($x, $y) = @_;
    my $count = 0;
    {
        my $x_original = $x;
        $x = $x - $y if $x >= $y;
        $y = $y - $x_original if $y >= $x_original;
        $count++;
        redo unless $x == 0 && $y == 0;
    }
    return $count;
}

MAIN:{
    say count_zero(5, 4);
    say count_zero(4, 6);
    say count_zero(2, 5);
    say count_zero(3, 1);
    say count_zero(7, 4);
}

Sample Run


$ perl perl/ch-2.pl
5
3
4
3
5

Notes

The operations are dictated by these rules:

or

This problem seemed somewhat confusingly stated at first. I had to work through the first given example by hand to make sure I really understood what was going on.

After a little analysis I realized this is not as confusing as I first thought. The main problem I ran into was not properly accounting for the changed value of $x using a temporary variable $x_original. If you see my Prolog Solutions for this problem you can see how Prolog's immutable variables obviate this issue!

References

Challenge 188

posted at: 19:24 by: Adam Russell | path: /perl | permanent link to this entry

2022-10-23

Days Together Are Magical

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

Two friends, Foo and Bar gone on holidays seperately to the same city. You are given their schedule i.e. start date and end date. To keep the task simple, the date is in the form DD-MM and all dates belong to the same calendar year i.e. between 01-01 and 31-12.
Also the year is non-leap year and both dates are inclusive. Write a script to find out for the given schedule, how many days they spent together in the city, if at all.

Solution


use v5.36;
use strict;
use warnings;

use Time::Piece;
use Time::Seconds;

sub days_together{
    my($together) = @_;
    my $days_together = 0;
    my($start, $end);
    my $foo_start = Time::Piece->strptime($together->{Foo}->{SD}, q/%d-%m/);
    my $bar_start = Time::Piece->strptime($together->{Bar}->{SD}, q/%d-%m/);
    my $foo_end = Time::Piece->strptime($together->{Foo}->{ED}, q/%d-%m/);
    my $bar_end = Time::Piece->strptime($together->{Bar}->{ED}, q/%d-%m/);
    $start = $foo_start;
    $start = $bar_start if $bar_start > $foo_start;
    $end = $foo_end;
    $end = $bar_end if $bar_end < $foo_end;
    {
        $days_together++ if $start <= $end;
        $start += ONE_DAY;
        redo if $start <= $end;
    }
    return $days_together;
}


MAIN:{
    my $days;
    $days = days_together({Foo => {SD => q/12-01/, ED => q/20-01/},
                           Bar => {SD => q/15-01/, ED => q/18-01/}});
    say $days;
    $days = days_together({Foo => {SD => q/02-03/, ED => q/12-03/},
                           Bar => {SD => q/13-03/, ED => q/14-03/}});
    say $days;
    $days = days_together({Foo => {SD => q/02-03/, ED => q/12-03/},
                           Bar => {SD => q/11-03/, ED => q/15-03/}});
    say $days;
    $days = days_together({Foo => {SD => q/30-03/, ED => q/05-04/},
                           Bar => {SD => q/28-03/, ED => q/02-04/}});
    say $days;        
}

Sample Run


$ perl perl/ch-1.pl
4
0
2
4

Notes

Time:Piece makes this easy, once we figure out the logic. The start date should be the later of the two start dates since clearly there can be no overlap until the second person shows up. Similarly the end date should be the earlier of the two dates since once one person leaves their time together is over. By converting the dates to Time::Piece objects the comparisons are straightforward.

Now, once the dates are converted to Time::Piece objects and the start and end dates determined we could also use Time::Piece arithmetic to subtract one from the other and pretty much be done. However, since that might be a little too boring I instead iterate and count the number of days in a redo loop!

Part 2

You are given a list of positive numbers, @n, having at least 3 numbers. Write a script to find the triplets (a, b, c) from the given list that satisfies a set of rules.

Solution


use v5.36;
use strict;
use warnings;

use Hash::MultiKey;
use Math::Combinatorics;

sub magical_triples{
    my(@numbers) = @_;
    my %triple_sum;
    tie %triple_sum, q/Hash::MultiKey/;
    my $combinations = Math::Combinatorics->new(count => 3, data => [@numbers]);
    my($s, $t, $u);
    while(my @combination = $combinations->next_combination()){
        my($s, $t, $u) = @combination;
        my $sum;
        $sum = $s + $t + $u if $s + $t > $u && $t + $u > $s && $s + $u > $t;
        $triple_sum{[$s, $t, $u]} = $sum if $sum;
    }
    my @triples_sorted = sort {$triple_sum{$b} <=> $triple_sum{$a}} keys %triple_sum; 
    return ($triples_sorted[0]->[0], $triples_sorted[0]->[1], $triples_sorted[0]->[2]) if @triples_sorted;
    return ();
}

MAIN:{
    say "(" . join(", ", magical_triples(1, 2, 3, 2)) . ")";
    say "(" . join(", ", magical_triples(1, 3, 2)) . ")";
    say "(" . join(", ", magical_triples(1, 1, 2, 3)) . ")";
    say "(" . join(", ", magical_triples(2, 4, 3)) . ")";
}

Sample Run


$ perl perl/ch-2.pl
(2, 3, 2)
()
()
(4, 3, 2)

Notes

The "magical" rules, if not clear from the above code are:

To be certain, this problem is an excellent application of constraint programming. Unfortunately I do not know of a good constraint programming library in Perl. If you see my Prolog Solutions for this problem you can see just how straightforward such a solution can be!

Here we find ourselves with a brute force implementation. Math::Combinatorics is a battle tested module when dealing with combinatorics problems in Perl. For all possible selections of three elements of the original list we evaluate the rules and track their sums in a hash. We then sort the hash keys based on the associated values and return the triple which has maximal sum and otherwise passes all the other requirements.

A nice convenient module used here is Hash::MultiKey which allows us to use an array reference as a hash key. In this way we can have immediate access to the triples when needed.

References

Challenge 187

posted at: 17:11 by: Adam Russell | path: /perl | permanent link to this entry

2022-10-16

Zippy Fast Dubious OCR Process

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given two lists of the same size. Create a subroutine sub zip() that merges the two lists.

Solution


use v5.36;
use strict;
use warnings;

sub zip($a, $b){
    return map { $a->[$_], $b->[$_] } 0 .. @$a - 1;
}

MAIN:{
    print join(", ", zip([qw/1 2 3/], [qw/a b c/])) . "\n";
    print join(", ", zip([qw/a b c/], [qw/1 2 3/])) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
1, a, 2, b, 3, c
a, 1, b, 2, c, 3

Notes

The solution here is basically that one line map. Since we know that the lists are of the same size we can map over the array indices and then construct the desired return list directly.

Part 2

You are given a string with possible unicode characters. Create a subroutine sub makeover($str) that replace the unicode characters with their ascii equivalent. For this task, let us assume the string only contains letters.

Solution


use utf8;
use v5.36;
use strict;
use warnings;
##
# You are given a string with possible unicode characters. Create a subroutine 
# sub makeover($str) that replace the unicode characters with their ascii equivalent.
# For this task, let us assume the string only contains letters.
##
use Imager;
use File::Temp q/tempfile/;
use Image::OCR::Tesseract q/get_ocr/;

use constant TEXT_SIZE => 30;
use constant FONT => q#/usr/pkg/share/fonts/X11/TTF/Symbola.ttf#;

sub makeover($s){
    my $image = Imager->new(xsize => 100, ysize => 100);
    my $temp = File::Temp->new(SUFFIX => q/.tiff/);
    my $font = Imager::Font->new(file => FONT) or die "Cannot load " . FONT . " ", Imager->errstr;
    $font->align(string => $s,
                 size => TEXT_SIZE,
                 color => q/white/,
                 x => $image->getwidth/2,
                 y => $image->getheight/2,
                 halign => q/center/,
                 valign => q/center/,
                 image => $image
    );
    $image->write(file => $temp) or die "Cannot save $temp", $image->errstr;
    my $text = get_ocr($temp);
    return $text;
}


MAIN:{
    say makeover(q/ Ã Ê Í Ò Ù /);
}

Sample Run


$ perl perl/ch-2.pl
EIO



Notes

First I have to say upfront that this code doesn't work all that well for the problem at hand! Rather than modify it to something that works better I thought I would share it as is. It's intentionally ridiculous and while it would have been great if it worked better I figure it's worth taking a look at anyway.

So, my idea was:

I wasn't so sure about that last one. A good ocr should maintain the true letters, accents and all. Tesseract, the ocr engine used here, claims to support Unicode and "more than 100 languages" so it should have reproduced the original input text, except that it didn't. In fact, for a variety of font sizes and letter combinations it never detected the accents. While I would be frustrated if I wanted that feature to work well, I was happy to find that it did not!

Anyway, to put it mildly, it's clear that this implementation is fragile for the task at hand! In other ways it's pretty solid though. Imager is a top notch image manipulation module that does the job nicely here. Image::OCR::Tesseract is similarly a high quality wrapper around the Tesseract ocr engine. Tesseract itself is widely accepted as being world class. My lack of a great result here is mainly due to my intentional misuse of these otherwise fine tools!

References

Imager

Image::OCR::Tesseract

Challenge 186

posted at: 22:38 by: Adam Russell | path: /perl | permanent link to this entry

2022-09-18

Deepest Common Index

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a list of integers. Write a script to find the index of the first biggest number in the list.

Solution


use v5.36; 
use strict;
use warnings;

sub index_biggest{
    my(@numbers) = @_;
    my @sorted = sort {$b <=> $a} @numbers; 
    map { return $_ if $numbers[$_] == $sorted[0] } 0 .. @numbers - 1; 
}

MAIN:{
    my @n;
    @n = (5, 2, 9, 1, 7, 6);
    print index_biggest(@n) . "\n";  
    @n = (4, 2, 3, 1, 5, 0);  
    print index_biggest(@n) . "\n";  
}

Sample Run


$ perl perl/ch-1.pl
2
4

Notes

Essentially this solution is two lines, and could even have been a one liner. All that is required is to sort the array of numbers and then determine the index of the first occurrence of the largest value from the original list. Finding the index of the first occurrence can be done using a map with a return to short circuit the search as soon as the value is found.

Part 2

Given a list of absolute Linux file paths, determine the deepest path to the directory that contains all of them.

Solution


use v5.36;
use strict;
use warnings;

sub deepest_path{
    my(@paths) = @_;
    my @sub_paths = map { [split(/\//, $_)] } @paths; 
    my @path_lengths_sorted = sort { $a <=> $b } map { 0 + @{$_} } @sub_paths;    
    my $deepest_path = q//; 
    for my $i (0 .. $path_lengths_sorted[0] - 1){
        my @column =  map { $_->[$i] } @sub_paths;
        my %h;
        map { $h{$_} = undef } @column;
        $deepest_path .= (keys %h)[0] . q#/# if 1 == keys %h;  
    }  
    chop $deepest_path;
    return $deepest_path;  
}

MAIN:{
    my $data = do{
        local $/;
        <DATA>; 
    };
    my @paths = split(/\n/, $data);  
    print deepest_path(@paths) . "\n"; 
}

__DATA__
/a/b/c/1/x.pl
/a/b/c/d/e/2/x.pl
/a/b/c/d/3/x.pl
/a/b/c/4/x.pl
/a/b/c/d/5/x.pl

Sample Run


$ perl perl/ch-2.pl
/a/b/c

Notes

The approach here is fairly straightforward but I will admit that it may look more complex than it truly is if you simply glance at the code.

To summarize what is going on here:

References

Challenge 182

posted at: 20:17 by: Adam Russell | path: /perl | permanent link to this entry

2022-09-11

These Sentences Are Getting Hot

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a paragraph. Write a script to order each sentence alphanumerically and print the whole paragraph.

Solution


use v5.36;
use strict;
use warnings;

sub sort_paragraph{
    my($paragraph) = @_;
    my @sentences = split(/\./, $paragraph); 
    for(my $i = 0; $i < @sentences; $i++){
        $sentences[$i] = join(" ", sort {uc($a) cmp uc($b)} split(/\s/, $sentences[$i]));
    }
    return join(".", @sentences);
}

MAIN:{
    my $paragraph = do{
        local $/;
        <DATA>;
    };
    print sort_paragraph($paragraph);
}

__DATA__
All he could think about was how it would all end. There was
still a bit of uncertainty in the equation, but the basics
were there for anyone to see. No matter how much he tried to
see the positive, it wasn't anywhere to be seen. The end was
coming and it wasn't going to be pretty.

Sample Run


$ perl perl/ch-1.pl
about All all could end he how it think was would. a anyone basics bit but equation, for in of see still the the There there to uncertainty was were. anywhere be he how it matter much No positive, see seen the to to tried wasn't. and be coming end going it pretty The to was wasn't

Notes

This code is fairly compact but not at all obfuscated, I would argue. First we take in the paragraph all at once. Then we split into sentences and begin the sorting.

The sort is a little complicated looking at first because we want the words to be sorted irrespective of letter case. One way to handle that is to compare only all uppercase versions of the words. Lowercase would work too, of course!

Part 2

You are given file with daily temperature record in random order. Write a script to find out days hotter than previous day.

Solution


use v5.36;
use strict;
use warnings;

use DBI;
use Text::CSV;
use Time::Piece;

sub hotter_than_previous{
    my($data) = @_;
    my @hotter;
    my $csv_parser = Text::CSV->new();
    my $dbh = DBI->connect(q/dbi:CSV:/, undef, undef, undef);
    $dbh->do(q/CREATE TABLE hotter_than_previous_a(day INTEGER, temperature INTEGER)/);
    $dbh->do(q/CREATE TABLE hotter_than_previous_b(day INTEGER, temperature INTEGER)/);
    for my $line (@{$data}){
        $line =~ tr/ //d;
        $csv_parser->parse($line);
        my($day, $temperature) = $csv_parser->fields();
        $day = Time::Piece->strptime($day, q/%Y-%m-%d/);
        $dbh->do(q/INSERT INTO hotter_than_previous_a VALUES(/ . $day->epoch . qq/, $temperature)/);
        $dbh->do(q/INSERT INTO hotter_than_previous_b VALUES(/ . $day->epoch . qq/, $temperature)/);
    }
    my $statement = $dbh->prepare(q/SELECT day FROM hotter_than_previous_a A INNER JOIN  
                                    hotter_than_previous_b B WHERE (A.day - B.day = 86400)                            
                                    AND A.temperature > B.temperature/);
    $statement->execute();
    while(my $row = $statement->fetchrow_hashref()){
        push @hotter, $row->{day};
    }
    @hotter = map {Time::Piece->strptime($_, q/%s/)->strftime(q/%Y-%m-%d/)} sort @hotter;
    unlink(q/hotter_than_previous_a/);
    unlink(q/hotter_than_previous_b/);
    return @hotter;
}

MAIN:{
    my $data = do{
        local $/;
        <DATA>; 
    };
    my @hotter = hotter_than_previous([split(/\n/, $data)]);
    say join(qq/\n/, @hotter);
}

__DATA__
2022-08-01, 20
2022-08-09, 10
2022-08-03, 19
2022-08-06, 24
2022-08-05, 22
2022-08-10, 28
2022-08-07, 20
2022-08-04, 18
2022-08-08, 21
2022-08-02, 25

Sample Run


$ perl perl/ch-2.pl
2022-08-02
2022-08-05
2022-08-06
2022-08-08
2022-08-10

Notes

To be clear up front, this is an intentionally over engineered solution! I have been intrigued by the idea of DBD::CSV since I first heard of it but never had a reason to use it. So I invented a reason!

DBD::CSV provides a SQL interface to CSV data. That is, it allows you to write SQL queries against CSV data as if they were a more ordinary relational database. Very cool! Instead of solving this problem in Perl I am actually implementing the solution in SQL. Perl is providing the implementation of the SQL Engine and the quasi-database for the CSV data.

DBD::CSV is quite powerful but is not completely on par feature wise with what you'd get if you were using an ordinary database. Not all SQL data types are supported, for example. Work arounds can be constructed to do everything that we want and these sorts of trade offs are to be expected. To store the dates we use Time::Piece to compute UNIX epoch times which are stored as INTEGERs. Also, DBD::CSV expects data from files and so we can't use the data directly in memory, it has to be written to a file first. Actually, we find out that we need to create two tables! Each hold exact copies of the same data.

The creation of two tables is due to a quirk of the underlying SQL Engine SQL::Statement. SQL::Statement will throw an error when doing a join on the same table. The way one would do this ordinarily is something like SELECT day FROM hotter_than_previous A, hotter_than_previous B .... That join allows SQL to iterate over all pairs of dates but this throws an error when done with SQL::Statement. To work around this we instead we create two tables which works.

References

Challenge 181

posted at: 08:45 by: Adam Russell | path: /perl | permanent link to this entry

2022-09-04

First Uniquely Trimmed Index

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a string, $s. Write a script to find out the first unique character in the given string and print its index (0-based).

Solution


use v5.36;
use strict;
use warnings;

sub index_first_unique{
    my($s) = @_;
    my @s = split(//, $s);
    map {my $i = $_; my $c = $s[$i]; return $_ if 1 == grep {$c eq $_ } @s } 0 .. @s - 1;
}

MAIN:{
    say index_first_unique(q/Perl Weekly Challenge/);
    say index_first_unique(q/Long Live Perl/);
}

Sample Run


$ perl perl/ch-1.pl
0
1

Notes

I use the small trick of return-ing early out of a map. Since we only want the first unique index there is no need to consider other characters in the string and we can do this short circuiting to bail early.

Part 2

You are given list of numbers, @n and an integer $i. Write a script to trim the given list when an element is less than or equal to the given integer.

Solution


use v5.36;
use strict;
use warnings;

sub trimmer{
    my($i) = @_;
    return sub{
        my($x) = @_;
        return $x if $x > $i;
    }
}

sub trim_list_r{
    my($n, $trimmer, $trimmed) = @_;
    $trimmed = [] unless $trimmed;
    return @$trimmed if @$n == 0;
    my $x = pop @$n;
    $x = $trimmer->($x);
    unshift @$trimmed, $x if $x;
    trim_list_r($n, $trimmer, $trimmed);
}

sub trim_list{
    my($n, $i) = @_;
    my $trimmer = trimmer($i);
    return trim_list_r($n, $trimmer);
}

MAIN:{
    my(@n, $i);
    $i = 3;
    @n = (1, 4, 2, 3, 5);
    say join(", ", trim_list(\@n, $i));
    $i = 4;
    @n = (9, 0, 6, 2, 3, 8, 5);
    say join(", ", trim_list(\@n, $i));
}

Sample Run


$ perl perl/ch-2.pl
4, 5
9, 6, 8, 5

Notes

After using map and grep in the first part this week's challenge I decided to try out something else for this problem. grep would certainly be a perfect fit for this! Instead, though, I do the following:

This works quite well, especially for something so intentionally over engineered. If you end up trying this yourself be careful with the size of the list used with the recursion. For processing long lists in this way you'll either need to set no warnings 'recusion or, preferably, goto __SUB__ in order to take advantage of Perl style tail recursion.

References

Challenge 180

posted at: 11:57 by: Adam Russell | path: /perl | permanent link to this entry

2022-08-14

Cyclops Validation

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a positive number, $n. Write a script to validate the given number against the included check digit.

Solution


use strict;
use warnings;
use boolean;

my @damm_matrix;
$damm_matrix[0] = [0, 7, 4, 1, 6, 3, 5, 8, 9, 2];
$damm_matrix[1] = [3, 0, 2, 7, 1, 6, 8, 9, 4, 5];
$damm_matrix[2] = [1, 9, 0, 5, 2, 7, 6, 4, 3, 8];
$damm_matrix[3] = [7, 2, 6, 0, 3, 4, 9, 5, 8, 1];
$damm_matrix[4] = [5, 1, 8, 9, 0, 2, 7, 3, 6, 4];
$damm_matrix[5] = [9, 5 ,7, 8, 4, 0, 2, 6, 1, 3];
$damm_matrix[6] = [8, 4, 1, 3, 5, 9, 0, 2, 7, 6];
$damm_matrix[7] = [6, 8, 3, 4, 9, 5, 1, 0, 2, 7];
$damm_matrix[8] = [4, 6, 5, 2, 7, 8, 3, 1, 0, 9];
$damm_matrix[9] = [2, 3, 9, 6, 8, 1, 4, 7, 5, 0];

sub damm_validation{
    my($x) = @_;
    my @digits = split(//, $x);
    my $interim_digit = 0;
    while(my $d = shift @digits){
        $interim_digit = $damm_matrix[$d][$interim_digit];
    }
    return boolean($interim_digit == 0);
}

MAIN:{
    print damm_validation(5724) . "\n";
    print damm_validation(5727) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
1
0

Notes

Damm Validation really boils down to a series of table lookups. Once that is determined we need to encode the table and then perform the lookups in a loop.

Part 2

Write a script to generate first 20 Palindromic Prime Cyclops Numbers.

Solution


use strict;
use warnings;
no warnings q/recursion/;
use Math::Primality qw/is_prime/;

sub n_cyclops_prime_r{
    my($i, $n, $cyclops_primes) = @_;
    return @{$cyclops_primes} if @{$cyclops_primes} == $n;
    push @{$cyclops_primes}, $i if is_prime($i) && 
                                   length($i) % 2 == 1 &&
                                   join("", reverse(split(//, $i))) == $i &&
                                   (grep {$_ == 0} split(//, $i))   == 1 && 
                                   do{my @a = split(//, $i);
                                      $a[int(@a / 2)]
                                   } == 0;
    n_cyclops_prime_r(++$i, $n, $cyclops_primes);
}

sub n_cyclops_primes{
    my($n) = @_;
    return n_cyclops_prime_r(1, $n, []);
}

MAIN:{
    print join(", ", n_cyclops_primes(20)) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
101, 16061, 31013, 35053, 38083, 73037, 74047, 91019, 94049, 1120211, 1150511, 1160611, 1180811, 1190911, 1250521, 1280821, 1360631, 1390931, 1490941, 1520251

Notes

I recently saw the word whipupitide used by Dave Jacoby and here is, I think, a good example of it. We need to determine if a number is prime, palindromic, and cyclops. In Perl we can determine all of these conditions very easily.

Just to add a bit of fun I decided to use a recursive loop. Out of necessity this will have a rather deep recursive depth, so we'll need to set no warnings q/recursion/ or else perl will complain when we go deeper than 100 steps. We aren't using too much memory here, but if that were a concern we could do Perl style tail recursion with a goto __SUB__ instead.

References

Challenge 177

posted at: 17:59 by: Adam Russell | path: /perl | permanent link to this entry