RabbitFarm

2021-07-18

A Genetic Algorithm solution to the Travelling Salesman Problem

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

Part 1

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

Solution


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

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

Sample Run


$ perl perl/ch-1.pl
8 
26

Notes

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

Part 2

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

Solution


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

use constant N => 7;

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

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

sub terminate{
    return true;
}

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

Sample Run


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

Notes

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

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

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

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

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

References

Challenge 121

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

2021-07-11

Swapping Bits / Time Angle

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

Part 1

You are given a positive integer $N less than or equal to 255. Write a script to swap the odd positioned bits with the even positioned bits and print the decimal equivalent of the new binary representation.

Solution


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

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

Sample Run


$ perl perl/ch-1.pl
154
33

Notes

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

Part 2

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

Solution


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

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

Sample Run


$ perl perl/ch-1.pl
35
120

Notes

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

References

Challenge 120

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

2021-07-04

Packing and Unpacking from vacation: The Weekly Challenge 119

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

Part 1

You are given a positive integer $N. Write a script to swap the two nibbles of the binary representation of the given number and print the decimal number of the new binary representation.

Solution


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

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

Sample Run


$ perl perl/ch-1.pl
86
33

Notes

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

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

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

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

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

References

Challenge 119

Network Byte Order

Perl Programmers Facebook Group

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

2021-06-20

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

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

Part 1

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

Solution


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

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

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

Sample Run


$ perl perl/ch-1.pl
12

Notes

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

Part 2

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

Solution


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

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

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

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

Sample Run


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

Notes

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

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

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

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

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

References

Challenge 117

Quantum Pascal's Triangle

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

2021-06-13

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

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

Part 1

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

Solution


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

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

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

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

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

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

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

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

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

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

Sample Run


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

Notes

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

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

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

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

Part 2

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

Solution


use strict;
use warnings;
use POSIX;

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

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

Sample Run


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

Notes

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

References

Challenge 116

Challenge 044 | Only 100, please

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

2021-06-05

The Weekly Challenge 115

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

Part 1

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

Solution


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

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

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

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

__DATA__
ab
bea
cd

Sample Run


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

Notes

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

The approach here is:

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

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

Part 2

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

Solution


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

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

Sample Run


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

Notes

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

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

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

References

Challenge 115

Pokemon Name Ladder

Weakly Connected Component

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

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

Challenge 114

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

Challenge 113

Depth First Traversal

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:

Combinations are generated using Algorithm::Combinatorics.

Duplicate array removal is facilitated by Array::Compare.

References

Challenge 112

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

Challenge 111

Binary Search

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

Challenge 110

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

Challenge 109

Sarvadaman D. S. Chowla

AI::Prolog

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

Challenge 108

perlguts

Bell Numbers

Bell Triangle

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

Challenge 107

Challenge 043

Perl::Analysis::Static

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:

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

Challenge 106

Repeating Decimal

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

Challenge 105

nth root by Newton’s method

Name Game Rules

Perl Formats

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:

References

Challenge 103 Chinese Zodiac

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.

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

Challenge 102

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

Challenge 100

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

Challenge 098

Perlmonks article on currying

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

ASCII Table

xor

Perl’s xor

bitwise feature

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

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

Memoization

Levenshtein distance

posted at: 01:26 by: Adam Russell | path: /perl | permanent link to this entry

2021-01-17

Perl Weekly Challenge 095

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

Part 1

You are given a number $N. Write a script to figure out if the given number is a Palindrome. Print 1 if true, otherwise 0.

Solution


use strict;
use warnings;

use boolean;

sub is_palindrome{
    my($n) = @_;
    return false if $n < 0;
    my @digits = split(//, $n);
    if(@digits % 2 == 0){
        do{
            my $a = shift @digits;
            my $b = pop @digits;
            return false if $a != $b;
        }while(@digits);
        return true;
    }
    while(@digits != 1){
        my $a = shift @digits;
        my $b = pop @digits;
        return false if $a != $b;
    };
    return true;
}

MAIN:{
    print is_palindrome(1221);
    print "\n";
    print is_palindrome(-101);
    print "\n";
    print is_palindrome(90);
    print "\n";
}

Sample Run


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

Notes

One assumption is made and that is that the input is a valid integer.

My approach here is straightforward iteration and matches what one might do manually: work inwards from both ends and if at any point there is not a match of the two elements being compared then return false. If we make it all the way to the middle then return true. Here the middle is either an empty array, in the case of an even number of elements or, in the case of an odd number of elements, an array of length 1.

The case of a single digit has no special handling, if the number has an odd number of digits but that odd number happens to be 1 then the loop is not entered and we just return true.

Part 2

Write a script to demonstrate Stack operations.

Solution


use strict;
use warnings;

use Stack;

my $stack = new Stack();
$stack->push(2);
$stack->push(-1);
$stack->push(0);
$stack->pop;       
print $stack->top . "\n"; 
$stack->push(0);
print $stack->min . "\n"; 

The Stack module used is of my own making. The next listing is that code.


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

    struct(
        data => q/@/
    );

    sub push{
        my($self, $n) = @_;
        push @{$self->data()}, $n;
    }

    sub pop{
        my($self, $n) = @_;
        pop @{$self->data()};
    }

    sub top{
        my($self, $n) = @_;
        @{$self->data()}[@{$self->data()} - 1];
    }
    
    sub min{
        my($self, $n) = @_;
        my @sorted = sort {$a <=> $b} @{$self->data()};
        return $sorted[0];
    }
    true;
}  

Sample Run


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

Notes

Like last week’s LinkedList module I use Class::Struct to create the Stack module.

Class::Struct creates accessors for all the class variables automatically. In this way, by calling $self->data(), we get a reference to the internal array data and perform the required Stack operations.

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

2021-01-10

Perl Weekly Challenge 094

Part 1

You are given an array of strings @S. Write a script to group Anagrams together in any random order.

Solution


use strict;
use warnings;
my %letter_factor = (
    e => 2,
    t => 3,
    a => 5,
    o => 7,
    i => 11,
    n => 13,
    s => 17,
    h => 19,
    r => 23,
    d => 29,
    l => 31,
    c => 37,
    u => 41,
    m => 43,
    w => 47,
    f => 53,
    g => 59,
    y => 61,
    p => 67,
    b => 71,
    v => 73,
    k => 79,
    j => 83,
    x => 89,
    q => 97,
    z => 101  
);  

