# RabbitFarm

### 2023-02-05

#### Into the Odd Wide Valley

*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. Write a script to print 1 if there are THREE
consecutive odds in the given array otherwise print 0.*

### Solution

```
use v5.36;
use boolean;
sub three_consecutive_odds{
my @numbers = @_;
my $consecutive_odds = 0;
{
my $x = pop @numbers;
$consecutive_odds++ if 1 == ($x & 1);
$consecutive_odds = 0 if 0 == ($x & 1);
return true if 3 == $consecutive_odds;
redo if @numbers;
}
return false;
}
MAIN:{
say three_consecutive_odds(1, 5, 3, 6);
say three_consecutive_odds(2, 6, 3, 5);
say three_consecutive_odds(1, 2, 3, 4);
say three_consecutive_odds(2, 3, 5, 7);
}
```

### Sample Run

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

### Notes

## Part 2

*Given a profile as a list of altitudes, return the leftmost widest valley. A valley is
defined as a subarray of the profile consisting of two parts: the first part is
non-increasing and the second part is non-decreasing. Either part can be empty.*

### Solution

```
use v5.36;
use boolean;
use FSA::Rules;
sub widest_valley_rules{
my @altitudes = @_;
my @downslope;
my @upslope;
my $fsa = FSA::Rules->new(
move => {
do => sub{ my $state = shift;
$state->machine->{altitude} = [] if(!$state->machine->{altitude});
$state->machine->{plateau} = [] if(!$state->machine->{plateau});
$state->machine->{downslope} = [] if(!$state->machine->{downslope});
$state->machine->{upslope} = [] if(!$state->machine->{upslope});
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
move => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
@{$previous_altitudes} == 1;
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}else{false}
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} == 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if(@{$previous_altitudes} > 2){
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
},
],
},
plateau => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, @{$state->machine->{plateau}};
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
$state->machine->{plateau} = [];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, @{$state->machine->{plateau}};
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
$state->machine->{plateau} = [];
}
}
],
},
downslope => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
#pop @{$state->machine->{downslope}};true;
}
},
downslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{downslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
$state->machine->{upslope} = [];
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
],
},
upslope => {
do => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
my $current_altitude = shift @altitudes;
push @{$previous_altitudes}, $current_altitude;
},
rules => [ done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
!defined($previous_altitudes->[@{$previous_altitudes} - 1])
},
done => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
$previous_altitudes->[@{$previous_altitudes} - 1] < $previous_altitudes->[@{$previous_altitudes} - 2];
},
plateau => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] == $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{plateau}}, $previous_altitudes->[@{$previous_altitudes} - 2], $previous_altitudes->[@{$previous_altitudes} - 1];
}
},
upslope => sub{ my $state = shift;
my $previous_altitudes = $state->machine->{altitude};
if($previous_altitudes->[@{$previous_altitudes} - 1] > $previous_altitudes->[@{$previous_altitudes} - 2]){
push @{$state->machine->{upslope}}, $previous_altitudes->[@{$previous_altitudes} - 1];
}
}
],
},
done => {
do => sub { my $state = shift;
say q/Valley: / . join(q/, /, @{$state->machine->{downslope}}, @{$state->machine->{upslope}});
}
},
);
return $fsa;
}
sub widest_valley{
my $rules = widest_valley_rules(@_);
$rules->start;
$rules->switch until $rules->at(q/done/);
my $graph_viz = $rules->graph();
}
MAIN:{
widest_valley 1, 5, 5, 2, 8;
widest_valley 2, 6, 8, 5;
widest_valley 2, 1, 2, 1, 3;
}
```

### Sample Run

```
$ perl perl/ch-2.pl
Valley: 5, 5, 2, 8
Valley: 2, 6, 8
Valley: 2, 1, 2
```

### Notes

## References

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

### 2023-01-29

The Weekly Challenge 201 (Prolog Solutions)

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

## Part 1

*You are given an array of unique numbers. Write a script to find out all missing numbers
in the range 0..$n where $n is the array size.*

### Solution

```
missing_number(Numbers, Missing):-
length(Numbers, NumbersLength),
between(0, NumbersLength, Missing),
\+ member(Missing, Numbers).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- missing_number([0, 1, 3], Missing).
Missing = 2 ?
(1 ms) yes
| ?- missing_number([0, 1], Missing).
Missing = 2
yes
| ?-
```

### Notes

`missing_number/2`

will only find one missing number at a time. In the examples that come
with the original problem statement there is only ever one missing number. If multiple
missing numbers are required backtracking with `findall/3`

is all you need!

## Part 2

*You are given an integer, $n > 0. Write a script to determine the number of ways of
putting $n pennies in a row of piles of ascending heights from left to right.*

### Solution

```
sum(Coins):-
sum([], Coins, 0).
sum(Coins, Coins, 5).
sum(Partial, Coins, Sum):-
Sum < 5,
between(1, 5, X),
S is Sum + X,
sum([X | Partial], Coins, S).
main:-
findall(Coins, sum(Coins), C),
maplist(msort, C, CS),
sort(CS, CoinsSorted),
write(CoinsSorted), nl,
halt.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- main.
[[1,1,1,1,1],[1,1,1,2],[1,1,3],[1,2,2],[1,4],[2,3],[5]]
```

### Notes

The approach here is the same that I used for the *Coins Sum* problem from
TWC 075. The same as for the
Perl solution to the same problem.

## References

posted at: 18:39 by: Adam Russell | path: /prolog | permanent link to this entry

#### How Many Missing Coins?

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

## Part 1

*You are given an array of unique numbers. Write a script to find out all missing numbers
in the range 0..$n where $n is the array size.*

### Solution

```
use v5.36;
use boolean;
sub missing_numbers{
my @numbers = @_;
my %h;
do { $h{$_} = undef } for @numbers;
my @missing = grep { !exists($h{$_}) } 0 .. @numbers;
return @missing;
}
MAIN:{
say q/(/ . join(q/, /, missing_numbers(0, 1, 3)) . q/)/;
say q/(/ . join(q/, /, missing_numbers(0, 1)) . q/)/;
say q/(/ . join(q/, /, missing_numbers(0, 1, 2, 2)) . q/)/;
}
```

### Sample Run

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

### Notes

This problem was a nice refresh on exists,
which is often confused with `defined`

. Here we want to see if the hash key *exists* at
all and so the use is appropriate. If we had wanted to see if the value keyed was defined,
well, that is the use for `defined`

!

## Part 2

*You are given an integer, $n > 0. Write a script to determine the number of ways of
putting $n pennies in a row of piles of ascending heights from left to right.*

### Solution

```
use v5.36;
use AI::Prolog;
use Hash::MultiKey;
MAIN:{
my $S = $ARGV[0];
my $C = "[" . $ARGV[1] . "]";
my $prolog = do{
local $/;
<DATA>;
};
$prolog =~ s/_COINS_/$C/g;
$prolog =~ s/_SUM_/$S/g;
$prolog = AI::Prolog->new($prolog);
$prolog->query("sum(Coins).");
my %h;
tie %h, "Hash::MultiKey";
while(my $result = $prolog->results){
my @s = sort @{$result->[1]};
$h{\@s} = undef;
}
for my $k ( sort { @{$b} <=> @{$a} } keys %h){
print "(" . join(",", @{$k}) . ")";
print "\n";
}
}
__DATA__
member(X,[X|_]).
member(X,[_|T]) :- member(X,T).
coins(_COINS_).
sum(Coins):-
sum([], Coins, 0).
sum(Coins, Coins, _SUM_).
sum(Partial, Coins, Sum):-
Sum < _SUM_,
coins(L),
member(X,L),
S is Sum + X,
sum([X | Partial], Coins, S).
```

### Sample Run

```
$ perl perl/ch-2.pl 5 1,2,3,4,5
(1,1,1,1,1)
(1,1,1,2)
(1,2,2)
(1,1,3)
(1,4)
(2,3)
(5)
```

### Notes

The approach here is the same that I used for the *Coins Sum* problem from
TWC 075. The only change is the added
sort by the length of the "piles".

## References

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

### 2023-01-15

The Weekly Challenge 199 (Prolog Solutions)

## Part 1

*You are given a list of integers, @list. Write a script to find the total count of Good
airs.*

### Solution

```
good_pair(Numbers, Pair):-
length(Numbers, L),
fd_domain(I, 1, L),
fd_domain(J, 1, L),
I #<# J,
fd_labeling([I, J]),
fd_element(I, Numbers, Ith),
fd_element(J, Numbers, Jth),
Ith #= Jth,
Pair = [I, J].
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- good_pair([1, 2, 3, 1, 1, 3], Pair).
Pair = [1,4] ? a
Pair = [1,5]
Pair = [3,6]
Pair = [4,5]
no
| ?- good_pair([1, 2, 3], Pair).
no
| ?- good_pair([1, 1, 1, 1], Pair).
Pair = [1,2] ? a
Pair = [1,3]
Pair = [1,4]
Pair = [2,3]
Pair = [2,4]
Pair = [3,4]
yes
| ?-
```

### Notes

I take a clpfd approach to this problem and the next. This allows a pretty concise
solution. Here we get the length of the list of numbers, constrain the indices for the
pair and then specify the additional conditions of a *Good Pair*.

## Part 2

*You are given an array of integers, @array and three integers $x,$y,$z. Write a script to
find out total Good Triplets in the given array.*

### Solution

```
good_triplet(Numbers, X, Y, Z, Triplet):-
length(Numbers, I),
fd_domain(S, 1, I),
fd_domain(T, 1, I),
fd_domain(U, 1, I),
S #<# T, T #<# U,
fd_labeling([S, T, U]),
fd_element(S, Numbers, Sth),
fd_element(T, Numbers, Tth),
fd_element(U, Numbers, Uth),
Ast is abs(Sth - Tth), Ast #=<# X,
Atu is abs(Tth - Uth), Atu #=<# Y,
Asu is abs(Sth - Uth), Asu #=<# Z,
Triplet = [Sth, Tth, Uth].
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- good_triplet([3, 0, 1, 1, 9, 7], 7, 2, 3, Triplet).
Triplet = [3,0,1] ? a
Triplet = [3,0,1]
Triplet = [3,1,1]
Triplet = [0,1,1]
no
| ?- good_triplet([1, 1, 2, 2, 3], 0, 0, 1, Triplet).
no
| ?-
```

### Notes

Again for part 2 a clpfd solution ends up being fairly concise. In fact, the approach here is virtually identical to part 1. The differences are only that we are looking for a triple, not a pair, and slightly different criteria.

## References

posted at: 15:16 by: Adam Russell | path: /prolog | permanent link to this entry

#### Multiple Goods

## Part 1

*You are given a list of integers, @list. Write a script to find the total count of Good
airs.*

### Solution

```
use v5.36;
sub good_pairs{
my(@numbers) = @_;
my @pairs;
do{
my $i = $_;
do{
my $j = $_;
push @pairs, [$i, $j] if $numbers[$i] == $numbers[$j] && $i < $j;
} for 0 .. @numbers - 1;
} for 0 .. @numbers - 1;
return 0 + @pairs;
}
MAIN:{
say good_pairs 1, 2, 3, 1, 1, 3;
say good_pairs 1, 2, 3;
say good_pairs 1, 1, 1, 1;
}
```

### Sample Run

```
$ perl perl/ch-1.pl
4
0
6
```

### Notes

First off, a pair `(i, j)`

is called *good* if `list[i] == list[j]`

and `i < j`

. Secondly,
I have never written a nested loop with this mix of `do`

blocks and postfix `for`

, and
I am greatly entertained by it! Perl fans will know that it really isn't all that
different from the more standard looking do/while construct. A `do`

block is not really a
loop, although it can be repeated, and so you cannot use `last`

, `redo`

, or `next`

within
the block. But this is exactly the same case as within a `map`

, which is what we are
trying to replicate here, a `map`

in *void context* without actually using `map`

.

Imagine a nested `map`

, that is basically the same thing as this, but with the more clear
focus on *side effects* versus a return value.

## Part 2

*You are given an array of integers, @array and three integers $x,$y,$z. Write a script to
find out total Good Triplets in the given array.*

### Solution

```
use v5.36;
use Math::Combinatorics;
sub good_triplets{
my($numbers, $x, $y, $z) = @_;
my $combinations = Math::Combinatorics->new(count => 3, data => [0 .. @{$numbers} - 1]);
my @combination = $combinations->next_combination;
my @good_triplets;
{
my($s, $t, $u) = @combination;
unless($s >= $t || $t >= $u || $s >= $u){
push @good_triplets, [@{$numbers}[$s, $t, $u]] if(abs($numbers->[$s] - $numbers->[$t]) <= $x &&
abs($numbers->[$t] - $numbers->[$u]) <= $y &&
abs($numbers->[$s] - $numbers->[$u]) <= $z);
}
@combination = $combinations->next_combination;
redo if @combination;
}
return 0 + @good_triplets;
}
MAIN:{
say good_triplets([3, 0, 1, 1, 9, 7], 7, 2, 3);
say good_triplets([1, 1, 2, 2, 3], 0, 0, 1);
}
```

### Sample Run

```
$ perl perl/ch-2.pl
4
0
```

### Notes

The approach here is the same that I used for the *Magical Triples* problem from
TWC 187. The module
Math::Combinatorics is used to generate all possible triples of indices. These are then
filtered according to the criteria for good triplets.

## References

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

### 2023-01-08

#### Prime the Gaps!

## Part 1

*You are given a list of integers, @list. Write a script to find the total pairs in the
sorted list where 2 consecutive elements has the max gap. If the list contains less
then 2 elements then return 0.*

### Solution

```
use v5.36;
sub largest_gap{
my(@numbers) = @_;
my $gap = -1;
map{ $gap = $numbers[$_] - $numbers[$_ - 1] if $numbers[$_] - $numbers[$_ - 1] > $gap } 1 .. @numbers - 1;
return $gap;
}
sub gap_pairs{
my(@numbers) = @_;
return 0 if @numbers < 2;
my $gap = largest_gap(@numbers);
my $gap_count;
map { $gap_count++ if $numbers[$_] - $numbers[$_ - 1] == $gap } 1 .. @numbers - 1;
return $gap_count;
}
MAIN:{
say gap_pairs(3);
say gap_pairs(2, 5, 8, 1);
}
```

### Sample Run

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

### Notes

Probably these two subroutines could be combined into one without too much trouble, but it still seems cleaner to me this way.

Do an initial pass over the list to determine the largest gap.

Perform a second pass over the list and count up all pairs which have the maximum gap.

An interesting issue came up. I've been trying to avoid the use of a map in a void context. This is just due to the general principal to use map as a function and use its return value rather than rely on side effects.

As part of this reformative effort I have been doing more with for in a postfix position. I discovered this when working this problem:

`{say $_ if $_ % 2 == 0} for 0 .. 9`

will not work. Perl gets confused by the
postfix `if`

within the block, apparently.

But there is a work around! Add `do`

and all is well.

`do {say $_ if $_ % 2 == 0} for 0 .. 9`

Of course the equivalent `map`

works just fine as you'd
expect `map {say $_ if $_ % 2 == 0} 0 .. 9)`

E. Choroba pointed out this is due to postfix
`for`

being a statement modifier which doesn't know what to do with blocks. But why does
`do`

fix this? I am still unclear on why that is. Even with the `do`

it's still a block!
Apparently perl will view it as a statement, for the purposes of the postfix `for`

?

UPDATE: Turns out that the `do {}`

construct qualifies as a *Simple Statement*. From the
perldoc: *Note that there are
operators like eval {}, sub {}, and do {} that look like compound statements, but
aren't--they're just TERMs in an expression--and thus need an explicit termination when
used as the last item in a statement.*

## Part 2

*You are given an integer $n > 0. Write a script to print the count of primes less
than $n.*

### Solution

```
use v5.36;
use Math::Primality q/is_prime/;
sub prime_count{
return 0 + grep { is_prime $_ } 2 .. $_[0] - 1;
}
MAIN:{
say prime_count(10);
say prime_count(15);
say prime_count(1);
say prime_count(25);
}
```

### Sample Run

```
$ perl perl/ch-2.pl
4
6
0
9
```

### Notes

