# RabbitFarm

### 2021-10-17

#### A Couple of Brute Force Computations

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

## Part 1

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

### Solution

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

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

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

### Sample Run

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

### Notes

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

## Part 2

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

### Solution

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

### Sample Run

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

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

### Notes

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

## References

Challenge 134

Pandigital Numbers

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

### 2021-09-19

#### These Binary Trees are Odd

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

## Part 1

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

### Solution

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

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

### Sample Run

``````
\$ perl perl/ch-1.pl
5
4
``````

### Notes

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

## Part 2

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

### Solution

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

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

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

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

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

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

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

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

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

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

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

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

### Sample Run

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

### Notes

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

• This allows for object oriented construction of the data structure with almost the minimum overhead
• While providing for some OO structure, other than generating default accessor methods there is not too much done behind the scenes. Organizing the code this way does not feel like "cheating" in that there is any reliance on the OO framework, since it is so minimal.
• Many classic texts on data structures use C and that languages `struct` ability. Some superficial resemblance to that code is helpful in translating examples from the literature to Perl.

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

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

## References

Challenge 130

Class::Struct

Binary Trees

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

### 2021-09-12

#### Two Exercises in Fundamental Data Structures

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

## Part 1

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

### Solution

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

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

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

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

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

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

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

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

### Sample Run

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

### Notes

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

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

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

## Part 2

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

### Solution

``````
use strict;
use warnings;
use boolean;
use Class::Struct;

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

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

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

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

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

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

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

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

### Sample Run

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

### Notes

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

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

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

• a function for inserting at the end of the list, insert at each addition step
• holding the sum in an array and when `add()` is finished with all list elements use the existing `insert()` and create a LinkedList instance to return by `shift`ing off the array.

## References

Challenge 129

Class::Struct

Tie::RefHash

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

### 2021-09-05

#### A Platform for Every Departing Sub-Matrix

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

## Part 1

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

### Solution

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

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

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

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

### Sample Run

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

### Notes

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

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

## Part 2

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

### Solution

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

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

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

### Sample Run

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

### Notes

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

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

## References

Challenge 128

Date::Parse

Heap::MinMax

Tree::Suffix

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

### 2021-08-29

#### Conflicting Lists and Intervals

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

## Part 1

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

### Solution

``````
use strict;
use warnings;
use boolean;

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

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

### Sample Run

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

### Notes

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

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

## Part 2

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

### Solution

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

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

### Sample Run

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

### Notes

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

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

## References

Challenge 127

C++ solution for Part 1

C++ solution for Part 2

Disjoint Sets

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

### 2021-08-22

#### Count Numbers / MineSweeper game: The Weekly Challenge 126

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

## Part 1

You are given a positive integer \$N. Write a script to print count of numbers from 1 to \$N that don’t contain digit 1.

### Solution

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

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

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

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

### Sample Run

``````
\$ perl perl/ch-1.pl
8
13
``````

### Notes

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

## Part 2

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

### Solution

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

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

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

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

### Sample Run

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

### Notes

• The grid is randomly determined. Any cell has a 1/3 chance of being a mine.

• The code for finding all adjacent cells, if they exist, is largely taken from my solution to Challenge 077.

• Once the tedious business of finding the adjacent cells is done counting up the "mines" and labelling the cells is straightforward!

## References

Challenge 126

C++ solution for Part 1

C++ solution for Part 2

History of Minesweeper

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

### 2021-08-01

#### Ugly Numbers / Square Points

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

## Part 1

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

### Solution

``````
use strict;
use warnings;
use boolean;

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

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

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

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

### Sample Run

``````
\$ perl perl/ch-1.pl
8
12
``````

### Notes

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

## Part 2

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

### Solution

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

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

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

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

### Sample Run

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

### Notes

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

• Are there only two each of X and Y co-ordinates? Then that is enough to establish that we have a square.
• Otherwise, make sure the side lengths are all equivalent and that the angles between the sides are all 90 degrees.

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

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

## References

Challenge 123

C++ solution for Part 1

C++ solution for Part 2

Rhombus

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

### 2021-07-25

#### Average of Stream / Basketball Points

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

## Part 1

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

### Solution

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

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

### Sample Run

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

### Notes

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

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

## Part 2

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

### Solution

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

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

### Sample Run

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

\$S = 5
3 2
2 3
3 1 1
2 1 2
1 3 1
2 2 1
1 2 2
1 1 3
1 2 1 1
1 1 1 2
1 1 2 1
2 1 1 1
1 1 1 1 1
``````

