RabbitFarm
2023-10-01
Exact Array Loops
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are asked to sell juice each costs $5. You are given an array of bills. You can only sell ONE juice to each customer but make sure you return exact change back. You only have $5, $10 and $20 notes. You do not have any change in hand at first. Write a script to find out if it is possible to sell to each customers with correct change.
Solution
use v5.38;
use boolean;
use constant COST_JUICE => 5;
sub exact_change{
my @bank;
my $current_customer = shift;
{
push @bank, $current_customer if $current_customer == COST_JUICE;
if($current_customer > COST_JUICE){
my $change_due = $current_customer - COST_JUICE;
my @bank_sorted = sort {$a <=> $b} @bank;
my @bank_reserved;
{
my $bill = pop @bank_sorted;
push @bank_reserved, $bill if $change_due < $bill;
$change_due -= $bill if $change_due >= $bill;
redo if @bank_sorted;
}
return false if $change_due != 0;
@bank = @bank_reserved;
push @bank, $current_customer;
}
$current_customer = shift;
redo if $current_customer;
}
return true;
}
MAIN:{
say exact_change 5, 5, 5, 10, 20;
say exact_change 5, 5, 10, 10, 20;
say exact_change 5, 5, 5, 20;
}
Sample Run
$ perl perl/ch-1.pl
1
0
1
Notes
Making change is easy as long as we preferentially use larger bills first. To do so all we
need to do is sort any accumulated payments and then pop off the change as required by
the current transaction, if possible.
Part 2
You are given an array of unique integers. Write a script to determine how many loops are in the given array. To determine a loop: Start at an index and take the number at array[index] and then proceed to that index and continue this until you end up at the starting index.
Solution
use v5.38;
use boolean;
sub loop_counter{
my @integers = @_;
my @loops;
do{
my @loop;
my $loop_found = false;
my $start = $_;
my $next = $integers[$start];
push @loop, $start, $next;
my $counter = 1;
{
if($next == $start){
shift @loop;
if(@loops == 0 || @loop == 2){
push @loops, \@loop;
my @loop;
$loop_found = true;
}
else{
my $loop_duplicate = false;
my @s0 = sort @loop;
do {
my @s1 = sort @{$_};
$loop_duplicate = true if((@s0 == @s1) && (0 < grep {$s0[$_] == $s1[$_]} 0 .. @s0 - 1));
} for @loops;
if(!$loop_duplicate){
$loop_found = true;
push @loops, \@loop;
}
else{
$counter = @integers + 1;
}
}
}
else{
$next = $integers[$next];
push @loop, $next;
$counter++;
}
redo unless $loop_found || $counter > @integers;
}
} for 0 .. @integers - 1;
return @loops + 0;
}
MAIN:{
say loop_counter 4, 6, 3, 8, 15, 0, 13, 18, 7, 16, 14, 19, 17, 5, 11, 1, 12, 2, 9, 10;
say loop_counter 0, 1, 13, 7, 6, 8, 10, 11, 2, 14, 16, 4, 12, 9, 17, 5, 3, 18, 15, 19;
say loop_counter 9, 8, 3, 11, 5, 7, 13, 19, 12, 4, 14, 10, 18, 2, 16, 1, 0, 15, 6, 17;
}
Sample Run
$ perl perl/ch-2.pl
3
6
1
Notes
When I first approached this problem I didn't appreciate that many loops are just cycles of each other. In those cases we need to identify if such cyclical duplicates exit. Much of the code here, then, is for examining such cases. The detection is done by comparing each loop to the existing loops, in sorted order. if there are any equivalents we know we have a duplicate.
The line shift @loop; is to remove to starting point, which is convenient to maintain up
until storing in the @loops array.
References
posted at: 17:54 by: Adam Russell | path: /perl | permanent link to this entry
2023-09-07
What's the Similar Frequency, Kenneth?
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of words made up of alphabets only. Write a script to find the number of pairs of similar words. Two words are similar if they consist of the same characters.
Solution
use v5.38;
use boolean;
sub is_similar{
my($s0, $s1) = @_;
my(%h0, %h1);
do { $h0{$_} = undef } for split //, $s0;
do { $h1{$_} = undef } for split //, $s1;
return false if keys %h0 != keys %h1;
do { return false if !exists $h1{$_} } for keys %h0;
return true;
}
sub similar_words_pairs_count{
my @words = @_;
my @similar;
do{
my $word_index = $_;
my @similar_temp = grep { $words[$word_index] ne $words[$_] &&
is_similar $words[$word_index], $words[$_] } $word_index + 1 .. @words - 1;
push @similar, @words[@similar_temp] if @similar_temp > 0;
} for 0 .. @words - 1;
return @similar + 0;
}
MAIN:{
say similar_words_pairs_count qw/aba aabb abcd bac aabc/;
say similar_words_pairs_count qw/aabb ab ba/;
say similar_words_pairs_count qw/nba cba dba/;
}
Sample Run
$ perl perl/ch-1.pl
2
3
0
Notes
The core of this problem is to count up the number of pairs of similar words. A clearly
good use of grep, but how to do that exactly? Well, here we define a subroutine
is_similar that returns a true/false value depending on if the words meet the definition
of similar given in the problem. That's done by expanding the words into arrays of
characters, stuffing those characters into hash key slots in order to force uniqueness,
and then seeing if the two key sets are equal.
Once we have the logic to determine similarity worked out we can then use it in grep and
count up the results.
Part 2
You are given an array of integers. Write a script to sort the given array in increasing order based on the frequency of the values. If multiple values have the same frequency then sort them in decreasing order.
Solution
use v5.38;
sub frequency_sort{
my(@numbers) = @_;
my %frequency;
do{$frequency{$_}++} for @numbers;
my $frequency_sorter = sub{
my $c = $frequency{$a} <=> $frequency{$b};
return $c unless !$c;
return $b <=> $a;
};
return sort $frequency_sorter @numbers;
}
MAIN:{
say join q/, /, frequency_sort 1, 1, 2, 2, 2, 3;
say join q/, /, frequency_sort 2, 3, 1, 3, 2;
say join q/, /, frequency_sort -1, 1, -6, 4, 5, -6, 1, 4, 1
}
Sample Run
$ perl perl/ch-2.pl
3, 1, 1, 2, 2, 2
1, 3, 3, 2, 2
5, -1, 4, 4, -6, -6, 1, 1, 1
Notes
This problem ended up being a bit more complex than it seemed after the first reading.
Perl makes this sort of complexity easy to manage though! sort can take a custom sorting
subroutine as an argument. That is what is done here, with the requirements of the
frequency sort for this problem implemented within the subroutine referenced by
$frequency_sorter. This is written as an anonymous subroutine in order to obtain a
closure around %frequency. Finally, observe that we can use the scalar reference
directly with sort. sort is flexible enough to know how to use the reference.
References
posted at: 17:08 by: Adam Russell | path: /perl | permanent link to this entry
2023-08-21
Not the MinMax Count
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of distinct integers. Write a script to find all elements that is neither minimum nor maximum. Return -1 if you can’t.
Solution
use v5.38;
sub not_min_max{
my($minimum, $maximum);
do{
$minimum = $_ if !$minimum || $_ < $minimum;
$maximum = $_ if !$maximum || $_ > $maximum;
} for @_;
my @r = grep { $_ ^ $minimum && $_ ^ $maximum } @_;
return @r ^ 0 ? @r : -1;
}
MAIN:{
say join q/, /, not_min_max 3, 2, 1, 4;
say join q/, /, not_min_max 3, 1;
say join q/, /, not_min_max 2, 1, 3;
}
Sample Run
$ perl perl/ch-1.pl
3, 2
-1
2
Notes
Once we find the maximum and minimum values, we need to remove them. Just to be different
I used the XOR ^ operator instead of !=. The effect is the same, a false (zero) value
is returned if the values are identical, true (one) otherwise.
Part 2
You are given a list of passenger details in the form “9999999999A1122”, where 9 denotes the phone number, A the sex, 1 the age and 2 the seat number. Write a script to return the count of all senior citizens (age >= 60).
Solution
use v5.38;
sub count_senior_citizens{
my $count = 0;
do{
my @a = unpack q/A10A1A2A2/, $_;
$count++ if $a[2] >= 60;
} for @_;
return $count;
}
MAIN:{
say count_senior_citizens qw/7868190130M7522 5303914400F9211 9273338290F4010/;
say count_senior_citizens qw/1313579440F2036 2921522980M5644/;
}
Sample Run
$ perl perl/ch-2.pl
2
0
Notes
It isn't all that often you find a nice clean use of unpack! This seems to be a very
nice opportunity: each passenger string has fixed field lengths.
The passenger strings themselves are just Perl scalar values. They are not, say, specially
constructed strings via pack. To unpack an ordinary scalar we can just use As in the
template string.
References
posted at: 20:27 by: Adam Russell | path: /perl | permanent link to this entry
2023-08-20
Separate and Count
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of positive integers. Write a script to separate the given array into single digits.
Solution
use v5.38;
sub separate_digits{
return separater([], @_);
}
sub separater{
my $seperated = shift;
return @{$seperated} if @_ == 0;
my @digits = @_;
push @{$seperated}, split //, shift @digits;
separater($seperated, @digits);
}
MAIN:{
say join q/,/, separate_digits 1, 34, 5, 6;
}
Sample Run
$ perl perl/ch-1.pl
1,3,4,5,6
Notes
It has been a while since I wrote recursive Perl code, this week's TWC offered two nice
chances to do so. The first call to separate_digits invokes the call to the recursive
subroutine separater, adding an array reference for the convenience of accumulating the
individual digits at each recursive step.
Within separater each number in the array is taken one at a time and expanded to its
individual digits. The digits are pushed into the accumulator. When we run of digits we
return the complete list of digits.
Part 2
You are given an array of words made up of alphabetic characters and a prefix. Write a script to return the count of words that starts with the given prefix.
Solution
use v5.38;
sub count_words{
return counter(0, @_);
}
sub counter{
my $count = shift;
my $prefix = shift;
return $count if @_ == 0;
my $word = shift;
$count++ if $word =~ m/^$prefix/;
counter($count, $prefix, @_);
}
MAIN:{
say count_words qw/at pay attention practice attend/;
say count_words qw/ja janet julia java javascript/;
}
Sample Run
$ perl perl/ch-2.pl
2
3
Notes
The exact same approach used for Part 1 is used here in the second part. Instead of accumulating am array of digits instead we increment the counter of words which start with the prefix characters.
References
posted at: 21:40 by: Adam Russell | path: /perl | permanent link to this entry
2023-07-23
Shuffled Operations
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a string and an array of indices of same length as string. Write a script to return the string after re-arranging the indices in the correct order.
Solution
use v5.38;
sub shuffle_string{
my($s, $indices) = @_;
my @s = split(//, $s);
my @t;
do { $t[$_] = shift @s } for @{$indices};
return join(q//, @t);
}
MAIN:{
say shuffle_string(q/lacelengh/, [3, 2, 0, 5, 4, 8, 6, 7, 1]);
say shuffle_string(q/rulepark/, [4, 7, 3, 1, 0, 5, 2, 6]);
}
Sample Run
$ perl perl/ch-1.pl
challenge
perlraku
Notes
I had to think of this one a bit! What we need to do is take each letter, from left to
right, and assign it a new position. It's not often you see a shift within another loop
but here that is the key to getting everything working.
Part 2
You are given an array of non-negative integers, @ints. Write a script to return the minimum number of operations to make every element equal zero.
Solution
use v5.38;
sub zero_array{
my $operations = 0;
do{
return $operations if 0 == unpack(q/%32I*/, pack(q/I*/, @_));
my $minimum = (sort { $a <=> $b } grep { $_ > 0 } @_)[0];
@_ = map { $_ > 0 ? $_ - $minimum : 0 } @_;
$operations++;
} for @_;
}
MAIN:{
say zero_array 1, 5, 0, 3, 5;
say zero_array 0;
say zero_array 2, 1, 4, 0, 3
}
Sample Run
$ perl perl/ch-2.pl
3
0
4
Notes
Usually I assign function arguments new names, even if I am just passing in a single array
of values like in this example. I decided this time to not do it, I don't think
readability is sacrificed. Provided the reader actually knows what @_ is I think for a
short function such as this it's fine. In fact, I think an argument could be made that
readability is actually enhanced since lines such as the one with both a sort and a
grep are kept to a shorter length.
References
posted at: 20:55 by: Adam Russell | path: /perl | permanent link to this entry
2023-07-13
Sentenced To Compute Differences
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a list of sentences. Write a script to find out the maximum number of words that appear in a single sentence.
Solution
use v5.38;
sub max_sentence_length{
my(@sentences) = @_;
my $max_words = -1;
do{
my @word_matches = $_ =~ m/(\w+)/g;
$max_words = @word_matches if @word_matches > $max_words;
} for @sentences;
return $max_words;
}
MAIN:{
my @list;
@list = ("Perl and Raku belong to the same family.", "I love Perl.",
"The Perl and Raku Conference.");
say max_sentence_length(@list);
@list = ("The Weekly Challenge.", "Python is the most popular guest language.",
"Team PWC has over 300 members.");
say max_sentence_length(@list);
}
Sample Run
$ perl perl/ch-1.pl
8
7
Notes
This is the perfect job for a regular expression! In fact \w is a special character
sequence which matches word characters, so they heart of the solution is to apply it
to the given sentences and count the matches.
The expression my @word_matches = $_ =~ m/(\w+)/g may look a little weird at first. What
is happening here is that we are collecting all groups of matchs (enclosed in parentheses
in the regex) into a single array. In this way, we immediately know the number of words
in each sentence, it is just the size of the array.
Part 2
You are given an array of integers. Write a script to return left right sum difference array.
Solution
use v5.38;
sub left_right_sum{
return unpack("%32I*", pack("I*", @_));
}
sub left_right_differences{
my(@left_sum, @right_sum);
for(my $i = 0; $i < @_; $i++){
push @left_sum, left_right_sum(@_[0 .. $i - 1]);
push @right_sum, left_right_sum(@_[$i + 1 .. @_ - 1]);
}
return map { abs($left_sum[$_] - $right_sum[$_]) } 0 .. @_ - 1;
}
MAIN:{
say join(q/, /, left_right_differences 10, 4, 8, 3);
say join(q/, /, left_right_differences 1);
say join(q/, /, left_right_differences 1, 2, 3, 4, 5);
}
Sample Run
$ perl perl/ch-2.pl
15, 1, 11, 22
0
14, 11, 6, 1, 10
Notes
The problem statement may be a little confusing at first. What we are trying to do here is to get two lists the prefix sums and suffix sums, also called the left and right sums. We then pairwise take the absolute values of each element in these lists to get the final result. Iterating over the list the prefix sums are the partial sums of the list elements to the left of the current element. The suffix sums are the partial sums of the list elements to the right of the current element.
With that understanding in hand the solution becomes much more clear! We iterate over the
list and then using slices get the prefix and suffix arrays for each element. Using my
favorite way to sum a list of numbers, left_right_sum() does the job with pack/unpack.
Finally, a map computes the set of differences.
References
posted at: 17:17 by: Adam Russell | path: /perl | permanent link to this entry
2023-02-05
Into the Odd Wide Valley
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of integers. Write a script to print 1 if there are THREE consecutive odds in the given array otherwise print 0.
Solution
use v5.36;
use boolean;
sub three_consecutive_odds{
my @numbers = @_;
my $consecutive_odds = 0;
{
my $x = pop @numbers;
$consecutive_odds++ if 1 == ($x & 1);
$consecutive_odds = 0 if 0 == ($x & 1);
return true if 3 == $consecutive_odds;
redo if @numbers;
}
return false;
}
MAIN:{
say three_consecutive_odds(1, 5, 3, 6);
say three_consecutive_odds(2, 6, 3, 5);
say three_consecutive_odds(1, 2, 3, 4);
say three_consecutive_odds(2, 3, 5, 7);
}
Sample Run
$ perl perl/ch-1.pl
1
0
0
1
Notes
Part 2
Given a profile as a list of altitudes, return the leftmost widest valley. A valley is defined as a subarray of the profile consisting of two parts: the first part is non-increasing and the second part is non-decreasing. Either part can be empty.
Solution
use v5.36;
use boolean;
use FSA::Rules;
sub widest_valley_rules{
my @altitudes = @_;
my @downslope;
my @upslope;
my $fsa = FSA::Rules->new(
move => {
do => sub{ my $state = shift;
$state->machine->{altitude} = [] if(!$state->machine->{altitude});
$state->machine->{plateau} = [] if(!$state->machine->{plateau});
$state->machine->{downslope} = [] if(!$state->machine->{downslope});
$state->machine->{upslope} = [] if(!$state->machine->{upslope});
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
move => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
@{$previous_altitudes} == 1;
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}else{false}
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
],
},
plateau => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, @{$state->machine->{plateau}};
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
$state->machine->{plateau} = [];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, @{$state->machine->{plateau}};
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
$state->machine->{plateau} = [];
}
}
],
},
downslope => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
#pop @{$state->machine->{downslope}};true;
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
$state->machine->{upslope} = [];
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
],
},
upslope => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
$previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2];
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
],
},
done => {
do => sub { my $state = shift;
say q/Valley: / . join(q/, /, @{$state->machine->{downslope}}, @{$state->machine->{upslope}});
}
},
);
return $fsa;
}
sub widest_valley{
my $rules = widest_valley_rules(@_);
$rules->start;
$rules->switch until $rules->at(q/done/);
my $graph_viz = $rules->graph();
}
MAIN:{
widest_valley 1, 5, 5, 2, 8;
widest_valley 2, 6, 8, 5;
widest_valley 2, 1, 2, 1, 3;
}
Sample Run
$ perl perl/ch-2.pl
Valley: 5, 5, 2, 8
Valley: 2, 6, 8
Valley: 2, 1, 2
Notes
References
posted at: 18:39 by: Adam Russell | path: /perl | permanent link to this entry
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
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
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.
Do an initial pass over the list to determine the largest gap.
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
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
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
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:
converts a given integer into an array of bits via
int2bits()flips the bits using an xor operation (the
mapinbinary_flip())converts the array of flipped bits to the decimal equivalent via
oct()which, despite the name, handles any decimal, binary, octal, and hex strings as input.
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
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:
sort the list O(n log n)
get the max element from the sorted list O(1)
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
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
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:
Compute the degree of any given array.
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
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
0 <= i < j < len(list)
list[i] + list[j] is divisible by k
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:
$x = $x - $y if $x >= $y
or
$y = $y - $x if $y >= $x (using the original value of $x)
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
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:
a + b > c
b + c > a
a + c > b
a + b + c is maximum.
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
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:
- take the input text and generate an image
- ocr the image
- the ocr process would ignore anything non-text (emojis and other symbols)
- the ocr process would possibly ignore the accent marks
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
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:
- We read in the file paths, one path (string) per line.
- The paths are sent to
deepest_path()where we create a 2d array. Each array element is an array reference of file sub paths. For example here$sub_paths[0]is[a, b, c, 1, x.pl]. - We sort the lengths of all the sub path array references to know how far we must search. We need only look as far as the shortest path after all.
- At each iteration we take column wise slices.
- For each column wise slice we check if all the sub paths are equal. We do this but putting all the sub path values into a hash as keys. If we have only one key value when done we know all the values are equal.
- As long as tall the sub paths are equal we accumulate it in
$deepest_path. $deepest_pathis returned when we are doing examining all sub paths. (Wechopthe trailing/). Done!
References
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'tNotes
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
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:
- Create an anonymous subroutine closure around
$ito perform the comparison. The subroutine is referenced in the variable$trimmer. - This subroutine reference is then passed to a recursive function along with the list.
- The recursive function accumulates numbers meeting the criteria in an array reference
$trimmed.unshiftis used to maintain the original ordering. I could have also, for example, processed the list of numbers in reverse and usingpush. I haven't usedunshiftin a long time so this seemed more fun. $trimmedis returned to when the list of numbers to be reviewed is exhausted.
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
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
posted at: 17:59 by: Adam Russell | path: /perl | permanent link to this entry
2022-08-07
Permuted Reversibly
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to find the smallest integer x such that x, 2x, 3x, 4x, 5x and 6x are permuted multiples of each other.
Solution
use strict;
use warnings;
use boolean;
sub is_permuted{
my($x, $y) = @_;
my(@x, @y);
map {$x[$_]++} split(//, $x);
map {$y[$_]++} split(//, $y);
return false if $#x != $#y;
my @matched = grep {(!$x[$_] && !$y[$_]) || ($x[$_] && $y[$_] && $x[$_] == $y[$_])} 0 .. @y - 1;
return true if @matched == @x;
return false;
}
sub smallest_permuted{
my $x = 0;
{
$x++;
redo unless is_permuted($x, 2 * $x) && is_permuted(2 * $x, 3 * $x) &&
is_permuted(3 * $x, 4 * $x) && is_permuted(4 * $x, 5 * $x) &&
is_permuted(5 * $x, 6 * $x);
}
return $x;
}
MAIN:{
print smallest_permuted . "\n";
}
Sample Run
$ perl perl/ch-1.pl
142857
Notes
The approach here is to check if any two numbers are permutations of each other by
counting up the digits for each and comparing the counts. A fun use of map and grep
but I will admit it is a bit unnecessary. I implemented solutions to this problem in
multiple languages and in doing so just sorted the lists of digits and compared them. Much
easier, but less fun!
Part 2
Write a script to find out all Reversible Numbers below 100.
Solution
use strict;
use warnings;
sub is_reversible{
my($x) = @_;
my @even_digits = grep { $_ % 2 == 0 } split(//, ($x + reverse($x)));
return @even_digits == 0;
}
sub reversibles_under_n{
my($n) = @_;
my @reversibles;
do{
$n--;
unshift @reversibles, $n if is_reversible($n);
}while($n > 0);
return @reversibles;
}
MAIN:{
print join(", ", reversibles_under_n(100)) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
10, 12, 14, 16, 18, 21, 23, 25, 27, 30, 32, 34, 36, 41, 43, 45, 50, 52, 54, 61, 63, 70, 72, 81, 90
Notes
My favorite use of Perl is to prototype algorithms. I'll get an idea for how to solve a problem and then quickly prove out the idea in Perl. Once demonstrated to be effective the same approach can be implemented in another language if required, usually for business reasons but also sometimes simply for performance.
The code here is concise, easy to read, and works well. It's also 3 times slower than a Fortran equivalent.
$ time perl perl/ch-2.pl
10, 12, 14, 16, 18, 21, 23, 25, 27, 30, 32, 34, 36, 41, 43, 45, 50, 52, 54, 61, 63, 70, 72, 81, 90
real 0m0.069s
user 0m0.048s
sys 0m0.020s
-bash-5.0$ time fortran/ch-2
10
12
14
16
18
21
23
25
27
30
32
34
36
41
43
45
50
52
54
61
63
70
72
81
90
real 0m0.021s
user 0m0.001s
sys 0m0.016s
That said, the Fortran took at least 3x longer to write. These are the tradeoffs that get considered on a daily basis!
References
posted at: 12:16 by: Adam Russell | path: /perl | permanent link to this entry
2022-07-30
Sunday Was Perfectly Totient
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to list the last sunday of every month in the given year.
Solution
use strict;
use warnings;
use Time::Piece;
sub last_sunday_month{
my($month, $year) = @_;
$month = "0$month" if $month < 10;
my $sunday;
my $t = Time::Piece->strptime("$month", "%m");
for my $day (20 .. $t->month_last_day()){
$t = Time::Piece->strptime("$day $month $year", "%d %m %Y");
$sunday = "$year-$month-$day" if $t->wday == 1;
}
return $sunday;
}
sub last_sunday{
my($year) = @_;
my @sundays;
for my $month (1 .. 12){
push @sundays, last_sunday_month($month, $year);
}
return @sundays;
}
MAIN:{
print join("\n", last_sunday(2022)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
2022-01-30
2022-02-27
2022-03-27
2022-04-24
2022-05-29
2022-06-26
2022-07-31
2022-08-28
2022-09-25
2022-10-30
2022-11-27
2022-12-25
Notes
When dealing with dates in Perl you have a ton of options, including implementing
everything on your own. I usually use the Time::Piece module. Here you can see why I
find it so convenient. With strptime you can create a new object from any conceivable
date string, for setting the upper bounds on iterating over the days of a month we can use
month_last_day, and there are many other convenient functions like this.
Part 2
Write a script to generate the first 20 Perfect Totient Numbers.
Solution
use strict;
use warnings;
use constant EPSILON => 1e-7;
sub distinct_prime_factors{
my $x = shift(@_);
my %factors;
for(my $y = 2; $y <= $x; $y++){
next if $x % $y;
$x /= $y;
$factors{$y} = undef;
redo;
}
return keys %factors;
}
sub n_perfect_totients{
my($n) = @_;
my $x = 1;
my @perfect_totients;
{
$x++;
my $totient = $x;
my @totients;
map {$totient *= (1 - (1 / $_))} distinct_prime_factors($x);
push @totients, $totient;
while(abs($totient - 1) > EPSILON){
map {$totient *= (1 - (1 / $_))} distinct_prime_factors($totient);
push @totients, $totient;
}
push @perfect_totients, $x if unpack("%32I*", pack("I*", @totients)) == $x;
redo if @perfect_totients < $n;
}
return @perfect_totients;
}
MAIN:{
print join(", ", n_perfect_totients(20)) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
3, 9, 15, 27, 39, 81, 111, 183, 243, 255, 327, 363, 471, 729, 2187, 2199, 3063, 4359, 4375, 5571
Notes
This code may look deceptively simple. In writing it I ended up hitting a few blockers that weren't obvious at first. The simplest one was my own misreading of how to compute totients using prime factors. We must use unique prime factors. To handle this I modified my prime factorization code to use a hash and by returning the keys we can get only the unique values. Next, while Perl is usually pretty good about floating point issues, in this case it was necessary to implement a standard epsilon comparison to check that the computed totient was equal to 1.
Actually, maybe I should say that such an epsilon comparison is always advised but in many cases Perl can let you get away without one. Convenient for simple calculations but not a best practice!
For doing serious numerical computing in Perl the best choice is of course to use PDL!
References
posted at: 12:08 by: Adam Russell | path: /perl | permanent link to this entry
2022-07-24
Permutations Ranked in Disarray on Mars
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the first 19 Disarium Numbers.
Solution
use strict;
use warnings;
use POSIX;
sub disarium_n{
my($n) = @_;
my @disariums;
map{
return @disariums if @disariums == $n;
my @digits = split(//, $_);
my $digit_sum = 0;
map{
$digit_sum += $digits[$_] ** ($_ + 1);
} 0 .. @digits - 1;
push @disariums, $digit_sum if $digit_sum == $_;
} 0 .. INT_MAX / 100;
}
MAIN:{
print join(", ", disarium_n(19)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 89, 135, 175, 518, 598, 1306, 1676, 2427, 2646798
Notes
I gave myself a writing prompt for this exercise: only use map. This turned out to
present a small issue and that is, how do we terminate out of a map early? This comes up
because we do not need to examine all numbers in the large range of 0 .. INT_MAX / 100.
Once we find the 19 numbers we require we should just stop looking. last will not work
from within a map it turns out. In this case a return works well. But suppose we did
not want to return out of the subroutine entirely? Well, I have tested it out and it
turns out that goto will work fine from within a map block as well!
That code would look something like this, where the CONTINUE block would have some more
code for doing whatever else was left to do.
sub disarium_n{
my($n) = @_;
my @disariums;
map{
goto CONTINUE if @disariums == $n;
my @digits = split(//, $_);
my $digit_sum = 0;
map{
$digit_sum += $digits[$_] ** ($_ + 1);
} 0 .. @digits - 1;
push @disariums, $digit_sum if $digit_sum == $_;
} 0 .. INT_MAX / 100;
CONTINUE:{
##
# more to do before we return
##
}
return @disariums;
}
Part 2
You are given a list of integers with no duplicates, e.g. [0, 1, 2]. Write two functions, permutation2rank() which will take the list and determine its rank (starting at 0) in the set of possible permutations arranged in lexicographic order, and rank2permutation() which will take the list and a rank number and produce just that permutation.
Solution
use strict;
use warnings;
package PermutationRanking{
use Mars::Class;
use List::Permutor;
attr q/list/;
attr q/permutations/;
attr q/permutations_sorted/;
attr q/permutations_ranked/;
sub BUILD{
my $self = shift;
my @permutations;
my %permutations_ranked;
my $permutor = new List::Permutor(@{$self->list()});
while(my @set = $permutor->next()) {
push @permutations, join(":", @set);
}
my @permutations_sorted = sort @permutations;
my $rank = 0;
for my $p (@permutations_sorted){
$permutations_ranked{$p} = $rank;
$rank++;
}
@permutations_sorted = map {[split(/:/, $_)]} @permutations_sorted;
$self->permutations_sorted(\@permutations_sorted);
$self->permutations_ranked(\%permutations_ranked);
}
sub permutation2rank{
my($self, $list) = @_;
return $self->permutations_ranked()->{join(":", @{$list})};
}
sub rank2permutation{
my($self, $n) = @_;
return "[" . join(", ", @{$self->permutations_sorted()->[$n]}) . "]";
}
}
package main{
my $ranker = new PermutationRanking(list => [0, 1, 2]);
print "[1, 0, 2] has rank " . $ranker->permutation2rank([1, 0, 2]) . "\n";
print "[" . join(", ", @{$ranker->list()}) . "]" . " has permutation at rank 1 --> " . $ranker->rank2permutation(1) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
[1, 0, 2] has rank 2
[0, 1, 2] has permutation at rank 1 --> [0, 2, 1]
Notes
I've been enjoying trying out Al Newkirk's Mars OOP framework. When it comes to Object
Oriented code in Perl I've usually just gone with the default syntax or Class::Struct.
I am far from a curmudgeon when it comes to OOP though, as I have a lot of experience
using Java and C++. What I like about Mars is that it reminds me of the best parts of
Class::Struct as well as the best parts of how Java does OOP. The code above, by its
nature does not require all the features of Mars as here we don't need much in the way
of Roles or Interfaces.
Perhaps guided by my desire to try out Mars more I have taken a definitively OOP approach
to this problem. From the problem statement the intent may have been to have two
independent functions. This code has two methods which depend on the constructor (defined
within sub BUILD) to have populated the internal class variables needed.
There is a small trick here that the sorting is to be by lexicograohic order, which
conveniently is the default for Perl's default sort. That doesn't really buy us any
algorithmic improvement in performance, in fact it hurts it! Other approaches exist for
this problem which avoid producing all permutations of the list.
References
posted at: 19:34 by: Adam Russell | path: /perl | permanent link to this entry
2022-07-17
Suffering Succotash!
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 out if the given number is an Esthetic Number.
Solution
use strict;
use warnings;
use boolean;
sub is_esthetic{
my($n) = @_;
my @digits = split(//, $n);
my $d0 = pop @digits;
while(@digits){
my $d1 = pop @digits;
return false if abs($d1 - $d0) != 1;
$d0 = $d1;
}
return true;
}
MAIN:{
my $n;
$n = 5456;
print "$n is ";
print "esthetic\n" if is_esthetic($n);
print "not esthetic\n" if !is_esthetic($n);
$n = 120;
print "$n is ";
print "esthetic\n" if is_esthetic($n);
print "not esthetic\n" if !is_esthetic($n);
}
Sample Run
$ perl perl/ch-1.pl
5456 is esthetic
120 is not esthetic
Notes
I started to write this solution and then kept coming back to it, considering if there is a more elegant approach. If there is I could not come up with it on my own over this past week! This doesn't seem all that bad, just a bit "mechanical" perhaps?
- Break the number into an array of digits
- Do a pairwise comparison of successive digits by popping them off the array one at a time and retaining the most recently popped digit for the next iteration's comparison.
- If at any point the "different by 1" requirement is not met, return false.
- If we complete all comparisons without a failure, return true.
Part 2
Write a script to generate first 10 members of Sylvester's sequence.
Solution
use strict;
use warnings;
use bigint;
sub sylvester_n{
my($n) = @_;
my @terms = (2, 3);
my %product_table;
$product_table{"2,3"} = 6;
while(@terms < $n){
my $term_key = join(",", @terms);
my $term = $product_table{$term_key} + 1;
push @terms, $term;
$product_table{"$term_key,$term"} = $term * $product_table{$term_key};
}
return @terms;
}
MAIN:{
print join(", ", sylvester_n(10)). "\n";
}
Sample Run
$ perl perl/ch-2.pl
2, 3, 7, 43, 1807, 3263443, 10650056950807, 113423713055421844361000443, 12864938683278671740537145998360961546653259485195807, 165506647324519964198468195444439180017513152706377497841851388766535868639572406808911988131737645185443
Notes
Much like the first part I considered what might be an optimal way to compute this. Here the standard recursion and memoization would be most appropriate, I believe. Just to mix things up a little I implemented my own memoization like lookup table and computed the terms iteratively. Otherwise though, the effect is largely the same in that for each new term we need not reproduce any previous multiplications.
These terms get large almost immediately! use bigint is clearly necessary here. An
additional optimization would be the use of Tie::Hash and Tie::Array to save memory as
we compute larger and larger terms. Since TWC 173.2 only specified 10 terms I left that
unimplemented.
Finally, I should note that the title of this blog draws from Sylvester the Cat, not Sylvester the Mathematician! Sylvester the Cat's famous phrase is "Suffering Succotash!". See the link in the references for an example. Not everyone may not be familiar, so see the video link below! The comments on that video have some interesting facts about the phrase and the character.
References
posted at: 21:30 by: Adam Russell | path: /perl | permanent link to this entry
2022-07-10
Partition the Summary
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given two positive integers, $n and $k. Write a script to find out the Prime Partition of the given number. No duplicates are allowed.
Solution
use strict;
use warnings;
use boolean;
use Math::Combinatorics;
sub sieve_atkin{
my($upper_bound) = @_;
my @primes = (2, 3, 5);
my @atkin = (false) x $upper_bound;
my @sieve = (1, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 49, 53, 59);
for my $x (1 .. sqrt($upper_bound)){
for(my $y = 1; $y <= sqrt($upper_bound); $y+=2){
my $m = (4 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (1, 13, 17, 29, 37, 41, 49, 53) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 1; $x <= sqrt($upper_bound); $x += 2){
for(my $y = 2; $y <= sqrt($upper_bound); $y += 2){
my $m = (3 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (7, 19, 31, 43) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 2; $x <= sqrt($upper_bound); $x++){
for(my $y = $x - 1; $y >= 1; $y -= 2){
my $m = (3 * $x ** 2) - ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (11, 23, 47, 59) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
my @m;
for my $w (0 .. ($upper_bound / 60)){
for my $s (@sieve){
push @m, 60 * $w + $s;
}
}
for my $m (@m){
last if $upper_bound < ($m ** 2);
my $mm = $m ** 2;
if($atkin[$m]){
for my $m2 (@m){
my $c = $mm * $m2;
last if $c > $upper_bound;
$atkin[$c] = false;
}
}
}
map{ push @primes, $_ if $atkin[$_] } 0 .. @atkin - 1;
return @primes;
}
sub prime_partition{
my($n, $k) = @_;
my @partitions;
my @primes = sieve_atkin($n);
my $combinations = Math::Combinatorics->new(count => $k, data => [@primes]);
while(my @combination = $combinations->next_combination()){
push @partitions, [@combination] if unpack("%32I*", pack("I*", @combination)) == $n;
}
return @partitions;
}
MAIN:{
my($n, $k);
$n = 18, $k = 2;
map{
print "$n = " . join(", ", @{$_}) . "\n"
} prime_partition($n, $k);
print"\n\n";
$n = 19, $k = 3;
map{
print "$n = " . join(", ", @{$_}) . "\n"
} prime_partition($n, $k);
}
Sample Run
$ perl perl/ch-1.pl
18 = 7, 11
18 = 5, 13
19 = 3, 11, 5
Notes
Only when writing this short blog did I realize there is a far more efficient way of doing this!
Here we see a brute force exhaustion of all possible combinations. This works alright for
when $n and $k are relatively small. For larger values a procedure like this would be
better,
1. Obtain all primes $p < $n 2. Start with $n and compute $m = $n - $p for all $p 3. If $m is prime and $k = 2 DONE 4. Else set $n = $m and repeat, computing a new $m with all $p < $m stopping with the same criteria if $m is prime and $k is satisfied
This procedure would be a natural fit for recursion, if you were in the mood for that sort of thing.
Part 2
You are given an array of integers. Write a script to compute the five-number summary of the given set of integers.
Solution
use strict;
use warnings;
sub five_number_summary{
my @numbers = @_;
my($minimum, $maximum, $first_quartile, $median, $third_quartile);
my @sorted = sort {$a <=> $b} @numbers;
$minimum = $sorted[0];
$maximum = $sorted[@sorted - 1];
if(@sorted % 2 == 0){
my $median_0 = $sorted[int(@sorted / 2) - 1];
my $median_1 = $sorted[int(@sorted / 2)];
$median = ($median_0 + $median_1) / 2;
my @lower_half = @sorted[0 .. int(@sorted / 2)];
my $median_lower_0 = $lower_half[int(@lower_half / 2) - 1];
my $median_lower_1 = $lower_half[int(@lower_half / 2)];
$first_quartile = ($median_lower_0 + $median_lower_1) / 2;
my @upper_half = @sorted[int(@sorted / 2) .. @sorted];
my $median_upper_0 = $upper_half[int(@upper_half / 2) - 1];
my $median_upper_1 = $upper_half[int(@upper_half / 2)];
$third_quartile = ($median_upper_0 + $median_upper_1) / 2;
}
else{
$median = $sorted[int(@sorted / 2)];
$first_quartile = [@sorted[0 .. int(@sorted / 2)]]->[int(@sorted / 2) / 2];
$third_quartile = [@sorted[int(@sorted / 2) .. @sorted]]->[(@sorted - int(@sorted / 2)) / 2];
}
return {
minimum => $minimum,
maximum => $maximum,
first_quartile => $first_quartile,
median => $median,
third_quartile => $third_quartile
};
}
MAIN:{
my @numbers;
my $five_number_summary;
@numbers = (6, 3, 7, 8, 1, 3, 9);
print join(", ", @numbers) . "\n";
$five_number_summary = five_number_summary(@numbers);
map{
print "$_: $five_number_summary->{$_}\n";
} keys %{$five_number_summary};
print "\n\n";
@numbers = (2, 6, 3, 8, 1, 5, 9, 4);
print join(", ", @numbers) . "\n";
$five_number_summary = five_number_summary(@numbers);
map{
print "$_: $five_number_summary->{$_}\n";
} keys %{$five_number_summary};
print "\n\n";
@numbers = (1, 2, 2, 3, 4, 6, 6, 7, 7, 7, 8, 11, 12, 15, 15, 15, 17, 17, 18, 20);
print join(", ", @numbers) . "\n";
$five_number_summary = five_number_summary(@numbers);
map{
print "$_: $five_number_summary->{$_}\n";
} keys %{$five_number_summary};
}
Sample Run
$ perl perl/ch-2.pl
6, 3, 7, 8, 1, 3, 9
third_quartile: 8
maximum: 9
minimum: 1
first_quartile: 3
median: 6
2, 6, 3, 8, 1, 5, 9, 4
median: 4.5
first_quartile: 2.5
minimum: 1
maximum: 9
third_quartile: 7
1, 2, 2, 3, 4, 6, 6, 7, 7, 7, 8, 11, 12, 15, 15, 15, 17, 17, 18, 20
maximum: 20
third_quartile: 15
first_quartile: 5
median: 7.5
minimum: 1
Notes
Note that the case of an even or odd number of elements of the list (and sublists) requires slightly special handling.
References
posted at: 20:39 by: Adam Russell | path: /perl | permanent link to this entry
2022-07-03
Abundant Composition
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the first twenty Abundant Odd Numbers.
Solution
use strict;
use warnings;
sub proper_divisors{
my($n) = @_;
my @divisors;
for my $x (1 .. $n / 2){
push @divisors, $x if $n % $x == 0;
}
return @divisors;
}
sub n_abundant_odd{
my($n) = @_;
my $x = 0;
my @odd_abundants;
{
push @odd_abundants, $x if $x % 2 == 1 && unpack("%32I*", pack("I*", proper_divisors($x))) > $x;
$x++;
redo if @odd_abundants < $n;
}
return @odd_abundants;
}
MAIN:{
print join(", ", n_abundant_odd(20)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
945, 1575, 2205, 2835, 3465, 4095, 4725, 5355, 5775, 5985, 6435, 6615, 6825, 7245, 7425, 7875, 8085, 8415, 8505, 8925
Notes
The solution here incorporated a lot of elements from previous weekly challenges. That is
to say it is quite familiar, I continue to be a fan of redo as well as the pack/unpack
method of summing the elements of an array.
Part 2
Create sub compose($f, $g) which takes in two parameters $f and $g as subroutine refs and returns subroutine ref i.e. compose($f, $g)->($x) = $f->($g->($x)).
Solution
use strict;
use warnings;
sub f{
my($x) = @_;
return $x + $x;
}
sub g{
my($x) = @_;
return $x * $x;
}
sub compose{
my($f, $g) = @_;
return sub{
my($x) = @_;
return $f->($g->($x));
};
}
MAIN:{
my $h = compose(\&f, \&g);
print $h->(7) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
98
Notes
This problem incorporates some interesting concepts, especially from functional programming. Treating functions in a first class way, that is, passing them as parameters, manipulating them, dynamically generating new ones are commonly performed in functional programming languages such as Lisp and ML. Here we can see that Perl can quite easily do these things as well!
References
posted at: 12:39 by: Adam Russell | path: /perl | permanent link to this entry
2022-06-19
Brilliantly Discover Achilles' Imperfection
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the first 20 Brilliant Numbers.
Solution
use strict;
use warnings;
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 is_brilliant{
my($n) = @_;
my @factors = prime_factor($n);
return @factors == 2 && length($factors[0]) == length($factors[1]);
}
sub n_brilliants{
my($n) = @_;
my @brilliants;
my $i = 0;
{
push @brilliants, $i if is_brilliant($i);
$i++;
redo if @brilliants < $n;
}
return @brilliants;
}
MAIN:{
print join(", ", n_brilliants(20)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
4, 6, 9, 10, 14, 15, 21, 25, 35, 49, 121, 143, 169, 187, 209, 221, 247, 253, 289, 299
Notes
The solution here incorporated a lot of elements from previous weekly challenges. That is
to say it is quite familiar, I continue to be a fan of redo!
Part 2
Write a script to generate the first 20 Achilles Numbers.
Solution
use strict;
use warnings;
use POSIX;
use boolean;
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 is_achilles{
my($n) = @_;
my @factors = prime_factor($n);
for my $factor (@factors){
return false if $n % ($factor * $factor) != 0;
}
for(my $i = 2; $i <= sqrt($n); $i++) {
my $d = log($n) / log($i) . "";
return false if ceil($d) == floor($d);
}
return true;
}
sub n_achilles{
my($n) = @_;
my @achilles;
my $i = 1;
{
$i++;
push @achilles, $i if is_achilles($i);
redo if @achilles < $n;
}
return @achilles;
}
MAIN:{
print join(", ", n_achilles(20)) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
72, 108, 200, 288, 392, 432, 500, 648, 675, 800, 864, 968, 972, 1125, 1152, 1323, 1352, 1372, 1568, 1800
Notes
This problem revealed something interesting with how, apparently, certain functions will handle integer and floating point values. The issue arises when we are computing logarithms. We can see the issue in isolation in a one liner.
perl -MPOSIX -e '$d = log(9) / log(3); print ceil($d) . "\t" . floor($d) . "\t$d\n"'
which prints 3 2 2. Notice that log(9) / log(3) is exactly 2 but, ok,
floating point issues maybe it is 2.0000000001 and ceil will give 3.
But why does this work?
perl -MPOSIX -e '$d = sqrt(9); print ceil($d) . "\t" . floor($d) . "\t$d\n"'
which gives 3 3 3. I am not sure what sqrt is doing differently? I guess
how it stores the result internally? By the way, I am doing this to check is the result is
an integer. That is if ceil($x) == floor($x), but that isn't working here as expected but
I have used that trick in the past. I guess only with sqrt in the past though so never
encountered this.
The trick to work around this, in the solution to the challenge is like this:
perl -MPOSIX -e '$d = log(9) / log(3) . ""; print ceil($d) . "\t" . floor($d) . "\t$d\n"'
this does what I want and gives 2 2 2. I guess that drops the
infinitesimally small decimal part when concatenating and converting to a string which
stays gone when used numerically?
Of course, there are other ways to do this. For example abs($x - int(x)) < 1e-7 will
ensure that, within a minuscule rounding error, $x is an integer.
References
posted at: 12:39 by: Adam Russell | path: /perl | permanent link to this entry
2022-06-12
Take the Long Way Home
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Calculate the first 13 Perrin Primes.
Solution
use strict;
use warnings;
use boolean;
use Math::Primality qw/is_prime/;
sub n_perrin_prime_r{
my($n, $perrins, $perrin_primes) = @_;
return $perrin_primes if keys %{$perrin_primes} == $n;
my $perrin = $perrins->[@{$perrins} - 3] + $perrins->[@{$perrins} - 2];
push @{$perrins}, $perrin;
$perrin_primes->{$perrin} = -1 if is_prime($perrin);
n_perrin_prime_r($n, $perrins, $perrin_primes);
}
sub perrin_primes{
return n_perrin_prime_r(13, [3, 0, 2], {});
}
MAIN:{
print join(", ", sort {$a <=> $b} keys %{perrin_primes()}) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
2, 3, 5, 7, 17, 29, 277, 367, 853, 14197, 43721, 1442968193, 792606555396977
Notes
The solution here incorporated a lot of elements from previous weekly challenges. That is
to say it is quite familiar, we recursively generate the sequence which is stored as hash
keys and, once completed, sort and print the results. The hash keys are a convenient,
although perhaps slightly bulky, way of handling the repeated 5 term at the beginning.
The terms strictly increase thereafter.
Part 2
You are given an integer greater than 1. Write a script to find the home prime of the given number.
Solution
use strict;
use warnings;
use bigint;
use Math::Primality qw/is_prime/;
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 home_prime{
my($n) = @_;
return $n if is_prime($n);
my $s = $n;
{
$s = join("", prime_factor($s));
redo if !is_prime($s);
}
return $s;
}
MAIN:{
print home_prime(10) . "\n";
print home_prime(16) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
773
31636373
Notes
So you think eight is low
Calculating HP(8) should be an easy go
Take the long way home
Take the long way home
The second part of this week's challenge was a lot of fun as it presented some unexpected
behavior. Here we are asked to compute the Home Prime of any given number. The process
for doing so is, given N to take the prime factors for N and concatenate them
together. If the result is prime then we are done, that is the Home Prime of N,
typically written HP(N). This is an easy process to repeat, and in many cases the
computation is a very quick one. However, in some cases, the size of the interim numbers
on the path to HP(N) grow extremely large and the computation bogs down, whence take the
long way home! As an example, the computation of HP(8) is still running after 24 hours
on my M1 Mac Mini.
References
posted at: 23:34 by: Adam Russell | path: /perl | permanent link to this entry
2022-06-05
Circular Primes and Getting Complex
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to find out first 10 circular primes having at least 3 digits (base 10).
Solution
use strict;
use warnings;
use boolean;
use Math::Primality qw/is_prime/;
sub is_circular_prime{
my($x, $circular) = @_;
my @digits = split(//, $x);
my @rotations;
for my $i (0 .. @digits - 1){
@digits = (@digits[1 .. @digits - 1], $digits[0]);
my $candidate = join("", @digits) + 0;
push @rotations, $candidate;
return false if !is_prime($candidate);
}
map{$circular->{$_} = -1} @rotations;
return true;
}
sub first_n_circular_primes{
my($n) = @_;
my $i = 100;
my %circular;
my @circular_primes;
{
if(!$circular{$i} && is_circular_prime($i, \%circular)){
push @circular_primes, $i;
}
$i++;
redo if @circular_primes < $n;
}
return @circular_primes;
}
sub first_10_circular_primes{
return first_n_circular_primes(10);
}
MAIN:{
print join(", ", first_10_circular_primes()) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
113, 197, 199, 337, 1193, 3779, 11939, 19937, 193939, 199933
Notes
There is a bit of a trick here where we need to disallow repeated use of previous cycles. For example, 199 and 919 and considered to be the same circular prime (we count the first occurrence only) since 919 is a rotation of 199.
I don't ordinarily use a lot of references, especially hash references, in my Perl code
but here it seems appropriate. It makes sense to break the rotating and primality checking
to it's own function but we also need to track all the unique rotations. Wishing to avoid
a global variable, which in this case wouldn't be all that bad anyway, having a single
hash owned by the caller and updated by the primality checking function makes the most
sense to me. The code is arguably cleaner then if we had multiple return values, to
include the rotations. Another option, which would have avoided the use of a reference
and multiple return values would have been to have is_circular_prime return either
undef or an array containing the rotations. This would have added a little extra
bookkeeping code to first_n_circular_primes in order to maintain the master list of all
seen rotations so I considered it, simply as a matter of style, to be just a little less
elegant than the use of the reference.
Part 2
Implement a subroutine gamma() using the Lanczos approximation method.
Solution
use strict;
use warnings;
use POSIX;
use Math::Complex;
use constant EPSILON => 1e-07;
sub lanczos{
my($z) = @_;
my @p = (676.5203681218851, -1259.1392167224028, 771.32342877765313, -176.61502916214059, 12.507343278686905, -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7);
my $y;
$z = new Math::Complex($z);
if(Re($z) < 0.5){
$y = M_PI / (sin(M_PI * $z) * lanczos(1 - $z));
}
else{
$z -= 1;
my $x = 0.99999999999980993;
for my $i (0 .. @p - 1){
$x += ($p[$i] / ($z + $i + 1));
}
my $t = $z + @p - 0.5;
$y = sqrt(2 * M_PI) * $t ** ($z + 0.5) * exp(-1 * $t) * $x;
}
return Re($y) if abs(Im($y)) <= EPSILON;
return $y;
}
sub gamma{
return lanczos(@_);
}
MAIN:{
printf("%.2f\n",gamma(3));
printf("%.2f\n",gamma(5));
printf("%.2f\n",gamma(7));
}
Sample Run
$ perl perl/ch-2.pl
2.00
24.00
720.00
Notes
The code here is based on a Python sample code that accompanies the Wikipedia article and there really isn't much room for additional stylistic flourishes. Well, maybe that for loop could have been a map. For this sort of numeric algorithm there really isn't much variation in what is otherwise a fairly raw computation.
The interesting thing here is that it is by all appearances a faithful representation of
the Lanczos Approximation and yet the answers seem to siffer from a slight floating point
accuracy issue. That is the expected answers vary from what is computed here by a small
decimal part, apparently anyway. Perl is generally quite good at these sorts of things so
getting to the bottom of this may require a bit more investigation! I wonder if it has to
do with how Math::Complex handles the real part of the number?
References
posted at: 10:46 by: Adam Russell | path: /perl | permanent link to this entry
2022-05-22
SVG Plots of Points and Lines
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Plot lines and points in SVG format.
Solution
use strict;
use warnings;
sub svg_begin{
return <<BEGIN;
<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd"> <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
BEGIN
}
sub svg_end{
return "";
}
sub svg_point{
my($x, $y) = @_;
return "<circle cx=\"$x\" cy=\"$y\" r=\"1\" />";
}
sub svg_line{
my($x0, $y0, $x1, $y1) = @_;
return "<line x1=\"$x0\" x2=\"$x1\" y1=\"$y0\" y2=\"$y1\" style=\"stroke:#006600;\" />";
}
sub svg{
my @lines = @_;
my $svg = svg_begin;
for my $line (@_){
$svg .= svg_point(@{$line}) if @{$line} == 2;
$svg .= svg_line(@{$line}) if @{$line} == 4;
}
return $svg . svg_end;
}
MAIN:{
my @lines;
while(){
chomp;
push @lines, [split(/,/, $_)];
}
print svg(@lines);
}
__DATA__
53,10
53,10,23,30
23,30
Sample Run
$ perl perl/ch-1.pl
<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd"> <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<circle cx="53" cy="10" r="1" /><line x1="53" x2="23" y1="10" y2="30" /><circle cx="23" cy="30" r="1" /></svg>
Notes
Doing the SVG formatting from scratch is not so bad, especially when sticking only to points and lines. The boiler plate XML is taken from a known good SVG example and used as a template.
Part 2
Compute a linear regression and output an SVG plot of the points and regression line.
Solution
use strict;
use warnings;
sub svg_begin{
return <<BEGIN;
<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd"> <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
BEGIN
}
sub svg_end{
return "";
}
sub svg_point{
my($x, $y) = @_;
return "<circle cx=\"$x\" cy=\"$y\" r=\"1\" />";
}
sub svg_line{
my($x0, $y0, $x1, $y1) = @_;
return "<line x1=\"$x0\" x2=\"$x1\" y1=\"$y0\" y2=\"$y1\" style=\"stroke:#006600;\" />";
}
sub svg{
my @lines = @_;
my $svg = svg_begin;
for my $line (@_){
$svg .= svg_point(@{$line}) if @{$line} == 2;
$svg .= svg_line(@{$line}) if @{$line} == 4;
}
return $svg . svg_end;
}
sub linear_regression{
my(@points) = @_;
# 1. Calculate average of your X variable.
my $sum = 0;
my $x_avg;
map{$sum += $_->[0]} @points;
$x_avg = $sum / @points;
# 2. Calculate the difference between each X and the average X.
my @x_differences = map{$_->[0] - $x_avg} @points;
# 3. Square the differences and add it all up. This is Sx.
my $sx = 0;
my @squares = map{$_ * $_} @x_differences;
map{$sx += $_} @squares;
# 4. Calculate average of your Y variable.
$sum = 0;
my $y_avg;
map{$sum += $_->[1]} @points;
$y_avg = $sum / @points;
my @y_differences = map{$_->[1] - $y_avg} @points;
# 5. Multiply the differences (of X and Y from their respective averages) and add them all together. This is Sxy.
my $sxy = 0;
@squares = map {$y_differences[$_] * $x_differences[$_]} 0 .. @points - 1;
map {$sxy += $_} @squares;
# 6. Using Sx and Sxy, you calculate the intercept by subtracting Sx / Sxy * AVG(X) from AVG(Y).
my $m = $sxy / $sx;
my $y_intercept = $y_avg - ($sxy / $sx * $x_avg);
my @sorted = sort {$a->[0] <=> $b->[0]} @points;
my $max_x = $sorted[@points - 1]->[0];
return [0, $y_intercept, $max_x + 10, $m * ($max_x + 10) + $y_intercept];
}
MAIN:{
my @points;
while(){
chomp;
push @points, [split(/,/, $_)];
}
push @points, linear_regression(@points);
print svg(@points);
}
__DATA__
333,129
39,189
140,156
292,134
393,52
160,166
362,122
13,193
341,104
320,113
109,177
203,152
343,100
225,110
23,186
282,102
284,98
205,133
297,114
292,126
339,112
327,79
253,136
61,169
128,176
346,72
316,103
124,162
65,181
159,137
212,116
337,86
215,136
153,137
390,104
100,180
76,188
77,181
69,195
92,186
275,96
250,147
34,174
213,134
186,129
189,154
361,82
363,89
Sample Run
$ perl perl/ch-2.pl
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">
<svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<circle cx="333" cy="129" r="1" /><circle cx="39" cy="189" r="1" /><circle cx="140" cy="156" r="1" /><circle cx="292" cy="134" r="1" /><circle cx="393" cy="52" r="1" /><circle cx="160" cy="166" r="1" /><circle cx="362" cy="122" r="1" /><circle cx="13" cy="193" r="1" /><circle cx="341" cy="104" r="1" /><circle cx="320" cy="113" r="1" /><circle cx="109" cy="177" r="1" /><circle cx="203" cy="152" r="1" /><circle cx="343" cy="100" r="1" /><circle cx="225" cy="110" r="1" /><circle cx="23" cy="186" r="1" /><circle cx="282" cy="102" r="1" /><circle cx="284" cy="98" r="1" /><circle cx="205" cy="133" r="1" /><circle cx="297" cy="114" r="1" /><circle cx="292" cy="126" r="1" /><circle cx="339" cy="112" r="1" /><circle cx="327" cy="79" r="1" /><circle cx="253" cy="136" r="1" /><circle cx="61" cy="169" r="1" /><circle cx="128" cy="176" r="1" /><circle cx="346" cy="72" r="1" /><circle cx="316" cy="103" r="1" /><circle cx="124" cy="162" r="1" /><circle cx="65" cy="181" r="1" /><circle cx="159" cy="137" r="1" /><circle cx="212" cy="116" r="1" /><circle cx="337" cy="86" r="1" /><circle cx="215" cy="136" r="1" /><circle cx="153" cy="137" r="1" /><circle cx="390" cy="104" r="1" /><circle cx="100" cy="180" r="1" /><circle cx="76" cy="188" r="1" /><circle cx="77" cy="181" r="1" /><circle cx="69" cy="195" r="1" /><circle cx="92" cy="186" r="1" /><circle cx="275" cy="96" r="1" /><circle cx="250" cy="147" r="1" /><circle cx="34" cy="174" r="1" /><circle cx="213" cy="134" r="1" /><circle cx="186" cy="129" r="1" /><circle cx="189" cy="154" r="1" /><circle cx="361" cy="82" r="1" /><circle cx="363" cy="89" r="1" /><line x1="0" x2="403" y1="200.132272535582" y2="79.2498029303056" /></svg>
Notes
I re-use the SVG code from Part 1 and add in the linear regression calculation. Continuing
a small habit from the past few weeks of these challenges I am making much use of map to
keep the code as small, and yet still readable, as possible. The linear regression
calculation is fairly straightforward, as much as I hate having a terse writeup on this
I am not sure I have much more to say!
References
posted at: 23:16 by: Adam Russell | path: /perl | permanent link to this entry
2022-05-15
Happily Computing Prime Palindrome Numbers
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to find all prime numbers less than 1000, which are also palindromes in base 10.
Solution
use strict;
use warnings;
use Math::Primality qw/is_prime/;
sub palindrome_primes_under{
my($n) = shift;
my @palindrome_primes;
{
$n--;
unshift @palindrome_primes, $n if(is_prime($n) && join("", reverse(split(//, $n))) == $n);
redo if $n > 1;
}
return @palindrome_primes;
}
MAIN:{
print join(", ", palindrome_primes_under(1000));
}
Sample Run
$ perl perl/ch-1.pl
2, 3, 5, 7, 11, 101, 131, 151, 181, 191, 313, 353, 373, 383, 727, 757, 787, 797, 919, 929
Notes
I have become incorrigible in my use of redo! The novelty just hasn't worn off I
suppose. There is nothing really wrong with it, of course, it's just not particularly
modern convention what with it's vaguely goto like behavior. Anyway, there's not a whole
lot to cover here. All the real work is done in the one line which tests both primality
and, uh, palindromedary.
Part 2
Write a script to find the first 8 Happy Numbers in base 10.
Solution
use strict;
use warnings;
use boolean;
use constant N => 8;
sub happy{
my $n = shift;
my @seen;
my $pdi = sub{
my $n = shift;
my $total = 0;
{
$total += ($n % 10)**2;
$n = int($n / 10);
redo if $n > 0;
}
return $total;
};
{
push @seen, $n;
$n = $pdi->($n);
redo if $n > 1 && (grep {$_ == $n} @seen) == 0;
}
return boolean($n == 1);
}
MAIN:{
my $i = 0;
my @happy;
{
$i++;
push @happy, $i if happy($i);
redo if @happy < N;
}
print join(", ", @happy) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
1, 7, 10, 13, 19, 23, 28, 31
Notes
This solution has even more redo, huzzah! Again, fairly straightforward bit of code
which follows the definitions. The happiness check is done using a perfect digit
invariant (PDI) function, here rendered as an anonymous inner subroutine. A good chance
here when looking at this code to remind ourselves that $n inside that anonymous
subroutine is in a different scope and does not effect the outer $n!
References
posted at: 23:58 by: Adam Russell | path: /perl | permanent link to this entry
2022-05-08
Bitwise AndSums and Skip Summations: Somewhat Complicated Uses of Map
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given a list of numbers. Write a script to calculate the sum of the bitwise & operator for all unique pairs.
Solution
use strict;
use warnings;
sub sum_bitwise{
my $sum = 0;
for my $i (0 .. @_ - 2){
my $x = $_[$i];
map {$sum += ($x & $_)} @_[$i + 1 .. @_ - 1];
}
return $sum;
}
MAIN:{
print sum_bitwise(1, 2, 3) . "\n";
print sum_bitwise(2, 3, 4) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
3
2
Notes
Since most of the code for both parts of the challenge was fairly straightforward I thought it was worthwhile to concentrate on how I use map. In both cases are somewhat non-trivial. Here map is used in lieu of a nested loop. Effectively it is equivalent but the resulting code is more compact. The for loop iterates over the array of numbers. At each iteration the current number is saved as $x. We then need to work pairwise through the rest of the array. To do this we use map over the slice of the array representing the elements after $x. Within the for loop/map $sum is continuously updated with the bitwise & results as required.Part 2
Given a list of numbers @n, generate the skip summations.
use strict;
use warnings;
sub skip_summations{
my @lines = ([@_]);
for my $i (1 .. @_ - 1){
my @skip = @{$lines[$i - 1]}[1 .. @{$lines[$i - 1]} - 1];
my $line = [map {my $j = $_; $skip[$j] + unpack("%32I*", pack("I*", @skip[0 .. $j - 1]))} 0 .. @skip - 1];
push @lines, $line;
}
return @lines;
}
MAIN:{
for my $line (skip_summations(1, 2, 3, 4, 5)){
print join(" ", @{$line}) . "\n";
}
print "\n";
for my $line (skip_summations(1, 3, 5, 7, 9)){
print join(" ", @{$line}) . "\n";
}
}
Sample Run
$ perl perl/ch-2.pl
1 2 3 4 5
2 5 9 14
5 14 28
14 42
42
1 3 5 7 9
3 8 15 24
8 23 47
23 70
70
Notes
Again map is used in place of a nested loop. With the use of pack/unpack we further replace work that would take place inside yet another loop. While much more concise it is reasonable to concede a slight loss of readability, for the untrained eye anyway. The map in the code above works over a list of numbers representing array indices of the previously computed line of summations. For each element we get the slice of the array representing the ones before it and then use pack/unpack to get the sum which is then added to the current element. Each use of map here generates the next line and so we enclose the map in square brackets [] to place bthe results in an array reference which is the pushed onto the array of alllines to be returned.References
posted at: 13:52 by: Adam Russell | path: /perl | permanent link to this entry
2022-05-01
The Weekly Challenge 162
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the check digit of a given ISBN-13 code.
Solution
use strict;
use warnings;
sub isbn_check_digit{
my($isbn) = @_;
my $i = 0;
my @weights = (1, 3);
my $check_sum = 0;
my $check_digit;
map {$check_sum += $_ * $weights[$i]; $i = $i == 0 ? 1 : 0} split(//, $isbn);
$check_digit = $check_sum % 10;
return 10 - $check_digit;
}
MAIN:{
print isbn_check_digit(978030640615) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
7
References
posted at: 14:34 by: Adam Russell | path: /perl | permanent link to this entry
2022-04-24
Are Abecedarians from Abecedaria?
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Output or return a list of all abecedarian words in the dictionary, sorted in decreasing order of length.
Solution
use strict;
use warnings;
sub abecedarian{
sort {$b->[1] <=> $a->[1]} map {[$_, length($_)]} grep{chomp; $_ eq join("", sort {$a cmp $b} split(//, $_))} @_;
}
MAIN:{
open(DICTIONARY, "dictionary");
for my $abc (abecedarian(<DICTIONARY>)){
print $abc->[0] . " length: " . $abc->[1] . "\n";
}
close(DICTIONARY);
}
Sample Run
$ perl perl/ch-1.pl
abhors length: 6
accent length: 6
accept length: 6
access length: 6
accost length: 6
almost length: 6
begins length: 6
.
.
.
ox length: 2
qt length: 2
xx length: 2
a length: 1
m length: 1
x length: 1
Notes
The Power of Perl! This problem reduces to one (one!) line of code, plus a few more to manage reading the data and printing the results.
Reading from left to right what is happening? Well, we are sorting, in descending order,
an array of array references based on the value of the element at index 1. Where does this
array of array refs come from? From a map which takes in an array of strings and stores
each string in an array ref with it's length. Where Does the array fo strings come from?
From the grep which takes the list of strings sent to sub abecedarian as arguments,
splits them into characters, sorts the characters, and then sees if the characters in
sorted order are in the same order as the original word demonstrating that the word fits
the definition of Abecedarian.
Ordinarily I will make an effort to avoid these more complicated expressions but in this case the reading of it seems to proceed in a straightforward way as a chain of easily understood sub-expressions.
Part 2
Using the provided dictionary generate at least one pangram.
Solution
use strict;
use warnings;
use Lingua::EN::Tagger;
sub pangram{
my %tagged_words;
my $tagger = new Lingua::EN::Tagger;
for my $word (@_){
chomp($word);
my $tagged_text = $tagger->add_tags($word);
$tagged_text =~ m/<([a-z]*)>([a-z]*<)/;
my $tag = $1;
if($tagged_words{$tag}){
push @{$tagged_words{$tag}}, $word;
}
else{
$tagged_words{$tag} = [$word];
}
}
##
# generate sentences from random words in a (somewhat) grammatical way
##
my $sentence;
my @dets = @{$tagged_words{det}};
my @adjs = @{$tagged_words{jj}};
my @nouns = @{$tagged_words{nn}};
my @verbs = @{$tagged_words{vb}};
my @cons = @{$tagged_words{cc}};
my @adverbs = @{$tagged_words{vb}};
do{
my $det0 = $dets[rand @dets];
my $adj0 = $adjs[rand @adjs];
my $noun = $nouns[rand @nouns];
my $verb = $verbs[rand @verbs];
my $det1 = $dets[rand @dets];
my $adj1 = $adjs[rand @adjs];
my $object0 = $nouns[rand @nouns];
my $conj = $cons[rand @cons];
my $det2 = $dets[rand @dets];
my $adj2 = $adjs[rand @adjs];
my $object1 = $nouns[rand @nouns];
my $adverb = $adverbs[rand @adverbs];
my %h;
for my $c (split(//, "$det0$adj0$noun$verb$det1$adj1$object0$conj$det2$adj2$object1")){
$h{$c} = undef;
}
$sentence = "$det0 $adj0 $noun $verb $det1 $adj1 $object0 $conj $det2 $adj2 $object1" if keys %h == 26;
}while(!$sentence);
return $sentence;
}
MAIN:{
open(DICTIONARY, "dictionary");
print pangram(<DICTIONARY>) . "\n";
close(DICTIONARY);
}
Sample Run
$ perl perl/ch-2.pl
each toxic windpipe jeopardize some quick wafted less every favorable arrangement
$ perl perl/ch-2.pl
each exaggerated wilier jeopardize all marketable enunciate and every quirky forgiveness
Notes
I made this a bit ore complicated then it could have been, although I didn't really get into the "Bonus" questions (see the original problem statement on the Weekly Challenge site for details). The main complication I chose to take on here is that I wanted to have the generated pangrams to be reasonably grammatically correct. To simplify things I chose a single template that the generated sentence can take on. The words for the sentences are then chosen at random according to the template. Amazingly this works! As part of this simplification words that need to match in number (plural, singular) will not quite line up. This is certainly doable, but represented more work than I was willing to put in at the time.
In order to get words to fit the template I make a first pass through the dictionary and assign parts of speech. This is another simplification, and seems to be a little rough. This is likely due to the fact that Lingua::EN::Tagger is very sophisticated and uses both its own dictionary and statistical techniques to determine parts of speech from bodies of text. Given just one word at a time its powers are not able to be used fully.
Since words are chosen completely at random the process to generate a valid pangram can take several minutes. The sentences generated can take on a slightly poetic aspect, there are some decent verses amidst all the chaos!
References
posted at: 16:10 by: Adam Russell | path: /perl | permanent link to this entry
2022-04-17
Four is Equilibrium
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 < 10. Write a script to generate english text sequence starting with the English cardinal representation of the given number, the word "is" and then the English cardinal representation of the count of characters that made up the first word, followed by a comma. Continue until you reach four.
Solution
use strict;
use warnings;
my %cardinals = (
1 => "one",
2 => "two",
3 => "three",
4 => "four",
5 => "five",
6 => "six",
7 => "seven",
8 => "eight",
9 => "nine"
);
sub four_is_magic{
my($n, $s) = @_;
$s = "" if !$s;
return $s .= "four is magic" if $n == 4;
$s .= $cardinals{$n} . " is " . $cardinals{length($cardinals{$n})} . ", ";
four_is_magic(length($cardinals{$n}), $s);
}
MAIN:{
print four_is_magic(5) . "\n";
print four_is_magic(7) . "\n";
print four_is_magic(6) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
five is four, four is magic
seven is five, five is four, four is magic
six is three, three is five, five is four, four is magic
Notes
I was thinking of a clever way I might do this problem. I got nothing! Too much Easter candy perhaps? Anyway, I am not sure there is much tow rite about here as it's an otherwise straightforward use of hashes.
Part 2
You are give an array of integers, @n. Write a script to find out the Equilibrium Index of the given array, if found.
Solution
use strict;
use warnings;
sub equilibrium_index{
for my $i (0 .. @_ - 1){
return $i if unpack("%32I*", pack("I*", @_[0 .. $i])) == unpack("%32I*", pack("I*", @_[$i .. @_ - 1]));
}
return -1;
}
MAIN:{
print equilibrium_index(1, 3, 5, 7, 9) . "\n";
print equilibrium_index(1, 2, 3, 4, 5) . "\n";
print equilibrium_index(2, 4, 2) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
3
-1
1
Notes
Like Part 1 above this problem allows for a pretty cut and dry solution. Also, similarly, I can't see a more efficient and/or creative way to solve this one. Maybe I should have just gone for obfuscated then?!?!? In any event, if nothing else, I always like using pack/unpack. I always considered it one of Perl's super powers!
References
posted at: 09:59 by: Adam Russell | path: /perl | permanent link to this entry
2022-04-10
Farey and Farey Again, but in a Mobius Way
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 compute the Farey Sequence of the order $n.
Solution
use strict;
use warnings;
use POSIX;
sub farey{
my($order) = @_;
my @farey;
my($s, $t, $u, $v, $x, $y) = (0, 1, 1, $order, 0, 0);
push @farey, "$s/$t", "$u/$v";
while($y != 1 && $order > 1){
$x = POSIX::floor(($t + $order) / $v) * $u - $s;
$y = POSIX::floor(($t + $order) / $v) * $v - $t;
push @farey, "$x/$y";
($s, $t, $u, $v) = ($u, $v, $x, $y);
}
return @farey;
}
MAIN:{
print join(", ", farey(7)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
0/1, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 2/5, 3/7, 1/2, 4/7, 3/5, 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 1/1
Notes
Here is an iterative implementation of what seems to be a fairly standard recursive definition of the Farey Sequence. Well, "standard" may be over stating it as this sequence is seemingly fairly obscure. Fare-ly obscure? Ha! Anyway, this all seems fairly straightforward and the main thing to note here is that the sequence elements are stored as strings. This seems the most convenient way to keep them for display although in the next part of the challenge we'll use the sequence elements in a numerical way.
Part 2
You are given a positive number $n. Write a script to generate the Moebius Number for the given number.
Solution
use strict;
use warnings;
use POSIX;
use Math::Complex;
sub farey{
my($order) = @_;
my @farey;
my($s, $t, $u, $v, $x, $y) = (0, 1, 1, $order, 0, 0);
push @farey, "$s/$t", "$u/$v";
while($y != 1 && $order > 1){
$x = POSIX::floor(($t + $order) / $v) * $u - $s;
$y = POSIX::floor(($t + $order) / $v) * $v - $t;
push @farey, "$x/$y";
($s, $t, $u, $v) = ($u, $v, $x, $y);
}
return @farey;
}
sub mertens{
my($n) = @_;
my @farey = farey($n);
my $mertens = 0;
map {$mertens += exp(2 * M_PI * i * eval($_))} @farey;
$mertens += -1;
return Re($mertens);
}
sub moebius{
my($n) = @_;
return 1 if $n == 1;
return sprintf("%.f", (mertens($n) - mertens($n - 1)));
}
MAIN:{
map {print moebius($_) . "\n"} (5, 10, 20);
}
Sample Run
$ perl perl/ch-2.pl
-1
1
0
Notes
We can consider this second task of the challenge to be a continuation of the first. Here
the Farey Sequence code is used again. But why? Well, in order to compute the Moebius
Number we use an interesting property. The Mertens Function of $n is defined as the
sum of the first $n Moebius Numbers. There is an alternative and equivalent definition
of the Mertens Function, however, that use the Farey Sequence. In the alternative
definition The Mertens Function is equivalent to what is shown in sub mertens:
the sum of the natural logarithm base raised to the power of two times pi times i times
the k-th element of the Farey Sequence.
In Perl: map {$mertens += exp(2 * M_PI * i * eval($_))} @farey;
Thus to compute the n-th Moebius Number we compute the n-th and n-th - 1 Mertens Function and subtract as shown.
Be aware that this computation requires the use of Math::Complex, a core module which
defines constants and operations on complex numbers. It's how we are able to use i in
sub mertens.
References
posted at: 11:45 by: Adam Russell | path: /perl | permanent link to this entry
2022-03-20
Persnickety Pernicious and Weird
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the first 10 Pernicious Numbers.
Solution
use strict;
use warnings;
use Math::Primality qw/is_prime/;
sub count_bits{
my($n) = @_;
my $total_count_set_bit = 0;
while($n){
my $b = $n & 1;
$total_count_set_bit++ if $b;
$n = $n >> 1;
}
return $total_count_set_bit;
}
sub first_n_pernicious{
my($n) = @_;
my @pernicious;
my $x = 1;
do{
my $set_bits = count_bits($x);
push @pernicious, $x if is_prime($set_bits);
$x++;
}while(@pernicious < $n);
return @pernicious;
}
MAIN:{
print join(", ", first_n_pernicious(10)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
3, 5, 6, 7, 9, 10, 11, 12, 13, 14
Notes
Number Theory was one of my favorite classes as an undergraduate. This sort of challenge is fun, especially if you dive into the background of these sequences and try to learn more about them. Computing them is fairly straightforward, especially here where the two functions are largely drawn from past TWCs.
Part 2
You are given number, $n > 0. Write a script to find out if the given number is a Weird Number.
Solution
use strict;
use warnings;
use boolean;
use Data::PowerSet q/powerset/;
sub factor{
my($n) = @_;
my @factors = (1);
foreach my $j (2 .. sqrt($n)){
push @factors, $j if $n % $j == 0;
push @factors, ($n / $j) if $n % $j == 0 && $j ** 2 != $n;
}
return @factors;
}
sub is_weird{
my($x) = @_;
my @factors = factor($x);
my $sum = unpack("%32I*", pack("I*", @factors));
for my $subset (@{powerset(@factors)}){
return false if unpack("%32I*", pack("I*", @{$subset})) == $x;
}
return boolean($sum > $x);
}
MAIN:{
print is_weird(12) . "\n";
print is_weird(70) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
0
1
Notes
This task kind of bothered me, not because of the complexity of the task itself; the code was overall not extremely demanding. Rather anytime when I want to make use of Data::PowerSet I get a bit anxious that there may be a far more elegant way of proceeding! After coming up blank on alternatives I just went with this, but I'll probably still have this in the back of my mind for a few more days.
References
posted at: 18:29 by: Adam Russell | path: /perl | permanent link to this entry