The Math::Primality module makes this quite easy! In fact, I am not sure there is that much to elaborate on. Check primality using is_prime() and we're done!

## References

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

The Weekly Challenge 198 (Prolog Solutions)

## Part 1

*You are given a list of integers, @list. Write a script to find the total pairs in the
sorted list where 2 consecutive elements has the max gap. If the list contains less
then 2 elements then return 0.*

### Solution

```
largest_gap(Numbers, LargestGap):-
largest_gap(Numbers, -1, LargestGap).
largest_gap([], LargestGap, LargestGap).
largest_gap([_|[]], LargestGap, LargestGap).
largest_gap([A, B|Numbers], Gap, LargestGap):-
G is B - A,
(G > Gap, largest_gap([B|Numbers], G, LargestGap));
largest_gap([B|Numbers], Gap, LargestGap).
gap_pairs(Numbers, GapPairs):-
length(Numbers, L),
L =< 2,
GapPairs = 0.
gap_pairs(Numbers, GapPairs):-
length(Numbers, L),
L > 2,
largest_gap(Numbers, LargestGap),
gap_pairs(Numbers, LargestGap, 0, GapPairs).
gap_pairs([], _, GapPairs, GapPairs).
gap_pairs([_|[]], _, GapPairs, GapPairs).
gap_pairs([A, B|Numbers], LargestGap, Pairs, GapPairs):-
LargestGap #= B - A,
succ(Pairs, P),
gap_pairs([B|Numbers], LargestGap, P, GapPairs).
gap_pairs([A, B|Numbers], LargestGap, Pairs, GapPairs):-
LargestGap #\= B - A,
gap_pairs([B|Numbers], LargestGap, Pairs, GapPairs).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- gap_pairs([3], Pairs).
Pairs = 0 ?
(1 ms) yes
| ?- gap_pairs([2, 5, 8, 1], Pairs).
Pairs = 2 ?
yes
| ?-
```

### Notes

At first glance this code may look more complex than it really is. All we are doing is , first, computing the largest gap between any two adjacent numbers. Then, second, seeing which pairs have exactly this gap.

## Part 2

*You are given an integer $n > 0. Write a script to print the count of primes less
than $n.*

### Solution

```
primes_under_n(N, NumberPrimes):-
findall(Prime, (between(2, N, I), fd_prime(I), Prime = I), Primes),
length(Primes, NumberPrimes).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- primes_under_n(10, Primes).
Primes = 4
yes
| ?- primes_under_n(15, Primes).
Primes = 6
yes
| ?- primes_under_n(1, Primes).
Primes = 0
yes
| ?- primes_under_n(25, Primes).
Primes = 9
yes
```

### Notes

This solution is short and sweet! No reason or the writeup to be longer than the code itself, right?

## References

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

### 2022-12-18

The Weekly Challenge 195 (Prolog Solutions)

## Part 1

*You are given a positive integer, $n > 0. Write a script to print the count of all
special integers between 1 and $n.*

### Solution

```
code2digit(C, D):-
number_codes(D, [C]).
special(N):-
number_codes(N, NCodes),
maplist(code2digit, NCodes, Digits),
sort(Digits, DigitsSorted),
length(Digits, NumberDigits),
length(DigitsSorted, NumberDigits).
number_special(N, NumberSpecial):-
findall(I, (between(1, N, I), special(I)), Specials),
length(Specials, NumberSpecial).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- number_special(15, NumberSpecial).
NumberSpecial = 14
(1 ms) yes
| ?- number_special(35, NumberSpecial).
NumberSpecial = 32
(1 ms) yes
| ?-
```

### Notes

The definition of a *special integer* for this problem is an integer whose digits are
unique. To determine this specialness we split the number into its digits using
`number_codes/2`

and a `maplist/3`

which uses a small helper predicate to convert the
codes back to the corresponding digit.

After getting set with identifying special integers all the is left is to count up all the ones found in the given range.

## Part 2

*You are given a list of numbers, @list. Write a script to find most frequent even numbers
in the list. In case you get more than one even numbers then return the smallest even
integer. For all other case, return -1.*

### Solution

```
even(N, Even):-
(0 is mod(N, 2), Even = N);
(Even = nil).
frequency(ListNumbers, N, Frequency):-
delete(ListNumbers, N, ListDeleted),
length(ListNumbers, L),
length(ListDeleted, LD),
Frequency is L - LD.
most_frequent_even(ListNumbers, MostFrequentEven):-
maplist(even, ListNumbers, EN),
delete(EN, nil, EvenNumbers),
length(EvenNumbers, LengthEvens),
LengthEvens > 0,
maplist(frequency(ListNumbers), EvenNumbers, Frequencies),
msort(Frequencies, FS),
reverse(FS, FrequenciesSorted),
((
nth(1, FrequenciesSorted, F1),
nth(2, FrequenciesSorted, F2),
F1 \== F2,
nth(N, Frequencies, F1),
nth(N, EvenNumbers, MostFrequentEven)
);
(
nth(1, FrequenciesSorted, F1),
nth(2, FrequenciesSorted, F2),
F1 == F2,
findall(MFE, (member(FX, FrequenciesSorted), FX == F1, nth(N, Frequencies, FX), nth(N, EvenNumbers, MFE)), MostFrequentEvens),
sort(MostFrequentEvens, MostFrequentEvensSorted),
nth(1, MostFrequentEvensSorted, MostFrequentEven)
)
), !.
most_frequent_even(_, MostFrequentEven):-
MostFrequentEven = -1, !.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- most_frequent_even([1, 1, 2, 6, 2], MostFrequentEven).
MostFrequentEven = 2
yes
| ?- most_frequent_even([1, 3, 5, 7], MostFrequentEven).
MostFrequentEven = -1
yes
| ?- most_frequent_even([6, 4, 4, 6, 1], MostFrequentEven).
MostFrequentEven = 4
yes
| ?-
```

### Notes

The code here may look a bit more convoluted than it really is. Well my use of the
disjunction in `most_frequent/2`

may only be against my own personal sense of aesthetics!
Also, in balance the use of `maplist/3`

cleans things up a bit.

The main ideas here are:

Remove all odd numbers and check to see if any numbers remain.

Compute the frequency of each remaining even number.

Sort and see if there is a tie for most frequent.

If there is no tie in (3) then we're done in the first part of the disjunction. Otherwise, in the second part of the disjunction, find the smallest of the numbers tied for most frequent.

## References

posted at: 16:05 by: Adam Russell | path: /prolog | permanent link to this entry

#### Especially Frequent Even

## Part 1

*You are given a positive integer, $n > 0. Write a script to print the count of all
special integers between 1 and $n.*

### Solution

```
use v5.36;
use boolean;
sub is_special{
my($x) = @_;
my %h;
my @digits = split(//, $x);
map{ $h{$_} = undef } @digits;
return keys %h == @digits;
}
MAIN:{
say q// . grep{ is_special($_) } 1 .. $ARGV[0];
}
```

### Sample Run

```
$ perl perl/ch-1.pl 15
14
$ perl perl/ch-1.pl 35
32
```

### Notes

The definition of a *special integer* for this problem is an integer whose digits are
unique. To determine this specialness we define `is_special()`

which splits any given
number into an array of digits. Each of the digits are added to a hash as the keys. If any
digits are not unique then they will not be duplicated as a hash key and the test will
return false.

Once `is_special()`

is set all we need to do is to map over the given range and count up
the results!

## Part 2

*You are given a list of numbers, @list. Write a script to find most frequent even numbers
in the list. In case you get more than one even numbers then return the smallest even
integer. For all other case, return -1.*

### Solution

```
use v5.36;
sub most_frequent_even{
my @list = @_;
@list = grep { $_ % 2 == 0 } @list;
return -1 if @list == 0;
my %frequencies;
map { $frequencies{$_}++ } @list;
my @sorted = sort { $frequencies{$b} <=> $frequencies{$a} } @list;
return $sorted[0] if $frequencies{$sorted[0]} != $frequencies{$sorted[1]};
my @tied = grep { $frequencies{$_} == $frequencies{$sorted[0]} } @list;
return (sort { $a <=> $b } @tied)[0];
}
MAIN:{
my @list;
@list = (1, 1, 2, 6, 2);
say most_frequent_even(@list);
@list = (1, 3, 5, 7);
say most_frequent_even(@list);
@list = (6, 4, 4, 6, 1);
say most_frequent_even(@list);
}
```

### Sample Run

```
$ perl perl/ch-2.pl
2
-1
4
```

### Notes

map and grep really do a lot to make this solution pretty succinct. First grep is used to extract just the even numbers. Then map is used to count up the frequencies. In the case of ties grep is used to identify the numbers with a tied frequency. The tied numbers are then sorted with the lowest one being returned, as specified.

## References

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

### 2022-12-03

The Weekly Challenge 193 (Prolog Solutions)

## Part 1

*You are given an integer, $n > 0. Write a script to find all possible binary numbers of
size $n.*

### Solution

```
binary --> [].
binary --> digit, binary.
digit --> [0]; [1].
binary_numbers_size_n(N, BinaryNumbers):-
length(Binary, N),
findall(Binary, phrase(binary, Binary), BinaryNumbers).
main:-
binary_numbers_size_n(2, BinaryNumbers),
write(BinaryNumbers), nl.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- main.
[[0,0],[0,1],[1,0],[1,1]]
(1 ms) yes
| ?- binary_numbers_size_n(3, BinaryNumbers).
BinaryNumbers = [[0,0,0],[0,0,1],[0,1,0],[0,1,1],[1,0,0],[1,0,1],[1,1,0],[1,1,1]]
yes
| ?- binary_numbers_size_n(4, BinaryNumbers).
BinaryNumbers = [[0,0,0,0],[0,0,0,1],[0,0,1,0],[0,0,1,1],[0,1,0,0],[0,1,0,1],[0,1,1,0],[0,1,1,1],[1,0,0,0],[1,0,0,1],[1,0,1,0],[1,0,1,1],[1,1,0,0],[1,1,0,1],[1,1,1,0],[1,1,1,1]]
yes
```

### Notes

This challenge presented a perfect use for a DCG, right!?!? For convenience we wrap the
DCG in a predicate `binary_numbers_size_n/2`

to make sure we set a list of the correct
size.

## Part 2

*You are given a list of strings of same length, @s. Write a script to find the odd string
in the given list. Use positional alphabet values starting
with 0, i.e. a = 0, b = 1, ... z = 25.*

### Solution

```
string_differences(String, Differences):-
atom_codes(String, Codes),
string_differences(Codes, [], Differences).
string_differences([_|[]], Differences, Differences).
string_differences([C0, C1|T], DifferenceAccum, Differences):-
Difference is C1 - C0,
string_differences([C1|T], [Difference|DifferenceAccum], Differences).
odd_string(Strings, OddString):-
maplist(string_differences, Strings, Differences),
member(Difference, Differences),
delete(Differences, Difference, UpdatedDifferences),
length(UpdatedDifferences, UpdatedDifferencesLength),
UpdatedDifferencesLength > 1,
nth(N, Differences, Difference),
nth(N, Strings, OddString).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- odd_string([adc, wzy, abc], OddString).
OddString = abc ?
yes
| ?- odd_string([aaa, bob, ccc, ddd], OddString).
OddString = bob ?
(1 ms) yes
| ?- odd_string([aaaa, bbob, cccc, dddd], OddString).
OddString = bbob ?
yes
```

### Notes

The approach here is:

1) Compute all the differences for each string using `maplist/3`

`with string_differences/2`

, a helper predicate I wrote.

2) Once done we use `member/2`

identify a difference from the list

3) Delete the difference and see if the list has been reduced to size one.

4) If the list has not been reduced to one element then we know we have found the uniquely odd string!

5) By position, determine the OddString from the original list.

## References

posted at: 19:58 by: Adam Russell | path: /prolog | permanent link to this entry

#### The Weekly Challenge 193

## Part 1

*You are given an integer, $n > 0. Write a script to find all possible binary numbers of
size $n.*

### Solution

```
use v5.36;
sub binary_numbers_size_n{
my($n) = @_;
my @numbers = map {
sprintf("%0${n}b", $_)
} 0 .. 2**$n - 1;
return @numbers;
}
MAIN:{
say join(", ", binary_numbers_size_n(2));
say join(", ", binary_numbers_size_n(3));
say join(", ", binary_numbers_size_n(4));
}
```

### Sample Run

```
$ perl perl/ch-1.pl
00, 01, 10, 11
000, 001, 010, 011, 100, 101, 110, 111
0000, 0001, 0010, 0011, 0100, 0101, 0110, 0111, 1000, 1001, 1010, 1011, 1100, 1101, 1110, 1111
```

### Notes

I think it's fair to say that `sprintf`

is doing most of the work here! For those
unfamiliar, the format string `"%0${n}b"`

means *print the number as binary of length $n,
left pad with 0s*.

## Part 2

*You are given a list of strings of same length, @s. Write a script to find the odd string
in the given list. Use positional alphabet values starting
with 0, i.e. a = 0, b = 1, ... z = 25.*

### Solution

```
use v5.36;
sub odd_string{
my(@strings) = @_;
my %differences;
for my $string (@strings){
my $current;
my $previous;
my @differences;
map {
unless($previous){
$previous = $_;
}
else{
$current = $_;
push @differences, ord($current) - ord($previous);
$previous = $current;
}
} split(//, $string);
my $key = join(",", @differences);
my $size_before = keys %differences;
$differences{$key} = undef;
my $size_after = keys %differences;
return $string if $size_before > 0 && $size_after - $size_before == 1;
}
return undef;
}
MAIN:{
say odd_string(qw/adc wzy abc/);
say odd_string(qw/aaa bob ccc ddd/);
say odd_string(qw/aaaa bbbb cccc dddd/) || "no odd string found";
say odd_string(qw/aaaa bbob cccc dddd/);
}
```

### Sample Run

```
$ perl perl/ch-2.pl
abc
bob
no odd string found
bbob
```

### Notes

There is one main assumption here and that is that the list of strings is going to be of length three or more. If the array has length one then can we say that single string is "odd" in and of itself? And if we have only two strings and they aren't the same which is the the odd one?

The basic steps of this solution are:

1) For each string split it into an array of characters.

2) Compute the differences. This is done in the `map`

. I'll concede that this is a
somewhat unusual use of `map`

!

3) Transform the differences into a single string to be used as a hash key using `join`

.

4) If we add this differences based key to the hash and the hash size changes by 1 (assuming it is a non-empty hash) then we know we have found the unique "odd string" which is then returned.

## References

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

### 2022-11-27

The Weekly Challenge 192 (Prolog Solutions)

## Part 1

*You are given a positive integer, $n. Write a script to find the binary flip.*

### Solution

```
bits(N, Bits):-
bits(N, [], Bits).
bits(0, Bits, Bits):-!.
bits(N, BitsAccum, Bits):-
B is N /\ 1,
N0 is N >> 1,
bits(N0, [B|BitsAccum], Bits).
bits_reverse(B, RB):-
Flipped is xor(B, 1),
number_chars(Flipped, [RB]).
binary_flip(N, NBitsReversed):-
bits(N, Bits),
maplist(bits_reverse, Bits, BitsReversed),
number_chars(NBitsReversed, ['0','b'|BitsReversed]).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- binary_flip(5, BinaryFlip).
BinaryFlip = 2
yes
| ?- binary_flip(4, BinaryFlip).
BinaryFlip = 3
yes
| ?- binary_flip(6, BinaryFlip).
BinaryFlip = 1
yes
```

### Notes

I learned a slightly obscure bit (no pun intended!) of information about Prolog's handling
of binary numbers this week. If you prepend '0','b' to a list of characters, or the ascii
code equivalents to a list of codes, representing binary digits then `number_chars/2`

(or
`number_codes/2`

) will automatically convert to decimal.

The solution to the whole problem is:

Convert the number to a list of bits (

`bits/2`

).Flip the bits with an xor

Convert the list of flipped bits to decimal using the

`number_chars/2`

method.

## Part 2

*You are given a list of integers greater than or equal to zero, @list. Write a script to
distribute the number so that each members are same. If you succeed then print the total
moves otherwise print -1.*

### Solution