### Notes

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

## References

Challenge 122

Dynamic Programming

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

### 2021-07-18

#### A Genetic Algorithm solution to the Travelling Salesman Problem

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

## Part 1

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

### Solution

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

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

### Sample Run

``````
\$ perl perl/ch-1.pl
8
26
``````

### Notes

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

## Part 2

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

### Solution

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

use constant N => 7;

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

sub fitness{
my(\$genes) = @_;
my \$cost = 0;
return -1 if \$genes-> != \$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(/:/, \$_);
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

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 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}->;
my \$visited = \$paths{\$path}->;
my @ij = split(/\-/, \$current);
my(\$left, \$horizontal, \$right) = ((\$ij + 1) . "-" . \$ij, \$ij . "-" . (\$ij + 1), (\$ij + 1) . "-" . (\$ij + 1));
@exists = grep {\$_ eq \$left} @vertices;
@visited = grep {\$_ eq \$left} @{\$visited};
if(@exists && !@visited){
my \$visited_left = [@{\$visited}, \$left];
if(\$left eq "\$n-\$n"){
push @complete_paths, \$path . "L";
}
else{
\$updated_paths{\$path . "L"} = [\$left, \$visited_left];
}
}
@exists = grep {\$_ eq \$horizontal} @vertices;
@visited = grep {\$_ eq \$horizontal} @{\$visited};
if(@exists && !@visited){
my \$visited_horizontal = [@{\$visited}, \$horizontal];
if(\$horizontal eq "\$n-\$n"){
push @complete_paths, \$path . "H";
}
else{
\$updated_paths{\$path . "H"} = [\$horizontal, \$visited_horizontal];
}
}
@exists = grep {\$_ eq \$right} @vertices;
@visited = grep {\$_ eq \$right} @{\$visited};
if(@exists && !@visited){
my \$visited_right = [@{\$visited}, \$right];
if(\$right eq "\$n-\$n"){
push @complete_paths, \$path . "R";
}
else{
\$updated_paths{\$path . "R"} = [\$right, \$visited_right];
}
}
}
%paths = %updated_paths;
}
return @complete_paths;
}

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

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

### Sample Run

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

### Notes

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

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

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

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

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

• A hash is kept of all paths. Keys are the paths themselves and values are an array reference containing the current position and all previously visited nodes on that path.
• Each path is examined and updated to move to the next position proved that next position exists and has not yet been visited. (See more on visited positions next).
• The hash of paths is refreshed by moving paths that are completed to an array. Also, this code allows for catching paths which deadend (i.e. end up in a corner which is impossible to get out of without backtracking over a visited node). Without horizontal leftward movements this is not really possible however. Some CPU cycles can be saved by eliminating these checks, but I decided to leave them in anyway. Please do note the unnecessary extra work, however!
• The traversal ends when all paths have been exhausted, the loop ends, and the paths are returned.

## References

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)) if !defined(\$x);
return \$x;
}

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

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

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

sub get_4{
my(\$s) = @_;
return (caller(0)) 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){
my \$child_nodes = \$first_letter_name{substr(\$word, -1)};
for my \$n (@{\$child_nodes}){
\$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 ] => [ ]" if @a == 1;
push @lines, "[ \$a ] => [ \$a ]" if @a > 1;
}
my \$parser = new Graph::Easy::Parser();
my \$graph_viz = \$parser->from_text(join("", @lines));
print \$graph_viz->as_ascii();
}

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

__DATA__
ab
bea
cd
``````

### Sample Run

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

### Notes

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

The approach here is:

• read in the words and construct the directed graph
• check to see that the number of connected components is one. If so, print 1. Otherwise print 0.
• display the graph (an optional data visualization step)

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

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

## Part 2

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

### Solution

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

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

### Sample Run

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

### Notes

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

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

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

• We need to make sure we have at least one digit which is a multiple of 2. If not, then there is no need to continue.
• Sort the numbers, but then inspect the final digit in descending order. Is it a multiple of 2? If so, then we are done!
• If the final digit is not a multiple of 2 then search the sorted list starting from the final digit and working "upwards". We had previously made sure we had at least one multiple of 2 so we are certain to find one. When we find it we need to swap it with the final digit to insure that the entire number itself is a multiple of 2.

## References

Challenge 115

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);
dfs_update(\$graph, \$successor, \$graph_updated, \$sum_remaining);
}
}

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 ] => [ \$a ]";
}
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;
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
##
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) = @_;
}

