RabbitFarm

2022-06-19

Brilliantly Discover Achilles' Imperfection

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

Part 1

Write a script to generate the first 20 Brilliant Numbers.

Solution


use strict;
use warnings;
sub prime_factor{
    my $x = shift(@_); 
    my @factors;    
    for(my $y = 2; $y <= $x; $y++){
        next if $x % $y;
        $x /= $y;
        push @factors, $y;
        redo;
    }
    return @factors;  
}

sub is_brilliant{
    my($n) = @_;
    my @factors = prime_factor($n); 
    return @factors == 2 && length($factors[0]) == length($factors[1]);
}

sub n_brilliants{
    my($n) = @_;
    my @brilliants;
    my $i = 0;
    {
       push @brilliants, $i if is_brilliant($i);
       $i++;
       redo if @brilliants < $n;
    }
    return @brilliants;
}

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

Sample Run


$ perl perl/ch-1.pl
4, 6, 9, 10, 14, 15, 21, 25, 35, 49, 121, 143, 169, 187, 209, 221, 247, 253, 289, 299

Notes

The solution here incorporated a lot of elements from previous weekly challenges. That is to say it is quite familiar, I continue to be a fan of redo!

Part 2

Write a script to generate the first 20 Achilles Numbers.

Solution


use strict;
use warnings;
use POSIX;
use boolean;

sub prime_factor{
    my $x = shift(@_); 
    my @factors;    
    for (my $y = 2; $y <= $x; $y++){
        next if $x % $y;
        $x /= $y;
        push @factors, $y;
        redo;
    }
    return @factors;  
}

sub is_achilles{
    my($n) = @_;
    my @factors = prime_factor($n); 
    for my $factor (@factors){
        return false if $n % ($factor * $factor) != 0;
    }
    for(my $i = 2; $i <= sqrt($n); $i++) {
        my $d = log($n) / log($i) . "";
        return false if ceil($d) == floor($d);  
    }
    return true;
}

sub n_achilles{
    my($n) = @_;
    my @achilles;
    my $i = 1;
    {
       $i++;
       push @achilles, $i if is_achilles($i);
       redo if @achilles < $n;
    }
    return @achilles;
}

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

Sample Run


$ perl perl/ch-2.pl
72, 108, 200, 288, 392, 432, 500, 648, 675, 800, 864, 968, 972, 1125, 1152, 1323, 1352, 1372, 1568, 1800

Notes

This problem revealed something interesting with how, apparently, certain functions will handle integer and floating point values. The issue arises when we are computing logarithms. We can see the issue in isolation in a one liner.

perl -MPOSIX -e '$d = log(9) / log(3); print ceil($d) . "\t" . floor($d) . "\t$d\n"'

which prints 3 2 2. Notice that log(9) / log(3) is exactly 2 but, ok, floating point issues maybe it is 2.0000000001 and ceil will give 3. But why does this work?

perl -MPOSIX -e '$d = sqrt(9); print ceil($d) . "\t" . floor($d) . "\t$d\n"'

which gives 3 3 3. I am not sure what sqrt is doing differently? I guess how it stores the result internally? By the way, I am doing this to check is the result is an integer. That is if ceil($x) == floor($x), but that isn't working here as expected but I have used that trick in the past. I guess only with sqrt in the past though so never encountered this.

The trick to work around this, in the solution to the challenge is like this:

perl -MPOSIX -e '$d = log(9) / log(3) . ""; print ceil($d) . "\t" . floor($d) . "\t$d\n"'

this does what I want and gives 2 2 2. I guess that drops the infinitesimally small decimal part when concatenating and converting to a string which stays gone when used numerically?

Of course, there are other ways to do this. For example abs($x - int(x)) < 1e-7 will ensure that, within a minuscule rounding error, $x is an integer.

References

Challenge 169

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

2022-06-12

Take the Long Way Home

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

Part 1

Calculate the first 13 Perrin Primes.

Solution


use strict;
use warnings;
use boolean;
use Math::Primality qw/is_prime/;

sub n_perrin_prime_r{
    my($n, $perrins, $perrin_primes) = @_;
    return $perrin_primes if keys %{$perrin_primes} == $n;
    my $perrin = $perrins->[@{$perrins} - 3] + $perrins->[@{$perrins} - 2];
    push @{$perrins}, $perrin;
    $perrin_primes->{$perrin} = -1 if is_prime($perrin);
    n_perrin_prime_r($n, $perrins, $perrin_primes);
}

sub perrin_primes{
    return n_perrin_prime_r(13, [3, 0, 2], {});
}