```
:-dynamic(moves/1).
moves(0).
equal_distribution(ListIntegers, _):-
length(ListIntegers, L),
sum_list(ListIntegers, S),
Average is S / L,
F is floor(Average),
C is ceiling(Average),
F \== C,
fail.
equal_distribution(ListIntegers, ListEqualDistribution):-
length(ListIntegers, L),
sum_list(ListIntegers, S),
Average is S / L,
F is floor(Average),
C is ceiling(Average),
F == C,
length(ListEqualDistribution, L),
equal_distribution(ListIntegers, F, ListEqual),
delete(ListEqual, F, ListEqualAverageDeleted),
length(ListEqualAverageDeleted, ListEqualAverageDeletedLength),
((ListEqualAverageDeletedLength == 0,
ListEqualDistribution = ListEqual);
equal_distribution(ListEqual, ListEqualDistribution)), !.
distribute(Average, [X, Y], [S, T]):-
X < Average,
X < Y,
S is X + 1,
T is Y - 1,
moves(Moves),
succ(Moves, M),
retract(moves(Moves)),
asserta(moves(M)).
distribute(Average, [X, Y], [S, T]):-
X > Average,
X > Y,
S is X - 1,
T is Y + 1,
moves(Moves),
succ(Moves, M),
retract(moves(Moves)),
asserta(moves(M)).
distribute(Average, [X, Y], [S, T]):-
((X == Average; X == Y);
(X < Average, X > Y)
),
S = X,
T = Y.
equal_distribution([A, B|[]], Average, [X, Y|[]]):-
maplist(distribute(Average),[[A, B]], [[X, Y]]).
equal_distribution(ListIntegers, Average, [X|T]):-
append([A, B], RestIntegers, ListIntegers),
maplist(distribute(Average),[[A, B]], [[X, Y]]),
equal_distribution([Y|RestIntegers], Average, T).
main(ListIntegers, Moves):-
retract(moves(_)),
asserta(moves(0)),
(equal_distribution(ListIntegers, _), moves(Moves), !);
Moves = -1.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- main([1, 0, 5], Moves).
Moves = 4
(1 ms) yes
| ?- main([0, 2, 0], Moves).
Moves = -1
yes
| ?- main([0, 3, 0], Moves).
Moves = 2
yes
```

### Notes

The rules that must be followed are:

1) You can only move a value of '1' per move

2) You are only allowed to move a value of '1' to a direct neighbor/adjacent cell.

This code ended up being a little more complex than I had originally thought it would be.
At the heart of the solution is what I consider a pretty nice application of `maplist/3`

to drive the `distribution/3`

, which is the implementation of the given rules.

We need to track the number of moves taken, not just the final resulting list. Rather than
track the moves using a variable passed to the various predicates handling the
re-distribution it seemed a bit cleaner to me to instead not have so many variables and
`asserta/1`

and `retract/1`

the updated number of moves.

I generally try and avoid the use of the disjunction `(;)/2`

with the exception of small
cases where to use it would unnaturally increase the amount of code. In this problem there
are several such small cases such as whether we set the number of Moves to -1 in the case
of an impossible re-distribution or the condition for detecting that we are done
re-distributing.

## References

posted at: 19:05 by: Adam Russell | path: /prolog | permanent link to this entry

#### Flipping to Redistribute

## Part 1

*You are given a positive integer, $n. Write a script to find the binary flip.*

### Solution

```
use v5.36;
sub int2bits{
my($n) = @_;
my @bits;
while($n){
my $b = $n & 1;
unshift @bits, $b;
$n = $n >> 1;
}
return @bits
}
sub binary_flip{
my($n) = @_;
my @bits = int2bits($n);
@bits = map {$_^ 1} @bits;
return oct(q/0b/ . join(q//, @bits));
}
MAIN:{
say binary_flip(5);
say binary_flip(4);
say binary_flip(6);
}
```

### Sample Run

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

### Notes

There was once a time when I was positively terrified of bitwise operations. Anything at that level seemed a bit like magic. Especially spooky were the bitwise algorithms detailed in Hacker's Delight! Anyway, has time has gone on I am a bit more confortable with these sorts of things. Especially when, like this problem, the issues are fairly straightforward.

The code here does the following:

converts a given integer into an array of bits via

`int2bits()`

flips the bits using an xor operation (the

`map`

in`binary_flip()`

)converts the array of flipped bits to the decimal equivalent via

`oct()`

which, despite the name, handles any decimal, binary, octal, and hex strings as input.

## Part 2

*You are given a list of integers greater than or equal to zero, @list. Write a script to
distribute the number so that each members are same. If you succeed then print the total
moves otherwise print -1.*

### Solution

```
use v5.36;
use POSIX;
sub equal_distribution{
my(@integers) = @_;
my $moves;
my $average = unpack("%32I*", pack("I*", @integers)) / @integers;
return -1 unless floor($average) == ceil($average);
{
map{
my $i = $_;
if($integers[$i] > $average && $integers[$i] > $integers[$i+1]){$integers[$i]--; $integers[$i+1]++; $moves++}
if($integers[$i] < $average && $integers[$i] < $integers[$i+1]){$integers[$i]++; $integers[$i+1]--; $moves++}
} 0 .. @integers - 2;
redo unless 0 == grep {$average != $_} @integers;
}
return $moves;
}
MAIN:{
say equal_distribution(1, 0, 5);
say equal_distribution(0, 2, 0);
say equal_distribution(0, 3, 0);
}
```

### Sample Run

```
$ perl perl/ch-2.pl
4
-1
2
```

### Notes

The rules that must be followed are:

1) You can only move a value of '1' per move

2) You are only allowed to move a value of '1' to a direct neighbor/adjacent cell.

First we compute the average of the numbers in the list. Provided that the average is a
non-decimal (confirmed by comparing `floor`

to `ceil`

) we know we can compute the
necessary "distribution".

The re-distribution itself is handled just by following the rules and continuously looping until all values in the list are the same.

## References

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

### 2022-11-20

#### Twice Largest Once Cute

## Part 1