MAIN:{
    my $word;
    my %anagrams;
    while($word = ){
        chomp($word); 
        my @letters = split(//, $word);
        my $word_product = 1;
        map {$word_product *= $_} map{$letter_factor{$_}} @letters;
        push @{$anagrams{$word_product}} , $word if $anagrams{$word_product};  
        $anagrams{$word_product} = [$word] unless $anagrams{$word_product};  
    }  
    close(DATA);
    print "Organized anagrams:\n";
    for my $key (keys %anagrams){
        print "  "; 
        for my $word (@{$anagrams{$key}}){
            print "$word ";
        }
        print "\n";
    }   
}   

__DATA__
opt
bat
saw
tab
pot
top
was

Sample Run


$ perl ch-1.pl
Organized anagrams:
  saw was 
  bat tab 
  opt pot top 

Notes

Part 2

You are given a binary tree. Write a script to represent the given binary tree as an object and flatten it to a linked list object. Finally, print the linked list object.

Solution


use strict;
use warnings;

use Graph;
use LinkedList;

sub build_linked_list{ 
    my($tree) = @_;
    my $linked_list = new LinkedList(); 
    my @paths = build_paths($tree);
    my $root = $paths[0]->[0]; 
    my $next = $linked_list->insert($root, undef); 
    for my $path (@paths){
        for my $node (@{$path}){
            $next = $linked_list->insert($node, $next) if !$linked_list->in_list($node);    
        }
    } 
    return $linked_list;
}

sub build_paths {
   my ($graph) = @_;
   my @paths;
   local *_helper = sub{
      my $v = $_[-1];
      my @successors = $graph->successors($v);
      if(@successors){
         _helper(@_, $_) for @successors;
      } 
      else{
         unshift @paths, [@_];
      }
   };
   _helper($_) for $graph->source_vertices();
   return @paths;
}

MAIN:{
    my $Tree;
    $Tree = new Graph();
    $Tree->add_vertices(1, 2, 3, 4, 5, 6, 7);
    $Tree->add_edge(1, 2);
    $Tree->add_edge(1, 3);
    $Tree->add_edge(2, 4);
    $Tree->add_edge(2, 5);
    $Tree->add_edge(5, 6);
    $Tree->add_edge(5, 7);
    print build_linked_list($Tree)->stringify();
}

The LinkedList module used is of my own making. I am using a somewhat modified version of the LinkedList module I made for Challenge 059. Next is what that code looks like.


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

        struct(
            data => q/$/,
            next => q/Node/
        );
    }

    struct(
        head => q/Node/
    );

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

    sub insert{
        my($self, $data, $previous) = @_;
        if(!$previous){
            $previous=new Node(data => undef, next => undef);
            $self->head($previous);
        }
        my $next=new Node(data => $data, next => undef);
        $previous->next($next);
        return $next;
    }

    sub in_list{
        my($self, $k) = @_;
        my $previous = $self->head();
        my $next = $self->head()->next();
        tie my %node_value, "Tie::RefHash";
        while($next){
            return true if($next->data() == $k); 
            $next = $next->next(); 
        }
        return false;
    }
    true;
}

Sample Run


$ perl -I. ch-2.pl
1 -> 2 -> 4 -> 5 -> 6 -> 7 -> 3

Notes

References

Lewand Ordering

Fundamental Theorem of Arithmetic

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

2021-01-03

Perl Weekly Challenge 093

Part 1

You are given set of co-ordinates @N. Write a script to count maximum points on a straight line when given co-ordinates plotted on 2-d plane.

Solution


use strict;
use warnings;
##
# You are given set of co-ordinates @N.
# Write a script to count maximum points 
# on a straight line when given co-ordinates 
# plotted on 2-d plane.
##
sub triangle_area{
    my($i, $j, $k) = @_;
    return ($i->[0] * ($j->[1] - $k->[1])) 
         + ($j->[0] * ($k->[1] - $i->[1]))
         + ($k->[0] * ($i->[1] - $j->[1]));
}

sub collinear_points{
    my(@points) = @_;
    my @collinear;
    for my $i (@points){
        for my $j (@points){
            for my $k (@points){
                if(triangle_area($i, $j, $k) == 0){
                    my $i_string = join(",", @{$i});
                    my $j_string = join(",", @{$j});
                    my $k_string = join(",", @{$k});
                    if(($i_string ne $j_string) && ($i_string ne $k_string) && ($j_string ne $k_string)){
                        my $has_i = grep { $i_string eq join(",", @{$_}) } @collinear;
                        push @collinear, $i if !$has_i;
                        my $has_j = grep { $j_string eq join(",", @{$_}) } @collinear;
                        push @collinear, $j if !$has_j;
                        my $has_k = grep { $k_string eq join(",", @{$_}) } @collinear;
                        push @collinear, $k if !$has_k;
                    }
                }
            }
        }
    }
    return @collinear;
}

MAIN:{
    my @N;
    @N = ([5,3], [1,1], [2,2], [3,1], [1,3]);
    my @collinear = collinear_points(@N);
    print "There are a maximum of " . @collinear . " collinear points.\n"
}

Sample Run


$ perl perl/ch-1.pl
There are a maximum of 3 collinear points.

Notes

Keep in mind that any two points determine a line. Therefore to consider all possible non-trivial lines we need to review all triples of points. This method will work in the most general case when the starting data may contain multiple lines with a larger number of points.

In determining collinearity I calculate the area of a triangle using the triple of points. If the area is zero we know that all the points lay on the same line.

Part 2

You are given a binary tree containing only the numbers 0-9. Write a script to sum all possible paths from root to leaf.

Solution


use strict;
use warnings;
##
# You are given a binary tree containing 
# only the numbers 0-9.
# Write a script to sum all possible paths 
# from root to leaf.
##
use Graph;

sub travserse_sum{
    my($tree) = @_;
    my @paths = build_paths($tree);
    my $path_sum = 0;
    for my $path (@paths){
        $path_sum +=  unpack("%32C*", pack("C*", @{$path})); 
    }
    return $path_sum;
}

sub build_paths {
   my ($graph) = @_;
   my @paths;
   local *_helper = sub{
      my $v = $_[-1];
      my @successors = $graph->successors($v);
      if(@successors){
         _helper(@_, $_) for @successors;
      } 
      else{
         push @paths, [@_];
      }
   };
   _helper($_) for $graph->source_vertices();
   return @paths;
}

MAIN:{
    my $Tree;
    $Tree = new Graph();
    $Tree->add_vertices(1, 2, 3, 4);
    $Tree->add_edge(1, 2);
    $Tree->add_edge(2, 3);
    $Tree->add_edge(2, 4);
    print travserse_sum($Tree) . "\n";
    
    $Tree = new Graph();
    $Tree->add_vertices(1, 2, 3, 4, 5, 6);
    $Tree->add_edge(1, 2);
    $Tree->add_edge(1, 3);
    $Tree->add_edge(2, 4);
    $Tree->add_edge(3, 5);
    $Tree->add_edge(3, 6);
    print travserse_sum($Tree) . "\n";
}

Sample Run


$ perl perl/ch-2.pl
13
26

Notes

This is straightforward enough, at a high level anyway: (1) Get all paths and then (2) sum all the nodes on the paths.

References

Collinear Points

All Paths

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

2020-12-13

Perl Weekly Challenge 090

Part 1

Write a script to print the nucleiobase count in the given DNA sequence. Also print the complementary sequence where Thymine (T) on one strand is always facing an adenine (A) and vice versa; guanine (G) is always facing a cytosine (C) and vice versa.

Solution


use strict;
use warnings;
##
# Write a script to print  the nucleiobase count in
# the given DNA sequence. Also print the complementary 
# sequence where Thymine (T) on one strand is always 
# facing an adenine (A) and vice versa; guanine (G) is 
# always facing a cytosine (C) and vice versa.
##
use constant SEQUENCE => "GTAAACCCCTTTTCATTTAGACAGATCGACTCCTTATCCATTCTCAGAGATGTGTTGCTGGTCGCCG";
my %nucleotide_map = (
    "T" => "A", 
    "A" => "T", 
    "G" => "C", 
    "C" => "G" 
);    

