RabbitFarm
2021-04-11
Static Analysis and Self Describing Numbers (now with Threads!): The Weekly Challenge 107
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate self-descriptive numbers.
Solution
use strict;
use warnings;
use Thread;
use boolean;
use constant SDN_COUNT => 3;
use constant THREAD_COUNT => 4;
use constant RANGE_SIZE => 10_000;
sub self_describing{
my($i) = @_;
my @digits = split(//, $i);
for my $x (0 .. @digits - 1){
my $count = 0;
for my $j (0 .. @digits - 1){
$count++ if($digits[$j] == $x);
return false if($count > $digits[$x]);
}
return false if($count != $digits[$x]);
}
return true;
}
sub self_describing_number{
my($start, $end) = @_;
my @r = ();
for(my $i = $start; $i < $end; $i++){
push @r, [length($i), $i] if(self_describing($i));
}
return \@r;
}
MAIN:{
my @threads;
my $count = 0;
my $lower = 1;
my $upper = RANGE_SIZE;
do{
for(0..(THREAD_COUNT - 1)){
my $t = Thread->new(\&self_describing_number, ($lower, $upper));
push @threads, $t;
$lower = $upper + 1;
$upper = $lower + RANGE_SIZE;
}
foreach my $t (@threads){
my $sdns = $t->join();
foreach my $sdn (@{$sdns}){
print "Base " . $sdn->[0] . ":" . $sdn->[1] . "\n" if $count < SDN_COUNT;
$count++;
}
}
@threads = ();
} while($count < SDN_COUNT);
}
Sample Run
$ perl perl/ch-1.pl
Base 4:1210
Base 4:2020
Base 5:21200
Notes
Part 1 this week is repeated from Challenge 043. In order to provide something fresh for the same problem I modified the previous code to be multi-threaded.
Part 2
Write a script to list methods of a package/class.
Solution
use strict;
use warnings;
sub analyze{
my($file) = @_;
my @subs;
my @uses;
my @subroutines;
my $subs = `perlanalyst $file --analysis Sub`;
$subs =~ s/$file://;
@subs = split(/\n/, $subs);
my $uses = `perlanalyst $file --analysis Use`;
$uses =~ s/$file://;
@uses = split(/\n/, $uses);
for my $s (@subs){
$s =~ s/\s+//;
my @fields = split(/:/, $s);
push @subroutines, $fields[1] if(length($s) > 0);
}
push @subroutines, "BEGIN" if(@uses);
return @subroutines;
}
MAIN:{
my $FILE = $ARGV[0];
my @subroutines = analyze($FILE);
print join("\n", sort {$a cmp $b} @subroutines) . "\n";
}
Sample Run
$ perl perl/ch-2.pl perl/Calc.pm
BEGIN
DESTROY
add
div
mul
new
Notes
Getting a list of methods can mostly be done via just some plain analysis of the code. Rather than re-invent the wheel I am using a module, Perl::Analysis::Static, to do that for me. This is a pretty neat tool but has been left in an alpha state. The most stable way to use it is via the command line instead of its incomplete API. In this code I call the perlanalyst command and then parse the output.
If given a BEGIN block or if use-ing a module Perl will execute a BEGIN at compile time. I would argue that this is out of scope for this challenge. However, as given in the problem statement we are expected to catch this it seems. I do this by inspecting the perlanalyst output for use lines. I could have done a few other things as well but decided not to do more with this since it seems like a funny requirement anyway!
References
posted at: 17:51 by: Adam Russell | path: /perl | permanent link to this entry
2021-04-04
Recursion and Repeated Decimals: The Weekly Challenge 106
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of integers @N. Write a script to display the maximum difference between two successive elements once the array is sorted.
Solution
use strict;
use warnings;
sub max_difference_sorted{
my(@sorted) = @_;
return 0 if(@sorted == 1);
my $x = $sorted[1] - $sorted[0];
my $y = max_difference_sorted(@sorted[1 .. @sorted - 1]);
return ($x > $y)? $x: $y;
}
sub max_difference{
my (@numbers) = @_;
return max_difference_sorted(
sort { $a <=> $b } @numbers
);
}
MAIN:{
my (@N);
@N = (2, 9, 3, 5);
print max_difference(@N) . "\n";
@N = (1, 3, 8, 2, 0);
print max_difference(@N) . "\n";
@N = (5);
print max_difference(@N) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
4
5
0
Notes
I believe this code is straightforward enough! max_difference performs the sort and max_difference_sorted recursively finds the largest difference as required.
Part 2
You are given numerator and denominator i.e. $N and $D. Write a script to convert the fraction into decimal string. If the fractional part is recurring then put it in parenthesis.
Solution
use strict;
use warnings;
use boolean;
sub divide{
my($n, $d) = @_;
my @remainders;
my $q = (int($n / $d)) . ".";
my $r = $n % $d;
push @remainders, $r;
my @a;
for (0 .. $d){
$q .= int($r*10 / $d);
$r = $r*10 % $d;
@a = grep { $remainders[$_] == $r } (0 .. @remainders - 1);
last if(@a);
push @remainders, $r;
}
my $r_i = $a[0];
my $i = index($q, ".");
my $decimal_part = substr($q, $i+1);
return substr($q, 0, $i + 1) . substr($decimal_part, 0, $r_i) . "(" . substr($q, $i + $r_i + 1) . ")";
}
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 nd2decimal{
my($n, $d) = @_;
my $max_repetend = $d - 1;
my $repeats = false;
my @factors = prime_factor($d);
for my $factor (@factors){
$repeats = true if($factor != 2 && $factor != 5);
}
unless($repeats){
return sprintf("%0.${max_repetend}g", $n / $d);
}
else{
my $x = divide($n, $d, [], []);
return $x;
}
}
MAIN:{
my($N, $D);
($N, $D) = (1, 3);
print nd2decimal($N, $D) . "\n";
($N, $D) = (1, 2);
print nd2decimal($N, $D) . "\n";
($N, $D) = (5, 66);
print nd2decimal($N, $D) . "\n";
($N, $D) = (1, 6);
print nd2decimal($N, $D) . "\n";
($N, $D) = (1, 8);
print nd2decimal($N, $D) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
0.(3)
0.5
0.0(75)
0.1(6)
0.125
Notes
Part 2 is a bit trickier than the first part. The approach here is as follows:
- determine if it is a repeated decimal by checking if
$dhas prime factors other than 2 or 5 - if it is not a repeated decimal then this is quick work, divide and display the solution
- in the case of repeated decimals we essentially implement grade school long division in the
dividefunction and keep track of remainders. When a remainder is repeated we know that we have found the cycle.
There are some interesting theoretical properties to repeat decimals but none are particularly helpful in actually computing them. One observation is that the length of the cycle must be smaller than the value of the denominator, whence the use of $d in the main loop in the divide function.
I’m re-using the same prime_factors function that I used in Challenge 041.
References
posted at: 17:04 by: Adam Russell | path: /perl | permanent link to this entry
2021-03-28
Newton’s Method and Perl Formats: The Weekly Challenge 105
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given positive numbers $N and $k. Write a script to find out the $Nth root of $k
Solution
use strict;
use warnings;
sub nth_root{
my($n, $k) = @_;
my $x_i = int(rand(10) + 1);
my $r;
for my $i (0 .. 100){
$x_i = (1 / $n) * (($n - 1) * $x_i + ($k / $x_i ** ($n - 1)));
}
return $x_i;
}
MAIN:{
my($N, $k);
$N = 5;
$k = 248832;
print nth_root($N, $k) . "\n";
$N = 5;
$k = 34;
print sprintf("%0.2f", nth_root($N, $k)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
12
2.02
Notes
One of my neatest things one can learn in calculus class, I would argue, is Newton’s method for computing square roots. One can read more on this elsewhere but this works by using a recurrence relationship, defined using directives, to compute the zero of a function. If the function is x^n - a, the zero we are computing is the nth root of a.
To start the process any x_0 may be chosen. Here we pick an integer from 1 to 10 at random.
You can compute this for as many iterations as you’d like, of course, but here even 100 iterations is much more than enough to properly converge.
Part 2
You are given a $name. Write a script to display the lyrics to the Shirley Ellis song The Name Game.
Solution
use strict;
use warnings;
sub name_game{
my($name) = @_;
my($b, $f, $m);
my $first_letter = lc(substr($name, 0, 1));
my $irregular_v = $first_letter =~ tr/aeiou//d;
my $irregular_bfm = $first_letter =~ tr/bfm//d;
unless($irregular_v || $irregular_bfm){
$b = "b" . lc(substr($name, 1));
$f = "f" . lc(substr($name, 1));
$m = "m" . lc(substr($name, 1));
}
elsif($irregular_v){
$b = "b" . lc($name);
$f = "f" . lc($name);
$m = "m" . lc($name);
}
elsif($irregular_bfm){
$b = "b" . lc(substr($name, 1));
$f = "f" . lc(substr($name, 1));
$m = "m" . lc(substr($name, 1));
$b = lc(substr($name, 1)) if lc(substr($name, 0, 1)) eq "b";
$f = lc(substr($name, 1)) if lc(substr($name, 0, 1)) eq "f";
$m = lc(substr($name, 1)) if lc(substr($name, 0, 1)) eq "m";
}
format NAME_GAME =
@*, @*, bo-@*
$name, $name, $b
Banana-fana fo-@*
$f
Fee-fi-mo-@*
$m
@*!
$name
.
select(STDOUT);
$~ = "NAME_GAME";
write();
}
MAIN:{
my($name);
$name = "Katie";
name_game($name);
print "\n";
$name = "Adam";
name_game($name);
print "\n";
$name = "Mary";
name_game($name);
}
Sample Run
$ perl perl/ch-2.pl
Katie, Katie, bo-batie
Banana-fana fo-fatie
Fee-fi-mo-matie
Katie!
Adam, Adam, bo-badam
Banana-fana fo-fadam
Fee-fi-mo-madam
Adam!
Mary, Mary, bo-bary
Banana-fana fo-fary
Fee-fi-mo-ary
Mary!
Notes
My first comment is that I am a terrible singer and have never been able to reliably remember songs with rules like this at all, at any time of my life! Practically speaking that means I may have had to do more research on this part than one might expect. I did find an excellent reference (listed below) which detailed the rules for each case very clearly.
Perhaps the trickiest case in the one in which the name starts with a b, f, or m. For these you need to adjust the one specific rewrite rule which uses that letter. In the example above we see that Mary requires special handling and becomes Fee-fi-mo-ary.
To print the verses out I use a Perl Format. Formats are not the most commonly used feature of Perl these days but still have some nice uses such as here where we want to define a simple template for plain text output. Formats can even be used to write to files, but here we just print to the console.
One Format trick which I have not used before is the use of a variable width field. Much of the documentation for Formats has to do with fixed width fields which can be centered, padded left, padded right, involve multiple lines, and so forth. A common case which is not typically well explained is one we need here. Names are of different lengths and may be followed by a comma or an exclamation point. Padding right adds unwanted space before the “,” or “!”. Padding left adds unwanted space before the name. Centering does both! The trick is to use @* for the field specifier in the Format definition. This will allow the value to be substituted in without any padding.
References
posted at: 11:28 by: Adam Russell | path: /perl | permanent link to this entry
2021-03-14
The Weekly Challenge 103: Astrology and Audio
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a year $year. Write a script to determine the Chinese Zodiac for the given year $year.
Solution
use strict;
use warnings;
##
# You are given a year $year.
# Write a script to determine the Chinese Zodiac for the given year $year
##
use constant ELEMENTS => {1 => q/Wood/, 2 => q/Fire/, 3 => q/Earth/, 4 => q/Metal/, 0 => q/Water/};
use constant ANIMALS => {1 => q/Rat/, 2 => q/Ox/, 3 => q/Tiger/, 4 => q/Rabbit/, 5 => q/Dragon/, 6 => q/Snake/, 7 => q/Horse/, 8 => q/Goat/, 9 => q/Monkey/, 10 => q/Rooster/, 11 => q/Dog/, 0 => q/Pig/};
sub chinese_zodiac{
my($year) = @_;
return ELEMENTS->{$year % 5} . " " . ANIMALS->{($year + 9) % 12};
}
MAIN:{
my($YEAR);
$YEAR = 2017;
print chinese_zodiac($YEAR) . "\n";
$YEAR = 1938;
print chinese_zodiac($YEAR) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
Fire Rooster
Earth Tiger
Notes
When I first saw the problem statement for this part of the challenge I took a look at the cited Wikipedia article, but it just seemed like a real slog of a read. So I decided to just work backwards from the examples given! Pretty much this seems to boil down to a straightforward modular arithmetic problem. The values are all known and so I hard code then with use constant and then use them directly.
Part 2
Write a program to output which file is currently playing.
Solution
use strict;
use warnings;
sub song_times{
my($file_name) = @_;
my %song_times;
my @song_order;
my $length = 0;
my $index = 0;
if(!$file_name){
while(){
chomp;
my($time, $song) = split(/,/);
$length += $time;
$song_order[$index] = $song;
$song_times{$song} = $time;
$index++;
}
}
else{
open(FILE, $file_name);
while(){
chomp;
my($time, $song) = split(/,/);
$length += $time;
$song_order[$song] = $index;
$song_times{$song} = $time;
$index++;
}
}
return [\%song_times, \@song_order, $length];
}
sub now_playing{
my($start_time, $current_time, $file_name) = @_;
my($song_times, $song_order, $length_millis);
$current_time = time() if !$current_time;
($song_times, $song_order, $length_millis) = @{song_times()} if $file_name;
($song_times, $song_order, $length_millis) = @{song_times($file_name)} if !$file_name;
my $time_playing = $current_time - $start_time;
my $cycles = ($time_playing * 1000) / $length_millis;
my $current_cycle_millis = ($cycles - int($cycles)) * $length_millis;
my $seek_time = 0;
for my $song (@{$song_order}){
$seek_time += $song_times->{$song};
if($seek_time > $current_cycle_millis){
my $position = ($song_times->{$song} - ($seek_time - $current_cycle_millis)) / 1000;
my $hours = int($position/3600);
my $minutes = int(($position % 3600) / 60);
my $seconds = int(($position % 3600) % 60);
$position = sprintf("%02d", $hours) . ":" . sprintf("%02d", $minutes) . ":" . sprintf("%02d", $seconds);
return ($song, $position);
}
}
}
MAIN:{
my($song, $position) = now_playing(1606134123, 1614591276);
print "$song\n$position\n";
}
__DATA__
1709363,"Les Miserables Episode 1: The Bishop (broadcast date: 1937-07-23)"
1723781,"Les Miserables Episode 2: Javert (broadcast date: 1937-07-30)"
1723781,"Les Miserables Episode 3: The Trial (broadcast date: 1937-08-06)"
1678356,"Les Miserables Episode 4: Cosette (broadcast date: 1937-08-13)"
1646043,"Les Miserables Episode 5: The Grave (broadcast date: 1937-08-20)"
1714640,"Les Miserables Episode 6: The Barricade (broadcast date: 1937-08-27)"
1714640,"Les Miserables Episode 7: Conclusion (broadcast date: 1937-09-03)"
Sample Run
$ perl perl/ch-2.pl
"Les Miserables Episode 1: The Bishop (broadcast date: 1937-07-23)"
00:10:24
Notes
I have to say that I found this deceptively harder to implement than it first appears! I suppose that is always true when working with time.
In the spirit of good sportsmanship wrote the code to fit the specification given, but then allow for defaults, such as reading from <DATA> and using the value of time().
The way this works here is:
- The file list is read in and the times of the songs and the total length of the whole playlist is saved.
- We find out where in the playlist “cycle” we are.
- Given the time of the cycle we “seek” to the position of the current song.
References
posted at: 16:46 by: Adam Russell | path: /perl | permanent link to this entry
2021-03-07
The Weekly Challenge 102: Threads and Recursion
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 generate all Rare Numbers of size $N if any exist.
Solution
use strict;
use warnings;
use Thread;
use constant THREAD_COUNT => 4;
sub rare_number_check{
my($lower, $upper) = @_;
my @rares;
{
my $r = $lower;
my $r1 = reverse($r);
if($r > $r1){
my $rs = sqrt($r + $r1);
my $r1s = sqrt($r - $r1);
if($rs !~ m/\./ && $r1s !~ m/\./){
push @rares, $lower;
}
}
$lower++;
redo unless $lower > $upper;
}
return \@rares;
}
sub rare_number{
my($n) = @_;
my @rares;
my $lower = "1" . 0 x ($n - 1);
my $upper = "1" . 9 x ($n - 1);
my $increment = $lower;
{
my @threads;
for(1 .. THREAD_COUNT){
my $t = Thread->new(\&rare_number_check, $lower, $upper);
push @threads, $t;
$lower = $upper + 1;
$upper = $lower + $increment - 1;
last if(length($upper) == ($n + 1));
}
foreach my $t (@threads){
my $rares = $t->join();
push @rares, @{$rares};
}
redo unless(length($upper) == ($n + 1));
}
return \@rares;
}
MAIN:{
my($N);
$N=2;
my $rares = rare_number($N);
print "$N digits: " . join(" ", @{$rares}) . "\n";
$N=6;
$rares = rare_number($N);
print "$N digits: " . join(" ", @{$rares}) . "\n";
$N=9;
$rares = rare_number($N);
print "$N digits: " . join(" ", @{$rares}) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
2 digits: 65
6 digits: 621770
9 digits: 281089082
Notes
My approach here is brute force, but with a slight twist. I parallelize the computations by using Threads. I’ve used Threads in the past, for example in Challenge 008 Threads were used to compute Perfect Numbers. The search for Perfect Numbers bears enough similarity to the current problem with Rare Numbers that the code from Challenge 008 will also be similar to this week’s code.
There are four CPU cores on the system I am running this code on. We can create any number of Threads that we need, of course, but Perl Threads are a special sort of “thread” in that they create new copies of the running interpreter and so consume a bit more memory than the sort of light weight threads you may learn about in C or Java. In the interest of conserving memory, and to avoid having multiple interpreter threads running on the same core we’ll just create no more than four Threads at a time. Note: Ultimately it is the OS which schedules where things run but, generally speaking, four threads on a four core system will each run on individual cores.
We can demonstrate this to ourselves by increasing the number of threads beyond the number of cores and not seeing an improvement in execution time.
Each Thread will get a slice of the search space. Each slice is of size 10 ** ($N - 1). Threads run sub rare_number_check which implements the definition of a Rare Number.
- I chose to use a bare block with redo. This is purely a matter of style and aesthetics. I’d argue that in this case it is more readable than the equivalent
fororwhileloops would be. sub rare_numberwhich generates and co-ordinates the Threads also uses redo for similar reasons.- Interestingly Perl is clever enough to return a integer with no decimal part in the case of a perfect square! Checking to see if we have a perfect square then becomes a matter of checking to see if the value returned by sqrt contains a decimal.
Part 2
You are given a positive integer $N. Write a script to produce hash counting string of that length.
Solution
use strict;
use warnings;
sub hash_counting_string{
my($n) = @_;
return "" if $n == 0;
return "#" if $n == 1;
my $h = "$n#";
return hash_counting_string($n - length($h)) . $h;
}
MAIN:{
print hash_counting_string(1). "\n";
print hash_counting_string(2). "\n";
print hash_counting_string(3). "\n";
print hash_counting_string(10). "\n";
print hash_counting_string(14). "\n";
}
Sample Run
$ perl perl/ch-2.pl
#
2#
#3#
#3#5#7#10#
2#4#6#8#11#14#
Notes
This is what I consider to be a nice clean recursive implementation. When I first saw Part 2 it seemed a bit more complicated than it would later prove to be. My thought process was along the lines of “I am not sure how I would do this in Perl, and I have no idea of how this would go in Prolog either!” Often times I will rely on the insights gained by doing it in one to aid the implementation of the other. In times like this, with no immediately clear solution, I prefer to start off in Perl, and write it in a way which would allow for reproduction in Prolog. Then, as necessary, remove any vestiges of the solution’s origins by conforming to idiomatic Prolog by ensuring things are done declaratively, logically.
This is actually a long acknowledged use of Perl: algorithm development. If you see the Prolog solution for Part 2 you can detect the obvious origins!
As far as this solution in Perl, perhaps the main “trick” is that we must account for the length of the numeral. So, for example, “14#” consumes three characters and so the next time through we need to generate the hash count for 11 = 14 - 3.
References
posted at: 16:28 by: Adam Russell | path: /perl | permanent link to this entry
2021-02-21
The Weekly Challenge 100
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a time (12 hour / 24 hour). Write a script to convert the given time from 12 hour format to 24 hour format and vice versa.
Solution
perl -e 'shift=~/(\d+):(\d\d\s*((am|pm)))/;if($1 < 12 && $3 eq "pm"){$h = $1 + 12}elsif($1 > 12 && $3 eq "pm"){$h = "0" . ($1 - 12)}else{$h = $1}print "$h:$2\n"' "17:15 pm"
Sample Run
perl -e 'shift=~/(\d+):(\d\d\s*((am|pm)))/;if($1 < 12 && $3 eq "pm"){$h = $1 + 12}elsif($1 > 12 && $3 eq "pm"){$h = "0" . ($1 - 12)}else{$h = $1}print "$h:$2\n"' "17:15 pm"
05:15 pm
perl -e 'shift=~/(\d+):(\d\d\s*((am|pm)))/;if($1 < 12 && $3 eq "pm"){$h = $1 + 12}elsif($1 > 12 && $3 eq "pm"){$h = "0" . ($1 - 12)}else{$h = $1}print "$h:$2\n"' "05:15 pm"
17:15 pm
Notes
Ok, so this isn;t going to win and Perl Golf competitions, that’s for sure! Frankly, this approach using regexes might not be the best for succinctly handling the bi-directionality.
For anyone that might not be familiar shift=~/(\d+):(\d\d\s*((am|pm)))/ means shift the first argument off of @ARGV (the command line arguments and then match against the regex. This is equivalent to $ARGV[0]=~/(\d+):(\d\d\s*((am|pm)))/.
Part 2
You are given triangle array. Write a script to find the minimum path sum from top to bottom. When you are on index i on the current row then you may move to either index i or index i + 1 on the next row.
Solution
use strict;
use warnings;
sub minimum_sum{
my(@triangle) = @_;
my($i, $j) = (0, 0);
my $sum = $triangle[0]->[0];
while($i < @triangle){
unless(!exists($triangle[$i+1])){
$j = ($triangle[$i+1]->[$j] >= $triangle[$i+1]->[$j+1]) ? $j+1 : $j;
$sum += $triangle[$i+1]->[$j];
}
$i++;
}
return $sum;
}
MAIN:{
my(@TRIANGLE);
@TRIANGLE = ([1], [2, 4], [6, 4, 9], [5, 1 , 7, 2]);
print minimum_sum(@TRIANGLE) . "\n";
@TRIANGLE =([3], [3, 1], [5, 2, 3], [4, 3, 1, 3]);
print minimum_sum(@TRIANGLE) . "\n";
}
Sample Run
$ perl ch-2.pl
8
7
Notes
I think this is a relatively well known greedy tactic. In order to minimize the total sum, make the minimum choice at each step.
References
posted at: 17:09 by: Adam Russell | path: /perl | permanent link to this entry
2021-02-06
Perl Weekly Challenge 098
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given file $FILE. Create subroutine readN($FILE, $number) returns the first n-characters and moves the pointer to the (n+1)th character.
Solution
use strict;
use warnings;
sub read_maker0{
my $n = 0;
return sub{
my($file, $x) = @_;
my $chars;
open(FILE, $file);
unless(seek(FILE, $n, 0)){
close(FILE);
}
read(FILE, $chars, $x);
$n = $n + $x;
return $chars;
}
}
sub read_maker1{
my ($file) = @_;
my $n = 0;
open(FILE, $file);
return sub{
my($x) = @_;
my $chars;
my $read = read(FILE, $chars, $x);
$n = $n + $x;
unless(seek(FILE, $n, 0)){
close(FILE);
}
return $chars;
}
}
MAIN:{
my($FILE, $number) = ("ch-1.dat", 4);
my($read_n, $chars);
$read_n = read_maker0();
$chars = $read_n->($FILE, $number);
print "$chars\n";
$chars = $read_n->($FILE, $number);
print "$chars\n";
$chars = $read_n->($FILE, $number);
print "$chars\n";
$read_n = read_maker1($FILE);
$chars = $read_n->($number);
print "$chars\n";
$chars = $read_n->($number);
print "$chars\n";
$chars = $read_n->($number);
print "$chars\n";
}
Sample Run
$ perl perl/ch-1.pl
1234
5678
90
1234
5678
90
Notes
I actually did this two different ways. The first follows the letter of the challenge as to the parameters of the read_n function and the second differs, only passing in $number and does not include the filename.
Before I get into the differences it makes sense to point out how read_maker0() works. What is does is create a closure over the value $n which will hold the current position in the file. Think of the variable $n created in read_maker0() as captured inside the function that is being returned. This process is called currying and it’s a neat trick. I’ve used it in the past for these challenges, the first being way back in Challenge 003! In this way read_maker0() is creating the function which we are referring to by the scalar $read_n.
After each read $n is incremented and used to seek to the next position. I should note that this is not really necessary here since the value of $number is never changed. In this case the read alone will advance the file position as necessary. However, by including seek the solution is more general. We would be able to move around the file however we want, backwards and forwards, with seek if we wanted to.
So we see that we can capture $n and use it to store the file position between function calls. The challenge states that we are to called read_n with two parameters, the filename and the number of characters to read. As you can see, we do not need to keep sending the filename with each function call. The filename can also be a part of the closure!
That is the difference between read_maker0() and read_maker1(). The first returns a read_n function that matches the challenge specification of taking a filename and a number of characters to read. read_maker1() returns a function that only takes the number of characters to read, the function itself has a stored value for the file handle we want.
One small final thing to mention: anyone unfamiliar with read might notice that there is no checking to see if we attempt to read past the end of the file. That is because read will read all the characters it can and if it hits the end of the file it will stop. The return value from read is the number of characters successfully read. While we do not check that value in this code, if we did we would see that in this example the final read would return 2, which is clear in the output shown.
Part 2
You are given a sorted array of distinct integers @N and a target `$N``. Write a script to return the index of the given target if found otherwise place the target in the sorted array and return the index.
Solution
use strict;
use warnings;
sub find_insert{
my($list, $n) = @_;
if($n < $list->[0]){
unshift @{$list}, $n;
return 0;
}
if($n > $list->[@{$list} - 1]){
push @{$list}, $n;
return @{$list} - 1;
}
for(my $i = 0; $i < (@{$list} - 1); $i++){
return $i if $n == $list->[$i];
if($n > $list->[$i] && $n < $list->[$i + 1]){
splice(@{$list}, $i, 2, ($list->[$i], $n, $list->[$i + 1]));
return $i + 1;
}
}
}
MAIN:{
my(@N, $N, $i);
@N = (1, 2, 3, 4);
$N = 3;
$i = find_insert(\@N, $N);
print "$i\n";
@N = (1, 3, 5, 7);
$N = 6;
$i = find_insert(\@N, $N);
print "$i\n";
@N = (12, 14, 16, 18);
$N = 10;
$i = find_insert(\@N, $N);
print "$i\n";
@N = (11, 13, 15, 17);
$N = 19;
$i = find_insert(\@N, $N);
print "$i\n";
}
Sample Run
$ perl perl/ch-2.pl
2
3
0
4
Notes
While somewhat convoluted sounding at first this part of Challenge 098 ended up being fairly straightforward, especially when using splice to do any array insertions. Probably there are more “fun” ways to have done this but the intuitive way here has an almost comforting look to it. Reminds me of university computer lab exercises!
Anyway, the approach here is to consider the possible cases. find_insert starts off by checking to see if $n would belong at the very start or end of the array. If neither of those cases hold we loop over the array looking for where $n might be. If found in the array we return with the index, else we insert with splice.
The challenge never asks to see the modified array so I suppose it is possible to merely return where $n belongs without actually inserting it but that didn’t seem quite as sporting.
References
posted at: 21:34 by: Adam Russell | path: /perl | permanent link to this entry
2021-01-31
Perl Weekly Challenge 097
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given string $S containing alphabets A..Z only and a number $N. Write a script to encrypt the given string $S using Caesar Cipher with left shift of size $N.
Solution
use strict;
use warnings;
sub caesar_cypher{
my($s, $n) = @_;
my @cypher = map { unless(ord($_) == ord(' ')){
my $x = ((ord($_) - $n) < ord('A')?(ord($_) - $n + 26):(ord($_) - $n));
chr($x);
}
else{
$_
}
} split(//, $s);
return join("", @cypher);
}
MAIN:{
my($S, $N);
$S = "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG";
$N = 3;
print "$S\n";
print caesar_cypher($S, $N) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG
QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD
Notes
The basic approach here is pretty much the straightforward one: use the ascii values for the characters and subtract $n. In Perl we use the ord function to do this and the chr to go in the other direction, ascii value to character. The only thing we really need to be careful of is if subtracting $n takes us outside the ascii range for upper case letters, then we need to add 26 to get back in range.
Certain style instructions have been burned into my brain over the years and I find them almost impossible to deviate from. The one that applies here is Whenever possible do not use numeric literals. They are often poorly documented and become “magic numbers”, and make code readability and future debugging unnecessarily difficult. So it is in that spirit that I write, for example, ord(' ') instead of just 32.
Part 2
You are given a binary string $B and an integer $S. Write a script to split the binary string $B of size $S and then find the minimum number of flips required to make it all the same.
Solution
use strict;
use warnings;
use feature "bitwise";
sub substrings{
my($d, $s) = @_;
my @substrings;
for(my $i = 0; $i < length($d); $i+=$s){
push @substrings, substr($d, $i, $s);
}
return @substrings;
}
sub min_flips{
my($d, $s) = @_;
my @flips;
my @substrings = substrings($d, $s);
for my $digits (@substrings){
my $flip_count = 0;
map { $flip_count += unpack("%32b*", $digits ^. $_) } @substrings;
push @flips, $flip_count;
}
return [sort {$a <=> $b} @flips]->[0];
}
MAIN:{
my($B, $S);
$B = "101100101";
$S = 3;
print min_flips($B, $S) . " flips\n";
$B = "10110111";
$S = 4;
print min_flips($B, $S) . " flips\n";
}
Sample Run
$ perl perl/ch-2.pl
1 flips
2 flips
Notes
The substrings function is just a convenient wrapper around the code necessary to break the string into the right sized chunks. The assumption is that the string is evenly divisible into chunks of size $s. If we were not making this assumption we would need to add some zero padding for any unevenly sized substring.
Since use feature "bitwise"; is present the ^. is defined and the operands to ^. are taken to be bit strings and the result is itself a bit string.min_flips does a bitwise xor operation, pairwise comparing each substring in a map. Since xor is 1 only when the bits are different the result is a bit string of set bits, the ones needed to be flipped. unpack is used to sum these, and the result added $flip_count which is then pushed into an array. The minimum number of flips is determined by the smallest number in that array. The bitwise feature was introduced in Perl 5.22 and graduated from experimental status in Perl 5.28.
References
posted at: 11:11 by: Adam Russell | path: /perl | permanent link to this entry
2021-01-24
Perl Weekly Challenge 096
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 reverse the order of words in the given string.
Solution
use strict;
use warnings;
sub reverse_words{
my($words) = @_;
if(@{$words}){
my $word = $words->[0];
my $a = reverse_words([@{$words}[1 .. (@{$words} - 1)]]);
$a->[@{$a}] = $word;
return $a;
}
return [];
}
MAIN:{
my($S, $reversed);
$S = "The Weekly Challenge";
$reversed = reverse_words([split(/\s+/, $S)]);
print join(" ", @{$reversed}) . "\n";
$S = " Perl and Raku are part of the same family ";
$reversed = reverse_words([split(/\s+/, $S)]);
print join(" ", @{$reversed}) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
Challenge Weekly The
family same the of part are Raku and Perl
Notes
My solution is done using recursion with the self-imposed restrictions
- do not use the reverse function.
- only access array elements in an ordinary way, without using any functions
Other than being a bit over engineered it works as required!
Part 2
You are given two strings $S1 and $S2. Write a script to find out the minimum operations required to convert $S1 into $S2. The operations can be insert, remove or replace a character.
Solution
use strict;
use warnings;
use Memoize;
memoize("edit_distance");
sub edit_distance{
my($s, $t) = @_;
if(length($s) == 0){
return length($t);
}
if(length($t) == 0){
return length($s);
}
my($s0, $t0) = (substr($s, 0, 1), substr($t, 0, 1));
if($s0 eq $t0){
return edit_distance(substr($s, 1), substr($t, 1));
}
my @sorted_distances = sort {$a <=> $b} (
edit_distance($s, substr($t, 1)),
edit_distance(substr($s, 1), $t),
edit_distance(substr($s, 1), substr($t, 1)),
);
return 1 + $sorted_distances[0];
}
MAIN:{
my $distance;
$distance = edit_distance("kitten", "sitting");
print "$distance\n";
$distance = edit_distance("sunday", "monday");
print "$distance\n";
}
Sample Run
$ perl perl/ch-2.pl
3
2
Notes
This code is a pretty faithful Perl translation of the algorithm presented in Haskell in the Wikipedia article for Levenshtein_distance. Like the code for Part 1 of this weeks Challenge this is a recursive procedure.
As noted in that article this algorithm is inefficient in that substrings are checked repeatedly. This code can be made more efficient by the use of Memoization so that the results for each substring are saved and re-used. In the interest of improving performance Memoize is used with the edit_distance function. While the code is now more efficient it really doesn’t have much effect on execution time for these short test strings. However, the code is now ready to handle much more significant sized strings.
References
posted at: 01:26 by: Adam Russell | path: /perl | permanent link to this entry
2021-01-17
Perl Weekly Challenge 095
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a number $N. Write a script to figure out if the given number is a Palindrome. Print 1 if true, otherwise 0.
Solution
use strict;
use warnings;
use boolean;
sub is_palindrome{
my($n) = @_;
return false if $n < 0;
my @digits = split(//, $n);
if(@digits % 2 == 0){
do{
my $a = shift @digits;
my $b = pop @digits;
return false if $a != $b;
}while(@digits);
return true;
}
while(@digits != 1){
my $a = shift @digits;
my $b = pop @digits;
return false if $a != $b;
};
return true;
}
MAIN:{
print is_palindrome(1221);
print "\n";
print is_palindrome(-101);
print "\n";
print is_palindrome(90);
print "\n";
}
Sample Run
$ perl perl/ch-1.pl
1
0
0
Notes
One assumption is made and that is that the input is a valid integer.
My approach here is straightforward iteration and matches what one might do manually: work inwards from both ends and if at any point there is not a match of the two elements being compared then return false. If we make it all the way to the middle then return true. Here the middle is either an empty array, in the case of an even number of elements or, in the case of an odd number of elements, an array of length 1.
The case of a single digit has no special handling, if the number has an odd number of digits but that odd number happens to be 1 then the loop is not entered and we just return true.
Part 2
Write a script to demonstrate Stack operations.
Solution
use strict;
use warnings;
use Stack;
my $stack = new Stack();
$stack->push(2);
$stack->push(-1);
$stack->push(0);
$stack->pop;
print $stack->top . "\n";
$stack->push(0);
print $stack->min . "\n";
The Stack module used is of my own making. The next listing is that code.
use strict;
use warnings;
package Stack{
use boolean;
use Class::Struct;
struct(
data => q/@/
);
sub push{
my($self, $n) = @_;
push @{$self->data()}, $n;
}
sub pop{
my($self, $n) = @_;
pop @{$self->data()};
}
sub top{
my($self, $n) = @_;
@{$self->data()}[@{$self->data()} - 1];
}
sub min{
my($self, $n) = @_;
my @sorted = sort {$a <=> $b} @{$self->data()};
return $sorted[0];
}
true;
}
Sample Run
$ perl -Iperl perl/ch-2.pl
-1
-1
Notes
Like last week’s LinkedList module I use Class::Struct to create the Stack module.
Class::Struct creates accessors for all the class variables automatically. In this way, by calling $self->data(), we get a reference to the internal array data and perform the required Stack operations.
posted at: 14:49 by: Adam Russell | path: /perl | permanent link to this entry
2021-01-10
Perl Weekly Challenge 094
Part 1
You are given an array of strings @S. Write a script to group Anagrams together in any random order.
Solution
use strict;
use warnings;
my %letter_factor = (
e => 2,
t => 3,
a => 5,
o => 7,
i => 11,
n => 13,
s => 17,
h => 19,
r => 23,
d => 29,
l => 31,
c => 37,
u => 41,
m => 43,
w => 47,
f => 53,
g => 59,
y => 61,
p => 67,
b => 71,
v => 73,
k => 79,
j => 83,
x => 89,
q => 97,
z => 101
);
MAIN:{
my $word;
my %anagrams;
while($word = ){
chomp($word);
my @letters = split(//, $word);
my $word_product = 1;
map {$word_product *= $_} map{$letter_factor{$_}} @letters;
push @{$anagrams{$word_product}} , $word if $anagrams{$word_product};
$anagrams{$word_product} = [$word] unless $anagrams{$word_product};
}
close(DATA);
print "Organized anagrams:\n";
for my $key (keys %anagrams){
print " ";
for my $word (@{$anagrams{$key}}){
print "$word ";
}
print "\n";
}
}
__DATA__
opt
bat
saw
tab
pot
top
was
Sample Run
$ perl ch-1.pl
Organized anagrams:
saw was
bat tab
opt pot top
Notes
I am using the same mathematical trick that I have used for anagrams in the past, starting with Challenge 005. The By the Fundamental Theorem of Arithmetic every integer greater than 1 is either a prime number itself or can be represented as the unique product of prime numbers. We use that to our advantage by having a prime number associated with each letter. Each word is a product of these numbers and words with the same product are anagrams.
In this way we build a hash keyed by word product whose values are list of anagrams. After constructing this data structure we then just print out the contents of all the lists.
The choice of letters and prime numbers is based on the Lewand Ordering and it isn’t at all necessary but it does little harm so I left it in anyway.
Part 2
You are given a binary tree. Write a script to represent the given binary tree as an object and flatten it to a linked list object. Finally, print the linked list object.
Solution
use strict;
use warnings;
use Graph;
use LinkedList;
sub build_linked_list{
my($tree) = @_;
my $linked_list = new LinkedList();
my @paths = build_paths($tree);
my $root = $paths[0]->[0];
my $next = $linked_list->insert($root, undef);
for my $path (@paths){
for my $node (@{$path}){
$next = $linked_list->insert($node, $next) if !$linked_list->in_list($node);
}
}
return $linked_list;
}
sub build_paths {
my ($graph) = @_;
my @paths;
local *_helper = sub{
my $v = $_[-1];
my @successors = $graph->successors($v);
if(@successors){
_helper(@_, $_) for @successors;
}
else{
unshift @paths, [@_];
}
};
_helper($_) for $graph->source_vertices();
return @paths;
}
MAIN:{
my $Tree;
$Tree = new Graph();
$Tree->add_vertices(1, 2, 3, 4, 5, 6, 7);
$Tree->add_edge(1, 2);
$Tree->add_edge(1, 3);
$Tree->add_edge(2, 4);
$Tree->add_edge(2, 5);
$Tree->add_edge(5, 6);
$Tree->add_edge(5, 7);
print build_linked_list($Tree)->stringify();
}
The LinkedList module used is of my own making. I am using a somewhat modified version of the LinkedList module I made for Challenge 059. Next is what that code looks like.
use strict;
use warnings;
package LinkedList{
use boolean;
use Tie::RefHash;
use Class::Struct;
package Node{
use Class::Struct;
struct(
data => q/$/,
next => q/Node/
);
}
struct(
head => q/Node/
);
sub stringify{
my($self) = @_;
my $s = "";
my $next = $self->head()->next();
while($next && $next->next()){
$s .= " -> " if $s;
$s = $s . $next->data();
$next = $next->next();
}
$s = $s . " -> " . $next->data() if $next->data();
$s .= "\n";
return $s;
}
sub insert{
my($self, $data, $previous) = @_;
if(!$previous){
$previous=new Node(data => undef, next => undef);
$self->head($previous);
}
my $next=new Node(data => $data, next => undef);
$previous->next($next);
return $next;
}
sub in_list{
my($self, $k) = @_;
my $previous = $self->head();
my $next = $self->head()->next();
tie my %node_value, "Tie::RefHash";
while($next){
return true if($next->data() == $k);
$next = $next->next();
}
return false;
}
true;
}
Sample Run
$ perl -I. ch-2.pl
1 -> 2 -> 4 -> 5 -> 6 -> 7 -> 3
Notes
The Depth First Search (DFS) code for building the paths is the same as last week.
After the DFS returns all the paths they are simply inserted into the list.
My LinkedList module is one of my favorite uses of Class::Struct.
My write up for Challenge 059 has some more notes on this LinkedList.pm.
References
posted at: 11:29 by: Adam Russell | path: /perl | permanent link to this entry
2021-01-03
Perl Weekly Challenge 093
Part 1
You are given set of co-ordinates @N. Write a script to count maximum points on a straight line when given co-ordinates plotted on 2-d plane.
Solution
use strict;
use warnings;
##
# You are given set of co-ordinates @N.
# Write a script to count maximum points
# on a straight line when given co-ordinates
# plotted on 2-d plane.
##
sub triangle_area{
my($i, $j, $k) = @_;
return ($i->[0] * ($j->[1] - $k->[1]))
+ ($j->[0] * ($k->[1] - $i->[1]))
+ ($k->[0] * ($i->[1] - $j->[1]));
}
sub collinear_points{
my(@points) = @_;
my @collinear;
for my $i (@points){
for my $j (@points){
for my $k (@points){
if(triangle_area($i, $j, $k) == 0){
my $i_string = join(",", @{$i});
my $j_string = join(",", @{$j});
my $k_string = join(",", @{$k});
if(($i_string ne $j_string) && ($i_string ne $k_string) && ($j_string ne $k_string)){
my $has_i = grep { $i_string eq join(",", @{$_}) } @collinear;
push @collinear, $i if !$has_i;
my $has_j = grep { $j_string eq join(",", @{$_}) } @collinear;
push @collinear, $j if !$has_j;
my $has_k = grep { $k_string eq join(",", @{$_}) } @collinear;
push @collinear, $k if !$has_k;
}
}
}
}
}
return @collinear;
}
MAIN:{
my @N;
@N = ([5,3], [1,1], [2,2], [3,1], [1,3]);
my @collinear = collinear_points(@N);
print "There are a maximum of " . @collinear . " collinear points.\n"
}
Sample Run
$ perl perl/ch-1.pl
There are a maximum of 3 collinear points.
Notes
Keep in mind that any two points determine a line. Therefore to consider all possible non-trivial lines we need to review all triples of points. This method will work in the most general case when the starting data may contain multiple lines with a larger number of points.
In determining collinearity I calculate the area of a triangle using the triple of points. If the area is zero we know that all the points lay on the same line.
Part 2
You are given a binary tree containing only the numbers 0-9. Write a script to sum all possible paths from root to leaf.
Solution
use strict;
use warnings;
##
# You are given a binary tree containing
# only the numbers 0-9.
# Write a script to sum all possible paths
# from root to leaf.
##
use Graph;
sub travserse_sum{
my($tree) = @_;
my @paths = build_paths($tree);
my $path_sum = 0;
for my $path (@paths){
$path_sum += unpack("%32C*", pack("C*", @{$path}));
}
return $path_sum;
}
sub build_paths {
my ($graph) = @_;
my @paths;
local *_helper = sub{
my $v = $_[-1];
my @successors = $graph->successors($v);
if(@successors){
_helper(@_, $_) for @successors;
}
else{
push @paths, [@_];
}
};
_helper($_) for $graph->source_vertices();
return @paths;
}
MAIN:{
my $Tree;
$Tree = new Graph();
$Tree->add_vertices(1, 2, 3, 4);
$Tree->add_edge(1, 2);
$Tree->add_edge(2, 3);
$Tree->add_edge(2, 4);
print travserse_sum($Tree) . "\n";
$Tree = new Graph();
$Tree->add_vertices(1, 2, 3, 4, 5, 6);
$Tree->add_edge(1, 2);
$Tree->add_edge(1, 3);
$Tree->add_edge(2, 4);
$Tree->add_edge(3, 5);
$Tree->add_edge(3, 6);
print travserse_sum($Tree) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
13
26
Notes
This is straightforward enough, at a high level anyway: (1) Get all paths and then (2) sum all the nodes on the paths.
- I am always happy to have a chance to use the Graph module!
- The Graph module has a bunch of nice algorithms implemented but what we want here is not a shortest path but all paths. The Graph module doesn’t have anything for us to use for that. Implementing a recursive Depth First Search and collecting all the paths is not such a hard thing to do, but in the Holiday Spirit (i.e. laziness) I just re-used Ikegami’s code. See the References section.
- I first used the pack/unpack trick for summing array back in Challenge 007.
References
posted at: 16:37 by: Adam Russell | path: /perl | permanent link to this entry
2020-12-13
Perl Weekly Challenge 090
Part 1
Write a script to print the nucleiobase count in the given DNA sequence. Also print the complementary sequence where Thymine (T) on one strand is always facing an adenine (A) and vice versa; guanine (G) is always facing a cytosine (C) and vice versa.
Solution
use strict;
use warnings;
##
# Write a script to print the nucleiobase count in
# the given DNA sequence. Also print the complementary
# sequence where Thymine (T) on one strand is always
# facing an adenine (A) and vice versa; guanine (G) is
# always facing a cytosine (C) and vice versa.
##
use constant SEQUENCE => "GTAAACCCCTTTTCATTTAGACAGATCGACTCCTTATCCATTCTCAGAGATGTGTTGCTGGTCGCCG";
my %nucleotide_map = (
"T" => "A",
"A" => "T",
"G" => "C",
"C" => "G"
);
sub complementary_sequence{
my($sequence) = @_;
my @complement = map { $nucleotide_map{$_} } split(//, $sequence);
return @complement;
}
MAIN:{
print "length of sequence: " . length(SEQUENCE) . "\n";
print "complementary sequence: " . join("", complementary_sequence(SEQUENCE)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
length of sequence: 67
complementary sequence: CATTTGGGGAAAAGTAAATCTGTCTAGCTGAGGAATAGGTAAGAGTCTCTACACAACGACCAGCGGC
Notes
When doing this problem I recalled a talk I attended at YAPC 2009. In that talk Steven Lembark discussed how allocating array storage for very long arrays, such as DNA sequences!, could result in memory issues. He presented an interesting use of LinkedLists to deal with this. I have to say that I am not sure if Perl’s internals have changed in some way that these concerns are still valid. If you are looking to deal with actual (tremendously large) DNA sequences and not the sample shown here this would be something to consider!
Part 2
You are given two positive numbers $A and $B. Write a script to demonstrate Ethiopian Multiplication using the given numbers.
Solution
use strict;
use warnings;
##
# You are given two positive numbers $A and $B.
# Write a script to demonstrate Ethiopian Multiplication
# using the given numbers.
##
sub ethiopian_multiplication{
my($a, $b) = @_;
my @steps;
my $product = 0;
my ($x, $y) = ($a, $b);
do{
$x = int($x / 2);
$y = $y * 2;
push @steps, [$x, $y] if $x % 2 != 0;
}until $steps[-1]->[0] == 1;
for my $step (@steps){
$product += $step->[1];
}
return $product;
}
MAIN:{
my($A, $B) = (14, 12);
print "$A x $B = " . ethiopian_multiplication($A, $B) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
14 x 12 = 168
Notes
My implementation here follows pretty directly from the definition of the procedure. At each step there is a check to see if the odd/even condition holds and if true the result for that step is saved to an array. After the loop terminates the results are evaluated.
References
posted at: 18:34 by: Adam Russell | path: /perl | permanent link to this entry
2020-12-06
Perl Weekly Challenge 089
Part 1
You are given a positive integer $N. Write a script to sum GCD of all possible unique pairs between 1 and $N.
Solution
use strict;
use warnings;
##
# You are given a positive integer $N. Write a script to sum GCD of all possible
# unique pairs between 1 and $N.
##
sub all_unique_pairs{
my($n) = @_;
my %pairs;
for my $i (1 .. $n){
for my $j (1 .. $n){
$pairs{"$i-$j"} = -1 unless $pairs{"$i-$j"} || $pairs{"$j-$i"} || $i == $j;
}
}
return sort keys %pairs;
}
sub euclid {
my($a, $b) = @_;
return ($b) ? euclid($b, $a % $b) : $a;
}
MAIN:{
my $gcd_sum = 0;
my @values = all_unique_pairs(3);
for my $pair (@values[0 .. @values - 2]){
my($i, $j) = split(/-/, $pair);
$gcd_sum += euclid($i, $j);
print "gcd($i, $j) + ";
}
my ($i, $j) = split(/-/, $values[-1]);
$gcd_sum += euclid($i, $j);
print "gcd($i, $j) = $gcd_sum\n";
$gcd_sum = 0;
@values = all_unique_pairs(4);
for my $pair (@values[0 .. @values - 2]){
my($i, $j) = split(/-/, $pair);
$gcd_sum += euclid($i, $j);
print "gcd($i, $j) + ";
}
($i, $j) = split(/-/, $values[-1]);
$gcd_sum += euclid($i, $j);
print "gcd($i, $j) = $gcd_sum\n";
}
Sample Run
$ perl perl/ch-1.pl
gcd(1, 2) + gcd(1, 3) + gcd(2, 3) = 3
gcd(1, 2) + gcd(1, 3) + gcd(1, 4) + gcd(2, 3) + gcd(2, 4) + gcd(3, 4) = 7
Notes
Sometimes before jumping into my own solutions I do a little research on the topics at hand. In doing so for this I came across this beautifully succinct implementation of Euclid’s algorithm. I decided to use that here for the GCD computation.
Ok, with that sorted out, what is left is to generate all the unique pairs and print the results. I generate the pairs in all_unique_pairs by saving the pairs as hash heys, stringified by joining them with a ‘-’. When printing them out later it is necessary to split on the ‘-’.
Part 2
You are given m x n matrix of positive integers. Write a script to print spiral matrix as a list.
Solution
use strict;
use warnings;
##
# Write a script to display matrix as below with numbers 1 - 9.
# Please make sure numbers are used once.
##
use boolean;
use Math::GSL::Permutation q/:all/;
sub validate {
my($a, $b, $c, $d, $e, $f, $g, $h, $i) = @_;
return false if ($a + $b + $c) != 15;
return false if ($d + $e + $f) != 15;
return false if ($g + $h + $i) != 15;
return false if ($a + $d + $g) != 15;
return false if ($b + $e + $h) != 15;
return false if ($c + $f + $i) != 15;
return false if ($a + $e + $i) != 15;
return false if ($c + $e + $g) != 15;
return true;
}
sub print_matrix {
my($a, $b, $c, $d, $e, $f, $g, $h, $i) = @_;
print "[ $a $b $c ]\n";
print "[ $d $e $f ]\n";
print "[ $g $h $i ]\n";
}
MAIN:{
my $permutation = new Math::GSL::Permutation(9);
while(gsl_permutation_next($permutation->raw) == 0){
my @values = $permutation->as_list();
@values = map { $_ + 1 } @values;
do {
print_matrix(@values);
print "\n";
}if validate(@values);
}
}
Sample Run
$ perl perl/ch-2.pl
[ 2 7 6 ]
[ 9 5 1 ]
[ 4 3 8 ]
[ 2 9 4 ]
[ 7 5 3 ]
[ 6 1 8 ]
[ 4 3 8 ]
[ 9 5 1 ]
[ 2 7 6 ]
[ 4 9 2 ]
[ 3 5 7 ]
[ 8 1 6 ]
[ 6 1 8 ]
[ 7 5 3 ]
[ 2 9 4 ]
[ 6 7 2 ]
[ 1 5 9 ]
[ 8 3 4 ]
[ 8 1 6 ]
[ 3 5 7 ]
[ 4 9 2 ]
[ 8 3 4 ]
[ 1 5 9 ]
[ 6 7 2 ]
Notes
The validate function is pretty straight forward, especially so since I intentionally wrote it to be blazingly obvious what is going on!
The real work is in generating the permutations that get checked. For that I used Math::GSL::Permutation which, as the name implies, is an excellent module which wraps the Gnu Scientific Library. Well, the module is quite solid aside from the documentation which is a bit rough and often requires referring to the GSL documentation on the functions being wrapped.
The main point to know about Math::GSL::Permutation is that it only creates permutations on integers. As Perl programmers we get spoiled by being able to easily manipulate any type of data. If you are interested in permuting lists of arbitrary elements you could use Math::GSL::Permutation to permute the indices, but not the elements themselves.
One final note, having a conditional after the expression is just one of those classic examples of Perl expressiveness, but I seldom see the do/if form. A do/if allows you to have multiple statements, a whole block, execute with the if coming afterwards. Obviously just syntactic sugar for the more common if{} but I prefer it in cases like this where there is no need for an else.
References
posted at: 17:23 by: Adam Russell | path: /perl | permanent link to this entry
2020-11-29
Perl Weekly Challenge 088
Part 1
You are given an array of positive integers @N. Write a script to return an array @M where $M[i] is the product of all elements of @N except the index $N[i].
Solution
use strict;
use warnings;
##
# You are given an array of positive integers @N.
# Write a script to return an array @M where $M[i]
# is the product of all elements of @N except the index $N[i].
##
sub list_product{
my @numbers = @_;
my $product = 1;
map {$product *= $_ } @numbers;
return $product;
}
MAIN:{
my(@N, @M);
@N = (5, 2, 1, 4, 3);
for my $i (0 .. (@N - 1)){
my @numbers = @N[0 .. $i - 1, $i+1 .. (@N - 1)];
push @M, list_product(@numbers);
}
print "(" . join(", ", @M) . ")\n";
@M = ();
@N = (2, 1, 4, 3);
for my $i (0 .. (@N - 1)){
my @numbers = @N[0 .. $i - 1, $i+1 .. (@N - 1)];
push @M, list_product(@numbers);
}
print "(" . join(", ", @M) . ")\n";
}
Sample Run
$ perl perl/ch-1.pl
(24, 60, 120, 30, 40)
(12, 24, 6, 8)
Notes
Taking the product of a list of numbers is a well known perl idiom using map. To keep the code somewhat cleaner I placed the list_product computation in it’s own subroutine. The trickiest part, then, is to make sure the list has the right element removed. This is done using array slices. as we loop over the array of numbers we construct a list of indices which do not include the current element.
Another possible approach would be to use a map inside the loop to identify the elements we want to retain. I decided against that approach since it would be a second complete full iteration over the list. To be fair, I don’t necessarily try to always make these challenge solutions all that efficient, but this just happened to strike me as particularly egregious at the time!
Part 2
You are given m x n matrix of positive integers. Write a script to print spiral matrix as a list.
Solution
use strict;
use warnings;
##
# You are given m x n matrix of positive integers.
# Write a script to print spiral matrix as a list.
##
sub print_remove_top{
my(@matrix) = @_;
print join(", ", @{$matrix[0]}) . ", ";
splice(@matrix, 0, 1);
return @matrix;
}
sub print_remove_right{
my(@matrix) = @_;
my @right;
for my $row (@matrix){
push @right, $row->[-1];
my @a = @{$row}[0 .. (@{$row} - 2)];
$row = \@a;
}
print join(", ", @right) . ", ";
return @matrix;
}
sub print_remove_bottom{
my(@matrix) = @_;
print join(", ", reverse(@{$matrix[-1]})) . ", ";
splice(@matrix, -1);
return @matrix;
}
sub print_remove_left{
my(@matrix) = @_;
my @left;
for my $row (@matrix){
push @left, $row->[0];
my @a = @{$row}[1 .. (@{$row} - 1)];
$row = \@a;
}
print join(", ", reverse(@left)) . ", ";
return @matrix;
}
sub spiral_print{
my(@matrix) = @_;
print "[";
{
@matrix = print_remove_top(@matrix) if @matrix;
@matrix = print_remove_right(@matrix) if @matrix;
@matrix = print_remove_bottom(@matrix) if @matrix;
@matrix = print_remove_left(@matrix) if @matrix;
redo if @matrix;
}
print "\b\b]\n";
}
MAIN:{
spiral_print(
[1, 2, 3],
[4, 5, 6],
[7, 8, 9]
);
spiral_print(
[ 1, 2, 3, 4],
[ 5, 6, 7, 8],
[ 9, 10, 11, 12],
[13, 14, 15, 16]
);
}
Sample Run
$ perl perl/ch-2.pl
[1, 2, 3, 6, 9, 8, 7, 4, 5]
[1, 2, 3, 4, 8, 12, 16, 15, 14, 13, 9, 5, 6, 7, 11, 10]
Notes
The spiral print works in a repeated pattern from the outside in: top row, right column, bottom row, left column. My solution put each print/remove step of this pattern in their own subroutines. A few things worth pointing out
- The matrix is a 2d array: a perl array with inner array references.
- In some cases I use splice to remove from the matrix.
splicedoesn’t work on array references (since perl v5.24) so when needing to remove from the matrice’s inner array references I just use the slicing syntax. - redo looked better to me than the equivalent
whileloop although obviously either one would work fine. - for the spiral effect we need to print bottom up and right to left. In those cases I first use reverse on the elements being printed.
posted at: 13:56 by: Adam Russell | path: /perl | permanent link to this entry
2020-11-22
Perl Weekly Challenge 087
Part 1
You are given an unsorted array of integers @N. Write a script to find the longest consecutive sequence. Print 0 if no sequence found.
Solution
use strict;
use warnings;
##
# You are given an unsorted array of integers @N.
# Write a script to find the longest consecutive sequence.
# Print 0 if no sequence found.
##
sub min_max{
my @a = @_;
my($min, $max) = ($a[0], $a[0]);
for my $x (@a){
$min = $x if($x < $min);
$max = $x if($x > $max);
}
return ($min, $max);
}
sub longest_sequence{
my @sequences = @_;
my @max = (0);
for my $sequence (@sequences){
@max = @{$sequence} if((@{$sequence} > @max) && (@{$sequence} > 1));
}
return @max;
}
sub continuous_sub_sequences{
my @a = @_;
my($min, $max) = min_max(@a);
my @sub_sequences;
my $sub_sequence = [];
while($min <= $max){
my $test = grep {$_ == $min} @a;
if($test){
push @{$sub_sequence}, $min;
}
else{
push @sub_sequences, $sub_sequence if(@{$sub_sequence} > 0);
$sub_sequence = [];
}
$min++;
}
return @sub_sequences;
}
MAIN:{
my @N = (100, 4, 50, 3, 2);
my @sequences = continuous_sub_sequences(@N);
my @max = longest_sequence(@sequences);
print join(",", @max) . "\n";
@N = (20, 30, 10, 40, 50);
@sequences = continuous_sub_sequences(@N);
@max = longest_sequence(@sequences);
print join(",", @max) . "\n";
@N = (20, 19, 9, 11, 10);
@sequences = continuous_sub_sequences(@N);
@max = longest_sequence(@sequences);
print join(",", @max) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
2,3,4
0
9,10,11
Notes
I decided to force myself to work with an artificial constraint as a way fo forcing a little bit more creativity in my solution. When I first looked at this problem I immediately thought “ok, first thing should be to sort the list”. Based on that first impression my self-imposed constraint was to “solve this without using a sort”!
What I did can be summarized as follows: 1. Find the minimum and maximum numbers in the given list. 2. Starting with the minimum number generate test sequences by incrementing upwards towards the maximum list value. 3. As each new element of the test sequence is added test to see if it is in the original list. 4. If it is in the list, good, keep going. 5. If it is not in the list then save the test sequence generated up to that point and continue with a new test sequence. 6. Return all successful test sequences and determine the longest one.
The most blatant inefficiency to this approach is when lists are sparse. For example, suppose we are given (2, 100000000, 3, 4, 5) then we would be iterating from 2 to 100000000. An approach using a sorted list would basically need only loop over the elements of the list, checking to see if the next element was 1 larger than the previous.
Part 2
You are given matrix m x n with 0 and 1. Write a script to find the largest rectangle containing only 1. Print 0 if none found.
Solution
use strict;
use warnings;
##
# You are given matrix m x n with 0 and 1.
# Write a script to find the largest rectangle
# containing only 1. Print 0 if none found.
##
use boolean;
sub print_solution{
my($m, $n) = @_;
if(!$m || !$n){
print "0\n";
}
else{
for (1 .. $n){
print "[". join(" ", (1)x $m) . "]\n";
}
}
}
sub evaluate{
my($m, $n, $matrix) = @_;
my $row_string = join(",", (1) x $m);
my $columns = 0;
for my $row (@{$matrix}){
my $test = join(",", @{$row});
if(index($test, $row_string) > -1){
$columns++;
return true if($columns == $n);
}
else{
$columns = 0;
}
}
return false;
}
sub largest_rectangle{
my @matrix = @_;
my $rows = @{$matrix[0]};
my $columns = @matrix;
my $max_area = 0;
my @rectangle;
for my $m (2 .. $columns){
for my $n (1 .. $rows){
if(evaluate($m, $n, \@matrix)){
if(($m * $n) > $max_area){
$max_area = ($m * $n);
@rectangle = ($m, $n);
}
}
}
}
return @rectangle;
}
MAIN:{
my @MATRIX = (
[0, 0, 0, 1, 0, 0],
[1, 1, 1, 0, 0, 0],
[0, 0, 1, 0, 0, 1],
[1, 1, 1, 1, 1, 0],
[1, 1, 1, 1, 1, 0]
);
print_solution(largest_rectangle(@MATRIX));
@MATRIX = (
[1, 0, 1, 0, 1, 0],
[0, 1, 0, 1, 0, 1],
[1, 0, 1, 0, 1, 0],
[0, 1, 0, 1, 0, 1]
);
print_solution(largest_rectangle(@MATRIX));
@MATRIX = (
[0, 0, 0, 1, 1, 1],
[1, 1, 1, 1, 1, 1],
[0, 0, 1, 0, 0, 1],
[0, 0, 1, 1, 1, 1],
[0, 0, 1, 1, 1, 1]
);
print_solution(largest_rectangle(@MATRIX));
}
Sample Run
$ perl perl/ch-2.pl
[1 1 1 1 1]
[1 1 1 1 1]
0
[1 1 1 1]
[1 1 1 1]
Notes
Unlike Part 1 I did not necessarily have a self-imposed constraint other than to try and be as creative as possible. I’ll only know when I look at other submitted solutions if I was really all that relatively clever or not!
Here I do the following: 1. Check the size of the given matrix 2. Test the matrix for all possible sub-matrix sizes. 3. For all found sub-matrices determine the largest one.
For checking the presence of sub-matrices I join the rows into strings and then use index to see if they appear in a given row or not. To determine if a sub-matrix is the largest I compare the areas of the “rectangles”.
posted at: 17:36 by: Adam Russell | path: /perl | permanent link to this entry
2020-11-15
Perl Weekly Challenge 086
Part 1
You are given an array of integers @N and an integer $A. Write a script to find find if there exists a pair of elements in the array whose difference is $A. Print 1 if exists otherwise 0.
Solution
use strict;
use warnings;
##
# You are given an array of integers @N and an integer $A.
# Write a script to find find if there exists a pair of elements
# in the array whose difference is $A.
# Print 1 if exists otherwise 0.
##
use boolean;
use Math::Combinatorics;
sub build_constraints{
my @constraints;
my $a_not_equal_b = sub { $_[0] != $_[1] };
my $difference_equal_n = sub { $_[0] - $_[1] == $_[2] };
return (
$a_not_equal_b,
$difference_equal_n
);
}
MAIN:{
my $combinations = Math::Combinatorics->new(
count => 2,
data => [@ARGV[1 .. @ARGV - 1]],
);
my $found = false;
my ($check_equal, $check_difference) = build_constraints();
while(my @combination = $combinations->next_combination()){
if($check_equal->(@combination) && $check_difference->(@combination, $ARGV[0])){
$found = true;
print "1\n"; last;
}
}
print "0\n" if(!$found);
}
Sample Run
$ perl perl/ch-1.pl 15 10 30 20 50 40
0
$ perl perl/ch-1.pl 7 10 8 12 15 5
1
Notes
This is a fairly silly use of the constraint programming approach I used last week. Like last time I generate all combinations and test them using a filtering approach. The filter is an array of constraint functions. Here we just have two simple constraints though!
Part 2
You are given Sudoku puzzle (9x9). Write a script to complete the puzzle
Notes
I didn’t have a chance to implement a solution in Perl. I would have used a similar constraint approach if I did. This is a natural use for Prolog and if you’re interested in reading in my Prolog implementation you can go here.
posted at: 23:49 by: Adam Russell | path: /perl | permanent link to this entry
2020-11-08
Perl Weekly Challenge 085
Part 1
You are given an array of real numbers greater than zero. Write a script to find if there exists a triplet (a,b,c) such that 1 < a+b+c < 2. Print 1 if you succeed otherwise 0.
Solution
use strict;
use warnings;
##
# You are given an array of real numbers greater than zero.
# Write a script to find if there exists a triplet (a,b,c)
# such that 1 < a+b+c < 2. Print 1 if you succeed otherwise 0.
##
use boolean;
use Math::Combinatorics;
sub build_constraints{
my @constraints;
my $a_not_equal_b = sub { $_[0] != $_[1] };
my $a_not_equal_c = sub { $_[0] != $_[2] };
my $b_not_equal_c = sub { $_[1] != $_[2] };
my $sum_greater_than_1 = sub { 1 < ($_[0] + $_[1] + $_[2]) };
my $sum_less_than_2 = sub { 2 > ($_[0] + $_[1] + $_[2]) };
return (
$a_not_equal_b,
$a_not_equal_c,
$b_not_equal_c,
$sum_greater_than_1,
$sum_less_than_2
);
}
MAIN:{
my $combinations = Math::Combinatorics->new(
count => 3,
data => [@ARGV],
);
my $found;
while(my @combination = $combinations->next_combination()){
$found = true;
for my $constraint (build_constraints()){
if(!$constraint->(@combination)){
$found = false;
last;
}
}
do{ print "1\n"; last; } if($found);
}
print "0\n" if(!$found);
}
Sample Run
$ perl perl/ch-1.pl 0.1 1.2 3.4 0.2
1
$ perl perl/ch-1.pl 1.1 1.2 3.4 0.2
0
Notes
I decided to try a constraint programming approach for this. While there are several modules for doing this available on CPAN I didn’t want to quite go so deep down that rabbithole. Instead I took the simpler path of implementing each constraint as a subroutine stored in an array. For each candidate combination the constraints are tests. Since all constraints must be satisfied if any one returns a false value then we can move immediately to the next combination.
Part 2
You are given a positive integer $N. Write a script to find if it can be expressed as a ** b where a > 0 and b > 1. Print 1 if you succeed otherwise 0.
Solution
use strict;
use warnings;
##
# You are given a positive integer $N.
# Write a script to find if it can be expressed
# as a ^ b where a > 0 and b > 1.
# Print 1 if you succeed otherwise 0.
##
use boolean;
sub log_a{
my($a, $n) = @_;
return log($n)/log($a);
}
MAIN:{
my $N = $ARGV[0];
my $found = false;
for my $a (2 .. $N){
my $b = log_a($a, $N);
if($b =~ /^[-]?\d+$/ && $b > 1){
print "1\n";
$found = true;
last;
}
}
print "0\n" if(!$found);
}
Sample Run
$ perl perl/ch-2.pl 7
0
$ perl perl/ch-2.pl 9
1
Notes
I was tempted to repeat roughly the same design as Part 1 and use constraints but that really would be over engineering it! Instead here we just loop over all possible values $a and test using logarithms to see if $b holds an integer value. There seems to be a number of ways to do the test to determine if a scalar holds an integer but a regex seems maybe the most idiomatically Perlish way.
posted at: 16:20 by: Adam Russell | path: /perl | permanent link to this entry
2020-11-01
Perl Weekly Challenge 084
Part 1
You are given an integer $N. Write a script to reverse the given integer and print the result. Print 0 if the result doesn’t fit in 32-bit signed integer.
Solution
use strict;
use warnings;
##
# You are given an integer $N.
# Write a script to reverse the given integer and print the result.
# Print 0 if the result doesn’t fit in 32-bit signed integer.
##
use Config;
use boolean;
use constant MAX_32BIT_SIGNED => 2_147_483_647;
sub reverse_digits{
my($n) = @_;
return 0 if $n > MAX_32BIT_SIGNED || $n < -1*MAX_32BIT_SIGNED;
my $negative = $n < 0 ? true : false;
$n = abs($n) if $negative;
return join("", reverse split(//, $n)) if !$negative;
return "-" . join("", reverse split(//, $n));
}
MAIN:{
my $A = $ARGV[0];
print reverse_digits($A) . "\n";
}
Sample Run
$ perl perl/ch-1.pl -123452
-254321
$ perl perl/ch-1.pl 12345
54321
$ perl perl/ch-1.pl -2147483647
-7463847412
$ perl perl/ch-1.pl -2147483648
0
$ perl perl/ch-1.pl 2147483647
7463847412
$ perl perl/ch-1.pl 2147483
3847412
Notes
Before starting this I did a little research and found some interesting articles. This Perlmonks thread covers the topic on the size in bytes of integers in Perl. This thread gets into how to detect overflow. In this challenge, however, we don’t need to really know any of this since the perl I am using (5.28.0) on my Mac Mini (running OS X) can easily accomodate much larger numbers than the 32-bit signed restriction placed here. All that need be done is check to see if the number is above or below this maximum/minimum.
posted at: 14:57 by: Adam Russell | path: /perl | permanent link to this entry
2020-10-25
Perl Weekly Challenge 083
Part 1
You are given a string $S with 3 or more words. Write a script to find the length of the string except the first and last words ignoring whitespace.
Solution
use strict;
use warnings;
##
# You are given a string $S with 3 or more words.
# Write a script to find the length of the string
# except the first and last words ignoring whitespace.
##
sub count_most_words{
my ($s) = @_;
my $count = 0;
my @a = split(/\s/, $s);
map {$count += tr/a-zA-Z//d} @a[1 .. (@a - 2)];
return $count;
}
MAIN:{
my $S;
$S = "The Weekly Challenge";
print "$S --> " . count_most_words($S) . "\n";
$S = "The purpose of our lives is to be happy";
print "$S --> " . count_most_words($S) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
The Weekly Challenge --> 6
The purpose of our lives is to be happy --> 23
Notes
Anytime I need to count characters I immediately think of tr. tr will, of course, do character replacements but it’s return value is the number of characters which have been effected. Here with the d option the matching characters are just deleted. This code would work exactly just as well with the d but I figured it’d be actually less confusing to have it there and make it more clear what it was doing.
Part 2
You are given an array @A of positive numbers. Write a script to flip the sign of some members of the given array so that the sum of the all members is minimum non-negative.
use strict;
use warnings;
##
# You are given an array @A of positive numbers.
# Write a script to flip the sign of some members
# of the given array so that the sum of the all
# members is minimum non-negative.
##
sub try_all_flips{
my(@a) = @_;
my @minimum = (undef, undef, []);
for my $i (0 .. (2**(@a) - 1)){
my $b = sprintf("%0" . @a . "b", $i);
my @b = split(//, $b);
my $flip_count = 0;
map {$flip_count++ if $_ == 1} @b;
my @f;
for my $i (0 .. (@b - 1)){
if($b[$i] == 1){
push @f, (-1) * $a[$i];
}
else{
push @f, $a[$i];
}
}
my $sum = unpack("%32I*", pack("I*", @f));
if(!defined($minimum[0]) || ($sum <= $minimum[0] && $sum >= 0)){
if(defined($minimum[0]) && $sum == $minimum[0] && $flip_count < $minimum[1]){
$minimum[0] = $sum;
$minimum[1] = $flip_count;
$minimum[2] = \@f;
}
elsif(!defined($minimum[0])){
$minimum[0] = $sum;
$minimum[1] = $flip_count;
$minimum[2] = \@f;
}
elsif($sum < $minimum[0]){
$minimum[0] = $sum;
$minimum[1] = $flip_count;
$minimum[2] = \@f;
}
}
}
return @minimum;
}
MAIN:{
my @A;
my @minimum;
@A = (3, 10, 8);
@minimum = try_all_flips(@A);
print "[". join(", ", @A) . "] --> ";
print " [". join(", ", @{$minimum[2]}) . "] = " . $minimum[0] ."\n";
@A = (12, 2, 10);
@minimum = try_all_flips(@A);
print "[". join(", ", @A) . "] --> ";
print " [". join(", ", @{$minimum[2]}) . "] = " . $minimum[0] ."\n";
}
Sample Run
$ perl perl/ch-2.pl
[3, 10, 8] --> [3, -10, 8] = 1
[12, 2, 10] --> [-12, 2, 10] = 0
Notes
This is a brute force approach. I use the same method for generating all combinations that I used in Challenge 077 with the variation that here I use the generated combination to determine which elements of the list are to be flipped. After calculating the sum of each new list (with flipped elements) I check to see if this is a new minimum positive value and, if so, if it has been done with fewer flips.
posted at: 01:01 by: Adam Russell | path: /perl | permanent link to this entry
2020-10-18
Perl Weekly Challenge 082
Part 1
You are given 2 positive numbers $M and $N. Write a script to list all common factors of the given numbers.
Solution
use strict;
use warnings;
##
# You are given 2 positive numbers $M and $N.
# Write a script to list all common factors of the given numbers.
##
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 common_factors{
my($m, $n) = @_;
my @common_factors = grep { my $f = $_; grep { $f == $_ } @{$n}} @{$m};
return @common_factors;
}
MAIN:{
my $M = 12;
my $N = 18;
my @m_factors = factor($M);
my @n_factors = factor($N);
print "(" . join(",", common_factors(\@m_factors, \@n_factors)) . ")\n";
}
Sample Run
$ perl perl/ch-1.pl
(1,2,6,3)
Notes
I have used sub factor previously, back in Challenge 008. The most interesting thing in this solution is probably the nested grep’s. In order to nest them properly you need to create a local variable to hold the element being examined in the outer grep block. Here I use $f. Although we need just two grep’s here this trick can be used to nest them more deeply.
Part 2
You are given 3 strings; $A, $B and $C. Write a script to check if $C is created by an interleaving of $A and $B. Print 1 if check is success otherwise 0.
use strict;
use warnings;
##
# You are given 3 strings; $A, $B and $C.
# Write a script to check if $C is created by interleave $A and $B.
# Print 1 if check is success otherwise 0.
##
sub find_remove{
my($s, $x) = @_;
my $i = index($s, $x);
if($i != -1){
substr $s, $i, length($x), "";
return $s;
}
return undef;
}
MAIN:{
my $A = "XY";
my $B = "X";
my $C = "XXY";
my $s = find_remove($C, $A);
if($s && $s eq $B){
print "1\n";
exit;
}
else{
$s = find_remove($C, $B);
if($s && $s eq $A){
print "1\n";
exit;
}
}
print "0\n";
}
Sample Run
$ perl perl/ch-2.pl
1
Notes
I believe this is the most straightforward way of tackling this problem. By checking for both $A and $B as substrings and removing them if found we can determine if there was an interleaving by checking to see if the other remains.
posted at: 01:42 by: Adam Russell | path: /perl | permanent link to this entry
2020-10-11
Perl Weekly Challenge 081
Part 1
You are given 2 strings, $A and $B. Write a script to find out common base strings in $A and $B.
Solution
use strict;
use warnings;
##
# You are given 2 strings, $A and $B.
# Write a script to find out common base strings in $A and $B.
##
use boolean;
sub contains{
my($s0) = @_;
return sub{
my($s) = @_;
return [true, $s0] if($s =~ m/^($s0)+$/g);
return [false, $s0];
}
}
sub make_checks{
my($s) = @_;
my @letters = split(//, $s);
my @checks;
for my $i (0 .. (int(@letters/2 - 1))){
push @checks, contains(join("", @letters[0 .. $i]));
}
return @checks;
}
MAIN:{
my($A, $B);
#$A = "aaaaaaa";
#$B = "aaaaaaaaaaaaaaaaaa";
$A = "abcdabcd";
$B = "abcdabcdabcdabcd";
my @checks = make_checks($A);
for my $check (@checks){
if($check->($A)->[0] && $check->($B)->[0]){
print $check->($A)->[1] . "\n";
exit;
}
}
}
Sample Run
$ perl perl/ch-1.pl
abcdabcd, abcdabcdabcdabcd --> (abcd abcdabcd)
aaa, aa --> (a)Notes
I used a similar technique to what I used in Challenge 003 and Challenge 004 where I create an array of anonymous functions which each check different substrings. The functions are created using what is called currying whereby we pass in a parameter (or multiple parameters if we needed to!) to a function which creates a closure around those parameters and returns a new function. This is, I admit, not all that necessary! I repeat the method though out of a sense of nostalgia. We are now on Challenge 081!
Part 2
You are given file named input. Write a script to find the frequency of all the words. It should print the result as first column of each line should be the frequency of the word followed by all the words of that frequency arranged in lexicographical order. Also sort the words in the ascending order of frequency.
use strict;
use warnings;
##
# You are given file named input.
# Write a script to find the frequency of all the words.
# It should print the result as first column of each line should be the frequency of the
# word followed by all the words of that frequency arranged in lexicographical order. Also
# sort the words in the ascending order of frequency.
##
MAIN:{
my %counts;
my %count_words;
my $s;
{ local $/;
$s = ;
}
$s =~ s/'s//g;
$s =~ tr/."(),//d;
$s =~ tr/-/ /;
my @words = split(/\s+/, $s);
for my $word (@words){
$counts{$word}++;
}
for my $k (keys %counts){
my $count = $counts{$k};
push @{$count_words{$count}}, $k;
}
for my $k (sort keys %count_words){
print $k . "\t" . join(" ", sort {$a cmp $b} @{$count_words{$k}}) . "\n";
}
}
__DATA__
West Side Story
The award-winning adaptation of the classic romantic tragedy "Romeo and
Juliet". The feuding families become two warring New York City gangs,
the white Jets led by Riff and the Latino Sharks, led by Bernardo. Their
hatred escalates to a point where neither can coexist with any form of
understanding. But when Riff's best friend (and former Jet) Tony and
Bernardo's younger sister Maria meet at a dance, no one can do anything
to stop their love. Maria and Tony begin meeting in secret, planning to
run away. Then the Sharks and Jets plan a rumble under the
highway--whoever wins gains control of the streets. Maria sends Tony to
stop it, hoping it can end the violence. It goes terribly wrong, and
before the lovers know what's happened, tragedy strikes and doesn't stop
until the climactic and heartbreaking ending.
Sample Run
$ perl perl/ch-2.pl
1 But City It Jet Juliet Latino New Romeo Side Story Their Then West York adaptation any anything at award away become before begin best classic climactic coexist control dance do doesn't end ending escalates families feuding form former friend gains gangs goes happened hatred heartbreaking highway hoping in know love lovers meet meeting neither no one plan planning point romantic rumble run secret sends sister streets strikes terribly their two under understanding until violence warring what when where white whoever winning wins with wrong younger
2 Bernardo Jets Riff Sharks The by it led tragedy
3 Maria Tony a can of stop
4 to
9 and the
Notes
I have to admit that sometimes, even after many years of using Perl, that if I don’t use a certain feature often enough that I end up getting a little surprised. The surprise here is that Perl is clever enough to know that if I am trying a push onto a hash value which is undef, such as when I first do a push @{$count_words{$count}}, $k; for a new value of $k, that a new array is created. No need to check for undef and create a new one manually. This is called autovivification and while a very common thing in Perl for whatever reason it managed to catch me a little by surprise this time around. Probably due to my working a lot in other languages recently that don;t have this feature! Gabor has a nice writeup on autovivification for anyone interested in reading more.
posted at: 17:56 by: Adam Russell | path: /perl | permanent link to this entry
2020-10-04
Perl Weekly Challenge 080
Part 1
use strict;
use warnings;
##
# You are given an unsorted list of integers @N.
# Write a script to find out the smallest positive number missing.
##
sub least_missing{
my(@numbers) = @_;
@numbers = sort @numbers;
for my $i ($numbers[0] .. $numbers[@numbers - 1]){
my @a = grep { $_ == $i } @numbers;
return $i if(!@a && $i > 0);
}
return undef;
}
MAIN:{
my @N;
@N = (5, 2, -2, 0);
my $least_missing = least_missing(@N);
print "The least mising number from (" .
join(",", @N) . ") is $least_missing\n";
@N = (1, 8, -1);
$least_missing = least_missing(@N);
print "The least mising number from (" .
join(",", @N) . ") is $least_missing\n";
@N = (2, 0, -1);
$least_missing = least_missing(@N);
print "The least mising number from (" .
join(",", @N) . ") is $least_missing\n";
}
Sample Run
$ perl perl/ch-1.pl
The least mising number from (5,2,-2,0) is 1
The least mising number from (1,8,-1) is 2
The least mising number from (2,0,-1) is 1Notes
The list is given in arbitrary order so the first thing to do is to sort it. Once in sorted order iterate from the least number to the highest, incrementing by one at each step. Perl makes this easy with the range (aka flip-flop) operator. Each each iteration see if the current number is from the original list or not and if not, then if it is the smallest positive number not yet seen, which really just means the first positive number not from the original list.
As I am writing this I realize that it’d make sense to use grep to remove all the negative numbers from the list before even bothering to sort them. If the list were presented as, say, 1 million negative numbers and then three positive ones why waste doing anything with all the negatives!
Part 2
use strict;
use warnings;
##
# You are given rankings of @N candidates.
# Write a script to find out the total candies needed for all candidates.
# You are asked to follow the rules below:
# a) You must given at least one candy to each candidate.
# b) Candidate with higher ranking get more candies than their immediate
# neighbors on either side.
##
sub count_candies{
my(@candidates) = @_;
my $candies = @candidates;
for my $i (0 .. (@candidates - 1)){
if($candidates[$i - 1]){
$candies++ if $candidates[$i] > $candidates[$i - 1];
}
if($candidates[$i + 1]){
$candies++ if $candidates[$i] > $candidates[$i + 1];
}
}
return $candies;
}
MAIN:{
my @N;
my $number_candies;
@N = (1, 2, 2);
$number_candies = count_candies(@N);
print "The number of candies for (" .
join(",", @N) . ") is $number_candies\n";
@N = (1, 4, 3, 2);
$number_candies = count_candies(@N);
print "The number of candies for (" .
join(",", @N) . ") is $number_candies\n";
}
Sample Run
$ perl perl/ch-2.pl
The number of candies for (1,2,2) is 4
The number of candies for (1,4,3,2) is 7Notes
I don’t think there are any surprises in this approach. In fact, I could not think of a better way, in terms of efficiency, than this. Still, this is not exactly exciting code to read!
posted at: 15:26 by: Adam Russell | path: /perl | permanent link to this entry
2020-09-27
Perl Weekly Challenge 079
Part 1
You are given a positive number $N. Write a script to count the total number of set bits of the binary representations of all numbers from 1 to $N and return $total_count_set_bit % 1000000007.
Solution
Sample Run
$ perl perl/ch-1.pl
5 % 1000000007 = 5
4 % 1000000007 = 4
Notes
The approach here is to continuously shift bits off to the right, checking to see if the bit about to be shifted off is set or not. This is a pretty standard pattern and it looks pretty much the same in C++ and Prolog too!
Part 2
You are given an array of positive numbers @N. Write a script to represent it as Histogram Chart and find out how much water it can trap.
Sample Run
Notes
This is one of the more fun sorts of problems that come up in these challenges! It is somewhat similar to the “leader problem” from last week in that we are given an array of numbers and need to do a similar set of look ahead comparisons. Here we look ahead in the array to determine if what I call buckets exist. Whatever buckets are found are then used to compute the total volume as specified.
References
posted at: 17:34 by: Adam Russell | path: /perl | permanent link to this entry
2020-09-20
Perl Weekly Challenge 078
Part 1
You are given an array @A containing distinct integers. Write a script to find all leader elements in the array @A. Print (0) if none found.
Solution
Sample Run
$ perl perl/ch-1.pl 6
@A = (9,10,7,5,6,1)
Leaders = (10,7,6,1)
@A = (3,4,5)
Leaders = (5)
Notes
The approach here is to just repeating the checks for smaller elements. Nothing too fancy. In fact, I actually thought that there might be room for some fun and over engineered way of doing this but I couldn’t really come up with anything that wouldn’t just be obfuscated!
Part 2
You are given array @A containing positive numbers and @B containing one or more indices from the array @A. Write a script to left rotate @A so that the number at the first index of @B becomes the first element in the array. Similary, left rotate @A again so that the number at the second index of @B becomes the first element in the array.
Sample Run
$ perl perl/ch-2.pl
@A = (10,20,30,40,50)
@B = (3,4)
Rotations:
[40,50,10,20,30]
[50,10,20,30,40]
@A = (7,4,2,6,3)
@B = (1,3,4)
Rotations:
[4,2,6,3,7]
[6,3,7,4,2]
[3,7,4,2,6]
Notes
Another straight forward one. For each value in @B I shift and push the respective number of times.
posted at: 00:27 by: Adam Russell | path: /perl | permanent link to this entry
2020-09-13
Perl Weekly Challenge 077
Part 1
You are given a positive integer $N. Write a script to find out all possible combination of Fibonacci Numbers required to get $N on addition.
Solution
Sample Run
$ perl perl/ch-1.pl 6
1 + 5 = 6
1 + 2 + 3 = 6
1 + 5 = 6
1 + 2 + 3 = 6
$ perl perl/ch-1.pl 9
1 + 8 = 9
1 + 3 + 5 = 9
1 + 8 = 9
1 + 3 + 5 = 9
1 + 1 + 2 + 5 = 9
Notes
The approach here is to generate all Fibonacci terms up to $n and then evaluate all combinations of these terms and see which sum to $n. The most interesting part here is perhaps how the combinations are generated. Here we are making use of a convenient property that there are 2^n -1 subsets of the set {1..n}. So we generate numbers $b as an n-digit binary number using sprintf. We correspond the binary digits of k to indices into the Fibonacci sequence and select a Fibonacci term if its bit value is 1.
Also note that the Fibonacci sequence starts off as 1, 1, 2, 3, 5, … and so while we may see two 1s these are separate, and not repeated, Fibonacci terms.
Part 2
You are given m x n character matrix consists of O and X only. Write a script to count the total number of X surrounded by O only. Print 0 if none found.
Sample Run
perl perl/ch-2.pl
O O X
X O O
X O O
1 X found at Row 1 Column 3.
O O X O
X O O O
X O O X
O X O O
1st X found at Row 1 Column 3.
2nd X found at Row 3 Column 4.
Notes
I made use of Neil Bowers Lingua::EN::Numbers::Ordinate to make the output look a little nicer.
Otherwise think this is straight forward enough…for each test matrix identify the Xs and then check to see if they are “lonely”. The number of possible adjacent space to check is no more than eight as shown in the code so we check these all, if they exist.
posted at: 16:54 by: Adam Russell | path: /perl | permanent link to this entry
2020-09-06
Perl Weekly Challenge 076
I did this week's Perl Weekly Challenge in both Perl and Prolog. The Prolog solutions were good practice in shaking the rust off my logic programming but I won't discuss them here, to keep things short. The code for the Prolog solutions for Part 1 and Part 2 are on GitHub.
Part 1
You are given a number $N. Write a script to find the minimum number of prime numbers required, whose summation gives you $N. For the sake of this task, please assume 1 is not a prime number.
For this solution I used a pre-computed list of the first 1000 prime numbers. Larger pre-computed lists are available and of course computing them directly is always an option too! For the purposes of this challenge it seemed a pre-computed list would be OK.
Code
Sample Run
$ perl perl/ch-1.pl 9
7 + 2 = 9
$ perl perl/ch-1.pl 87
83 + 2 + 2 = 87
Part 2
Write a script that takes two file names. The first file would contain word search grid as shown below. The second file contains list of words, one word per line. You could even use local dictionary file.
Print out a list of all words seen on the grid, looking both orthogonally and diagonally, backwards as well as forwards.
I opted to hard code the grid and load a small dictionary file. This file was obtained from http://www-personal.umich.edu/~jlawler/wordlist.html and contains 60,000 of the most common english words. Ultimately this yield a lot of awkward looking two and three letter words which, frankly, I do not personally consider all that common. I used the full dictionary but filter the results to only words with 4 or more letters.
The approach is straightforward:
- Create arrays of all diagonals, columns, rows, etc of the grid.
- Search for all dictionary words (forward and reverse) from all the grid arrays.
- Filter out words with less than 4 letters. Many of these are very uncommon.
- Sort and display the found words.
Sample Run
$ perl perl/ch-2.pl
Found the following words: align,alls,ante,arare,aras,aras,argos,baas,bide,blunt,bosc,broad,buff,butea,cart,cess,cold,cord,demi,depart,departed,doth,dust,ebro,enter,etna,eves,filch,garlic,gila,goat,gram,grieve,grit,hani,hazard,heed,laic,lien,luge,lune,mali,malign,malignant,mall,mein,mero,midst,need,oats,ough,ought,ovary,part,parte,parted,quash,rape,rara,rare,rast,road,roccus,ruse,sara,sara,shed,shrine,slag,slug,social,spasm,spasmodic,succor,succors,theorem,togo,trap,tsar,vary,virus,visa,wigged,zing
posted at: 21:45 by: Adam Russell | path: /perl | permanent link to this entry
2020-08-30
Largest Rectangle Histogram
Perl Weekly Challenge 075 asks us to find the maximum rectangle of a histogram as follows
You are given an array of positive numbers @A.
Write a script to find the largest rectangle histogram created by the given array.
Looking at the above histogram, the largest rectangle (4 x 3) is formed by columns (4, 5, 3 and 7).
Output: 12
This is a fun sort of problem that seems to be right at home in a programming challenge and seldom seen in more typical scenarios!
My approach to this is as follows:
- Compare each value V in the histogram against the others.
- If V is greater than the one being compared against set rectangle size to 0.
- If V is less than or equal to the one being compared against increase rectangle by V.
- We determine the maximum rectangle size by comparing all the computed rectangle sizes as they are generated.
In code:
Sample Run
posted at: 06:09 by: Adam Russell | path: /perl | permanent link to this entry
2020-08-27
All Combinations Equal to a Sum in Perl and Prolog
A problem that comes up surprisingly often is that we want to determine lists of numbers which sum to some given number S.
For example, let's look at Perl Weekly Challenge 075
You are given a set of coins @C, assuming you have infinite amount of each coin in the set.
Write a script to find how many ways you make sum $S using the coins from the set @C.
Example:
Input:
@C = (1, 2, 4)
$S = 6
Output: 6
There are 6 possible ways to make sum 6.
a) (1, 1, 1, 1, 1, 1)
b) (1, 1, 1, 1, 2)
c) (1, 1, 2, 2)
d) (1, 1, 4)
e) (2, 2, 2)
f) (2, 4)
Such a problem is a nice application for a logic programming approach!
Here is a first attempt with a pure Prolog solution (with SWI-Prolog).
Sample Run
$ swipl -s prolog/ch-1.p -g main
[[1,1,1,1,1,1],[2,1,1,1,1],[1,2,1,1,1],[1,1,2,1,1],[2,2,1,1],[4,1,1],[1,1,1,2,1],[2,1,2,1],[1,2,2,1],[1,4,1],[1,1,1,1,2],[2,1,1,2],[1,2,1,2],[1,1,2,2],[2,2,2],[4,2],[1,1,4],[2,4]]
We have some duplicate solutions to clean up, but since this is a Perl centric challenge let's do it in Perl and while we're at it, we'll also have Perl handle the input and output.
Sample Run
$ perl perl/ch-1.pl 6 "1,2,4"
(1,1,1,1,2)
(1,1,4)
(1,1,1,1,1,1)
(1,1,2,2)
(2,2,2)
(2,4)
The deduplication is handled by storing the resulting lists as hash keys. In order to use array references as hash keys we need to use Hash::MultiKey. The target sum and coin value list are set in the Prolog code via string substitution. Of course these could have been set as parameters and passed in the normal way but this seemed slightly more fun!
posted at: 21:37 by: Adam Russell | path: /perl | permanent link to this entry
2020-08-09
n! has how many trailing zeroes?
Perl Weekly Challenge 072 asks
You are given a positive integer $N (<= 10). Write a script to print number of trailing zeroes in $N!.
Note that the number of zeroes is equivalent to the number of factors of 10 in n!. For example, 4! = 4 * 3 * 2 * 1 which has none. 6! = 6 * 5 * 4 * 3 * 2 * 1 = 6 * 4 * 3 *1 * (5 * 2) has one. 10! = 10 * 9 * 8 * 7 * 6 * 4 * 3 * 1 * (5 * 2) has two.
In this case, for n <= 10, we can can these cases directly.
sub count_10s{
my($n) = @_;
return 2 if $n == 10;
return 1 if $n >=5 && $n < 10;
return 0 if $n < 5;
}
If we wanted to solve this for the general case we would have to follow an algorithm that would look like this (pseudo code)
Function count 10s
Pass In: n, a whole number
Doing: For each term of n! = 1 * 2 * 3 * ... * n perform a prime factorization.
Save all prime factors for all terms to an array. Count each pair of
(2,5). This is the number of factors of 10 in n!
Pass Out: the number of factors of 10 in n!
Endfunction
posted at: 18:46 by: Adam Russell | path: /perl | permanent link to this entry
Using -s with Perl One Liners
For Perl Weekly Challenge 072 we are asked the following:
You are given a text file name $file and range $A - $B where $A <= $B. Write a script to display lines range $A and $B in the given file.
I was a bit surprised to realize how this could be done with a one liner. In the example below input.txt is a plain text file which has 100 lines that all look like LX for 1 <= X <= 100.
$ perl -s -n -e 'print if $. >= $A && $. <= $B' — -A=4 -B=12 < input.txt
L4
L5
L6
L7
L8
L9
L10
L11
L12
The use of the special variable $. to track input line numbers is a common Perl idiom. What was surprising to me was that I was unfamiliar with the -s command line option. This option allows you to set variables on the command line. Anything after the — is interpreted to be a variable initialized to the given value. You can see that in the example above where -A=4 and -B=12 creates variables $A and $B initialized to 4 and 12 respectively.
If you do not set the variable to something then it is just initialized as true. For example:
$ perl -s -e 'print "$x\n";' — -x
1
posted at: 01:34 by: Adam Russell | path: /perl | permanent link to this entry
2019-05-26
Perl Weekly Challenge 009
This week's Perl Weekly Challenge presented a problem I hadn't really thought of before: how to do a ranking or what is mathematically referred to as a weak ordering.
Part 1
Sample Run
$ perl perl5/ch-1.plFirst square with five distinct digits: 12769 (= 113 * 113)
I think this was straightforward enough of a problem with a straightforward solution: start iterating through integers until you find one that has the property we want. The number must have a square root of at least 100 since it has at least five digits so that is our starting point. Counting the unique digits (see line 12) is done using a clever trick suggested by Prakash Kailasa via a Gabor Szabo Perl Maven blog. The trick is to create an anonymous hash with the values from the array as the keys. This will remove the duplicates since hash keys must be unique. Originally this could be done without the %{} around the map {$_ => 1} because for a time keys() could be applied to a hash reference however this is no longer allowed in perl-5.28.0 (I think it was removed in perl-5.14.0?).
Part 2
Sample Run
This presented some nice opportunities for creativity. It's a standing rule, as far as I know, that if a challenge statement has any ambiguity than you can simply interpret it as you like. This leads to solutions having a variety of styles and flavors. The problem statement didn't suggest what in particular we should rank so I decided to do a ranking of basic Perl objects. These are stored in an array, sorted, and then sent to the ranking functions. The sorting and ranking functions were written as generically as possible to allow for any sort of object as long as it has an accessor that returns a single numeric value. A rare bit of explicitly polymorphic code in Perl.
I think that the ranking logic would have been a little less convoluted with a better choice of data structures. I think a doubly linked list (i.e. with forward and previous references) would have been best. Still, the Standard and Dense rankings did not cause too much trouble to implement. The Modified ranking was the most complex. A concise definition from Wikipedia is that, for the Modified ranking, each item's ranking number is equal to the number of items ranked equal to it or above it. But what about ties for first place? And multi-way ties? Based on the sample output shown I think I achieved all the goals of the modified ranking but this is a good example of having someone else check your work! Especially a domain expert, someone who may have worked with this ranking many times in the past. Some searches didn't reveal much use of the Modified ranking. I did find a suggestion on how to address ties for first in Modifed Ranking here. Overall documentation of examples implementing the Modified ranking was otherwise not turning up in my searches.
I did make use of a core module which I do not ordinarily use, Tie::RefHash. For this particular problem I found it convenient to use the object references as hash keys and to do so requires the use of this module.
posted at: 12:47 by: Adam Russell | path: /perl | permanent link to this entry
2019-05-18
There is nothing wrong with use Threads;
Fight me
In a previous article I showed how a significant performance improvement can be made by re-implementing key parts of your Perl code in C++. This was done as an example of improving a brute force computation of the first five perfect numbers. In my writeup of that initial problem I discussed how the best way to improve the speed of that computation was an algorithmic improvement, using well known mathematical relationships to compute the perfect numbers directly and not doing a large scale brute force evaluation of tens of millions of numbers. Still, the fact remains that substantial performance improvements can be made through either one or both of (a) parallelizing the problem and spreading the computation out to run concurrently in pieces and (b) implementing the most computationally intense parts of the code in a compiled language such as C++. (b) was discussed previously, as mentioned above, here we'll take a look at (a). Specifically we'll look at using the perl Threads module. First, though, let's discuss the use of the Threads module.
Threads in Perl
If you want to take full advantage of your hardware and divide computationally intensive tasks across all your CPU cores, and have your code be fully portable, then you need to use Threads. Perhaps the only other option would be to use an MPI implementation, but that introduces significant complexity. Ignoring portability you could you use a fork(), perhaps using one of several modules that makes using fork more convenient. If you choose to ignore having any meaningful benefit to dividing your computationally intense code into different threads of execution than there are modules such as Coro which provide co-operative threads. Co-operative threads share the same CPU so using them for a significant computation would be for cosmetic code organizing purposes only. For non-computational tasks they may provide some benefit beyond the merely cosmetic. For example, when reading from several data sources you can avoid reading them completely in sequence and instead read a little from each until all reads complete. Note that this mediocre sort of threading is as good as you will ever get if you are a Python developer. Well, at least if you use the main CPython implementation of that language. Jython makes full use of the JVM's very nice multi-threading abilities. Most Python developers don't know or care about this limitation because they are mostly just calling wrappers to powerful libraries written in C++ such as TensorFlow. Those libraries of course make full use of C++'s multi-threading as well as GPU APIs.
Now, if you look at the Threads documentation you will find it's written in this extremely hand wringing tone all but begging you not to use them. This is ridiculous and the result of an absurd argument from people that are loud pedantic jerks mean well. The fact is that the Threads module is not implemented in the way an experienced programmer might expect and so it comes with a decent list of use cases which must be avoided. This is mostly because each thread is given its own Perl interpreter. Many all of these cases to avoid are fairly obscure such as "don't use END blocks in a thread". Yeah, sure. Thanks for the heads up.
Indeed I am not aware of any actual horror stories of the Threads module causing trouble in practice. Those that are aware of their limitations either work around them as necessary or write test cases in an effort to bemoan these limitations.
If you're breaking up a tough computation into smaller pieces to take advantage of multiple CPUs Threads provide a simple interface to unleash a lot of processing power. Just read the documentation first and you'll be fine.
The Code
Original code but now threaded
This is the same code as used in the initial problem but with Threads. Getting a rough idea of run time with time we see that it takes about 78 minutes. That is coming down from the original take ~257m. So a little over a 3x speedup.
$ time perl ch-1t.pl
6 28 496 8128 33550336
real 77m58.142s
user 268m17.491s
sys 0m21.845s
We already saw that a substantial speedup is obtained by re-writing the factoring and perfect checking in C++. What if we combined that code with Threads?
Native Library + Threads
$ time perl -Iext -Iext/blib/arch/auto/Perfect ch-1xt.pl
6 28 496 8128 33550336
real 5m40.543s
user 20m6.924s
sys 0m4.594s
Great! We are now able to find the first five perfect numbers with brute force in a little over 5½ minutes. That's a roughly 45x speedup from the original pure (single threaded) perl code.
Notes:
- The number of threads is set to be the number of cores available on my (Late 2012) iMac. A supercomputer it is not.
- The RANGE_SIZE is set to a number that I determined experimentally from a few runs to best reduce the number of wasted evaluations but still put the threads to best use. Remember, these are ithreads and so they don't come cheaply. A new interpreter is created for each one. Angry pedants would scold me for not having creating a thread pool and re-used threads. Also, we're going to end up evaluating numbers that we don't need to because a previously created thread will have found the last perfect number while other threads are still running. I'd argue this is a reasonable tradeoff and when looking for larger and larger perfect numbers not that bad, they do occur very sparsely after all. As a reminder: we're only using this perfect number search as a MacGuffin to try out some different methods. If we were really holding ourselves to the mathematics of perfect numbers we'd have computed them directly and have been done with it!
- It's possible that the perfect numbers would be printed out of numerical order as the threads complete. For the first five this is not really a problem since the first thread created should usually finish well before the last one given the distance between these numbers. Remember, ultimately these threads get executed at the pleasure of your OS and on a busy system unexpected things may happen!
- The time command gives us a decent rough idea of execution time but it is no substitute for closer benchmarking of code if we're really interested in identifying any particular bottleneck.
- This is what the core utilization looked before, during, and after a run of ch-1xt.pl. (Ignore the blank to the left which accounts for the time before measuring started) The third and fourth cores seem a but underutilized before being tasked with this computation. You paid for all those cores so use them! use Threads!
Summary
This is the final chapter in a story that started by taking a naive computational approach to identifying perfect numbers and improving it first by re-implementing parts in C++ and then by introducing Threads. Both lead to noteworthy improvement in performance, in fact, a very significant improvement when taken together.
posted at: 13:10 by: Adam Russell | path: /perl | permanent link to this entry
2019-05-16
Integrating C++ and Perl with SWIG
In another article I mentioned that it's possible to call code written in C++ from Perl. Perl offers two ways to do that:
- Perl's XS (eXternal Subroutines)
- SWIG
Here SWIG will be used. I like SWIG better than XS because it is somewhat more straightforward to integrate with C++ (XS is much more C-centric) and also because the steps necessary to wrap C++ code for use by Perl can be readily modified to work with other languages whereas XS will only let you integrate with Perl. In other words, if you have a significant C++ library that you would like to make available to a variety of programming languages SWIG is your best bet!
This came up when discussing the solution to one of the Perl Weekly Challenges in which the problem was to computer Perfect Numbers. The issue is that Perfect Numbers occur very sparsely and a brute force method to find them when written in even a fast interpreted language such as Perl will take a long time as it searches through many millions of numbers. The preferred solution to speeding up that computation is to use a little mathematical sophistication and use one of the several well known methods for computing Perfect Numbers directly. Algorithmic improvements lead to the greatest performance gains.
Often times, however, in practice a significant algorithmic improvement is not forthcoming or the time to spend researching it is disallowed by, say, project schedules. In these cases what we may want to do is write the computationally intensive parts of the code in a compiled language such as C++ and call it from our Perl code. This will allow the use of Perl to more rapidly develop the system as a whole while, as needed, certain parts are re-written in a way that improve overall performance.
The original code is shown in the previous article. That script, written only in Perl took nearly four and half hours to find the first five Perfect Numbers.
$ time perl perl5/ch-1.pl
6 28 496 8128 33550336
real 257m33.621s
user 255m52.169s
sys 0m24.603s
Let's see what speedup we get from re-implementing the most computationally intense parts of the code in C++.
Overview
First be sure to install swig! Otherwise it's assumed you already have a C++ compiler and Perl installation.
I am using OS X 10.14 "Mojave" with perlbrew installation of perl-5.28. I use macports and have installed gcc9.
The swig installation is done in two parts:
$ port install swig
$ port install swig-perl
Other systems, such as Linux, will have similarly named packages available.
I am using swig 3.0.12. swig 4.0 was released a few weeks prior to this writing but is not yet available on macports. That is fine, none of the latest features are necessary.
Also, I will save the extra issues related to creating a distributable module (e.g. suitable for uploading to CPAN) for a later article.
Required Project Files
- The C++ header (perfect.h)
- The C++ implementation (perfect.cxx)
- The SWIG interface file (perfect.i)
- The perl script (ch-1x.pl)
- A MakeMaker file (Makefile.PL) [somewhat optional but highly recommended]
- All the above files are linked to GitHub if you'd like to download the code.
- Other files will be generated by swig but these are the ones that we must create.
Building (the easier way)
- swig -c++ -perl perfect.i generates perfect.pm and perfect_wrap.cxx. perfect.pm is the Perl side of your new module. perfect_wrap.cxx is, as the name implies, the native wrapper side of your module. Both of these files are generated based on what you've put into your interface file (e.g. perfect.i). If you want to modify these files do so by changing your interface file!
- make Makefile.PL this will create a Makefile. This step is optional in the sense that you can definitely compile and link everything yourself but MakeMaker does some nice extra stuff, such as create all the necessary perl packaging files. It's amazing how convenient this is!
- make assuming you ran the command in the previous step this will compile and link the C++ code to a dynamic library as well as package it. At this point you might consider yourself done.
- make install this will install your new module in a location that Perl can easily find it for your use. This is definitely optional. While still developing your module you'll likely want to leave it in a local directory for testing.
Note that we didn't create any tests in this basic use case. That should be something you add in later and when you do be sure to run a make test before you install to make sure everything is OK.
Also, none of the above is concerned with distribution of your module. To do so requires a little more packaging which we will discuss later. For now we are focussing on building everything up to a usable state for a single developer.
Running
After going through all the above you will have a directory that looks something like this.
MakeMaker did us quite a favor in creating several additional files and directories. To run the script ch-1x.pl from within this directory you would execute as shown next. The -I arguments are necessary to tell perl where to find the perfect.pm (Perl module) and perfect.dylib (OS X dynamically linked library) files.
Sample Run
perl -I. -Iblib/arch/auto/Perfect ch-1x.pl
6 28 496 8128 33550336
That seemed to run quicker. But I wasn't watching closely. What does time tell us?
time perl -I. -Iblib/arch/auto/Perfect ch-1x.pl
6 28 496 8128 33550336
real 19m31.171s
user 19m24.311s
sys 0m2.196s
That's great! That is about 14x faster than the pure Perl version! Again, for this particular problem this is not the method for getting the absolute best performance but it definitely shows that some great performance gains can be achieved by re-writing computationally intensive parts of your system in C++ vs plain Perl.
Details
Let's take a deeper look at what we did, starting by examine the files required for this project.
Required Project Files
- The C++ header (perfect.h)
We are declaring a pretty basic class. A constructor, destructor, and single method isPerfect().
- The C++ implementation (perfect.cxx)
We don't do much with the constructor or destructor, the code is really all in the isPerfect() method which is a very close translation of the previous pure Perl program.
- The SWIG interface file (perfect.i)
The syntax of the interface files is a little unusual but this is small enough to not be too confusing. We declare that we are creating a module called Perfect. According to the swig docs The %{ %} block provides a location for inserting additional code, such as C header files or additional C declarations, into the generated C wrapper code. So that is why we need to include our header file perfect.h there, so it gets included in the generated perfect_wrap.cxx file. The seeming duplicate mentioning of perfect.h in the line %include "perfect.h" is not actually redundant. The %{%} block includes that header in the wrapper but what comes later is what is parsed by swig to actually generate the wrappers. In this smaller example they appear redundant but in larger more complex examples the different sections of the interface file become more distinct.
- The perl script (ch-1x.pl)
Here we actually get to put all our work to use! Notice how we use Perfect; and declare and use a Perfect object.
- A MakeMaker file (Makefile.PL) [somewhat optional but highly recommended]
The contents of this file are small, just state your module name and the object files output by the compilation step and you should be good to go.
This is "optional" because it is possible execute the commands to build and link everything yourself, either in a Makefile you write or just executing the right commands in sequence. By using MakeMaker you get all the extra packaging files such as the blob directory and meta files with no extra effort. You also get the ability to easily install the new module on your system. By using MakeMaker you are probably 80% of the way to having created a distributable module, suitable for inclusion on CPAN.
For the sake of completeness and a slightly fuller understanding here is what doing the build manually looks like ...
Building (the harder way)
$ swig -c++ -perl perfect.i
$ g++ -c perfect.cxx perfect_wrap.cxx `/Users/adamcrussell/perl5/perlbrew/perls/perl-5.28.0/bin/perl -MExtUtils::Embed -e ccopts`
$ g++ -dynamiclib -single_module -flat_namespace -undefined suppress -o perfect.dylib perfect.o perfect_wrap.o -L /Users/adamcrussell/perl5/perlbrew/perls/perl-5.28.0/lib/5.28.0/darwin-thread-multi-2level/CORE/ -lperl
Sample Run
$ perl -I. -MPerfect -e 'my $p=new Perfect::Perfect();print $p->isPerfect(6);'
1
Just what we hoped for, a true value returned. We can now confidently run ch-1x.pl as we did before.
We use the -I. to make sure that the interpreter sees perfect.pm and perfect.dylib in the current directory. If they occur in other locations than be sure to specify that with -I. In earlier examples you may have seen -Iblib/arch/auto/Perfect for this same reason.
Clearly this was done on a Mac OS X system and is very specific to my particular configuration with perlbrew. You'll need to adjust accordingly. In particular on Linux systems, not using perlbrew, for example your last line might look more like
g++ -shared perfect.o perfect_wrap.o -L /usr/lib/ -lperl -o perfect.so
Summary
This article has shown the construction of a Perl module with portions written in C++ and integrated with SWIG. The example module is small and straightforward but demonstrates the main capabilities of SWIG. More complexity comes into play when using advanced C++ features such as templates and nested namespaces, however SWIG is able to handle these well and the integration of more advanced C++ code and Perl may be the subject of a future article.
posted at: 19:36 by: Adam Russell | path: /perl | permanent link to this entry
2019-05-14
Perl Weekly Challenge 008
As with the previous weekly challenges the problem statements are short and are included in the first comment of the code. The code blocks shown link to GitHub Gists.
Part 1
This is straightforward enough of an implementation, without much code that requires a lot of explanation. For each candidate number we compute the factors and then add them up. If the sum of the factors is equal to the number itself it's perfect, print it and continue the search. I am re-using the pack/unpack trick to do the summing, like I have done before. So what could go wrong!?!?
Look at the sample run below though. I executed it use the time command. time is a quick way to see just how long a command takes to execute and here we see that to find the first five the above code takes nearly four and half hours!
Sample Run
$ time perl perl5/ch-1.pl
6 28 496 8128 33550336
real 257m33.621s
user 255m52.169s
sys 0m24.603s
The reason for this long run time is that Perfect Numbers become extremely sparse very quickly. The first four are typically found within seconds but the fifth takes the rest of the time because 33,542,208 numbers must be checked before it is found. Even a fast interpreted language like Perl running on modern hardware will take a long time to examine so many numbers. So how to make things faster? There are three ways:
- Algorithmic improvement
- Parallelization
- Write the computationally intensive parts in a compiled language such as C++.
The answer for this problem is definitely (1). Useful properties of Perfect Numbers are well documented. A good web page to reference would be http://mathworld.wolfram.com/PerfectNumber.html. There you would find that you can compute Perfect Numbers in several direct ways due to properties related to Triangular Numbers, Mersenne Primes, and Hexagonal Numbers. The compute time to find the first five would be at most a few seconds even when written in an interpreted language such as Perl when running on contemporary hardware.
Even though (1) is the best answer for this and most any performance problem you may ever encounter (2) and (3) are worth discussing because in many practical situations they offer the best solution (usually in terms of time and money!).
(3) is discussed in detail here. The results are that we can find a ~14x speedup, from 257m33.621s to 19m31.171s.
A combination of (2) and (3) is discussed here and results in a ~45x speedup, from 257m33.621s to 5m55.348s.
Part 2
Sample Run
Details
The logic used here is that we must first find the longest line. Once we determine the longest line find the midpoint of that line. The midpoint of the longest line will be where we want to center all the other lines. The padding needed is computed as the difference between the middle of the longest line and the middle of any other line. In the case of the longest line itself no special handling is needed, its padding length is zero. I use the same eval() and tr() method to find line lengths as I have done before.
posted at: 19:19 by: Adam Russell | path: /perl | permanent link to this entry
2019-05-09
Perl Weekly Challenge 007
As with the previous weekly challenges the problem statements are short and are included in the first comment of the code. The code blocks shown link to GitHub Gists.
Part 1
I think this is straightforward enough, with the exception of the use of pack and unpack.
Sample Run
$ perl ch-1.pl
1 2 3 4 5 6 7 8 9 10 12 18 20 21 24 27 30 36 40 42 45 48 50 54 60 63 70 72 80 81 84 90 100 102 108 110 111 112 114 117 120 126 132 133 135 140 144 150 152 153
pack/unpack
The line unpack("%32C*", pack("C*", @digits)) is a bit mysterious looking at first so let's unpack it (pun intended!) .
We are first, in the inner pack() call, creating a binary representation of the @digits array according to a template.
- The 'C' means to break the input into unsigned chars
- the '*' means repeat the 'C' for the rest of the input.
The template "C*", in other words, means "treat every item in this array as an unsigned char" and then pack them together. The result is a binary representation which, to be quite honest, means just about nothing unless you know, or are able to guess, the template.
So then we use unpack()'s checksum function to sum the digits, which is really all we are after here anyway.
- The '%' is just telling unpack to use the special checksum function
- The 'C' means to break the input into unsigned chars (because that is how they were packed to begin with)
- the '*' means repeat the 'C' for the rest of the input (because that is how they were packed to begin with)
- The 32 means to compute a 32-bit checksum
The two functions share the same template syntax which is documented on the pack manpage.
More on binary formats
If you are curious just what the raw binary created by pack() looks like you can use the xxd command with the -b option. For example, suppose I ran a command like the following:
perl -e '$i="
can you guess what A is based on this output from xxd?
$ xxd -b /tmp/pack
00000000: 00000010 00000000 00000001 00001001 ....
If you find this figuring out of the meaning behind binary strings interesting than perhaps you have a future as a reverse engineer! If not, than you are a normal well adjusted person. :D
Part 2
Sample Run
$ perl ch-2.pl
cold -> cord -> card -> ward -> warm
Overview
To compute a word ladder we can calculate the shortest path between the two words, as represented by vertices, on a graph. To create the graph sub build_graph() creates a vertex in the graph for each word and does a pairwise comparison between all words. If they differ only by one letter then an edge is drawn between the two vertices. Once the graph is created we perform a Dijkstra Single Source Shortest Path computation which will compute all shortest paths from a given source vertex to all other vertices. This may seem wasteful, we are only concerned with one such path after all, right? Interestingly, the worst case time complexity is the same whether we abort the algorithm after finding the path we want or keep going and compute them all. There is some wasted calculation of course but, asymptotically speaking, we don't need to be too anxious about it.
The code shown above gets a little dense in place although I think at a high level the approach is not too hard to comprehend.
- Create the graph. I use the Graph module from CPAN.
- Select a source word (vertex). Compute all shortest paths from this source.
- return the path we are interested in for our word ladder.
Details
As mentioned before some parts of the code get a bit dense. This is not out of some intent to be purposefully obfuscated! As always with Perl There Is More Than One Way to Do It and the way I chose fits a balance between readability and still not being overly verbose. I think.
In sub build_graph these lines
my $length_w0 = do{
$w0 =~ tr/[a-z]//;
};
compute the string length of $w0 by using the return value from tr which is the number of matches made. The same technique is used a few lines down with
my $differences = eval "\$w1 =~ tr/$w0//";
but here we need to wrap the tr in an eval because tr does not perform any variable interpolation since its transliteration table is built at compile time and not run time.
In sub dijkstra_sssp the lines
local *by_total_edges = sub {
return 1 if $total_edges{$a} eq OO;
return -1 if $total_edges{$b} eq OO;
return $total_edges{$a} <=> $total_edges{$b};
};
define a nested subroutine. The need for the use of local is to avoid creating a closure. The perlref manpage describes the situation: ... named subroutines do not nest properly and should only be declared in the main package scope. This is because named subroutines are created at compile time so their lexical variables get assigned to the parent lexicals from the first execution of the parent block. If a parent scope is entered a second time, its lexicals are created again, while the nested subs still reference the old ones.
Anonymous subroutines get to capture each time you execute the sub operator, as they are created on the fly. If you are accustomed to using nested subroutines in other programming languages with their own private variables, you'll have to work at it a bit in Perl. The intuitive coding of this type of thing incurs mysterious warnings about "will not stay shared" due to the reasons explained above.
So by using local what we are doing is creating a temporary (i.e. re-created for each call to the enclosing subroutine) assignment of the anonymous subroutine. This has normal access to the lexical variables from the enclosing scope at the time it is is invoked.
This has the interesting effect of creating a function local to another function, something not normally supported in Perl. I'll freely admit this is definitely not idiomatic Perl. I'd argue that stylistically, in any language, this should be the preferred way of organizing this code. The small function used for sorting vertices has no use outside of sub dijkstra_sssp. Indeed I could imagine many programmers just inlining the code in the call to sort! This use of local is essentially the same thing, but cleaner looking than inlining. The only complication is that perl will complain with
Name "main::by_total_edges" used only once: possible typo at perl5/ch-2.pl line 41.
unless we add the line no warnings "once"; I am still investigating this. At face value the warning makes no sense: by_total_edges is called from within a loop. Is this a slight defect in the interpreter to not recognize this? I'll write up what I learn about this another time.
Notes
- If you thought the use of the Unicode character '∞' was unnecessary you are correct! I was hoping that it would be an acceptable identifier and that line could have read use constant ∞ => "INF"; or something like that where I could then have used ∞ in the code almost like a numeric literal. Sadly this is not an acceptable identifier. (Although I think it should be!)
- The Graph module has an interesting history, it was originally written as part of the code samples for the book Mastering Algorithms with Perl. That book has served as an excellent reference for many years.
posted at: 20:05 by: Adam Russell | path: /perl | permanent link to this entry
2019-05-05
Perl Weekly Challenge 006
This week I was not feeling well and allowed myself some shortcuts. Rather than take the time to implement necessary routines myself in some interesting (to me) way I instead opted to make use of a couple of modules and be done with it. All the sooner to get back to feeling sick and tired.
As with the previous weekly challenges the problem statements are short and are included in the first comment of the code. The code blocks shown link to GitHub Gists.
Part 1
Data::Dump is one of my favorite debugging tools. The pp() function "pretty prints" the contents of a data structure and, in doing so, performs the sort of compaction required in the first part of this week's challenge. All that is necessary is to call pp() and then do a bit of polishing on the final output by removing unnecessary parentheses and white space.
Sample Run
$ perl ch-1.pl 1,2,3,4,9,10,14,15,16
1-4,9,10,14,15,16
Ok, maybe it's somewhat off the requirements since pp() wants to compact 4 or more continuous numbers and not 3 or more. Did I mention I was feeling sick? Close enough!
Part 2
I had dreams of writing my own arbitrary precision code for this. Fever dreams that is! Math::BigFloat helped make quick work of this.
Sample Run
$ perl ch-2.pl
262537412640768743.9999999999992500725947
posted at: 20:56 by: Adam Russell | path: /perl | permanent link to this entry
2019-04-26
Perl Weekly Challenge 005
Anagrams!
This weeks challenge involves anagrams.
The problem statements are short and are included in the first comment of the code. The code blocks shown link to GitHub Gists.
The Approach
For both parts I used the same general approach.
By the Fundamental Theorem of Arithmetic every integer greater than 1 is either a prime number itself or can be represented as the unique product of prime numbers.
Using this information the idea used in both Part 1 and Part 2 is to have each letter mapped to a prime number and each word represented by the product of each its letter's corresponding numbers. For example let's consider the word "live":
live = l * i * v * e = 31 * 11 * 73 * 2 = 49786.
Any word also spelled with an 'l' an 'i' a 'v' and an 'e' will have the same product of 49786 even if the letters are arranged differently. In this way we have a straightforward path to determining anagrams.
Assumptions:
- Only single word anagrams are considered
- Words shall contain only the 26 letters of the English alphabet
- Only lower case letters are used.
- The values assigned to each letter are inverse to their overall frequency.
- No bad actors: all inputs are safe and clean and need not be checked.
That last point is a minor detail. I thought that to minimize the overall size of the numbers generated I would assign smaller numbers to the most frequently used letters. Letter frequency uses the Lewand ordering described in the wikipedia article. It seems that this was unnecessary for the test corpus used (the standard Unix dictionary file) but I decided to leave it in the final code anyway as it was an interesting design point nonetheless.
Part 1
The code for Part 1 takes a test word from the command line and computes it's product. The product for every word in the standard Unix dictionary file is also computed and stored in a hash. That hash is then searched for matches against the test word and the results printed. The line
delete($word_product{$test_word});
is just a simple way to make sure that the test word itself is omitted from the printed results. Interestingly there are exactly two words in the dictionary file which contain a hyphen! Those two entries are "Jean-Christophe" and "Jean-Pierre". Because of these I make sure to remove hyphens.
Sample Run
$ perl ch-1.pl live
live: vlei levi vile veil evil
Part 2
Again using the same approach Part 2 words are read in from stdin and the word/product hash created. The values in the hash (the products) are counted and the sequence of letters corresponding to the product with the highest number of entries is printed.
Sample Run
$ perl ch-2.pl < /usr/share/dict/words
e a s l p
Note: In the case there is a tie the first one in the sorted list is taken. Co-incidentally in the dictionary file there is a tie! In addition to the one shown above is a o n r g which also has ten anagrams.
$ perl ch-1.pl easlp
easlp: salep speal pales spale saple slape lapse elaps sepal lepas
$ perl ch-1.pl aonrg
aonrg: ronga orang angor grano goran argon nagor groan rogan organ
posted at: 19:37 by: Adam Russell | path: /perl | permanent link to this entry
2019-04-16
Perl Weekly Challenge 004
Another week, another chance to get creative with some Perl!
Part 1
This code is done to solve the stated problem as generally as possible! That means that instead of golf-ing the code down to such a small size that I could have just used sprintf("%1.Xf", ...) where X is the size of the, presumably, one-liner I instead put the code in a file and use stat() to get the size of that file. The digits of π are then computed as needed using a so-called spigot algorithm. This name comes form the fact that the algorithm delivers an endless supply of digits, like water flowing from a spigot.
This computation of the digits of π uses continued fractions. The method, the mathematics behind the algorithm, and some Ruby code implementing the method (which I drew heavily from!) can be found here.
For the record the one-liner solution would look like this:
perl -e 'print(sprintf("%1.37f",4*atan2(1,1)))'
Part 2
This code is inspired greatly by the solution to Challenge 003's first part. This time instead of creating a few individual closures I create an array of them, one for each of the given letters. These are then used in a recursive loop to remove letters from each word being examined. If we use up all the closures (letters) and the word still i snot empty then the word does not pass. If the word is reduced to the empty string (whether we have closures left or not) indicates the word passes.
Note: I did not follow the exact wording of the challenge in that the letters and words are not coming from separate files. Changing the code to get the words and letters from a file would not change the logic of the main parts of the code at all, however.
"posted at: 17:03 by: Adam Russell | path: /perl | permanent link to this entry
2019-04-14
Perl Weekly Challenge 003
Both parts of this week's challenge seemed to have the same theme of performing a calculation that inspires recursion. I wrote a bit about recursion in Perl last week so there isn't too much new to add on that subject in describing the code.
The problem statements are short and are included in the first comment of the code. The code blocks shown link to GitHub Gists.
Part 1
This a pretty straightforward solution to the stated problem. To jazz things up a little I used currying to generate the three is_divisible_by_X functions. This is neat to see in practice, but is never required. In fact, I've never seen currying used seriously in Perl. Just these sorts of toy problems and examples. If anyone is interested in why someone would want to do this I refer you to a nice Perlmonks post on why currying may have some practical usage in other programming environments.
I generally avoid using any CPAN modules for these problem sets but I made a small exception in the code for Part 1 and use boolean; this module simply allows the use of true and false as boolean values. Completely unnecessary, of course, but I have always preferred the aesthetics of boolean keywords.
Part 2
The computation for Pascal's Triangle (binomial co-efficients) is, similar to the Hamming Numbers of Part 1, straightforward. This week perhaps my creativite energy was a bit low. The solution for Part 2 is about as vanilla as you can get!
posted at: 11:09 by: Adam Russell | path: /perl | permanent link to this entry