*You are given list of integers, @list. Write a script to find out whether the largest
item in the list is at least twice as large as each of the other items.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub twice_largest{
my(@list_integers) = @_;
my @sorted_integers = sort {$a <=> $b} @list_integers;
for my $i (@sorted_integers[0 .. @sorted_integers - 1]){
unless($sorted_integers[@sorted_integers - 1] == $i){
return -1 unless $sorted_integers[@sorted_integers - 1] >= 2 * $i;
}
}
return 1;
}
MAIN:{
say twice_largest(1, 2, 3, 4);
say twice_largest(1, 2, 0, 5);
say twice_largest(2, 6, 3, 1);
say twice_largest(4, 5, 2, 3);
}
```

### Sample Run

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

### Notes

For Part 1 I at first couldn't see how to avoid a basic O(n^2) nested for loop. After I took a nap I think the best approach is what I have here:

sort the list O(n log n)

get the max element from the sorted list O(1)

iterate over the sorted list, stop and return false if at any point an element times two is not less then max. return true if all elements (other than $max itself) pass the test. O(n)

So total worst case dominated by the sort O(n log n).

(And the nap was required because I was on an overnight camping trip with my son's Cub Scout pack the previous day and barely slept at all!)

## Part 2

*You are given an integer, 0 < $n <= 15. Write a script to find the number of orderings
of numbers that form a cute list.*

### Solution

```
use v5.36;
use strict;
use warnings;
use Hash::MultiKey;
sub cute_list{
my($n) = @_;
my %cute;
tie %cute, "Hash::MultiKey";
for my $i (1 .. $n){
$cute{[$i]} = undef;
}
my $i = 1;
{
$i++;
my %cute_temp;
tie %cute_temp, "Hash::MultiKey";
for my $j (1 .. $n){
for my $cute (keys %cute){
if(0 == grep {$j == $_} @{$cute}){
if(0 == $j % $i || 0 == $i % $j){
$cute_temp{[@{$cute}, $j]} = undef;
}
}
}
}
%cute = %cute_temp;
untie %cute_temp;
redo unless $i == $n;
}
return keys %cute;
}
MAIN:{
say cute_list(2) . q//;
say cute_list(3) . q//;
say cute_list(5) . q//;
say cute_list(10) . q//;
say cute_list(11) . q//;
say cute_list(15) . q//;
}
```

### Sample Run

```
$ perl perl/ch-2.pl
2
3
10
700
750
24679
```

### Notes

This solution with a dynamic programming style approach seems to work pretty well. cute(11) runs in less than a second (perl 5.34.0, M1 Mac Mini 2020) which is pretty good compared to some other reported run times that have been posted to social media this week.

Some may notice that the solution here bears a striking resemblance to the one for TWC 117! The logic there was a bit more complicated, since multiple paths could be chosen. The overall idea is the same though: as we grow the possible lists we are able to branch and create new lists (paths).

## References

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

The Weekly Challenge 191 (Prolog Solutions)

## Part 1

*You are given an encoded string consisting of a sequence $s of numeric characters: 0..9.
Write a script to find the all valid different decodings in sorted order.*

### Solution

```
twice_greater(X, Y, TwiceGreater):-
X \== Y,
TwiceY is 2 * Y,
X >= TwiceY,
TwiceGreater = -1.
twice_greater(X, Y, TwiceGreater):-
TwiceY is 2 * Y,
X < TwiceY,
TwiceGreater = 1.
twice_largest(List):-
max_list(List, Max),
maplist(twice_greater(Max), List, TwiceGreater),
delete(TwiceGreater, -1, TwiceGreaterOneDeleted),
length(TwiceGreaterOneDeleted, TwiceGreaterOneDeletedLength),
TwiceGreaterOneDeletedLength == 1, !.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- twice_largest([1, 2, 3, 4]).
no
| ?- twice_largest([1, 2, 0, 5]).
yes
| ?- twice_largest([2, 6, 3, 1]).
yes
| ?- twice_largest([4, 5, 2, 3]).
no
```

### Notes

There are a few ways one could approach this problem. I thought this implementation was
nice and concise, albeit unconventional. `maplist/3`

is used to generate a list with
entries corresponding to whether or not the respective element, times two, in the original
List was more or less than the List Max. If we find only one element fails this, the List
Max itself, then `twice_largest/1`

is true.

## Part 2

*You are given an integer, 0 < $n <= 15. Write a script to find the number of orderings
of numbers that form a cute list.*

### Solution

```
cute(_, _) --> [].
cute(N, CuteList) --> [X], {between(1, N, X), \+ member(X, CuteList),
length(CuteList, CuteListLength),
succ(CuteListLength, I),
(0 is mod(X, I); 0 is mod(I, X)),
append(CuteList, [X], CuteListUpdated)},
cute(N, CuteListUpdated).
main:-
N = 15,
findall(Cute, (length(Cute, N), phrase(cute(N, []), Cute)), C),
sort(C, CuteList),
length(CuteList, NumberCuteList),
write(NumberCuteList), nl.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- main.
24679
```

### Notes

This is a somewhat convoluted use of a DCG and, in turn, the DCG code itself might be a
bit convoluted. Here the DCG will generate all lists which conform to the given rules.
There ends up being some duplication which is natural given the condition. To remove the
duplicates I `sort/2`

the results.

## References

posted at: 16:05 by: Adam Russell | path: /prolog | permanent link to this entry

### 2022-11-13

The Weekly Challenge 190 (Prolog Solutions)

## Part 1

*You are given a string with alphabetic characters only: A..Z and a..z. Write a script to
find out if the usage of Capital is appropriate if it satisfies at least one of the
rules.*

### Solution

```
all_small([]).
all_small([H|T]):-
H >= 97,
H =< 122,
all_small(T).
all_capitals([]).
all_capitals([H|T]):-
H >= 65,
H =< 90,
all_capitals(T).
capital_detection([]).
capital_detection([H|T]):-
H >= 65,
H =< 90,
all_capitals(T).
capital_detection([H|T]):-
H >= 65,
H =< 90,
all_small(T).
capital_detection([H|T]):-
H >= 97,
H =< 122,
all_small(T).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- capital_detection("Perl").
true ?
yes
| ?- capital_detection("TPF").
true ?
(1 ms) yes
| ?- capital_detection("PyThon").
no
| ?- capital_detection("raku").
yes
```

### Notes

The rules to be satisfied are:

```
1) Only first letter is capital and all others are small.
2) Every letter is small.
3) Every letter is capital.
```

While I know it is not everyone's favorite way of handling strings in Prolog, I prefer to stick with the codes representation of double quotes strings. Here the solution is pretty straightforward, with the code being in most ways a direct translation of the rules.

## Part 2

*You are given an encoded string consisting of a sequence $s of numeric characters: 0..9.
Write a script to find the all valid different decodings in sorted order.*

### Solution

```
digits([1, 2]).
alphabet(1, 'A').
alphabet(2, 'B').
alphabet(3, 'C').
alphabet(4, 'D').
alphabet(5, 'E').
alphabet(6, 'F').
alphabet(7, 'G').
alphabet(8, 'H').
alphabet(9, 'I').
alphabet(10,'J').
alphabet(11, 'K').
alphabet(12, 'L').
alphabet(13, 'M').
alphabet(14, 'N').
alphabet(15, 'O').
alphabet(16, 'P').
alphabet(17, 'Q').
alphabet(18, 'R').
alphabet(19, 'S').
alphabet(20, 'T').
alphabet(21, 'U').
alphabet(22, 'V').
alphabet(23, 'W').
alphabet(24, 'X').
alphabet(25, 'Y').
alphabet(26, 'Z').
list_chunks(_, [], []).
list_chunks(List, [H|T], [PrefixNumber|RestNumbers]):-
length(Prefix, H),
prefix(Prefix, List),
append(Prefix, Rest, List),
number_codes(PrefixNumber, Prefix),
list_chunks(Rest, T, RestNumbers).
sum(Digits, Length):-
sum([], Digits, Length, 0).
sum(Digits, Digits, _, _).
sum(Partial, Digits, Length, Sum):-
Sum < Length,
digits(L),
member(X, L),
S is Sum + X,
sum([X | Partial], Digits, Length, S).
decode(Encoded, Decoded):-
number_codes(Encoded, EncodedCodes),
length(EncodedCodes, EncodedLength),
findall(Digits,(
sum(Digits, EncodedLength),
sum_list(Digits, EncodedLength)), DigitList),
findall(Chunks, (
member(ChunkSizes, DigitList),
list_chunks(EncodedCodes, ChunkSizes, Chunks)), ChunkList),
findall(DecodedChunk,(
member(C, ChunkList),
maplist(alphabet, C, DecodedChunkChars),
atom_chars(DecodedChunk, DecodedChunkChars)), Decoded).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- decode(11, Decoded).
Decoded = ['AA','K']
yes
| ?- decode(1115, Decoded).
Decoded = ['AAAE','KAE','AKE','AAO','KO']
(1 ms) yes
| ?- decode(127, Decoded).
Decoded = ['ABG','LG']
yes
```

### Notes

There is an element of this task which reminded me of a much older problem presented back in TWC 075. In brief, the question was how many ways could coins be used in combination to form a target sum. My solution used a mix of Prolog and Perl since Prolog is especially well suited for elegant solutions to these sorts of combinatorial problems.

I recognized that this week we have a similar problem in how we may separate the given encoded string into different possible chunks for decoding. Here we know that no chunk may have value greater than 26 and so we can only choose one or two digits at a time. How many ways we can make these one or two digit chunks is the exact same problem, somewhat in hiding, as in TWC 075!

For the Perl Solutions to this problem I re-used much of that older code mentioned above. Also, that Prolog code which was embedded in the Perl code was used as the basis for this pure Prolog solution.

`decode/2`

is the main predicate. We need to work across all possible splits of the
list of the number and it's easiest to use `findall/3`

to cover the splitting of the
number, the chunking, and the final decoding of all possible combinations.

## References

posted at: 21:12 by: Adam Russell | path: /prolog | permanent link to this entry

#### Capital Detection Decode

## Part 1

*You are given a string with alphabetic characters only: A..Z and a..z. Write a script to
find out if the usage of Capital is appropriate if it satisfies at least one of the
rules.*

### Solution

```
use v5.36;
use strict;
use warnings;
use boolean;
sub capital_detection{
{my($s) = @_; return true if length($s) == $s =~ tr/A-Z//d;}
{my($s) = @_; return true if length($s) == $s =~ tr/a-z//d;}
{
my($s) = @_;
$s =~ m/(^.{1})(.*)$/;
my $first_letter = $1;
my $rest_letters = $2;
return true if $first_letter =~ tr/A-Z//d == 1 &&
length($rest_letters) == $rest_letters =~ tr/a-z//d;
}
return false;
}
MAIN:{
say capital_detection(q/Perl/);
say capital_detection(q/TPF/);
say capital_detection(q/PyThon/);
say capital_detection(q/raku/);
}
```

### Sample Run

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

### Notes

The rules to be satisfied are:

```
1) Only first letter is capital and all others are small.
2) Every letter is small.
3) Every letter is capital.
```

I did a bit of experimenting with `tr`

this week. Somewhat relatedly I also reminded
myself of *scope* issues in Perl.

The `tr`

function has a nice feature where it returns the number of characters changed, or
as was the case here, deleted. Here we delete all upper or lower case letters and if the
number of letters deleted is equal to original length we know that the original contained
all upper/lower case letters as required by the rules. One catch is that `tr`

when used
this way alters the original string. One way around that would be to use temporary
variables. Another option is to contain each of these rules checks in their own block!

## Part 2

*You are given an encoded string consisting of a sequence $s of numeric characters: 0..9.
Write a script to find the all valid different decodings in sorted order.*

### Solution

```
use v5.36;
use strict;
use warnings;
use AI::Prolog;
use Hash::MultiKey;
my $prolog_code;
sub init_prolog{
$prolog_code = do{
local $/;
<DATA>;
};
}
sub decoded_list{
my($s) = @_;
my $prolog = $prolog_code;
my @alphabet = qw/A B C D E F G H I J K L M N O P Q R S T U V W X Y Z/;
my @encoded;
my @decoded;
my $length = length($s);
$prolog =~ s/_LENGTH_/$length/g;
$prolog = AI::Prolog->new($prolog);
$prolog->query("sum(Digits).");
my %h;
tie %h, "Hash::MultiKey";
while(my $result = $prolog->results){
$h{$result->[1]} = undef;
}
for my $pattern (keys %h){
my $index = 0;
my $encoded = [];
for my $i (@{$pattern}){
push @{$encoded}, substr($s, $index, $i);
$index += $i;
}
push @encoded, $encoded if 0 == grep { $_ > 26 } @{$encoded};
}
@decoded = sort { $a cmp $b } map { join("", map { $alphabet[$_ - 1] } @{$_}) } @encoded;
}
MAIN:{
init_prolog;
say join(", ", decoded_list(11));
say join(", ", decoded_list(1115));
say join(", ", decoded_list(127));
}
__DATA__
member(X,[X|_]).
member(X,[_|T]) :- member(X,T).
digits([1, 2]).
sum(Digits):-
sum([], Digits, 0).
sum(Digits, Digits, _LENGTH_).
sum(Partial, Digits, Sum):-
Sum < _LENGTH_,
digits(L),
member(X,L),
S is Sum + X,
sum([X | Partial], Digits, S).
```

### Sample Run

```
$ perl perl/ch-2.pl
AA, K
AAAE, AAO, AKE, KAE, KO
ABG, LG
```

### Notes

There is an element of this task which reminded me of a much older problem presented back in TWC 075. In brief, the question was how many ways could coins be used in combination to form a target sum. My solution used a mix of Prolog and Perl since Prolog is especially well suited for elegant solutions to these sorts of combinatorial problems.

I recognized that this week we have a similar problem in how we may separate the given encoded string into different possible chunks for decoding. Here we know that no chunk may have value greater than 26 and so we can only choose one or two digits at a time. How many ways we can make these one or two digit chunks is the exact same problem, somewhat in hiding, as in TWC 075!

I re-use almost the exact same Prolog code as used previously. This is used to identify
the different combinations of digits for all possible chunks. Once that is done we need
only map the chunks to letters and `sort`

.

## References

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

### 2022-11-06

The Weekly Challenge 189 (Prolog Solutions)

## Part 1

*You are given an array of characters (a..z) and a target character. Write a script to
find out the smallest character in the given array lexicographically greater than the
target character.*

### Solution

```
greater_than_character(Target, C0, C1):-
C0 > Target,
C1 = C0.
greater_than_character(Target, C0, C1):-
\+ C0 > Target,
C1 = nil.
greater_character(Characters, Target, Greater):-
maplist(greater_than_character(Target), Characters, GreaterCharacters),
delete(GreaterCharacters, nil, GreaterCharactersNonNil),
length(GreaterCharactersNonNil, GreaterCharactersNonNilLength),
GreaterCharactersNonNilLength > 0,
min_list(GreaterCharactersNonNil, GreaterChar),
char_code(Greater, GreaterChar), !.
greater_character(Characters, [Target], Greater):-
maplist(greater_than_character(Target), Characters, GreaterCharacters),
delete(GreaterCharacters, nil, GreaterCharactersNonNil),
length(GreaterCharactersNonNil, GreaterCharactersNonNilLength),
GreaterCharactersNonNilLength == 0,
char_code(Greater, Target), !.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- greater_character("emug", "b", LeastGreaterCharacter).
LeastGreaterCharacter = e
(1 ms) yes
| ?- greater_character("dcef", "a", LeastGreaterCharacter).
LeastGreaterCharacter = c
yes
| ?- greater_character("jar", "o", LeastGreaterCharacter).
LeastGreaterCharacter = r
(1 ms) yes
| ?- greater_character("dcaf", "a", LeastGreaterCharacter).
LeastGreaterCharacter = c
(1 ms) yes
| ?- greater_character("tgal", "v", LeastGreaterCharacter).
LeastGreaterCharacter = v
yes
```

### Notes

First off, I should note that the use of double quoted strings here might confuse some
people. To clarify, in GNU Prolog what look like double quoted strings are handled as
lists of character codes. Character codes, not characters! So the use of *Character*
in some variable names may seem a little distracting. They are accurate in intent, but if
you are unaware of what's going on it may seem a little strange.

For the solution itself I use a trick with `maplist/3`

that I have used
previously.
`greater_than_character/3`

will either return the character greater than the target or
`nil`

otherwise. `min_list/2`

is then used to get the smallest character which is
greater than the target, as required. Also, note that in the case no character is found to
be greater than the target we instead supply the target itself.

## Part 2

*You are given an array of 2 or more non-negative integers. Write a script to find out the
smallest slice, i.e. contiguous subarray of the original array, having the degree of the
given array.*

### Solution

```
array_degree(Array, Degree):-
array_degree(Array, Array, 0, Degree), !.
array_degree([], _, Degree, Degree).
array_degree([H|T], Array, DegreeAccum, Degree):-
length(Array, ArrayLength),
delete(Array, H, ArrayWithout),
length(ArrayWithout,ArrayWithoutLength),
CurrentDegree is ArrayLength - ArrayWithoutLength,
CurrentDegree > DegreeAccum,
array_degree(T, Array, CurrentDegree, Degree).
array_degree([H|T], Array, DegreeAccum, Degree):-
length(Array, ArrayLength),
delete(Array, H, ArrayWithout),
length(ArrayWithout,ArrayWithoutLength),
CurrentDegree is ArrayLength - ArrayWithoutLength,
\+ CurrentDegree > DegreeAccum,
array_degree(T, Array, DegreeAccum, Degree).
least_slice_degree(Array, LeastDegreeSlice):-
array_degree(Array, ArrayDegree),
findall(Sublist, (prefix(Prefix, Array), suffix(Suffix, Array),
sublist(Sublist, Array), length(Sublist, SublistLength),
SublistLength >= 2, flatten([Prefix, Sublist, Suffix], Array)), Sublists),
sort(Sublists, Slices),
findall(DegreeSlice, (member(Slice, Slices), array_degree(Slice, Degree), DegreeSlice = Degree-Slice), DegreeSlices),
findall(MatchingSlice, (member(DegreeSlice, DegreeSlices), ArrayDegree-MatchingSlice = DegreeSlice), MatchingSlices),
findall(LengthSlice, (member(MatchingDegreeSlice, MatchingSlices), length(MatchingDegreeSlice, MatchingDegreeSliceLength), LengthSlice = MatchingDegreeSliceLength-MatchingDegreeSlice), LengthSlices),
keysort(LengthSlices),
[_-LeastDegreeSlice|_] = LengthSlices.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- least_slice_degree([1, 3, 3, 2], LeastDegreeSlice).
LeastDegreeSlice = [3,3]
(6 ms) yes
| ?- least_slice_degree([1, 2, 1, 3], LeastDegreeSlice).
LeastDegreeSlice = [1,2,1]
(6 ms) yes
| ?- least_slice_degree([1, 3, 2, 1, 2], LeastDegreeSlice).
LeastDegreeSlice = [2,1,2]
(19 ms) yes
| ?- least_slice_degree([1, 1, 2, 3, 2], LeastDegreeSlice).
LeastDegreeSlice = [1,1]
(19 ms) yes
| ?- least_slice_degree([2, 1, 2, 1, 1], LeastDegreeSlice).
LeastDegreeSlice = [1,2,1,1]
(20 ms) yes
```

### Notes

This is the most I've used `findall/3`

in a long time! The main complexity here, I feel,
is in that we must compute all contiguous slices of the original list. `sublist/2`

is not
useful by itself here as it returns sublists which are not contiguous, only ordered. With
the help of `prefix/2`

and `suffix/2`

we are able to identify contiguous sublists.

`findall/3`

is used, then, to obtain and then process all of these contiguous slices to
ultimately identify the one that meets all criteria. First we identify all slices, then we
obtain all degree/slice pairs, and then finally we examine the lengths.

## References

posted at: 20:57 by: Adam Russell | path: /prolog | permanent link to this entry

#### To a Greater Degree

## Part 1

*You are given an array of characters (a..z) and a target character. Write a script to
find out the smallest character in the given array lexicographically greater than the
target character.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub greatest_character{
my($characters, $target) = @_;
return [sort {$a cmp $b} grep {$_ gt $target} @{$characters}]->[0] || $target;
}
MAIN:{
say greatest_character([qw/e m u g/], q/b/);
say greatest_character([qw/d c e f/], q/a/);
say greatest_character([qw/j a r/], q/o/);
say greatest_character([qw/d c a f/], q/a/);
say greatest_character([qw/t g a l/], q/v/);
}
```

### Sample Run

```
$ perl perl/ch-1.pl
e
c
r
c
v
```

### Notes

Practically a one liner! Here we use `grep`

to filter out all the characters greater than
the target. The results are then sorted and we return the first one. If all that yields no
result, say there are no characters greater than the target, the just return the target.

## Part 2

*You are given an array of 2 or more non-negative integers. Write a script to find out the
smallest slice, i.e. contiguous subarray of the original array, having the degree of the
given array.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub array_degree{
my(@integers) = @_;
my @counts;
map { $counts[$_]++ } @integers;
@counts = grep {defined} @counts;
return [sort {$b <=> $a} @counts]->[0];
}
sub least_slice_degree{
my(@integers) = @_;
my @minimum_length_slice;
my $minimum_length = @integers;
my $array_degree = array_degree(@integers);
for my $i (0 .. @integers - 1){
for my $j ($i + 1 .. @integers - 1){
if(array_degree(@integers[$i .. $j]) == $array_degree && @integers[$i .. $j] < $minimum_length){
@minimum_length_slice = @integers[$i .. $j];
$minimum_length = @minimum_length_slice;
}
}
}
return @minimum_length_slice;
}
MAIN:{
say "(" . join(", ", least_slice_degree(1, 3, 3, 2)) . ")";
say "(" . join(", ", least_slice_degree(1, 2, 1)) . ")";
say "(" . join(", ", least_slice_degree(1, 3, 2, 1, 2)) . ")";
say "(" . join(", ", least_slice_degree(1, 1 ,2 ,3, 2)) . ")";
say "(" . join(", ", least_slice_degree(2, 1, 2, 1, 1)) . ")";
}
```

### Sample Run

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

### Notes

I view this problem in two main pieces:

Compute the degree of any given array.

Generate all contiguous slices of the given array and looking for a match on the criteria.

So, with that in mind we perform (1) in `sub array_degree`

and then think of how we might
best compute all those contiguous slices. Here we use a nested `for`

loop. Since we also
need to check to see if any of the computed slices have an array degree equal to the
starting array we just do that inside the nested loop as well. This way we don't need to
use any extra storage. Instead we just track the minimum length slice with matching array
degree. Once the loops exit we return that minimum length slice.

## References

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

### 2022-10-30

#### Pairs Divided by Zero

## Part 1

*You are given list of integers @list of size $n and divisor $k. Write a script to
find out count of pairs in the given list that satisfies a set of rules.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub divisible_pairs{
my($numbers, $k) = @_;
my @pairs;
for my $i (0 .. @{$numbers} - 1){
for my $j ($i + 1 .. @{$numbers} - 1){
push @pairs, [$i, $j] if(($numbers->[$i] + $numbers->[$j]) % $k == 0);
}
}
return @pairs;
}
MAIN:{
my @pairs;
@pairs = divisible_pairs([4, 5, 1, 6], 2);
print @pairs . "\n";
@pairs = divisible_pairs([1, 2, 3, 4], 2);
print @pairs . "\n";
@pairs = divisible_pairs([1, 3, 4, 5], 3);
print @pairs . "\n";
@pairs = divisible_pairs([5, 1, 2, 3], 4);
print @pairs . "\n";
@pairs = divisible_pairs([7, 2, 4, 5], 4);
print @pairs . "\n";
}
```

### Sample Run

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

### Notes

The rules, if not clear from the above code are : the pair (i, j) is eligible if and only if

0 <= i < j < len(list)

list[i] + list[j] is divisible by k

While certainly possible to develop a more complicated looking solution using `map`

and
`grep`

I found myself going with nested `for`

loops. The construction of the loop indices
takes care of the first condition and the second is straightforward.

## Part 2