sub complementary_sequence{
    my($sequence) = @_;
    my @complement = map { $nucleotide_map{$_} } split(//, $sequence);
    return @complement; 
} 

MAIN:{
    print "length of sequence: " . length(SEQUENCE) . "\n";
    print "complementary sequence: " . join("", complementary_sequence(SEQUENCE)) . "\n";      
} 

Sample Run


$ perl perl/ch-1.pl 
length of sequence: 67
complementary sequence: CATTTGGGGAAAAGTAAATCTGTCTAGCTGAGGAATAGGTAAGAGTCTCTACACAACGACCAGCGGC

Notes

When doing this problem I recalled a talk I attended at YAPC 2009. In that talk Steven Lembark discussed how allocating array storage for very long arrays, such as DNA sequences!, could result in memory issues. He presented an interesting use of LinkedLists to deal with this. I have to say that I am not sure if Perl’s internals have changed in some way that these concerns are still valid. If you are looking to deal with actual (tremendously large) DNA sequences and not the sample shown here this would be something to consider!

Part 2

You are given two positive numbers $A and $B. Write a script to demonstrate Ethiopian Multiplication using the given numbers.

Solution


use strict;
use warnings;
##
# You are given two positive numbers $A and $B.
# Write a script to demonstrate Ethiopian Multiplication 
# using the given numbers.
##
sub ethiopian_multiplication{
    my($a, $b) = @_;
    my @steps;
    my $product = 0; 
    my ($x, $y) = ($a, $b); 
    do{
        $x = int($x / 2);
        $y = $y * 2;
        push @steps, [$x, $y] if $x % 2 != 0;
    }until $steps[-1]->[0] == 1; 
    for my $step (@steps){
        $product += $step->[1];
    } 
    return $product; 
}

MAIN:{
    my($A, $B) = (14, 12);
    print "$A x $B = " . ethiopian_multiplication($A, $B) . "\n";
}

Sample Run


$ perl perl/ch-2.pl 
14 x 12 = 168

Notes

My implementation here follows pretty directly from the definition of the procedure. At each step there is a check to see if the odd/even condition holds and if true the result for that step is saved to an array. After the loop terminates the results are evaluated.

References

Ethiopian Multiplication

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

2020-12-06

Perl Weekly Challenge 089

Part 1

You are given a positive integer $N. Write a script to sum GCD of all possible unique pairs between 1 and $N.

Solution


use strict;
use warnings;
##
# You are given a positive integer $N. Write a script to sum GCD of all possible 
# unique pairs between 1 and $N.
##

sub all_unique_pairs{
    my($n) = @_;
    my %pairs;
    for my $i (1 .. $n){
        for my $j (1 .. $n){
            $pairs{"$i-$j"} = -1 unless $pairs{"$i-$j"} || $pairs{"$j-$i"} || $i == $j; 
        }
    }
    return sort keys %pairs;
}

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

MAIN:{
    my $gcd_sum = 0; 
    my @values =  all_unique_pairs(3);
    for my $pair (@values[0 .. @values - 2]){
        my($i, $j) = split(/-/, $pair);
        $gcd_sum += euclid($i, $j);
        print "gcd($i, $j) + ";  
    }
    my ($i, $j) = split(/-/, $values[-1]); 
    $gcd_sum += euclid($i, $j);
    print "gcd($i, $j) = $gcd_sum\n";  

    $gcd_sum = 0; 
    @values =  all_unique_pairs(4);
    for my $pair (@values[0 .. @values - 2]){
        my($i, $j) = split(/-/, $pair);
        $gcd_sum += euclid($i, $j);
        print "gcd($i, $j) + ";  
    }
    ($i, $j) = split(/-/, $values[-1]); 
    $gcd_sum += euclid($i, $j);
    print "gcd($i, $j) = $gcd_sum\n";  

}

Sample Run


$ perl perl/ch-1.pl
gcd(1, 2) + gcd(1, 3) + gcd(2, 3) = 3
gcd(1, 2) + gcd(1, 3) + gcd(1, 4) + gcd(2, 3) + gcd(2, 4) + gcd(3, 4) = 7

Notes

Sometimes before jumping into my own solutions I do a little research on the topics at hand. In doing so for this I came across this beautifully succinct implementation of Euclid’s algorithm. I decided to use that here for the GCD computation.

Ok, with that sorted out, what is left is to generate all the unique pairs and print the results. I generate the pairs in all_unique_pairs by saving the pairs as hash heys, stringified by joining them with a ‘-’. When printing them out later it is necessary to split on the ‘-’.

Part 2

You are given m x n matrix of positive integers. Write a script to print spiral matrix as a list.

Solution


use strict;
use warnings;
##
# Write a script to display matrix as below with numbers 1 - 9. 
# Please make sure numbers are used once.
##
use boolean;
use Math::GSL::Permutation q/:all/;

sub validate {
    my($a, $b, $c, $d, $e, $f, $g, $h, $i) = @_;
    return false if ($a + $b + $c) != 15;
    return false if ($d + $e + $f) != 15;
    return false if ($g + $h + $i) != 15;
    return false if ($a + $d + $g) != 15;
    return false if ($b + $e + $h) != 15;
    return false if ($c + $f + $i) != 15;
    return false if ($a + $e + $i) != 15;
    return false if ($c + $e + $g) != 15;
    return true;
}

sub print_matrix {
    my($a, $b, $c, $d, $e, $f, $g, $h, $i) = @_;
    print "[ $a $b $c ]\n";
    print "[ $d $e $f ]\n";
    print "[ $g $h $i ]\n";
}    

MAIN:{
    my $permutation = new Math::GSL::Permutation(9);
    while(gsl_permutation_next($permutation->raw) == 0){
        my @values =  $permutation->as_list();
        @values = map { $_ + 1 } @values;
        do { 
            print_matrix(@values);
            print "\n";
        }if validate(@values);  
    }
}

Sample Run


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

[ 2 9 4 ]
[ 7 5 3 ]
[ 6 1 8 ]

[ 4 3 8 ]
[ 9 5 1 ]
[ 2 7 6 ]

[ 4 9 2 ]
[ 3 5 7 ]
[ 8 1 6 ]

[ 6 1 8 ]
[ 7 5 3 ]
[ 2 9 4 ]

[ 6 7 2 ]
[ 1 5 9 ]
[ 8 3 4 ]

[ 8 1 6 ]
[ 3 5 7 ]
[ 4 9 2 ]

[ 8 3 4 ]
[ 1 5 9 ]
[ 6 7 2 ]

Notes

The validate function is pretty straight forward, especially so since I intentionally wrote it to be blazingly obvious what is going on!

The real work is in generating the permutations that get checked. For that I used Math::GSL::Permutation which, as the name implies, is an excellent module which wraps the Gnu Scientific Library. Well, the module is quite solid aside from the documentation which is a bit rough and often requires referring to the GSL documentation on the functions being wrapped.

The main point to know about Math::GSL::Permutation is that it only creates permutations on integers. As Perl programmers we get spoiled by being able to easily manipulate any type of data. If you are interested in permuting lists of arbitrary elements you could use Math::GSL::Permutation to permute the indices, but not the elements themselves.

One final note, having a conditional after the expression is just one of those classic examples of Perl expressiveness, but I seldom see the do/if form. A do/if allows you to have multiple statements, a whole block, execute with the if coming afterwards. Obviously just syntactic sugar for the more common if{} but I prefer it in cases like this where there is no need for an else.

References

Euclid’s Algorithm

Math::GSL

GSL

GSL Permutations Example

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

2020-11-29

Perl Weekly Challenge 088

Part 1

You are given an array of positive integers @N. Write a script to return an array @M where $M[i] is the product of all elements of @N except the index $N[i].

Solution


use strict;
use warnings;
##
# You are given an array of positive integers @N.
# Write a script to return an array @M where $M[i] 
# is the product of all elements of @N except the index $N[i].
##
sub list_product{
    my @numbers = @_;
    my $product = 1;
    map {$product *= $_ } @numbers;
    return $product;
}

MAIN:{
    my(@N, @M);
    @N = (5, 2, 1, 4, 3);
    for my $i (0 .. (@N - 1)){
        my @numbers = @N[0 .. $i - 1, $i+1 .. (@N - 1)];
        push @M, list_product(@numbers);
    }
    print "(" . join(", ", @M) . ")\n";
    @M = ();
    @N = (2, 1, 4, 3);
    for my $i (0 .. (@N - 1)){
        my @numbers = @N[0 .. $i - 1, $i+1 .. (@N - 1)];
        push @M, list_product(@numbers);
    }
    print "(" . join(", ", @M) . ")\n";
}

Sample Run


$ perl perl/ch-1.pl
(24, 60, 120, 30, 40)
(12, 24, 6, 8)

Notes

Taking the product of a list of numbers is a well known perl idiom using map. To keep the code somewhat cleaner I placed the list_product computation in it’s own subroutine. The trickiest part, then, is to make sure the list has the right element removed. This is done using array slices. as we loop over the array of numbers we construct a list of indices which do not include the current element.

Another possible approach would be to use a map inside the loop to identify the elements we want to retain. I decided against that approach since it would be a second complete full iteration over the list. To be fair, I don’t necessarily try to always make these challenge solutions all that efficient, but this just happened to strike me as particularly egregious at the time!

Part 2

You are given m x n matrix of positive integers. Write a script to print spiral matrix as a list.

Solution


use strict;
use warnings;
##
# You are given m x n matrix of positive integers.
# Write a script to print spiral matrix as a list.
##
sub print_remove_top{
    my(@matrix) = @_;
    print join(", ", @{$matrix[0]}) . ", ";
    splice(@matrix, 0, 1);
    return @matrix;
}

sub print_remove_right{
    my(@matrix) = @_;
    my @right;
    for my $row (@matrix){
        push @right, $row->[-1];
        my @a = @{$row}[0 .. (@{$row} - 2)];
        $row = \@a;
    }
    print join(", ", @right) . ", ";
    return @matrix;
}

sub print_remove_bottom{
    my(@matrix) = @_;
    print join(", ", reverse(@{$matrix[-1]})) . ", ";
    splice(@matrix, -1);
    return @matrix;
}

sub print_remove_left{
    my(@matrix) = @_;
    my @left;
    for my $row (@matrix){
        push @left, $row->[0];
        my @a = @{$row}[1 .. (@{$row} - 1)];
        $row = \@a;
    }
    print join(", ", reverse(@left)) . ", ";
    return @matrix;
}

sub spiral_print{
    my(@matrix) = @_;
    print "[";
    {
        @matrix = print_remove_top(@matrix) if @matrix;
        @matrix = print_remove_right(@matrix) if @matrix;
        @matrix = print_remove_bottom(@matrix) if @matrix;
        @matrix = print_remove_left(@matrix) if @matrix;
        redo if @matrix;
    }
    print "\b\b]\n";
}

MAIN:{
    spiral_print(
        [1, 2, 3],
        [4, 5, 6],
        [7, 8, 9]
    );
    spiral_print(
        [ 1,  2,  3,  4],
        [ 5,  6,  7,  8],
        [ 9, 10, 11, 12],
        [13, 14, 15, 16]
    );
}

Sample Run


$ perl perl/ch-2.pl
[1, 2, 3, 6, 9, 8, 7, 4, 5] 
[1, 2, 3, 4, 8, 12, 16, 15, 14, 13, 9, 5, 6, 7, 11, 10] 

Notes

The spiral print works in a repeated pattern from the outside in: top row, right column, bottom row, left column. My solution put each print/remove step of this pattern in their own subroutines. A few things worth pointing out

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

2020-11-22

Perl Weekly Challenge 087

Part 1

You are given an unsorted array of integers @N. Write a script to find the longest consecutive sequence. Print 0 if no sequence found.

Solution


use strict;
use warnings;
##
# You are given an unsorted array of integers @N.
# Write a script to find the longest consecutive sequence. 
# Print 0 if no sequence found.
##
sub min_max{
    my @a = @_;
    my($min, $max) = ($a[0], $a[0]);
    for my $x (@a){
        $min = $x if($x < $min);
        $max = $x if($x > $max);
    }
    return ($min, $max);
}

sub longest_sequence{
    my @sequences = @_;
    my @max = (0);
    for my $sequence (@sequences){
        @max = @{$sequence} if((@{$sequence} > @max) && (@{$sequence} > 1));
    }
    return @max;
}

sub continuous_sub_sequences{
    my @a = @_;
    my($min, $max) = min_max(@a);
    my @sub_sequences;
    my $sub_sequence = [];
    while($min <= $max){
        my $test = grep {$_ == $min} @a;
        if($test){
            push @{$sub_sequence}, $min;
        }
        else{
            push @sub_sequences, $sub_sequence if(@{$sub_sequence} > 0);
            $sub_sequence = [];
        }
        $min++;
    }
    return @sub_sequences;
}

MAIN:{
    my @N = (100, 4, 50, 3, 2);
    my @sequences = continuous_sub_sequences(@N);
    my @max = longest_sequence(@sequences);
    print join(",", @max) . "\n";
    @N = (20, 30, 10, 40, 50);
    @sequences = continuous_sub_sequences(@N);
    @max = longest_sequence(@sequences);
    print join(",", @max) . "\n";
    @N = (20, 19, 9, 11, 10);
    @sequences = continuous_sub_sequences(@N);
    @max = longest_sequence(@sequences);
    print join(",", @max) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
2,3,4
0
9,10,11

Notes

I decided to force myself to work with an artificial constraint as a way fo forcing a little bit more creativity in my solution. When I first looked at this problem I immediately thought “ok, first thing should be to sort the list”. Based on that first impression my self-imposed constraint was to “solve this without using a sort”!

What I did can be summarized as follows: 1. Find the minimum and maximum numbers in the given list. 2. Starting with the minimum number generate test sequences by incrementing upwards towards the maximum list value. 3. As each new element of the test sequence is added test to see if it is in the original list. 4. If it is in the list, good, keep going. 5. If it is not in the list then save the test sequence generated up to that point and continue with a new test sequence. 6. Return all successful test sequences and determine the longest one.

The most blatant inefficiency to this approach is when lists are sparse. For example, suppose we are given (2, 100000000, 3, 4, 5) then we would be iterating from 2 to 100000000. An approach using a sorted list would basically need only loop over the elements of the list, checking to see if the next element was 1 larger than the previous.

Part 2

You are given matrix m x n with 0 and 1. Write a script to find the largest rectangle containing only 1. Print 0 if none found.

Solution


use strict;
use warnings;
##
# You are given matrix m x n with 0 and 1.
# Write a script to find the largest rectangle 
# containing only 1. Print 0 if none found.
##
use boolean;

sub print_solution{
    my($m, $n) = @_;
    if(!$m || !$n){
        print "0\n";
    }
    else{
        for (1 .. $n){
            print "[". join(" ", (1)x $m) . "]\n";
        }       
    }
}

sub evaluate{
    my($m, $n, $matrix) = @_;
    my $row_string = join(",", (1) x $m);
    my $columns = 0;
    for my $row (@{$matrix}){
        my $test = join(",", @{$row});
        if(index($test, $row_string) > -1){
            $columns++;
            return true if($columns == $n);
        }
        else{
            $columns = 0;
        }
    }
    return false;
}

sub largest_rectangle{
    my @matrix = @_;
    my $rows = @{$matrix[0]};
    my $columns = @matrix;
    my $max_area = 0;
    my @rectangle;
    for my $m (2 .. $columns){
        for my $n (1 .. $rows){
            if(evaluate($m, $n, \@matrix)){
                if(($m * $n) > $max_area){
                    $max_area = ($m * $n);
                    @rectangle = ($m, $n);
                }
            }
        }
    }
    return @rectangle;
}

MAIN:{
    my @MATRIX = (
        [0, 0, 0, 1, 0, 0],
        [1, 1, 1, 0, 0, 0],
        [0, 0, 1, 0, 0, 1],
        [1, 1, 1, 1, 1, 0],
        [1, 1, 1, 1, 1, 0]
    );
    print_solution(largest_rectangle(@MATRIX));
    @MATRIX = (
        [1, 0, 1, 0, 1, 0],
        [0, 1, 0, 1, 0, 1],
        [1, 0, 1, 0, 1, 0],
        [0, 1, 0, 1, 0, 1]
    );
    print_solution(largest_rectangle(@MATRIX));
    @MATRIX = (
        [0, 0, 0, 1, 1, 1],
        [1, 1, 1, 1, 1, 1],
        [0, 0, 1, 0, 0, 1],
        [0, 0, 1, 1, 1, 1],
        [0, 0, 1, 1, 1, 1]
    );
    print_solution(largest_rectangle(@MATRIX));  
}

Sample Run


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

Notes

Unlike Part 1 I did not necessarily have a self-imposed constraint other than to try and be as creative as possible. I’ll only know when I look at other submitted solutions if I was really all that relatively clever or not!

Here I do the following: 1. Check the size of the given matrix 2. Test the matrix for all possible sub-matrix sizes. 3. For all found sub-matrices determine the largest one.

For checking the presence of sub-matrices I join the rows into strings and then use index to see if they appear in a given row or not. To determine if a sub-matrix is the largest I compare the areas of the “rectangles”.

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

2020-11-15

Perl Weekly Challenge 086

Part 1

You are given an array of integers @N and an integer $A. Write a script to find find if there exists a pair of elements in the array whose difference is $A. Print 1 if exists otherwise 0.

Solution


use strict;
use warnings;
##
# You are given an array of integers @N and an integer $A.
# Write a script to find find if there exists a pair of elements 
# in the array whose difference is $A.
# Print 1 if exists otherwise 0.
##
use boolean;
use Math::Combinatorics;

sub build_constraints{
    my @constraints;
    my $a_not_equal_b = sub { $_[0] != $_[1] };
    my $difference_equal_n = sub { $_[0] - $_[1] == $_[2] };
    return (
       $a_not_equal_b,
       $difference_equal_n
    );
}

MAIN:{
    my $combinations = Math::Combinatorics->new(
                           count => 2,
                           data => [@ARGV[1 .. @ARGV - 1]],
                       );
    my $found = false;  
    my ($check_equal, $check_difference) = build_constraints();           
    while(my @combination = $combinations->next_combination()){  
        if($check_equal->(@combination) && $check_difference->(@combination, $ARGV[0])){
            $found = true;
            print "1\n"; last;
        }
    }
    print "0\n" if(!$found);
}

Sample Run


$ perl perl/ch-1.pl 15 10 30 20 50 40
0
$ perl perl/ch-1.pl 7 10 8 12 15 5
1

Notes

This is a fairly silly use of the constraint programming approach I used last week. Like last time I generate all combinations and test them using a filtering approach. The filter is an array of constraint functions. Here we just have two simple constraints though!

Part 2

You are given Sudoku puzzle (9x9). Write a script to complete the puzzle

Notes

I didn’t have a chance to implement a solution in Perl. I would have used a similar constraint approach if I did. This is a natural use for Prolog and if you’re interested in reading in my Prolog implementation you can go here.

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

2020-11-08

Perl Weekly Challenge 085

Part 1

You are given an array of real numbers greater than zero. Write a script to find if there exists a triplet (a,b,c) such that 1 < a+b+c < 2. Print 1 if you succeed otherwise 0.

Solution


use strict;
use warnings;
##
# You are given an array of real numbers greater than zero.
# Write a script to find if there exists a triplet (a,b,c) 
# such that 1 < a+b+c < 2. Print 1 if you succeed otherwise 0.
##
use boolean;
use Math::Combinatorics;

sub build_constraints{
    my @constraints;
    my $a_not_equal_b = sub { $_[0] != $_[1] };
    my $a_not_equal_c = sub { $_[0] != $_[2] };
    my $b_not_equal_c = sub { $_[1] != $_[2] };
    my $sum_greater_than_1 = sub { 1 < ($_[0] + $_[1] + $_[2]) };
    my $sum_less_than_2 = sub { 2 > ($_[0] + $_[1] + $_[2]) };
    return (
       $a_not_equal_b,
       $a_not_equal_c,
       $b_not_equal_c,
       $sum_greater_than_1,
       $sum_less_than_2
    );
}

MAIN:{
    my $combinations = Math::Combinatorics->new(
                           count => 3,
                           data => [@ARGV],
                       );
    my $found;                  
    while(my @combination = $combinations->next_combination()){  
        $found = true;  
        for my $constraint (build_constraints()){
            if(!$constraint->(@combination)){
                $found = false;
                last;
            }
        }
        do{ print "1\n"; last; } if($found);
    }
    print "0\n" if(!$found);
}

Sample Run


$ perl perl/ch-1.pl 0.1 1.2 3.4 0.2
1
$ perl perl/ch-1.pl 1.1 1.2 3.4 0.2
0

Notes

I decided to try a constraint programming approach for this. While there are several modules for doing this available on CPAN I didn’t want to quite go so deep down that rabbithole. Instead I took the simpler path of implementing each constraint as a subroutine stored in an array. For each candidate combination the constraints are tests. Since all constraints must be satisfied if any one returns a false value then we can move immediately to the next combination.

Part 2

You are given a positive integer $N. Write a script to find if it can be expressed as a ** b where a > 0 and b > 1. Print 1 if you succeed otherwise 0.

Solution


use strict;
use warnings;
##
# You are given a positive integer $N.
# Write a script to find if it can be expressed
# as a ^ b where a > 0 and b > 1. 
# Print 1 if you succeed otherwise 0.
##
use boolean;

sub log_a{
    my($a, $n) = @_;
    return log($n)/log($a);
}

MAIN:{
    my $N = $ARGV[0];
    my $found = false;                  
    for my $a (2 .. $N){ 
        my $b = log_a($a, $N);
        if($b =~ /^[-]?\d+$/ && $b > 1){ 
            print "1\n";
            $found = true;
            last;
        }
    }
    print "0\n" if(!$found);
}

Sample Run


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

Notes

I was tempted to repeat roughly the same design as Part 1 and use constraints but that really would be over engineering it! Instead here we just loop over all possible values $a and test using logarithms to see if $b holds an integer value. There seems to be a number of ways to do the test to determine if a scalar holds an integer but a regex seems maybe the most idiomatically Perlish way.

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

2020-11-01

Perl Weekly Challenge 084

Part 1

You are given an integer $N. Write a script to reverse the given integer and print the result. Print 0 if the result doesn’t fit in 32-bit signed integer.

Solution


use strict;
use warnings;
##
# You are given an integer $N.
# Write a script to reverse the given integer and print the result. 
# Print 0 if the result doesn’t fit in 32-bit signed integer.
##
use Config;
use boolean;
use constant MAX_32BIT_SIGNED => 2_147_483_647;

sub reverse_digits{
    my($n) = @_;
    return 0 if $n > MAX_32BIT_SIGNED || $n < -1*MAX_32BIT_SIGNED;
    my $negative = $n < 0 ? true : false;
    $n = abs($n) if $negative;
    return join("", reverse split(//, $n)) if !$negative;
    return "-" . join("", reverse split(//, $n));
}

MAIN:{
    my $A = $ARGV[0];
    print reverse_digits($A) . "\n";   
}

Sample Run


$ perl perl/ch-1.pl -123452
-254321
$ perl perl/ch-1.pl 12345
54321
$ perl perl/ch-1.pl -2147483647
-7463847412
$ perl perl/ch-1.pl -2147483648
0
$ perl perl/ch-1.pl 2147483647
7463847412
$ perl perl/ch-1.pl 2147483
3847412

Notes

Before starting this I did a little research and found some interesting articles. This Perlmonks thread covers the topic on the size in bytes of integers in Perl. This thread gets into how to detect overflow. In this challenge, however, we don’t need to really know any of this since the perl I am using (5.28.0) on my Mac Mini (running OS X) can easily accomodate much larger numbers than the 32-bit signed restriction placed here. All that need be done is check to see if the number is above or below this maximum/minimum.

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

2020-10-25

Perl Weekly Challenge 083

Part 1

You are given a string $S with 3 or more words. Write a script to find the length of the string except the first and last words ignoring whitespace.

Solution


use strict;
use warnings;
##
# You are given a string $S with 3 or more words.
# Write a script to find the length of the string 
# except the first and last words ignoring whitespace.
##
sub count_most_words{
    my ($s) = @_;
    my $count = 0;
    my @a = split(/\s/, $s);
    map {$count += tr/a-zA-Z//d} @a[1 .. (@a - 2)];
    return $count;
}

MAIN:{
    my $S;
    $S = "The Weekly Challenge";
    print "$S --> " . count_most_words($S) . "\n";
    $S = "The purpose of our lives is to be happy";
    print "$S --> " . count_most_words($S) . "\n";
}

Sample Run


$ perl perl/ch-1.pl
The Weekly Challenge --> 6
The purpose of our lives is to be happy --> 23

Notes

Anytime I need to count characters I immediately think of tr. tr will, of course, do character replacements but it’s return value is the number of characters which have been effected. Here with the d option the matching characters are just deleted. This code would work exactly just as well with the d but I figured it’d be actually less confusing to have it there and make it more clear what it was doing.

Part 2

You are given an array @A of positive numbers. Write a script to flip the sign of some members of the given array so that the sum of the all members is minimum non-negative.


use strict;
use warnings;
##
# You are given an array @A of positive numbers.
# Write a script to flip the sign of some members 
# of the given array so that the sum of the all 
# members is minimum non-negative.
##
sub try_all_flips{
    my(@a) = @_;
    my @minimum = (undef, undef, []); 
    for my $i (0 .. (2**(@a) - 1)){
        my $b = sprintf("%0" . @a . "b", $i); 
        my @b = split(//, $b);
        my $flip_count = 0;
        map {$flip_count++ if $_ == 1} @b;
        my @f;
        for my $i (0 .. (@b - 1)){
            if($b[$i] == 1){
                push @f, (-1) * $a[$i];
            }
            else{
                push @f, $a[$i];
            }
        }
        my $sum = unpack("%32I*", pack("I*", @f)); 
        if(!defined($minimum[0]) || ($sum <= $minimum[0] && $sum >= 0)){
            if(defined($minimum[0]) && $sum == $minimum[0] && $flip_count < $minimum[1]){
                $minimum[0] = $sum;
                $minimum[1] = $flip_count;
                $minimum[2] = \@f;
            }
            elsif(!defined($minimum[0])){
                $minimum[0] = $sum;
                $minimum[1] = $flip_count;
                $minimum[2] = \@f;
            }
            elsif($sum < $minimum[0]){
                $minimum[0] = $sum;
                $minimum[1] = $flip_count;
                $minimum[2] = \@f;
            }
        }
    }
    return @minimum;
}

MAIN:{
    my @A;
    my @minimum;
    @A = (3, 10, 8);
    @minimum = try_all_flips(@A);
    print "[". join(", ", @A) . "] --> ";
    print  " [". join(", ", @{$minimum[2]}) . "] = " . $minimum[0] ."\n";
    @A = (12, 2, 10);
    @minimum = try_all_flips(@A);
    print "[". join(", ", @A) . "] --> ";
    print  " [". join(", ", @{$minimum[2]}) . "] = " . $minimum[0] ."\n";
}

Sample Run


$ perl perl/ch-2.pl
[3, 10, 8] -->  [3, -10, 8] = 1
[12, 2, 10] -->  [-12, 2, 10] = 0

Notes

This is a brute force approach. I use the same method for generating all combinations that I used in Challenge 077 with the variation that here I use the generated combination to determine which elements of the list are to be flipped. After calculating the sum of each new list (with flipped elements) I check to see if this is a new minimum positive value and, if so, if it has been done with fewer flips.

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

2020-10-18

Perl Weekly Challenge 082

Part 1

You are given 2 positive numbers $M and $N. Write a script to list all common factors of the given numbers.

Solution


use strict;
use warnings;
##
# You are given 2 positive numbers $M and $N.
# Write a script to list all common factors of the given numbers.
##
sub factor{
    my($n) = @_;
    my @factors = (1);
    foreach my $j (2..sqrt($n)){
        push @factors, $j if $n % $j == 0;
        push @factors, ($n / $j) if $n % $j == 0 && $j ** 2 != $n;
    }    
    return @factors;  
}

sub common_factors{
    my($m, $n) = @_;
    my @common_factors = grep { my $f = $_; grep { $f == $_ } @{$n}} @{$m};
    return @common_factors;
}


MAIN:{
    my $M = 12;
    my $N = 18;
    my @m_factors = factor($M);
    my @n_factors = factor($N);
    print "(" . join(",", common_factors(\@m_factors, \@n_factors)) . ")\n";
}

Sample Run


$ perl perl/ch-1.pl
(1,2,6,3)

Notes

I have used sub factor previously, back in Challenge 008. The most interesting thing in this solution is probably the nested grep’s. In order to nest them properly you need to create a local variable to hold the element being examined in the outer grep block. Here I use $f. Although we need just two grep’s here this trick can be used to nest them more deeply.

Part 2

You are given 3 strings; $A, $B and $C. Write a script to check if $C is created by an interleaving of $A and $B. Print 1 if check is success otherwise 0.


use strict;
use warnings;
##
# You are given 3 strings; $A, $B and $C.
# Write a script to check if $C is created by interleave $A and $B.
# Print 1 if check is success otherwise 0.
##
sub find_remove{
    my($s, $x) = @_;
    my $i = index($s, $x);
    if($i != -1){
        substr $s, $i, length($x), "";
        return $s;
    }
    return undef;
}
MAIN:{
    my $A = "XY";
    my $B = "X";
    my $C = "XXY";
    my $s = find_remove($C, $A);
    if($s && $s eq $B){
        print "1\n";
        exit;
    }
    else{
        $s = find_remove($C, $B);
        if($s && $s eq $A){
            print "1\n";
            exit;
        }
    }
    print "0\n";
}

Sample Run


$ perl perl/ch-2.pl
1

Notes

I believe this is the most straightforward way of tackling this problem. By checking for both $A and $B as substrings and removing them if found we can determine if there was an interleaving by checking to see if the other remains.

posted at: 01:42 by: Adam Russell | path: /perl | permanent link to this entry

2020-10-11

Perl Weekly Challenge 081

Part 1

You are given 2 strings, $A and $B. Write a script to find out common base strings in $A and $B.

Solution


use strict;
use warnings;
##
# You are given 2 strings, $A and $B.
# Write a script to find out common base strings in $A and $B.
## 
use boolean;

sub contains{
    my($s0) = @_;
    return sub{
        my($s) = @_;
        return [true, $s0] if($s =~ m/^($s0)+$/g);
        return [false, $s0];
    }
}

sub make_checks{
    my($s) = @_;
    my @letters = split(//, $s);
    my @checks;
    for my $i (0 .. (int(@letters/2 - 1))){
        push @checks, contains(join("", @letters[0 .. $i]));
    }
    return @checks;
}

MAIN:{
    my($A, $B);
    #$A = "aaaaaaa";
    #$B = "aaaaaaaaaaaaaaaaaa";
    $A = "abcdabcd";
    $B = "abcdabcdabcdabcd";
    my @checks = make_checks($A);
    for my $check (@checks){
        if($check->($A)->[0] && $check->($B)->[0]){
            print $check->($A)->[1] . "\n";
            exit;
        }
    }
}

Sample Run

$ perl perl/ch-1.pl
abcdabcd, abcdabcdabcdabcd --> (abcd abcdabcd)
aaa, aa --> (a)

Notes

I used a similar technique to what I used in Challenge 003 and Challenge 004 where I create an array of anonymous functions which each check different substrings. The functions are created using what is called currying whereby we pass in a parameter (or multiple parameters if we needed to!) to a function which creates a closure around those parameters and returns a new function. This is, I admit, not all that necessary! I repeat the method though out of a sense of nostalgia. We are now on Challenge 081!

Part 2

You are given file named input. Write a script to find the frequency of all the words. It should print the result as first column of each line should be the frequency of the word followed by all the words of that frequency arranged in lexicographical order. Also sort the words in the ascending order of frequency.


use strict;
use warnings;
##
# You are given file named input.
# Write a script to find the frequency of all the words.
# It should print the result as first column of each line should be the frequency of the 
# word followed by all the words of that frequency arranged in lexicographical order. Also 
# sort the words in the ascending order of frequency.
##
MAIN:{
    my %counts;
    my %count_words;
    my $s;
    {    local $/;
         $s = ;
    }
    $s =~ s/'s//g;
    $s =~ tr/."(),//d;
    $s =~ tr/-/ /;
    my @words = split(/\s+/, $s);
    for my $word (@words){
        $counts{$word}++;
    }
    for my $k (keys %counts){
        my $count = $counts{$k};
        push @{$count_words{$count}}, $k;
    }
    for my $k (sort keys %count_words){
        print $k . "\t" . join(" ",  sort {$a cmp $b} @{$count_words{$k}}) . "\n";
    }
}


__DATA__ 
West Side Story

The award-winning adaptation of the classic romantic tragedy "Romeo and
Juliet". The feuding families become two warring New York City gangs,
the white Jets led by Riff and the Latino Sharks, led by Bernardo. Their
hatred escalates to a point where neither can coexist with any form of
understanding. But when Riff's best friend (and former Jet) Tony and
Bernardo's younger sister Maria meet at a dance, no one can do anything
to stop their love. Maria and Tony begin meeting in secret, planning to
run away. Then the Sharks and Jets plan a rumble under the
highway--whoever wins gains control of the streets. Maria sends Tony to
stop it, hoping it can end the violence. It goes terribly wrong, and
before the lovers know what's happened, tragedy strikes and doesn't stop
until the climactic and heartbreaking ending.

Sample Run

$ perl perl/ch-2.pl
1   But City It Jet Juliet Latino New Romeo Side Story Their Then West York adaptation any anything at award away become before begin best classic climactic coexist control dance do doesn't end ending escalates families feuding form former friend gains gangs goes happened hatred heartbreaking highway hoping in know love lovers meet meeting neither no one plan planning point romantic rumble run secret sends sister streets strikes terribly their two under understanding until violence warring what when where white whoever winning wins with wrong younger
2   Bernardo Jets Riff Sharks The by it led tragedy
3   Maria Tony a can of stop
4   to
9   and the

Notes

I have to admit that sometimes, even after many years of using Perl, that if I don’t use a certain feature often enough that I end up getting a little surprised. The surprise here is that Perl is clever enough to know that if I am trying a push onto a hash value which is undef, such as when I first do a push @{$count_words{$count}}, $k; for a new value of $k, that a new array is created. No need to check for undef and create a new one manually. This is called autovivification and while a very common thing in Perl for whatever reason it managed to catch me a little by surprise this time around. Probably due to my working a lot in other languages recently that don;t have this feature! Gabor has a nice writeup on autovivification for anyone interested in reading more.

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

2020-10-04

Perl Weekly Challenge 080

Part 1


use strict;
use warnings;
##
# You are given an unsorted list of integers @N.
# Write a script to find out the smallest positive number missing.
##
sub least_missing{
    my(@numbers) = @_;
    @numbers = sort @numbers;
    for my $i ($numbers[0] .. $numbers[@numbers - 1]){
        my @a = grep { $_ == $i } @numbers;
        return $i if(!@a && $i > 0);
    }
    return undef;
}

MAIN:{
    my @N;
    @N = (5, 2, -2, 0);
    my $least_missing = least_missing(@N);
    print "The least mising number from (" .
        join(",", @N) . ") is $least_missing\n";
    @N = (1, 8, -1);
    $least_missing = least_missing(@N);
    print "The least mising number from (" .
        join(",", @N) . ") is $least_missing\n";
    @N = (2, 0, -1);
    $least_missing = least_missing(@N);
    print "The least mising number from (" .
        join(",", @N) . ") is $least_missing\n";
}

Sample Run

$ perl perl/ch-1.pl
The least mising number from (5,2,-2,0) is 1
The least mising number from (1,8,-1) is 2
The least mising number from (2,0,-1) is 1

Notes

The list is given in arbitrary order so the first thing to do is to sort it. Once in sorted order iterate from the least number to the highest, incrementing by one at each step. Perl makes this easy with the range (aka flip-flop) operator. Each each iteration see if the current number is from the original list or not and if not, then if it is the smallest positive number not yet seen, which really just means the first positive number not from the original list.

As I am writing this I realize that it’d make sense to use grep to remove all the negative numbers from the list before even bothering to sort them. If the list were presented as, say, 1 million negative numbers and then three positive ones why waste doing anything with all the negatives!

Part 2


use strict;
use warnings;
##
# You are given rankings of @N candidates.
# Write a script to find out the total candies needed for all candidates. 
# You are asked to follow the rules below:
#     a) You must given at least one candy to each candidate.
#     b) Candidate with higher ranking get more candies than their immediate
#        neighbors on either side.
##
sub count_candies{
    my(@candidates) = @_;
    my $candies = @candidates;
    for my $i (0 .. (@candidates - 1)){
        if($candidates[$i - 1]){
            $candies++ if $candidates[$i] > $candidates[$i - 1];
        }   
        if($candidates[$i + 1]){
            $candies++ if $candidates[$i] > $candidates[$i + 1];
        }
    }
    return $candies;
}


MAIN:{
    my @N;
    my $number_candies;
    @N = (1, 2, 2);
    $number_candies = count_candies(@N);
    print "The number of candies for (" .
        join(",", @N) . ") is $number_candies\n";
    @N = (1, 4, 3, 2);
    $number_candies = count_candies(@N);
    print "The number of candies for (" .
        join(",", @N) . ") is $number_candies\n";
}

Sample Run

$ perl perl/ch-2.pl
The number of candies for (1,2,2) is 4
The number of candies for (1,4,3,2) is 7

Notes

I don’t think there are any surprises in this approach. In fact, I could not think of a better way, in terms of efficiency, than this. Still, this is not exactly exciting code to read!

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

2020-09-27

Perl Weekly Challenge 079

Part 1

You are given a positive number $N. Write a script to count the total number of set bits of the binary representations of all numbers from 1 to $N and return $total_count_set_bit % 1000000007.

Solution

“ch-1.pl”

Sample Run

$ perl perl/ch-1.pl
5 % 1000000007 = 5
4 % 1000000007 = 4

Notes

The approach here is to continuously shift bits off to the right, checking to see if the bit about to be shifted off is set or not. This is a pretty standard pattern and it looks pretty much the same in C++ and Prolog too!

Part 2

You are given an array of positive numbers @N. Write a script to represent it as Histogram Chart and find out how much water it can trap.

“ch-2.pl”

Sample Run

ch-2.pl output

Notes

This is one of the more fun sorts of problems that come up in these challenges! It is somewhat similar to the “leader problem” from last week in that we are given an array of numbers and need to do a similar set of look ahead comparisons. Here we look ahead in the array to determine if what I call buckets exist. Whatever buckets are found are then used to compute the total volume as specified.

References

https://users.cs.cf.ac.uk/Dave.Marshall/PERL/node36.html

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

2020-09-20

Perl Weekly Challenge 078

Part 1

You are given an array @A containing distinct integers. Write a script to find all leader elements in the array @A. Print (0) if none found.

Solution

“ch-1.pl”

Sample Run

$ perl perl/ch-1.pl 6
@A = (9,10,7,5,6,1)
Leaders = (10,7,6,1)
@A = (3,4,5)
Leaders = (5)

Notes

The approach here is to just repeating the checks for smaller elements. Nothing too fancy. In fact, I actually thought that there might be room for some fun and over engineered way of doing this but I couldn’t really come up with anything that wouldn’t just be obfuscated!

Part 2

You are given array @A containing positive numbers and @B containing one or more indices from the array @A. Write a script to left rotate @A so that the number at the first index of @B becomes the first element in the array. Similary, left rotate @A again so that the number at the second index of @B becomes the first element in the array.

“ch-2.pl”

Sample Run

$ perl perl/ch-2.pl
@A = (10,20,30,40,50)
@B = (3,4)
Rotations:
[40,50,10,20,30]
[50,10,20,30,40]
@A = (7,4,2,6,3)
@B = (1,3,4)
Rotations:
[4,2,6,3,7]
[6,3,7,4,2]
[3,7,4,2,6]

Notes

Another straight forward one. For each value in @B I shift and push the respective number of times.

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

2020-09-13

Perl Weekly Challenge 077

Part 1

You are given a positive integer $N. Write a script to find out all possible combination of Fibonacci Numbers required to get $N on addition.

Solution

“ch-1.pl”

Sample Run

$ perl perl/ch-1.pl 6
1 + 5 = 6
1 + 2 + 3 = 6
1 + 5 = 6
1 + 2 + 3 = 6

$ perl perl/ch-1.pl 9
1 + 8 = 9
1 + 3 + 5 = 9
1 + 8 = 9
1 + 3 + 5 = 9
1 + 1 + 2 + 5 = 9

Notes

The approach here is to generate all Fibonacci terms up to $n and then evaluate all combinations of these terms and see which sum to $n. The most interesting part here is perhaps how the combinations are generated. Here we are making use of a convenient property that there are 2^n -1 subsets of the set {1..n}. So we generate numbers $b as an n-digit binary number using sprintf. We correspond the binary digits of k to indices into the Fibonacci sequence and select a Fibonacci term if its bit value is 1.

Also note that the Fibonacci sequence starts off as 1, 1, 2, 3, 5, … and so while we may see two 1s these are separate, and not repeated, Fibonacci terms.

Part 2

You are given m x n character matrix consists of O and X only. Write a script to count the total number of X surrounded by O only. Print 0 if none found.

“ch-2.pl”

Sample Run

perl perl/ch-2.pl
O O X
X O O
X O O
1 X found at Row 1 Column 3.

O O X O
X O O O
X O O X
O X O O
1st X found at Row 1 Column 3.
2nd X found at Row 3 Column 4.

Notes

I made use of Neil Bowers Lingua::EN::Numbers::Ordinate to make the output look a little nicer.

Otherwise think this is straight forward enough…for each test matrix identify the Xs and then check to see if they are “lonely”. The number of possible adjacent space to check is no more than eight as shown in the code so we check these all, if they exist.

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

2020-09-06

Perl Weekly Challenge 076

I did this week's Perl Weekly Challenge in both Perl and Prolog. The Prolog solutions were good practice in shaking the rust off my logic programming but I won't discuss them here, to keep things short. The code for the Prolog solutions for Part 1 and Part 2 are on GitHub. 

Part 1

You are given a number $N. Write a script to find the minimum number of prime numbers required, whose summation gives you $N. For the sake of this task, please assume 1 is not a prime number.

For this solution I used a pre-computed list of the first 1000 prime numbers. Larger pre-computed lists are available and of course computing them directly is always an option too! For the purposes of this challenge it seemed a pre-computed list would be OK.

Code

ch-1.pl (with list of pre-computed primes cropped)
ch-1.pl (with list of pre-computed primes cropped)

Sample Run

$ perl perl/ch-1.pl 9
7 + 2 = 9

$ perl perl/ch-1.pl 87
83 + 2 + 2 = 87

Part 2

Write a script that takes two file names. The first file would contain word search grid as shown below. The second file contains list of words, one word per line. You could even use local dictionary file.

Print out a list of all words seen on the grid, looking both orthogonally and diagonally, backwards as well as forwards.

I opted to hard code the grid and load a small dictionary file. This file was obtained from http://www-personal.umich.edu/~jlawler/wordlist.html and contains 60,000 of the most common english words. Ultimately this yield a lot of awkward looking two and three letter words which, frankly, I do not personally consider all that common. I used the full dictionary but filter the results to only words with 4 or more letters.

ch-2.pl (with some utility functions cropped)
ch-2.pl (with some utility functions cropped)

The approach is straightforward:

Sample Run

$ perl perl/ch-2.pl
Found the following words: align,alls,ante,arare,aras,aras,argos,baas,bide,blunt,bosc,broad,buff,butea,cart,cess,cold,cord,demi,depart,departed,doth,dust,ebro,enter,etna,eves,filch,garlic,gila,goat,gram,grieve,grit,hani,hazard,heed,laic,lien,luge,lune,mali,malign,malignant,mall,mein,mero,midst,need,oats,ough,ought,ovary,part,parte,parted,quash,rape,rara,rare,rast,road,roccus,ruse,sara,sara,shed,shrine,slag,slug,social,spasm,spasmodic,succor,succors,theorem,togo,trap,tsar,vary,virus,visa,wigged,zing

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