MAIN:{
    print join(", ", sort {$a <=> $b} keys %{perrin_primes()}) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
2, 3, 5, 7, 17, 29, 277, 367, 853, 14197, 43721, 1442968193, 792606555396977

Notes

The solution here incorporated a lot of elements from previous weekly challenges. That is to say it is quite familiar, we recursively generate the sequence which is stored as hash keys and, once completed, sort and print the results. The hash keys are a convenient, although perhaps slightly bulky, way of handling the repeated 5 term at the beginning. The terms strictly increase thereafter.

Part 2

You are given an integer greater than 1. Write a script to find the home prime of the given number.

Solution


use strict;
use warnings;
use bigint;
use Math::Primality qw/is_prime/;

sub prime_factor{
    my $x = shift(@_); 
    my @factors;    
    for (my $y = 2; $y <= $x; $y++){
        next if $x % $y;
        $x /= $y;
        push @factors, $y;
        redo;
    }
    return @factors;  
}

sub home_prime{
    my($n) = @_;
    return $n if is_prime($n);
    my $s = $n;
    {
        $s = join("", prime_factor($s));
        redo if !is_prime($s);
    }
    return $s;
}

MAIN:{
    print home_prime(10) . "\n";
    print home_prime(16) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
773
31636373

Notes

So you think eight is low

Calculating HP(8) should be an easy go

Take the long way home

Take the long way home

The second part of this week's challenge was a lot of fun as it presented some unexpected behavior. Here we are asked to compute the Home Prime of any given number. The process for doing so is, given N to take the prime factors for N and concatenate them together. If the result is prime then we are done, that is the Home Prime of N, typically written HP(N). This is an easy process to repeat, and in many cases the computation is a very quick one. However, in some cases, the size of the interim numbers on the path to HP(N) grow extremely large and the computation bogs down, whence take the long way home! As an example, the computation of HP(8) is still running after 24 hours on my M1 Mac Mini.

References

Challenge 168

Home Prime

Take the Long Way Home

posted at: 23:34 by: Adam Russell | path: /perl | permanent link to this entry

2022-06-05

Circular Primes and Getting Complex

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

Part 1

Write a script to find out first 10 circular primes having at least 3 digits (base 10).

Solution


use strict;
use warnings;
use boolean;
use Math::Primality qw/is_prime/;

sub is_circular_prime{
    my($x, $circular) = @_;
    my @digits = split(//, $x);
    my @rotations;
    for my $i (0 .. @digits - 1){
        @digits = (@digits[1 .. @digits - 1], $digits[0]);
        my $candidate = join("", @digits) + 0;
        push @rotations, $candidate;
        return false if !is_prime($candidate);
    }
    map{$circular->{$_} = -1} @rotations;
    return true;
}

sub first_n_circular_primes{
    my($n) = @_;
    my $i = 100;
    my %circular;
    my @circular_primes;
    {
        if(!$circular{$i} && is_circular_prime($i, \%circular)){
            push @circular_primes, $i; 
        }
        $i++;
        redo if @circular_primes < $n;
    }
    return @circular_primes;
}

sub first_10_circular_primes{
    return first_n_circular_primes(10);
}

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

Sample Run


$ perl perl/ch-1.pl
113, 197, 199, 337, 1193, 3779, 11939, 19937, 193939, 199933

Notes

There is a bit of a trick here where we need to disallow repeated use of previous cycles. For example, 199 and 919 and considered to be the same circular prime (we count the first occurrence only) since 919 is a rotation of 199.

I don't ordinarily use a lot of references, especially hash references, in my Perl code but here it seems appropriate. It makes sense to break the rotating and primality checking to it's own function but we also need to track all the unique rotations. Wishing to avoid a global variable, which in this case wouldn't be all that bad anyway, having a single hash owned by the caller and updated by the primality checking function makes the most sense to me. The code is arguably cleaner then if we had multiple return values, to include the rotations. Another option, which would have avoided the use of a reference and multiple return values would have been to have is_circular_prime return either undef or an array containing the rotations. This would have added a little extra bookkeeping code to first_n_circular_primes in order to maintain the master list of all seen rotations so I considered it, simply as a matter of style, to be just a little less elegant than the use of the reference.

Part 2

Implement a subroutine gamma() using the Lanczos approximation method.

Solution


use strict;
use warnings;
use POSIX;
use Math::Complex;

use constant EPSILON => 1e-07;

sub lanczos{
    my($z) = @_;
    my @p = (676.5203681218851, -1259.1392167224028, 771.32342877765313, -176.61502916214059, 12.507343278686905, -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7);
    my $y;
    $z = new Math::Complex($z);
    if(Re($z) < 0.5){
        $y = M_PI / (sin(M_PI * $z) * lanczos(1 - $z));
    }
    else{
        $z -= 1;
        my $x = 0.99999999999980993;
        for my $i (0 .. @p - 1){
            $x += ($p[$i] / ($z + $i + 1));
        }
        my $t = $z + @p - 0.5;
        $y = sqrt(2 * M_PI) * $t ** ($z + 0.5) * exp(-1 * $t) * $x;
    }
    return Re($y) if abs(Im($y)) <= EPSILON;
    return $y;
}

sub gamma{
    return lanczos(@_);
}

MAIN:{
    printf("%.2f\n",gamma(3));
    printf("%.2f\n",gamma(5));
    printf("%.2f\n",gamma(7));
}

Sample Run


$ perl perl/ch-2.pl
2.00
24.00
720.00

Notes

The code here is based on a Python sample code that accompanies the Wikipedia article and there really isn't much room for additional stylistic flourishes. Well, maybe that for loop could have been a map. For this sort of numeric algorithm there really isn't much variation in what is otherwise a fairly raw computation.

The interesting thing here is that it is by all appearances a faithful representation of the Lanczos Approximation and yet the answers seem to siffer from a slight floating point accuracy issue. That is the expected answers vary from what is computed here by a small decimal part, apparently anyway. Perl is generally quite good at these sorts of things so getting to the bottom of this may require a bit more investigation! I wonder if it has to do with how Math::Complex handles the real part of the number?

References

Challenge 167

Lanczos Approximation

posted at: 10:46 by: Adam Russell | path: /perl | permanent link to this entry

2022-05-22

SVG Plots of Points and Lines

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

Part 1

Plot lines and points in SVG format.

Solution


use strict;
use warnings;
sub svg_begin{
    return <<BEGIN;
        <?xml version="1.0" encoding="UTF-8" standalone="yes"?>                                   <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">                                                                          <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
BEGIN
}

sub svg_end{
    return "";
}

sub svg_point{
    my($x, $y) = @_;
    return "<circle cx=\"$x\" cy=\"$y\" r=\"1\" />";
}

sub svg_line{
    my($x0, $y0, $x1, $y1) = @_;
    return "<line x1=\"$x0\" x2=\"$x1\" y1=\"$y0\" y2=\"$y1\" style=\"stroke:#006600;\" />";          
}

sub svg{
    my @lines = @_;
    my $svg = svg_begin;
    for my $line (@_){
        $svg .= svg_point(@{$line}) if @{$line} == 2;
        $svg .= svg_line(@{$line})  if @{$line} == 4;
    }
    return $svg . svg_end;
}


MAIN:{
    my @lines;
    while(){
        chomp;
        push @lines, [split(/,/, $_)];
    }
    print svg(@lines);
}


__DATA__
53,10
53,10,23,30
23,30

Sample Run


$ perl perl/ch-1.pl
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>                                   <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">                                                                          <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<circle cx="53" cy="10" r="1" /><line x1="53" x2="23" y1="10" y2="30" /><circle cx="23" cy="30" r="1" /></svg>

Notes

Doing the SVG formatting from scratch is not so bad, especially when sticking only to points and lines. The boiler plate XML is taken from a known good SVG example and used as a template.

Part 2

Compute a linear regression and output an SVG plot of the points and regression line.

Solution


use strict;
use warnings;
sub svg_begin{
    return <<BEGIN;
        <?xml version="1.0" encoding="UTF-8" standalone="yes"?>                                   <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">                                                                          <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
BEGIN
}

sub svg_end{
    return "";
}

sub svg_point{
    my($x, $y) = @_;
    return "<circle cx=\"$x\" cy=\"$y\" r=\"1\" />";
}

sub svg_line{
    my($x0, $y0, $x1, $y1) = @_;
    return "<line x1=\"$x0\" x2=\"$x1\" y1=\"$y0\" y2=\"$y1\" style=\"stroke:#006600;\" />";          
}

sub svg{
    my @lines = @_;
    my $svg = svg_begin;
    for my $line (@_){
        $svg .= svg_point(@{$line}) if @{$line} == 2;
        $svg .= svg_line(@{$line})  if @{$line} == 4;
    }
    return $svg . svg_end;
}

sub linear_regression{
    my(@points) = @_;
    # 1. Calculate average of your X variable.
    my $sum = 0;
    my $x_avg;
    map{$sum += $_->[0]} @points;
    $x_avg = $sum / @points;
    # 2. Calculate the difference between each X and the average X.
    my @x_differences = map{$_->[0] - $x_avg} @points;
    # 3. Square the differences and add it all up. This is Sx.
    my $sx = 0;
    my @squares = map{$_ * $_} @x_differences;
    map{$sx += $_} @squares;
    # 4. Calculate average of your Y variable.
    $sum = 0;
    my $y_avg;
    map{$sum += $_->[1]} @points;
    $y_avg = $sum / @points;
    my @y_differences = map{$_->[1] - $y_avg} @points;
    # 5. Multiply the differences (of X and Y from their respective averages) and add them all together.  This is Sxy.
    my $sxy = 0;
    @squares = map {$y_differences[$_] * $x_differences[$_]} 0 .. @points - 1;
    map {$sxy += $_} @squares;
    # 6. Using Sx and Sxy, you calculate the intercept by subtracting Sx / Sxy * AVG(X) from AVG(Y).
    my $m = $sxy / $sx;
    my $y_intercept = $y_avg - ($sxy / $sx * $x_avg);
    my @sorted = sort {$a->[0] <=> $b->[0]} @points;
    my $max_x = $sorted[@points - 1]->[0];
    return [0, $y_intercept, $max_x + 10, $m * ($max_x + 10) + $y_intercept];
}

MAIN:{
    my @points;
    while(){
        chomp;
        push @points, [split(/,/, $_)];
    }
    push @points, linear_regression(@points);
    print svg(@points);    
}


__DATA__
333,129
39,189
140,156
292,134
393,52
160,166
362,122
13,193
341,104
320,113
109,177
203,152
343,100
225,110
23,186
282,102
284,98
205,133
297,114
292,126
339,112
327,79
253,136
61,169
128,176
346,72
316,103
124,162
65,181
159,137
212,116
337,86
215,136
153,137
390,104
100,180
76,188
77,181
69,195
92,186
275,96
250,147
34,174
213,134
186,129
189,154
361,82
363,89

Sample Run


$ perl perl/ch-2.pl
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
           <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">
           <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<circle cx="333" cy="129" r="1" /><circle cx="39" cy="189" r="1" /><circle cx="140" cy="156" r="1" /><circle cx="292" cy="134" r="1" /><circle cx="393" cy="52" r="1" /><circle cx="160" cy="166" r="1" /><circle cx="362" cy="122" r="1" /><circle cx="13" cy="193" r="1" /><circle cx="341" cy="104" r="1" /><circle cx="320" cy="113" r="1" /><circle cx="109" cy="177" r="1" /><circle cx="203" cy="152" r="1" /><circle cx="343" cy="100" r="1" /><circle cx="225" cy="110" r="1" /><circle cx="23" cy="186" r="1" /><circle cx="282" cy="102" r="1" /><circle cx="284" cy="98" r="1" /><circle cx="205" cy="133" r="1" /><circle cx="297" cy="114" r="1" /><circle cx="292" cy="126" r="1" /><circle cx="339" cy="112" r="1" /><circle cx="327" cy="79" r="1" /><circle cx="253" cy="136" r="1" /><circle cx="61" cy="169" r="1" /><circle cx="128" cy="176" r="1" /><circle cx="346" cy="72" r="1" /><circle cx="316" cy="103" r="1" /><circle cx="124" cy="162" r="1" /><circle cx="65" cy="181" r="1" /><circle cx="159" cy="137" r="1" /><circle cx="212" cy="116" r="1" /><circle cx="337" cy="86" r="1" /><circle cx="215" cy="136" r="1" /><circle cx="153" cy="137" r="1" /><circle cx="390" cy="104" r="1" /><circle cx="100" cy="180" r="1" /><circle cx="76" cy="188" r="1" /><circle cx="77" cy="181" r="1" /><circle cx="69" cy="195" r="1" /><circle cx="92" cy="186" r="1" /><circle cx="275" cy="96" r="1" /><circle cx="250" cy="147" r="1" /><circle cx="34" cy="174" r="1" /><circle cx="213" cy="134" r="1" /><circle cx="186" cy="129" r="1" /><circle cx="189" cy="154" r="1" /><circle cx="361" cy="82" r="1" /><circle cx="363" cy="89" r="1" /><line x1="0" x2="403" y1="200.132272535582" y2="79.2498029303056" /></svg>

Notes

I re-use the SVG code from Part 1 and add in the linear regression calculation. Continuing a small habit from the past few weeks of these challenges I am making much use of map to keep the code as small, and yet still readable, as possible. The linear regression calculation is fairly straightforward, as much as I hate having a terse writeup on this I am not sure I have much more to say!

References

Challenge 165

Linear Regression Calculation

posted at: 23:16 by: Adam Russell | path: /perl | permanent link to this entry

2022-05-15

Happily Computing Prime Palindrome Numbers

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

Part 1

Write a script to find all prime numbers less than 1000, which are also palindromes in base 10.

Solution


use strict;
use warnings;
use Math::Primality qw/is_prime/;

sub palindrome_primes_under{
    my($n) = shift;
    my @palindrome_primes;
    {
        $n--;
        unshift @palindrome_primes, $n if(is_prime($n) && join("", reverse(split(//, $n))) == $n);
        redo if $n > 1;  
    }
    return @palindrome_primes;
}

MAIN:{
    print join(", ", palindrome_primes_under(1000));
}

Sample Run


$ perl perl/ch-1.pl
2, 3, 5, 7, 11, 101, 131, 151, 181, 191, 313, 353, 373, 383, 727, 757, 787, 797, 919, 929

Notes

I have become incorrigible in my use of redo! The novelty just hasn't worn off I suppose. There is nothing really wrong with it, of course, it's just not particularly modern convention what with it's vaguely goto like behavior. Anyway, there's not a whole lot to cover here. All the real work is done in the one line which tests both primality and, uh, palindromedary.

Part 2

Write a script to find the first 8 Happy Numbers in base 10.

Solution


use strict;
use warnings;
use boolean;
use constant N => 8;

sub happy{
    my $n = shift;
    my @seen;
    my $pdi = sub{
        my $n = shift;
        my $total = 0;
        {
            $total += ($n % 10)**2;
            $n = int($n / 10);
            redo if $n > 0;
        }
        return $total;
    };
    {
        push @seen, $n;
        $n = $pdi->($n);
        redo if $n > 1 && (grep {$_ == $n} @seen) == 0; 
    }
    return boolean($n == 1);
}

MAIN:{
    my $i = 0;
    my @happy;
    {
        $i++;
        push @happy, $i if happy($i);
        redo if @happy < N;
    }
    print join(", ", @happy) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
1, 7, 10, 13, 19, 23, 28, 31

Notes

This solution has even more redo, huzzah! Again, fairly straightforward bit of code which follows the definitions. The happiness check is done using a perfect digit invariant (PDI) function, here rendered as an anonymous inner subroutine. A good chance here when looking at this code to remind ourselves that $n inside that anonymous subroutine is in a different scope and does not effect the outer $n!

References

Challenge 164

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

2022-05-08

Bitwise AndSums and Skip Summations: Somewhat Complicated Uses of Map

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given a list of numbers. Write a script to calculate the sum of the bitwise & operator for all unique pairs.

Solution


use strict;
use warnings; 

sub sum_bitwise{
    my $sum = 0;
    for my $i (0 .. @_ - 2){
        my $x = $_[$i];
	map {$sum += ($x & $_)} @_[$i + 1 .. @_ - 1];
    }
    return $sum; 
}

MAIN:{
    print sum_bitwise(1, 2, 3) . "\n";  
    print sum_bitwise(2, 3, 4) . "\n";
}  

Sample Run


$ perl perl/ch-1.pl
3
2

Notes

Since most of the code for both parts of the challenge was fairly straightforward I thought it was worthwhile to concentrate on how I use map. In both cases are somewhat non-trivial. Here map is used in lieu of a nested loop. Effectively it is equivalent but the resulting code is more compact. The for loop iterates over the array of numbers. At each iteration the current number is saved as $x. We then need to work pairwise through the rest of the array. To do this we use map over the slice of the array representing the elements after $x. Within the for loop/map $sum is continuously updated with the bitwise & results as required.

Part 2

Given a list of numbers @n, generate the skip summations.


use strict;
use  warnings;

sub skip_summations{
    my @lines = ([@_]);
    for my $i (1 .. @_ - 1){
        my @skip = @{$lines[$i - 1]}[1 .. @{$lines[$i - 1]} - 1];
        my $line = [map {my $j = $_; $skip[$j] + unpack("%32I*", pack("I*", @skip[0 .. $j - 1]))} 0 .. @skip - 1];
        push @lines, $line;
    }
    return @lines;
}

MAIN:{
    for my $line (skip_summations(1, 2, 3, 4, 5)){
        print join(" ", @{$line}) . "\n";
    }
    print "\n";
    for my $line (skip_summations(1, 3, 5, 7, 9)){
        print join(" ", @{$line}) . "\n";
    }
}

Sample Run


$ perl perl/ch-2.pl
1 2 3 4 5
2 5 9 14
5 14 28
14 42
42

1 3 5 7 9
3 8 15 24
8 23 47
23 70
70

Notes

Again map is used in place of a nested loop. With the use of pack/unpack we further replace work that would take place inside yet another loop. While much more concise it is reasonable to concede a slight loss of readability, for the untrained eye anyway. The map in the code above works over a list of numbers representing array indices of the previously computed line of summations. For each element we get the slice of the array representing the ones before it and then use pack/unpack to get the sum which is then added to the current element. Each use of map here generates the next line and so we enclose the map in square brackets [] to place bthe results in an array reference which is the pushed onto the array of alllines to be returned.

References

Challenge 163

posted at: 13:52 by: Adam Russell | path: /perl | permanent link to this entry

2022-05-01

The Weekly Challenge 162

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to generate the check digit of a given ISBN-13 code.

Solution


use strict;
use warnings;

sub isbn_check_digit{
    my($isbn) = @_;
    my $i = 0;
    my @weights = (1, 3);
    my $check_sum = 0;
    my $check_digit;
    map {$check_sum += $_ * $weights[$i]; $i = $i == 0 ? 1 : 0} split(//, $isbn);
    $check_digit = $check_sum % 10;
    return 10 - $check_digit;
}

MAIN:{
    print isbn_check_digit(978030640615) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
7   

References

Challenge 162

posted at: 14:34 by: Adam Russell | path: /perl | permanent link to this entry

2022-04-24

Are Abecedarians from Abecedaria?

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Output or return a list of all abecedarian words in the dictionary, sorted in decreasing order of length.

Solution


use strict;
use warnings;

sub abecedarian{
    sort {$b->[1] <=> $a->[1]} map {[$_, length($_)]} grep{chomp; $_ eq join("", sort {$a cmp $b} split(//, $_))} @_;
}

MAIN:{
    open(DICTIONARY, "dictionary");
    for my $abc (abecedarian(<DICTIONARY>)){
        print $abc->[0] . " length: " . $abc->[1] . "\n";
    }
    close(DICTIONARY);
}

Sample Run


$ perl perl/ch-1.pl
abhors length: 6
accent length: 6
accept length: 6
access length: 6
accost length: 6
almost length: 6
begins length: 6
    .
    .
    .
ox length: 2
qt length: 2
xx length: 2
a length: 1
m length: 1
x length: 1    

Notes

The Power of Perl! This problem reduces to one (one!) line of code, plus a few more to manage reading the data and printing the results.

Reading from left to right what is happening? Well, we are sorting, in descending order, an array of array references based on the value of the element at index 1. Where does this array of array refs come from? From a map which takes in an array of strings and stores each string in an array ref with it's length. Where Does the array fo strings come from? From the grep which takes the list of strings sent to sub abecedarian as arguments, splits them into characters, sorts the characters, and then sees if the characters in sorted order are in the same order as the original word demonstrating that the word fits the definition of Abecedarian.

Ordinarily I will make an effort to avoid these more complicated expressions but in this case the reading of it seems to proceed in a straightforward way as a chain of easily understood sub-expressions.

Part 2

Using the provided dictionary generate at least one pangram.

Solution


use strict;
use warnings;

use Lingua::EN::Tagger;

sub pangram{
    my %tagged_words;
    my $tagger = new Lingua::EN::Tagger;
    for my $word (@_){
        chomp($word);
        my $tagged_text = $tagger->add_tags($word);
        $tagged_text =~ m/<([a-z]*)>([a-z]*<)/;
        my $tag = $1;
        if($tagged_words{$tag}){
            push @{$tagged_words{$tag}}, $word;
        }
        else{
            $tagged_words{$tag} = [$word];
        }
    }
    ##
    # generate sentences from random words in a (somewhat) grammatical way
    ##
    my $sentence;
    my @dets = @{$tagged_words{det}};
    my @adjs = @{$tagged_words{jj}};
    my @nouns = @{$tagged_words{nn}};
    my @verbs = @{$tagged_words{vb}};
    my @cons = @{$tagged_words{cc}};
    my @adverbs = @{$tagged_words{vb}};
    do{
        my $det0 = $dets[rand @dets];
        my $adj0 = $adjs[rand @adjs];
        my $noun = $nouns[rand @nouns];
        my $verb = $verbs[rand @verbs];
        my $det1 = $dets[rand @dets];
        my $adj1 = $adjs[rand @adjs];
        my $object0 = $nouns[rand @nouns];
        my $conj = $cons[rand @cons];
        my $det2 = $dets[rand @dets];
        my $adj2 = $adjs[rand @adjs];
        my $object1 = $nouns[rand @nouns];
        my $adverb = $adverbs[rand @adverbs];
        my %h;
        for my $c (split(//, "$det0$adj0$noun$verb$det1$adj1$object0$conj$det2$adj2$object1")){
            $h{$c} = undef;
        }
        $sentence = "$det0 $adj0 $noun $verb $det1 $adj1 $object0 $conj $det2 $adj2 $object1" if keys %h == 26;        
    }while(!$sentence);
    return $sentence;
}

MAIN:{
    open(DICTIONARY, "dictionary");
    print pangram(<DICTIONARY>) . "\n";
    close(DICTIONARY);
}

Sample Run


$ perl perl/ch-2.pl
each toxic windpipe jeopardize some quick wafted less every favorable arrangement
$ perl perl/ch-2.pl
each exaggerated wilier jeopardize all marketable enunciate and every quirky forgiveness

Notes

I made this a bit ore complicated then it could have been, although I didn't really get into the "Bonus" questions (see the original problem statement on the Weekly Challenge site for details). The main complication I chose to take on here is that I wanted to have the generated pangrams to be reasonably grammatically correct. To simplify things I chose a single template that the generated sentence can take on. The words for the sentences are then chosen at random according to the template. Amazingly this works! As part of this simplification words that need to match in number (plural, singular) will not quite line up. This is certainly doable, but represented more work than I was willing to put in at the time.

In order to get words to fit the template I make a first pass through the dictionary and assign parts of speech. This is another simplification, and seems to be a little rough. This is likely due to the fact that Lingua::EN::Tagger is very sophisticated and uses both its own dictionary and statistical techniques to determine parts of speech from bodies of text. Given just one word at a time its powers are not able to be used fully.

Since words are chosen completely at random the process to generate a valid pangram can take several minutes. The sentences generated can take on a slightly poetic aspect, there are some decent verses amidst all the chaos!

References

Challenge 161

Lingua::EN::Tagger

posted at: 16:10 by: Adam Russell | path: /perl | permanent link to this entry

2022-04-17

Four is Equilibrium

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given a positive number, $n < 10. Write a script to generate english text sequence starting with the English cardinal representation of the given number, the word "is" and then the English cardinal representation of the count of characters that made up the first word, followed by a comma. Continue until you reach four.

Solution


use strict;
use warnings;

my %cardinals = (
    1 => "one",
    2 => "two",
    3 => "three",
    4 => "four",
    5 => "five",
    6 => "six",
    7 => "seven",
    8 => "eight",
    9 => "nine"
);

sub four_is_magic{
    my($n, $s) = @_;
    $s = "" if !$s;
    return $s .= "four is magic" if $n == 4;
    $s .= $cardinals{$n} . " is " . $cardinals{length($cardinals{$n})} . ", ";
    four_is_magic(length($cardinals{$n}), $s);
}

MAIN:{
    print four_is_magic(5) . "\n";
    print four_is_magic(7) . "\n";
    print four_is_magic(6) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
five is four, four is magic
seven is five, five is four, four is magic
six is three, three is five, five is four, four is magic

Notes

I was thinking of a clever way I might do this problem. I got nothing! Too much Easter candy perhaps? Anyway, I am not sure there is much tow rite about here as it's an otherwise straightforward use of hashes.

Part 2

You are give an array of integers, @n. Write a script to find out the Equilibrium Index of the given array, if found.

Solution


use strict;
use warnings;

sub equilibrium_index{
    for my $i (0 .. @_ - 1){
        return $i if unpack("%32I*", pack("I*",  @_[0 .. $i])) == unpack("%32I*", pack("I*",  @_[$i .. @_ - 1]));
    }
    return -1;
}

MAIN:{
    print equilibrium_index(1, 3, 5, 7, 9) . "\n";
    print equilibrium_index(1, 2, 3, 4, 5) . "\n";
    print equilibrium_index(2, 4, 2) . "\n";
}

Sample Run


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

Notes

Like Part 1 above this problem allows for a pretty cut and dry solution. Also, similarly, I can't see a more efficient and/or creative way to solve this one. Maybe I should have just gone for obfuscated then?!?!? In any event, if nothing else, I always like using pack/unpack. I always considered it one of Perl's super powers!

References

Challenge 160

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

2022-04-10

Farey and Farey Again, but in a Mobius Way

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given a positive number, $n. Write a script to compute the Farey Sequence of the order $n.

Solution


use strict;
use warnings;

use POSIX;

sub farey{
    my($order) = @_;
    my @farey;
    my($s, $t, $u, $v, $x, $y) = (0, 1, 1, $order, 0, 0);
    push @farey, "$s/$t", "$u/$v";
    while($y != 1 && $order > 1){
        $x = POSIX::floor(($t + $order) / $v) * $u - $s;
        $y = POSIX::floor(($t + $order) / $v) * $v - $t;
        push @farey, "$x/$y";
        ($s, $t, $u, $v) = ($u, $v, $x, $y);
    }
    return @farey;
}

MAIN:{
    print join(", ", farey(7)) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
0/1, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 2/5, 3/7, 1/2, 4/7, 3/5, 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 1/1

Notes

Here is an iterative implementation of what seems to be a fairly standard recursive definition of the Farey Sequence. Well, "standard" may be over stating it as this sequence is seemingly fairly obscure. Fare-ly obscure? Ha! Anyway, this all seems fairly straightforward and the main thing to note here is that the sequence elements are stored as strings. This seems the most convenient way to keep them for display although in the next part of the challenge we'll use the sequence elements in a numerical way.

Part 2

You are given a positive number $n. Write a script to generate the Moebius Number for the given number.

Solution


use strict;
use warnings;

use POSIX;
use Math::Complex;

sub farey{
    my($order) = @_;
    my @farey;
    my($s, $t, $u, $v, $x, $y) = (0, 1, 1, $order, 0, 0);
    push @farey, "$s/$t", "$u/$v";
    while($y != 1 && $order > 1){
        $x = POSIX::floor(($t + $order) / $v) * $u - $s;
        $y = POSIX::floor(($t + $order) / $v) * $v - $t;
        push @farey, "$x/$y";
        ($s, $t, $u, $v) = ($u, $v, $x, $y);
    }
    return @farey;
}

sub mertens{
    my($n) = @_;
    my @farey = farey($n);
    my $mertens = 0;
    map {$mertens += exp(2 * M_PI * i * eval($_))} @farey;
    $mertens += -1;
    return Re($mertens);
}

sub moebius{
    my($n) = @_;
    return 1 if $n == 1;
    return sprintf("%.f", (mertens($n) - mertens($n - 1)));
}

MAIN:{
    map {print moebius($_) . "\n"} (5, 10, 20);
}

Sample Run


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

Notes

We can consider this second task of the challenge to be a continuation of the first. Here the Farey Sequence code is used again. But why? Well, in order to compute the Moebius Number we use an interesting property. The Mertens Function of $n is defined as the sum of the first $n Moebius Numbers. There is an alternative and equivalent definition of the Mertens Function, however, that use the Farey Sequence. In the alternative definition The Mertens Function is equivalent to what is shown in sub mertens: the sum of the natural logarithm base raised to the power of two times pi times i times the k-th element of the Farey Sequence. In Perl: map {$mertens += exp(2 * M_PI * i * eval($_))} @farey;

Thus to compute the n-th Moebius Number we compute the n-th and n-th - 1 Mertens Function and subtract as shown.

Be aware that this computation requires the use of Math::Complex, a core module which defines constants and operations on complex numbers. It's how we are able to use i in sub mertens.

References

Challenge 159

Farey Sequence

Mertens Function

Moebius Function

Math::Complex

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

2022-03-20

Persnickety Pernicious and Weird

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to generate the first 10 Pernicious Numbers.

Solution


use strict;
use warnings;

use Math::Primality qw/is_prime/;

sub count_bits{
    my($n) = @_;
    my $total_count_set_bit = 0;
    while($n){
        my $b = $n & 1;
        $total_count_set_bit++ if $b;
        $n = $n >> 1;
    }
    return $total_count_set_bit;
}

sub first_n_pernicious{
    my($n) = @_;
    my @pernicious;
    my $x = 1;
    do{
        my $set_bits = count_bits($x);
        push @pernicious, $x if is_prime($set_bits);
        $x++;
    }while(@pernicious < $n);
    return @pernicious;
}

MAIN:{
    print join(", ", first_n_pernicious(10)) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
3, 5, 6, 7, 9, 10, 11, 12, 13, 14

Notes

Number Theory was one of my favorite classes as an undergraduate. This sort of challenge is fun, especially if you dive into the background of these sequences and try to learn more about them. Computing them is fairly straightforward, especially here where the two functions are largely drawn from past TWCs.

Part 2

You are given number, $n > 0. Write a script to find out if the given number is a Weird Number.

Solution


use strict;
use warnings;

use boolean;
use Data::PowerSet q/powerset/;

sub factor{
    my($n) = @_;
    my @factors = (1);
    foreach  my $j (2 .. sqrt($n)){
        push @factors, $j if $n % $j == 0;
        push @factors, ($n / $j) if $n % $j == 0 && $j ** 2 != $n;
    }
    return @factors;  
}

sub is_weird{
    my($x) = @_;
    my @factors = factor($x); 
    my $sum = unpack("%32I*", pack("I*",  @factors));
    for my $subset (@{powerset(@factors)}){
        return false if unpack("%32I*", pack("I*",  @{$subset})) == $x;
    }  
    return boolean($sum > $x);
}

MAIN:{
    print is_weird(12) . "\n";
    print is_weird(70) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
0
1

Notes

This task kind of bothered me, not because of the complexity of the task itself; the code was overall not extremely demanding. Rather anytime when I want to make use of Data::PowerSet I get a bit anxious that there may be a far more elegant way of proceeding! After coming up blank on alternatives I just went with this, but I'll probably still have this in the back of my mind for a few more days.

References

Challenge 156

Pernicious Number

Weird Number

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

2022-03-13

Fortunate Pisano

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to produce the first eight Fortunate Numbers (unique and sorted).

Solution


use strict;
use warnings;

use boolean;
use Math::Primality qw/is_prime/;

use constant N => 10_000; 

sub sieve_atkin{
    my($n) = @_;
    my @primes = (2, 3, 5);
    my $upper_bound = int($n * log($n) + $n * log(log($n)));
    my @atkin = (false) x $upper_bound;    
    my @sieve = (1, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 49, 53, 59);
    for my $x (1 .. sqrt($upper_bound)){
        for(my $y = 1; $y <= sqrt($upper_bound); $y+=2){
            my $m = (4 * $x ** 2) + ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (1, 13, 17, 29, 37, 41, 49, 53) if $m <= $upper_bound; 
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    } 
    for(my $x = 1; $x <= sqrt($upper_bound); $x += 2){
        for(my $y = 2; $y <= sqrt($upper_bound); $y += 2){
            my $m = (3 * $x ** 2) + ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (7, 19, 31, 43) if $m <= $upper_bound; 
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    }   
    for(my $x = 2; $x <= sqrt($upper_bound); $x++){
        for(my $y = $x - 1; $y >= 1; $y -= 2){
            my $m = (3 * $x ** 2) - ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (11, 23, 47, 59) if $m <= $upper_bound;
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    } 
    my @m;
    for my $w (0 .. ($upper_bound / 60)){
        for my $s (@sieve){
            push @m, 60 * $w + $s;  
        }
    }
    for my $m (@m){
        last if $upper_bound < ($m ** 2);
        my $mm = $m ** 2;
        if($atkin[$m]){
            for my $m2 (@m){
                my $c = $mm * $m2;
                last if $c > $upper_bound;
                $atkin[$c] = false;
            }
        }
    }
    map{ push @primes, $_ if $atkin[$_] } 0 .. @atkin - 1;
    return @primes; 
}

sub first_n_fortunate{
    my($n) = @_;
    my @primes = sieve_atkin(N);
    my @fortunates;
    my $x = 1;
    do{
        my @first_n_primes = @primes[0 .. $x - 1];
        my $product_first_n_primes = 1;
        map {$product_first_n_primes *= $_} @first_n_primes;
        my $m = 1;
        do{
            $m++;
        }while(!is_prime($product_first_n_primes + $m));
        if(!grep {$m == $_} @fortunates){
             unshift @fortunates, $m;
        }
        $x++;
    }while(@fortunates != $n);
    return sort {$a <=> $b} @fortunates;
}

MAIN:{
    print join(", ", first_n_fortunate(8)) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
3, 5, 7, 13, 17, 19, 23, 37

Notes

Yet another re-use of my Sieve of Adkin code! Here the sieve is used to generate primes for us to compute primorials, the product of the first n prime numbers. A Fortunate Number is a sequence in which each kth term is the number m such that for the primorial of the first k primes summed with the smallest m,m > 1 such that the sum is prime. It is an unproven conjecture in Number Theory that all terms of the Fortunate Numbers sequence are prime.

Here the code follows pretty directly from the definition with the added restrictions that we must eliminate duplicates and sort the results.

Part 2

Write a script to find the period of the third Pisano Period.

Solution


use strict;
use warnings;

use constant N => 1_000_000_000; 

sub fibonacci_below_n{
    my($n, $fibonaccis) = @_;
    $fibonaccis = [1, 1] if !$fibonaccis;
    my $f = $fibonaccis->[@{$fibonaccis} - 2] + $fibonaccis->[@{$fibonaccis} - 1];
    if($f < $n){
        push @{$fibonaccis}, $f;
        fibonacci_below_n($n, $fibonaccis);
    }
    else{
        return $fibonaccis;
    }
}

sub multiplicative_order{
    my($a, $n) = @_;
    my $k = 1;
    my $result = 1;
    while($k < $n){
        $result = ($result * $a) % $n;
        return $k if $result == 1;
        $k++;
    }
    return -1 ;
}

sub fibonacci_period_mod_n{
    my($n) = @_;
    my $fibonaccis = fibonacci_below_n(N);
    my $k = 1;
    for my $f (@{$fibonaccis}){
        if($f % $n == 0){
            return $k * multiplicative_order($fibonaccis->[$k+1], $n);
        }
        $k++;
    }
    return -1;
}

MAIN:{
    print fibonacci_period_mod_n(3) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
8

Notes

It is possible to compute the Pisano period in a fairly direct way. First you must determine the smallest Fibonacci Number evenly divisible by the modulus. Record the index of this term in the sequence, call it k. Compute the multiplicative order M of the k+1st term with the given modulus. The Pisano period is then k * M.

The above code implements that procedure fairly directly. One possible change would be to not pre-compute Fibonacci terms as done here, but for this small problem it hardly matters. Take care if trying this out on very large terms, however.

References

Challenge 155

Fortunate Prime

Multiplicative Order

Pisano Period

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

2022-03-06

Padovan Prime Directive: Find the Missing Permutations

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given possible permutations of the string "PERL". Write a script to find any permutations missing from the list.

Solution


use strict;
use warnings;

use Algorithm::Loops q/NestedLoops/;

sub factorial{
    my($n) = @_;
    return 1 if $n == 1;
    $n * factorial($n - 1);
}

sub missing_permutations{
    my($permutations, $s) = @_;
    my @missing;
    ##
    # remove any duplicates
    ##
    my %permutations;
    map {$permutations{$_}=undef} @{$permutations};    
    $permutations = [keys %permutations];
    ##
    # get the letters missing in each slot
    ##
    my @missing_letters;
    for my $i (0 .. length($s) - 1){
        my %slot_counts;
        my @ith_letters = map {my @a = split(//, $_); $a[$i]} @{$permutations};
        map{$slot_counts{$_}++} @ith_letters;
        $missing_letters[$i] = [grep {$slot_counts{$_} != factorial(length($s) - 1)} keys %slot_counts];
    }
    ##
    # determine which missing letters form missing permutations
    ##
    my $nested = NestedLoops(\@missing_letters);
    while (my @set = $nested->()){
        my $candidate = join("", @set);
        my @matched = grep {$candidate eq $_} @{$permutations};
        push @missing, $candidate if !@matched;
    }
    return @missing;
}


MAIN:{
    my @missing = missing_permutations(
        ["PELR", "PREL", "PERL", "PRLE", "PLER", "PLRE", "EPRL", "EPLR", "ERPL",
         "ERLP", "ELPR", "ELRP", "RPEL", "RPLE", "REPL", "RELP", "RLPE", "RLEP",
         "LPER", "LPRE", "LEPR", "LRPE", "LREP"], "PERL"
    );
    print join(", ", @missing) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
LERP

Notes

Here I tried to write as general a solution as possible. This code should handle any number of missing permutations, provided that there are no duplicate letters within the starting word.

The approach is to first consider each position in the starting word as a "slot" and then check which letters are missing from each slot. In the code above we assume that each letter from the starting word appears in each slot at least once.

Once we know the missing letters we form new permutations with them and see which ones are missing from the initial list. To cut down on the tedious bookkeeping involved I used the Algorithm::Loops module to generate the candidate permutations from the known missing letters.

An even more general solution would not only catch any number of missing permutations but also allow for duplicate letters in the starting word and an input containing permutations which so not have at least one occurrence of each letter per slot.

Part 2

Write a script to compute the first 10 distinct Padovan Primes.

Solution


use strict;
use warnings;

use Math::Primality qw/is_prime/;

sub first_n_padovan_primes{
    my($n) = @_;
    my @padovan_primes;
    my @padovans = (1, 1, 1);
    {
        push @padovans, $padovans[@padovans - 2] + $padovans[@padovans - 3];
        push @padovan_primes, $padovans[@padovans - 1] if is_prime($padovans[@padovans - 1]);
        redo if @padovan_primes <= $n;
    }
    return @padovan_primes[1..@padovan_primes - 1];
}

MAIN:{
    print join(", ", first_n_padovan_primes(10)) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
2, 3, 5, 7, 37, 151, 3329, 23833, 13091204281, 3093215881333057

Notes

Before really looking at the sample solutions for this problem I decided that my approach would be generat e giant list of primes and then check against that list to determine if a new sequence element was prime or not. Nice idea, but it doesn't scale that well for this problem! Yes, it worked for a smaller number of Padovan Primes but to catch the first ten would require generating an enormous list of prime numbers. Better in this case to use something like Math::Primality to check each candidate.

References

Challenge 154

Padovan Sequence

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

2022-02-27

Finding the Factorials and Factorions That Are Left

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to determine the first ten members of the Left Factorials sequence.

Solution


use strict;
use warnings;

use POSIX;
use constant UPPER_BOUND => INT_MAX/1000;

sub left_factorials_sieve{
    my($n) = @_;
    my @sieve = (0 .. UPPER_BOUND);
    my $x = 2;
    {
        my @sieve_indices = grep { $_ <= $x || $_ % $x == 0 } 0 .. @sieve - 1; 
        @sieve = map{ $sieve[$_] } @sieve_indices;
        $x++;
        redo if $x <= $n;
    }
    return @sieve[1 .. @sieve - 1];
}

MAIN:{
    print join(", ", left_factorials_sieve(10)) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
1, 2, 4, 10, 34, 154, 874, 5914, 46234, 409114 

Notes

The problem statement for this refers to a On-Line Encyclopedia of Integer Sequences entry. That OEIS entry mentions some interesting facts about the sequence, including the sieve technique used here. Officially the sequence seems to start with 0 but since the example shows it starting with 1 here the initial 0 element is removed.

There is nothing special about the choice of UPPER_BOUND it is just an arbitrarily large number which fits the purpose. I chose the number via trial and error, but it seems there is a straightforward provable upper bound U required to get a sequence of required sequence length N. If this were a math text then I as the author would be compelled to leave a frustrating note that finding the upper bound is left as an exercise for the reader. Ha!

Part 2

Write a script to figure out if the given integer is a factorion.

Solution


use strict;
use warnings;

use boolean;

sub factorial{
    my($n) = @_;
    return 1 if $n == 1;
    $n * factorial($n - 1);
}

sub is_factorion{
    my($n) = @_;
    return boolean($n == unpack("%32I*", pack("I*", map {factorial($_)} split(//, $n))));
}

MAIN:{
    print is_factorion(145) . "\n";
    print is_factorion(123) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
1
0

Notes

In this solution I tried to optimize for the least amount of code. Not quite a golfed solution, but compact, to be sure. The digits are obtained via split, passed to our totally boring recursive factorial() function, the sum of the resulting factorials taken using pack, and then that sum compared to $n. For convenience in stringifying the output boolean() is used.

References

Challenge 153

Left Factorial Sequence

Left Factorial

Factorion

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

2022-02-06

Fibonacci Words That Yearn to Be Squarefree

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given two strings having the same number of digits, $a and $b. Write a script to generate Fibonacci Words by concatenation of the previous two strings. Print the 51st
of the first term having at least 51 digits.

Solution


use strict;
use warnings;

sub _fibonacci_words_51{
    my($accumulated) = @_;
    my $i = @{$accumulated} - 1;
    my $next = $accumulated->[$i - 1] . $accumulated->[$i];
    return substr($next, 51 - 1, 1) if length($next) >= 51;
    push @{$accumulated}, $next;
    _fibonacci_words_51($accumulated);
}

sub fibonacci_words{
    my($u, $v) = @_;
    return _fibonacci_words_51([$u, $v]);
}

MAIN:{
    print fibonacci_words(q[1234], q[5678]) . "\n";    
}

Sample Run


$ perl perl/ch-1.pl
7

Notes

Fibonacci sequences are often an introductory example of recursion. This solution keeps with that recursive tradition. sub _fibonacci_words_51 takes a single argument, an array reference which stores the sequence terms. At each recursive step the next term is computed and checked for the terminating condition.

Part 2

Write a script to generate all square-free integers <= 500.

Solution


use strict;
use warnings;

use constant LIMIT => 500;

sub prime_factor{
    my $x = shift(@_); 
    my @factors;    
    for (my $y = 2; $y <= $x; $y++){
        next if $x % $y;
        $x /= $y;
        push @factors, $y;
        redo;
    }
    return @factors;  
}

sub square_free{
    my @square_free;
    for my $x (1 .. LIMIT){
        my @factors = prime_factor($x);
        my @a;
        map {$a[$_]++} @factors;
        @a = grep {$_ && $_ > 1} @a;
        push @square_free, $x if !@a;
    }
    return @square_free;
}

main:{
    print join(", ", square_free()) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
1, 2, 3, 5, 6, 7, 10, 11, 13, 14, 15, 17, 19, 21, 22, 23, 26, 29, 30, 31, 33, 34, 35, 37, 38, 39, 41, 42, 43, 46, 47, 51, 53, 55, 57, 58, 59, 61, 62, 65, 66, 67, 69, 70, 71, 73, 74, 77, 78, 79, 82, 83, 85, 86, 87, 89, 91, 93, 94, 95, 97, 101, 102, 103, 105, 106, 107, 109, 110, 111, 113, 114, 115, 118, 119, 122, 123, 127, 129, 130, 131, 133, 134, 137, 138, 139, 141, 142, 143, 145, 146, 149, 151, 154, 155, 157, 158, 159, 161, 163, 165, 166, 167, 170, 173, 174, 177, 178, 179, 181, 182, 183, 185, 186, 187, 190, 191, 193, 194, 195, 197, 199, 201, 202, 203, 205, 206, 209, 210, 211, 213, 214, 215, 217, 218, 219, 221, 222, 223, 226, 227, 229, 230, 231, 233, 235, 237, 238, 239, 241, 246, 247, 249, 251, 253, 254, 255, 257, 258, 259, 262, 263, 265, 266, 267, 269, 271, 273, 274, 277, 278, 281, 282, 283, 285, 286, 287, 290, 291, 293, 295, 298, 299, 301, 302, 303, 305, 307, 309, 310, 311, 313, 314, 317, 318, 319, 321, 322, 323, 326, 327, 329, 330, 331, 334, 335, 337, 339, 341, 345, 346, 347, 349, 353, 354, 355, 357, 358, 359, 362, 365, 366, 367, 370, 371, 373, 374, 377, 379, 381, 382, 383, 385, 386, 389, 390, 391, 393, 394, 395, 397, 398, 399, 401, 402, 403, 406, 407, 409, 410, 411, 413, 415, 417, 418, 419, 421, 422, 426, 427, 429, 430, 431, 433, 434, 435, 437, 438, 439, 442, 443, 445, 446, 447, 449, 451, 453, 454, 455, 457, 458, 461, 462, 463, 465, 466, 467, 469, 470, 471, 473, 474, 478, 479, 481, 482, 483, 485, 487, 489, 491, 493, 494, 497, 498, 499

Notes

This solution makes use of sub prime_factor which frequently comes in handy in these challenges. Beyond getting the prime factors the only other requirement is to determine that none are repeated. This is done by a counting array, created with a map and then checked with grep for any entries greater than 1. If such an entry exists then we know that there was a duplicate prime factor and that number is not square free.

References

Challenge 150

Squarefree Numbers

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

2022-01-29

Calling a Python Function From Perl

Part 1

Recently the question came up of how to call a Python function from Perl. Here is one way to do it.

The method here is to use Expect.pm to create a subprocess containing the Python repl. Python code is then loaded and called interactively. In my experience this is good for calling, say, a BERT model on some text from Perl. This approach is minimalistic as compared to other solutions such as standing up a Fast API instance to serve the model. Furthermore, this same pattern can be used for any arbitrary Python code you may need to call from Perl.

While this works well it does introduce additional complexity to an application. If at all possible it is preferable to re-write the Python functionality in Perl. An ideal use case would be where it would be too laborious to re-implement the Python code in Perl. Imagine, say, we want to use KeyBERT to extract keywords from a given body of text. In this case we may be doing substantial data and text processing in Perl and merely need to call out to Python for this single function. If at some point KeyBERT were to become available natively to Perl, perhaps through the Apache MXNet bindings, then that interface should be preferred. If nothing else, the performance improvement would be dramatic.

Solution


use strict;
use warnings;
##
# A simple example of calling a Python function
# from a Perl script using a Python repl started
# as a subprocess.
##
use Expect;
use boolean;
use constant TIMEOUT => 0.25; 
use constant PYTHON => q[/usr/bin/python];

sub create_python{
    my($io) = @_;
    my $python = do{
        local $/;
        ;
    };
    $$io = new Expect();
    $$io->log_stdout(false);
    $$io->raw_pty(true);
    $$io->spawn(PYTHON);
    $$io->send("$python\n\n");
    $$io->expect(TIMEOUT, q[-re] , q|m/[0-9]*/|);
    $$io->clear_accum();
}

sub call_python_sample{
    my($io, $arg) = @_;
    print $$io->send("sample(" . $arg . ")\n");
    $$io->expect(TIMEOUT, q[-re], qr[\d+]);
    my $r = $$io->exp_match();
    $$io->clear_accum();
    return $r;
}

MAIN:{
    my($io);
    create_python(\$io);
    print call_python_sample(\$io, 1) . "\n";
    print call_python_sample(\$io, 9) . "\n";
}

__DATA__
import os
os.system("stty -echo")
def sample(a):
    print(str(a + 1))

The results


$ perl call_python_.pl
2
10

Notes

The code here is a minimum working example. Well, fairly minimal in that I could have avoided breaking things up into multiple subroutines. In terms of cleanliness and explainability these divisions make sense, with only the added need to pass a reference to an Expect object back and forth as a parameter.

For a self-contained example the Python code we are going to run is contained in the DATA section. For more complex use cases it would make sense to have the Python code in separate files which could be read in and loaded. They could also be specified directly as arguments to the Python interpreter.

Effectively what we are doing is interprocess communication using text passed between the two processes. Perl knows nothing of the state of the Python code, and vice versa. If you call a Python function which does not print a value to STDOUT then you will need to add your own print() call. This is not actually so bad a situation since Expect works by pattern matching on the expected (pun intended!) output. To ensure you are collecting the right values some massaging of what the Python code is doing is to be anticipated (pun avoided!). For example, suppose we want to call the KeyBERT function to extract key words from some given text. We might consider writing a wrapper function which takes the output from KeyBERT.extract_keywords (a list of tuples, each tuple a pair: key phrase and a distance) and concatenates and prints each of the pairs to STDOUT on a single line. In this way our Perl regex can most easily pick up the phrase/distance pairs.

Expect is a very mature tool, with a generous set of options and abilities. This sort of use is really just the tip of the iceberg. In terms of Perl being a "Glue Language" consider Expect to be a key ingredient that causes the glue to stick. Peruse the documentation for further inspiration.

References

Expect.pm

KeyBERT

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

2022-01-16

Primes and Pentagonals

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to generate first 20 left-truncatable prime numbers in base 10.

Solution


use strict;
use warnings;

use boolean;
use constant N => 10_000; 

sub sieve_atkin{
    my($n) = @_;
    my @primes = (2, 3, 5);
    my $upper_bound = int($n * log($n) + $n * log(log($n)));
    my @atkin = (false) x $upper_bound;    
    my @sieve = (1, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 49, 53, 59);
    for my $x (1 .. sqrt($upper_bound)){
        for(my $y = 1; $y <= sqrt($upper_bound); $y+=2){
            my $m = (4 * $x ** 2) + ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (1, 13, 17, 29, 37, 41, 49, 53) if $m <= $upper_bound; 
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    } 
    for(my $x = 1; $x <= sqrt($upper_bound); $x += 2){
        for(my $y = 2; $y <= sqrt($upper_bound); $y += 2){
            my $m = (3 * $x ** 2) + ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (7, 19, 31, 43) if $m <= $upper_bound; 
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    }   
    for(my $x = 2; $x <= sqrt($upper_bound); $x++){
        for(my $y = $x - 1; $y >= 1; $y -= 2){
            my $m = (3 * $x ** 2) - ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (11, 23, 47, 59) if $m <= $upper_bound;
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    } 
    my @m;
    for my $w (0 .. ($upper_bound / 60)){
        for my $s (@sieve){
            push @m, 60 * $w + $s;  
        }
    }
    for my $m (@m){
        last if $upper_bound < ($m ** 2);
        my $mm = $m ** 2;
        if($atkin[$m]){
            for my $m2 (@m){
                my $c = $mm * $m2;
                last if $c > $upper_bound;
                $atkin[$c] = false;
            }
        }
    }
    map{ push @primes, $_ if $atkin[$_] } 0 .. @atkin - 1;
    return @primes; 
}

sub truncatable{
    my($prime, $primes) = @_;
    return false if $prime =~ m/0/;
    my @truncatable = map { my $p = substr($prime, -1 * $_, $_); grep {$p == $_} @{$primes}} 1 .. length($prime);
    return @truncatable == length($prime);
}

sub first_n_truncatable_primes{
    my($n) = @_;
    my @primes = sieve_atkin(N);
    my @truncatable;
    for my $prime (@primes){
        push @truncatable, $prime if truncatable($prime, \@primes);
        last if @truncatable == $n;
    }
    return @truncatable;
}

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

Sample Run


$ perl perl/ch-1.pl
2, 3, 5, 7, 13, 17, 23, 37, 43, 47, 53, 67, 73, 83, 97, 113, 137, 167, 173, 197

Notes

First off, I am re-using the Sieve of Atkin code I wrote for a previous challenge. These challenges somewhat frequently have a prime number component so, if I get a chance, I'll compose that code into it's own module. If it weren't for the copy/paste of the Sieve of Atkin code then this solution would be very short! This sort of string manipulation is where Perl excels and the determination of whether a number is left truncatable takes only a few lines.

Part 2

Write a script to find the first pair of Pentagon Numbers whose sum and difference are also a Pentagon Number.

Solution


use strict;
use warnings;

use constant N => 10_000;

sub n_pentagon_numbers{
    my($n) = @_;
    my @pentagon_numbers;
    my $x = 1;
    my %h;
    do{
        my $pentagon = $x * (3 * $x - 1) / 2;
        push @pentagon_numbers, $pentagon;
        $h{"$pentagon"} = $x;
        $x++;
    }while(@pentagon_numbers < $n);
    return (\@pentagon_numbers, \%h);
}

sub pairs_pentagon{
    my($n) = @_;
    my($pentagons, $lookup) = n_pentagon_numbers(N);
    my @pairs;
    for my $x (0 .. @{$pentagons} - 1){
        for my $y (0 .. @{$pentagons} - 1){
            unless($x == $y){
                my($sum, $difference) = ($pentagons->[$x] + $pentagons->[$y], abs($pentagons->[$x] - $pentagons->[$y]));
                 if($lookup->{$sum} && $lookup->{$difference}){
                     my($s, $t) = ($x + 1, $y + 1);
                     push @pairs, ["P($s)", "P($t)"]
                 }
            }
            last if @pairs == $n;
        }
        last if @pairs == $n;
    }
    return @pairs;
}

sub first_pair_pentagon{
    return [pairs_pentagon(1)];
}

MAIN:{
    print join(", ", @{first_pair_pentagon()->[0]}) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
P(1020), P(2167)

Notes

This second part of the challenge proceeds in mostly the same way as the first. We generate a large list of candidates and then search for those exhibiting the property in question. It is somewhat unexpected that the first pair of Pentagonal Numbers that have this property are so deeply located. Many times in these challenges the solution is emitted without quite as much searching!

References

Challenge 147

Left Truncatable Primes

Pentagonal Numbers

posted at: 13:29 by: Adam Russell | path: /perl | permanent link to this entry

2022-01-09

Sieve of Atkin / Curious Fraction Tree

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to generate the 10001st prime number.

Solution


use strict;
use warnings;

use boolean; 
use Getopt::Long;
use LWP::UserAgent;

use constant N => 10_001;   
use constant PRIME_URL => "http://primes.utm.edu/lists/small/100000.txt";

sub get_primes{
    my @primes;
    my $ua = new LWP::UserAgent(
        ssl_opts => {verify_hostname => 0}
    );
    my $response = $ua->get(PRIME_URL);
    my @lines = split(/\n/,$response->decoded_content);
    foreach my $line (@lines){
        my @p = split(/\s+/, $line);
        unless(@p < 10){
            push @primes, @p[1..(@p - 1)];
        }
    }
    return @primes;
}

sub sieve_atkin{
    my($n) = @_;
    my @primes = (2, 3, 5);
    my $upper_bound = int($n * log($n) + $n * log(log($n)));
    my @atkin = (false) x $upper_bound;    
    my @sieve = (1, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 49, 53, 59);
    for my $x (1 .. sqrt($upper_bound)){
        for(my $y = 1; $y <= sqrt($upper_bound); $y+=2){
            my $m = (4 * $x ** 2) + ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (1, 13, 17, 29, 37, 41, 49, 53) if $m <= $upper_bound; 
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    } 
    for(my $x = 1; $x <= sqrt($upper_bound); $x += 2){
        for(my $y = 2; $y <= sqrt($upper_bound); $y += 2){
            my $m = (3 * $x ** 2) + ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (7, 19, 31, 43) if $m <= $upper_bound; 
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    }   
    for(my $x = 2; $x <= sqrt($upper_bound); $x++){
        for(my $y = $x - 1; $y >= 1; $y -= 2){
            my $m = (3 * $x ** 2) - ($y ** 2);
            my @remainders;  
            @remainders = grep {$m % 60 == $_} (11, 23, 47, 59) if $m <= $upper_bound; 
            $atkin[$m] = !$atkin[$m] if @remainders; 
        }          
    } 
    my @m;
    for my $w (0 .. ($upper_bound / 60)){
        for my $s (@sieve){
            push @m, 60 * $w + $s;  
        }
    }
    for my $m (@m){
        last if $upper_bound < ($m ** 2);
        my $mm = $m ** 2;
        if($atkin[$m]){
            for my $m2 (@m){
                my $c = $mm * $m2;
                last if $c > $upper_bound;
                $atkin[$c] = false;
            }
        }
    }
    map{ push @primes, $_ if $atkin[$_] } 0 .. @atkin - 1;
    return @primes; 
}

sub get_nth_prime{
    my($n, $generate) = @_; 
    my @primes;
    unless($generate){
        @primes = get_primes;
    }
    else{
        @primes = sieve_atkin($n);
    }
    return $primes[$n - 1]; 
}


MAIN:{
    my $n = N;
    my $generate = false;
    GetOptions("n=i" => \$n, generate => \$generate);
    print get_nth_prime($n, $generate) . "\n"; 
}

Sample Run


$ perl perl/ch-1.pl
104743
$ perl perl/ch-1.pl --generate
104743
$ perl perl/ch-1.pl --generate
104743
$ perl perl/ch-1.pl --generate --n 101
547
$ perl perl/ch-1.pl --generate --n 11
31
$ perl perl/ch-1.pl --n 10001
104743
$ perl perl/ch-1.pl --n 11
31

Notes

I've mentioned it before, but for anything that asks for or needs prime numbers I always ust grab them from one of several convenient online sources, rather than generate them myself.

This time around I figured it'd be sporting to generate them myself, but maybe in an interesting way. Here I implement a sieve method for determining prime numbers. This Sieve of Atkin_ has a claim to fame of being the most performant among prime number generating sieve techniques. The code is a bit convoluted looking, I will admit, but is a faithful Perl representation of the algorithm (follow the reference link for pseudocode). Also, rather than try and explain the algorithm myself anyone interested can find full in depth treatments elsewhere. A background in number theory helps for some of the details.

Since I have some existing code for getting the pre-computed primes I figured I would use that as a check and extra feature. Command line options allow for the default behavior (fetch pre-computed primes for an N of 10,001) to be overridden.

Part 2

Given a fraction return the parent and grandparent of the fraction from the Curious Fraction Tree.

Solution


use strict;
use warnings;

use Graph;
use constant ROOT => "1/1";
use constant SEPARATOR => "/";

sub initialize{
    my($member) = @_;
    my $graph = new Graph();
    $graph->add_vertex(ROOT);
    my @next = (ROOT);
    my @changes = ([0, 1], [1, 0]);
    my $level = 0;
    {
        my @temp_next;
        my @temp_changes;
        do{
            $level++;
            my $next = shift @next;
            my($top, $bottom) = split(/\//, $next);
            my $change_left = shift @changes;
            my $change_right = shift @changes;
            my $v_left = ($top + $change_left->[0]) . SEPARATOR . ($bottom + $change_left->[1]);
            my $v_right = ($top + $change_right->[0]) . SEPARATOR . ($bottom + $change_right->[1]);    
            $graph->add_edge($next, $v_left);
            $graph->add_edge($next, $v_right);
            push @temp_next, $v_left, $v_right;
            push @temp_changes, $change_left;
            push @temp_changes, [$level + 1, 0], [0, $level + 1];
            push @temp_changes, $change_right;
        }while(@next && !$graph->has_vertex($member));
        @next = @temp_next;
        @changes = @temp_changes; 
        redo if !$graph->has_vertex($member);
    }
    return $graph;
}

sub curious_fraction_tree{
    my($member) = @_;
    my $graph = initialize($member);
    my($parent) = $graph->predecessors($member);
    my($grandparent) = $graph->predecessors($parent);
    return ($parent, $grandparent);
}

MAIN:{
    my($member, $parent, $grandparent);
    $member = "3/5";
    ($parent, $grandparent) = curious_fraction_tree($member);
    print "member = '$member'\n";
    print "parent = '$parent' and grandparent = '$grandparent'\n";
    print "\n";
    $member = "4/3";
    ($parent, $grandparent) = curious_fraction_tree($member);
    print "member = '$member'\n";
    print "parent = '$parent' and grandparent = '$grandparent'\n";
}

Sample Run


$ perl perl/ch-2.pl
member = '3/5'
parent = '3/2' and grandparent = '1/2'

member = '4/3'
parent = '1/3' and grandparent = '1/2'

Notes

My thought process on this problem started somewhat backwards. After reading the problem statement I thought of the Graph module and remembered that it defines a function predecessors() which would be very useful for this. After convincing myself to use Graph; I then probably spent the majority of the time for this just getting my head around how to define new vertices at each level of the tree. Like all trees there is some recursiveness to the structure, but an iterative implementation still looks clean as well.

Once the graph is constructed the solution as required comes from calling predecessors() to get the parent and grandparent vertices.

References

Challenge 146

Sieve of Atkin

Prime Pages

Graph

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

2021-12-26

A Stocking Full of Numbers: Semiprimes and the Ulam Sequence

Merry Christmas and Happy New Year! May 2022 bring you less COVID and more Perl projects!

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to generate all Semiprime numbers <= 100.

Solution


use strict;
use warnings;
use boolean; 
use LWP::UserAgent;
use constant N => 100; 
use constant PRIME_URL => "http://primes.utm.edu/lists/small/100000.txt";

sub get_primes{
    my @primes;
    my $ua = new LWP::UserAgent(
        ssl_opts => {verify_hostname => 0}
    );
    my $response = $ua->get(PRIME_URL);
    my @lines = split(/\n/,$response->decoded_content);
    foreach my $line (@lines){
        my @p = split(/\s+/, $line);
        unless(@p < 10){
            push @primes, @p[1..(@p - 1)];
        }
    }
    return @primes;
}

sub factor{
    my($n) = @_;
    my @factors = ();
    for  my $j (2 .. sqrt($n)){
        if($j**2 == $n){  
            push @factors, [$j, $j] if $j**2 == $n;
            next; 
        }
        push @factors, [$j, $n / $j] if $n % $j == 0;
    }
    return @factors;
}

sub semiprime{
    my($n, $primes) = @_;
    my @factors = factor($n);
    return false if @factors != 1;  
    my @prime_factors = grep {$factors[0]->[0] == $_ || $factors[0]->[1] == $_} @{$primes};     
    return true if @prime_factors == 2 || $prime_factors[0]**2 == $n; 
    return false; 
}

sub semiprime_n{
    my @primes = get_primes; 
    for my $n (1 .. N){
        print "$n " if semiprime($n, \@primes);   
    } 
    print "\n"; 
}

MAIN:{
    semiprime_n;
}

Sample Run


$ perl ch-1.pl
4 6 9 10 14 15 21 22 25 26 33 34 35 38 39 46 49 51 55 57 58 62 65 69 74 77 82 85 86 87 91 93 94 95

Notes

I am sticking to the convention that I started a while back to not re-compute prime numbers myself, but instead just grab them from one of several convenient online sources. The URL in the code above requires only a small amount of effort to scrape and parse. I hope nobody minds the little bit of extra traffic to their site!

Please do check out their main page listed below. It's a fun resource with interesting facts and news on prime numbers and related research.

Once the list of the first 100k primes is obtained (that's more than enough for any of these challenges) we proceed to factor and test candidate numbers. Provided the number has only two factors (which may be equal) and both of them are prime then it passes the semiprime test.

Part 2

You are given two positive numbers, $u and $v. Write a script to generate Ulam Sequence having at least 10 Ulam numbers where $u and $v are the first 2 Ulam numbers.

Solution


use strict;
use warnings;
use constant ULAM_LIMIT => 10;   

sub ulam{
    my($u, $v) = @_;    
    my %pairs; 
    my @ulam = ($u, $v); 
    my $w = $u + $v;  
    push @ulam, $w;  
    $pairs{"$u,$v"} = $w; 
    $pairs{"$u,$w"} = $u + $w; 
    $pairs{"$v,$w"} = $v + $w; 
    do{
        my @sums = sort {$a <=> $b} grep{my $sum = $_; my @values = grep{$sum == $_} values %pairs; $sum if @values == 1 && $sum > $ulam[@ulam - 1]} values %pairs; 
        my $u = $sums[0]; 
        push @ulam, $u;
        for my $pair (keys %pairs){
            my($s, $t) = split(/,/, $pair);  
            $pairs{"$s,$u"} = $s + $u;
            $pairs{"$t,$u"} = $t + $u;
        }   
    }while(@ulam < ULAM_LIMIT);
    return @ulam;  
}

MAIN:{
    my @ulam;
    @ulam = ulam(1, 2);   
    {
        print shift @ulam;
        print ", ";
        redo if @ulam > 1;
    } 
    print shift @ulam;
    print "\n";

    @ulam = ulam(2, 3);   
    {
        print shift @ulam;
        print ", ";
        redo if @ulam > 1;
    } 
    print shift @ulam;
    print "\n";

    @ulam = ulam(2, 5);   
    {
        print shift @ulam;
        print ", ";
        redo if @ulam > 1;
    } 
    print shift @ulam;
    print "\n";
}

Sample Run


$ perl perl/ch-2.pl
1, 2, 3, 4, 6, 8, 11, 13, 16, 18
2, 3, 5, 7, 8, 9, 13, 14, 18, 19
2, 5, 7, 9, 11, 12, 13, 15, 19, 23

Notes

The code here is a pretty direct translation of the definition: the next member of the sequence must be a sum of two previous members which is greater than the previous member and only be obtainable one way. Here that is done with a grep filter, with the sequence itself being stored in an array, but for convenience the sums of all unique previous pairs are kept in a hash.

References

Challenge 144

Semiprime Number

Prime Pages

Ulam Sequence

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

2021-12-19

Stealthy Calculations

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given a string, $s, containing mathematical expression. Write a script to print the result of the mathematical expression. To keep it simple, please only accept + - * ().

Solution

Main driver.


use strict;
use warnings;
##
# Write a script to implement a four function infix calculator.     
##
use TWCCalculator;
use constant ADD => "10 + 8";
use constant SUBTRACT => "18 - 66";
use constant ADD_SUBTRACT => "10 + 20 - 5";  
use constant MULTIPLY => "10 * 8";
use constant DIVIDE => "52 / 2";
use constant CALCULATE => "(10 + 20 - 5) * 2"; 

MAIN:{
    my $parser = new TWCCalculator();
    $parser->parse(ADD); 
    $parser->parse(SUBTRACT); 
    $parser->parse(ADD_SUBTRACT); 
    $parser->parse(MULTIPLY); 
    $parser->parse(DIVIDE);
    $parser->parse(CALCULATE);
}   

TWCCalculator.yp (the Parse::Yapp code). This file is used to generate a parser module, TWCCalculator.pm, which is used in the code above. This is where the actual parsing of the input and implementation of the calculator is.


%token NUMBER    
%left '+' '-' '*' '/'

%%

line: 
    | expression  {print $_[1] . "\n"} 
;

expression: NUMBER
    | expression '+' expression {$_[1] + $_[3]}
    | expression '-' expression {$_[1] - $_[3]}
    | expression '*' expression {$_[1] * $_[3]}
    | expression '/' expression {$_[1] / $_[3]}
    | '(' expression ')' {$_[2]}
;

%%

sub lexer{
    my($parser) = @_;
    $parser->YYData->{INPUT} or return('', undef);
    $parser->YYData->{INPUT} =~ s/^[ \t]//;
    ##
    # send tokens to parser
    ##
    for($parser->YYData->{INPUT}){
        s/^([0-9]+)// and return ("NUMBER", $1);
        s/^(\+)// and return ("+", $1);
        s/^(-)// and return ("-", $1);
        s/^(\*)// and return ("*", $1);
        s/^(\/)// and return ("/", $1);
        s/^(\()// and return ("(", $1);
        s/^(\))// and return (")", $1);
        s/^(\n)// and return ("\n", $1);
    }  
}

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

sub parse{
    my($self, $input) = @_;
    $self->YYData->{INPUT} = $input;
    my $result = $self->YYParse(yylex => \&lexer, yyerror => \&error);
    return $result;  
}

Sample Run


$ yapp TWCCalculator.yp
$ perl ch-1.pl
18
-48
25
80
26
50

Notes

In a long ago (almost exactly two years!) Challenge we were asked to implement a Reverse Polish Notation (RPN) Calculator. For that challenge I wrote a short introduction to the parser module, Parse::Yapp, that I used. See the references below, I think it still holds up.

For this challenge I was able to rely pretty heavily on that older code. I simply changed the expected position of the operators and that was about it!

I really like any excuse to use a parser generator, they're a powerful tool one can have at the disposal for a fairly small investment of learning time. Well, practical usage may be quick to learn. Depending on how deep one wants to go there is the possibility also of a lifetime of study of computational linguistics.

Part 2

You are given a positive number, $n. Write a script to find out if the given number is a Stealthy Number.

Solution


use strict;
use warnings;
use boolean; 

sub factor{
    my($n) = @_;
    my @factors = ();
    for  my $j (2 .. sqrt($n)){
        push @factors, [$j, $n / $j] if $n % $j == 0;
    }
    return @factors;  
}

sub stealthy{
    my($n) = @_;
    my @factors = factor($n);
    for(my $i = 0; $i < @factors; $i++){
        for(my $j = 0; $j < @factors; $j++){
            unless($i == $j){
                my($s, $t) = @{$factors[$i]}; 
                my($u, $v) = @{$factors[$j]}; 
                return true if $s + $t == $u + $v + 1; 
            }  
        }  
    }  
    return false; 
}

MAIN:{
    print stealthy(12) . "\n";
    print stealthy(36) . "\n";
    print stealthy(6)  . "\n";
}

Sample Run


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

Notes

That factor subroutine makes another appearance! Well, here there is a slight modification to get it to return the factors in pairs, each pair an array reference. These are all checked in a loop for the desired property.

This is a classic "generate and test" approach. For an idea of what it would look like to instead constrain the variables to fit the property and then discover which values, if any, match these constraints then please do take a look at my Prolog solution for Challenge 143 which uses a Constraint Logic Programming over Finite Domains (clpfd) approach.

References

Challenge 143

Parse::Yapp

RPN Calculator for Challenge 039

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

2021-12-12

Sleeping Divisors

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given positive integers, $m and $n. Write a script to find total count of divisors of $m having last digit $n.

Solution


use strict;
use warnings;
sub factor{
    my($n) = @_;
    my @factors = (1);
    foreach  my $j (2 .. sqrt($n)){
        push @factors, $j if $n % $j == 0;
        push @factors, ($n / $j) if $n % $j == 0 && $j ** 2 != $n;
    }
    return @factors;  
}

sub divisors_last_digit{
    my($m, $n) = @_;
    my @divisors;   
    my @factors = factor($m);
    {
        my $factor = pop @factors;
        push @divisors, $factor if $n == substr($factor, -1);    
        redo  if @factors;  
    }    
    return sort {$a <=> $b} @divisors;   
}

MAIN:{
    my($m, $n); 
    my @divisors;
    ($m, $n) = (24, 2); 
    @divisors = divisors_last_digit($m, $n);
    print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";  
    ($m, $n) = (75, 5); 
    @divisors = divisors_last_digit($m, $n);
    print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";  
    ($m, $n) = (30, 5); 
    @divisors = divisors_last_digit(30, 5);
    print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";  
}

Sample Run


$ perl perl/ch-1.pl
(24, 2): 2 --> 2, 12
(75, 5): 3 --> 5, 15, 25
(30, 5): 2 --> 5, 15

Part 2

Implement Sleep Sort.

Solution


use strict;
use warnings;
use Thread::Pool;

sub create_workers{
    my @numbers = @_; 
    my $count = @numbers; 
    my $workers = new Thread::Pool({
        optimize => "cpu", 
        do => \&sleeper, 
        workers => $count,
        maxjobs => $count, 
        minjobs => $count 
    });
    return $workers;
}

sub sleeper{
    my($n) = @_; 
    sleep($n);
    return $n;   
}

sub sleep_sort{
    my($numbers, $workers) = @_; 
    my @jobs;
    my @sorted;   
    for my $n (@{$numbers}){
        my $job_id = $workers->job($n);
        push @jobs, $job_id;   
    } 
    {
        my $job = pop @jobs;     
        my @result = $workers->result_any(\$job);
        if(!@result){    
            push @jobs, $job;  
        }
        else{
            push @sorted, $result[0]; 
        }
        redo if @jobs; 
    }
    $workers->shutdown; 
    return @sorted;   
}

MAIN:{
    my @numbers;
    my @sorted; 
    @numbers = map{int(rand($_) + 1)} (0 .. 9);  
    print join(", ", @numbers) . "\n"; 
    @sorted = sleep_sort(\@numbers, create_workers(@numbers));  
    print join(", ", @sorted) . "\n"; 
}  

Sample Run


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

Notes

I hope participants in The Weekly Challenge enjoyed this! After I saw Jort Sort in Challenge 139 I was reminded of other joke sorts and suggested this as a future challenge. Happily the suggestion was accepted!

Threading is easy in Perl, which uses an "Interpreter Threads" ("ithreads") model. Node.js programmers will find this model familiar as it is exactly what that language uses. Unfortunately Perl's documentation writers are not as familiar with concurrent and parallel programming topics and some of the official documentation needs updating. Unfortunately, this is a bizarrely contentious issue.

To ensure you are using a perl interpreter with proper ithreads support try this one-liner: $ perl -Mthreads -e 0. If that runs without error you are good to go! If you get an error you'll need to install a new perl. One convenient option is to use Perlbrew. After installing perlbrew you'll need to invoke it like this perlbrew install perl-5.34.0 -Dusethreads. Please see the Perlbrew documentation for additional (straightforward) details if you decide to undertake this.

Here rather than use threads directly Thread::Pool is used. This is a convenient pattern for using Perl's ithreads. Since each ithread is really a new perl interpreter process this allows for some fine tuning of the number of ithreads created to help conserve memory usage. In this case the memory conservation is actually somewhat minimal since Sleep Sort requires us to start a new ithread for each element of the array to be sorted. Amusingly, because of the process based threading model, we can quickly crash the program by attempting to sort an array whose size causes the system to exceed the number of allowed processes. Remember, this is a joke sort, right!?!?

Typically you'd create a pool of workers whose number matched the number of CPU cores available. That way each core could be tasked by the OS for whatever CPU intensive code you'd care to run without the ithreads competing too badly with each other.

Concurrent and parallel programming issues are somewhat advanced. Excellent documentation exists that is both Perl specific and more general. Be sure to understand the difference between ithreads and so called "co-operative thread" models (as used in modules such as Coro. The "advanced" nature of this topic is due to understanding the various trade-offs at play. Deep understanding usually comes from experience of implementing solutions this way and study of the underlying Operating System concepts. Even the most modest modern computer systems systems available have multiple cores at your disposal as a programmer so this effort is certainly worthwhile! The bibliography of perlthrtut is an excellent starting point.

References

Challenge 142

Sleep Sort

perlthrtut

Thread::Pool

Node.js Workers

posted at: 13:16 by: Adam Russell | path: /perl | permanent link to this entry

2021-12-05

Like, It’s Just the First Ten Numbers Man!

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to find lowest 10 positive integers having exactly 8 divisors

Solution


use strict;
use warnings;
sub factor{
    my($n) = @_;
    my @factors = (1, $n);
    foreach my $j (2..sqrt($n)){
        push @factors, $j if $n % $j == 0;
        push @factors, ($n / $j) if $n % $j == 0 && $j ** 2 != $n;
    }    
    return @factors;  
}

sub first_ten_with_eight{
    my $i = 0;
    my @first_ten;  
    do{
        my @factors = factor($i);
        push @first_ten, $i if @factors == 8;   
        $i++; 
    }while(@first_ten != 10); 
    return @first_ten;
}

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

Sample Run


$ perl perl/ch-1.pl
24, 30, 40, 42, 54, 56, 66, 70, 78, 88

Notes

I have re-used that factor() function quite a bit for these challenges, especially recently. My blog writing has been fairly terse recently and as much as I'd like to be a bit more verbose I really am not sure if there all that much more to say about this code that hasn't been said before!

Part 2

You are given positive integers, $m and $n. Write a script to find total count of integers created using the digits of $m which is also divisible by $n.

Solution


use strict;
use warnings;
##
# You are given positive integers, $m and $n.
# Write a script to find total count of integers 
# created using the digits of $m which is also 
# divisible by $n.
##
use Data::PowerSet q/powerset/;

sub like_numbers{
    my($m, $n) = @_; 
    my @divisible; 
    for my $subset (@{powerset(split(//, $m))}){
        my $i = join("", @$subset);
        push @divisible, $i if $i && $i != $m && $i % $n == 0;
    }  
    return @divisible;
}

MAIN:{
    print like_numbers(1234, 2) . "\n";
    print like_numbers(768, 4) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
9
3

Notes

I've been making more use of Data::PowerSet recently that I would have expected! If anyone is interested in seeing an implementation of the Power Set calculations see my C++ solution links below. While not Perl the code is quite readable and should be adaptable easy to other languages. There is also a Rosetta Code entry for Power Set but, frankly, many of the submissions there, especially the C++ and Perl ones are overly convoluted in my opinion. Or at least much more so than the way I implemented it, which I would think would be the more common method but I guess not!

References

Challenge 141

Power Set Defined

Data::PowerSet

Rosetta Code Entry: Power Set

C++ Solutions: Part 1

C++ Solutions: Part 2

posted at: 16:47 by: Adam Russell | path: /perl | permanent link to this entry

2021-11-28

A Binary Addition Simulation / Nth from a Sorted Multiplication: Table The Weekly Challenge 140

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given two decimal-coded binary numbers, $a and $b. Write a script to simulate the addition of the given binary numbers.

Solution


use strict;
use warnings;
sub add_binary{
    my($x, $y) = @_;
    my $sum = ""; 
    my @a = reverse(split(//, $x));            
    my @b = reverse(split(//, $y));            
    if(@b > @a){
        my @c = @b;
        @b = @a;
        @a = @c;   
    } 
    my $carry = 0; 
    for(my $d = 0; $d <= @a - 1; $d++){ 
        my $d0 = $a[$d]; 
        my $d1 = $b[$d];
        if($d1){
            $sum = "0$sum", $carry = 0 if $d0 == 1 && $d1 == 1 && $carry == 1;  
            $sum = "1$sum", $carry = 0 if $d0 == 1 && $d1 == 0 && $carry == 0; 
            $sum = "0$sum", $carry = 1 if $d0 == 1 && $d1 == 1 && $carry == 0; 
            $sum = "0$sum", $carry = 1 if $d0 == 0 && $d1 == 1 && $carry == 1; 
            $sum = "0$sum", $carry = 0 if $d0 == 0 && $d1 == 0 && $carry == 0; 
            $sum = "1$sum", $carry = 0 if $d0 == 0 && $d1 == 0 && $carry == 1; 
            $sum = "0$sum", $carry = 1 if $d0 == 1 && $d1 == 0 && $carry == 1; 
            $sum = "1$sum", $carry = 0 if $d0 == 0 && $d1 == 1 && $carry == 0; 
        } 
        else{
            $sum = "0$sum", $carry = 1, next if $d0 == 1 && $carry == 1;  
            $sum = "1$sum", $carry = 0, next if $d0 == 0 && $carry == 1;  
            $sum = "0$sum", $carry = 0, next if $d0 == 0 && $carry == 0;  
            $sum = "1$sum", $carry = 0, next if $d0 == 1 && $carry == 0;  
        }  
    } 
    $sum = "$carry$sum" if $carry == 1;  
    return $sum; 
}

MAIN:{
    print add_binary(11, 1) . "\n"; 
    print add_binary(101, 1) . "\n"; 
    print add_binary(100, 11) . "\n"; 
}

Sample Run


$ perl perl/ch-1.pl
100
110
111

Notes

I have an unusual fondness for Perl's right hand conditional. But that is pretty obvious from the way I wrote this, right?

Part 2

You are given 3 positive integers, $i, $j and $k. Write a script to print the $kth element in the sorted multiplication table of $i and $j.

Solution


use strict;
use warnings;
sub nth_from_table{
    my($i, $j, $k) = @_;
    my @table;
    for my $x (1 .. $i){
        for my $y (1 .. $j){
            push @table, $x * $y; 
        }  
    }  
    return (sort {$a <=> $b} @table)[$k - 1];   
} 

MAIN:{
    print nth_from_table(2, 3, 4) . "\n";  
    print nth_from_table(3, 3, 6) . "\n";  
} 

Sample Run


$ perl perl/ch-2.pl 
3
4

Notes

Full Disclosure: At first I wanted to do this in some convoluted way for fun. After experimenting with, like, nested maps for a few minutes I lost all interest in "fun" and just went with a couple of for loops!

References

Challenge 140

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

2021-11-21

Jort Sort the First Five Long Primes

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given a list of numbers. Write a script to implement JortSort. It should return true/false depending if the given list of numbers are already sorted.

Solution


use strict;
use warnings;
use boolean;

sub jort_sort{
    for(my $i=0; $i < @_ - 1; $i++){
        return false if $_[$i + 1] < $_[$i];  
    }  
    return true;
}

MAIN:{
    print jort_sort(1, 2, 3, 4, 5) . "\n";
    print jort_sort(1, 3, 2, 4, 5) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
1
0

Notes

Apparently Jort Sort is a joke sort started by somebody in the JavaScript community. I didn't find it all that funny, but the code to implement it only took a quick minute.

Part 2

Write a script to generate the first 5 Long Primes.

Solution


use strict;
use warnings;
use boolean;
use LWP::UserAgent;
use constant PRIME_URL => "http://primes.utm.edu/lists/small/100000.txt";

sub get_primes{
    my @primes;  
    my $ua = new LWP::UserAgent(
        ssl_opts => {verify_hostname => 0}
    );
    my $response = $ua->get(PRIME_URL);
    my @lines = split(/\n/,$response->decoded_content);
    foreach my $line (@lines){
        my @p = split(/\s+/, $line);
        unless(@p < 10){
            push @primes, @p[1..(@p - 1)]; 
        }  
    }
    return @primes; 
}

sub 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 long_primes_five{
    my @long_primes;
    my @primes = get_primes();
    do{
        my $prime = shift @primes;    
        my $max_repetend = $prime - 1; 
        my $repeats = true if($prime != 2 && $prime != 5); 
        if($repeats){
            my $x = divide(1, $prime, [], []); 
            $x =~ m/\((\d+)\)/;
            my $repetend = $1;
            push @long_primes, [$prime, $x] if length($repetend) == $prime - 1;   
        }
    }while(@long_primes < 5);
    return @long_primes;
}

MAIN:{
    for my $p (long_primes_five()){
        print $p->[0] . "\t" . $p->[1] . "\n";
    }
}

Sample Run


$ perl perl/ch-2.pl 
7       0.(142857)
17      0.(0588235294117647)
19      0.(052631578947368421)
23      0.(0434782608695652173913)
29      0.(0344827586206896551724137931)

Notes

This second part of the challenge was much more fun! Maybe my favorite part was that it largely re-used code from challenge 106 and also Challenge 015. Here we grab a list of pre-computed primes and then check each one for the desired property. After we find five, as required, we're done.

References

Jort Sort

Long Prime

Challenge 139

posted at: 16:34 by: Adam Russell | path: /perl | permanent link to this entry

2021-10-31

Friendly Fibonacci Summands

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given 2 positive numbers, $m and $n. Write a script to find out if the given two numbers are Two Friendly.

Solution


use strict;
use warnings;
use POSIX;
use boolean;

sub euclid {
    my($a, $b) = @_;
    return ($b) ? euclid($b, $a % $b) : $a;
}

sub two_friendly{
    my($m, $n) = @_;
    my $gcd = euclid($m, $n);
    my $p = log($gcd) / log(2);
    return boolean(ceil($p) == floor($p));
}

MAIN:{
    print two_friendly(8, 24). "\n";
    print two_friendly(26, 39). "\n";
    print two_friendly(4, 10). "\n";
}

Sample Run


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

Notes

I've used this code for Euclid's GCD method before in Challenge 089. To determine if $p is an integer we check to see if the floor() and ceiling() are equal.

Part 2

You are given a positive number $n. Write a script to find how many different sequences you can create using Fibonacci numbers where the sum of unique numbers in each sequence are the same as the given number.

Solution


use strict;
use warnings;
use Data::PowerSet q/powerset/;

sub fibonacci_below_n{
    my($n, $fibonaccis) = @_;
    $fibonaccis = [1, 1] if !$fibonaccis;
    my $f = $fibonaccis->[@{$fibonaccis} - 2] + $fibonaccis->[@{$fibonaccis} - 1];
    if($f < $n){
        push @{$fibonaccis}, $f;
        fibonacci_below_n($n, $fibonaccis);
    }
    else{
        shift @{$fibonaccis};
        return $fibonaccis;
    }
}

sub fibonacci_sum{
    my($n) = @_;
    my $powerset = powerset(fibonacci_below_n($n));
    my @summands = grep {
        my $fibonaccis = $_;
        my $sum = 0;
        map{
            $sum += $_;
        } @{$fibonaccis};
        $sum == $n;
    } @{$powerset};
    return @summands;
}

MAIN:{
    for my $summands (fibonacci_sum($ARGV[0])){
        print "(" . join(" + ", @{$summands}) . ") = " . $ARGV[0] . "\n";
    }
}

Sample Run


$ perl perl/ch-2.pl 16
(3 + 13) = 16
(1 + 2 + 13) = 16
(3 + 5 + 8) = 16
(1 + 2 + 5 + 8) = 16

Notes

Instead of using a pre-computed list of Fibonacci numbers we generate them as needed. No particular reason other than it's a little more fun, and also it allows us to flexibly allow for virtually any value for $n.

The sequences are determined by examining the Power Set of all possible sequences and checking the sums.

References

Challenge 136

Power Set

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

2021-10-24

Caught in the Middle With SEDOL

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given an integer. Write a script find out the middle 3-digits of the given integer, if possible, otherwise show a sensible error message.

Solution


use strict;
use warnings;
use POSIX;
sub middle_3{
    my($i) = @_;
    $i = abs($i);
    my $length = length($i);
    return "even number of digits" if $length % 2 == 0;
    return "too short" if $length < 3;
    my $middle = ceil($length / 2);
    return substr($i, $middle - 2, 3);
}

MAIN:{
    print middle_3(1234567) . "\n";
    print middle_3(-123) . "\n";
    print middle_3(1) . "\n";
    print middle_3(10) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
345
123
too short
even number of digits

Notes

Maybe on of the more interesting things about this is just what we consider the middle 3. Truly it only makes sense for an integer with an odd number of digits. But could we have stretched the idea to allow for an even number of digits, perhaps with some left padding? Perhaps, but here we don't. So all integers with only 1 or 2 digits are discarded as are those with an even number of digits. Negative numbers are allowed, but we do not consider the minus sign in determining the middle.

Part 2

You are given 7-characters alphanumeric SEDOL. Write a script to validate the given SEDOL. Print 1 if it is a valid SEDOL otherwise 0.

Solution


use strict;
use warnings;
use boolean;

sub is_sedol{
    my($sedol) = @_;
    my $base = substr($sedol, 0, 6);
    my $check_digit = substr($sedol, 6, 1); 
    ##
    # check length
    ##
    return false if length($sedol) != 7;
    ##
    # check for alphanumerics only
    ##
    my $test_base = $base;
    $test_base =~ tr/[0-9][B-Z]//d;
    return false if $test_base;
    ##
    # confirm the check_digit
    ##
    return false if $check_digit != compute_check_digit($base);
    ##
    # all tests passed!
    ##
    return true;
}

sub compute_check_digit{
    my($base) = @_;
    my @chars = split(//, $base);
    my @weights = (1, 3, 1, 7, 3, 9),
    my $sum = 0;
    do{
        my $c = ord(shift @chars);
        if($c >= 66 && $c <= 90){
            $sum += (($c - 64 + 9) * shift @weights);
        }
        if($c >= 48 && $c <= 57){
            $sum += (($c - 48) * shift @weights);
        }
    }while(@chars);
    return (10 - ($sum % 10)) % 10
}

MAIN:{
    print is_sedol(2936921) . "\n";
    print is_sedol(1234567) . "\n";
    print is_sedol("B0YBKL9") . "\n";
}

Sample Run


1
0
1

Notes

The rules around SEDOLs are a bit more complex than this problem lets on. I won't recount them all here, but suffice to say we are dealing with a quite idealized set of validations here. For example, prior to 2004 only numerals were allowed, but since then letters are allowed. But only a numeral can follow a letter. Again, though, those are only rules that apply for a certain time range.

Here we are just checking on length, whether or not the SEDOl contains all numerals and/or (uppercase) letter, and the checksum validation.

References

Challenge 135

Stock Exchange Daily Official List (SEDOL)

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

2021-10-17

A Couple of Brute Force Computations

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to generate first 5 Pandigital Numbers in base 10.

Solution


use strict;
use warnings;
##
# Write a script to generate first 5 Pandigital Numbers in base 10.
##
use boolean;

sub first_n_pandigitals {
    my ($n)         = @_;
    my $found       = false;
    my $pandigitals = [];
    my $x           = 1_000_000_000;
    do {
        my $test = $x;
        push @{$pandigitals}, $x
          if ( $test =~ tr/0//d ) > 0
          && ( $test =~ tr/1//d ) > 0
          && ( $test =~ tr/2//d ) > 0
          && ( $test =~ tr/3//d ) > 0
          && ( $test =~ tr/4//d ) > 0
          && ( $test =~ tr/5//d ) > 0
          && ( $test =~ tr/6//d ) > 0
          && ( $test =~ tr/7//d ) > 0
          && ( $test =~ tr/8//d ) > 0
          && ( $test =~ tr/9//d ) > 0;
        $found = ( @{$pandigitals} == $n );
        $x++;
    } while ( !$found );
    return $pandigitals;
}

sub first_5_pandigitals {
    return first_n_pandigitals(5);
}
MAIN: {
    my $pandigitals = first_5_pandigitals;
    for my $x ( @{$pandigitals} ) {
        print "$x\n";
    }
}

Sample Run


$ perl perl/ch-1.pl
1023456789
1023456798
1023456879
1023456897
1023456978

Notes

From the definition we know that we will need at least 10 digits and, intuitively, the first five pandigital numbers will start with 1. So then, we start with 1_000_000_000 and iterate upwards testing each candidate until we find the first five. The test used here is to determine if tr finds all the required digits.

Part 2

You are given 2 positive numbers, $m and $n. Write a script to generate multiplication table and display count of distinct terms.

Solution


use strict;
use warnings;
##
# You are given 2 positive numbers, $m and $n.
# Write a script to generate multiplcation table and display count of distinct terms.
##
sub compute_print {
    my ( $m, $n ) = @_;
    my $distinct = {};
    print " x | " . join( " ", ( 1 .. $n ) ) . "\n";
    print "---+-" . "-" x ( $n * 2 - 1 ) . "\n";
    for my $i ( 1 .. $m ) {
        print " $i | " . join( " ", map { $i * $_ } ( 1 .. $n ) ) . "\n";
        for my $j ( 1 .. $n ) {
            $distinct->{ $i * $j } = undef;
        }
    }
    return $distinct;
}
MAIN: {
    my $distinct = compute_print( 3, 3 );
    print "Distinct Terms: "
      . join( ", ", sort { $a <=> $b } keys %{$distinct} ) . "\n";
    print "Count: " . keys( %{$distinct} ) . "\n";
    print "\n\n";
    $distinct = compute_print( 3, 5 );
    print "Distinct Terms: "
      . join( ", ", sort { $a <=> $b } keys %{$distinct} ) . "\n";
    print "Count: " . keys( %{$distinct} ) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
 x | 1 2 3
---+------
 1 | 1 2 3
 2 | 2 4 6
 3 | 3 6 9
Distinct Terms: 1, 2, 3, 4, 6, 9
Count: 6


 x | 1 2 3 4 5
---+----------
 1 | 1 2 3 4 5
 2 | 2 4 6 8 10
 3 | 3 6 9 12 15
Distinct Terms: 1, 2, 3, 4, 5, 6, 8, 9, 10, 12, 15
Count: 11

Notes

This is a perfectly Perl shaped problem. The computations can be handled in a straightforward way, especially with map. Getting rid of duplicates is done using the idiomatic method with hash keys. Finally, formatting the output cleanly is done without much undo stress. Compare what we do here to format the table with what was necessary to represent the same table in Prolog.

References

Challenge 134

Pandigital Numbers

posted at: 13:03 by: Adam Russell | path: /perl | permanent link to this entry

2021-09-19

These Binary Trees are Odd

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given an array of positive integers, such that all the numbers appear even number of times except one number. Write a script to find that integer.

Solution


use strict;
use warnings;
sub find_odd_occurring{
    my %counts;
    for my $x (@_){
        $counts{$x}++;
    }
    for my $x (keys %counts){
        return $x if $counts{$x} % 2 != 0;
    }
}

MAIN:{
    print find_odd_occurring(2, 5, 4, 4, 5, 5, 2) . "\n";
    print find_odd_occurring(1, 2, 3, 4, 3, 2, 1, 4, 4) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
5
4

Notes

I spent some time thinking if this could be done without two passes over the numbers. I do not think that is possible, since we have no limits on the off or even occurrences. For example, we could short circuit the checking if we knew that there might on be, say, three occurrences of the odd number. But here we have no such limitations and so we must tally all numbers in the list and then check to see which has an odd number of occurrences.

Part 2

You are given a tree. Write a script to find out if the given tree is Binary Search Tree (BST).

Solution


use strict;
use warnings;
package Tree130{
    use boolean;      
    use Class::Struct; 

    use constant LEFT => 0;
    use constant RIGHT => 1;

    package Node{
        use boolean;  
        use Class::Struct; 
        struct(
            value => q/$/,
            left => q/Node/,
            right => q/Node/
        );  
        true; 
    }  

    struct(
        root => q/Node/,
        nodes => q/@/
    );   

    sub print_tree{ 
        my($self) = @_;   
        my $left_child = $self->root()->left();
        my $right_child = $self->root()->right();
        print $self->root()->value() . " -> " . $left_child->value() . "\n" if $left_child;
        print $self->root()->value() . " -> " . $right_child->value() . "\n" if $right_child;
        print_tree_r($left_child);
        print_tree_r($right_child);
    }  

    sub print_tree_r{ 
        my($node) = @_;   
        my $left_child = $node->left();
        my $right_child = $node->right();
        print $node->value() . " -> " . $left_child->value() . "\n" if $left_child;
        print $node->value() . " -> " . $right_child->value() . "\n" if $right_child;
        print_tree_r($left_child) if $left_child;
        print_tree_r($right_child) if $right_child;
    } 

    sub min_tree_value{
        my($node) = @_; 
        my $left_child = $node->left();
        my $right_child = $node->right();
        return $node->value() if !$left_child && !$right_child;
        return [sort {$a <=> $b} ($node->value(), min_tree_value($left_child), min_tree_value($right_child))]->[0];
    }

    sub max_tree_value{
        my($node) = @_;   
        my $left_child = $node->left();
        my $right_child = $node->right();
        return $node->value() if !$left_child && !$right_child;
        return [sort {$a <=> $b} ($node->value(), max_tree_value($left_child), max_tree_value($right_child))]->[2];
    }

    sub is_bst{
        my($self, $node) = @_;
        return true if !$node;
        my $left_child = $node->left();
        my $right_child = $node->right();
        return false if $left_child && $node->value < max_tree_value($left_child);    
        return false if $right_child && $node->value > min_tree_value($right_child);   
        return false if !$self->is_bst($left_child) || !$self->is_bst($right_child);
        return true;    
    }

    sub insert{
        my($self, $source, $target, $left_right) = @_;   
        if(!$self->root()){      
            $self->root(new Node(value => $source));   
            push @{$self->nodes()},  $self->root();      
        }   
        my $source_node = [grep {$_->value() == $source} @{$self->nodes()}]->[0];
        my $target_node = new Node(value => $target);
        if($source_node){
            $source_node->left($target_node) if $left_right == LEFT;
            $source_node->right($target_node) if $left_right == RIGHT;
            push @{$self->nodes()}, $target_node;
        }
    }  
    true; 
}

package main{
    use constant LEFT => 0;
    use constant RIGHT => 1;

    my $tree = new Tree130(); 
    $tree->insert(8, 5, LEFT); 
    $tree->insert(8, 9, RIGHT); 
    $tree->insert(5, 4, LEFT); 
    $tree->insert(5, 6, RIGHT); 
    print $tree->is_bst($tree->root()) . "\n";
    $tree = new Tree130(); 
    $tree->insert(5, 4, LEFT); 
    $tree->insert(5, 7, RIGHT); 
    $tree->insert(4, 3, LEFT); 
    $tree->insert(4, 6, RIGHT); 
    print $tree->is_bst($tree->root()) . "\n";
} 

Sample Run


$ perl perl/ch-2.pl
1
0

Notes

All my code, for the time being at least, has converged on a pretty standard approach using Class::Struct. I have done this enough recently where I've convinced myself this is the best for several reasons

The first issue to deal with this part of the challenge is to construct a Binary Tree, but not do any sort of balancing when performing insertions into the tree. To do this I made a simple insert function which takes a source and target node and a third parameter which dictates whether the target is to be the left or right child of the source. In this way we can easily construct a broken binary tree.

Actually verifying whether the tree is a proper BST follows fairly directly from the definition of a Binary Tree. For each node, including the root, we check to see if the largest value to the left is smaller as well as the minimum value to the right being larger.

References

Challenge 130

Class::Struct

Binary Trees

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

2021-09-12

Two Exercises in Fundamental Data Structures

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given a tree and a node of the given tree. Write a script to find out the distance of the given node from the root.

Solution


use strict;
use warnings;
package Tree129{
    use boolean;  
    use Tie::RefHash;
    use Class::Struct; 

    package Node{
        use boolean;  
        use Class::Struct; 
        struct(
            value => q/$/,
        );  
        true; 
    }  

    package Edge{
        use boolean;  
        use Class::Struct; 
        struct(
            weight => q/$/,
            source => q/Node/,
            target => q/Node/
        );  
        true; 
    }  

    struct(
        root => q/Node/,
        edges => q/%/
    );   

    sub print_tree{ 
        my($self) = @_;   
        for my $edge_source (keys %{$self->edges()}){
            for my $target (@{$self->edges()->{$edge_source}}){
                print $edge_source->value() . "->" . $target->value() . "\n";
            }
        }
    }  

    sub distance{
        my($self, $target) = @_;
        my $distance = 0;
        return $distance if($self->root()->value() == $target);
        my @nodes = @{$self->edges()->{$self->root()}};
        my @edge_sources = keys %{$self->edges()};
        do{
            $distance++;
            return $distance if((grep {$_->value() == $target} @nodes) > 0);
            my @child_nodes;
            for my $node (@nodes){
                my @k = grep {$_->value() == $node->value()} @edge_sources;
                push @child_nodes, @{$self->edges()->{$k[0]}} if $k[0] && $self->edges()->{$k[0]};
            }
            @nodes = @child_nodes;
        }while(@nodes);
        return -1;
    }

    sub insert{
        my($self, $source, $target) = @_;   
        if(!$self->root()){      
            $self->root(new Node(value => $source));  
            tie %{$self->edges()}, "Tie::RefHash";
            $self->edges($self->root() => [new Node(value => $target)]);          
        }   
        else{
            my $found = false;
            for my $edge_source (keys %{$self->edges()}){
                if($edge_source->value() == $source){
                    push @{$self->edges()->{$edge_source}}, new Node(value => $target);
                    $found = true;
                }
            }
            if(!$found){
                $self->edges()->{new Node(value => $source)} = [new Node(value => $target)];
            }
        }
    }  
    true; 
}

package main{
    my $tree = new Tree129(); 
    $tree->insert(1, 2); 
    $tree->insert(1, 3); 
    $tree->insert(3, 4); 
    $tree->insert(4, 5); 
    $tree->insert(4, 6); 
    print $tree->distance(6) . "\n";
    print $tree->distance(5) . "\n";
    print $tree->distance(2) . "\n";
    print $tree->distance(4) . "\n";
} 

Sample Run


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

Notes

In the past, for this sort of problem, I would separate out the Tree package into its own file . Here I decided to keep everything in one file, but still divide everything into the proper packages.

While creating a Tree package from scratch was fun, getting that data structure correct is just half the battle. Still need to solve the problem! To that end we need to start at the root of the tree and then descend and count how many levels down the node is found, if it exists. If not return -1.

One issue is that to store the edges I use a hash with Nodes as keys. To use a Node instance as a key we need to use Tie::RefHash. There is a slight trick here though, to properly retrieve the value we need to access the keys using keys. Here I store the keys in an array and grep for a match. A slightly awkward requirement, but the work around is easy enough.

Part 2

You are given two linked list having single digit positive numbers. Write a script to add the two linked list and create a new linked representing the sum of the two linked list numbers. The two linked lists may or may not have the same number of elements.

Solution


use strict;
use warnings;
package LinkedList129{
    use boolean;
    use Class::Struct;

    package Node{
        use boolean;
        use Class::Struct;
        struct(
            value => q/$/,
            previous => q/Node/,
            next => q/Node/
        );
        true;
    }

    struct(
        head => q/Node/,
        tail => q/Node/,
        length => q/$/
    );

    sub stringify{
        my($self) = @_;
        my $s = $self->head()->value();
        my $next = $self->head()->next();
        while($next && $next->next()){
            $s .= " -> " if $s; 
            $s = $s . $next->value();
            $next = $next->next();
        }
        $s = $s . " -> " . $next->value() if $next->value();
        $s .= "\n"; 
        return $s;
    }

    sub stringify_reverse{
        my($self) = @_;
        my $s = $self->tail()->value();
        my $previous = $self->tail()->previous();
        while($previous && $previous->previous()){
            $s .= " -> " if $s; 
            $s = $s . $previous->value();
            $previous = $previous->previous();
        }
        $s = $s . " -> " . $self->head()->value();
        $s .= "\n"; 
        return $s;
    }

    sub insert{
        my($self, $value) = @_;
        if(!$self->head()){
            $self->head(new Node(value => $value, previous => undef, next => undef));
            $self->tail($self->head());
            $self->length(1);
        }
        else{
            my $current = $self->head();
            my $inserted = false;
            do{
                if(!$current->next()){
                    $current->next(new Node(value => $value, previous => $current, next => undef));
                    $inserted = true; 
                }
                $current = $current->next();
            }while(!$inserted);
            $self->tail($current);
            $self->length($self->length() + 1);
        }
        return $value;
    }

    sub add{
        my($self, $list) = @_;
        my $shortest = [sort {$a <=> $b} ($self->length(), $list->length())]->[0];
        my($x, $y) = ($self->tail(), $list->tail());
        my $sum = new LinkedList129();
        my $carry = 0;
        do{
            my $z;
            if($x && $x->value() && $y && $y->value()){
                $z = $x->value() + $y->value() + $carry;
                ($x, $y) = ($x->previous(), $y->previous());
            }
            elsif($x && $x->value() && !$y){
                $z = $x->value() + $carry;
                ($x, $y) = ($x->previous(), undef);
            }
            elsif(!$x->value() && $y->value()){
                $z = $y->value() + $carry;
                ($x, $y) = (undef, $y->previous());
            }
            if(length($z) == 2){
                $carry = 1;
                $sum->insert(int(substr($z, 1, 1)));
            }
            else{
                $carry = 0;
                $sum->insert($z);
            }

        }while($x || $y);
        return $sum;
    }
    true;
}

package main{
    my $l0 = new LinkedList129();
    $l0->insert(1);
    $l0->insert(2);
    $l0->insert(3);
    $l0->insert(4);
    $l0->insert(5);
    my $l1 = new LinkedList129();
    $l1->insert(6);
    $l1->insert(5);
    $l1->insert(5);
    my $sum = $l0->add($l1);
    print "    " . $l0->stringify();
    print "+\n";
    print "              " . $l1->stringify();
    print "---" x ($l0->length() * 2) . "\n";  
    print "    " . $sum->stringify_reverse();
}

Sample Run


$ perl perl/ch-2.pl
    1 -> 2 -> 3 -> 4 -> 5
+
              6 -> 5 -> 5
------------------------------
    1 -> 3 -> 0 -> 0 -> 0

Notes

My opinion on LinkedList problems may not be shared by the majority of Team PWC. I love Linked List problems!

Similar to the first part of Challenge 129 Class::Struct is used to create the data structure central tot he problem. This LinkedList implementation just has an insert() and two stringify functions, along with the required add().

The problem asks to sum two linked lists of single digit numbers. The add() function works in the same way that one would manually add the numbers. The sum of the two lists is represented as a new Linked List, but to represent it properly it is output in reverse. That should be fine for the purposes of this challenge. Other options are:

References

Challenge 129

Class::Struct

Tie::RefHash

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

2021-09-05

A Platform for Every Departing Sub-Matrix

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given m x n binary matrix having 0 or 1. Write a script to find out maximum sub-matrix having only 0.

Solution


use strict;
use warnings;
use Tree::Suffix; 

sub maximum_sub_matrix{
    my @matrix = @_;
    my @sub_matrix;

    my %indices;  
    my @indices_maximum;
    my $indices_previous = "";
    my $indices_current = "";
    my $tree = new Tree::Suffix(); 
    for my $i (0 .. @matrix - 1){
        $indices_current = "";
        for my $j (0 .. @{$matrix[0]} - 1){
            $indices_current .= $j if $matrix[$i][$j] == 0;  
            $indices_current .= "x" if $matrix[$i][$j] == 1;  
        }
        $tree->insert($indices_current);  
        for my $n (2 .. @{$matrix[0]}){
            for my $s ($tree->longest_common_substrings(1, $n)){
                if(!$indices{$s}){
                    $indices{$s} = [$i - 1, $i];  
                }
                else{ 
                    push @{$indices{$s}}, $i - 1, $i; 
                } 
            }
        }
        $tree->remove($indices_previous) if $indices_previous; 
        $indices_previous = $indices_current; 
    } 
    for my $s (keys %indices){
        my $max_area = -1; 
        my @indices = sort {$a <=> $b} do {my %seen; grep { !$seen{$_}++} @{$indices{$s}}};  
        unless($indices[0] < 0){
            my $area = 0;
            my $count = 0; 
            for(my $i = 0; $i <=  @indices - 1; $i++){ 
                $count++; 
                $area += length($s) if $i == 0;
                $area += length($s) if $i > 0 && $indices[$i] == $indices[$i - 1] + 1;   
                do{$area = 0; $count = 0} if $i > 0 && $indices[$i] != $indices[$i - 1] + 1;  
            }
            if($area >= $max_area){
                $max_area = $area; 
                push @indices_maximum, [$s, $count];      
            } 
        } 
    } 
    for (0 .. $indices_maximum[0][1] - 1){
        push @sub_matrix, [(0) x length($indices_maximum[0][0])];  
    }  
    return @sub_matrix; 
}

MAIN:{
    my @sub_matrix = maximum_sub_matrix(
        [1, 0, 0, 0, 1, 0],
        [1, 1, 0, 0, 0, 1],
        [1, 0, 0, 0, 0, 0]
    );
    for my $row (@sub_matrix){
        print "[" . join(" ", @{$row}) . "]\n"; 
    }  
} 

Sample Run


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

Notes

At first this seemed like a very similar Dynamic Programming style approach like the one used in Challenge 117 would be suitable. The idea being to start with the top row and the track in a hash all the different possible submatrices that arise as we work downwards in the matrix. While this is definitely a DP problem tracking the possible submatrices in this way is completely inefficient! Unlike the problem of Challenge 117 in which the possible paths descending the triangle are all completely known and predictable, here a lot of extra work needs to be done.

In order to determine overlap between the zeroes in successive rows of the matrix the rows are converted to strings and then the common substrings are computed using Tree::Suffix. Because we are looking for any possible overlap we need to repeat the common substring search for different lengths. The process to do this is a bit cumbersome, but it does work! So, at least the solution I had in mind ended up working but it's all so convoluted. Clearly more elegant solutions exist. One positive feature here though is that multiple maximum sized submatrices can be identified. In the example output you can see that two solutions exist, both with an "area" of six. Here which one gets shown is just based on the random ordering of the keys in %indices, but determining all solutions could be easily done. Since this was not part of the original challenge it was left undone.

Part 2

You are given a list of intervals. Write a script to determine conflicts between the intervals.

Solution


use strict;
use warnings;
use Date::Parse;
use Heap::MinMax;

sub number_platforms{
    my($arrivals, $departures) = @_;
    my $platforms = 0; 
    my $heap = new Heap::MinMax();
    $heap->insert(str2time(shift @{$departures}));  
    for my $i (0 .. @{$departures}){
        $platforms++ if str2time($arrivals->[$i]) < $heap->min();  
        $heap->pop_min() if str2time($arrivals->[$i]) >= $heap->min();  
        $heap->insert(str2time($departures->[$i]));  
    }    
    return $platforms; 
}

MAIN:{
    print number_platforms(
        ["11:20", "14:30"],
        ["11:50", "15:00"]
    ) . "\n"; 
    print number_platforms(
        ["10:20", "11:00", "11:10", "12:20", "16:20", "19:00"],
        ["10:30", "13:20", "12:40", "12:50", "20:20", "21:20"],
    ) . "\n"; 
}

Sample Run


$ perl perl/ch-2.pl
1
3

Notes

First, all times have to be converted to something numeric and so Date::Parse's str2time is used to convert the times to Unix epoch timestamps.

Heaps are not usually something I commonly use, even for these challenge problems they never seem to be convenient. Here though is a pretty standard use of a Heap! Here the use of a Heap allows for easy access to the next departure time. If a train arrives before the next departure, increase the number of platforms.

References

Challenge 128

Date::Parse

Heap::MinMax

Tree::Suffix

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

2021-08-29

Conflicting Lists and Intervals

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given two sets with unique numbers. Write a script to figure out if they are disjoint.

Solution


use strict;
use warnings;
use boolean;

sub disjoint{
    my($list1, $list2) = @_;
    my @a = map { my $n = $_; grep  $n == $_ , @{$list2} }  @{$list1};
    return boolean(@a == 0);#boolean() used for better stringification
}

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

Sample Run


$ perl perl/ch-1.pl
0
1

Notes

I cannot think of a way of determining conflicts between these two lists which is all that more efficient than comparing them in this way. Sorting helps a little in some cases but if the overlapping element(s) are at the end of the sorted list you need to traverse the entire list anyway. Sorting would help the average case and since we need only find one overlapping element and then stop looking this would have some noticeable effect in the case of very large lists. But then I'd have to write a for-loop in order to break out of the loop early and instead I wanted to experiment with this grep inside a map construct! This worked without too much hassle, the only consideration really being to assign map's list value alias $_ to a variable so as to not conflict with grep's $_.

The use of boolean() is just to make sure that a 1 or 0 is printed as the final result.

Part 2

You are given a list of intervals. Write a script to determine conflicts between the intervals.

Solution


use strict;
use warnings;
sub conflicts{
    my @intervals = @_;
    my @conflicts;
    @intervals = sort { $a->[1] <=> $b->[1] } @intervals;
    {
        my $interval = pop @intervals;
        my($i, $j) = @{$interval};
        for $interval (@intervals){
            my($m, $n) = @{$interval};
            do { unshift @conflicts, [$i, $j]; last } if $i >= $m && $i <= $n;
        }
        redo if @intervals;
    }
    return @conflicts;
}

MAIN:{
    my(@Intervals);
    @Intervals = ([1, 4], [3, 5], [6, 8], [12, 13], [3, 20]);
    map { print "[" . join(", ", @{$_}) . "] " } conflicts(@Intervals);
    print "\n";
    @Intervals = ([3, 4], [5, 7], [6, 9], [10, 12], [13, 15]);
    map { print "[" . join(", ", @{$_}) . "] " } conflicts(@Intervals);
    print "\n";
}

Sample Run


$ perl perl/ch-2.pl
[3, 5] [3, 20]
[6, 9]

Notes

The examples given in the problem statement are with the [minimum, maximum] intervals sorted by the maximum value. This makes the problem a bit easier since then we need only check to see, when working down the sorted list, if the minimum is in one of the other intervals.

Since it isn't totally clear if this is something that should be assumed for all inputs I added a sort in conflicts() to ensure this is the case.

References

Challenge 127

C++ solution for Part 1

C++ solution for Part 2

Disjoint Sets

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

2021-08-22

Count Numbers / MineSweeper game: The Weekly Challenge 126

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 print count of numbers from 1 to $N that don’t contain digit 1.

Solution


use strict;
use warnings;
sub has_1{
    my($x) = @_;
    return 1 if $x =~ tr/1//d > 0;
    return 0;   
}

sub count_with_1{
    my($n) = @_;
    my $x = 1;  
    my $count = 0; 
    {
        $count += has_1($x); 
        $x += 1;
        redo if $x <= $n; 
    }
    return $count; 
}

sub count_without_1{
    my($n) = @_;
    return $n - count_with_1($n);  
}

MAIN:{
    my $N;
    $N = 15;
    print count_without_1($N) . "\n"; 
    $N = 25;
    print count_without_1($N) . "\n"; 
}  

Sample Run


$ perl perl/ch-1.pl
8
13

Notes

Given the flexibility and richness of Perl there were many choices of how to determine the presence of a '1'. I decided to use tr which will helpfully return the number of changes made. In this case, what is returned is the number of 1's deleted. If this number is greater than zero then we know a 1 was found.

Part 2

You are given a rectangle with points marked with either x or *. Please consider the x as a land mine. Write a script to print a rectangle with numbers and x as in the Minesweeper game.

Solution


use strict;
use warnings;
sub initialize_grid{
    my($m, $n) = @_;
    my @grid; 
    for my $i (0 .. $m - 1){
        for my $j (0 .. $n - 1){
            $grid[$i][$j] = "*";   
            $grid[$i][$j] = "x" if rand() <= (1 / 3);   
        }  
    }  
    return @grid; 
}

sub make_grid{
    my($m, $n) = @_;
    my @initial_grid = initialize_grid($m, $n);  
    my @grid = map {[@$_]} @initial_grid; 
    for my $i (0 .. $m - 1){ 
        for my $j (0 .. $n - 1){
            unless($grid[$i][$j] eq "x"){
                my $mine_count = 0;
                $mine_count++ if $i >= 1 && $j >= 1 && $grid[$i - 1][$j - 1] eq "x"; 
                $mine_count++ if $i >= 1 && $grid[$i - 1][$j] eq "x"; 
                $mine_count++ if $i >=1 && $j < $n - 1 && $grid[$i - 1][$j + 1] eq "x"; 
                $mine_count++ if $j >= 1 && $grid[$i][$j - 1] eq "x"; 
                $mine_count++ if $j < $n - 1 && $grid[$i][$j + 1] eq "x"; 
                $mine_count++ if $i < $m - 1 && $j >= 1 && $grid[$i + 1][$j - 1] eq "x"; 
                $mine_count++ if $i < $m - 1 && $grid[$i + 1][$j] eq "x" ; 
                $mine_count++ if $i < $m - 1 && $j < $n - 1 && $grid[$i + 1][$j + 1] eq "x"; 
                $grid[$i][$j] = $mine_count; 
            } 
        }  
    } 
    return (\@initial_grid, \@grid); 
}  

sub print_grid{
    my @grid = @_; 
    for my $row (@grid){
        print "\t" . join(" ", @{$row}) . "\n"  
    } 
} 

MAIN:{
    my($m, $n) = @ARGV;
    my($initial_grid, $grid) = make_grid($m, $n);  
    print "Input:\n"; 
    print_grid(@{$initial_grid});      
    print "Output:\n"; 
    print_grid(@{$grid});      
}

Sample Run


$ perl perl/ch-2.pl 5 10
Input:
        x x * * * * x * * x
        * * x * x x x * x *
        * * * * * * * * * *
        x * x x * * * * * x
        * * x * x * * * x *
Output:
        x x 2 2 2 4 x 3 2 x
        2 3 x 2 x x x 3 x 2
        1 3 3 4 3 3 2 2 2 2
        x 3 x x 2 1 0 1 2 x
        1 3 x 4 x 1 0 1 x 2

Notes

References

Challenge 126

C++ solution for Part 1

C++ solution for Part 2

History of Minesweeper

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

2021-08-01

Ugly Numbers / Square Points

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given an integer $n >= 1. Write a script to find the $nth Ugly Number.

Solution


use strict;
use warnings;
use boolean;

sub prime_factor{
    my $x = shift(@_); 
    my @factors;    
    for (my $y = 2; $y <= $x; $y++){
        next if $x % $y;
        $x /= $y;
        push @factors, $y;
        redo;
    }
    return @factors;  
}

sub is_ugly{
    my($x) = @_; 
    for my $factor (prime_factor($x)){
        return false if $factor != 2 && $factor != 3 && $factor !=5; 
    }
    return true; 
}

sub nth_ugly{
    my($n) = @_;  
    return 1 if $n == 1; 
    my $ugly_count = 1; 
    my $i = 1;  
    do{
        $i++;
        $ugly_count++ if is_ugly($i);   
    }while($ugly_count != $n);
    return $i;    
} 

MAIN:{
    my($N);
    $N = 7; 
    print nth_ugly($N) . "\n"; 
    $N = 10; 
    print nth_ugly($N) . "\n"; 
}   

Sample Run


$ perl perl/ch-1.pl
8
12

Notes

I also worked this problem in Prolog and C++ and, unsurprisingly, the Perl code is the shortest. All three solutions followed the same approach but Perl's syntax is naturally less verbose without making comprehension of the code more difficult.

Part 2

You are given co-ordinates for four points. Write a script to find out if the given four points form a square.

Solution


use strict;
use warnings;
use boolean;  
use Math::GSL::Vector;

sub unique{
    my %seen;
    return grep {!$seen{$_}++} @_;
} 

sub is_square{
    my @points = @_;
    ##
    # Definitely a square if there are only 2 x and 2 y values. 
    ##
    my @x = unique(map {$_->[0]} @points);  
    my @y = unique(map {$_->[1]} @points);  
    return true if @x == 2 && @y == 2;
    ##
    # sort the points and compute side lengths  
    ##  
    my @sorted_x = sort {$a->[0] <=> $b->[0]} @points;  
    my @sorted_y = sort {$a->[1] <=> $b->[1]} @points;  
    my($s, $t, $u, $v) = ($sorted_y[@sorted_y - 1], $sorted_x[@sorted_x - 1], $sorted_y[0], $sorted_x[0]);    
    return false if $s->[0] + $u->[0] != $t->[0] + $v->[0];  
    return false if $s->[1] + $u->[1] != $t->[1] + $v->[1];  
    return false if $s->[1] - $u->[1] != $t->[0] - $v->[0];  
    ##
    # compute angles 
    ##
    my $dv_st = new Math::GSL::Vector([$s->[0] - $t->[0], $s->[1] - $t->[1]]); 
    my $dv_tu = new Math::GSL::Vector([$t->[0] - $u->[0], $t->[1] - $u->[1]]); 
    my $dv_uv = new Math::GSL::Vector([$u->[0] - $v->[0], $u->[1] - $v->[1]]); 
    my $dv_vs = new Math::GSL::Vector([$v->[0] - $s->[0], $v->[1] - $s->[1]]); 
    return false if $dv_st * $dv_tu != 0;
    return false if $dv_tu * $dv_uv != 0;
    return false if $dv_uv * $dv_vs != 0;
    return true;  
}



MAIN:{
    my @points;
    @points = ([10, 20], [20, 20], [20, 10], [10, 10]);  
    print is_square(@points) . "\n";  
    @points = ([12, 24], [16, 10], [20, 12], [18, 16]);  
    print is_square(@points) . "\n";  
    @points = ([-3, 1], [4, 2], [9, -3], [2, -4]);  
    print is_square(@points) . "\n";  
    @points = ([0, 0], [2, 1], [3, -1], [1, -2]);  
    print is_square(@points) . "\n";  
}

Sample Run


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

Notes

The logic of determining if the points determine a square is clear to most people familiar with geometry:

The code in is_square() works through that logic with multiple exit points set up along the way. Perhaps this is a bit odd looking but I have been doing a lot of logic programming in Prolog recently and thought to give a somewhat more logical style to this perl solution to this problem. Developing a more logical style for Perl is a bit of a work in progress for me, I will admit!

The unique function (and it's clever use of grep!) was taken from a PerlMaven article.

References

Challenge 123

C++ solution for Part 1

C++ solution for Part 2

Rhombus

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

2021-07-25

Average of Stream / Basketball Points

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given a stream of numbers, @N. Write a script to print the average of the stream at every point.

Solution


use strict;
use warnings;
sub moving_average{
    my $n = 0;
    my $sum = 0;
    {
        $n += 1;
        $sum += shift;
        print $sum / $n;
        print ", " if @_;
        redo if @_;
    }
    print "\n";
}


MAIN:{
    my @N;
    for(my $i = 10; $i < 1_000_000; $i += 10){
        push @N, $i;
    }
    moving_average(@N);
}

Sample Run


$ perl perl/ch-1.pl
10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95, 

Notes

Typically when one thinks of a stream the idea is of a virtually endless source of data. Or, at least, data which is handled as if this were the case. Here the "stream" is simulated by a long (one million items) array.

The computation of the average as the simulated stream is evaluated is done using a redo loop. I would think it is fair to say that typically my code is somewhat verbose. I prefer to be fairly explicit in that way to enhance readability. Here, however, I try to be more terse. The "stream" is evaluated by shifting values off the array passed to the function. The array argument is also used to determine if the block should be repeated, and also to format the output.

Part 2

You are given a score $S. You can win basketball points e.g. 1 point, 2 points and 3 points. Write a script to find out the different ways you can score $S.

Solution


use strict;
use warnings;
sub basketball_points{
    my($total) = @_;
    my %points;
    my @valid_points;
    $points{"1"} = "1";
    $points{"2"} = "2";
    $points{"3"} = "3";
    while((keys %points) > 0){
        my %updated_points = ();
        for my $points (keys %points){
            my @points = split(/,/, $points);
            for my $point (1 .. 3){
                my $point_sum = unpack("%32I*", pack("I*",  (@points, $point)));
                push @valid_points, [@points, $point] if $point_sum == $total;
                $updated_points{join(",", (@points, $point))} = $point_sum if $point_sum < $total;
            }
        }
        %points = %updated_points;
    }
    return @valid_points;
}

MAIN:{
    my $S;
    $S = 4;
    print "\$S = $S\n";
    my @point_combinations = basketball_points($S);
    for my $points (basketball_points($S)){
        print join(" ", @{$points}) . "\n";
    }
    $S = 5;
    print "\n\$S = $S\n";
    @point_combinations = basketball_points($S);
    for my $points (basketball_points($S)){
        print join(" ", @{$points}) . "\n";
    }
}

Sample Run


$ perl perl/ch-2.pl
$S = 4
1 3
2 2
3 1
1 2 1
1 1 2
2 1 1
1 1 1 1

$S = 5
3 2
2 3
3 1 1
2 1 2
1 3 1
2 2 1
1 2 2
1 1 3
1 2 1 1
1 1 1 2
1 1 2 1
2 1 1 1
1 1 1 1 1

Notes

The approach here borrows heavily from the solution to the triangle problem from Challenge 117. This is a dynamic programming style solution which builds and updates lists of potential point sequences. Uniqueness is guaranteed by saving the lists as hash keys, in a command separated values string format.

References

Challenge 122

Dynamic Programming

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

2021-07-18

A Genetic Algorithm solution to the Travelling Salesman Problem

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given integers 0 <= $m <= 255 and 1 <= $n <= 8. Write a script to invert $n bit from the end of the binary representation of $m and print the decimal representation of the new binary number.

Solution


use strict;
use warnings;
sub flip_bit_n{
    my($x, $n) = @_;
    my $bits = substr(unpack("B32", pack("N", $x)), 24, 8);
    my @bits = split(//, $bits);
    $bits[@bits - $n] ^= 1;
    my $flipped_decimal = unpack("N", pack("B32", substr("0" x 32 . join("", @bits), -32)));
    return $flipped_decimal;
}

MAIN:{
    my($M, $N);
    $M = 12;
    $N = 3;
    print flip_bit_n($M, $N) . "\n";
    $M = 18;
    $N = 4;
    print flip_bit_n($M, $N) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
8 
26

Notes

This code re-uses much of the code from last week's challenge solution. The only difference is that this week we flip the specified nth bit using the XOR operator. I think that this may be the first time I have ever used a ^= operation!

Part 2

You are given a NxN matrix containing the distances between N cities. Write a script to find a round trip of minimum length visiting all N cities exactly once and returning to the start.

Solution


use strict;
use warnings;
use boolean;
use AI::Genetic;

use constant N => 7;

my @matrix= ([0, 5, 2, 7],
             [5, 0, 5, 3],
             [3, 1, 0, 6],
             [4, 5, 4, 0]);

sub fitness{
    my($genes) = @_;
    my $cost = 0;
    return -1 if $genes->[0] != $genes->[@{$genes} - 1];
    my @path = sort {$a <=> $b} @{$genes}[0 .. @{$genes} - 2];
    for my $i (0 .. (@path - 2)){
        return -1 if $path[$i] == $path[$i + 1];
    }
    for my $i (0 .. @{$genes} - 2){
        $cost += $matrix[$genes->[$i]][$genes->[$i + 1]];
    }
    return 1/$cost;
}

sub terminate{
    return true;
}

MAIN:{
    srand(121);
    my $aig = new AI::Genetic(
        -fitness    => \&fitness,
        -type       => "rangevector",
        -population => 500,
        -crossover  => 0.9,
        -mutation   => 0.1,
    );
    my $genes = [];
    for (0 .. N + 1){
        push @{$genes}, [0, N];
    }
    @matrix = ();
    for (0 .. N){
        my $row = [];
        for my $i (0 .. N){
            push @{$row}, int(rand(N * 2 + 1));
        }
        push @matrix, $row;
    }
    $aig->init(
        $genes
    );
    $aig->evolve("tournamentUniform", 100000);
    my $path = $aig->getFittest()->genes();
    print join(",", @{$path}) . "\n";
    my $cost;
    for my $i (0 .. @{$path} - 2){
        $cost += $matrix[$path->[$i]][$path->[$i + 1]];
    }
    print "cost: $cost\n";
}

Sample Run


$ perl perl/ch-2.pl
3,0,1,2,3
cost: 10
$ perl perl/ch-2.pl
3,1,7,5,4,6,0,2,3
cost: 24

Notes

I have used Genetic Algorithm (GA) approaches to a bunch of these challenge problems in the past. I will admit that in some cases the GA approach is more for fun than as a good example of the sorts of problems GA is good for. This time, however, we have a somewhat classic use case!

The Travelling Salesman Problem is well known to be NP-Hard and Genetic Algorithms are a well studied approach to tackling these beasts.

I first tested this solution with the example in the original problem statement, hardcoded here in @matrix and obtained a result which matched the known correct one. Then, testing with increasingly larger values of N to generate random matrices I continued to get seemingly correct results. I did not verify these by hand. Instead I set a random seed with srand and verified that I got the same cost results over several runs. As needed I would adjust the number of generations in the evolve() method call upwards until again getting results which converged on the same cost value.

For a 20 x 20 matrix I seem to be getting correct results, but runtimes are quite lengthy and I ran out of time to test this further. However, I am very confident that a correct path is obtainable this way although perhaps some additional slight adjustment of parameters is necessary.

(Hopefully nobody is too terribly confused by this, but please do notice that the size of the matrix is actually N + 1. That is, in order to obtain a matrix like the one given in the problem statement you specify an N of 3, although obviously this is a 4 x 4 matrix. This is just in keeping with the city labels starting with 0.)

References

Challenge 121

posted at: 23:36 by: Adam Russell | path: /perl | permanent link to this entry

2021-07-11

Swapping Bits / Time Angle

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 less than or equal to 255. Write a script to swap the odd positioned bits with the even positioned bits and print the decimal equivalent of the new binary representation.

Solution


use strict;
use warnings;
sub swap_bits{
    my($n) = @_;
    my $bits = substr(unpack("B32", pack("N", shift)), 24, 8);
    my @bits = split(//, $bits);
    for(my $i = 0; $i < @bits; $i += 2){
        @bits[$i, $i + 1] = @bits[$i + 1, $i]; 
    }  
    my $swapped_decimal = unpack("N", pack("B32", substr("0" x 32 . join("", @bits), -32)));
    return $swapped_decimal; 
}

MAIN:{
    my $N;
    $N = 101; 
    print swap_bits($N) . "\n";
    $N = 18; 
    print swap_bits($N) . "\n";
}   

Sample Run


$ perl perl/ch-1.pl
154
33

Notes

This code re-uses much of the code from last week's challenge solution. The only difference here is the for loop which swaps the even/odd bits.

Part 2

You are given time $T in the format hh:mm. Write a script to find the smaller angle formed by the hands of an analog clock at a given time.

Solution


use strict;
use warnings;
sub clock_angle{
    my($h, $m) = split(/:/, $_[0]);
    my $angle = abs(0.5 * (60 * $h - 11 * $m)); 
    $angle = 360 - $angle if $angle > 180; 
    return $angle;
}

MAIN:{
    my $T;
    $T = "03:10";  
    print clock_angle($T) . "\n";  
    $T = "04:00";  
    print clock_angle($T) . "\n";  
}

Sample Run


$ perl perl/ch-1.pl
35
120

Notes

Perhaps not a whole lot going on here: the time is broken into hour and minute parts and then the angle is computed directly from those values.

References

Challenge 120

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

2021-07-04

Packing and Unpacking from vacation: The Weekly Challenge 119

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 swap the two nibbles of the binary representation of the given number and print the decimal number of the new binary representation.

Solution


use strict;
use warnings;
sub swap_nibbles{
    my($n) = @_;
    my $bits = substr(unpack("B32", pack("N", shift)), 24, 8);
    my $swapped_bits = substr($bits, 4) . substr($bits, 0, 4);
    my $swapped_decimal = unpack("N", pack("B32", substr("0" x 32 . $swapped_bits, -32)));
    print $swapped_decimal . "\n";
}

MAIN:{
    swap_nibbles(101);
    swap_nibbles(18);
}

Sample Run


$ perl perl/ch-1.pl
86
33

Notes

I was on vacation recently and did not have time for the last couple of Weekly Challenges, but as I posted a meme about it is hard to take a break!

(The Perl Programmers Facebook group is a lof of fun. It is kept Private by the group owner but joining is easy, anyone is allowed provided they are interested in Perl.)

I was able to get through the first part of this week's challenge with the time I had after getting back from vacation. As I was unpacking my suitcase, co-incidentally enough, I noticed that the first task is a great use of pack and unpack!

I have used these functions several times in the past, for example this writeup from Challenge 020 has an example and some links to others. I must admit that from the earliest days of my Perl experience I have been fascinated by pack! At first it seemed like a bit of black magic and due to its versatility, in some ways it still retains this mystique.

In the swap_nibbles function the number is packed into Network Byte Order and that representation is that unpacked bitwise to get the expected binary representation. After that the two nibbles are swapped using substr to get each 4 bit slice. The process is then reversed on the swapped bits to get the result we want.

References

Challenge 119

Network Byte Order

Perl Programmers Facebook Group

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

2021-06-20

A List with One Missing Line and Too Many Lines to List: The Weekly Challenge 117

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

Part 1

You are given text file with rows numbered 1-15 in random order but there is a catch one row in missing in the file.

Solution


use strict;
use warnings;
sub find_missing{
    my(@numbers) = sort {$a <=> $b} @_;
    for(my $i=0; $i< @numbers - 1; $i++){
        return $numbers[$i] + 1 if $numbers[$i] != $numbers[$i + 1] - 1;   
    }  
}

MAIN:{
    my @line_numbers; 
    while(){
        chomp;
        m/([0-9]+),.*/;
        push @line_numbers, $1;
    }
    my $missing = find_missing(@line_numbers);
    print "$missing\n"; 
}

__DATA__
11, Line Eleven
1, Line one
9, Line Nine
13, Line Thirteen
2, Line two
6, Line Six
8, Line Eight
10, Line Ten
7, Line Seven
4, Line Four
14, Line Fourteen
3, Line three
15, Line Fifteen
5, Line Five

Sample Run


$ perl perl/ch-1.pl
12

Notes

My approach here is likely the most common one for this problem I would think. We get a list of all the numbers and then iterate through the list to determine which one is missing. This code assumes the conditions of the problem hold, that there is always one missing number.

Part 2

You are given size of a triangle. Write a script to find all possible paths from top to the bottom right corner. In each step, we can either move horizontally to the right (H), or move downwards to the left (L) or right (R).

Solution


use strict;
use warnings;
use constant FINAL => "end"; 
use constant DEADEND => "-1"; 
use constant TRIANGLE_TOP => q|/\\| ;
use constant TRIANGLE_BOTTOM => q|/__\\|;

sub find_paths{
    my($n) = @_;
    my %paths;
    my @complete_paths;
    my @vertices; 
    for my $i (0 .. $n){
        for my $j (0 .. $i){
            push @vertices, "$i-$j";
        }
    }
    $paths{""}=["0-0",["0-0"]];    
    my %updated_paths;
    while((keys %paths) > 0){
        %updated_paths = ();
        for my $path (keys %paths){
            my @exists;
            my @visited; 
            my $current = $paths{$path}->[0];  
            my $visited = $paths{$path}->[1];
            my @ij = split(/\-/, $current);  
            my($left, $horizontal, $right) = (($ij[0] + 1) . "-" . $ij[1], $ij[0] . "-" . ($ij[1] + 1), ($ij[0] + 1) . "-" . ($ij[1] + 1));
            @exists = grep {$_ eq $left} @vertices;
            @visited = grep {$_ eq $left} @{$visited};
            if(@exists && !@visited){
               my $visited_left = [@{$visited}, $left];
               if($left eq "$n-$n"){
                   push @complete_paths, $path . "L"; 
               }
               else{
                   $updated_paths{$path . "L"} = [$left, $visited_left];     
               }
            }          
            @exists = grep {$_ eq $horizontal} @vertices;
            @visited = grep {$_ eq $horizontal} @{$visited};
            if(@exists && !@visited){
               my $visited_horizontal = [@{$visited}, $horizontal];
               if($horizontal eq "$n-$n"){
                   push @complete_paths, $path . "H"; 
               }
               else{
                   $updated_paths{$path . "H"} = [$horizontal, $visited_horizontal];     
               }
            }           
            @exists = grep {$_ eq $right} @vertices;
            @visited = grep {$_ eq $right} @{$visited};
            if(@exists && !@visited){
               my $visited_right = [@{$visited}, $right];
               if($right eq "$n-$n"){
                   push @complete_paths, $path . "R"; 
               }
               else{
                   $updated_paths{$path . "R"} = [$right, $visited_right];     
               }
            }           
        }  
        %paths = %updated_paths;  
    }   
    return @complete_paths; 
}

sub print_triangle{
    my($n) = @_;
    my $top = TRIANGLE_TOP . "  ";
    for my $i (1 .. $n ){
        print " ";
        print "  " x ($n - $i);
        print $top x $i  ;
        print "\n";
        print "  " x ($n - $i );
        print TRIANGLE_BOTTOM x ($i );
        print "\n";
    }
}

MAIN:{
    my($N);
    $N = 1;
    print_triangle($N);
    for my $path (find_paths($N)){
        print "$path ";
    } 
    print "\n"; 
    $N = 2;
    print_triangle($N);
    for my $path (find_paths($N)){
        print "$path ";
    } 
    print "\n"; 
    $N = 3;
    print_triangle($N);
    for my $path (find_paths($N)){
        print "$path ";
    } 
    print "\n"; 
    $N = 4;
    print_triangle($N);
    for my $path (find_paths($N)){
        print "$path ";
    } 
    print "\n"; 
}

Sample Run


$ perl perl/ch-2.pl
 /\  
/__\
R LH 
   /\  
  /__\
 /\  /\  
/__\/__\
RR LRH RLH LHR LLHH LHLH 
     /\  
    /__\
   /\  /\  
  /__\/__\
 /\  /\  /\  
/__\/__\/__\
RRR LHRR RLHR LRRH RRLH RLRH LRHR LLHRH LLRHH RLHLH LHRLH RLLHH LHLRH LLHHR LHLHR LRLHH LRHLH LHLHLH LHLLHH LLHLHH LLLHHH LLHHLH 
       /\  
      /__\
     /\  /\  
    /__\/__\
   /\  /\  /\  
  /__\/__\/__\
 /\  /\  /\  /\  
/__\/__\/__\/__\
RRRR LRRHR LRHRR RRLHR LRRRH RRLRH RLRRH RLHRR RLRHR LHRRR RRRLH LHRRLH RLRHLH RLHLRH RLHLHR LLRHRH RLLRHH RLLHRH LHLRRH LLRRHH LRRLHH LRHRLH RLLHHR LHLRHR LHLHRR LLRHHR RRLLHH LRLHHR RLHRLH RLRLHH LHRLRH LRLRHH LHRLHR LRLHRH LRHLHR LLHRRH LRRHLH LLHHRR RRLHLH LLHRHR LRHLRH LLHRHLH LLLHHHR LLHHRLH LRLLHHH LLLRHHH LRHLHLH LLLHRHH RLHLLHH LLHLHHR LHRLHLH LHLHLHR LLRHLHH LHLLHRH LRLHHLH LLHLRHH RLLHLHH LLHHLRH LHLRLHH LHLHRLH LLRHHLH LRLHLHH LHLRHLH RLLHHLH LLLHHRH LHRLLHH LLHHLHR LRHLLHH LHLLHHR RLHLHLH LHLHLRH LLHRLHH LHLLRHH LLRLHHH RLLLHHH LLHLHRH LLHHLHLH LLLHHLHH LHLLHHLH LHLLLHHH LHLHLLHH LLHLHLHH LLLLHHHH LLHLHHLH LHLHLHLH LLHLLHHH LLLHHHLH LHLLHLHH LLHHLLHH LLLHLHHH 

Notes

Here we see a great example of combinatorial explosion! As the triangle size grows the number of possible pathways increases extremely quickly. The number of possible paths when $N = 10 is 1,037,718. My code finds all of those in about 40 seconds when run on a 2019 MacBook Pro. Performance on more modest hardware is still reasonable.

When $N = 20 the complete number of paths is so large that maintaining a list of paths in memory will cause the Perl interpreter to run out of memory and crash. It is simply not possible to list them all!

Interestingly it turns out that the original author of the challenge thought simply counting the paths would be sufficient, but the problem was edited to instead list the paths. I have to say that listing them all, along with my own optional variation of drawing the triangles was fun. The only downside was a bit of initial surprise, and then realization, about just how large the number of paths grows.

It turns out that this task is a slightly disguised description of what is known as a Quantum Pascal's Triangle. The possible number of paths, the count that is, can be obtained directly from a closed form approach. No need to actually traverse the paths!

What I did here was to effectively do a breadth first traversal.

References

Challenge 117

Quantum Pascal's Triangle

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

2021-06-13

Evolving a Sequence with a Functional Genome: The Weekly Challenge 116

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

Part 1

You are given a number $N >= 10. Write a script to split the given number such that the difference between two consecutive numbers is always 1, and it shouldn't have a leading 0. Print the given number if it impossible to split the number.

Solution


use strict;
use warnings;
use boolean;
use AI::Genetic;

use constant THRESHOLD => 0;
use constant NUMBERS   => "1234";

sub no_op{
    my($x) = @_;
    return (caller(0))[3] if !defined($x);
    return $x;
}

sub get_1{
    my($s) = @_;
    return (caller(0))[3] if !defined($s);
    return substr($s, 0, 1);
}

sub get_2{
    my($s) = @_;
    return (caller(0))[3] if !defined($s);
    return substr($s, 0, 2);
}

sub get_3{
    my($s) = @_;
    return (caller(0))[3] if !defined($s);
    return substr($s, 0, 3);
}

sub get_4{
    my($s) = @_;
    return (caller(0))[3] if !defined($s);
    return substr($s, 0, 4);
}

sub fitness{
    my($genes) = @_;
    my $s = NUMBERS;
    my $fitness = -1 * (length($s) -1);
    my @operands;
    for my $gene (@{$genes}){
        if(my($i) = $gene->() =~ m/get_([1-4])/){
            push @operands, $gene->($s);
            return -1 * NUMBERS if length($s) < $i;
            $s = substr($s, $i) if length($s) >= $i;
        }
    }
    $s = NUMBERS;
    for(my $i = 0; $i < @operands - 1; $i++){
        if($operands[$i] == ($operands[$i + 1] - 1)){
            $fitness++;
            my $chars = length($operands[$i]);
            $s = substr($s, $chars);
        }
    }
    if($operands[@operands - 1] && $operands[@operands - 2]){
    if($operands[@operands - 1] == ($operands[@operands - 2] + 1)){
        my $chars = length($operands[@operands - 1]);
        $s = substr($s, $chars);
    }
    }
    $fitness *= length($s);
    return $fitness;
}

sub terminate{
    my($aig) = @_;
    my $top_individual = $aig->getFittest();
    if($top_individual->score == THRESHOLD){
        my $genes = $top_individual->genes();
        my $s = NUMBERS;
        my @operands;
        for my $gene (@{$genes}){
            if(my($i) = $gene->() =~ m/get_([1-4])/){
                push @operands, $gene->($s);
                $s = substr($s, $i);
            }
        }
        print join(",", @operands) . "\n";
        return true;
    }
    print NUMBERS . "\n";
    return true;
}

MAIN:{
    my $aig = new AI::Genetic(
        -fitness    => \&fitness,
        -type       => "listvector",
        -population => 50000,
        -crossover  => 0.9,
        -mutation   => 0.1,
        -terminate  => \&terminate,
    );
    my $genes = [];
    for (0 .. 7){
        push @{$genes}, [\&get_1, \&get_2, \&get_3, \&get_4, \&no_op],
    }
    $aig->init(
        $genes
    );
    $aig->evolve("tournamentUniform", 1000);
}

Sample Run


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

Notes

Task #1 is slightly similar to the Only 100, please task from Challenge 044. In that previous task we are given a string of numbers and asked to split the string with only + or - operations to arrive at a value of 100. Here we must similarly split the string of numbers, but the criteria is different. Here we need to assemble the string into numbers that differ only by 1, if possible.

As done in that previous challenge we use a not so brutish, yet forceful, approach using AI::Genetic. In this way our program learns the best way to achieve our goal given a fitness function which allows it to evaluate different splitting patterns and smartly choose the next attempt.

While avoiding evaluating a great many possible combinations, I must admit to a certain brutishness here in that I did not spend much time tuning the parameters used. Also, the get_ functions will not scale very well for very long strings. It would be possible to generate these functions in a loop using a functional programming style currying approach dependent on the length of the input string. Imagine an input of 1 followed by 999 0s, then a 1 followed by 998 0s and final 1. This use of AI::Genetic would certainly work with such an input given proper get_ functions, very many of which would be quickly be lost in the evolutionary dust, so to speak.

The use of function references for the genes is not something I am aware of outside of my own usage. I like to call this a Functional Genome.

Part 2

You are given a number $N >= 10. Write a script to find out if the given number $N is such that sum of squares of all digits is a perfect square. Print 1 if it is otherwise 0.

Solution


use strict;
use warnings;
use POSIX;

sub sum_squares{
    my($n) = @_;
    my @digits = split(//, $n);
    my $sum = 0;
    map { $sum += ($_ ** 2) } @digits;
    return (ceil(sqrt($sum)) == floor(sqrt($sum)));
}

MAIN:{
    my($N);
    $N = 34;
    if(sum_squares($N)){
        print "1\n";
    }
    else{
        print "0\n";
    }
    $N = 50;
    if(sum_squares($N)){
        print "1\n";
    }
    else{
        print "0\n";
    }
    $N = 52;
    if(sum_squares($N)){
        print "1\n";
    }
    else{
        print "0\n";
    }
}

Sample Run


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

Notes

This task is well suited for Perl. We can make quick work of what might be a heavier lift in other languages by split-ting the number into individual digits and then using a map to perform the summing of the squares. The POSIX module provides convenient ceil and floor functions for checking to see if the result is a perfect square.

References

Challenge 116

Challenge 044 | Only 100, please

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

2021-06-05

The Weekly Challenge 115

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

Part 1

You are given an array of strings. Write a script to find out if the given strings can be chained to form a circle. Print 1 if found otherwise 0. A string $S can be put before another string $T in circle if the last character of $S is same as first character of $T.

Solution


use strict;
use warnings;
use Graph;
use Graph::Easy::Parser;

sub build_graph{
    my @words;
    my %first_letter_name;
    my $graph = new Graph();
    while(my $s = ){
        chomp($s);
        my $first_letter = substr($s, 0, 1);
        if($first_letter_name{$first_letter}){
            push @{$first_letter_name{$first_letter}}, $s;
        }
        else{
            $first_letter_name{$first_letter} = [$s];
        }
        push @words, $s;
    }
    for my $word (@words){
        $graph->add_vertex($word) if !$graph->has_vertex($word);
        my $child_nodes = $first_letter_name{substr($word, -1)};
        for my $n (@{$child_nodes}){
            $graph->add_vertex($n) if !$graph->has_vertex($n);
            $graph->add_weighted_edge($word, $n, (-1 * length($n))) if !$graph->has_edge($word, $n);
            $graph->delete_edge($word, $n) if $graph->has_a_cycle();
        }
    }
    return $graph;
}

sub display_graph{
    my($graph) = @_;
    my $s = $graph->stringify();
    my @s = split(/,/, $s);
    my @lines;
    for my $n (@s){
        my @a = split(/-/, $n);
        push @lines, "[ $a[0] ] => [ ]" if @a == 1;
        push @lines, "[ $a[0] ] => [ $a[1] ]" if @a > 1;
    }
    my $parser = new Graph::Easy::Parser();
    my $graph_viz = $parser->from_text(join("", @lines));
    print $graph_viz->as_ascii();
}

MAIN:{
    my $graph = build_graph();
    my @cc = $graph->weakly_connected_components();
    print "1\n" if @cc == 1;
    print "0\n" if @cc != 1;
    display_graph($graph);
}

__DATA__
ab
bea
cd

Sample Run


$ perl perl/ch-1.pl
0
+----+     +-----+
| ab | ==> | bea |
+----+     +-----+
+----+
| cd | ==>
+----+
$ perl perl/ch-1.pl
1
+-----+     +-----+     +----+
| dea | ==> | abc | ==> | cd |
+-----+     +-----+     +----+

Notes

Task #1 is very similar to the Pokemon Name Ladder task from Challenge 025. This task is actually a part of that previous challenge in that here we do not need to compute the longest possible chain of strings; we just need to confirm that the chain exists.

The approach here is:

The function used to determine the number of connected components is weakly_connected_components(). This is because the chain is constructed as a directed graph and the idea of a connected component is defined for undirected graphs. Weakly connected components are determined by whether or not the nodes are connected if we ignore the direction of the edges. This is what we want for our use case here, as opposed to strongly connected components. To determine strongly connected components we would need bi-directional edges for each link in the chain. No need to overcomplicate this with extra edges...the desired result is obtained just fine as is!

In the example output the first run shows two connected components, therefor no chain exists. In the second output the chain is shown, there is one connected component.

Part 2

You are given a list of positive integers (0-9), single digit. Write a script to find the largest multiple of 2 that can be formed from the list.

Solution


use strict;
use warnings;
sub largest_multiple_2{
    my @numbers = @_;
    return unless grep { $_ % 2 == 0 } @numbers;
    my @sorted = sort {$b <=> $a} @numbers;
    if(@sorted >= 2){
        my $ultima = @sorted[@sorted - 1];
        if($ultima % 2 != 0){
            my $swap_index = -1;
            for(my $i = @sorted - 2; $i >= 0; $i--){
                $swap_index = $i if $sorted[$i] % 2 == 0;
                last if $swap_index > 0;
            }
            $sorted[@sorted - 1] = $sorted[$swap_index];
            $sorted[$swap_index] = $ultima;
        }
    }
    return join("", @sorted);
}

MAIN:{
    my @N;
    @N = (1, 0, 2, 6);
    print largest_multiple_2(@N) . "\n";
    @N = (1, 4, 2, 8);
    print largest_multiple_2(@N) . "\n";
    @N = (4, 1, 7, 6);
    print largest_multiple_2(@N) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
6210
8412
7614

Notes

Suppose we did not have the "multiple of 2" restriction and instead had to arrange a list of numbers to have maximal value when concatenated together. The solution, then, would be to sort the numbers in descending order and concatenate the digits in this sorted order.

Here we can still use that same logic but more care is needed.

First, let's remind ourselves that we can check to see if any number is a multiple of 2 by checking if it's rightmost digit is a multiple of 2 (including 0).

References

Challenge 115

Pokemon Name Ladder

Weakly Connected Component

posted at: 23:34 by: Adam Russell | path: /perl | permanent link to this entry