RabbitFarm
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
2022-03-13
Fortunate Pisano
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to produce the first eight Fortunate Numbers (unique and sorted).
Solution
use strict;
use warnings;
use boolean;
use Math::Primality qw/is_prime/;
use constant N => 10_000;
sub sieve_atkin{
my($n) = @_;
my @primes = (2, 3, 5);
my $upper_bound = int($n * log($n) + $n * log(log($n)));
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 first_n_fortunate{
my($n) = @_;
my @primes = sieve_atkin(N);
my @fortunates;
my $x = 1;
do{
my @first_n_primes = @primes[0 .. $x - 1];
my $product_first_n_primes = 1;
map {$product_first_n_primes *= $_} @first_n_primes;
my $m = 1;
do{
$m++;
}while(!is_prime($product_first_n_primes + $m));
if(!grep {$m == $_} @fortunates){
unshift @fortunates, $m;
}
$x++;
}while(@fortunates != $n);
return sort {$a <=> $b} @fortunates;
}
MAIN:{
print join(", ", first_n_fortunate(8)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
3, 5, 7, 13, 17, 19, 23, 37
Notes
Yet another re-use of my Sieve of Adkin code! Here the sieve is used to generate primes
for us to compute primorials, the product of the first n prime numbers. A Fortunate
Number is a sequence in which each kth term is the number m such that for the
primorial of the first k primes summed with the smallest m,m > 1 such that the sum
is prime. It is an unproven conjecture in Number Theory that all terms of the Fortunate
Numbers sequence are prime.
Here the code follows pretty directly from the definition with the added restrictions that we must eliminate duplicates and sort the results.
Part 2
Write a script to find the period of the third Pisano Period.
Solution
use strict;
use warnings;
use constant N => 1_000_000_000;
sub fibonacci_below_n{
my($n, $fibonaccis) = @_;
$fibonaccis = [1, 1] if !$fibonaccis;
my $f = $fibonaccis->[@{$fibonaccis} - 2] + $fibonaccis->[@{$fibonaccis} - 1];
if($f < $n){
push @{$fibonaccis}, $f;
fibonacci_below_n($n, $fibonaccis);
}
else{
return $fibonaccis;
}
}
sub multiplicative_order{
my($a, $n) = @_;
my $k = 1;
my $result = 1;
while($k < $n){
$result = ($result * $a) % $n;
return $k if $result == 1;
$k++;
}
return -1 ;
}
sub fibonacci_period_mod_n{
my($n) = @_;
my $fibonaccis = fibonacci_below_n(N);
my $k = 1;
for my $f (@{$fibonaccis}){
if($f % $n == 0){
return $k * multiplicative_order($fibonaccis->[$k+1], $n);
}
$k++;
}
return -1;
}
MAIN:{
print fibonacci_period_mod_n(3) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
8
Notes
It is possible to compute the Pisano period in a fairly direct way. First you must
determine the smallest Fibonacci Number evenly divisible by the modulus. Record the index
of this term in the sequence, call it k. Compute the multiplicative order M of the
k+1st term with the given modulus. The Pisano period is then k * M.
The above code implements that procedure fairly directly. One possible change would be to not pre-compute Fibonacci terms as done here, but for this small problem it hardly matters. Take care if trying this out on very large terms, however.
References
posted at: 19:10 by: Adam Russell | path: /perl | permanent link to this entry
2022-03-06
Padovan Prime Directive: Find the Missing Permutations
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given possible permutations of the string "PERL". Write a script to find any permutations missing from the list.
Solution
use strict;
use warnings;
use Algorithm::Loops q/NestedLoops/;
sub factorial{
my($n) = @_;
return 1 if $n == 1;
$n * factorial($n - 1);
}
sub missing_permutations{
my($permutations, $s) = @_;
my @missing;
##
# remove any duplicates
##
my %permutations;
map {$permutations{$_}=undef} @{$permutations};
$permutations = [keys %permutations];
##
# get the letters missing in each slot
##
my @missing_letters;
for my $i (0 .. length($s) - 1){
my %slot_counts;
my @ith_letters = map {my @a = split(//, $_); $a[$i]} @{$permutations};
map{$slot_counts{$_}++} @ith_letters;
$missing_letters[$i] = [grep {$slot_counts{$_} != factorial(length($s) - 1)} keys %slot_counts];
}
##
# determine which missing letters form missing permutations
##
my $nested = NestedLoops(\@missing_letters);
while (my @set = $nested->()){
my $candidate = join("", @set);
my @matched = grep {$candidate eq $_} @{$permutations};
push @missing, $candidate if !@matched;
}
return @missing;
}
MAIN:{
my @missing = missing_permutations(
["PELR", "PREL", "PERL", "PRLE", "PLER", "PLRE", "EPRL", "EPLR", "ERPL",
"ERLP", "ELPR", "ELRP", "RPEL", "RPLE", "REPL", "RELP", "RLPE", "RLEP",
"LPER", "LPRE", "LEPR", "LRPE", "LREP"], "PERL"
);
print join(", ", @missing) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
LERP
Notes
Here I tried to write as general a solution as possible. This code should handle any number of missing permutations, provided that there are no duplicate letters within the starting word.
The approach is to first consider each position in the starting word as a "slot" and then check which letters are missing from each slot. In the code above we assume that each letter from the starting word appears in each slot at least once.
Once we know the missing letters we form new permutations with them and see which ones are missing from the initial list. To cut down on the tedious bookkeeping involved I used the Algorithm::Loops module to generate the candidate permutations from the known missing letters.
An even more general solution would not only catch any number of missing permutations but also allow for duplicate letters in the starting word and an input containing permutations which so not have at least one occurrence of each letter per slot.
Part 2
Write a script to compute the first 10 distinct Padovan Primes.
Solution
use strict;
use warnings;
use Math::Primality qw/is_prime/;
sub first_n_padovan_primes{
my($n) = @_;
my @padovan_primes;
my @padovans = (1, 1, 1);
{
push @padovans, $padovans[@padovans - 2] + $padovans[@padovans - 3];
push @padovan_primes, $padovans[@padovans - 1] if is_prime($padovans[@padovans - 1]);
redo if @padovan_primes <= $n;
}
return @padovan_primes[1..@padovan_primes - 1];
}
MAIN:{
print join(", ", first_n_padovan_primes(10)) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
2, 3, 5, 7, 37, 151, 3329, 23833, 13091204281, 3093215881333057
Notes
Before really looking at the sample solutions for this problem I decided that my approach would be generat e giant list of primes and then check against that list to determine if a new sequence element was prime or not. Nice idea, but it doesn't scale that well for this problem! Yes, it worked for a smaller number of Padovan Primes but to catch the first ten would require generating an enormous list of prime numbers. Better in this case to use something like Math::Primality to check each candidate.
References
posted at: 18:43 by: Adam Russell | path: /perl | permanent link to this entry
2022-02-27
Finding the Factorials and Factorions That Are Left
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to determine the first ten members of the Left Factorials sequence.
Solution
use strict;
use warnings;
use POSIX;
use constant UPPER_BOUND => INT_MAX/1000;
sub left_factorials_sieve{
my($n) = @_;
my @sieve = (0 .. UPPER_BOUND);
my $x = 2;
{
my @sieve_indices = grep { $_ <= $x || $_ % $x == 0 } 0 .. @sieve - 1;
@sieve = map{ $sieve[$_] } @sieve_indices;
$x++;
redo if $x <= $n;
}
return @sieve[1 .. @sieve - 1];
}
MAIN:{
print join(", ", left_factorials_sieve(10)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
1, 2, 4, 10, 34, 154, 874, 5914, 46234, 409114
Notes
The problem statement for this refers to a On-Line Encyclopedia of Integer Sequences
entry. That OEIS entry mentions some interesting facts about the sequence, including the
sieve technique used here. Officially the sequence seems to start with 0 but since the
example shows it starting with 1 here the initial 0 element is removed.
There is nothing special about the choice of UPPER_BOUND it is just an arbitrarily large
number which fits the purpose. I chose the number via trial and error, but it seems there
is a straightforward provable upper bound U required to get a sequence of required
sequence length N. If this were a math text then I as the author would be compelled to
leave a frustrating note that finding the upper bound is left as an exercise for the
reader. Ha!
Part 2
Write a script to figure out if the given integer is a factorion.
Solution
use strict;
use warnings;
use boolean;
sub factorial{
my($n) = @_;
return 1 if $n == 1;
$n * factorial($n - 1);
}
sub is_factorion{
my($n) = @_;
return boolean($n == unpack("%32I*", pack("I*", map {factorial($_)} split(//, $n))));
}
MAIN:{
print is_factorion(145) . "\n";
print is_factorion(123) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
1
0
Notes
In this solution I tried to optimize for the least amount of code. Not quite a golfed
solution, but compact, to be sure. The digits are obtained via split, passed to our
totally boring recursive factorial() function, the sum of the resulting factorials taken
using pack, and then that sum compared to $n. For convenience in stringifying the
output boolean() is used.
References
posted at: 19:55 by: Adam Russell | path: /perl | permanent link to this entry
2022-02-06
Fibonacci Words That Yearn to Be Squarefree
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given two strings having the same number of digits, $a and $b. Write a script to
generate Fibonacci Words by concatenation of the previous two strings. Print the 51st
of the first term having at least 51 digits.
Solution
use strict;
use warnings;
sub _fibonacci_words_51{
my($accumulated) = @_;
my $i = @{$accumulated} - 1;
my $next = $accumulated->[$i - 1] . $accumulated->[$i];
return substr($next, 51 - 1, 1) if length($next) >= 51;
push @{$accumulated}, $next;
_fibonacci_words_51($accumulated);
}
sub fibonacci_words{
my($u, $v) = @_;
return _fibonacci_words_51([$u, $v]);
}
MAIN:{
print fibonacci_words(q[1234], q[5678]) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
7
Notes
Fibonacci sequences are often an introductory example of recursion. This solution keeps
with that recursive tradition. sub _fibonacci_words_51 takes a single argument, an array
reference which stores the sequence terms. At each recursive step the next term is
computed and checked for the terminating condition.
Part 2
Write a script to generate all square-free integers <= 500.
Solution
use strict;
use warnings;
use constant LIMIT => 500;
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 square_free{
my @square_free;
for my $x (1 .. LIMIT){
my @factors = prime_factor($x);
my @a;
map {$a[$_]++} @factors;
@a = grep {$_ && $_ > 1} @a;
push @square_free, $x if !@a;
}
return @square_free;
}
main:{
print join(", ", square_free()) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
1, 2, 3, 5, 6, 7, 10, 11, 13, 14, 15, 17, 19, 21, 22, 23, 26, 29, 30, 31, 33, 34, 35, 37, 38, 39, 41, 42, 43, 46, 47, 51, 53, 55, 57, 58, 59, 61, 62, 65, 66, 67, 69, 70, 71, 73, 74, 77, 78, 79, 82, 83, 85, 86, 87, 89, 91, 93, 94, 95, 97, 101, 102, 103, 105, 106, 107, 109, 110, 111, 113, 114, 115, 118, 119, 122, 123, 127, 129, 130, 131, 133, 134, 137, 138, 139, 141, 142, 143, 145, 146, 149, 151, 154, 155, 157, 158, 159, 161, 163, 165, 166, 167, 170, 173, 174, 177, 178, 179, 181, 182, 183, 185, 186, 187, 190, 191, 193, 194, 195, 197, 199, 201, 202, 203, 205, 206, 209, 210, 211, 213, 214, 215, 217, 218, 219, 221, 222, 223, 226, 227, 229, 230, 231, 233, 235, 237, 238, 239, 241, 246, 247, 249, 251, 253, 254, 255, 257, 258, 259, 262, 263, 265, 266, 267, 269, 271, 273, 274, 277, 278, 281, 282, 283, 285, 286, 287, 290, 291, 293, 295, 298, 299, 301, 302, 303, 305, 307, 309, 310, 311, 313, 314, 317, 318, 319, 321, 322, 323, 326, 327, 329, 330, 331, 334, 335, 337, 339, 341, 345, 346, 347, 349, 353, 354, 355, 357, 358, 359, 362, 365, 366, 367, 370, 371, 373, 374, 377, 379, 381, 382, 383, 385, 386, 389, 390, 391, 393, 394, 395, 397, 398, 399, 401, 402, 403, 406, 407, 409, 410, 411, 413, 415, 417, 418, 419, 421, 422, 426, 427, 429, 430, 431, 433, 434, 435, 437, 438, 439, 442, 443, 445, 446, 447, 449, 451, 453, 454, 455, 457, 458, 461, 462, 463, 465, 466, 467, 469, 470, 471, 473, 474, 478, 479, 481, 482, 483, 485, 487, 489, 491, 493, 494, 497, 498, 499
Notes
This solution makes use of sub prime_factor which frequently comes in handy in these
challenges. Beyond getting the prime factors the only other requirement is to determine
that none are repeated. This is done by a counting array, created with a map and then
checked with grep for any entries greater than 1. If such an entry exists then we know
that there was a duplicate prime factor and that number is not square free.
References
posted at: 17:00 by: Adam Russell | path: /perl | permanent link to this entry
2022-01-29
Calling a Python Function From Perl
Part 1
Recently the question came up of how to call a Python function from Perl. Here is one way to do it.
The method here is to use Expect.pm to create a subprocess containing the Python repl. Python code is then loaded and called interactively. In my experience this is good for calling, say, a BERT model on some text from Perl. This approach is minimalistic as compared to other solutions such as standing up a Fast API instance to serve the model. Furthermore, this same pattern can be used for any arbitrary Python code you may need to call from Perl.
While this works well it does introduce additional complexity to an application. If at all possible it is preferable to re-write the Python functionality in Perl. An ideal use case would be where it would be too laborious to re-implement the Python code in Perl. Imagine, say, we want to use KeyBERT to extract keywords from a given body of text. In this case we may be doing substantial data and text processing in Perl and merely need to call out to Python for this single function. If at some point KeyBERT were to become available natively to Perl, perhaps through the Apache MXNet bindings, then that interface should be preferred. If nothing else, the performance improvement would be dramatic.
Solution
use strict;
use warnings;
##
# A simple example of calling a Python function
# from a Perl script using a Python repl started
# as a subprocess.
##
use Expect;
use boolean;
use constant TIMEOUT => 0.25;
use constant PYTHON => q[/usr/bin/python];
sub create_python{
my($io) = @_;
my $python = do{
local $/;
;
};
$$io = new Expect();
$$io->log_stdout(false);
$$io->raw_pty(true);
$$io->spawn(PYTHON);
$$io->send("$python\n\n");
$$io->expect(TIMEOUT, q[-re] , q|m/[0-9]*/|);
$$io->clear_accum();
}
sub call_python_sample{
my($io, $arg) = @_;
print $$io->send("sample(" . $arg . ")\n");
$$io->expect(TIMEOUT, q[-re], qr[\d+]);
my $r = $$io->exp_match();
$$io->clear_accum();
return $r;
}
MAIN:{
my($io);
create_python(\$io);
print call_python_sample(\$io, 1) . "\n";
print call_python_sample(\$io, 9) . "\n";
}
__DATA__
import os
os.system("stty -echo")
def sample(a):
print(str(a + 1))
The results
$ perl call_python_.pl
2
10
Notes
The code here is a minimum working example. Well, fairly minimal in that I could have avoided breaking things up into multiple subroutines. In terms of cleanliness and explainability these divisions make sense, with only the added need to pass a reference to an Expect object back and forth as a parameter.
For a self-contained example the Python code we are going to run is contained in the DATA section. For more complex use cases it would make sense to have the Python code in separate files which could be read in and loaded. They could also be specified directly as arguments to the Python interpreter.
sub create_pythoninstantiates a new Expect object, sets some parameters for the object, and spawns the Python repl. We also clear the Expect buffers so that upon the next invocation we need not worry about the Python header messages.sub call_python_samplecalls the function of interest. Here it is justsample()which takes a single argument, adds 1 to the argument, and prints out the result.
Effectively what we are doing is interprocess communication using text passed between the
two processes. Perl knows nothing of the state of the Python code, and vice versa. If you
call a Python function which does not print a value to STDOUT then you will need to add
your own print() call. This is not actually so bad a situation since Expect works by
pattern matching on the expected (pun intended!) output. To ensure you are collecting the
right values some massaging of what the Python code is doing is to be anticipated
(pun avoided!). For example, suppose we want to call the KeyBERT function to extract key
words from some given text. We might consider writing a wrapper function which takes
the output from KeyBERT.extract_keywords (a list of tuples, each tuple a pair: key
phrase and a distance) and concatenates and prints each of the pairs to STDOUT on a single
line. In this way our Perl regex can most easily pick up the phrase/distance pairs.
Expect is a very mature tool, with a generous set of options and abilities. This sort of use is really just the tip of the iceberg. In terms of Perl being a "Glue Language" consider Expect to be a key ingredient that causes the glue to stick. Peruse the documentation for further inspiration.
References
posted at: 16:30 by: Adam Russell | path: /perl | permanent link to this entry
2022-01-16
Primes and Pentagonals
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate first 20 left-truncatable prime numbers in base 10.
Solution
use strict;
use warnings;
use boolean;
use constant N => 10_000;
sub sieve_atkin{
my($n) = @_;
my @primes = (2, 3, 5);
my $upper_bound = int($n * log($n) + $n * log(log($n)));
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 truncatable{
my($prime, $primes) = @_;
return false if $prime =~ m/0/;
my @truncatable = map { my $p = substr($prime, -1 * $_, $_); grep {$p == $_} @{$primes}} 1 .. length($prime);
return @truncatable == length($prime);
}
sub first_n_truncatable_primes{
my($n) = @_;
my @primes = sieve_atkin(N);
my @truncatable;
for my $prime (@primes){
push @truncatable, $prime if truncatable($prime, \@primes);
last if @truncatable == $n;
}
return @truncatable;
}
MAIN:{
print join(", ", first_n_truncatable_primes(20)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
2, 3, 5, 7, 13, 17, 23, 37, 43, 47, 53, 67, 73, 83, 97, 113, 137, 167, 173, 197
Notes
First off, I am re-using the Sieve of Atkin code I wrote for a previous challenge. These challenges somewhat frequently have a prime number component so, if I get a chance, I'll compose that code into it's own module. If it weren't for the copy/paste of the Sieve of Atkin code then this solution would be very short! This sort of string manipulation is where Perl excels and the determination of whether a number is left truncatable takes only a few lines.
Part 2
Write a script to find the first pair of Pentagon Numbers whose sum and difference are also a Pentagon Number.
Solution
use strict;
use warnings;
use constant N => 10_000;
sub n_pentagon_numbers{
my($n) = @_;
my @pentagon_numbers;
my $x = 1;
my %h;
do{
my $pentagon = $x * (3 * $x - 1) / 2;
push @pentagon_numbers, $pentagon;
$h{"$pentagon"} = $x;
$x++;
}while(@pentagon_numbers < $n);
return (\@pentagon_numbers, \%h);
}
sub pairs_pentagon{
my($n) = @_;
my($pentagons, $lookup) = n_pentagon_numbers(N);
my @pairs;
for my $x (0 .. @{$pentagons} - 1){
for my $y (0 .. @{$pentagons} - 1){
unless($x == $y){
my($sum, $difference) = ($pentagons->[$x] + $pentagons->[$y], abs($pentagons->[$x] - $pentagons->[$y]));
if($lookup->{$sum} && $lookup->{$difference}){
my($s, $t) = ($x + 1, $y + 1);
push @pairs, ["P($s)", "P($t)"]
}
}
last if @pairs == $n;
}
last if @pairs == $n;
}
return @pairs;
}
sub first_pair_pentagon{
return [pairs_pentagon(1)];
}
MAIN:{
print join(", ", @{first_pair_pentagon()->[0]}) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
P(1020), P(2167)
Notes
This second part of the challenge proceeds in mostly the same way as the first. We generate a large list of candidates and then search for those exhibiting the property in question. It is somewhat unexpected that the first pair of Pentagonal Numbers that have this property are so deeply located. Many times in these challenges the solution is emitted without quite as much searching!
References
posted at: 13:29 by: Adam Russell | path: /perl | permanent link to this entry
2022-01-09
Sieve of Atkin / Curious Fraction Tree
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the 10001st prime number.
Solution
use strict;
use warnings;
use boolean;
use Getopt::Long;
use LWP::UserAgent;
use constant N => 10_001;
use constant PRIME_URL => "http://primes.utm.edu/lists/small/100000.txt";
sub get_primes{
my @primes;
my $ua = new LWP::UserAgent(
ssl_opts => {verify_hostname => 0}
);
my $response = $ua->get(PRIME_URL);
my @lines = split(/\n/,$response->decoded_content);
foreach my $line (@lines){
my @p = split(/\s+/, $line);
unless(@p < 10){
push @primes, @p[1..(@p - 1)];
}
}
return @primes;
}
sub sieve_atkin{
my($n) = @_;
my @primes = (2, 3, 5);
my $upper_bound = int($n * log($n) + $n * log(log($n)));
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 get_nth_prime{
my($n, $generate) = @_;
my @primes;
unless($generate){
@primes = get_primes;
}
else{
@primes = sieve_atkin($n);
}
return $primes[$n - 1];
}
MAIN:{
my $n = N;
my $generate = false;
GetOptions("n=i" => \$n, generate => \$generate);
print get_nth_prime($n, $generate) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
104743
$ perl perl/ch-1.pl --generate
104743
$ perl perl/ch-1.pl --generate
104743
$ perl perl/ch-1.pl --generate --n 101
547
$ perl perl/ch-1.pl --generate --n 11
31
$ perl perl/ch-1.pl --n 10001
104743
$ perl perl/ch-1.pl --n 11
31
Notes
I've mentioned it before, but for anything that asks for or needs prime numbers I always ust grab them from one of several convenient online sources, rather than generate them myself.
This time around I figured it'd be sporting to generate them myself, but maybe in an interesting way. Here I implement a sieve method for determining prime numbers. This Sieve of Atkin_ has a claim to fame of being the most performant among prime number generating sieve techniques. The code is a bit convoluted looking, I will admit, but is a faithful Perl representation of the algorithm (follow the reference link for pseudocode). Also, rather than try and explain the algorithm myself anyone interested can find full in depth treatments elsewhere. A background in number theory helps for some of the details.
Since I have some existing code for getting the pre-computed primes I figured I would use that as a check and extra feature. Command line options allow for the default behavior (fetch pre-computed primes for an N of 10,001) to be overridden.
Part 2
Given a fraction return the parent and grandparent of the fraction from the Curious Fraction Tree.
Solution
use strict;
use warnings;
use Graph;
use constant ROOT => "1/1";
use constant SEPARATOR => "/";
sub initialize{
my($member) = @_;
my $graph = new Graph();
$graph->add_vertex(ROOT);
my @next = (ROOT);
my @changes = ([0, 1], [1, 0]);
my $level = 0;
{
my @temp_next;
my @temp_changes;
do{
$level++;
my $next = shift @next;
my($top, $bottom) = split(/\//, $next);
my $change_left = shift @changes;
my $change_right = shift @changes;
my $v_left = ($top + $change_left->[0]) . SEPARATOR . ($bottom + $change_left->[1]);
my $v_right = ($top + $change_right->[0]) . SEPARATOR . ($bottom + $change_right->[1]);
$graph->add_edge($next, $v_left);
$graph->add_edge($next, $v_right);
push @temp_next, $v_left, $v_right;
push @temp_changes, $change_left;
push @temp_changes, [$level + 1, 0], [0, $level + 1];
push @temp_changes, $change_right;
}while(@next && !$graph->has_vertex($member));
@next = @temp_next;
@changes = @temp_changes;
redo if !$graph->has_vertex($member);
}
return $graph;
}
sub curious_fraction_tree{
my($member) = @_;
my $graph = initialize($member);
my($parent) = $graph->predecessors($member);
my($grandparent) = $graph->predecessors($parent);
return ($parent, $grandparent);
}
MAIN:{
my($member, $parent, $grandparent);
$member = "3/5";
($parent, $grandparent) = curious_fraction_tree($member);
print "member = '$member'\n";
print "parent = '$parent' and grandparent = '$grandparent'\n";
print "\n";
$member = "4/3";
($parent, $grandparent) = curious_fraction_tree($member);
print "member = '$member'\n";
print "parent = '$parent' and grandparent = '$grandparent'\n";
}
Sample Run
$ perl perl/ch-2.pl
member = '3/5'
parent = '3/2' and grandparent = '1/2'
member = '4/3'
parent = '1/3' and grandparent = '1/2'
Notes
My thought process on this problem started somewhat backwards. After reading the problem
statement I thought of the Graph module and remembered that it defines a function
predecessors() which would be very useful for this. After convincing myself to
use Graph; I then probably spent the majority of the time for this just getting my
head around how to define new vertices at each level of the tree. Like all trees there is
some recursiveness to the structure, but an iterative implementation still looks clean as
well.
Once the graph is constructed the solution as required comes from calling predecessors()
to get the parent and grandparent vertices.
References
posted at: 17:32 by: Adam Russell | path: /perl | permanent link to this entry
2021-12-26
A Stocking Full of Numbers: Semiprimes and the Ulam Sequence
Merry Christmas and Happy New Year! May 2022 bring you less COVID and more Perl projects!
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate all Semiprime numbers <= 100.
Solution
use strict;
use warnings;
use boolean;
use LWP::UserAgent;
use constant N => 100;
use constant PRIME_URL => "http://primes.utm.edu/lists/small/100000.txt";
sub get_primes{
my @primes;
my $ua = new LWP::UserAgent(
ssl_opts => {verify_hostname => 0}
);
my $response = $ua->get(PRIME_URL);
my @lines = split(/\n/,$response->decoded_content);
foreach my $line (@lines){
my @p = split(/\s+/, $line);
unless(@p < 10){
push @primes, @p[1..(@p - 1)];
}
}
return @primes;
}
sub factor{
my($n) = @_;
my @factors = ();
for my $j (2 .. sqrt($n)){
if($j**2 == $n){
push @factors, [$j, $j] if $j**2 == $n;
next;
}
push @factors, [$j, $n / $j] if $n % $j == 0;
}
return @factors;
}
sub semiprime{
my($n, $primes) = @_;
my @factors = factor($n);
return false if @factors != 1;
my @prime_factors = grep {$factors[0]->[0] == $_ || $factors[0]->[1] == $_} @{$primes};
return true if @prime_factors == 2 || $prime_factors[0]**2 == $n;
return false;
}
sub semiprime_n{
my @primes = get_primes;
for my $n (1 .. N){
print "$n " if semiprime($n, \@primes);
}
print "\n";
}
MAIN:{
semiprime_n;
}
Sample Run
$ perl ch-1.pl
4 6 9 10 14 15 21 22 25 26 33 34 35 38 39 46 49 51 55 57 58 62 65 69 74 77 82 85 86 87 91 93 94 95
Notes
I am sticking to the convention that I started a while back to not re-compute prime numbers myself, but instead just grab them from one of several convenient online sources. The URL in the code above requires only a small amount of effort to scrape and parse. I hope nobody minds the little bit of extra traffic to their site!
Please do check out their main page listed below. It's a fun resource with interesting facts and news on prime numbers and related research.
Once the list of the first 100k primes is obtained (that's more than enough for any of these challenges) we proceed to factor and test candidate numbers. Provided the number has only two factors (which may be equal) and both of them are prime then it passes the semiprime test.
Part 2
You are given two positive numbers, $u and $v. Write a script to generate Ulam Sequence having at least 10 Ulam numbers where $u and $v are the first 2 Ulam numbers.
Solution
use strict;
use warnings;
use constant ULAM_LIMIT => 10;
sub ulam{
my($u, $v) = @_;
my %pairs;
my @ulam = ($u, $v);
my $w = $u + $v;
push @ulam, $w;
$pairs{"$u,$v"} = $w;
$pairs{"$u,$w"} = $u + $w;
$pairs{"$v,$w"} = $v + $w;
do{
my @sums = sort {$a <=> $b} grep{my $sum = $_; my @values = grep{$sum == $_} values %pairs; $sum if @values == 1 && $sum > $ulam[@ulam - 1]} values %pairs;
my $u = $sums[0];
push @ulam, $u;
for my $pair (keys %pairs){
my($s, $t) = split(/,/, $pair);
$pairs{"$s,$u"} = $s + $u;
$pairs{"$t,$u"} = $t + $u;
}
}while(@ulam < ULAM_LIMIT);
return @ulam;
}
MAIN:{
my @ulam;
@ulam = ulam(1, 2);
{
print shift @ulam;
print ", ";
redo if @ulam > 1;
}
print shift @ulam;
print "\n";
@ulam = ulam(2, 3);
{
print shift @ulam;
print ", ";
redo if @ulam > 1;
}
print shift @ulam;
print "\n";
@ulam = ulam(2, 5);
{
print shift @ulam;
print ", ";
redo if @ulam > 1;
}
print shift @ulam;
print "\n";
}
Sample Run
$ perl perl/ch-2.pl
1, 2, 3, 4, 6, 8, 11, 13, 16, 18
2, 3, 5, 7, 8, 9, 13, 14, 18, 19
2, 5, 7, 9, 11, 12, 13, 15, 19, 23
Notes
The code here is a pretty direct translation of the definition: the next member of the
sequence must be a sum of two previous members which is greater than the previous member
and only be obtainable one way. Here that is done with a grep filter, with the sequence
itself being stored in an array, but for convenience the sums of all unique previous pairs
are kept in a hash.
References
posted at: 18:00 by: Adam Russell | path: /perl | permanent link to this entry
2021-12-19
Stealthy Calculations
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given a string, $s, containing mathematical expression. Write a script to print the result of the mathematical expression. To keep it simple, please only accept + - * ().
Solution
Main driver.
use strict;
use warnings;
##
# Write a script to implement a four function infix calculator.
##
use TWCCalculator;
use constant ADD => "10 + 8";
use constant SUBTRACT => "18 - 66";
use constant ADD_SUBTRACT => "10 + 20 - 5";
use constant MULTIPLY => "10 * 8";
use constant DIVIDE => "52 / 2";
use constant CALCULATE => "(10 + 20 - 5) * 2";
MAIN:{
my $parser = new TWCCalculator();
$parser->parse(ADD);
$parser->parse(SUBTRACT);
$parser->parse(ADD_SUBTRACT);
$parser->parse(MULTIPLY);
$parser->parse(DIVIDE);
$parser->parse(CALCULATE);
}
TWCCalculator.yp (the Parse::Yapp code). This file is used to generate a parser module, TWCCalculator.pm, which is used in the code above. This is where the actual parsing of the input and implementation of the calculator is.
%token NUMBER
%left '+' '-' '*' '/'
%%
line:
| expression {print $_[1] . "\n"}
;
expression: NUMBER
| expression '+' expression {$_[1] + $_[3]}
| expression '-' expression {$_[1] - $_[3]}
| expression '*' expression {$_[1] * $_[3]}
| expression '/' expression {$_[1] / $_[3]}
| '(' expression ')' {$_[2]}
;
%%
sub lexer{
my($parser) = @_;
$parser->YYData->{INPUT} or return('', undef);
$parser->YYData->{INPUT} =~ s/^[ \t]//;
##
# send tokens to parser
##
for($parser->YYData->{INPUT}){
s/^([0-9]+)// and return ("NUMBER", $1);
s/^(\+)// and return ("+", $1);
s/^(-)// and return ("-", $1);
s/^(\*)// and return ("*", $1);
s/^(\/)// and return ("/", $1);
s/^(\()// and return ("(", $1);
s/^(\))// and return (")", $1);
s/^(\n)// and return ("\n", $1);
}
}
sub error{
exists $_[0]->YYData->{ERRMSG}
and do{
print $_[0]->YYData->{ERRMSG};
return;
};
print "syntax error\n";
}
sub parse{
my($self, $input) = @_;
$self->YYData->{INPUT} = $input;
my $result = $self->YYParse(yylex => \&lexer, yyerror => \&error);
return $result;
}
Sample Run
$ yapp TWCCalculator.yp
$ perl ch-1.pl
18
-48
25
80
26
50
Notes
In a long ago (almost exactly two years!) Challenge we were asked to implement a Reverse Polish Notation (RPN) Calculator. For that challenge I wrote a short introduction to the parser module, Parse::Yapp, that I used. See the references below, I think it still holds up.
For this challenge I was able to rely pretty heavily on that older code. I simply changed the expected position of the operators and that was about it!
I really like any excuse to use a parser generator, they're a powerful tool one can have at the disposal for a fairly small investment of learning time. Well, practical usage may be quick to learn. Depending on how deep one wants to go there is the possibility also of a lifetime of study of computational linguistics.
Part 2
You are given a positive number, $n. Write a script to find out if the given number is a Stealthy Number.
Solution
use strict;
use warnings;
use boolean;
sub factor{
my($n) = @_;
my @factors = ();
for my $j (2 .. sqrt($n)){
push @factors, [$j, $n / $j] if $n % $j == 0;
}
return @factors;
}
sub stealthy{
my($n) = @_;
my @factors = factor($n);
for(my $i = 0; $i < @factors; $i++){
for(my $j = 0; $j < @factors; $j++){
unless($i == $j){
my($s, $t) = @{$factors[$i]};
my($u, $v) = @{$factors[$j]};
return true if $s + $t == $u + $v + 1;
}
}
}
return false;
}
MAIN:{
print stealthy(12) . "\n";
print stealthy(36) . "\n";
print stealthy(6) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
1
1
0
Notes
That factor subroutine makes another appearance! Well, here there is a slight
modification to get it to return the factors in pairs, each pair an array reference.
These are all checked in a loop for the desired property.
This is a classic "generate and test" approach. For an idea of what it would look like to instead constrain the variables to fit the property and then discover which values, if any, match these constraints then please do take a look at my Prolog solution for Challenge 143 which uses a Constraint Logic Programming over Finite Domains (clpfd) approach.
References
posted at: 19:56 by: Adam Russell | path: /perl | permanent link to this entry
2021-12-12
Sleeping Divisors
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given positive integers, $m and $n. Write a script to find total count of divisors of $m having last digit $n.
Solution
use strict;
use warnings;
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 divisors_last_digit{
my($m, $n) = @_;
my @divisors;
my @factors = factor($m);
{
my $factor = pop @factors;
push @divisors, $factor if $n == substr($factor, -1);
redo if @factors;
}
return sort {$a <=> $b} @divisors;
}
MAIN:{
my($m, $n);
my @divisors;
($m, $n) = (24, 2);
@divisors = divisors_last_digit($m, $n);
print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";
($m, $n) = (75, 5);
@divisors = divisors_last_digit($m, $n);
print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";
($m, $n) = (30, 5);
@divisors = divisors_last_digit(30, 5);
print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
(24, 2): 2 --> 2, 12
(75, 5): 3 --> 5, 15, 25
(30, 5): 2 --> 5, 15
Part 2
Implement Sleep Sort.
Solution
use strict;
use warnings;
use Thread::Pool;
sub create_workers{
my @numbers = @_;
my $count = @numbers;
my $workers = new Thread::Pool({
optimize => "cpu",
do => \&sleeper,
workers => $count,
maxjobs => $count,
minjobs => $count
});
return $workers;
}
sub sleeper{
my($n) = @_;
sleep($n);
return $n;
}
sub sleep_sort{
my($numbers, $workers) = @_;
my @jobs;
my @sorted;
for my $n (@{$numbers}){
my $job_id = $workers->job($n);
push @jobs, $job_id;
}
{
my $job = pop @jobs;
my @result = $workers->result_any(\$job);
if(!@result){
push @jobs, $job;
}
else{
push @sorted, $result[0];
}
redo if @jobs;
}
$workers->shutdown;
return @sorted;
}
MAIN:{
my @numbers;
my @sorted;
@numbers = map{int(rand($_) + 1)} (0 .. 9);
print join(", ", @numbers) . "\n";
@sorted = sleep_sort(\@numbers, create_workers(@numbers));
print join(", ", @sorted) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
1, 1, 1, 3, 2, 3, 4, 7, 8, 6
1, 1, 1, 2, 3, 3, 4, 6, 7, 8
$ perl perl/ch-2.pl
1, 1, 1, 2, 2, 5, 5, 2, 1, 9
1, 1, 1, 1, 2, 2, 2, 5, 5, 9
Notes
I hope participants in The Weekly Challenge enjoyed this! After I saw Jort Sort in Challenge 139 I was reminded of other joke sorts and suggested this as a future challenge. Happily the suggestion was accepted!
Threading is easy in Perl, which uses an "Interpreter Threads" ("ithreads") model. Node.js programmers will find this model familiar as it is exactly what that language uses. Unfortunately Perl's documentation writers are not as familiar with concurrent and parallel programming topics and some of the official documentation needs updating. Unfortunately, this is a bizarrely contentious issue.
To ensure you are using a perl interpreter with proper ithreads support try this
one-liner: $ perl -Mthreads -e 0. If that runs without error you are good to go! If you
get an error you'll need to install a new perl. One convenient option is to use
Perlbrew. After installing perlbrew you'll need to invoke it
like this perlbrew install perl-5.34.0 -Dusethreads. Please see the Perlbrew
documentation for additional (straightforward) details if you decide to undertake this.
Here rather than use threads directly Thread::Pool is used. This is a convenient
pattern for using Perl's ithreads. Since each ithread is really a new perl interpreter
process this allows for some fine tuning of the number of ithreads created to help
conserve memory usage. In this case the memory conservation is actually somewhat minimal
since Sleep Sort requires us to start a new ithread for each element of the array to be
sorted. Amusingly, because of the process based threading model, we can quickly crash the
program by attempting to sort an array whose size causes the system to exceed the number
of allowed processes. Remember, this is a joke sort, right!?!?
Typically you'd create a pool of workers whose number matched the number of CPU cores available. That way each core could be tasked by the OS for whatever CPU intensive code you'd care to run without the ithreads competing too badly with each other.
Concurrent and parallel programming issues are somewhat advanced. Excellent documentation
exists that is both Perl specific and more general. Be sure to understand the difference
between ithreads and so called "co-operative thread" models (as used in modules such as
Coro. The "advanced" nature of this topic is due to understanding the various trade-offs
at play. Deep understanding usually comes from experience of implementing solutions this
way and study of the underlying Operating System concepts. Even the most modest modern
computer systems systems available have multiple cores at your disposal as a programmer
so this effort is certainly worthwhile! The bibliography of perlthrtut is an excellent
starting point.
References
posted at: 13:16 by: Adam Russell | path: /perl | permanent link to this entry
2021-12-05
Like, It’s Just the First Ten Numbers Man!
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to find lowest 10 positive integers having exactly 8 divisors
Solution
use strict;
use warnings;
sub factor{
my($n) = @_;
my @factors = (1, $n);
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 first_ten_with_eight{
my $i = 0;
my @first_ten;
do{
my @factors = factor($i);
push @first_ten, $i if @factors == 8;
$i++;
}while(@first_ten != 10);
return @first_ten;
}
MAIN:{
print join(", ", first_ten_with_eight()) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
24, 30, 40, 42, 54, 56, 66, 70, 78, 88
Notes
I have re-used that factor() function quite a bit for these challenges, especially
recently. My blog writing has been fairly terse recently and as much as I'd like to
be a bit more verbose I really am not sure if there all that much more to say about this
code that hasn't been said before!
Part 2
You are given positive integers, $m and $n. Write a script to find total count of integers created using the digits of $m which is also divisible by $n.
Solution
use strict;
use warnings;
##
# You are given positive integers, $m and $n.
# Write a script to find total count of integers
# created using the digits of $m which is also
# divisible by $n.
##
use Data::PowerSet q/powerset/;
sub like_numbers{
my($m, $n) = @_;
my @divisible;
for my $subset (@{powerset(split(//, $m))}){
my $i = join("", @$subset);
push @divisible, $i if $i && $i != $m && $i % $n == 0;
}
return @divisible;
}
MAIN:{
print like_numbers(1234, 2) . "\n";
print like_numbers(768, 4) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
9
3
Notes
I've been making more use of Data::PowerSet recently that I would have expected! If
anyone is interested in seeing an implementation of the Power Set calculations see my
C++ solution links below. While not Perl the code is quite readable and should be
adaptable easy to other languages. There is also a Rosetta Code entry for Power Set
but, frankly, many of the submissions there, especially the C++ and Perl ones are overly
convoluted in my opinion. Or at least much more so than the way I implemented it, which
I would think would be the more common method but I guess not!
References
posted at: 16:47 by: Adam Russell | path: /perl | permanent link to this entry
2021-11-28
A Binary Addition Simulation / Nth from a Sorted Multiplication: Table The Weekly Challenge 140
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given two decimal-coded binary numbers, $a and $b. Write a script to simulate the addition of the given binary numbers.
Solution
use strict;
use warnings;
sub add_binary{
my($x, $y) = @_;
my $sum = "";
my @a = reverse(split(//, $x));
my @b = reverse(split(//, $y));
if(@b > @a){
my @c = @b;
@b = @a;
@a = @c;
}
my $carry = 0;
for(my $d = 0; $d <= @a - 1; $d++){
my $d0 = $a[$d];
my $d1 = $b[$d];
if($d1){
$sum = "0$sum", $carry = 0 if $d0 == 1 && $d1 == 1 && $carry == 1;
$sum = "1$sum", $carry = 0 if $d0 == 1 && $d1 == 0 && $carry == 0;
$sum = "0$sum", $carry = 1 if $d0 == 1 && $d1 == 1 && $carry == 0;
$sum = "0$sum", $carry = 1 if $d0 == 0 && $d1 == 1 && $carry == 1;
$sum = "0$sum", $carry = 0 if $d0 == 0 && $d1 == 0 && $carry == 0;
$sum = "1$sum", $carry = 0 if $d0 == 0 && $d1 == 0 && $carry == 1;
$sum = "0$sum", $carry = 1 if $d0 == 1 && $d1 == 0 && $carry == 1;
$sum = "1$sum", $carry = 0 if $d0 == 0 && $d1 == 1 && $carry == 0;
}
else{
$sum = "0$sum", $carry = 1, next if $d0 == 1 && $carry == 1;
$sum = "1$sum", $carry = 0, next if $d0 == 0 && $carry == 1;
$sum = "0$sum", $carry = 0, next if $d0 == 0 && $carry == 0;
$sum = "1$sum", $carry = 0, next if $d0 == 1 && $carry == 0;
}
}
$sum = "$carry$sum" if $carry == 1;
return $sum;
}
MAIN:{
print add_binary(11, 1) . "\n";
print add_binary(101, 1) . "\n";
print add_binary(100, 11) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
100
110
111
Notes
I have an unusual fondness for Perl's right hand conditional. But that is pretty obvious from the way I wrote this, right?
Part 2
You are given 3 positive integers, $i, $j and $k. Write a script to print the $kth element in the sorted multiplication table of $i and $j.
Solution
use strict;
use warnings;
sub nth_from_table{
my($i, $j, $k) = @_;
my @table;
for my $x (1 .. $i){
for my $y (1 .. $j){
push @table, $x * $y;
}
}
return (sort {$a <=> $b} @table)[$k - 1];
}
MAIN:{
print nth_from_table(2, 3, 4) . "\n";
print nth_from_table(3, 3, 6) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
3
4
Notes
Full Disclosure: At first I wanted to do this in some convoluted way for fun. After
experimenting with, like, nested maps for a few minutes I lost all interest in "fun" and
just went with a couple of for loops!
References
posted at: 17:16 by: Adam Russell | path: /perl | permanent link to this entry