*You are given two positive integers $x and $y. Write a script to find out the number of
operations needed to make both ZERO.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub count_zero{
my($x, $y) = @_;
my $count = 0;
{
my $x_original = $x;
$x = $x - $y if $x >= $y;
$y = $y - $x_original if $y >= $x_original;
$count++;
redo unless $x == 0 && $y == 0;
}
return $count;
}
MAIN:{
say count_zero(5, 4);
say count_zero(4, 6);
say count_zero(2, 5);
say count_zero(3, 1);
say count_zero(7, 4);
}
```

### Sample Run

```
$ perl perl/ch-2.pl
5
3
4
3
5
```

### Notes

The operations are dictated by these rules:

`$x = $x - $y if $x >= $y`

or

`$y = $y - $x if $y >= $x (using the original value of $x)`

This problem seemed somewhat confusingly stated at first. I had to work through the first given example by hand to make sure I really understood what was going on.

After a little analysis I realized this is not as confusing as I first thought. The main
problem I ran into was not properly accounting for the changed value of `$x`

using a
temporary variable `$x_original`

. If you see my
Prolog Solutions for this
problem you can see how Prolog's immutable variables obviate this issue!

## References

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

The Weekly Challenge 188 (Prolog Solutions)

## Part 1

*You are given list of integers @list of size $n and divisor $k. Write a script to
find out count of pairs in the given list that satisfies a set of rules.*

### Solution

```
divisible_pair(Numbers, K, Pair):-
length(Numbers, NumbersLength),
between(1, NumbersLength, I),
succ(I, INext),
between(INext, NumbersLength, J),
nth(I, Numbers, Ith),
nth(J, Numbers, Jth),
IJModK is (Ith + Jth) mod K,
IJModK == 0,
Pair = [I, J].
divisible_pairs(Numbers, K, Pairs):-
findall(Pair, divisible_pair(Numbers, K, Pair), Pairs).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- divisible_pairs([4, 5, 1, 6], 2, Pairs), length(Pairs, NumberPairs).
NumberPairs = 2
Pairs = [[1,4],[2,3]]
(1 ms) yes
| ?- divisible_pairs([1, 2, 3, 4], 2, Pairs), length(Pairs, NumberPairs).
NumberPairs = 2
Pairs = [[1,3],[2,4]]
(1 ms) yes
| ?- divisible_pairs([1, 3, 4, 5], 3, Pairs), length(Pairs, NumberPairs).
NumberPairs = 2
Pairs = [[1,4],[3,4]]
yes
| ?- divisible_pairs([5, 1, 2, 3], 4, Pairs), length(Pairs, NumberPairs).
NumberPairs = 2
Pairs = [[1,4],[2,4]]
yes
| ?- divisible_pairs([7, 2, 4, 5], 4, Pairs), length(Pairs, NumberPairs).
NumberPairs = 1
Pairs = [[1,4]]
yes
```

### Notes

The rules, if not clear from the above code are : the pair (i, j) is eligible if and only if

0 <= i < j < len(list)

list[i] + list[j] is divisible by k

There really is not too much here beyond translating the rules into Prolog. The first
condition on i and j are handled by default using `between/3`

. Once we define how to find
one such pair we use `findall/3`

to obtain them all.

## Part 2

*You are given two positive integers $x and $y. Write a script to find out the number of
operations needed to make both ZERO.*

### Solution

```
count_zero(X, Y, Count):-
count_zero(X, Y, 0, Count), !.
count_zero(0, 0, Count, Count).
count_zero(X, Y, CountAccum, Count):-
X > Y,
XNew is X - Y,
succ(CountAccum, CountAccumSucc),
count_zero(XNew, Y, CountAccumSucc, Count).
count_zero(X, Y, CountAccum, Count):-
Y > X,
YNew is Y - X,
succ(CountAccum, CountAccumSucc),
count_zero(X, YNew, CountAccumSucc, Count).
count_zero(X, Y, CountAccum, Count):-
X == Y,
XNew is X - Y,
YNew is Y - X,
succ(CountAccum, CountAccumSucc),
count_zero(XNew, YNew, CountAccumSucc, Count).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- count_zero(5, 4, Count).
Count = 5
(1 ms) yes
| ?- count_zero(4, 6, Count).
Count = 3
yes
| ?- count_zero(2, 5, Count).
Count = 4
yes
| ?- count_zero(3, 1, Count).
Count = 3
yes
| ?- count_zero(7, 4, Count).
Count = 5
yes
```

### Notes

The operations are dictated by these rules:

`$x = $x - $y if $x >= $y`

or

`$y = $y - $x if $y >= $x (using the original value of $x)`

Be carefully examining the rules we can see that we can arrange `count_zero/4`

predicates
in a somewhat concise way. I find this preferable to Prolog's if/else syntax which
absolutely could have been used here. I would argue that the slightly longer form here is
worthwhile in that it is much more readable.

One thing I found especially convenient was that due to the immutable nature of Prolog
variables we don;t have to do any extra accounting for the possibly changed value of `X`

when computing an updated `Y`

. The
Perl solution to this
requires a temporary variable, for example.

## References

posted at: 18:55 by: Adam Russell | path: /prolog | permanent link to this entry

### 2022-10-23

The Weekly Challenge 187 (Prolog Solutions)

## Part 2

*You are given a list of positive numbers, @n, having at least 3 numbers.
Write a script to find the triplets (a, b, c) from the given list that satisfies
a set of rules.*

### Solution

```
magical_triple_sum(Numbers, Triple, TripleSum):-
sublist([A, B, C], Numbers),
A + B > C,
B + C > A,
A + C > B,
Triple = [A, B, C],
sum_list(Triple, TripleSum).
magical_triple(Numbers, Triple):-
fd_maximize(magical_triple_sum(Numbers, Triple, TripleSum), TripleSum).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- magical_triple([4, 2, 3], Triple).
Triple = [4,2,3] ?
(1 ms) yes
| ?- magical_triple([1, 3, 2], Triple).
no
| ?- magical_triple([1, 1, 3, 2], Triple).
no
| ?- magical_triple([1, 2, 3, 2], Triple).
Triple = [2,3,2] ?
yes
```

### Notes

The "magical" rules, if not clear from the above code are:

a + b > c

b + c > a

a + c > b

a + b + c is maximum.

I don't routinely do a lot of constraint programming, but I don't think a smaller solution for this can be written! Indeed, the code here is largely a rewriting of the given rules in slightly modified Prolog form.

## References

posted at: 17:25 by: Adam Russell | path: /prolog | permanent link to this entry

#### Days Together Are Magical

## Part 1

*Two friends, Foo and Bar gone on holidays seperately to the same city. You are
given their schedule i.e. start date and end date. To keep the task simple, the
date is in the form DD-MM and all dates belong to the same calendar
year i.e. between 01-01 and 31-12.
Also the year is non-leap year and both dates are inclusive. Write a script to
find out for the given schedule, how many days they spent together in the
city, if at all.*

### Solution

```
use v5.36;
use strict;
use warnings;
use Time::Piece;
use Time::Seconds;
sub days_together{
my($together) = @_;
my $days_together = 0;
my($start, $end);
my $foo_start = Time::Piece->strptime($together->{Foo}->{SD}, q/%d-%m/);
my $bar_start = Time::Piece->strptime($together->{Bar}->{SD}, q/%d-%m/);
my $foo_end = Time::Piece->strptime($together->{Foo}->{ED}, q/%d-%m/);
my $bar_end = Time::Piece->strptime($together->{Bar}->{ED}, q/%d-%m/);
$start = $foo_start;
$start = $bar_start if $bar_start > $foo_start;
$end = $foo_end;
$end = $bar_end if $bar_end < $foo_end;
{
$days_together++ if $start <= $end;
$start += ONE_DAY;
redo if $start <= $end;
}
return $days_together;
}
MAIN:{
my $days;
$days = days_together({Foo => {SD => q/12-01/, ED => q/20-01/},
Bar => {SD => q/15-01/, ED => q/18-01/}});
say $days;
$days = days_together({Foo => {SD => q/02-03/, ED => q/12-03/},
Bar => {SD => q/13-03/, ED => q/14-03/}});
say $days;
$days = days_together({Foo => {SD => q/02-03/, ED => q/12-03/},
Bar => {SD => q/11-03/, ED => q/15-03/}});
say $days;
$days = days_together({Foo => {SD => q/30-03/, ED => q/05-04/},
Bar => {SD => q/28-03/, ED => q/02-04/}});
say $days;
}
```

### Sample Run

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

### Notes

Time:Piece makes this easy, once we figure out the logic. The start date should be the later of the two start dates since clearly there can be no overlap until the second person shows up. Similarly the end date should be the earlier of the two dates since once one person leaves their time together is over. By converting the dates to Time::Piece objects the comparisons are straightforward.

Now, once the dates are converted to Time::Piece objects and the start and end dates
determined we could also use Time::Piece arithmetic to subtract one from the other
and pretty much be done. However, since that might be a little too boring I instead
iterate and count the number of days in a `redo`

loop!

## Part 2

*You are given a list of positive numbers, @n, having at least 3 numbers.
Write a script to find the triplets (a, b, c) from the given list that satisfies
a set of rules.*

### Solution

```
use v5.36;
use strict;
use warnings;
use Hash::MultiKey;
use Math::Combinatorics;
sub magical_triples{
my(@numbers) = @_;
my %triple_sum;
tie %triple_sum, q/Hash::MultiKey/;
my $combinations = Math::Combinatorics->new(count => 3, data => [@numbers]);
my($s, $t, $u);
while(my @combination = $combinations->next_combination()){
my($s, $t, $u) = @combination;
my $sum;
$sum = $s + $t + $u if $s + $t > $u && $t + $u > $s && $s + $u > $t;
$triple_sum{[$s, $t, $u]} = $sum if $sum;
}
my @triples_sorted = sort {$triple_sum{$b} <=> $triple_sum{$a}} keys %triple_sum;
return ($triples_sorted[0]->[0], $triples_sorted[0]->[1], $triples_sorted[0]->[2]) if @triples_sorted;
return ();
}
MAIN:{
say "(" . join(", ", magical_triples(1, 2, 3, 2)) . ")";
say "(" . join(", ", magical_triples(1, 3, 2)) . ")";
say "(" . join(", ", magical_triples(1, 1, 2, 3)) . ")";
say "(" . join(", ", magical_triples(2, 4, 3)) . ")";
}
```

### Sample Run

```
$ perl perl/ch-2.pl
(2, 3, 2)
()
()
(4, 3, 2)
```

### Notes

The "magical" rules, if not clear from the above code are:

a + b > c

b + c > a

a + c > b

a + b + c is maximum.

To be certain, this problem is an excellent application of constraint programming. Unfortunately I do not know of a good constraint programming library in Perl. If you see my Prolog Solutions for this problem you can see just how straightforward such a solution can be!

Here we find ourselves with a brute force implementation. Math::Combinatorics is a battle tested module when dealing with combinatorics problems in Perl. For all possible selections of three elements of the original list we evaluate the rules and track their sums in a hash. We then sort the hash keys based on the associated values and return the triple which has maximal sum and otherwise passes all the other requirements.

A nice convenient module used here is Hash::MultiKey which allows us to use an array reference as a hash key. In this way we can have immediate access to the triples when needed.

## References

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

### 2022-10-16

#### Zippy Fast Dubious OCR Process

## Part 1

*You are given two lists of the same size. Create a subroutine sub zip() that
merges the two lists.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub zip($a, $b){
return map { $a->[$_], $b->[$_] } 0 .. @$a - 1;
}
MAIN:{
print join(", ", zip([qw/1 2 3/], [qw/a b c/])) . "\n";
print join(", ", zip([qw/a b c/], [qw/1 2 3/])) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-1.pl
1, a, 2, b, 3, c
a, 1, b, 2, c, 3
```

### Notes

The solution here is basically that one line `map`

. Since we know that the lists
are of the same size we can map over the array indices and then construct the
desired return list directly.

## Part 2

*You are given a string with possible unicode characters. Create a subroutine
sub makeover($str) that replace the unicode characters with their ascii equivalent.
For this task, let us assume the string only contains letters.*

### Solution

```
use utf8;
use v5.36;
use strict;
use warnings;
##
# You are given a string with possible unicode characters. Create a subroutine
# sub makeover($str) that replace the unicode characters with their ascii equivalent.
# For this task, let us assume the string only contains letters.
##
use Imager;
use File::Temp q/tempfile/;
use Image::OCR::Tesseract q/get_ocr/;
use constant TEXT_SIZE => 30;
use constant FONT => q#/usr/pkg/share/fonts/X11/TTF/Symbola.ttf#;
sub makeover($s){
my $image = Imager->new(xsize => 100, ysize => 100);
my $temp = File::Temp->new(SUFFIX => q/.tiff/);
my $font = Imager::Font->new(file => FONT) or die "Cannot load " . FONT . " ", Imager->errstr;
$font->align(string => $s,
size => TEXT_SIZE,
color => q/white/,
x => $image->getwidth/2,
y => $image->getheight/2,
halign => q/center/,
valign => q/center/,
image => $image
);
$image->write(file => $temp) or die "Cannot save $temp", $image->errstr;
my $text = get_ocr($temp);
return $text;
}
MAIN:{
say makeover(q/ Ã Ê Í Ò Ù /);
}
```

### Sample Run

```
$ perl perl/ch-2.pl
EIO
```

### Notes

First I have to say upfront that this code doesn't work all that well for the problem at hand! Rather than modify it to something that works better I thought I would share it as is. It's intentionally ridiculous and while it would have been great if it worked better I figure it's worth taking a look at anyway.

So, my idea was:

- take the input text and generate an image
- ocr the image
- the ocr process would ignore anything non-text (emojis and other symbols)
- the ocr process would possibly ignore the accent marks

I wasn't so sure about that last one. A good ocr should maintain the true letters, accents and all. Tesseract, the ocr engine used here, claims to support Unicode and "more than 100 languages" so it should have reproduced the original input text, except that it didn't. In fact, for a variety of font sizes and letter combinations it never detected the accents. While I would be frustrated if I wanted that feature to work well, I was happy to find that it did not!

Anyway, to put it mildly, it's clear that this implementation is fragile for the task at hand! In other ways it's pretty solid though. Imager is a top notch image manipulation module that does the job nicely here. Image::OCR::Tesseract is similarly a high quality wrapper around the Tesseract ocr engine. Tesseract itself is widely accepted as being world class. My lack of a great result here is mainly due to my intentional misuse of these otherwise fine tools!

## References

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

The Weekly Challenge 186 (Prolog Solutions)

## Part 1

*You are given two lists of the same size. Write a predicate that
merges the two lists.*

### Solution

```
zip([], [], []).
zip([Ha|Ta], [Hb|Tb], [Ha, Hb|Tc]):-
zip(Ta, Tb, Tc).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- zip([1,2,3],[a,b,c],C).
C = [1,a,2,b,3,c]
```

### Notes

This is a great simple example of recursion in Prolog. If there is any doubt
about what is happening here is what `trace/0`

shows:

```
| ?- trace.
The debugger will first creep -- showing everything (trace)
yes
{trace}
| ?- zip([1,2,3],[a,b,c],C).
1 1 Call: zip([1,2,3],[a,b,c],_38) ?
2 2 Call: zip([2,3],[b,c],_73) ?
3 3 Call: zip([3],[c],_102) ?
4 4 Call: zip([],[],_131) ?
4 4 Exit: zip([],[],[]) ?
3 3 Exit: zip([3],[c],[3,c]) ?
2 2 Exit: zip([2,3],[b,c],[2,b,3,c]) ?
1 1 Exit: zip([1,2,3],[a,b,c],[1,a,2,b,3,c]) ?
```

Given that we know the lists are of the same size we have an extremely elegant solution. That is, we state that the first argument is an element, followed by the rest of the list, and the same goes for the second argument. For the third argument we state that its head is the combined initial two elements from the first and second lists and this unifies our uninstantiated variable.

## References

posted at: 20:00 by: Adam Russell | path: /prolog | permanent link to this entry

### 2022-09-18

#### Deepest Common Index

## Part 1