MAIN:{
while(){
chomp;
print canonical_path(\$_) . "\n";
}
}

__DATA__
/a/
/a/b//c/
/a/b/c/../..
``````

### Sample Run

``````
\$ perl perl/ch-1.pl
/a
/a/b/c
/a
``````

### Notes

The challenge I set for myself here was to completely avoid any use of regular expressions! I think I pulled it off, more or less. I am not quite sure I covered every possible corner case, but it works for the examples given.

## Part 2

You are given \$n steps to climb. Write a script to find out the distinct ways to climb to the top. You are allowed to climb either 1 or 2 steps at a time.

### Solution

``````
use strict;
use warnings;
##
# You are given \$n steps to climb
# Write a script to find out the distinct ways to climb to the top.
# You are allowed to climb either 1 or 2 steps at a time.
##
use Array::Compare;
use Algorithm::Combinatorics q/variations_with_repetition/;

sub steps{
my(\$k) = @_;
my @data = (0, 1, 2);
my @steps;
my \$comparison = new Array::Compare();
my \$iterator = variations_with_repetition(\@data, \$k);
while(my \$combination = \$iterator->next()){
if(unpack("%32C*", pack("C*", @{\$combination})) == \$k){
my \$step = [grep {\$_ != 0} @{\$combination}];
push @steps, \$step if(!grep {\$comparison->compare(\$_, \$step)} @steps);
}
}
return @steps;
}

MAIN:{
my @steps;
@steps = steps(3);
print "k = 3\n";
for my \$steps (@steps){
my \$option;
for my \$step (@{\$steps}){
\$option .=  "\$step step + "  if \$step == 1;
\$option .=  "\$step steps + " if \$step == 2;
}
chop(\$option);
chop(\$option);
print "\$option\n";
}
@steps = steps(4);
print "\nk = 4\n";
for my \$steps (@steps){
my \$option;
for my \$step (@{\$steps}){
\$option .=  "\$step step + "  if \$step == 1;
\$option .=  "\$step steps + " if \$step == 2;
}
chop(\$option);
chop(\$option);
print "\$option\n";
}
@steps = steps(5);
print "\nk = 5\n";
for my \$steps (@steps){
my \$option;
for my \$step (@{\$steps}){
\$option .=  "\$step step + "  if \$step == 1;
\$option .=  "\$step steps + " if \$step == 2;
}
chop(\$option);
chop(\$option);
print "\$option\n";
}
}
``````

### Sample Run

``````
\$ perl perl/ch-2.pl
k = 3
1 step + 2 steps
2 steps + 1 step
1 step + 1 step + 1 step

k = 4
2 steps + 2 steps
1 step + 1 step + 2 steps
1 step + 2 steps + 1 step
2 steps + 1 step + 1 step
1 step + 1 step + 1 step + 1 step

k = 5
1 step + 2 steps + 2 steps
2 steps + 1 step + 2 steps
2 steps + 2 steps + 1 step
1 step + 1 step + 1 step + 2 steps
1 step + 1 step + 2 steps + 1 step
1 step + 2 steps + 1 step + 1 step
2 steps + 1 step + 1 step + 1 step
1 step + 1 step + 1 step + 1 step + 1 step
``````

### Notes

Rather than pursue some sort of algorithmic elegance and optimization I decided to try what is effectively a brute force approach. For small values of `\$k` this works quite nicely with the above example output generated in about a second on very modest hardware (an approximately 20 year old 450Mhz G4 Power Macintosh). Naturally we face a combinatorial explosion for larger values of `\$k`. For larger input values consider a graph search with memoization!

Overview of this brute force approach:

• Generate all arrays of numbers of length `\$k` using digits 0, 1, and 2.
• Keep all those arrays that sum to `\$k`
• Remove zeroes from these matching arrays
• Remove duplicate arrays

Combinations are generated using Algorithm::Combinatorics.

Duplicate array removal is facilitated by Array::Compare.

## References

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]-> > \$search){
my @matrix_reduced = @{\$matrix}[0 .. \$half - 1];
matrix_search(\@matrix_reduced, \$search);
}
elsif(\$matrix->[\$half]-> < \$search){
my @matrix_reduced = @{\$matrix}[\$half .. @{\$matrix} - 1];
matrix_search(\@matrix_reduced, \$search);
}
elsif(\$matrix->[\$half]-> == \$search){
return true;
}
}
else{
return row_search(\$matrix->, \$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
``````

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
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.

Challenge 111

Binary Search