RabbitFarm
2022-01-16
Primes and Pentagonals
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate first 20 left-truncatable prime numbers in base 10.
Solution
use strict;
use warnings;
use boolean;
use constant N => 10_000;
sub sieve_atkin{
my($n) = @_;
my @primes = (2, 3, 5);
my $upper_bound = int($n * log($n) + $n * log(log($n)));
my @atkin = (false) x $upper_bound;
my @sieve = (1, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 49, 53, 59);
for my $x (1 .. sqrt($upper_bound)){
for(my $y = 1; $y <= sqrt($upper_bound); $y+=2){
my $m = (4 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (1, 13, 17, 29, 37, 41, 49, 53) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 1; $x <= sqrt($upper_bound); $x += 2){
for(my $y = 2; $y <= sqrt($upper_bound); $y += 2){
my $m = (3 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (7, 19, 31, 43) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 2; $x <= sqrt($upper_bound); $x++){
for(my $y = $x - 1; $y >= 1; $y -= 2){
my $m = (3 * $x ** 2) - ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (11, 23, 47, 59) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
my @m;
for my $w (0 .. ($upper_bound / 60)){
for my $s (@sieve){
push @m, 60 * $w + $s;
}
}
for my $m (@m){
last if $upper_bound < ($m ** 2);
my $mm = $m ** 2;
if($atkin[$m]){
for my $m2 (@m){
my $c = $mm * $m2;
last if $c > $upper_bound;
$atkin[$c] = false;
}
}
}
map{ push @primes, $_ if $atkin[$_] } 0 .. @atkin - 1;
return @primes;
}
sub truncatable{
my($prime, $primes) = @_;
return false if $prime =~ m/0/;
my @truncatable = map { my $p = substr($prime, -1 * $_, $_); grep {$p == $_} @{$primes}} 1 .. length($prime);
return @truncatable == length($prime);
}
sub first_n_truncatable_primes{
my($n) = @_;
my @primes = sieve_atkin(N);
my @truncatable;
for my $prime (@primes){
push @truncatable, $prime if truncatable($prime, \@primes);
last if @truncatable == $n;
}
return @truncatable;
}
MAIN:{
print join(", ", first_n_truncatable_primes(20)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
2, 3, 5, 7, 13, 17, 23, 37, 43, 47, 53, 67, 73, 83, 97, 113, 137, 167, 173, 197
Notes
First off, I am re-using the Sieve of Atkin code I wrote for a previous challenge. These challenges somewhat frequently have a prime number component so, if I get a chance, I'll compose that code into it's own module. If it weren't for the copy/paste of the Sieve of Atkin code then this solution would be very short! This sort of string manipulation is where Perl excels and the determination of whether a number is left truncatable takes only a few lines.
Part 2
Write a script to find the first pair of Pentagon Numbers whose sum and difference are also a Pentagon Number.
Solution
use strict;
use warnings;
use constant N => 10_000;
sub n_pentagon_numbers{
my($n) = @_;
my @pentagon_numbers;
my $x = 1;
my %h;
do{
my $pentagon = $x * (3 * $x - 1) / 2;
push @pentagon_numbers, $pentagon;
$h{"$pentagon"} = $x;
$x++;
}while(@pentagon_numbers < $n);
return (\@pentagon_numbers, \%h);
}
sub pairs_pentagon{
my($n) = @_;
my($pentagons, $lookup) = n_pentagon_numbers(N);
my @pairs;
for my $x (0 .. @{$pentagons} - 1){
for my $y (0 .. @{$pentagons} - 1){
unless($x == $y){
my($sum, $difference) = ($pentagons->[$x] + $pentagons->[$y], abs($pentagons->[$x] - $pentagons->[$y]));
if($lookup->{$sum} && $lookup->{$difference}){
my($s, $t) = ($x + 1, $y + 1);
push @pairs, ["P($s)", "P($t)"]
}
}
last if @pairs == $n;
}
last if @pairs == $n;
}
return @pairs;
}
sub first_pair_pentagon{
return [pairs_pentagon(1)];
}
MAIN:{
print join(", ", @{first_pair_pentagon()->[0]}) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
P(1020), P(2167)
Notes
This second part of the challenge proceeds in mostly the same way as the first. We generate a large list of candidates and then search for those exhibiting the property in question. It is somewhat unexpected that the first pair of Pentagonal Numbers that have this property are so deeply located. Many times in these challenges the solution is emitted without quite as much searching!
References
posted at: 13:29 by: Adam Russell | path: /perl | permanent link to this entry
2022-01-09
Sieve of Atkin / Curious Fraction Tree
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the 10001st prime number.
Solution
use strict;
use warnings;
use boolean;
use Getopt::Long;
use LWP::UserAgent;
use constant N => 10_001;
use constant PRIME_URL => "http://primes.utm.edu/lists/small/100000.txt";
sub get_primes{
my @primes;
my $ua = new LWP::UserAgent(
ssl_opts => {verify_hostname => 0}
);
my $response = $ua->get(PRIME_URL);
my @lines = split(/\n/,$response->decoded_content);
foreach my $line (@lines){
my @p = split(/\s+/, $line);
unless(@p < 10){
push @primes, @p[1..(@p - 1)];
}
}
return @primes;
}
sub sieve_atkin{
my($n) = @_;
my @primes = (2, 3, 5);
my $upper_bound = int($n * log($n) + $n * log(log($n)));
my @atkin = (false) x $upper_bound;
my @sieve = (1, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 49, 53, 59);
for my $x (1 .. sqrt($upper_bound)){
for(my $y = 1; $y <= sqrt($upper_bound); $y+=2){
my $m = (4 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (1, 13, 17, 29, 37, 41, 49, 53) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 1; $x <= sqrt($upper_bound); $x += 2){
for(my $y = 2; $y <= sqrt($upper_bound); $y += 2){
my $m = (3 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (7, 19, 31, 43) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 2; $x <= sqrt($upper_bound); $x++){
for(my $y = $x - 1; $y >= 1; $y -= 2){
my $m = (3 * $x ** 2) - ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (11, 23, 47, 59) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
my @m;
for my $w (0 .. ($upper_bound / 60)){
for my $s (@sieve){
push @m, 60 * $w + $s;
}
}
for my $m (@m){
last if $upper_bound < ($m ** 2);
my $mm = $m ** 2;
if($atkin[$m]){
for my $m2 (@m){
my $c = $mm * $m2;
last if $c > $upper_bound;
$atkin[$c] = false;
}
}
}
map{ push @primes, $_ if $atkin[$_] } 0 .. @atkin - 1;
return @primes;
}
sub get_nth_prime{
my($n, $generate) = @_;
my @primes;
unless($generate){
@primes = get_primes;
}
else{
@primes = sieve_atkin($n);
}
return $primes[$n - 1];
}
MAIN:{
my $n = N;
my $generate = false;
GetOptions("n=i" => \$n, generate => \$generate);
print get_nth_prime($n, $generate) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
104743
$ perl perl/ch-1.pl --generate
104743
$ perl perl/ch-1.pl --generate
104743
$ perl perl/ch-1.pl --generate --n 101
547
$ perl perl/ch-1.pl --generate --n 11
31
$ perl perl/ch-1.pl --n 10001
104743
$ perl perl/ch-1.pl --n 11
31
Notes
I've mentioned it before, but for anything that asks for or needs prime numbers I always ust grab them from one of several convenient online sources, rather than generate them myself.
This time around I figured it'd be sporting to generate them myself, but maybe in an interesting way. Here I implement a sieve method for determining prime numbers. This Sieve of Atkin_ has a claim to fame of being the most performant among prime number generating sieve techniques. The code is a bit convoluted looking, I will admit, but is a faithful Perl representation of the algorithm (follow the reference link for pseudocode). Also, rather than try and explain the algorithm myself anyone interested can find full in depth treatments elsewhere. A background in number theory helps for some of the details.
Since I have some existing code for getting the pre-computed primes I figured I would use that as a check and extra feature. Command line options allow for the default behavior (fetch pre-computed primes for an N of 10,001) to be overridden.
Part 2
Given a fraction return the parent and grandparent of the fraction from the Curious Fraction Tree.
Solution
use strict;
use warnings;
use Graph;
use constant ROOT => "1/1";
use constant SEPARATOR => "/";
sub initialize{
my($member) = @_;
my $graph = new Graph();
$graph->add_vertex(ROOT);
my @next = (ROOT);
my @changes = ([0, 1], [1, 0]);
my $level = 0;
{
my @temp_next;
my @temp_changes;
do{
$level++;
my $next = shift @next;
my($top, $bottom) = split(/\//, $next);
my $change_left = shift @changes;
my $change_right = shift @changes;
my $v_left = ($top + $change_left->[0]) . SEPARATOR . ($bottom + $change_left->[1]);
my $v_right = ($top + $change_right->[0]) . SEPARATOR . ($bottom + $change_right->[1]);
$graph->add_edge($next, $v_left);
$graph->add_edge($next, $v_right);
push @temp_next, $v_left, $v_right;
push @temp_changes, $change_left;
push @temp_changes, [$level + 1, 0], [0, $level + 1];
push @temp_changes, $change_right;
}while(@next && !$graph->has_vertex($member));
@next = @temp_next;
@changes = @temp_changes;
redo if !$graph->has_vertex($member);
}
return $graph;
}
sub curious_fraction_tree{
my($member) = @_;
my $graph = initialize($member);
my($parent) = $graph->predecessors($member);
my($grandparent) = $graph->predecessors($parent);
return ($parent, $grandparent);
}
MAIN:{
my($member, $parent, $grandparent);
$member = "3/5";
($parent, $grandparent) = curious_fraction_tree($member);
print "member = '$member'\n";
print "parent = '$parent' and grandparent = '$grandparent'\n";
print "\n";
$member = "4/3";
($parent, $grandparent) = curious_fraction_tree($member);
print "member = '$member'\n";
print "parent = '$parent' and grandparent = '$grandparent'\n";
}
Sample Run
$ perl perl/ch-2.pl
member = '3/5'
parent = '3/2' and grandparent = '1/2'
member = '4/3'
parent = '1/3' and grandparent = '1/2'
Notes
My thought process on this problem started somewhat backwards. After reading the problem
statement I thought of the Graph module and remembered that it defines a function
predecessors() which would be very useful for this. After convincing myself to
use Graph; I then probably spent the majority of the time for this just getting my
head around how to define new vertices at each level of the tree. Like all trees there is
some recursiveness to the structure, but an iterative implementation still looks clean as
well.
Once the graph is constructed the solution as required comes from calling predecessors()
to get the parent and grandparent vertices.
References
posted at: 17:32 by: Adam Russell | path: /perl | permanent link to this entry
2021-12-26
A Stocking Full of Numbers: Semiprimes and the Ulam Sequence
Merry Christmas and Happy New Year! May 2022 bring you less COVID and more Perl projects!
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate all Semiprime numbers <= 100.
Solution
use strict;
use warnings;
use boolean;
use LWP::UserAgent;
use constant N => 100;
use constant PRIME_URL => "http://primes.utm.edu/lists/small/100000.txt";
sub get_primes{
my @primes;
my $ua = new LWP::UserAgent(
ssl_opts => {verify_hostname => 0}
);
my $response = $ua->get(PRIME_URL);
my @lines = split(/\n/,$response->decoded_content);
foreach my $line (@lines){
my @p = split(/\s+/, $line);
unless(@p < 10){
push @primes, @p[1..(@p - 1)];
}
}
return @primes;
}
sub factor{
my($n) = @_;
my @factors = ();
for my $j (2 .. sqrt($n)){
if($j**2 == $n){
push @factors, [$j, $j] if $j**2 == $n;
next;
}
push @factors, [$j, $n / $j] if $n % $j == 0;
}
return @factors;
}
sub semiprime{
my($n, $primes) = @_;
my @factors = factor($n);
return false if @factors != 1;
my @prime_factors = grep {$factors[0]->[0] == $_ || $factors[0]->[1] == $_} @{$primes};
return true if @prime_factors == 2 || $prime_factors[0]**2 == $n;
return false;
}
sub semiprime_n{
my @primes = get_primes;
for my $n (1 .. N){
print "$n " if semiprime($n, \@primes);
}
print "\n";
}
MAIN:{
semiprime_n;
}
Sample Run
$ perl ch-1.pl
4 6 9 10 14 15 21 22 25 26 33 34 35 38 39 46 49 51 55 57 58 62 65 69 74 77 82 85 86 87 91 93 94 95
Notes
I am sticking to the convention that I started a while back to not re-compute prime numbers myself, but instead just grab them from one of several convenient online sources. The URL in the code above requires only a small amount of effort to scrape and parse. I hope nobody minds the little bit of extra traffic to their site!
Please do check out their main page listed below. It's a fun resource with interesting facts and news on prime numbers and related research.
Once the list of the first 100k primes is obtained (that's more than enough for any of these challenges) we proceed to factor and test candidate numbers. Provided the number has only two factors (which may be equal) and both of them are prime then it passes the semiprime test.
Part 2
You are given two positive numbers, $u and $v. Write a script to generate Ulam Sequence having at least 10 Ulam numbers where $u and $v are the first 2 Ulam numbers.
Solution
use strict;
use warnings;
use constant ULAM_LIMIT => 10;
sub ulam{
my($u, $v) = @_;
my %pairs;
my @ulam = ($u, $v);
my $w = $u + $v;
push @ulam, $w;
$pairs{"$u,$v"} = $w;
$pairs{"$u,$w"} = $u + $w;
$pairs{"$v,$w"} = $v + $w;
do{
my @sums = sort {$a <=> $b} grep{my $sum = $_; my @values = grep{$sum == $_} values %pairs; $sum if @values == 1 && $sum > $ulam[@ulam - 1]} values %pairs;
my $u = $sums[0];
push @ulam, $u;
for my $pair (keys %pairs){
my($s, $t) = split(/,/, $pair);
$pairs{"$s,$u"} = $s + $u;
$pairs{"$t,$u"} = $t + $u;
}
}while(@ulam < ULAM_LIMIT);
return @ulam;
}
MAIN:{
my @ulam;
@ulam = ulam(1, 2);
{
print shift @ulam;
print ", ";
redo if @ulam > 1;
}
print shift @ulam;
print "\n";
@ulam = ulam(2, 3);
{
print shift @ulam;
print ", ";
redo if @ulam > 1;
}
print shift @ulam;
print "\n";
@ulam = ulam(2, 5);
{
print shift @ulam;
print ", ";
redo if @ulam > 1;
}
print shift @ulam;
print "\n";
}
Sample Run
$ perl perl/ch-2.pl
1, 2, 3, 4, 6, 8, 11, 13, 16, 18
2, 3, 5, 7, 8, 9, 13, 14, 18, 19
2, 5, 7, 9, 11, 12, 13, 15, 19, 23
Notes
The code here is a pretty direct translation of the definition: the next member of the
sequence must be a sum of two previous members which is greater than the previous member
and only be obtainable one way. Here that is done with a grep filter, with the sequence
itself being stored in an array, but for convenience the sums of all unique previous pairs
are kept in a hash.
References
posted at: 18:00 by: Adam Russell | path: /perl | permanent link to this entry
2021-12-19
Stealthy Calculations
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given a string, $s, containing mathematical expression. Write a script to print the result of the mathematical expression. To keep it simple, please only accept + - * ().
Solution
Main driver.
use strict;
use warnings;
##
# Write a script to implement a four function infix calculator.
##
use TWCCalculator;
use constant ADD => "10 + 8";
use constant SUBTRACT => "18 - 66";
use constant ADD_SUBTRACT => "10 + 20 - 5";
use constant MULTIPLY => "10 * 8";
use constant DIVIDE => "52 / 2";
use constant CALCULATE => "(10 + 20 - 5) * 2";
MAIN:{
my $parser = new TWCCalculator();
$parser->parse(ADD);
$parser->parse(SUBTRACT);
$parser->parse(ADD_SUBTRACT);
$parser->parse(MULTIPLY);
$parser->parse(DIVIDE);
$parser->parse(CALCULATE);
}
TWCCalculator.yp (the Parse::Yapp code). This file is used to generate a parser module, TWCCalculator.pm, which is used in the code above. This is where the actual parsing of the input and implementation of the calculator is.
%token NUMBER
%left '+' '-' '*' '/'
%%
line:
| expression {print $_[1] . "\n"}
;
expression: NUMBER
| expression '+' expression {$_[1] + $_[3]}
| expression '-' expression {$_[1] - $_[3]}
| expression '*' expression {$_[1] * $_[3]}
| expression '/' expression {$_[1] / $_[3]}
| '(' expression ')' {$_[2]}
;
%%
sub lexer{
my($parser) = @_;
$parser->YYData->{INPUT} or return('', undef);
$parser->YYData->{INPUT} =~ s/^[ \t]//;
##
# send tokens to parser
##
for($parser->YYData->{INPUT}){
s/^([0-9]+)// and return ("NUMBER", $1);
s/^(\+)// and return ("+", $1);
s/^(-)// and return ("-", $1);
s/^(\*)// and return ("*", $1);
s/^(\/)// and return ("/", $1);
s/^(\()// and return ("(", $1);
s/^(\))// and return (")", $1);
s/^(\n)// and return ("\n", $1);
}
}
sub error{
exists $_[0]->YYData->{ERRMSG}
and do{
print $_[0]->YYData->{ERRMSG};
return;
};
print "syntax error\n";
}
sub parse{
my($self, $input) = @_;
$self->YYData->{INPUT} = $input;
my $result = $self->YYParse(yylex => \&lexer, yyerror => \&error);
return $result;
}
Sample Run
$ yapp TWCCalculator.yp
$ perl ch-1.pl
18
-48
25
80
26
50
Notes
In a long ago (almost exactly two years!) Challenge we were asked to implement a Reverse Polish Notation (RPN) Calculator. For that challenge I wrote a short introduction to the parser module, Parse::Yapp, that I used. See the references below, I think it still holds up.
For this challenge I was able to rely pretty heavily on that older code. I simply changed the expected position of the operators and that was about it!
I really like any excuse to use a parser generator, they're a powerful tool one can have at the disposal for a fairly small investment of learning time. Well, practical usage may be quick to learn. Depending on how deep one wants to go there is the possibility also of a lifetime of study of computational linguistics.
Part 2
You are given a positive number, $n. Write a script to find out if the given number is a Stealthy Number.
Solution
use strict;
use warnings;
use boolean;
sub factor{
my($n) = @_;
my @factors = ();
for my $j (2 .. sqrt($n)){
push @factors, [$j, $n / $j] if $n % $j == 0;
}
return @factors;
}
sub stealthy{
my($n) = @_;
my @factors = factor($n);
for(my $i = 0; $i < @factors; $i++){
for(my $j = 0; $j < @factors; $j++){
unless($i == $j){
my($s, $t) = @{$factors[$i]};
my($u, $v) = @{$factors[$j]};
return true if $s + $t == $u + $v + 1;
}
}
}
return false;
}
MAIN:{
print stealthy(12) . "\n";
print stealthy(36) . "\n";
print stealthy(6) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
1
1
0
Notes
That factor subroutine makes another appearance! Well, here there is a slight
modification to get it to return the factors in pairs, each pair an array reference.
These are all checked in a loop for the desired property.
This is a classic "generate and test" approach. For an idea of what it would look like to instead constrain the variables to fit the property and then discover which values, if any, match these constraints then please do take a look at my Prolog solution for Challenge 143 which uses a Constraint Logic Programming over Finite Domains (clpfd) approach.
References
posted at: 19:56 by: Adam Russell | path: /perl | permanent link to this entry
2021-12-12
Sleeping Divisors
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given positive integers, $m and $n. Write a script to find total count of divisors of $m having last digit $n.
Solution
use strict;
use warnings;
sub factor{
my($n) = @_;
my @factors = (1);
foreach my $j (2 .. sqrt($n)){
push @factors, $j if $n % $j == 0;
push @factors, ($n / $j) if $n % $j == 0 && $j ** 2 != $n;
}
return @factors;
}
sub divisors_last_digit{
my($m, $n) = @_;
my @divisors;
my @factors = factor($m);
{
my $factor = pop @factors;
push @divisors, $factor if $n == substr($factor, -1);
redo if @factors;
}
return sort {$a <=> $b} @divisors;
}
MAIN:{
my($m, $n);
my @divisors;
($m, $n) = (24, 2);
@divisors = divisors_last_digit($m, $n);
print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";
($m, $n) = (75, 5);
@divisors = divisors_last_digit($m, $n);
print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";
($m, $n) = (30, 5);
@divisors = divisors_last_digit(30, 5);
print "($m, $n): " . @divisors . " --> " . join(", ", @divisors) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
(24, 2): 2 --> 2, 12
(75, 5): 3 --> 5, 15, 25
(30, 5): 2 --> 5, 15
Part 2
Implement Sleep Sort.
Solution
use strict;
use warnings;
use Thread::Pool;
sub create_workers{
my @numbers = @_;
my $count = @numbers;
my $workers = new Thread::Pool({
optimize => "cpu",
do => \&sleeper,
workers => $count,
maxjobs => $count,
minjobs => $count
});
return $workers;
}
sub sleeper{
my($n) = @_;
sleep($n);
return $n;
}
sub sleep_sort{
my($numbers, $workers) = @_;
my @jobs;
my @sorted;
for my $n (@{$numbers}){
my $job_id = $workers->job($n);
push @jobs, $job_id;
}
{
my $job = pop @jobs;
my @result = $workers->result_any(\$job);
if(!@result){
push @jobs, $job;
}
else{
push @sorted, $result[0];
}
redo if @jobs;
}
$workers->shutdown;
return @sorted;
}
MAIN:{
my @numbers;
my @sorted;
@numbers = map{int(rand($_) + 1)} (0 .. 9);
print join(", ", @numbers) . "\n";
@sorted = sleep_sort(\@numbers, create_workers(@numbers));
print join(", ", @sorted) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
1, 1, 1, 3, 2, 3, 4, 7, 8, 6
1, 1, 1, 2, 3, 3, 4, 6, 7, 8
$ perl perl/ch-2.pl
1, 1, 1, 2, 2, 5, 5, 2, 1, 9
1, 1, 1, 1, 2, 2, 2, 5, 5, 9
Notes
I hope participants in The Weekly Challenge enjoyed this! After I saw Jort Sort in Challenge 139 I was reminded of other joke sorts and suggested this as a future challenge. Happily the suggestion was accepted!
Threading is easy in Perl, which uses an "Interpreter Threads" ("ithreads") model. Node.js programmers will find this model familiar as it is exactly what that language uses. Unfortunately Perl's documentation writers are not as familiar with concurrent and parallel programming topics and some of the official documentation needs updating. Unfortunately, this is a bizarrely contentious issue.
To ensure you are using a perl interpreter with proper ithreads support try this
one-liner: $ perl -Mthreads -e 0. If that runs without error you are good to go! If you
get an error you'll need to install a new perl. One convenient option is to use
Perlbrew. After installing perlbrew you'll need to invoke it
like this perlbrew install perl-5.34.0 -Dusethreads. Please see the Perlbrew
documentation for additional (straightforward) details if you decide to undertake this.
Here rather than use threads directly Thread::Pool is used. This is a convenient
pattern for using Perl's ithreads. Since each ithread is really a new perl interpreter
process this allows for some fine tuning of the number of ithreads created to help
conserve memory usage. In this case the memory conservation is actually somewhat minimal
since Sleep Sort requires us to start a new ithread for each element of the array to be
sorted. Amusingly, because of the process based threading model, we can quickly crash the
program by attempting to sort an array whose size causes the system to exceed the number
of allowed processes. Remember, this is a joke sort, right!?!?
Typically you'd create a pool of workers whose number matched the number of CPU cores available. That way each core could be tasked by the OS for whatever CPU intensive code you'd care to run without the ithreads competing too badly with each other.
Concurrent and parallel programming issues are somewhat advanced. Excellent documentation
exists that is both Perl specific and more general. Be sure to understand the difference
between ithreads and so called "co-operative thread" models (as used in modules such as
Coro. The "advanced" nature of this topic is due to understanding the various trade-offs
at play. Deep understanding usually comes from experience of implementing solutions this
way and study of the underlying Operating System concepts. Even the most modest modern
computer systems systems available have multiple cores at your disposal as a programmer
so this effort is certainly worthwhile! The bibliography of perlthrtut is an excellent
starting point.
References
posted at: 13:16 by: Adam Russell | path: /perl | permanent link to this entry
2021-12-05
Like, It’s Just the First Ten Numbers Man!
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to find lowest 10 positive integers having exactly 8 divisors
Solution
use strict;
use warnings;
sub factor{
my($n) = @_;
my @factors = (1, $n);
foreach my $j (2..sqrt($n)){
push @factors, $j if $n % $j == 0;
push @factors, ($n / $j) if $n % $j == 0 && $j ** 2 != $n;
}
return @factors;
}
sub first_ten_with_eight{
my $i = 0;
my @first_ten;
do{
my @factors = factor($i);
push @first_ten, $i if @factors == 8;
$i++;
}while(@first_ten != 10);
return @first_ten;
}
MAIN:{
print join(", ", first_ten_with_eight()) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
24, 30, 40, 42, 54, 56, 66, 70, 78, 88
Notes
I have re-used that factor() function quite a bit for these challenges, especially
recently. My blog writing has been fairly terse recently and as much as I'd like to
be a bit more verbose I really am not sure if there all that much more to say about this
code that hasn't been said before!
Part 2
You are given positive integers, $m and $n. Write a script to find total count of integers created using the digits of $m which is also divisible by $n.
Solution
use strict;
use warnings;
##
# You are given positive integers, $m and $n.
# Write a script to find total count of integers
# created using the digits of $m which is also
# divisible by $n.
##
use Data::PowerSet q/powerset/;
sub like_numbers{
my($m, $n) = @_;
my @divisible;
for my $subset (@{powerset(split(//, $m))}){
my $i = join("", @$subset);
push @divisible, $i if $i && $i != $m && $i % $n == 0;
}
return @divisible;
}
MAIN:{
print like_numbers(1234, 2) . "\n";
print like_numbers(768, 4) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
9
3
Notes
I've been making more use of Data::PowerSet recently that I would have expected! If
anyone is interested in seeing an implementation of the Power Set calculations see my
C++ solution links below. While not Perl the code is quite readable and should be
adaptable easy to other languages. There is also a Rosetta Code entry for Power Set
but, frankly, many of the submissions there, especially the C++ and Perl ones are overly
convoluted in my opinion. Or at least much more so than the way I implemented it, which
I would think would be the more common method but I guess not!
References
posted at: 16:47 by: Adam Russell | path: /perl | permanent link to this entry
2021-11-28
A Binary Addition Simulation / Nth from a Sorted Multiplication: Table The Weekly Challenge 140
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given two decimal-coded binary numbers, $a and $b. Write a script to simulate the addition of the given binary numbers.
Solution
use strict;
use warnings;
sub add_binary{
my($x, $y) = @_;
my $sum = "";
my @a = reverse(split(//, $x));
my @b = reverse(split(//, $y));
if(@b > @a){
my @c = @b;
@b = @a;
@a = @c;
}
my $carry = 0;
for(my $d = 0; $d <= @a - 1; $d++){
my $d0 = $a[$d];
my $d1 = $b[$d];
if($d1){
$sum = "0$sum", $carry = 0 if $d0 == 1 && $d1 == 1 && $carry == 1;
$sum = "1$sum", $carry = 0 if $d0 == 1 && $d1 == 0 && $carry == 0;
$sum = "0$sum", $carry = 1 if $d0 == 1 && $d1 == 1 && $carry == 0;
$sum = "0$sum", $carry = 1 if $d0 == 0 && $d1 == 1 && $carry == 1;
$sum = "0$sum", $carry = 0 if $d0 == 0 && $d1 == 0 && $carry == 0;
$sum = "1$sum", $carry = 0 if $d0 == 0 && $d1 == 0 && $carry == 1;
$sum = "0$sum", $carry = 1 if $d0 == 1 && $d1 == 0 && $carry == 1;
$sum = "1$sum", $carry = 0 if $d0 == 0 && $d1 == 1 && $carry == 0;
}
else{
$sum = "0$sum", $carry = 1, next if $d0 == 1 && $carry == 1;
$sum = "1$sum", $carry = 0, next if $d0 == 0 && $carry == 1;
$sum = "0$sum", $carry = 0, next if $d0 == 0 && $carry == 0;
$sum = "1$sum", $carry = 0, next if $d0 == 1 && $carry == 0;
}
}
$sum = "$carry$sum" if $carry == 1;
return $sum;
}
MAIN:{
print add_binary(11, 1) . "\n";
print add_binary(101, 1) . "\n";
print add_binary(100, 11) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
100
110
111
Notes
I have an unusual fondness for Perl's right hand conditional. But that is pretty obvious from the way I wrote this, right?
Part 2
You are given 3 positive integers, $i, $j and $k. Write a script to print the $kth element in the sorted multiplication table of $i and $j.
Solution
use strict;
use warnings;
sub nth_from_table{
my($i, $j, $k) = @_;
my @table;
for my $x (1 .. $i){
for my $y (1 .. $j){
push @table, $x * $y;
}
}
return (sort {$a <=> $b} @table)[$k - 1];
}
MAIN:{
print nth_from_table(2, 3, 4) . "\n";
print nth_from_table(3, 3, 6) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
3
4
Notes
Full Disclosure: At first I wanted to do this in some convoluted way for fun. After
experimenting with, like, nested maps for a few minutes I lost all interest in "fun" and
just went with a couple of for loops!
References
posted at: 17:16 by: Adam Russell | path: /perl | permanent link to this entry
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
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
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
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
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
- This allows for object oriented construction of the data structure with almost the minimum overhead
- While providing for some OO structure, other than generating default accessor methods there is not too much done behind the scenes. Organizing the code this way does not feel like "cheating" in that there is any reliance on the OO framework, since it is so minimal.
- Many classic texts on data structures use C and that languages
structability. Some superficial resemblance to that code is helpful in translating examples from the literature to Perl.
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
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:
- a function for inserting at the end of the list, insert at each addition step
- holding the sum in an array and when
add()is finished with all list elements use the existinginsert()and create a LinkedList instance to return byshifting off the array.
References
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
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
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
The grid is randomly determined. Any cell has a 1/3 chance of being a mine.
The code for finding all adjacent cells, if they exist, is largely taken from my solution to Challenge 077.
Once the tedious business of finding the adjacent cells is done counting up the "mines" and labelling the cells is straightforward!
References
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:
- Are there only two each of X and Y co-ordinates? Then that is enough to establish that we have a square.
- Otherwise, make sure the side lengths are all equivalent and that the angles between the sides are all 90 degrees.
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
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
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
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
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
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.
- A hash is kept of all paths. Keys are the paths themselves and values are an array reference containing the current position and all previously visited nodes on that path.
- Each path is examined and updated to move to the next position proved that next position exists and has not yet been visited. (See more on visited positions next).
- The hash of paths is refreshed by moving paths that are completed to an array. Also, this code allows for catching paths which deadend (i.e. end up in a corner which is impossible to get out of without backtracking over a visited node). Without horizontal leftward movements this is not really possible however. Some CPU cycles can be saved by eliminating these checks, but I decided to leave them in anyway. Please do note the unnecessary extra work, however!
- The traversal ends when all paths have been exhausted, the loop ends, and the paths are returned.
References
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
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:
- read in the words and construct the directed graph
- check to see that the number of connected components is one. If so, print 1. Otherwise print 0.
- display the graph (an optional data visualization step)
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).
- We need to make sure we have at least one digit which is a multiple of 2. If not, then there is no need to continue.
- Sort the numbers, but then inspect the final digit in descending order. Is it a multiple of 2? If so, then we are done!
- If the final digit is not a multiple of 2 then search the sorted list starting from the final digit and working "upwards". We had previously made sure we had at least one multiple of 2 so we are certain to find one. When we find it we need to swap it with the final digit to insure that the entire number itself is a multiple of 2.
References
posted at: 23:34 by: Adam Russell | path: /perl | permanent link to this entry
2021-05-30
The Weekly Challenge 114
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a positive integer $N. Write a script to find out the next Palindrome Number higher than the given integer $N.
Solution
use strict;
use warnings;
sub next_palindrome{
my($n) = @_;
{
$n++;
return $n if $n eq join("", reverse(split(//, $n)));
redo;
}
}
MAIN:{
my($N);
$N = 1234;
print next_palindrome($N) . "\n";
$N = 999;
print next_palindrome($N) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
1331
1001
Notes
This is probably the most straight forward approach to this task. Here we iterate upwards from our starting point and check each number using reverse. Since we are guaranteed of eventually finding a palindrome the loop is done (via redo) without any exit criteria or bounds checking other than returning when one is found.
Part 2
You are given a positive integer $N. Write a script to find the next higher integer having the same number of 1 bits in binary representation as $N.
Solution
use strict;
use warnings;
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 next_same_bits{
my($n) = @_;
my $number_bits = count_bits($n);
{
my $next = $n + 1;
return $next if count_bits($next) == $number_bits;
$n = $next;
redo;
}
}
MAIN:{
my($N);
$N = 3;
print next_same_bits($N) . "\n";
$N = 12;
print next_same_bits($N) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
5
17
Notes
The count_bits subroutine is based on code written for
Challenge 079. Otherwise, the approach
to this task is very similar to what was done in the first one this week.
References
posted at: 16:01 by: Adam Russell | path: /perl | permanent link to this entry
2021-05-23
The Weekly Challenge 113
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 and a digit $D. Write a script to check if $N can be represented as a sum of positive integers having $D at least once. If check passes print 1 otherwise 0.
Solution
use strict;
use warnings;
sub is_represented{
my($n, $d) = @_;
my @contains = grep { grep { $_ == $d } split(//) } (1 .. $n);
return $n == unpack("%32C*", pack("C*", @contains));
}
MAIN:{
print is_represented(25, 7) + 0 . "\n";
print is_represented(24, 7) + 0 . "\n";
}
Sample Run
$ perl perl/ch-1.pl
0
1
Notes
I've been trying to avoid using regexes in these challenges recently, to help promote
some increased creativity. Here I use a nested grep to determine which numbers contain the
digit $d.
I also use one of my favorite ways to sum a list of numbers using unpack and pack!
By default the false value in the first example will print as an empty string. The + 0
forces a numification to 0 (or 1 too) which then stringifies to what we expect.
Part 2
You are given a Binary Tree. Write a script to replace each node of the tree with the sum of all the remaining nodes.
Solution
use strict;
use warnings;
use Graph;
use Graph::Easy::Parser;
sub dfs_update{
my($graph, $vertex, $graph_updated, $previous) = @_;
my @successors = $graph->successors($vertex);
for my $successor (@successors){
my $sum_remaining = sum_remaining($graph, $vertex);
$graph_updated->add_edge($previous, $sum_remaining) if $previous;
dfs_update($graph, $successor, $graph_updated, $sum_remaining);
}
$graph_updated->add_edge($previous, sum_remaining($graph, $vertex)) if !@successors;
}
sub sum_remaining{
my($graph, $visited) = @_;
my $sum = 0;
for my $vertex ($graph->vertices()){
$sum += $vertex if $vertex != $visited;
}
return $sum;
}
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] ] => [ $a[1] ]";
}
my $parser = new Graph::Easy::Parser();
my $graph_viz = $parser->from_text(join("", @lines));
print $graph_viz->as_ascii();
}
MAIN:{
my $graph = new Graph();
my $graph_updated = new Graph();
my $root = 1;
$graph->add_edge($root, 2);
$graph->add_edge($root, 3);
$graph->add_edge(2, 4);
$graph->add_edge(4, 7);
$graph->add_edge(3, 5);
$graph->add_edge(3, 6);
dfs_update($graph, $root, $graph_updated);
display_graph($graph);
display_graph($graph_updated);
}
Sample Run
$ perl perl/ch-2.pl
+---+ +---+ +---+ +---+
| 1 | ==> | 2 | ==> | 4 | ==> | 7 |
+---+ +---+ +---+ +---+
H
H
v
+---+ +---+
| 3 | ==> | 5 |
+---+ +---+
H
H
v
+---+
| 6 |
+---+
+----+ +----+ +----+ +----+
| 27 | ==> | 26 | ==> | 24 | ==> | 21 |
+----+ +----+ +----+ +----+
H
H
v
+----+ +----+
| 25 | ==> | 22 |
+----+ +----+
H
H
v
+----+
| 23 |
+----+
Notes
Whenever I work these sort of problems with Trees and Graphs I use the Graph module. My main motivation is to maintain a consistent interface so the code I write is more re-usable for the many problems that can be solved using a graph based approach. The problem at hand is a clear candidate as it is explicitly stated as such. Sometimes, however, graph problems are somewhat in disguise although the use of a graph representation will yield the best solution.
The core of the solution is done via a Depth First traversal of the tree. Each vertex, as it is visited is used to generate a new edge on a tree constructed with the conditions of the problem statement.
The original and updated trees are visualized with Graph::Easy.
References
Mastering Algorithms with Perl is an excellent book with a very in depth chapter on Graphs.
posted at: 15:33 by: Adam Russell | path: /perl | permanent link to this entry
2021-05-16
The Weekly Challenge 112
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to convert the given absolute path to the simplified canonical path.
Solution
use strict;
use warnings;
##
# Write a script to convert the given absolute path to the simplified canonical path.
# The canonical path format:
# - The path starts with a single slash '/'.
# - Any two directories are separated by a single slash '/'.
# - The path does not end with a trailing '/'.
# - The path only contains the directories on the path from the root directory to the target file or directory
##
sub leading_slash{
my($path) = @_;
$path = "/" . $path if substr($path, 0, 1) ne "/";
return $path;
}
sub single_seperator{
my($path) = @_;
$path =~ s#\/\/#\/#;
return $path;
}
sub trailing_slash{
my($path) = @_;
chop($path) if substr($path, length($path) - 1, 1) eq "/";
return $path;
}
sub up_stay{
my($path) = @_;
my @directories = split(/\//, substr($path, 1));
my @temp_path;
for my $d (@directories){
push @temp_path, $d if $d ne "." && $d ne "..";
pop @temp_path if $d eq "..";
next if $d eq ".";
}
return "/" . join("/", @temp_path);
}
sub canonical_path{
my($path) = @_;
return up_stay(trailing_slash(single_seperator(leading_slash($path))));
}
MAIN:{
while(){
chomp;
print canonical_path($_) . "\n";
}
}
__DATA__
/a/
/a/b//c/
/a/b/c/../..
Sample Run
$ perl perl/ch-1.pl
/a
/a/b/c
/a
Notes
The challenge I set for myself here was to completely avoid any use of regular expressions! I think I pulled it off, more or less. I am not quite sure I covered every possible corner case, but it works for the examples given.
Part 2
You are given $n steps to climb. Write a script to find out the distinct ways to climb to the top. You are allowed to climb either 1 or 2 steps at a time.
Solution
use strict;
use warnings;
##
# You are given $n steps to climb
# Write a script to find out the distinct ways to climb to the top.
# You are allowed to climb either 1 or 2 steps at a time.
##
use Array::Compare;
use Algorithm::Combinatorics q/variations_with_repetition/;
sub steps{
my($k) = @_;
my @data = (0, 1, 2);
my @steps;
my $comparison = new Array::Compare();
my $iterator = variations_with_repetition(\@data, $k);
while(my $combination = $iterator->next()){
if(unpack("%32C*", pack("C*", @{$combination})) == $k){
my $step = [grep {$_ != 0} @{$combination}];
push @steps, $step if(!grep {$comparison->compare($_, $step)} @steps);
}
}
return @steps;
}
MAIN:{
my @steps;
@steps = steps(3);
print "k = 3\n";
for my $steps (@steps){
my $option;
for my $step (@{$steps}){
$option .= "$step step + " if $step == 1;
$option .= "$step steps + " if $step == 2;
}
chop($option);
chop($option);
print "$option\n";
}
@steps = steps(4);
print "\nk = 4\n";
for my $steps (@steps){
my $option;
for my $step (@{$steps}){
$option .= "$step step + " if $step == 1;
$option .= "$step steps + " if $step == 2;
}
chop($option);
chop($option);
print "$option\n";
}
@steps = steps(5);
print "\nk = 5\n";
for my $steps (@steps){
my $option;
for my $step (@{$steps}){
$option .= "$step step + " if $step == 1;
$option .= "$step steps + " if $step == 2;
}
chop($option);
chop($option);
print "$option\n";
}
}
Sample Run
$ perl perl/ch-2.pl
k = 3
1 step + 2 steps
2 steps + 1 step
1 step + 1 step + 1 step
k = 4
2 steps + 2 steps
1 step + 1 step + 2 steps
1 step + 2 steps + 1 step
2 steps + 1 step + 1 step
1 step + 1 step + 1 step + 1 step
k = 5
1 step + 2 steps + 2 steps
2 steps + 1 step + 2 steps
2 steps + 2 steps + 1 step
1 step + 1 step + 1 step + 2 steps
1 step + 1 step + 2 steps + 1 step
1 step + 2 steps + 1 step + 1 step
2 steps + 1 step + 1 step + 1 step
1 step + 1 step + 1 step + 1 step + 1 step
Notes
Rather than pursue some sort of algorithmic elegance and optimization I decided to
try what is effectively a brute force approach. For small values of $k this works quite
nicely with the above example output generated in about a second on very modest hardware
(an approximately 20 year old 450Mhz G4 Power Macintosh). Naturally we face a
combinatorial explosion for larger values of $k. For larger input values consider
a graph search with memoization!
Overview of this brute force approach:
- Generate all arrays of numbers of length
$kusing digits 0, 1, and 2. - Keep all those arrays that sum to
$k - Remove zeroes from these matching arrays
- Remove duplicate arrays
Combinations are generated using Algorithm::Combinatorics.
Duplicate array removal is facilitated by Array::Compare.
References
posted at: 18:10 by: Adam Russell | path: /perl | permanent link to this entry
2021-05-09
Efficient Matrix Search: The Weekly Challenge 111
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given 5x5 matrix filled with integers such that each row is sorted from left to right and the first integer of each row is greater than the last integer of the previous row. Write a script to find a given integer in the matrix using an efficient search algorithm.
Solution
use strict;
use warnings;
use boolean;
use constant MATRIX_SIZE => 5;
sub matrix_search{
my($matrix, $search) = @_;
unless(@{$matrix} == 1){
my $half = int(@{$matrix} / 2);
if($matrix->[$half]->[0] > $search){
my @matrix_reduced = @{$matrix}[0 .. $half - 1];
matrix_search(\@matrix_reduced, $search);
}
elsif($matrix->[$half]->[0] < $search){
my @matrix_reduced = @{$matrix}[$half .. @{$matrix} - 1];
matrix_search(\@matrix_reduced, $search);
}
elsif($matrix->[$half]->[0] == $search){
return true;
}
}
else{
return row_search($matrix->[0], $search);
}
}
sub row_search{
my ($row, $search) = @_;
unless(@{$row} == 1){
my $half = int(@{$row} / 2);
if($row->[$half] > $search){
my @row_reduced = @{$row}[0 .. $half - 1];
row_search(\@row_reduced, $search);
}
elsif($row->[$half] < $search){
my @row_reduced = @{$row}[$half .. @{$row} - 1];
row_search(\@row_reduced, $search);
}
elsif($row->[$half] == $search){
return true;
}
}
else{
return false;
}
}
MAIN:{
my $N = [[ 1, 2, 3, 5, 7 ],
[ 9, 11, 15, 19, 20 ],
[ 23, 24, 25, 29, 31 ],
[ 32, 33, 39, 40, 42 ],
[ 45, 47, 48, 49, 50 ]];
my $search = 35;
print matrix_search($N, $search) . "\n";
$search = 39;
print matrix_search($N, $search) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
0
1
Notes
The most efficient way to search through this sorted matrix is with a binary search. Here the binary search is implemented recursively and split into two subroutines. The first search for the right row, the second performs a binary search within the row.
Part 2
Write a script to find the longest English words that don’t change when their letters are sorted.
Solution
use strict;
use warnings;
sub max_sorted{
my($words) = @_;
my $max = -1;
my @length_words;
for my $word (@{$words}){
my $sorted_word = join("", sort { $a cmp $b } split(//, $word));
if($word eq $sorted_word && length($word) >= $max){
$length_words[length($word)] = [] if(!$length_words[length($word)]);
push @{$length_words[length($word)]}, $word;
$max = length($word);
}
}
return $length_words[$max];
}
MAIN:{
my @words;
while(<>){
chomp;
push @words, lc($_);
}
print join("\n", @{max_sorted(\@words)}) . "\n";
}
Sample Run
$ perl perl/ch-2.pl < /usr/share/dict/words
adelops
alloquy
beefily
begorry
billowy
egilops
Notes
This code expects input on STDIN. Here the system dictionary is used. For this file the maximum length of words meeting the criteria is seven. There are six such words, as shown in the output.
References
posted at: 23:58 by: Adam Russell | path: /perl | permanent link to this entry
2021-05-02
Checking Phone Numbers and Transposing Tabular Data the Hard Way: The Weekly Challenge 110
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a text file. Write a script to display all valid phone numbers in the given text file.
Solution
use Capture::Tiny q/capture_stdout/;
use PhoneNumberParser;
MAIN:{
my $parser = new PhoneNumberParser();
while(my $line = ){
$line =~ s/^\s+|\s+$//g;
my $syntax_error = capture_stdout {
$parser->parse($line);
};
print("$line\n") if !$syntax_error;
}
}
__DATA__
0044 1148820341
+44 1148820341
44-11-4882-0341
(44) 1148820341
00 1148820341
The Parse::Yapp grammar.
%token SPACE DIGIT OPEN CLOSE PLUS
%%
phone_number: prefix SPACE area_exchange_subscriber
;
prefix: DIGIT DIGIT DIGIT DIGIT
| OPEN DIGIT DIGIT CLOSE
| PLUS DIGIT DIGIT
;
area_exchange_subscriber: DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT
;
%%
sub lexer{
my($parser) = @_;
$parser->YYData->{INPUT} or return('', undef);
##
# send tokens to parser
##
for($parser->YYData->{INPUT}){
s/^(\s)// and return ("SPACE", $1);
s/^(\d)// and return ("DIGIT", $1);
s/^(\()// and return ("OPEN", $1);
s/^(\))// and return ("CLOSE", $1);
s/^(\+)// and return ("PLUS", $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 perl/PhoneNumberParser.yp
$ perl -Iperl perl/ch-1.pl
0044 1148820341
+44 1148820341
(44) 1148820341
Notes
While a set of regular expression would have done the job quite nicely I figured I’d use this problem as a reason to shake the rust off my grammar writing skills. Not that I am a master parser writer or anything, but Parse::Yapp makes it easy enough!
Well, easy is a bit relative I suppose. This is definitely not the simplest way of performing this task.
Part 2
You are given a text file. Write a script to transpose the contents of the given file.
Solution
sub transpose{
my @columns = @_;
return transpose_r([], \@columns);
}
sub transpose_r{
my($transposed, $remaining) = @_;
return $transposed if(@{$remaining} == 0);
$transposed = transpose_row_r($transposed, $remaining->[0]);
shift @{$remaining};
transpose_r($transposed, $remaining);
}
sub transpose_row_r{
my($transposed, $row) = @_;
return $transposed if(@{$row} == 0);
my $index = @{$row} - 1;
push @{$transposed->[$index]}, pop @{$row};
transpose_row_r($transposed, $row);
}
MAIN:{
my @columns;
while(my $line = ){
chomp($line);
my @fields = split(/,/, $line);
push @columns, \@fields;
}
my $transposed = transpose(@columns);
for my $i (0 .. @{$transposed} - 1){
print join(",", @{$transposed->[$i]}) . "\n";
}
}
__DATA__
name,age,sex
Mohammad,45,m
Joe,20,m
Julie,35,f
Cristina,10,f
Sample Run
$ perl perl/ch-2.pl
name,Mohammad,Joe,Julie,Cristina
age,45,20,35,10
sex,m,m,f,f
Notes
Similar to Part 1 this is also not the easiest way to perform this task. Here the same sort of recursion is used that is used in the Prolog version of the solution to this part. That is, we recurse over the table itself and then for each row perform a separate recursion to perform the transpostion.
References
posted at: 19:03 by: Adam Russell | path: /perl | permanent link to this entry
2021-04-25
Chowla Numbers and Numbers in Boxes: The Weekly Challenge 109
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to display the first 20 Chowla Numbers.
Solution
use strict;
use warnings;
use constant CHOWLA_COUNT => 20;
sub factor{
my($n) = @_;
my @factors = ();
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 chowla{
my(@factors) = @_;
my $sum = unpack("%32I*", pack("I*", @factors));
}
MAIN:{
my @chowla_numbers;
for my $n (1 .. CHOWLA_COUNT){
push @chowla_numbers, chowla(factor($n));
}
print join(", ", @chowla_numbers) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
0, 0, 0, 2, 0, 5, 0, 6, 3, 7, 0, 15, 0, 9, 8, 14, 0, 20, 0, 21
Notes
This code borrowed quite a bit a previous challenge involving Perfect Numbers. Indeed, the code is nearly identical! After we get the factors there is only the matter of summing them and displaying them.
Part 2
Place the given unique numbers in the square box so that sum of numbers in each box is the same.
Solution
use strict;
use warnings;
##
# You are given four squares as below with numbers named a,b,c,d,e,f,g.
# to place the given unique numbers in the square box so that sum of
# numbers in each box is the same.
# (1) (3)
# +--------------+ +--------------+
# ? ? ? ?
# ? a ? ? e ?
# ? ? (2) ? ? (4)
# ? +---+------+---+ +---+---------+
# ? ? ? ? ? ? ? ?
# ? ? b ? ? d ? ? f ? ?
# ? ? ? ? ? ? ? ?
# ? ? ? ? ? ? ? ?
# +----------+---+ +---+------+---+ ?
# ? c ? ? g ?
# ? ? ? ?
# ? ? ? ?
# +--------------+ +-------------+
##
use AI::Prolog;
my $prolog = do{
local $/;
;
};
$prolog = new AI::Prolog($prolog);
$prolog->query("sums_in_squares([1,2,3,4,5,6,7], Squares).");
my $result;
print join("\t", "a" .. "g") . "\n";
while ($result = $prolog->results()){
print join("\t", @{$result->[2]}) . "\n";
}
__DATA__
member(X,[X|T]).
member(X,[H|T]):- member(X,T).
sums_in_squares(Numbers, [A, B, C, D, E, F, G]):-
member(A, Numbers),
member(B, Numbers),
member(C, Numbers),
member(D, Numbers),
member(E, Numbers),
member(F, Numbers),
member(G, Numbers),
A \= B, A \= C, A \= D, A \= E, A \= F, A \= G,
B \= A, B \= C, B \= D, B \= E, B \= F, B \= G,
C \= A, C \= B, C \= D, C \= E, C \= F, C \= G,
D \= A, D \= B, D \= C, D \= E, D \= F, D \= G,
E \= A, E \= B, E \= C, E \= D, E \= F, E \= G,
F \= A, F \= B, F \= C, F \= D, F \= E, F \= G,
G \= A, G \= B, G \= C, G \= D, G \= E, G \= F,
Box1 is A + B,
Box2 is B + C + D,
Box3 is D + E + F,
Box4 is F + G,
Box1 == Box2,
Box2 == Box3,
Box3 == Box4.
Sample Run
$ perl perl/ch-2.pl
a b c d e f g
3 7 2 1 5 4 6
4 5 3 1 6 2 7
4 7 1 3 2 6 5
5 6 2 3 1 7 4
6 4 1 5 2 3 7
6 4 5 1 2 7 3
7 2 6 1 3 5 4
7 3 2 5 1 4 6
Notes
This sort of problem practically screams out for a Prolog solution! In the interest of keeping with the name, if not the spirit of the weekly challenge, this first part is indeed Perl, albeit using AI::Prolog, a module which offers a pure Perl implementation of a basic Prolog.
I have used AI::Prolog previously and it’s a neat way to take advantage of Prolog within a Perl based solution. The two main downsides are that (1) it is not a full ISO Prolog and (2) it is slow. So very very slow. I suspect, in fact, there is a serious bug in the implementation. Even accounting for the fact that a pure Perl Prolog would be much slower than one written in C, such as Gnu Prolog, the execution time differences are laughably dramatic. I didn’t bother with precise metrics but the code above takes about an hour to run on fairly current hardware (i.e. my 2018 Mac Mini). Essentially the same code run on the same hardware but with Gnu Prolog completes in mere seconds.
Still, this is a nice way to incorporate a bit of Symbolic AI in a Perl code base if there is a small search space. Say, for some simple game logic or a small chat bot.
The pure Prolog solution I did for this uses the same approach, in part, although I also wrote this to take advantage of Gnu Prolog’s FD solver. The FD version of the code completes in about 10ms!
References
posted at: 16:00 by: Adam Russell | path: /perl | permanent link to this entry
2021-04-18
Memory Addresses and Bell Numbers: The Weekly Challenge 108
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to declare a variable or constant and print it’s location in the memory.
Solution
use strict;
use warnings;
use Devel::Peek;
use Capture::Tiny q/capture_stderr/;
use constant A => "test";
my $a = 1;
my $address;
my $stderr = capture_stderr {
Dump(A)
};
$stderr =~ m/at\s(0x.*\n).*/;
$address = $1;
chomp($address);
print "Address of constant A: $address\n";
$stderr = capture_stderr {
Dump($a)
};
$stderr =~ m/at\s(0x.*\n).*/;
$address = $1;
chomp($address);
print "Address of \$a: $address\n";
Sample Run
$ perl perl/ch-1.pl
Address of constant A: 0xfd31ae90
Address of $a: 0xfdb2f770
Notes
This is a somewhat unusual challenge for Perl. Sometimes these challenges allow for a certain amount of interpretation. For example, under the hood, the representation of Perl data in memory involves more complicated data structures. I think it is in the spirit of this challenge to demonstrate access to this, without necessarily implementing complete and fully generalized solution.
Here I use Devel::Peek in order to get a report on the underlying memory usage of the given variables. The Dump function only prints a memory report to STDERR, so in order to obtain the information we seek Capture::Tiny is used to encapsulate the STDERR output and save it to a variable. A regex is then used to pull out the memory address which is then printed.
The memory address printed here is the reference address. For additional details on Perl’s core see the perlguts documentation.
Part 2
Write a script to display the first 10 Bell Numbers.
Solution
use strict;
use warnings;
sub bell_triangle{
my($n) = @_;
my @bell_numbers = ([]);
$bell_numbers[0]->[0] = 1;
for (my $i=1; $i<=$n; $i++) {
$bell_numbers[$i]->[0] = $bell_numbers[$i-1]->[$i-1];
for (my $j=1; $j<=$i; $j++){
$bell_numbers[$i]->[$j] = $bell_numbers[$i-1]->[$j-1] + $bell_numbers[$i]->[$j-1];
}
}
return $bell_numbers[$n]->[0];
}
MINA:{
for my $b (0 .. 9){
print "B_$b: " . bell_triangle($b) . "\n";
}
}
Sample Run
$ perl perl/ch-2.pl
B_0: 1
B_1: 1
B_2: 2
B_3: 5
B_4: 15
B_5: 52
B_6: 203
B_7: 877
B_8: 4140
B_9: 21147
Notes
This is an interesting problem. At first glance one might be tempted to proceed and compute the partitions and then take the total number of them all. Instead, it turns out that there is a simpler closed form solution whereby we can compute the Bell Triangle and then take the values on the leftmost diagonal to be the Bell Numbers as required.
For fun the Prolog solution does indeed compute the partitions instead of simply using the Bell Triangle!
References
posted at: 15:55 by: Adam Russell | path: /perl | permanent link to this entry
2021-04-11
Static Analysis and Self Describing Numbers (now with Threads!): The Weekly Challenge 107
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate self-descriptive numbers.
Solution
use strict;
use warnings;
use Thread;
use boolean;
use constant SDN_COUNT => 3;
use constant THREAD_COUNT => 4;
use constant RANGE_SIZE => 10_000;
sub self_describing{
my($i) = @_;
my @digits = split(//, $i);
for my $x (0 .. @digits - 1){
my $count = 0;
for my $j (0 .. @digits - 1){
$count++ if($digits[$j] == $x);
return false if($count > $digits[$x]);
}
return false if($count != $digits[$x]);
}
return true;
}
sub self_describing_number{
my($start, $end) = @_;
my @r = ();
for(my $i = $start; $i < $end; $i++){
push @r, [length($i), $i] if(self_describing($i));
}
return \@r;
}
MAIN:{
my @threads;
my $count = 0;
my $lower = 1;
my $upper = RANGE_SIZE;
do{
for(0..(THREAD_COUNT - 1)){
my $t = Thread->new(\&self_describing_number, ($lower, $upper));
push @threads, $t;
$lower = $upper + 1;
$upper = $lower + RANGE_SIZE;
}
foreach my $t (@threads){
my $sdns = $t->join();
foreach my $sdn (@{$sdns}){
print "Base " . $sdn->[0] . ":" . $sdn->[1] . "\n" if $count < SDN_COUNT;
$count++;
}
}
@threads = ();
} while($count < SDN_COUNT);
}
Sample Run
$ perl perl/ch-1.pl
Base 4:1210
Base 4:2020
Base 5:21200
Notes
Part 1 this week is repeated from Challenge 043. In order to provide something fresh for the same problem I modified the previous code to be multi-threaded.
Part 2
Write a script to list methods of a package/class.
Solution
use strict;
use warnings;
sub analyze{
my($file) = @_;
my @subs;
my @uses;
my @subroutines;
my $subs = `perlanalyst $file --analysis Sub`;
$subs =~ s/$file://;
@subs = split(/\n/, $subs);
my $uses = `perlanalyst $file --analysis Use`;
$uses =~ s/$file://;
@uses = split(/\n/, $uses);
for my $s (@subs){
$s =~ s/\s+//;
my @fields = split(/:/, $s);
push @subroutines, $fields[1] if(length($s) > 0);
}
push @subroutines, "BEGIN" if(@uses);
return @subroutines;
}
MAIN:{
my $FILE = $ARGV[0];
my @subroutines = analyze($FILE);
print join("\n", sort {$a cmp $b} @subroutines) . "\n";
}
Sample Run
$ perl perl/ch-2.pl perl/Calc.pm
BEGIN
DESTROY
add
div
mul
new
Notes
Getting a list of methods can mostly be done via just some plain analysis of the code. Rather than re-invent the wheel I am using a module, Perl::Analysis::Static, to do that for me. This is a pretty neat tool but has been left in an alpha state. The most stable way to use it is via the command line instead of its incomplete API. In this code I call the perlanalyst command and then parse the output.
If given a BEGIN block or if use-ing a module Perl will execute a BEGIN at compile time. I would argue that this is out of scope for this challenge. However, as given in the problem statement we are expected to catch this it seems. I do this by inspecting the perlanalyst output for use lines. I could have done a few other things as well but decided not to do more with this since it seems like a funny requirement anyway!
References
posted at: 17:51 by: Adam Russell | path: /perl | permanent link to this entry
2021-04-04
Recursion and Repeated Decimals: The Weekly Challenge 106
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given an array of integers @N. Write a script to display the maximum difference between two successive elements once the array is sorted.
Solution
use strict;
use warnings;
sub max_difference_sorted{
my(@sorted) = @_;
return 0 if(@sorted == 1);
my $x = $sorted[1] - $sorted[0];
my $y = max_difference_sorted(@sorted[1 .. @sorted - 1]);
return ($x > $y)? $x: $y;
}
sub max_difference{
my (@numbers) = @_;
return max_difference_sorted(
sort { $a <=> $b } @numbers
);
}
MAIN:{
my (@N);
@N = (2, 9, 3, 5);
print max_difference(@N) . "\n";
@N = (1, 3, 8, 2, 0);
print max_difference(@N) . "\n";
@N = (5);
print max_difference(@N) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
4
5
0
Notes
I believe this code is straightforward enough! max_difference performs the sort and max_difference_sorted recursively finds the largest difference as required.
Part 2
You are given numerator and denominator i.e. $N and $D. Write a script to convert the fraction into decimal string. If the fractional part is recurring then put it in parenthesis.
Solution
use strict;
use warnings;
use boolean;
sub divide{
my($n, $d) = @_;
my @remainders;
my $q = (int($n / $d)) . ".";
my $r = $n % $d;
push @remainders, $r;
my @a;
for (0 .. $d){
$q .= int($r*10 / $d);
$r = $r*10 % $d;
@a = grep { $remainders[$_] == $r } (0 .. @remainders - 1);
last if(@a);
push @remainders, $r;
}
my $r_i = $a[0];
my $i = index($q, ".");
my $decimal_part = substr($q, $i+1);
return substr($q, 0, $i + 1) . substr($decimal_part, 0, $r_i) . "(" . substr($q, $i + $r_i + 1) . ")";
}
sub prime_factor{
my $x = shift(@_);
my @factors;
for (my $y = 2; $y <= $x; $y++){
next if $x % $y;
$x /= $y;
push @factors, $y;
redo;
}
return @factors;
}
sub nd2decimal{
my($n, $d) = @_;
my $max_repetend = $d - 1;
my $repeats = false;
my @factors = prime_factor($d);
for my $factor (@factors){
$repeats = true if($factor != 2 && $factor != 5);
}
unless($repeats){
return sprintf("%0.${max_repetend}g", $n / $d);
}
else{
my $x = divide($n, $d, [], []);
return $x;
}
}
MAIN:{
my($N, $D);
($N, $D) = (1, 3);
print nd2decimal($N, $D) . "\n";
($N, $D) = (1, 2);
print nd2decimal($N, $D) . "\n";
($N, $D) = (5, 66);
print nd2decimal($N, $D) . "\n";
($N, $D) = (1, 6);
print nd2decimal($N, $D) . "\n";
($N, $D) = (1, 8);
print nd2decimal($N, $D) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
0.(3)
0.5
0.0(75)
0.1(6)
0.125
Notes
Part 2 is a bit trickier than the first part. The approach here is as follows:
- determine if it is a repeated decimal by checking if
$dhas prime factors other than 2 or 5 - if it is not a repeated decimal then this is quick work, divide and display the solution
- in the case of repeated decimals we essentially implement grade school long division in the
dividefunction and keep track of remainders. When a remainder is repeated we know that we have found the cycle.
There are some interesting theoretical properties to repeat decimals but none are particularly helpful in actually computing them. One observation is that the length of the cycle must be smaller than the value of the denominator, whence the use of $d in the main loop in the divide function.
I’m re-using the same prime_factors function that I used in Challenge 041.
References
posted at: 17:04 by: Adam Russell | path: /perl | permanent link to this entry
2021-03-28
Newton’s Method and Perl Formats: The Weekly Challenge 105
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given positive numbers $N and $k. Write a script to find out the $Nth root of $k
Solution
use strict;
use warnings;
sub nth_root{
my($n, $k) = @_;
my $x_i = int(rand(10) + 1);
my $r;
for my $i (0 .. 100){
$x_i = (1 / $n) * (($n - 1) * $x_i + ($k / $x_i ** ($n - 1)));
}
return $x_i;
}
MAIN:{
my($N, $k);
$N = 5;
$k = 248832;
print nth_root($N, $k) . "\n";
$N = 5;
$k = 34;
print sprintf("%0.2f", nth_root($N, $k)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
12
2.02
Notes
One of my neatest things one can learn in calculus class, I would argue, is Newton’s method for computing square roots. One can read more on this elsewhere but this works by using a recurrence relationship, defined using directives, to compute the zero of a function. If the function is x^n - a, the zero we are computing is the nth root of a.
To start the process any x_0 may be chosen. Here we pick an integer from 1 to 10 at random.
You can compute this for as many iterations as you’d like, of course, but here even 100 iterations is much more than enough to properly converge.
Part 2
You are given a $name. Write a script to display the lyrics to the Shirley Ellis song The Name Game.
Solution
use strict;
use warnings;
sub name_game{
my($name) = @_;
my($b, $f, $m);
my $first_letter = lc(substr($name, 0, 1));
my $irregular_v = $first_letter =~ tr/aeiou//d;
my $irregular_bfm = $first_letter =~ tr/bfm//d;
unless($irregular_v || $irregular_bfm){
$b = "b" . lc(substr($name, 1));
$f = "f" . lc(substr($name, 1));
$m = "m" . lc(substr($name, 1));
}
elsif($irregular_v){
$b = "b" . lc($name);
$f = "f" . lc($name);
$m = "m" . lc($name);
}
elsif($irregular_bfm){
$b = "b" . lc(substr($name, 1));
$f = "f" . lc(substr($name, 1));
$m = "m" . lc(substr($name, 1));
$b = lc(substr($name, 1)) if lc(substr($name, 0, 1)) eq "b";
$f = lc(substr($name, 1)) if lc(substr($name, 0, 1)) eq "f";
$m = lc(substr($name, 1)) if lc(substr($name, 0, 1)) eq "m";
}
format NAME_GAME =
@*, @*, bo-@*
$name, $name, $b
Banana-fana fo-@*
$f
Fee-fi-mo-@*
$m
@*!
$name
.
select(STDOUT);
$~ = "NAME_GAME";
write();
}
MAIN:{
my($name);
$name = "Katie";
name_game($name);
print "\n";
$name = "Adam";
name_game($name);
print "\n";
$name = "Mary";
name_game($name);
}
Sample Run
$ perl perl/ch-2.pl
Katie, Katie, bo-batie
Banana-fana fo-fatie
Fee-fi-mo-matie
Katie!
Adam, Adam, bo-badam
Banana-fana fo-fadam
Fee-fi-mo-madam
Adam!
Mary, Mary, bo-bary
Banana-fana fo-fary
Fee-fi-mo-ary
Mary!
Notes
My first comment is that I am a terrible singer and have never been able to reliably remember songs with rules like this at all, at any time of my life! Practically speaking that means I may have had to do more research on this part than one might expect. I did find an excellent reference (listed below) which detailed the rules for each case very clearly.
Perhaps the trickiest case in the one in which the name starts with a b, f, or m. For these you need to adjust the one specific rewrite rule which uses that letter. In the example above we see that Mary requires special handling and becomes Fee-fi-mo-ary.
To print the verses out I use a Perl Format. Formats are not the most commonly used feature of Perl these days but still have some nice uses such as here where we want to define a simple template for plain text output. Formats can even be used to write to files, but here we just print to the console.
One Format trick which I have not used before is the use of a variable width field. Much of the documentation for Formats has to do with fixed width fields which can be centered, padded left, padded right, involve multiple lines, and so forth. A common case which is not typically well explained is one we need here. Names are of different lengths and may be followed by a comma or an exclamation point. Padding right adds unwanted space before the “,” or “!”. Padding left adds unwanted space before the name. Centering does both! The trick is to use @* for the field specifier in the Format definition. This will allow the value to be substituted in without any padding.
References
posted at: 11:28 by: Adam Russell | path: /perl | permanent link to this entry
2021-03-14
The Weekly Challenge 103: Astrology and Audio
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a year $year. Write a script to determine the Chinese Zodiac for the given year $year.
Solution
use strict;
use warnings;
##
# You are given a year $year.
# Write a script to determine the Chinese Zodiac for the given year $year
##
use constant ELEMENTS => {1 => q/Wood/, 2 => q/Fire/, 3 => q/Earth/, 4 => q/Metal/, 0 => q/Water/};
use constant ANIMALS => {1 => q/Rat/, 2 => q/Ox/, 3 => q/Tiger/, 4 => q/Rabbit/, 5 => q/Dragon/, 6 => q/Snake/, 7 => q/Horse/, 8 => q/Goat/, 9 => q/Monkey/, 10 => q/Rooster/, 11 => q/Dog/, 0 => q/Pig/};
sub chinese_zodiac{
my($year) = @_;
return ELEMENTS->{$year % 5} . " " . ANIMALS->{($year + 9) % 12};
}
MAIN:{
my($YEAR);
$YEAR = 2017;
print chinese_zodiac($YEAR) . "\n";
$YEAR = 1938;
print chinese_zodiac($YEAR) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
Fire Rooster
Earth Tiger
Notes
When I first saw the problem statement for this part of the challenge I took a look at the cited Wikipedia article, but it just seemed like a real slog of a read. So I decided to just work backwards from the examples given! Pretty much this seems to boil down to a straightforward modular arithmetic problem. The values are all known and so I hard code then with use constant and then use them directly.
Part 2
Write a program to output which file is currently playing.
Solution
use strict;
use warnings;
sub song_times{
my($file_name) = @_;
my %song_times;
my @song_order;
my $length = 0;
my $index = 0;
if(!$file_name){
while(){
chomp;
my($time, $song) = split(/,/);
$length += $time;
$song_order[$index] = $song;
$song_times{$song} = $time;
$index++;
}
}
else{
open(FILE, $file_name);
while(){
chomp;
my($time, $song) = split(/,/);
$length += $time;
$song_order[$song] = $index;
$song_times{$song} = $time;
$index++;
}
}
return [\%song_times, \@song_order, $length];
}
sub now_playing{
my($start_time, $current_time, $file_name) = @_;
my($song_times, $song_order, $length_millis);
$current_time = time() if !$current_time;
($song_times, $song_order, $length_millis) = @{song_times()} if $file_name;
($song_times, $song_order, $length_millis) = @{song_times($file_name)} if !$file_name;
my $time_playing = $current_time - $start_time;
my $cycles = ($time_playing * 1000) / $length_millis;
my $current_cycle_millis = ($cycles - int($cycles)) * $length_millis;
my $seek_time = 0;
for my $song (@{$song_order}){
$seek_time += $song_times->{$song};
if($seek_time > $current_cycle_millis){
my $position = ($song_times->{$song} - ($seek_time - $current_cycle_millis)) / 1000;
my $hours = int($position/3600);
my $minutes = int(($position % 3600) / 60);
my $seconds = int(($position % 3600) % 60);
$position = sprintf("%02d", $hours) . ":" . sprintf("%02d", $minutes) . ":" . sprintf("%02d", $seconds);
return ($song, $position);
}
}
}
MAIN:{
my($song, $position) = now_playing(1606134123, 1614591276);
print "$song\n$position\n";
}
__DATA__
1709363,"Les Miserables Episode 1: The Bishop (broadcast date: 1937-07-23)"
1723781,"Les Miserables Episode 2: Javert (broadcast date: 1937-07-30)"
1723781,"Les Miserables Episode 3: The Trial (broadcast date: 1937-08-06)"
1678356,"Les Miserables Episode 4: Cosette (broadcast date: 1937-08-13)"
1646043,"Les Miserables Episode 5: The Grave (broadcast date: 1937-08-20)"
1714640,"Les Miserables Episode 6: The Barricade (broadcast date: 1937-08-27)"
1714640,"Les Miserables Episode 7: Conclusion (broadcast date: 1937-09-03)"
Sample Run
$ perl perl/ch-2.pl
"Les Miserables Episode 1: The Bishop (broadcast date: 1937-07-23)"
00:10:24
Notes
I have to say that I found this deceptively harder to implement than it first appears! I suppose that is always true when working with time.
In the spirit of good sportsmanship wrote the code to fit the specification given, but then allow for defaults, such as reading from <DATA> and using the value of time().
The way this works here is:
- The file list is read in and the times of the songs and the total length of the whole playlist is saved.
- We find out where in the playlist “cycle” we are.
- Given the time of the cycle we “seek” to the position of the current song.
References
posted at: 16:46 by: Adam Russell | path: /perl | permanent link to this entry
2021-03-07
The Weekly Challenge 102: Threads and Recursion
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a positive integer $N. Write a script to generate all Rare Numbers of size $N if any exist.
Solution
use strict;
use warnings;
use Thread;
use constant THREAD_COUNT => 4;
sub rare_number_check{
my($lower, $upper) = @_;
my @rares;
{
my $r = $lower;
my $r1 = reverse($r);
if($r > $r1){
my $rs = sqrt($r + $r1);
my $r1s = sqrt($r - $r1);
if($rs !~ m/\./ && $r1s !~ m/\./){
push @rares, $lower;
}
}
$lower++;
redo unless $lower > $upper;
}
return \@rares;
}
sub rare_number{
my($n) = @_;
my @rares;
my $lower = "1" . 0 x ($n - 1);
my $upper = "1" . 9 x ($n - 1);
my $increment = $lower;
{
my @threads;
for(1 .. THREAD_COUNT){
my $t = Thread->new(\&rare_number_check, $lower, $upper);
push @threads, $t;
$lower = $upper + 1;
$upper = $lower + $increment - 1;
last if(length($upper) == ($n + 1));
}
foreach my $t (@threads){
my $rares = $t->join();
push @rares, @{$rares};
}
redo unless(length($upper) == ($n + 1));
}
return \@rares;
}
MAIN:{
my($N);
$N=2;
my $rares = rare_number($N);
print "$N digits: " . join(" ", @{$rares}) . "\n";
$N=6;
$rares = rare_number($N);
print "$N digits: " . join(" ", @{$rares}) . "\n";
$N=9;
$rares = rare_number($N);
print "$N digits: " . join(" ", @{$rares}) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
2 digits: 65
6 digits: 621770
9 digits: 281089082
Notes
My approach here is brute force, but with a slight twist. I parallelize the computations by using Threads. I’ve used Threads in the past, for example in Challenge 008 Threads were used to compute Perfect Numbers. The search for Perfect Numbers bears enough similarity to the current problem with Rare Numbers that the code from Challenge 008 will also be similar to this week’s code.
There are four CPU cores on the system I am running this code on. We can create any number of Threads that we need, of course, but Perl Threads are a special sort of “thread” in that they create new copies of the running interpreter and so consume a bit more memory than the sort of light weight threads you may learn about in C or Java. In the interest of conserving memory, and to avoid having multiple interpreter threads running on the same core we’ll just create no more than four Threads at a time. Note: Ultimately it is the OS which schedules where things run but, generally speaking, four threads on a four core system will each run on individual cores.
We can demonstrate this to ourselves by increasing the number of threads beyond the number of cores and not seeing an improvement in execution time.
Each Thread will get a slice of the search space. Each slice is of size 10 ** ($N - 1). Threads run sub rare_number_check which implements the definition of a Rare Number.
- I chose to use a bare block with redo. This is purely a matter of style and aesthetics. I’d argue that in this case it is more readable than the equivalent
fororwhileloops would be. sub rare_numberwhich generates and co-ordinates the Threads also uses redo for similar reasons.- Interestingly Perl is clever enough to return a integer with no decimal part in the case of a perfect square! Checking to see if we have a perfect square then becomes a matter of checking to see if the value returned by sqrt contains a decimal.
Part 2
You are given a positive integer $N. Write a script to produce hash counting string of that length.
Solution
use strict;
use warnings;
sub hash_counting_string{
my($n) = @_;
return "" if $n == 0;
return "#" if $n == 1;
my $h = "$n#";
return hash_counting_string($n - length($h)) . $h;
}
MAIN:{
print hash_counting_string(1). "\n";
print hash_counting_string(2). "\n";
print hash_counting_string(3). "\n";
print hash_counting_string(10). "\n";
print hash_counting_string(14). "\n";
}
Sample Run
$ perl perl/ch-2.pl
#
2#
#3#
#3#5#7#10#
2#4#6#8#11#14#
Notes
This is what I consider to be a nice clean recursive implementation. When I first saw Part 2 it seemed a bit more complicated than it would later prove to be. My thought process was along the lines of “I am not sure how I would do this in Perl, and I have no idea of how this would go in Prolog either!” Often times I will rely on the insights gained by doing it in one to aid the implementation of the other. In times like this, with no immediately clear solution, I prefer to start off in Perl, and write it in a way which would allow for reproduction in Prolog. Then, as necessary, remove any vestiges of the solution’s origins by conforming to idiomatic Prolog by ensuring things are done declaratively, logically.
This is actually a long acknowledged use of Perl: algorithm development. If you see the Prolog solution for Part 2 you can detect the obvious origins!
As far as this solution in Perl, perhaps the main “trick” is that we must account for the length of the numeral. So, for example, “14#” consumes three characters and so the next time through we need to generate the hash count for 11 = 14 - 3.
References
posted at: 16:28 by: Adam Russell | path: /perl | permanent link to this entry
2021-02-21
The Weekly Challenge 100
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a time (12 hour / 24 hour). Write a script to convert the given time from 12 hour format to 24 hour format and vice versa.
Solution
perl -e 'shift=~/(\d+):(\d\d\s*((am|pm)))/;if($1 < 12 && $3 eq "pm"){$h = $1 + 12}elsif($1 > 12 && $3 eq "pm"){$h = "0" . ($1 - 12)}else{$h = $1}print "$h:$2\n"' "17:15 pm"
Sample Run
perl -e 'shift=~/(\d+):(\d\d\s*((am|pm)))/;if($1 < 12 && $3 eq "pm"){$h = $1 + 12}elsif($1 > 12 && $3 eq "pm"){$h = "0" . ($1 - 12)}else{$h = $1}print "$h:$2\n"' "17:15 pm"
05:15 pm
perl -e 'shift=~/(\d+):(\d\d\s*((am|pm)))/;if($1 < 12 && $3 eq "pm"){$h = $1 + 12}elsif($1 > 12 && $3 eq "pm"){$h = "0" . ($1 - 12)}else{$h = $1}print "$h:$2\n"' "05:15 pm"
17:15 pm
Notes
Ok, so this isn;t going to win and Perl Golf competitions, that’s for sure! Frankly, this approach using regexes might not be the best for succinctly handling the bi-directionality.
For anyone that might not be familiar shift=~/(\d+):(\d\d\s*((am|pm)))/ means shift the first argument off of @ARGV (the command line arguments and then match against the regex. This is equivalent to $ARGV[0]=~/(\d+):(\d\d\s*((am|pm)))/.
Part 2
You are given triangle array. Write a script to find the minimum path sum from top to bottom. When you are on index i on the current row then you may move to either index i or index i + 1 on the next row.
Solution
use strict;
use warnings;
sub minimum_sum{
my(@triangle) = @_;
my($i, $j) = (0, 0);
my $sum = $triangle[0]->[0];
while($i < @triangle){
unless(!exists($triangle[$i+1])){
$j = ($triangle[$i+1]->[$j] >= $triangle[$i+1]->[$j+1]) ? $j+1 : $j;
$sum += $triangle[$i+1]->[$j];
}
$i++;
}
return $sum;
}
MAIN:{
my(@TRIANGLE);
@TRIANGLE = ([1], [2, 4], [6, 4, 9], [5, 1 , 7, 2]);
print minimum_sum(@TRIANGLE) . "\n";
@TRIANGLE =([3], [3, 1], [5, 2, 3], [4, 3, 1, 3]);
print minimum_sum(@TRIANGLE) . "\n";
}
Sample Run
$ perl ch-2.pl
8
7
Notes
I think this is a relatively well known greedy tactic. In order to minimize the total sum, make the minimum choice at each step.
References
posted at: 17:09 by: Adam Russell | path: /perl | permanent link to this entry
2021-02-06
Perl Weekly Challenge 098
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given file $FILE. Create subroutine readN($FILE, $number) returns the first n-characters and moves the pointer to the (n+1)th character.
Solution
use strict;
use warnings;
sub read_maker0{
my $n = 0;
return sub{
my($file, $x) = @_;
my $chars;
open(FILE, $file);
unless(seek(FILE, $n, 0)){
close(FILE);
}
read(FILE, $chars, $x);
$n = $n + $x;
return $chars;
}
}
sub read_maker1{
my ($file) = @_;
my $n = 0;
open(FILE, $file);
return sub{
my($x) = @_;
my $chars;
my $read = read(FILE, $chars, $x);
$n = $n + $x;
unless(seek(FILE, $n, 0)){
close(FILE);
}
return $chars;
}
}
MAIN:{
my($FILE, $number) = ("ch-1.dat", 4);
my($read_n, $chars);
$read_n = read_maker0();
$chars = $read_n->($FILE, $number);
print "$chars\n";
$chars = $read_n->($FILE, $number);
print "$chars\n";
$chars = $read_n->($FILE, $number);
print "$chars\n";
$read_n = read_maker1($FILE);
$chars = $read_n->($number);
print "$chars\n";
$chars = $read_n->($number);
print "$chars\n";
$chars = $read_n->($number);
print "$chars\n";
}
Sample Run
$ perl perl/ch-1.pl
1234
5678
90
1234
5678
90
Notes
I actually did this two different ways. The first follows the letter of the challenge as to the parameters of the read_n function and the second differs, only passing in $number and does not include the filename.
Before I get into the differences it makes sense to point out how read_maker0() works. What is does is create a closure over the value $n which will hold the current position in the file. Think of the variable $n created in read_maker0() as captured inside the function that is being returned. This process is called currying and it’s a neat trick. I’ve used it in the past for these challenges, the first being way back in Challenge 003! In this way read_maker0() is creating the function which we are referring to by the scalar $read_n.
After each read $n is incremented and used to seek to the next position. I should note that this is not really necessary here since the value of $number is never changed. In this case the read alone will advance the file position as necessary. However, by including seek the solution is more general. We would be able to move around the file however we want, backwards and forwards, with seek if we wanted to.
So we see that we can capture $n and use it to store the file position between function calls. The challenge states that we are to called read_n with two parameters, the filename and the number of characters to read. As you can see, we do not need to keep sending the filename with each function call. The filename can also be a part of the closure!
That is the difference between read_maker0() and read_maker1(). The first returns a read_n function that matches the challenge specification of taking a filename and a number of characters to read. read_maker1() returns a function that only takes the number of characters to read, the function itself has a stored value for the file handle we want.
One small final thing to mention: anyone unfamiliar with read might notice that there is no checking to see if we attempt to read past the end of the file. That is because read will read all the characters it can and if it hits the end of the file it will stop. The return value from read is the number of characters successfully read. While we do not check that value in this code, if we did we would see that in this example the final read would return 2, which is clear in the output shown.
Part 2
You are given a sorted array of distinct integers @N and a target `$N``. Write a script to return the index of the given target if found otherwise place the target in the sorted array and return the index.
Solution
use strict;
use warnings;
sub find_insert{
my($list, $n) = @_;
if($n < $list->[0]){
unshift @{$list}, $n;
return 0;
}
if($n > $list->[@{$list} - 1]){
push @{$list}, $n;
return @{$list} - 1;
}
for(my $i = 0; $i < (@{$list} - 1); $i++){
return $i if $n == $list->[$i];
if($n > $list->[$i] && $n < $list->[$i + 1]){
splice(@{$list}, $i, 2, ($list->[$i], $n, $list->[$i + 1]));
return $i + 1;
}
}
}
MAIN:{
my(@N, $N, $i);
@N = (1, 2, 3, 4);
$N = 3;
$i = find_insert(\@N, $N);
print "$i\n";
@N = (1, 3, 5, 7);
$N = 6;
$i = find_insert(\@N, $N);
print "$i\n";
@N = (12, 14, 16, 18);
$N = 10;
$i = find_insert(\@N, $N);
print "$i\n";
@N = (11, 13, 15, 17);
$N = 19;
$i = find_insert(\@N, $N);
print "$i\n";
}
Sample Run
$ perl perl/ch-2.pl
2
3
0
4
Notes
While somewhat convoluted sounding at first this part of Challenge 098 ended up being fairly straightforward, especially when using splice to do any array insertions. Probably there are more “fun” ways to have done this but the intuitive way here has an almost comforting look to it. Reminds me of university computer lab exercises!
Anyway, the approach here is to consider the possible cases. find_insert starts off by checking to see if $n would belong at the very start or end of the array. If neither of those cases hold we loop over the array looking for where $n might be. If found in the array we return with the index, else we insert with splice.
The challenge never asks to see the modified array so I suppose it is possible to merely return where $n belongs without actually inserting it but that didn’t seem quite as sporting.
References
posted at: 21:34 by: Adam Russell | path: /perl | permanent link to this entry
2021-01-31
Perl Weekly Challenge 097
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given string $S containing alphabets A..Z only and a number $N. Write a script to encrypt the given string $S using Caesar Cipher with left shift of size $N.
Solution
use strict;
use warnings;
sub caesar_cypher{
my($s, $n) = @_;
my @cypher = map { unless(ord($_) == ord(' ')){
my $x = ((ord($_) - $n) < ord('A')?(ord($_) - $n + 26):(ord($_) - $n));
chr($x);
}
else{
$_
}
} split(//, $s);
return join("", @cypher);
}
MAIN:{
my($S, $N);
$S = "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG";
$N = 3;
print "$S\n";
print caesar_cypher($S, $N) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG
QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD
Notes
The basic approach here is pretty much the straightforward one: use the ascii values for the characters and subtract $n. In Perl we use the ord function to do this and the chr to go in the other direction, ascii value to character. The only thing we really need to be careful of is if subtracting $n takes us outside the ascii range for upper case letters, then we need to add 26 to get back in range.
Certain style instructions have been burned into my brain over the years and I find them almost impossible to deviate from. The one that applies here is Whenever possible do not use numeric literals. They are often poorly documented and become “magic numbers”, and make code readability and future debugging unnecessarily difficult. So it is in that spirit that I write, for example, ord(' ') instead of just 32.
Part 2
You are given a binary string $B and an integer $S. Write a script to split the binary string $B of size $S and then find the minimum number of flips required to make it all the same.
Solution
use strict;
use warnings;
use feature "bitwise";
sub substrings{
my($d, $s) = @_;
my @substrings;
for(my $i = 0; $i < length($d); $i+=$s){
push @substrings, substr($d, $i, $s);
}
return @substrings;
}
sub min_flips{
my($d, $s) = @_;
my @flips;
my @substrings = substrings($d, $s);
for my $digits (@substrings){
my $flip_count = 0;
map { $flip_count += unpack("%32b*", $digits ^. $_) } @substrings;
push @flips, $flip_count;
}
return [sort {$a <=> $b} @flips]->[0];
}
MAIN:{
my($B, $S);
$B = "101100101";
$S = 3;
print min_flips($B, $S) . " flips\n";
$B = "10110111";
$S = 4;
print min_flips($B, $S) . " flips\n";
}
Sample Run
$ perl perl/ch-2.pl
1 flips
2 flips
Notes
The substrings function is just a convenient wrapper around the code necessary to break the string into the right sized chunks. The assumption is that the string is evenly divisible into chunks of size $s. If we were not making this assumption we would need to add some zero padding for any unevenly sized substring.
Since use feature "bitwise"; is present the ^. is defined and the operands to ^. are taken to be bit strings and the result is itself a bit string.min_flips does a bitwise xor operation, pairwise comparing each substring in a map. Since xor is 1 only when the bits are different the result is a bit string of set bits, the ones needed to be flipped. unpack is used to sum these, and the result added $flip_count which is then pushed into an array. The minimum number of flips is determined by the smallest number in that array. The bitwise feature was introduced in Perl 5.22 and graduated from experimental status in Perl 5.28.
References
posted at: 11:11 by: Adam Russell | path: /perl | permanent link to this entry
2021-01-24
Perl Weekly Challenge 096
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a string $S. Write a script to reverse the order of words in the given string.
Solution
use strict;
use warnings;
sub reverse_words{
my($words) = @_;
if(@{$words}){
my $word = $words->[0];
my $a = reverse_words([@{$words}[1 .. (@{$words} - 1)]]);
$a->[@{$a}] = $word;
return $a;
}
return [];
}
MAIN:{
my($S, $reversed);
$S = "The Weekly Challenge";
$reversed = reverse_words([split(/\s+/, $S)]);
print join(" ", @{$reversed}) . "\n";
$S = " Perl and Raku are part of the same family ";
$reversed = reverse_words([split(/\s+/, $S)]);
print join(" ", @{$reversed}) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
Challenge Weekly The
family same the of part are Raku and Perl
Notes
My solution is done using recursion with the self-imposed restrictions
- do not use the reverse function.
- only access array elements in an ordinary way, without using any functions
Other than being a bit over engineered it works as required!
Part 2
You are given two strings $S1 and $S2. Write a script to find out the minimum operations required to convert $S1 into $S2. The operations can be insert, remove or replace a character.
Solution
use strict;
use warnings;
use Memoize;
memoize("edit_distance");
sub edit_distance{
my($s, $t) = @_;
if(length($s) == 0){
return length($t);
}
if(length($t) == 0){
return length($s);
}
my($s0, $t0) = (substr($s, 0, 1), substr($t, 0, 1));
if($s0 eq $t0){
return edit_distance(substr($s, 1), substr($t, 1));
}
my @sorted_distances = sort {$a <=> $b} (
edit_distance($s, substr($t, 1)),
edit_distance(substr($s, 1), $t),
edit_distance(substr($s, 1), substr($t, 1)),
);
return 1 + $sorted_distances[0];
}
MAIN:{
my $distance;
$distance = edit_distance("kitten", "sitting");
print "$distance\n";
$distance = edit_distance("sunday", "monday");
print "$distance\n";
}
Sample Run
$ perl perl/ch-2.pl
3
2
Notes
This code is a pretty faithful Perl translation of the algorithm presented in Haskell in the Wikipedia article for Levenshtein_distance. Like the code for Part 1 of this weeks Challenge this is a recursive procedure.
As noted in that article this algorithm is inefficient in that substrings are checked repeatedly. This code can be made more efficient by the use of Memoization so that the results for each substring are saved and re-used. In the interest of improving performance Memoize is used with the edit_distance function. While the code is now more efficient it really doesn’t have much effect on execution time for these short test strings. However, the code is now ready to handle much more significant sized strings.
References
posted at: 01:26 by: Adam Russell | path: /perl | permanent link to this entry