*You are given a list of integers. Write a script to find the index of the first biggest
number in the list.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub index_biggest{
my(@numbers) = @_;
my @sorted = sort {$b <=> $a} @numbers;
map { return $_ if $numbers[$_] == $sorted[0] } 0 .. @numbers - 1;
}
MAIN:{
my @n;
@n = (5, 2, 9, 1, 7, 6);
print index_biggest(@n) . "\n";
@n = (4, 2, 3, 1, 5, 0);
print index_biggest(@n) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-1.pl
2
4
```

### Notes

Essentially this solution is two lines, and could even have been a one liner. All that is
required is to `sort`

the array of numbers and then determine the index of the first
occurrence of the largest value from the original list. Finding the index of the first
occurrence can be done using a `map`

with a `return`

to short circuit the search as soon
as the value is found.

## Part 2

*Given a list of absolute Linux file paths, determine the deepest path to the directory
that contains all of them.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub deepest_path{
my(@paths) = @_;
my @sub_paths = map { [split(/\//, $_)] } @paths;
my @path_lengths_sorted = sort { $a <=> $b } map { 0 + @{$_} } @sub_paths;
my $deepest_path = q//;
for my $i (0 .. $path_lengths_sorted[0] - 1){
my @column = map { $_->[$i] } @sub_paths;
my %h;
map { $h{$_} = undef } @column;
$deepest_path .= (keys %h)[0] . q#/# if 1 == keys %h;
}
chop $deepest_path;
return $deepest_path;
}
MAIN:{
my $data = do{
local $/;
<DATA>;
};
my @paths = split(/\n/, $data);
print deepest_path(@paths) . "\n";
}
__DATA__
/a/b/c/1/x.pl
/a/b/c/d/e/2/x.pl
/a/b/c/d/3/x.pl
/a/b/c/4/x.pl
/a/b/c/d/5/x.pl
```

### Sample Run

```
$ perl perl/ch-2.pl
/a/b/c
```

### Notes

The approach here is fairly straightforward but I will admit that it may look more complex than it truly is if you simply glance at the code.

To summarize what is going on here:

- We read in the file paths, one path (string) per line.
- The paths are sent to
`deepest_path()`

where we create a 2d array. Each array element is an array reference of file sub paths. For example here`$sub_paths[0]`

is`[a, b, c, 1, x.pl]`

. - We sort the lengths of all the sub path array references to know how far we must search. We need only look as far as the shortest path after all.
- At each iteration we take column wise slices.
- For each column wise slice we check if all the sub paths are equal. We do this but putting all the sub path values into a hash as keys. If we have only one key value when done we know all the values are equal.
- As long as tall the sub paths are equal we accumulate it in
`$deepest_path`

. `$deepest_path`

is returned when we are doing examining all sub paths. (We`chop`

the trailing`/`

). Done!

## References

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

### 2022-09-11

#### These Sentences Are Getting Hot

## Part 1

*You are given a paragraph. Write a script to order each sentence alphanumerically and
print the whole paragraph.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub sort_paragraph{
my($paragraph) = @_;
my @sentences = split(/\./, $paragraph);
for(my $i = 0; $i < @sentences; $i++){
$sentences[$i] = join(" ", sort {uc($a) cmp uc($b)} split(/\s/, $sentences[$i]));
}
return join(".", @sentences);
}
MAIN:{
my $paragraph = do{
local $/;
<DATA>;
};
print sort_paragraph($paragraph);
}
__DATA__
All he could think about was how it would all end. There was
still a bit of uncertainty in the equation, but the basics
were there for anyone to see. No matter how much he tried to
see the positive, it wasn't anywhere to be seen. The end was
coming and it wasn't going to be pretty.
```

### Sample Run

```
$ perl perl/ch-1.pl
about All all could end he how it think was would. a anyone basics bit but equation, for in of see still the the There there to uncertainty was were. anywhere be he how it matter much No positive, see seen the to to tried wasn't. and be coming end going it pretty The to was wasn't
```

### Notes

This code is fairly compact but not at all obfuscated, I would argue. First we take in the paragraph all at once. Then we split into sentences and begin the sorting.

The `sort`

is a little complicated looking at first because we want the words to be sorted
irrespective of letter case. One way to handle that is to compare only all uppercase
versions of the words. Lowercase would work too, of course!

## Part 2

*You are given file with daily temperature record in random order. Write a script to find
out days hotter than previous day.*

### Solution

```
use v5.36;
use strict;
use warnings;
use DBI;
use Text::CSV;
use Time::Piece;
sub hotter_than_previous{
my($data) = @_;
my @hotter;
my $csv_parser = Text::CSV->new();
my $dbh = DBI->connect(q/dbi:CSV:/, undef, undef, undef);
$dbh->do(q/CREATE TABLE hotter_than_previous_a(day INTEGER, temperature INTEGER)/);
$dbh->do(q/CREATE TABLE hotter_than_previous_b(day INTEGER, temperature INTEGER)/);
for my $line (@{$data}){
$line =~ tr/ //d;
$csv_parser->parse($line);
my($day, $temperature) = $csv_parser->fields();
$day = Time::Piece->strptime($day, q/%Y-%m-%d/);
$dbh->do(q/INSERT INTO hotter_than_previous_a VALUES(/ . $day->epoch . qq/, $temperature)/);
$dbh->do(q/INSERT INTO hotter_than_previous_b VALUES(/ . $day->epoch . qq/, $temperature)/);
}
my $statement = $dbh->prepare(q/SELECT day FROM hotter_than_previous_a A INNER JOIN
hotter_than_previous_b B WHERE (A.day - B.day = 86400)
AND A.temperature > B.temperature/);
$statement->execute();
while(my $row = $statement->fetchrow_hashref()){
push @hotter, $row->{day};
}
@hotter = map {Time::Piece->strptime($_, q/%s/)->strftime(q/%Y-%m-%d/)} sort @hotter;
unlink(q/hotter_than_previous_a/);
unlink(q/hotter_than_previous_b/);
return @hotter;
}
MAIN:{
my $data = do{
local $/;
<DATA>;
};
my @hotter = hotter_than_previous([split(/\n/, $data)]);
say join(qq/\n/, @hotter);
}
__DATA__
2022-08-01, 20
2022-08-09, 10
2022-08-03, 19
2022-08-06, 24
2022-08-05, 22
2022-08-10, 28
2022-08-07, 20
2022-08-04, 18
2022-08-08, 21
2022-08-02, 25
```

### Sample Run

```
$ perl perl/ch-2.pl
2022-08-02
2022-08-05
2022-08-06
2022-08-08
2022-08-10
```

### Notes

To be clear up front, this is an intentionally over engineered solution! I have been intrigued by the idea of DBD::CSV since I first heard of it but never had a reason to use it. So I invented a reason!

DBD::CSV provides a SQL interface to CSV data. That is, it allows you to write SQL queries against CSV data as if they were a more ordinary relational database. Very cool! Instead of solving this problem in Perl I am actually implementing the solution in SQL. Perl is providing the implementation of the SQL Engine and the quasi-database for the CSV data.

DBD::CSV is quite powerful but is not completely on par feature wise with what you'd get
if you were using an ordinary database. Not all SQL data types are supported, for example.
Work arounds can be constructed to do everything that we want and these sorts of trade
offs are to be expected. To store the dates we use `Time::Piece`

to compute UNIX epoch
times which are stored as INTEGERs. Also, DBD::CSV expects data from files and so we can't
use the data directly in memory, it has to be written to a file first. Actually, we find
out that we need to create two tables! Each hold exact copies of the same data.

The creation of two tables is due to a quirk of the underlying SQL Engine SQL::Statement.
SQL::Statement will throw an error when doing a join on the same table. The way one would
do this ordinarily is something like
`SELECT day FROM hotter_than_previous A, hotter_than_previous B ...`

. That join allows SQL
to iterate over all pairs of dates but this throws an error when done with SQL::Statement.
To work around this we instead we create two tables which works.

## References

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

### 2022-09-04

The Weekly Challenge 180 (Prolog Solutions)

## Part 1

*You are given a string. Write a script to find out the first unique character in the
given string and print its index (0-based).*

### Solution

```
index_first_unique(Words, IndexUnique):-
index_first_unique(Words, 0, IndexUnique).
index_first_unique(String, I, IndexUnique):-
succ(I, Index),
length(String, Length),
nth(Index, String, Character),
delete(String, Character, Deleted),
length(Deleted, LengthDeleted),
LengthDifference is Length - LengthDeleted,
LengthDifference == 1, !,
IndexUnique = I.
index_first_unique(String, I, IndexUnique):-
succ(I, Index),
length(String, Length),
nth(Index, String, Character),
delete(String, Character, Deleted),
length(Deleted, LengthDeleted),
LengthDifference is Length - LengthDeleted,
\+ LengthDifference == 1,
succ(I, X),
index_first_unique(String, X, IndexUnique).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- index_first_unique("Long Live Perl", IndexUnique).
IndexUnique = 1
yes
| ?- index_first_unique("Perl Weekly Challenge", IndexUnique).
IndexUnique = 0
yes
| ?- index_first_unique("aabbcc", IndexUnique).
no
| ?- index_first_unique("Prolog Solution to Perl Weekly Challenge", IndexUnique).
IndexUnique = 7
yes
```

### Notes

The main steps here are to check to see if after a character is deleted from the list if the new list length only varies from the original by 1. If so, then we are done. In the case the list is exhausted without finding a unique character the predicate simply fails.

Also note that GNU Prolog's `nth/3`

assumes 1 indexing and so to get the correct 0 based
answer we do an extra `succ/2`

.

## Part 2

*You are given list of numbers and an integer. Write a script to trim the given list when
an element is less than or equal to the given integer.*

### Solution

```
trimmer(X, Y, Z):-
X < Y,
Z = Y.
trimmer(X, Y, Z):-
X >= Y,
Z = 'trimmed'.
trim_list(Numbers, I, TrimmedList):-
maplist(trimmer(I), Numbers, PartialTrimmedList),
delete(PartialTrimmedList, 'trimmed', TrimmedList).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- trim_list([1, 4, 2, 3, 5], 3, TrimmedList).
TrimmedList = [4,5] ?
yes
| ?- trim_list([9, 0, 6, 2, 3, 8, 5], 4, TrimmedList).
TrimmedList = [9,6,8,5] ?
yes
```

### Notes

`maplist/3`

is always tempting to use when required to process a list. In order to get the
effect that we want, however, requires that the predicate used in the maplist succeed for
each value of the list to be processed. Here `trimmer/3`

will either succeed with the
numerical value that passes that comparison or succeed and provide the atom `trimmed`

for
values in the list that fail the comparison. The resulting list is then used with
`delete/3`

to get the final list containing only the numerical values required.

## References

posted at: 16:18 by: Adam Russell | path: /prolog | permanent link to this entry

#### First Uniquely Trimmed Index

## Part 1

*You are given a string, $s. Write a script to find out the first unique character in the
given string and print its index (0-based).*

### Solution

```
use v5.36;
use strict;
use warnings;
sub index_first_unique{
my($s) = @_;
my @s = split(//, $s);
map {my $i = $_; my $c = $s[$i]; return $_ if 1 == grep {$c eq $_ } @s } 0 .. @s - 1;
}
MAIN:{
say index_first_unique(q/Perl Weekly Challenge/);
say index_first_unique(q/Long Live Perl/);
}
```

### Sample Run

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

### Notes

I use the small trick of return-ing early out of a `map`

. Since we only want the first
unique index there is no need to consider other characters in the string and we can do
this short circuiting to bail early.

## Part 2

*You are given list of numbers, @n and an integer $i. Write a script to trim the given
list when an element is less than or equal to the given integer.*

### Solution

```
use v5.36;
use strict;
use warnings;
sub trimmer{
my($i) = @_;
return sub{
my($x) = @_;
return $x if $x > $i;
}
}
sub trim_list_r{
my($n, $trimmer, $trimmed) = @_;
$trimmed = [] unless $trimmed;
return @$trimmed if @$n == 0;
my $x = pop @$n;
$x = $trimmer->($x);
unshift @$trimmed, $x if $x;
trim_list_r($n, $trimmer, $trimmed);
}
sub trim_list{
my($n, $i) = @_;
my $trimmer = trimmer($i);
return trim_list_r($n, $trimmer);
}
MAIN:{
my(@n, $i);
$i = 3;
@n = (1, 4, 2, 3, 5);
say join(", ", trim_list(\@n, $i));
$i = 4;
@n = (9, 0, 6, 2, 3, 8, 5);
say join(", ", trim_list(\@n, $i));
}
```

### Sample Run

```
$ perl perl/ch-2.pl
4, 5
9, 6, 8, 5
```

### Notes

After using `map`

and `grep`

in the first part this week's challenge I decided to try out
something else for this problem. `grep`

would certainly be a perfect fit for this!
Instead, though, I do the following:

- Create an anonymous subroutine closure around
`$i`

to perform the comparison. The subroutine is referenced in the variable`$trimmer`

. - This subroutine reference is then passed to a recursive function along with the list.
- The recursive function accumulates numbers meeting the criteria in an array reference
`$trimmed`

.`unshift`

is used to maintain the original ordering. I could have also, for example, processed the list of numbers in reverse and using`push`

. I haven't used`unshift`

in a long time so this seemed more fun. `$trimmed`

is returned to when the list of numbers to be reviewed is exhausted.

This works quite well, especially for something so intentionally over engineered. If you
end up trying this yourself be careful with the size of the list used with the recursion.
For processing long lists in this way you'll either need to set `no warnings 'recusion`

or, preferably, `goto __SUB__`

in order to take advantage of Perl style tail recursion.

## References

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

### 2022-08-14

#### Cyclops Validation

## Part 1

*You are given a positive number, $n. Write a script to validate the given number
against the included check digit.*

### Solution

```
use strict;
use warnings;
use boolean;
my @damm_matrix;
$damm_matrix[0] = [0, 7, 4, 1, 6, 3, 5, 8, 9, 2];
$damm_matrix[1] = [3, 0, 2, 7, 1, 6, 8, 9, 4, 5];
$damm_matrix[2] = [1, 9, 0, 5, 2, 7, 6, 4, 3, 8];
$damm_matrix[3] = [7, 2, 6, 0, 3, 4, 9, 5, 8, 1];
$damm_matrix[4] = [5, 1, 8, 9, 0, 2, 7, 3, 6, 4];
$damm_matrix[5] = [9, 5 ,7, 8, 4, 0, 2, 6, 1, 3];
$damm_matrix[6] = [8, 4, 1, 3, 5, 9, 0, 2, 7, 6];
$damm_matrix[7] = [6, 8, 3, 4, 9, 5, 1, 0, 2, 7];
$damm_matrix[8] = [4, 6, 5, 2, 7, 8, 3, 1, 0, 9];
$damm_matrix[9] = [2, 3, 9, 6, 8, 1, 4, 7, 5, 0];
sub damm_validation{
my($x) = @_;
my @digits = split(//, $x);
my $interim_digit = 0;
while(my $d = shift @digits){
$interim_digit = $damm_matrix[$d][$interim_digit];
}
return boolean($interim_digit == 0);
}
MAIN:{
print damm_validation(5724) . "\n";
print damm_validation(5727) . "\n";
}
```

### Sample Run

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

### Notes

Damm Validation really boils down to a series of table lookups. Once that is determined we need to encode the table and then perform the lookups in a loop.

## Part 2

*Write a script to generate first 20 Palindromic Prime Cyclops Numbers.*

### Solution

```
use strict;
use warnings;
no warnings q/recursion/;
use Math::Primality qw/is_prime/;
sub n_cyclops_prime_r{
my($i, $n, $cyclops_primes) = @_;
return @{$cyclops_primes} if @{$cyclops_primes} == $n;
push @{$cyclops_primes}, $i if is_prime($i) &&
length($i) % 2 == 1 &&
join("", reverse(split(//, $i))) == $i &&
(grep {$_ == 0} split(//, $i)) == 1 &&
do{my @a = split(//, $i);
$a[int(@a / 2)]
} == 0;
n_cyclops_prime_r(++$i, $n, $cyclops_primes);
}
sub n_cyclops_primes{
my($n) = @_;
return n_cyclops_prime_r(1, $n, []);
}
MAIN:{
print join(", ", n_cyclops_primes(20)) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-2.pl
101, 16061, 31013, 35053, 38083, 73037, 74047, 91019, 94049, 1120211, 1150511, 1160611, 1180811, 1190911, 1250521, 1280821, 1360631, 1390931, 1490941, 1520251
```

### Notes

I recently saw the word *whipupitide* used by Dave Jacoby and here is, I think, a good
example of it. We need to determine if a number is prime, palindromic, and cyclops. In
Perl we can determine all of these conditions very easily.

Just to add a bit of fun I decided to use a recursive loop. Out of necessity this will
have a rather deep recursive depth, so we'll need to set `no warnings q/recursion/`

or
else perl will complain when we go deeper than 100 steps. We aren't using too much memory
here, but if that were a concern we could do Perl style
tail recursion with a `goto __SUB__`

instead.

## References

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

The Weekly Challenge 177 (Prolog Solutions)

## Part 1

*You are given a positive number, $n. Write a script to validate the given number
against the included check digit.*

### Solution

```
damm_matrix(0, [0, 7, 4, 1, 6, 3, 5, 8, 9, 2]).
damm_matrix(1, [3, 0, 2, 7, 1, 6, 8, 9, 4, 5]).
damm_matrix(2, [1, 9, 0, 5, 2, 7, 6, 4, 3, 8]).
damm_matrix(3, [7, 2, 6, 0, 3, 4, 9, 5, 8, 1]).
damm_matrix(4, [5, 1, 8, 9, 0, 2, 7, 3, 6, 4]).
damm_matrix(5, [9, 5 ,7, 8, 4, 0, 2, 6, 1, 3]).
damm_matrix(6, [8, 4, 1, 3, 5, 9, 0, 2, 7, 6]).
damm_matrix(7, [6, 8, 3, 4, 9, 5, 1, 0, 2, 7]).
damm_matrix(8, [4, 6, 5, 2, 7, 8, 3, 1, 0, 9]).
damm_matrix(9, [2, 3, 9, 6, 8, 1, 4, 7, 5, 0]).
damm_validate(N):-
number_chars(N, NChars),
damm_validate(NChars, 0).
damm_validate([], InterimDigit):-
InterimDigit == 0.
damm_validate([H|T], InterimDigit):-
number_chars(N, [H]),
damm_matrix(N, DammRow),
succ(InterimDigit, I),
nth(I, DammRow, NextInterimDigit),
damm_validate(T, NextInterimDigit).
```

### Sample Run

```
| ?- damm_validate(5727).
(1 ms) no
| ?- damm_validate(5724).
yes
```

### Notes

The beauty of Prolog is when it's implicit features such as backtracking and unification are exclusively leveraged to obtain a beautiful solution. This is not one of those cases! This is pure recursion, more functional than logical. I can't think of a more elegant way to express this Damm Validation process, however. Essentially we are performing a series of lookups from a table. I could see this being done with a DCG, perhaps. But in that case we wouldn't really be making anything more elegant, I would argue, just removing the explicit recursion while still having to do the same sort of lookups. It would probably end up being more code than this!

Anyway, Damm Validation is pretty succinctly expressed, it's just that the algorithm doesn't seem to really lend itself to being made much more logically implemented.

## Part 2

*Write a script to generate first 20 Palindromic Prime Cyclops Numbers.*

### Solution

```
cyclops(X):-
number_chars(X, XChars),
length(XChars, XCharsLength),
XCharsLengthMinusOne is XCharsLength - 1,
delete(XChars, '0', XCharsNoZero),
length(XCharsNoZero, NoZeroLength),
NoZeroLength == XCharsLengthMinusOne,
append(Beginning, ['0'|End], XChars),
length(Beginning, BeginningLength),
length(End, EndLength),
BeginningLength == EndLength.
palindrome(X):-
number_codes(X, C),
reverse(C, CR),
number_codes(X, CR).
palindrome_prime(Prime):-
current_prolog_flag(max_integer, MAX_INTEGER),
between(100, MAX_INTEGER, Prime),
palindrome(Prime),
fd_prime(Prime).
palindromic_prime_cyclops(_) --> [].
palindromic_prime_cyclops(Seen) --> [X], {palindrome_prime(X), cyclops(X), \+ member(X, Seen)}, palindromic_prime_cyclops([X|Seen]).
main:-
length(PalindromicPrimeCyclops, 5),
phrase(palindromic_prime_cyclops([]), PalindromicPrimeCyclops),
write(PalindromicPrimeCyclops), nl.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- length(PalindromicPrimeCyclops, 20), phrase(palindromic_prime_cyclops([]), PalindromicPrimeCyclops).
PalindromicPrimeCyclops = [101,16061,31013,35053,38083,73037,74047,91019,94049,1120211,1150511,1160611,1180811,1190911,1250521,1280821,1360631,1390931,1490941,1520251] ?
```

### Notes

This borrows a quite a bit of code from previous challenges! Probably the newest thing
here is the checking of the cyclops condition. In `cyclops/1`

we first check to see if
there is a single zero. This is done by removing all zeroes with `delete/3`

and then
confirming, by checking lengths, that only one was removed. After that we split the list
around the '0' using `append/3`

and if the sublists before and after the '0' are of the
same size we know we have a cyclops number. Notice that it only matters that they are
equal. Whether they are of even length or odd length doesn't matter since we know we have
just a single '0' and so the length of the entire list is necessarily of odd length, as
required.

## References

posted at: 17:37 by: Adam Russell | path: /prolog | permanent link to this entry

### 2022-08-07

#### Permuted Reversibly

## Part 1

*Write a script to find the smallest integer x such that x, 2x, 3x, 4x, 5x and 6x are
permuted multiples of each other.*

### Solution

```
use strict;
use warnings;
use boolean;
sub is_permuted{
my($x, $y) = @_;
my(@x, @y);
map {$x[$_]++} split(//, $x);
map {$y[$_]++} split(//, $y);
return false if $#x != $#y;
my @matched = grep {(!$x[$_] && !$y[$_]) || ($x[$_] && $y[$_] && $x[$_] == $y[$_])} 0 .. @y - 1;
return true if @matched == @x;
return false;
}
sub smallest_permuted{
my $x = 0;
{
$x++;
redo unless is_permuted($x, 2 * $x) && is_permuted(2 * $x, 3 * $x) &&
is_permuted(3 * $x, 4 * $x) && is_permuted(4 * $x, 5 * $x) &&
is_permuted(5 * $x, 6 * $x);
}
return $x;
}
MAIN:{
print smallest_permuted . "\n";
}
```

### Sample Run

```
$ perl perl/ch-1.pl
142857
```

### Notes

The approach here is to check if any two numbers are permutations of each other by
counting up the digits for each and comparing the counts. A fun use of `map`

and `grep`

but I will admit it is a bit unnecessary. I implemented solutions to this problem in
multiple languages and in doing so just sorted the lists of digits and compared them. Much
easier, but less fun!

## Part 2

*Write a script to find out all Reversible Numbers below 100.*

### Solution

```
use strict;
use warnings;
sub is_reversible{
my($x) = @_;
my @even_digits = grep { $_ % 2 == 0 } split(//, ($x + reverse($x)));
return @even_digits == 0;
}
sub reversibles_under_n{
my($n) = @_;
my @reversibles;
do{
$n--;
unshift @reversibles, $n if is_reversible($n);
}while($n > 0);
return @reversibles;
}
MAIN:{
print join(", ", reversibles_under_n(100)) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-2.pl
10, 12, 14, 16, 18, 21, 23, 25, 27, 30, 32, 34, 36, 41, 43, 45, 50, 52, 54, 61, 63, 70, 72, 81, 90
```

### Notes

My favorite use of Perl is to prototype algorithms. I'll get an idea for how to solve a problem and then quickly prove out the idea in Perl. Once demonstrated to be effective the same approach can be implemented in another language if required, usually for business reasons but also sometimes simply for performance.

The code here is concise, easy to read, and works well. It's also 3 times slower than a Fortran equivalent.

```
$ time perl perl/ch-2.pl
10, 12, 14, 16, 18, 21, 23, 25, 27, 30, 32, 34, 36, 41, 43, 45, 50, 52, 54, 61, 63, 70, 72, 81, 90
real 0m0.069s
user 0m0.048s
sys 0m0.020s
-bash-5.0$ time fortran/ch-2
10
12
14
16
18
21
23
25
27
30
32
34
36
41
43
45
50
52
54
61
63
70
72
81
90
real 0m0.021s
user 0m0.001s
sys 0m0.016s
```

That said, the Fortran took at least 3x longer to write. These are the tradeoffs that get considered on a daily basis!

## References

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

The Weekly Challenge 176 (Prolog Solutions)

## Part 1

*Write a script to find the smallest integer x such that x, 2x, 3x, 4x, 5x and 6x are
permuted multiples of each other.*

### Solution

```
permuted(X, Y):-
number_chars(X, XChars),
number_chars(Y, YChars),
msort(XChars, XCharsSorted),
msort(YChars, YCharsSorted),
XCharsSorted == YCharsSorted.
permuted_multiple(Permuted):-
current_prolog_flag(max_integer, MAX_INTEGER),
between(1, MAX_INTEGER, X),
X2 is 2 * X,
X3 is 3 * X,
X4 is 4 * X,
X5 is 5 * X,
X6 is 6 * X,
permuted(X, X2), permuted(X2, X3),
permuted(X3, X4), permuted(X4, X5), permuted(X5, X6),
Permuted = X.
```

### Sample Run

```
| ?- permuted_multiple(Permuted).
Permuted = 142857 ?
(2150 ms) yes
```

### Notes

I implemented solutions for this problem in multiple languages and compared side by side on the same system this Prolog solution ran the fastest. I think that's because in Prolog the logic can be (naturally!) expressed very succinctly and so the underlying instructions getting executed are most efficient. Other implementations seem to require a bit more overhead, such as when deconstructing an integer into a list of digits for example.

The task here is for us to generate the smallest integer with this permutable property.
Technically the code here will generate all such numbers, however in search of other
solutions it seems there is just the one found before we exceed the bounds of
`MAX_INTEGER`

.

## Part 2

*Write a script to find out all Reversible Numbers below 100.*

### Solution

```
all_odd([]).
all_odd([H|T]):-
number_chars(Digit, [H]),
M is mod(Digit, 2),
M == 1,
all_odd(T).
reversible(X):-
number_chars(X, XChars),
reverse(XChars, XCharsReversed),
number_chars(R, XCharsReversed),
Sum is X + R,
number_chars(Sum, SumChars),
all_odd(SumChars).
reversible_under_n(N, Reversible):-
between(1, N, X),
reversible(X),
Reversible = X.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- reversible_under_n(100, Reversibles).
Reversibles = 10 ? a
Reversibles = 12
Reversibles = 14
Reversibles = 16
Reversibles = 18
Reversibles = 21
Reversibles = 23
Reversibles = 25
Reversibles = 27
Reversibles = 30
Reversibles = 32
Reversibles = 34
Reversibles = 36
Reversibles = 41
Reversibles = 43
Reversibles = 45
Reversibles = 50
Reversibles = 52
Reversibles = 54
Reversibles = 61
Reversibles = 63
Reversibles = 70
Reversibles = 72
Reversibles = 81
Reversibles = 90
(10 ms) no
```

### Notes

Here we also use Prolog's ability to identify multiple solutions to generate all solutions
less than `100`

, as required.

## References

posted at: 11:54 by: Adam Russell | path: /prolog | permanent link to this entry

### 2022-07-30

#### Sunday Was Perfectly Totient

## Part 1

*Write a script to list the last sunday of every month in the given year.*

### Solution

```
use strict;
use warnings;
use Time::Piece;
sub last_sunday_month{
my($month, $year) = @_;
$month = "0$month" if $month < 10;
my $sunday;
my $t = Time::Piece->strptime("$month", "%m");
for my $day (20 .. $t->month_last_day()){
$t = Time::Piece->strptime("$day $month $year", "%d %m %Y");
$sunday = "$year-$month-$day" if $t->wday == 1;
}
return $sunday;
}
sub last_sunday{
my($year) = @_;
my @sundays;
for my $month (1 .. 12){
push @sundays, last_sunday_month($month, $year);
}
return @sundays;
}
MAIN:{
print join("\n", last_sunday(2022)) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-1.pl
2022-01-30
2022-02-27
2022-03-27
2022-04-24
2022-05-29
2022-06-26
2022-07-31
2022-08-28
2022-09-25
2022-10-30
2022-11-27
2022-12-25
```

### Notes

When dealing with dates in Perl you have a ton of options, including implementing
everything on your own. I usually use the `Time::Piece`

module. Here you can see why I
find it so convenient. With `strptime`

you can create a new object from any conceivable
date string, for setting the upper bounds on iterating over the days of a month we can use
`month_last_day`

, and there are many other convenient functions like this.

## Part 2

*Write a script to generate the first 20 Perfect Totient Numbers.*

### Solution

```
use strict;
use warnings;
use constant EPSILON => 1e-7;
sub distinct_prime_factors{
my $x = shift(@_);
my %factors;
for(my $y = 2; $y <= $x; $y++){
next if $x % $y;
$x /= $y;
$factors{$y} = undef;
redo;
}
return keys %factors;
}
sub n_perfect_totients{
my($n) = @_;
my $x = 1;
my @perfect_totients;
{
$x++;
my $totient = $x;
my @totients;
map {$totient *= (1 - (1 / $_))} distinct_prime_factors($x);
push @totients, $totient;
while(abs($totient - 1) > EPSILON){
map {$totient *= (1 - (1 / $_))} distinct_prime_factors($totient);
push @totients, $totient;
}
push @perfect_totients, $x if unpack("%32I*", pack("I*", @totients)) == $x;
redo if @perfect_totients < $n;
}
return @perfect_totients;
}
MAIN:{
print join(", ", n_perfect_totients(20)) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-2.pl
3, 9, 15, 27, 39, 81, 111, 183, 243, 255, 327, 363, 471, 729, 2187, 2199, 3063, 4359, 4375, 5571
```

### Notes

This code may look deceptively simple. In writing it I ended up hitting a few blockers
that weren't obvious at first. The simplest one was my own misreading of how to compute
totients using prime factors. We must use *unique prime factors*. To handle this I
modified my prime factorization code to use a hash and by returning the keys we can get
only the unique values. Next, while Perl is usually pretty good about floating point
issues, in this case it was necessary to implement a standard *epsilon comparison* to
check that the computed totient was equal to 1.

Actually, maybe I should say that such an *epsilon comparison* is *always* advised but
in many cases Perl can let you get away without one. Convenient for simple calculations
but not a best practice!

For doing serious numerical computing in Perl the best choice is of course to `use PDL`

!

## References

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

### 2022-07-24

#### Permutations Ranked in Disarray on Mars

## Part 1

*Write a script to generate the first 19 Disarium Numbers.*

### Solution

```
use strict;
use warnings;
use POSIX;
sub disarium_n{
my($n) = @_;
my @disariums;
map{
return @disariums if @disariums == $n;
my @digits = split(//, $_);
my $digit_sum = 0;
map{
$digit_sum += $digits[$_] ** ($_ + 1);
} 0 .. @digits - 1;
push @disariums, $digit_sum if $digit_sum == $_;
} 0 .. INT_MAX / 100;
}
MAIN:{
print join(", ", disarium_n(19)) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-1.pl
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 89, 135, 175, 518, 598, 1306, 1676, 2427, 2646798
```

### Notes

I gave myself a *writing prompt* for this exercise: only use map. This turned out to
present a small issue and that is, how do we terminate out of a `map`

early? This comes up
because we do not need to examine all numbers in the large range of `0 .. INT_MAX / 100`

.
Once we find the 19 numbers we require we should just stop looking. `last`

will not work
from within a `map`

it turns out. In this case a `return`

works well. But suppose we did
not want to `return`

out of the subroutine entirely? Well, I have tested it out and it
turns out that `goto`

will work fine from within a `map`

block as well!

That code would look something like this, where the `CONTINUE`

block would have some more
code for doing whatever else was left to do.

```
sub disarium_n{
my($n) = @_;
my @disariums;
map{
goto CONTINUE if @disariums == $n;
my @digits = split(//, $_);
my $digit_sum = 0;
map{
$digit_sum += $digits[$_] ** ($_ + 1);
} 0 .. @digits - 1;
push @disariums, $digit_sum if $digit_sum == $_;
} 0 .. INT_MAX / 100;
CONTINUE:{
##
# more to do before we return
##
}
return @disariums;
}
```

## Part 2

*You are given a list of integers with no duplicates, e.g. [0, 1, 2]. Write two functions,
permutation2rank() which will take the list and determine its rank (starting at 0) in the
set of possible permutations arranged in lexicographic order, and rank2permutation() which
will take the list and a rank number and produce just that permutation.*

### Solution

```
use strict;
use warnings;
package PermutationRanking{
use Mars::Class;
use List::Permutor;
attr q/list/;
attr q/permutations/;
attr q/permutations_sorted/;
attr q/permutations_ranked/;
sub BUILD{
my $self = shift;
my @permutations;
my %permutations_ranked;
my $permutor = new List::Permutor(@{$self->list()});
while(my @set = $permutor->next()) {
push @permutations, join(":", @set);
}
my @permutations_sorted = sort @permutations;
my $rank = 0;
for my $p (@permutations_sorted){
$permutations_ranked{$p} = $rank;
$rank++;
}
@permutations_sorted = map {[split(/:/, $_)]} @permutations_sorted;
$self->permutations_sorted(\@permutations_sorted);
$self->permutations_ranked(\%permutations_ranked);
}
sub permutation2rank{
my($self, $list) = @_;
return $self->permutations_ranked()->{join(":", @{$list})};
}
sub rank2permutation{
my($self, $n) = @_;
return "[" . join(", ", @{$self->permutations_sorted()->[$n]}) . "]";
}
}
package main{
my $ranker = new PermutationRanking(list => [0, 1, 2]);
print "[1, 0, 2] has rank " . $ranker->permutation2rank([1, 0, 2]) . "\n";
print "[" . join(", ", @{$ranker->list()}) . "]" . " has permutation at rank 1 --> " . $ranker->rank2permutation(1) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-2.pl
[1, 0, 2] has rank 2
[0, 1, 2] has permutation at rank 1 --> [0, 2, 1]
```

### Notes

I've been enjoying trying out Al Newkirk's Mars OOP framework. When it comes to Object
Oriented code in Perl I've usually just gone with the default syntax or `Class::Struct`

.
I am far from a curmudgeon when it comes to OOP though, as I have a lot of experience
using Java and C++. What I like about Mars is that it reminds me of the best parts of
`Class::Struct`

as well as the best parts of how Java does OOP. The code above, by its
nature does not require all the features of Mars as here we don't need much in the way
of Roles or Interfaces.

Perhaps guided by my desire to try out Mars more I have taken a definitively OOP approach
to this problem. From the problem statement the intent may have been to have two
independent functions. This code has two methods which depend on the constructor (defined
within `sub BUILD`

) to have populated the internal class variables needed.

There is a small trick here that the sorting is to be by *lexicograohic order*, which
conveniently is the default for Perl's default `sort`

. That doesn't really buy us any
algorithmic improvement in performance, in fact it hurts it! Other approaches exist for
this problem which avoid producing all permutations of the list.

## References

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

The Weekly Challenge 174 (Prolog Solutions)

## Part 1

*Write a script to generate the first 19 Disarium Numbers.*

### Solution

```
disariums(_) --> [].
disariums(Seen) --> [X], {disarium(X), \+ member(X, Seen)}, disariums([X|Seen]).
sum_power(Digits, Sum):-
sum_power(Digits, 0, 0, Sum).
sum_power([], _, Sum, Sum).
sum_power([H|T], I, PartialSum, Sum):-
succ(I, N),
number_chars(X, [H]),
Partial is PartialSum + round(X ** N),
sum_power(T, N, Partial, Sum).
disarium(X):-
current_prolog_flag(max_integer, MAX_INTEGER),
between(0, MAX_INTEGER, X),
number_chars(X, Chars),
sum_power(Chars, Sum),
Sum == X.
n_disariums(N, Disariums):-
length(Disariums, N),
phrase(disariums([]), Disariums).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- n_disariums(19, Diariums).
Diariums = [0,1,2,3,4,5,6,7,8,9,89,135,175,518,598,1306,1676,2427,2646798] ?
```

## References

posted at: 19:34 by: Adam Russell | path: /prolog | permanent link to this entry

### 2022-07-17

#### Suffering Succotash!

## Part 1

*You are given a positive integer, $n. Write a script to find out if the given number is
an Esthetic Number.*

### Solution

```
use strict;
use warnings;
use boolean;
sub is_esthetic{
my($n) = @_;
my @digits = split(//, $n);
my $d0 = pop @digits;
while(@digits){
my $d1 = pop @digits;
return false if abs($d1 - $d0) != 1;
$d0 = $d1;
}
return true;
}
MAIN:{
my $n;
$n = 5456;
print "$n is ";
print "esthetic\n" if is_esthetic($n);
print "not esthetic\n" if !is_esthetic($n);
$n = 120;
print "$n is ";
print "esthetic\n" if is_esthetic($n);
print "not esthetic\n" if !is_esthetic($n);
}
```

### Sample Run

```
$ perl perl/ch-1.pl
5456 is esthetic
120 is not esthetic
```

### Notes

I started to write this solution and then kept coming back to it, considering if there is a more elegant approach. If there is I could not come up with it on my own over this past week! This doesn't seem all that bad, just a bit "mechanical" perhaps?

- Break the number into an array of digits
- Do a pairwise comparison of successive digits by popping them off the array one at a time and retaining the most recently popped digit for the next iteration's comparison.
- If at any point the "different by 1" requirement is not met, return false.
- If we complete all comparisons without a failure, return true.

## Part 2

*Write a script to generate first 10 members of Sylvester's sequence.*

### Solution

```
use strict;
use warnings;
use bigint;
sub sylvester_n{
my($n) = @_;
my @terms = (2, 3);
my %product_table;
$product_table{"2,3"} = 6;
while(@terms < $n){
my $term_key = join(",", @terms);
my $term = $product_table{$term_key} + 1;
push @terms, $term;
$product_table{"$term_key,$term"} = $term * $product_table{$term_key};
}
return @terms;
}
MAIN:{
print join(", ", sylvester_n(10)). "\n";
}
```

### Sample Run

```
$ perl perl/ch-2.pl
2, 3, 7, 43, 1807, 3263443, 10650056950807, 113423713055421844361000443, 12864938683278671740537145998360961546653259485195807, 165506647324519964198468195444439180017513152706377497841851388766535868639572406808911988131737645185443
```

### Notes

Much like the first part I considered what might be an optimal way to compute this. Here
the standard *recursion and memoization* would be most appropriate, I believe. Just to mix
things up a little I implemented my own memoization like lookup table and computed the
terms iteratively. Otherwise though, the effect is largely the same in that for each new
term we need not reproduce any previous multiplications.

These terms get large almost immediately! `use bigint`

is clearly necessary here. An
additional optimization would be the use of `Tie::Hash`

and `Tie::Array`

to save memory as
we compute larger and larger terms. Since TWC 173.2 only specified 10 terms I left that
unimplemented.

Finally, I should note that the title of this blog draws from Sylvester the Cat, not Sylvester the Mathematician! Sylvester the Cat's famous phrase is "Suffering Succotash!". See the link in the references for an example. Not everyone may not be familiar, so see the video link below! The comments on that video have some interesting facts about the phrase and the character.

## References

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

### 2022-07-10

#### Partition the Summary

## Part 1

*You are given two positive integers, $n and $k. Write a script to find out the Prime
Partition of the given number. No duplicates are allowed.*

### Solution

```
use strict;
use warnings;
use boolean;
use Math::Combinatorics;
sub sieve_atkin{
my($upper_bound) = @_;
my @primes = (2, 3, 5);
my @atkin = (false) x $upper_bound;
my @sieve = (1, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 49, 53, 59);
for my $x (1 .. sqrt($upper_bound)){
for(my $y = 1; $y <= sqrt($upper_bound); $y+=2){
my $m = (4 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (1, 13, 17, 29, 37, 41, 49, 53) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 1; $x <= sqrt($upper_bound); $x += 2){
for(my $y = 2; $y <= sqrt($upper_bound); $y += 2){
my $m = (3 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (7, 19, 31, 43) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 2; $x <= sqrt($upper_bound); $x++){
for(my $y = $x - 1; $y >= 1; $y -= 2){
my $m = (3 * $x ** 2) - ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (11, 23, 47, 59) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
my @m;
for my $w (0 .. ($upper_bound / 60)){
for my $s (@sieve){
push @m, 60 * $w + $s;
}
}
for my $m (@m){
last if $upper_bound < ($m ** 2);
my $mm = $m ** 2;
if($atkin[$m]){
for my $m2 (@m){
my $c = $mm * $m2;
last if $c > $upper_bound;
$atkin[$c] = false;
}
}
}
map{ push @primes, $_ if $atkin[$_] } 0 .. @atkin - 1;
return @primes;
}
sub prime_partition{
my($n, $k) = @_;
my @partitions;
my @primes = sieve_atkin($n);
my $combinations = Math::Combinatorics->new(count => $k, data => [@primes]);
while(my @combination = $combinations->next_combination()){
push @partitions, [@combination] if unpack("%32I*", pack("I*", @combination)) == $n;
}
return @partitions;
}
MAIN:{
my($n, $k);
$n = 18, $k = 2;
map{
print "$n = " . join(", ", @{$_}) . "\n"
} prime_partition($n, $k);
print"\n\n";
$n = 19, $k = 3;
map{
print "$n = " . join(", ", @{$_}) . "\n"
} prime_partition($n, $k);
}
```

### Sample Run

```
$ perl perl/ch-1.pl
18 = 7, 11
18 = 5, 13
19 = 3, 11, 5
```

### Notes

Only when writing this short blog did I realize there is a far more efficient way of doing this!

Here we see a brute force exhaustion of all possible combinations. This works alright for
when `$n`

and `$k`

are relatively small. For larger values a procedure like this would be
better,

1. Obtain all primes $p < $n 2. Start with $n and compute $m = $n - $p for all $p 3. If $m is prime and $k = 2 DONE 4. Else set $n = $m and repeat, computing a new $m with all $p < $m stopping with the same criteria if $m is prime and $k is satisfied

This procedure would be a natural fit for recursion, if you were in the mood for that sort of thing.

## Part 2

*You are given an array of integers. Write a script to compute the five-number summary of
the given set of integers.*

### Solution

```
use strict;
use warnings;
sub five_number_summary{
my @numbers = @_;
my($minimum, $maximum, $first_quartile, $median, $third_quartile);
my @sorted = sort {$a <=> $b} @numbers;
$minimum = $sorted[0];
$maximum = $sorted[@sorted - 1];
if(@sorted % 2 == 0){
my $median_0 = $sorted[int(@sorted / 2) - 1];
my $median_1 = $sorted[int(@sorted / 2)];
$median = ($median_0 + $median_1) / 2;
my @lower_half = @sorted[0 .. int(@sorted / 2)];
my $median_lower_0 = $lower_half[int(@lower_half / 2) - 1];
my $median_lower_1 = $lower_half[int(@lower_half / 2)];
$first_quartile = ($median_lower_0 + $median_lower_1) / 2;
my @upper_half = @sorted[int(@sorted / 2) .. @sorted];
my $median_upper_0 = $upper_half[int(@upper_half / 2) - 1];
my $median_upper_1 = $upper_half[int(@upper_half / 2)];
$third_quartile = ($median_upper_0 + $median_upper_1) / 2;
}
else{
$median = $sorted[int(@sorted / 2)];
$first_quartile = [@sorted[0 .. int(@sorted / 2)]]->[int(@sorted / 2) / 2];
$third_quartile = [@sorted[int(@sorted / 2) .. @sorted]]->[(@sorted - int(@sorted / 2)) / 2];
}
return {
minimum => $minimum,
maximum => $maximum,
first_quartile => $first_quartile,
median => $median,
third_quartile => $third_quartile
};
}
MAIN:{
my @numbers;
my $five_number_summary;
@numbers = (6, 3, 7, 8, 1, 3, 9);
print join(", ", @numbers) . "\n";
$five_number_summary = five_number_summary(@numbers);
map{
print "$_: $five_number_summary->{$_}\n";
} keys %{$five_number_summary};
print "\n\n";
@numbers = (2, 6, 3, 8, 1, 5, 9, 4);
print join(", ", @numbers) . "\n";
$five_number_summary = five_number_summary(@numbers);
map{
print "$_: $five_number_summary->{$_}\n";
} keys %{$five_number_summary};
print "\n\n";
@numbers = (1, 2, 2, 3, 4, 6, 6, 7, 7, 7, 8, 11, 12, 15, 15, 15, 17, 17, 18, 20);
print join(", ", @numbers) . "\n";
$five_number_summary = five_number_summary(@numbers);
map{
print "$_: $five_number_summary->{$_}\n";
} keys %{$five_number_summary};
}
```

### Sample Run

```
$ perl perl/ch-2.pl
6, 3, 7, 8, 1, 3, 9
third_quartile: 8
maximum: 9
minimum: 1
first_quartile: 3
median: 6
2, 6, 3, 8, 1, 5, 9, 4
median: 4.5
first_quartile: 2.5
minimum: 1
maximum: 9
third_quartile: 7
1, 2, 2, 3, 4, 6, 6, 7, 7, 7, 8, 11, 12, 15, 15, 15, 17, 17, 18, 20
maximum: 20
third_quartile: 15
first_quartile: 5
median: 7.5
minimum: 1
```

### Notes

Note that the case of an even or odd number of elements of the list (and sublists) requires slightly special handling.

## References

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

### 2022-07-03

The Weekly Challenge 171 (Prolog Solutions)

## Part 1

*Write a script to generate the first twenty Abundant Odd Numbers.*

### Solution

```
proper_divisors(X, Divisors):-
Half is X // 2,
findall(Divisor,(
between(1, Half, Divisor),
M is mod(X, Divisor),
M == 0
), Divisors).
abundants_odd(_) --> [].
abundants_odd(Previous) --> [X], {abundant_odd(Previous, X)}, abundants_odd(X).
abundant_odd(Previous, X):-
current_prolog_flag(max_integer, MAX_INTEGER),
between(Previous, MAX_INTEGER, X),
X > Previous,
M is mod(X, 2),
M == 1,
proper_divisors(X, Divisors),
sum_list(Divisors, DivisorsSum),
DivisorsSum > X.
n_abundants(N, Abundants):-
length(Abundants, N),
phrase(abundants_odd(-1), Abundants).
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-1.p
| ?- n_abundants(20, Abundants).
Abundants = [945,1575,2205,2835,3465,4095,4725,5355,5775,5985,6435,6615,6825,7245,7425,7875,8085,8415,8505,8925] ?
```

### Notes

The use of a DCG here seems appropriate as we are generating a sequence of numbers of a DCG will allow us to reason on such lists. The logic for inclusion in the sequence is a bit complex and so it further seems natural to break that into its own predicate.

## Part 2

*Create sub compose($f, $g) which takes in two parameters $f and $g as subroutine refs
and returns subroutine ref i.e. compose($f, $g)->($x) = $f->($g->($x)).*

### Solution

```
f(S, T):-
T is S + S.
g(S, T):-
T is S * S.
compose(F, G, H):-
asserta((h(X, Y) :- call(G, X, X0), call(F, X0, Y))),
H = h.
```

### Sample Run

```
$ gprolog --consult-file prolog/ch-2.p
| ?- compose(f, g, H), A =.. [H, 7, X], A.
A = h(7,98)
H = h
X = 98
yes
| ?-
```

### Notes

This challenge is posed as being Perl specific and while most any language is able to do more or less what is asked for, this is a bit of a strange thing to do in Prolog.

In general, Prolog would dicate the use of a *meta-interpreter* for this sort of thing,
instead of this sort of Functional Programming practice. Sticking to the letter of the
challenge I was able to cobble something together with `asserta/1`

and the `univ`

operator
`(=..)/2`

.

An assumption made in my code is that we know ahead of time the number of arguments to
predicates `F`

and `G`

and that we also know which variables are instantiated or not.
Those assumptions greatly simplify things and we can compose the two predicates in this
way. Without that assumption the code would explode in complexity as we would need to
examine whether variables are instantiated or not and then make possibly incorrect
new assumptions that they, in fact, should have been or not.

## References

posted at: 13:18 by: Adam Russell | path: /prolog | permanent link to this entry

#### Abundant Composition

## Part 1

*Write a script to generate the first twenty Abundant Odd Numbers.*

### Solution

```
use strict;
use warnings;
sub proper_divisors{
my($n) = @_;
my @divisors;
for my $x (1 .. $n / 2){
push @divisors, $x if $n % $x == 0;
}
return @divisors;
}
sub n_abundant_odd{
my($n) = @_;
my $x = 0;
my @odd_abundants;
{
push @odd_abundants, $x if $x % 2 == 1 && unpack("%32I*", pack("I*", proper_divisors($x))) > $x;
$x++;
redo if @odd_abundants < $n;
}
return @odd_abundants;
}
MAIN:{
print join(", ", n_abundant_odd(20)) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-1.pl
945, 1575, 2205, 2835, 3465, 4095, 4725, 5355, 5775, 5985, 6435, 6615, 6825, 7245, 7425, 7875, 8085, 8415, 8505, 8925
```

### Notes

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

as well as the `pack/unpack`

method of summing the elements of an array.

## Part 2

*Create sub compose($f, $g) which takes in two parameters $f and $g as subroutine refs
and returns subroutine ref i.e. compose($f, $g)->($x) = $f->($g->($x)).*

### Solution

```
use strict;
use warnings;
sub f{
my($x) = @_;
return $x + $x;
}
sub g{
my($x) = @_;
return $x * $x;
}
sub compose{
my($f, $g) = @_;
return sub{
my($x) = @_;
return $f->($g->($x));
};
}
MAIN:{
my $h = compose(\&f, \&g);
print $h->(7) . "\n";
}
```

### Sample Run

```
$ perl perl/ch-2.pl
98
```

### Notes

This problem incorporates some interesting concepts, especially from functional
programming. Treating functions in a *first class way*, that is, passing them as
parameters, manipulating them, dynamically generating new ones are commonly performed in
functional programming languages such as Lisp and ML. Here we can see that Perl can quite
easily do these things as well!

## References

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