RabbitFarm

2023-12-03

The Weekly Challenge 245 (Prolog Solutions)

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

Part 1

You are given two array of languages and its popularity. Write a script to sort the language based on popularity.

Solution


make_pairs(K, V, K-V).

sort_language(Languages, Popularity, SortedLanguages):-
    maplist(make_pairs, Popularity, Languages, PopularityLanguages),
    keysort(PopularityLanguages, SortedPopularityLanguages),
    findall(Language,  member(_-Language, SortedPopularityLanguages), SortedLanguages).

Sample Run


% gprolog --consult-file prolog/ch-1.p
| ?- sort_language([2, 1, 3], [perl, c, python], SortedLanguages). 

SortedLanguages = [1,2,3]

yes
| ?- 

Notes

A pretty standard Prolog convention is the - separated Pair. So here all we need do is generate the pairs of popularity and language, and then use keysort/2 to get everything in the right order.

Part 2

You are given an array of integers >= 0. Write a script to return the largest number formed by concatenating some of the given integers in any order which is also multiple of 3. Return -1 if none found.

Solution


largest_of_three(Numbers, LargestOfThree):-
    findall(Number,(
        sublist(SubList, Numbers),
        \+ SubList = [],
        permutation(SubList, SubListPermutation),
        number_codes(Number, SubListPermutation),
        0 is Number mod 3), NumbersOfThree),
    ((NumbersOfThree = [], LargestOfThree = -1);
     (max_list(NumbersOfThree, LargestOfThree))). 

Sample Run


% gprolog --consult-file prolog/ch-2.p 
| ?- largest_of_three("819", LargestOfThree).

LargestOfThree = 981

yes
| ?- largest_of_three("86710", LargestOfThree).

LargestOfThree = 8760

(1 ms) yes
| ?- largest_of_three("1", LargestOfThree).    

LargestOfThree = -1 ? 

yes
| ?- 

Notes

This is perhaps the most naive solution to the problem: generate sublists and sort the matching permutations of those sublists.

References

Challenge 245

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

Sleeping Threads Reveal the Largest of Three

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

Part 1

You are given two array of languages and its popularity. Write a script to sort the language based on popularity.

Solution


use Thread;
sub sort_language{
    my @language = @{$_[0]};
    my @popularity = @{$_[1]};
    my @threads;
    do{
        push @threads, Thread->new(
            sub{sleep($popularity[$_]); say $language[$_]}
        );
    } for 0 .. @popularity - 1;
    do{$_ -> join()} for @threads;
}

MAIN:{
    sort_language [qw/perl c python/], [2, 1, 3];
}

Sample Run


$ perl perl/ch-1.pl 
c
perl
python

Notes

This is the most ridiculous solution I could imagine for this problem! The sorting by popularity is done by way of a Sleep Sort. Sleep Sort is a very silly thing where you sleep for the values being sorted and then as the sleeps finish the solution comes together.

For added fun I used Perl's threading mechanism. A convenient wrapper for Perl's threads (which are properly called iThreads, and are basically the same construct as, say, JavaScript's workers) is use Thread which used to be an entirely different sort of threading model but is now just a handy set of functions around the current model. Be sure to read the documentation before using, for simple thread tasks it is perfectly fine! Just be aware of any issues with data sharing between threads, which is of no concern to us here.

For each array element of @popularity we create a new thread which is then pushed into an array for tracking all the threads we create. Each thread does nothing more than sleep and then print the corresponding language. Note that we do need to administer our threads in the end by looping over them and executing a join() to ensure they complete properly. We could just skip that, but doing so will cause Perl to warn us that not all threads may have properly completed, although in this case we wouldn't necessarily care since the program has completed executing anyway. Still, it's better to maintain the good practice of making sure everything is cleaned up!

Sleep Sort was the subject of a previous challenge

Part 2

You are given an array of integers >= 0. Write a script to return the largest number formed by concatenating some of the given integers in any order which is also multiple of 3. Return -1 if none found.

Solution


use v5.38;
use Algorithm::Permute;
sub largest_of_three{
    my @digits = @_;
    my $largest = -1;
    do{
        my $indices = $_;
        my @sub_digits = @digits[grep{vec($indices, $_, 1) == 1} 0 .. @digits - 1];
        my $permutor = Algorithm::Permute->new([@sub_digits]);
        while(my @permutation = $permutor->next()){
            my $d = join q//, @permutation;
            $largest = $d if $d > $largest && $d % 3 == 0;
        }
    } for 1 .. 2**@digits - 1;
    return $largest;
}

MAIN:{
    say largest_of_three 8, 1, 9;
    say largest_of_three 8, 6, 7, 1, 0;
    say largest_of_three 1;
}

Sample Run


$ perl perl/ch-2.pl 
981
8760
-1

Notes

I am not sure I have a whole lot to write about this one! My approach here is to take sublists and permute each one, checking at each step for divisibility by three. This works very well for small sets of digits but I cannot think of a more scaleable solution. Suppose we are given a million digits, is it possible to make some statement on the size of the number of digits we can use to compose a number as required? I suspect this problem is hitting on deeper complexities than I considered at first.

References

Thread

Sleep Sort

Challenge 245

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

2023-11-26

The Weekly Challenge 244 (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 integers. Write a script to calculate the number of integers smaller than the integer at each index.

Solution


smaller([], _, 0).
smaller([H|Integers], X, Y):-
    smaller(Integers, X, Y0),
    ((X > H, succ(Y0, Y));
     (X =< H, Y = Y0)).

count_smaller(Integers, CountSmaller):-
    maplist(smaller(Integers), Integers, CountSmaller).

Sample Run


% gprolog --consult-file prolog/ch-1.p
| ?- count_smaller([2, 2, 2], CountSmaller). 

CountSmaller = [0,0,0]

yes
| ?- count_smaller([6, 5, 4, 8], CountSmaller).

CountSmaller = [2,1,0,3] ? 

yes
| ?- count_smaller([8, 1, 2, 2, 3], CountSmaller).

CountSmaller = [4,0,1,1,3] ? 

yes
| ?- 

Notes

Probably this is the most obvious way to count up smaller elements as required. In order to cut down on the recursion I call smaller/3 via a maplist/3.

Part 2

You are given an array of integers representing the strength. Write a script to return the sum of the powers of all possible combinations; power is defined as the square of the largest number in a sequence, multiplied by the smallest.

Solution


group_hero(Group, GroupHero):-
    findall(Hero, (
        sublist(SubList, Group),
        max_list(SubList, Maximum),
        min_list(SubList, Minimum),
        Hero #= Maximum**2 * Minimum
    ), Heroes),
    sum_list(Heroes, GroupHero). 

Sample Run


% gprolog --consult-file prolog/ch-2.p 
| ?- group_hero([2, 1, 4], GroupHero).

GroupHero = 141

yes
| ?-

Notes

The core of this problem is to enumerate all the Power Sets of the Group list. In other programming languages enumerating all sublists of a list is straightforward enough, but requires much more code. Here, with Prolog, we need only call sublist/2 with backtracking. We use a findall/3 to generate all the necessary backtracking and create the list of intermediate sums, which are then all summed for the final solution.

References

Challenge 244

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

Counting the Smallest Embiggens the Group Hero

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 calculate the number of integers smaller than the integer at each index.

Solution


use v5.38;
sub count_smaller{
    my @integers = @_;
    my @integers_sorted = sort {$a <=> $b} @integers;
    return map {  
        my $x = $_;
        (grep { $integers[$x] == $integers_sorted[$_]} 0 .. @integers_sorted - 1)[0];
    } 0 .. @integers - 1;
}

MAIN:{
    say join q/, /, count_smaller qw/8 1 2 2 3/;
    say join q/, /, count_smaller qw/6 5 4 8/;
    say join q/, /, count_smaller qw/2 2 2/;
}

Sample Run


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

Notes

I'll admit this is a little convoluted. Since we already have a nested loop with the map and grep this is not any more efficient than if I had just searched and summed the smaller elements.

The idea here is to sort the array of integers and then for each element in the original array find it's position in the sorted array. The number of elements preceding the sought after element in the sorted list are the number of elements which are smaller than it.

This approach may have a performance benefit in the case of extremely large lists coupled with early termination of the inner loop.

Part 2

You are given an array of integers representing the strength. Write a script to return the sum of the powers of all possible combinations; power is defined as the square of the largest number in a sequence, multiplied by the smallest.

Solution


use v5.38;
sub group_hero{
    my @group = @_;
    my $group_hero = 0;
    do{
        my $indices = $_;
        my @hero = sort {$a <=> $b} @group[grep{vec($indices, $_, 1) == 1} 0 .. @group - 1];
        $group_hero += ($hero[@hero - 1]**2 * $hero[0]);
    } for 1 .. 2**@group - 1;
    return $group_hero;
}

MAIN:{
    say group_hero qw/2 1 4/;
}

Sample Run


$ perl perl/ch-2.pl 
141

Notes

A core part of this problem is to compute the Power Set, set of all subsets, of the original array. To do this we use the well known trick of mapping the set bits of the numbers from 1 .. N^2, where N is the size of the array, to the array indices.

@group[grep{vec($indices, $_, 1) == 1} 0 .. @group - 1] examines which bit within each number $_ in 1 .. 2**@group - 1 are set and then uses them as the indices to @group. The elements from within @group that are found this way are then sorted to obtain the maximum and minimum needed for the final calculation.

References

Power Set

Challenge 244

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

2023-11-19

The Weekly Challenge 243 (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 integers. Write a script to return the number of reverse pairs in the given array.

Solution


reverse_pair(X, Y, Z):-
    (X =\= Y, X > Y + Y, Z = 1, !); Z = 0.
reverse_pairs([], 0).    
reverse_pairs([H|T], ReversePairs):-
    reverse_pairs(T, R),
    maplist(reverse_pair(H), T, RP),
    sum_list(RP, Sum),
    ReversePairs is R + Sum.  

Sample Run


% gprolog --consult-file prolog/ch-1.p
| ?- reverse_pairs([1, 3, 2, 3, 1], ReversePairs).  

ReversePairs = 2

yes
| ?- reverse_pairs([2, 4, 3, 5, 1], ReversePairs).  

ReversePairs = 3

yes
| ?- 

Notes

reverse_pair/3 implements the reverse pair criteria and is called via a maplist/3 in reverse_pairs/3 which recurses over the list and counts up all Reverse Pairs found.

Part 2

You are given an array of positive integers (>=1). Write a script to return the floor sum.

Solution


floor_sum_pair(X, Y, Z):-
    Z is floor(X / Y).

floor_sum(Integers, FloorSum):-
    floor_sum(Integers, Integers, FloorSum).
floor_sum([], _, 0).    
floor_sum([H|T], L, FloorSum):-
    floor_sum(T, L, F),
    maplist(floor_sum_pair(H), L, FS),
    sum_list(FS, Sum),
    FloorSum is F + Sum.  

Sample Run


% gprolog --consult-file prolog/ch-2.p 
| ?- floor_sum([2, 5, 9], FloorSum).

FloorSum = 10

yes
| ?- floor_sum([7, 7, 7, 7, 7, 7, 7], FloorSum).

FloorSum = 49

(1 ms) yes
| ?- 

Notes

The process here is, co-incidentally, much the same as the first part above. We recurse over the list and use a maplist/3 to build an incremental sum at each step.

References

Challenge 243

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

Reverse Pairs on the Floor

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 return the number of reverse pairs in the given array.

Solution


use v5.38;
sub reverse_pairs{
    my @integers = @_;
    my @reverse_pairs;
    do{
        my $i = $_;
        do{
            my $j = $_;
            push @reverse_pairs, [$i, $j] if $integers[$i] > $integers[$j] + $integers[$j];
        } for $i + 1 .. @integers - 1;
    } for 0 .. @integers - 1;
    return 0 + @reverse_pairs;
}

MAIN:{
    say reverse_pairs 1, 3, 2, 3, 1;
    say reverse_pairs 2, 4, 3, 5, 1;
}

Sample Run


$ perl perl/ch-1.pl 
2
3

Notes

A reverse pair is a pair (i, j) where:

a) 0 <= i < j < nums.length 

and

b) nums[i] > 2 * nums[j].

I've been on a bit of a recursion kick recently, but I didn't have the appetite for it this week. A nested loop and we're done!

Part 2

You are given an array of positive integers (>=1). Write a script to return the floor sum.

Solution


use v5.38;
use POSIX;
sub floor_sum{
    my @integers = @_;
    my $floor_sum;
    do{
        my $i = $_;
        do{
            my $j = $_;
            $floor_sum += floor($integers[$i] / $integers[$j]);
        } for 0 .. @integers - 1;
    } for 0 .. @integers - 1;
    return $floor_sum;
}

MAIN:{
    say floor_sum 2, 5, 9;
    say floor_sum 7, 7, 7, 7, 7, 7, 7;
}

Sample Run


$ perl perl/ch-2.pl 
10
49

Notes

See above comment about not being as recursive this week!

References

Challenge 243

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

2023-11-11

The Weekly Challenge 242 (Prolog Solutions)

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

Part 1

You are given two arrays of integers. Write a script to find out the missing members in each other arrays.

Solution


missing(L, E, Member):-
    (member(E, L), Member = nil);
    (\+ member(E, L), Member = E).
missing_members([List1, List2], [Missing1, Missing2]):-
    maplist(missing(List2), List1, Missing1Nil),
    delete(Missing1Nil, nil, Missing1),
    maplist(missing(List1), List2, Missing2Nil),
    delete(Missing2Nil, nil, Missing2). 

Sample Run


% gprolog --consult-file prolog/ch-1.p
| ?- missing_members([[1, 2, 3], [2, 4, 6]] ,Missing).

Missing = [[1,3],[4,6]] ? 

yes
| ?- missing_members([[1, 2, 3, 3], [1, 1, 2, 2]] ,Missing).

Missing = [[3,3],[]] ? 

yes
| ?- missing_members([[1, 2, 3, 3], [1, 1, 2, 2]], Missing), maplist(sort, Missing, MissingNoDuplicates). 

Missing = [[3,3],[]]
MissingNoDuplicates = [[3],[]] ? 

yes
| ?- 

Notes

missing/3 is used in a maplist/3 to determine which elements are missing from an array. If they are not missing a nil is set for it. By deleting the nil elements all that remain are the ones that are missing. This solution doesn't itself remove duplicate missing elements that are identified. That said, as you can see in the example above that can be added, say, using sort/2.

Part 2

You are given n x n binary matrix. Write a script to flip the given matrix as below.

Solution


flip(B, F):-
    F is \ B /\ 1.
flip_matrix([], []).    
flip_matrix([Row|Matrix], [RowFlipped|MatrixFlipped]):-
    reverse(Row, RowReversed),
    maplist(flip, RowReversed, RowFlipped),
    flip_matrix(Matrix, MatrixFlipped).

Sample Run


% gprolog --consult-file prolog/ch-2.p 
| ?- flip_matrix([[1, 1, 0], [1, 0, 1], [0, 0, 0]], FlippedMatrix).

FlippedMatrix = [[1,0,0],[0,1,0],[1,1,1]]

yes
| ?- flip_matrix([[1, 1, 0, 0], [1, 0, 0, 1], [0, 1, 1, 1], [1, 0, 1, 0]], FlippedMatrix).

FlippedMatrix = [[1,1,0,0],[0,1,1,0],[0,0,0,1],[1,0,1,0]]

yes
| ?- 

Notes

For the given matrix we need only recursively consider each row, reverse it, do the necessary bit flips, and then assemble the newly flipped rows into the completed Flipped Matrix.

References

Challenge 242

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

Missing Flips

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

Part 1

You are given two arrays of integers. Write a script to find out the missing members in each other arrays.

Solution


use v5.38;
use boolean;
use Data::Dump q/pp/;
sub missing_members{
    my @r;
    my($a0, $a1) = @_;
    my $missing0 = [];
    missing_members_r([@{$a0}], [@{$a1}], $missing0);
    my $missing1 = [];
    missing_members_r([@{$a1}], [@{$a0}], $missing1);
    push @r, $missing0 if @{$missing0} > 0;
    push @r, $missing1 if @{$missing1} > 0;
    return @r;
}

sub missing_members_r{
    my($a0, $a1, $missing, $seen) = @_;
    $seen = [] if !defined($seen);
    my $x = shift @{$a0};
    push @{$missing}, $x if missing_r($x, [@{$a1}]) && !seen_r($x, $seen); 
    push @{$seen}, $x;
    missing_members_r($a0, $a1, $missing, $seen) if @{$a0} > 0;
}

sub missing_r{
    my($x, $a0) = @_;
    return true if @{$a0} == 0;
    if(@{$a0}){
        my $y = shift @{$a0};
        if($x == $y){ 
            return false;
        }
    }
    return missing_r($x, $a0);
}

sub seen_r{
    my($x, $seen) = @_;
    return false if @{$seen} == 0;
    my $y = shift @{$seen};
    if($x == $y){
        return true;
    }
    return seen_r($x, $seen);
}

MAIN:{
    my @array1 = (1, 2, 3);
    my @array2 = (2, 4, 6);
    say pp missing_members \@array1, \@array2;
    @array1 = (1, 2, 3, 3);
    @array2 = (1, 1, 2, 2);
    say pp missing_members \@array1, \@array2;
}

Sample Run


$ perl perl/ch-1.pl 
([1, 3], [4, 6])
[3]

Notes

So, yeah, this could just be a nice quick use of grep, but where is the fun in that!?!? Just looping over the arrays is not that exciting of an alternative, what other options are there? I know, how about a whole lot of recursion! That was pretty much my thought process here.

Really, all this code is doing is looping over the two arrays and looking for which elements are not contained in each. The looping, such as it is, happens recursively in missing_members_r() and missing_r(). Duplicates are possible and we avoid these, again recursively, using seen_r() rather than, say, grep or hash keys.

Part 2

You are given n x n binary matrix. Write a script to flip the given matrix as below.

Solution


use v5.38;
use Data::Dump q/pp/;
sub flip_matrix{
    return map { 
        my $row = $_;
        [map {~$_ & 1} reverse @{$row}]
    } @_;
}

MAIN:{
    my @matrix = ([1, 1, 0], [1, 0, 1], [0, 0, 0]);
    say pp flip_matrix @matrix;
    @matrix = ([1, 1, 0, 0], [1, 0, 0, 1], [0, 1, 1, 1], [1, 0, 1, 0]);
    say pp flip_matrix @matrix;
}

Sample Run


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

Notes

After all the recursive exitment in part 1 of this week's challenge I just went with a quick nested map for part 2.

References

Challenge 242

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

2023-11-05

The Weekly Challenge 241 (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 (3 or more members) of integers in increasing order and a positive integer. Write a script to find out the number of unique Arithmetic Triplets satisfying the given rules.

Solution


arithmetic_triplets(Numbers, Difference, TripletCount):-
    length(Triplet, 3),  
    member(I, Triplet),      
    member(J, Triplet),      
    member(K, Triplet),      
    fd_domain(Triplet, Numbers),  
    fd_all_different(Triplet), 
    Difference #= J - I,
    Difference #= K - J,  
    I #< J,
    J #< K,
    findall(Triplet, fd_labeling(Triplet), Triplets),
    length(Triplets, TripletCount).  

Sample Run


% gprolog --consult-file prolog/ch-1.p
| ?- arithmetic_triplets([0, 1, 4, 6, 7, 10], 3, TripletCount).

TripletCount = 2 ? 

yes
| ?- arithmetic_triplets([4, 5, 6, 7, 8, 9], 2, TripletCount). 

TripletCount = 2 ? 

yes
| ?- 

Notes

The rules for arithmetic triples are a) i < j < k b) nums[j] - nums[i] == diff and c) nums[k] - nums[j] == diff, where diff is a provided parameter. The code above implements these rules directly, letting Prolog do all the work for us!

Part 2

You are given an array of unique positive integers greater than 2. Write a script to sort them in ascending order of the count of their prime factors, tie-breaking by ascending value.

Solution


prime_factors(N, L):- 
    N > 0,  
    prime_factors(N, L, 2).
prime_factors(1, [], _):- 
    !.
prime_factors(N, [F|L], F):-                     
    R is N // F, 
    N =:= R * F, 
    !, 
    prime_factors(R, L, F).
prime_factors(N, L, F):-
    next_factor(N, F, NF), 
    prime_factors(N, L, NF).
next_factor(_, 2, 3):- 
    !.
next_factor(N, F, NF):- 
    F * F < N, 
    !, 
    NF is F + 2.
next_factor(N, _, N).

kvf_insert_sort(List,Sorted):-
    i_sort(List,[],Sorted).

i_sort([],Acc,Acc).
i_sort([H|T],Acc,Sorted):-
    kvf_insert(H,Acc,NAcc),
    i_sort(T,NAcc,Sorted).

kvf_insert(K0-V0,[K1-V1|T],[K1-V1|NT]):-
    V0 > V1,
    kvf_insert(K0-V0,T,NT).
kvf_insert(K0-V0,[K1-V1|T],[K0-V0,K1-V1|T]):-
    V0 < V1.
kvf_insert(K0-V0,[K1-V1|T],[K1-V1|NT]):-
    V0 = V1,
    K0 > K1,
    kvf_insert(K0-V0,T,NT).
kvf_insert(K0-V0,[K1-V1|T],[K0-V0,K1-V1|T]):-
    V0 = V1,
    K0 < K1.    
kvf_insert(K0-V0, [], [K0-V0]).

write_factor_sorted([K-_|[]]):-
    write(K),
    nl.
write_factor_sorted([K-_|T]):-
    write(K),
    write(', '),
    write_factor_sorted(T).

factor_counter(Number, Number-FactorCount):-
    prime_factors(Number, Factors),
    length(Factors, FactorCount).

factor_sorter(Numbers, FactorsSorted):-
    maplist(factor_counter, Numbers, Factors),
    kvf_insert_sort(Factors, FactorsSorted).

Sample Run


% gprolog --consult-file prolog/ch-2.p 
| ?- factor_sorter([11, 8, 27, 4], FactorsSorted), write_factor_sorted(FactorsSorted).
11, 4, 8, 27

FactorsSorted = [11-1,4-2,8-3,27-3] ? 

yes
| ?- 

Notes

This code is build mainly from pieces from previous challenges. The prime factorization code is something I've used several times and the modified Insertion Sort is a minor modification of code from TWC 233.

References

Challenge 241

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

Recursive Loops and Code Re-Use

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

Part 1

You are given an array (3 or more members) of integers in increasing order and a positive integer. Write a script to find out the number of unique Arithmetic Triplets satisfying the given rules.

Solution


use v5.38;
sub arithmetic_triplets{
    my $counter = 0;
    my $difference = shift;
    arithmetic_triplets_r($difference, \$counter, [@_[0 .. @_ -1]], [@_[1 .. @_ -1]], [@_[2 .. @_ -1]]);   
    return $counter;
} 

sub arithmetic_triplets_r{
    my $difference = $_[0]; 
    my $counter = $_[1]; 
    my @i = @{$_[2]};         
    my @j = @{$_[3]};         
    my @k = @{$_[4]};        
    if(@i > 0 && @j > 0 && @k > 0){
        $$counter++ if $j[0] - $i[0] == $difference && $k[0] - $j[0] == $difference;   
        arithmetic_triplets_r($difference, $counter, [@i], [@j], [@k[1 .. @k - 1]]);   
    }
    elsif(@i > 0 && @k == 0 && @j > 0){
        arithmetic_triplets_r($difference, $counter, [@i], [@j[1 .. @j - 1]], [@j[2 .. @j - 1]]);   
    }
    elsif(@i > 0 && @k == 0 && @j == 0){
        arithmetic_triplets_r($difference, $counter, [@i[1 .. @i - 1]], [@i[2 .. @i - 1]], [@i[3 .. @i - 1]]);   
    }
}

MAIN:{
    my $difference;
    $difference = 3;
    say arithmetic_triplets $difference, 0, 1, 4, 6, 7, 10;
    $difference = 2;
    say arithmetic_triplets $difference, 4, 5, 6, 7, 8, 9;  
}

Sample Run


$ perl perl/ch-1.pl 
2
2

Notes

The rules for arithmetic triples are a) i < j < k b) nums[j] - nums[i] == diff and c) nums[k] - nums[j] == diff, where diff is a provided parameter. The code above implements these rules somewhat in the obvious way, looping thricely over the list, but recursively.

Part 2

You are given an array of unique positive integers greater than 2. Write a script to sort them in ascending order of the count of their prime factors, tie-breaking by ascending value.

Solution


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

sub prime_order{
    my %factor_i = map{($_, 0 + prime_factor($_))} @_;
    my $factor_sorter = sub{
        my $c = $factor_i{$a} <=> $factor_i{$b};
        return $c unless !$c;
        return $a <=> $b;
    };
    return sort $factor_sorter @_;
}

MAIN:{
     say join q/, /, prime_order 11, 8, 27, 4;
}

Sample Run


$ perl perl/ch-2.pl 
11, 4, 8, 27

Notes

This code borrows from two previous challenges: The prime factor code has been used several times, but in this case I referred to the Attractive Number challenge from TWC 041. The sorting is a variant of the frequency sort from TWC 233. If you write enough code you don't need GitHub Copilot, you can just re-use your own work!

References

Challenge 241

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

2023-10-29

The Weekly Challenge 240 (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 strings and a check string. Write a script to find out if the check string is the acronym of the words in the given array.

Solution


acronym(Strings, CheckString):-
    maplist(nth(1), Strings, CheckStringUpperCaseCodes),
    maplist(char_code, CheckStringUpperCase, CheckStringUpperCaseCodes),
    maplist(lower_upper, CheckStringLowerCase, CheckStringUpperCase),
    atom_chars(CheckStringA, CheckStringLowerCase),
    atom_codes(CheckStringA, CheckString).

Sample Run


% gprolog --consult-file prolog/ch-1.p
| ?- acronym(["Perl", "Python", "Pascal"], "ppp"). 

true ? 

yes
| ?- acronym(["Perl", "Raku"], "rp").             

no
| ?- acronym(["Oracle", "Awk", "C"], "oac").

true ? 

yes
| ?- acronym(["Oracle", "Awk", "C"], A), atom_codes(Acronym, A).

A = [111,97,99]
Acronym = oac ? 

yes
| ?- 

Notes

In keeping with the spirit of the original, Perl centric, challenge question I use strings instead of Prolog atoms. The difference is that strings will be represented as lists of character codes, so a little extra code is required.

Chanelling the spirit of Prolog, the solution will backtrack and provide the acronym if that variable is given uninstantiated!

Part 2

You are given an array of integers. Write a script to create an array such that new[i] = old[old[i]] where 0 <= i < new.length.

Solution


build_list(_, [], []).
build_list(Old, [OldH|OldT], [NewH|NewT]):-
    succ(OldH, I),
    nth(I, Old, NewH),
    build_list(Old, OldT, NewT).

Sample Run


% gprolog --consult-file prolog/ch-2.p 
| ?- Old = [0, 2, 1, 5, 3, 4], build_list(Old, Old, New).

New = [0,1,2,4,5,3]
Old = [0,2,1,5,3,4] ? 

yes
| ?- Old = [5, 0, 1, 2, 3, 4], build_list(Old, Old, New).

New = [4,5,0,1,2,3]
Old = [5,0,1,2,3,4] ? 

yes
| ?- 

Notes

This is basically the same recursive procedure as used in the Perl solution to the same problem. I did the Perl version first, which was helpful to prototype the recursion.

References

Challenge 240

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

ABA (Acronym Build Array)

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

Part 1

You are given an array of strings and a check string. Write a script to find out if the check string is the acronym of the words in the given array.

Solution


use v5.38;
use boolean;
sub acronym{
    my($strings, $acronym) = @_;
    return boolean(join(q//, map {(split //, lc $_)[0]} @{$strings}) eq lc $acronym);
}

MAIN:{
    say acronym [qw/Perl Python Pascal/], q/ppp/;
    say acronym [qw/Perl Raku/], q/rp/;
    say acronym [qw/Oracle Awk C/], q/oac/;
}

Sample Run


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

Notes

I really wracked my brain to try and come up with a simpler solution and I couldn't!

Part 2

You are given an array of integers. Write a script to create an array such that new[i] = old[old[i]] where 0 <= i < new.length.

Solution


use v5.38;
sub build_array{ 
    push @{$_[0]}, $_[$_[@{$_[0]} + 1] + 1];
    return $_[0] if @{$_[0]} == @_ - 1;
    goto __SUB__;
}

MAIN:{
    say join q/, /, @{build_array([], 0, 2, 1, 5, 3, 4)};
    say join q/, /, @{build_array([], 5, 0, 1, 2, 3, 4)};
}

Sample Run


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

Notes

First off, yes, this code is a bit obfuscated! Writing obfuscated code is not usually something I strive to do, but I was sort of forced down this road. See, what happened is that I read E. Choroba's solution on Discord despite the spoiler warnings! Now, I didn't want his solution to influence mine so I forced myself to come up with something which would be as different as possible.

build_array uses recursion to accumulate the result in the first argument, an array reference. We use the length of the array reference as the index used to look up, and assign elements, from the original array. The original array is present as all remaining arguments in the subroutine call, so we'll need to adjust the indices by 1 to allow for the array reference accumulator as the first argument. The recursion is created using goto __SUB__ which by default retains the original array arguments. Since our accumulator is an array reference and none of the other arguments change then we can make use of this as a convenience. The recursion ends when the accumulated array is of the same length as the original array, then we know that all elements have been processed.

References

Challenge 240

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

2023-10-23

The Weekly Challenge 239 (Prolog Solutions)

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

Part 1

You are given two arrays of strings. Write a script to find out if the word created by concatenating the array elements is the same.

Solution


concatenate_all([], '').
concatenate_all([H|T], Concatenated):-
    concatenate_all(T, C),
    atom_concat(H, C, Concatenated).

same_string(L0, L1):-
    concatenate_all(L0, C0),
    concatenate_all(L1, C1),
    C0 == C1. 

Sample Run


% gprolog --consult-file prolog/ch-1.p
| ?- same_string([ab, c], [a, bc]).

yes
| ?- same_string([ab, c], [ac, b]). 

no
| ?- same_string([ab, cd, e], [abcde]).

yes
| ?- 

Notes

The problem is given as strings, which I interpret here as meaning atoms, in which case we need to concatenate all the atoms together and then check to see if they are equal.

If, instead, I had strictly used strings (arrays of character codes) then there would be no need to actually concatenate anything. In that case we could just flatten the lists and then check to see if the lists were the same.

Part 2

You are given an array of strings and allowed string having distinct characters. A string is consistent if all characters in the string appear in the string allowed. Write a script to return the number of consistent strings in the given array.

Solution


consistent(Allowed, String, Consistent):-
    subtract(String, Allowed, Subtracted),
    length(Subtracted, SubtractedLength),
    ((SubtractedLength == 0, Consistent = 1);
     (SubtractedLength == 1, Consistent = 0)).

consistent_strings(Strings, Allowed, ConsistentStringsCount):-
    maplist(consistent(Allowed), Strings, ConsistentStrings),
    sum_list(ConsistentStrings, ConsistentStringsCount).

Sample Run


% gprolog --consult-file prolog/ch-2.p 
| ?- consistent_strings(["ad", "bd", "aaab", "baa", "badab"], "ab", ConsistentStrings).

ConsistentStrings = 2 ? 

(1 ms) yes
| ?- consistent_strings(["a", "b", "c", "ab", "ac", "bc", "abc"], "abc", ConsistentStrings).

ConsistentStrings = 7 ? 

yes
| ?- consistent_strings(["cc", "acd", "b", "ba", "bac", "bad", "ac", "d"], "cad", ConsistentStrings).

ConsistentStrings = 4 ? 

yes
| ?- 

Notes

Here I count up all the consistent strings by using a maplist/3 to create a list of 0s and 1s. 0 if the string is not consistent, 1 if it is consistent. The check for if a string is consistent is done in a helper predicate which works by removing all the allowed characters and then checking if all characters have been removed, which satisfies the criteria.

References

Challenge 239

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

Same Consistent Strings

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

Part 1

You are given two arrays of strings. Write a script to find out if the word created by concatenating the array elements is the same.

Solution


use v5.36;
use boolean;
sub same_string{
    my($a1, $a2) = @_;
    return boolean(join(q//, @{$a1}) eq join(q//, @{$a2}));
}

MAIN:{
    say same_string [qw/ab c/], [qw/a bc/];
    say same_string [qw/ab c/], [qw/ac b/];
    say same_string [qw/ab cd e/], [qw/abcde/];
}

Sample Run


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

Notes

I really wracked my brain to try and come up with a simpler solution and I couldn't!

Part 2

You are given an array of strings and allowed string having distinct characters. A string is consistent if all characters in the string appear in the string allowed. Write a script to return the number of consistent strings in the given array.

Solution


use v5.36;
sub is_consistent{
    my($s, $allowed) = @_;
    $s =~ s/[$allowed]//g;
    return $s eq q//;
}

sub consistent_strings{
    my($strings, $allowed) = @_;
    my @consistent = grep { is_consistent $_, $allowed } @{$strings};
    return 0 + @consistent;
}

MAIN:{
    say consistent_strings [qw/ad bd aaab baa badab/], q/ab/; 
    say consistent_strings [qw/a b c ab ac bc abc/], q/abc/; 
    say consistent_strings [qw/cc acd b ba bac bad ac d/], q/cad/;
}

Sample Run


$ perl perl/ch-2.pl 
2
7
4

Notes

To check if a string is consistent using the given definition, all the allowed characters are removed from the given string. If the result is the empty string then we know the string meets the requirements. Here this is broken out to the is_consistent function. That in turn is called from within a grep which checks the entire list of strings.

References

Challenge 239

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

2023-10-01

Exact Array Loops

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

Part 1

You are asked to sell juice each costs $5. You are given an array of bills. You can only sell ONE juice to each customer but make sure you return exact change back. You only have $5, $10 and $20 notes. You do not have any change in hand at first. Write a script to find out if it is possible to sell to each customers with correct change.

Solution


use v5.38;
use boolean;
use constant COST_JUICE => 5;

sub exact_change{
    my @bank;
    my $current_customer = shift;
    { 
        push @bank, $current_customer if $current_customer == COST_JUICE;
        if($current_customer > COST_JUICE){
            my $change_due = $current_customer - COST_JUICE;
            my @bank_sorted = sort {$a <=> $b} @bank;
            my @bank_reserved;
            {
                my $bill = pop @bank_sorted;
                push @bank_reserved, $bill if $change_due < $bill;
                $change_due -= $bill if $change_due >= $bill;
                redo if @bank_sorted;
            } 
            return false if $change_due != 0;
            @bank = @bank_reserved;
            push @bank, $current_customer;
        }
        $current_customer = shift; 
        redo if $current_customer;
    }
    return true;
}


MAIN:{
    say exact_change 5, 5, 5, 10, 20;
    say exact_change 5, 5, 10, 10, 20;
    say exact_change 5, 5, 5, 20;
}

Sample Run


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

Notes

Making change is easy as long as we preferentially use larger bills first. To do so all we need to do is sort any accumulated payments and then pop off the change as required by the current transaction, if possible.

Part 2

You are given an array of unique integers. Write a script to determine how many loops are in the given array. To determine a loop: Start at an index and take the number at array[index] and then proceed to that index and continue this until you end up at the starting index.

Solution


use v5.38;
use boolean;
sub loop_counter{
    my @integers = @_;
    my @loops;
    do{
        my @loop;
        my $loop_found = false;
        my $start = $_;
        my $next = $integers[$start];
        push @loop, $start, $next;
        my $counter = 1;
        {
            if($next == $start){
                shift @loop;
                if(@loops == 0 || @loop == 2){
                    push @loops, \@loop;
                    my @loop;
                    $loop_found = true;
                }
                else{
                    my $loop_duplicate = false;
                    my @s0 = sort @loop;
                    do { 
                        my @s1 = sort @{$_};                        
                        $loop_duplicate = true if((@s0 == @s1) && (0 < grep {$s0[$_] == $s1[$_]} 0 .. @s0 - 1));
                    } for @loops;   
                    if(!$loop_duplicate){
                        $loop_found = true;
                        push @loops, \@loop;
                    }
                    else{
                        $counter = @integers + 1; 
                    }           
                }
            }
            else{
                $next = $integers[$next];
                push @loop, $next;   
                $counter++;     
            }
            redo unless $loop_found || $counter > @integers;
        }
    } for 0 .. @integers - 1; 
    return @loops + 0;
}

MAIN:{
    say loop_counter 4, 6, 3, 8, 15, 0, 13, 18, 7, 16, 14, 19, 17, 5, 11, 1, 12, 2, 9, 10;
    say loop_counter 0, 1, 13, 7, 6, 8, 10, 11, 2, 14, 16, 4, 12, 9, 17, 5, 3, 18, 15, 19;
    say loop_counter 9, 8, 3, 11, 5, 7, 13, 19, 12, 4, 14, 10, 18, 2, 16, 1, 0, 15, 6, 17;
}

Sample Run


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

Notes

When I first approached this problem I didn't appreciate that many loops are just cycles of each other. In those cases we need to identify if such cyclical duplicates exit. Much of the code here, then, is for examining such cases. The detection is done by comparing each loop to the existing loops, in sorted order. if there are any equivalents we know we have a duplicate.

The line shift @loop; is to remove to starting point, which is convenient to maintain up until storing in the @loops array.

References

Challenge 236

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

2023-09-07

The Weekly Challenge 233 (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 words made up of alphabets only. Write a script to find the number of pairs of similar words. Two words are similar if they consist of the same characters.

Solution


similar(A, B, Similar):-
    atom_codes(A, ACodes),
    sort(ACodes, ASorted),
    atom_codes(B, BCodes),
    sort(BCodes, BSorted),
    (ASorted = BSorted, Similar = 1);
    Similar = 0.

count_similar_pairs([], 0).
count_similar_pairs([Word|Words], PairsSimilar):-
    count_similar_pairs(Words, P), 
    maplist(similar(Word), Words, Similar), !,
    sum_list(Similar, SimilarCount),
    PairsSimilar is P + SimilarCount.

Sample Run


$ gprolog --consult-file prolog/ch-1.p
| ?- count_similar_pairs([aba, aabb, abcd, bac, aabc], PairsSimilar).

PairsSimilar = 2

yes
| ?- count_similar_pairs([aabb, ab, ba], PairsSimilar).              

PairsSimilar = 3

(1 ms) yes
| ?- count_similar_pairs([nba, cba, dba], PairsSimilar).             

PairsSimilar = 0

yes
| ?- 

Notes

Similarity of words is determined by doing a pairwise comparison of the unique character codes. I've gotten into the habit of counting things by using maplist with a predicate that provides a list of 0 and 1 elements. The count is done by summing the list. Here the counting is done in this way by similar/3. count_similar_pairs/2 recursively considers all pairs.

Part 2

You are given an array of integers. Write a script to sort the given array in increasing order based on the frequency of the values. If multiple values have the same frequency then sort them in decreasing order.

Solution


kvf_insert_sort(List,Sorted):-
    i_sort(List,[],Sorted).

i_sort([],Acc,Acc).
i_sort([H|T],Acc,Sorted):-
    kvf_insert(H,Acc,NAcc),
    i_sort(T,NAcc,Sorted).

kvf_insert(K0-V0,[K1-V1|T],[K1-V1|NT]):-
    V0 > V1,
    kvf_insert(K0-V0,T,NT).
kvf_insert(K0-V0,[K1-V1|T],[K0-V0,K1-V1|T]):-
    V0 < V1.
kvf_insert(K0-V0,[K1-V1|T],[K1-V1|NT]):-
    V0 = V1,
    K0 < K1,
    kvf_insert(K0-V0,T,NT).
kvf_insert(K0-V0,[K1-V1|T],[K0-V0,K1-V1|T]):-
    V0 = V1,
    K0 > K1.    
kvf_insert(K0-V0, [], [K0-V0]).

frequency_writer(_-0).
frequency_writer(K-F):-
    write(K),
    write(', '),
    succ(X, F),
    frequency_writer(K-X).

write_frequencies([K-F|[]]):-
    succ(X, F),
    frequency_writer(K-X),
    write(K),
    nl.
write_frequencies([H|T]):-
    frequency_writer(H),
    write_frequencies(T).

frequency_counter(Numbers, Number, Number-Count):-
    length(Numbers, StartCount),
    delete(Numbers, Number, NumberDeleted),
    length(NumberDeleted, EndCount),
    Count is StartCount - EndCount.

frequency_sorter(Numbers, FrequencySorted):-
    sort(Numbers, UniqueNumbers),
    maplist(frequency_counter(Numbers), UniqueNumbers, Frequencies),
    kvf_insert_sort(Frequencies, FrequencySorted).

Sample Run


$ gprolog --consult-file prolog/ch-2.p
| ?- frequency_sorter([1, 1, 2, 2, 2, 3], Sorted), write_frequencies(Sorted).
3, 1, 1, 2, 2, 2

Sorted = [3-1,1-2,2-3] ? 

(1 ms) yes
| ?- frequency_sorter([2, 3, 1, 3, 2], Sorted), write_frequencies(Sorted).
1, 3, 3, 2, 2

Sorted = [1-1,3-2,2-2] ? 

(1 ms) yes
| ?- frequency_sorter([-1, 1, -6, 4, 5, -6, 1, 4, 1], Sorted), write_frequencies(Sorted).
5, -1, 4, 4, -6, -6, 1, 1, 1

Sorted = [5-1,-1-1,4-2,-6-2,1-3] ? 

(1 ms) yes
| ?- 

Notes

First off, we get a count of the frequencies of each number in the list, via a maplist with frequency_counter/3. After that is when we hit the real complexity of the problem. This problem requires a somewhat unique idea of sorting frequencies! The frequencies have been built as key-value pairs but an ordinary sort or key sort won't work here for these unique requirements. All the required unique sort logic is contained in the kvf_insert_sort/2 and related predicates. This is a modification of insertion sort found in Roman Barták's Guide to Prolog Programming.

With the list of frequencies sorted all that is left is to print the result as specified, which is the work of write_frequencies/1. Those somewhat lengthy looking predicates expand the key-value pairs from the sorted result and print them in the new order.

References

Sort Algorithms in Prolog

Challenge 233

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

What's the Similar Frequency, Kenneth?

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

Part 1

You are given an array of words made up of alphabets only. Write a script to find the number of pairs of similar words. Two words are similar if they consist of the same characters.

Solution


use v5.38;
use boolean;

sub is_similar{
    my($s0, $s1) = @_;
    my(%h0, %h1);
    do { $h0{$_} = undef } for split //, $s0; 
    do { $h1{$_} = undef } for split //, $s1; 
    return false if keys %h0 != keys %h1;
    do { return false if !exists $h1{$_} } for keys %h0;
    return true;
}

sub similar_words_pairs_count{
    my @words = @_;
    my @similar;
    do{
        my $word_index = $_;
        my @similar_temp = grep { $words[$word_index] ne $words[$_] && 
                                  is_similar $words[$word_index], $words[$_] } $word_index + 1 .. @words - 1;
        push @similar, @words[@similar_temp] if @similar_temp > 0;
    } for 0 .. @words - 1;
    return @similar + 0;
}

MAIN:{
    say similar_words_pairs_count qw/aba aabb abcd bac aabc/;
    say similar_words_pairs_count qw/aabb ab ba/;
    say similar_words_pairs_count qw/nba cba dba/;
}

Sample Run


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

Notes

The core of this problem is to count up the number of pairs of similar words. A clearly good use of grep, but how to do that exactly? Well, here we define a subroutine is_similar that returns a true/false value depending on if the words meet the definition of similar given in the problem. That's done by expanding the words into arrays of characters, stuffing those characters into hash key slots in order to force uniqueness, and then seeing if the two key sets are equal.

Once we have the logic to determine similarity worked out we can then use it in grep and count up the results.

Part 2

You are given an array of integers. Write a script to sort the given array in increasing order based on the frequency of the values. If multiple values have the same frequency then sort them in decreasing order.

Solution


use v5.38;
sub frequency_sort{
    my(@numbers) = @_;
    my %frequency;
    do{$frequency{$_}++} for @numbers;
    my $frequency_sorter = sub{
        my $c = $frequency{$a} <=> $frequency{$b};
        return $c unless !$c;
        return $b <=> $a;

    };
    return sort $frequency_sorter @numbers;
}

MAIN:{
    say join q/, /, frequency_sort 1, 1, 2, 2, 2, 3;
    say join q/, /, frequency_sort 2, 3, 1, 3, 2;
    say join q/, /, frequency_sort -1, 1, -6, 4, 5, -6, 1, 4, 1
}

Sample Run


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

Notes

This problem ended up being a bit more complex than it seemed after the first reading. Perl makes this sort of complexity easy to manage though! sort can take a custom sorting subroutine as an argument. That is what is done here, with the requirements of the frequency sort for this problem implemented within the subroutine referenced by $frequency_sorter. This is written as an anonymous subroutine in order to obtain a closure around %frequency. Finally, observe that we can use the scalar reference directly with sort. sort is flexible enough to know how to use the reference.

References

Challenge 233

What's the Frequency, Kenneth?

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

2023-08-21

The Weekly Challenge 231 (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 distinct integers. Write a script to find all elements that is neither minimum nor maximum. Return -1 if you can’t.

Solution


not_min_max(Numbers, NotMinMax):-
    min_list(Numbers, Minimum),
    max_list(Numbers, Maximum),
    delete(Numbers, Minimum, NumbersNoMinimum),
    delete(NumbersNoMinimum, Maximum, NumbersNoMinimumNoMaximum),
    ((length(NumbersNoMinimumNoMaximum, 0), NotMinMax = -1), !;
     (NotMinMax = NumbersNoMinimumNoMaximum)).

Sample Run


$ gprolog --consult-file prolog/ch-1.p
| ?- not_min_max([3, 2], NotMinMax).  

NotMinMax = -1

yes
| ?- not_min_max([3, 2, 1, 4], NotMinMax). 

NotMinMax = [3,2]

yes
| ?- not_min_max([1, 3, 2], NotMinMax).

NotMinMax = [2]

yes

Notes

This is about as straightforward a solution as you can get in Prolog. All the details can be handled by built in predicates. That is, finding the minimum and maximum values, removing those values from consideration are all done for us. The only complication comes fromt he stipulation that we should return -1 instead of the empty list. This isn't a very Prolog thing to do! These problems are not written with Prolog in mind, however, and we make it work easily enough anyway.

Part 2

You are given a list of passenger details in the form “9999999999A1122”, where 9 denotes the phone number, A the sex, 1 the age and 2 the seat number. Write a script to return the count of all senior citizens (age >= 60).

Solution


passenger_senior(Passenger, Senior):-
    length(AgeSeat, 4),
    length(Age, 2),
    atom_chars(Passenger, PassengerChars),
    suffix(AgeSeat, PassengerChars),
    prefix(Age, AgeSeat),
    number_chars(A, Age),
    ((A >= 60, Senior = 1); Senior = 0).

count_senior_citizens(Passengers, CountSeniorCitizens):-
    maplist(passenger_senior, Passengers, SeniorCitizens), !,
    sum_list(SeniorCitizens, CountSeniorCitizens).

Sample Run


$ gprolog --consult-file prolog/ch-2.p
| ?- count_senior_citizens(['7868190130M7522', '5303914400F9211', '9273338290F4010'], Count).

Count = 2

(1 ms) yes
| ?- count_senior_citizens(['1313579440F2036', '2921522980M5644'], Count).   

Count = 0

yes
| ?-

Notes

Since the passenger details are given in strings with fixed width fields we can chop up and find what we need using lists. Since the information we seek (the age) is at the end of the passenger details we can work from the suffix. First we get the details as characters, then we get the final four characters. Of these final four the first two are the age.

This is all done by way of maplist/3. Only those passengers that meet the age criteria are given a value of one, the rest zero. The final count is taken via sum_list/2.

References

Challenge 231

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

Not the MinMax Count

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

Part 1

You are given an array of distinct integers. Write a script to find all elements that is neither minimum nor maximum. Return -1 if you can’t.

Solution


use v5.38;
sub not_min_max{
    my($minimum, $maximum);
    do{
        $minimum = $_ if !$minimum || $_ < $minimum;
        $maximum = $_ if !$maximum || $_ > $maximum;
    } for @_;
    my @r = grep { $_ ^ $minimum && $_ ^ $maximum } @_;
    return @r ^ 0 ? @r : -1;
}

MAIN:{
    say join q/, /, not_min_max 3, 2, 1, 4;
    say join q/, /, not_min_max 3, 1;
    say join q/, /, not_min_max 2, 1, 3;
}

Sample Run


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

Notes

Once we find the maximum and minimum values, we need to remove them. Just to be different I used the XOR ^ operator instead of !=. The effect is the same, a false (zero) value is returned if the values are identical, true (one) otherwise.

Part 2

You are given a list of passenger details in the form “9999999999A1122”, where 9 denotes the phone number, A the sex, 1 the age and 2 the seat number. Write a script to return the count of all senior citizens (age >= 60).

Solution


use v5.38;
sub count_senior_citizens{
    my $count = 0;
    do{
        my @a = unpack q/A10A1A2A2/, $_; 
        $count++ if $a[2] >= 60;
    } for @_;
    return $count;
}

MAIN:{
    say count_senior_citizens qw/7868190130M7522 5303914400F9211 9273338290F4010/;
    say count_senior_citizens qw/1313579440F2036 2921522980M5644/;
}

Sample Run


$ perl perl/ch-2.pl 
2
0

Notes

It isn't all that often you find a nice clean use of unpack! This seems to be a very nice opportunity: each passenger string has fixed field lengths.

The passenger strings themselves are just Perl scalar values. They are not, say, specially constructed strings via pack. To unpack an ordinary scalar we can just use As in the template string.

References

pack/unpack Templates

Challenge 231

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

2023-08-20

The Weekly Challenge 230 (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 positive integers. Write a script to separate the given array into single digits.

Solution


clone(X, [X]).

separate(Number, Digits):-
    number_chars(Number, Chars),
    maplist(clone, Chars, DigitChars),
    maplist(number_chars, Digits, DigitChars).

separate_digits(Numbers, Digits):-
    maplist(separate, Numbers, D),
    flatten(D, Digits).

Sample Run


$ gprolog --consult-file prolog/ch-1.p
| ?- separate_digits([1, 34, 5, 6], Digits).

Digits = [1,3,4,5,6] ? 

yes

Notes

For a long time I really never embraced the full power of maplist. At present I can't seem to get enough! In this solution to TWC230.1 we use maplist to first create a singleton list for each digit character in each of the given numbers, we then use maplist to convert these singleton lists to single digit numbers as required.

Part 2

You are given an array of words made up of alphabetic characters and a prefix. Write a script to return the count of words that starts with the given prefix.

Solution


prefix_match(Prefix, Word, Match):-
    atom_chars(Prefix, PrefixChars),
    atom_chars(Word, WordChars),
    ((prefix(PrefixChars, WordChars), Match = 1);
     (\+ prefix(PrefixChars, WordChars), Match = 0)).

count_words(Prefix, Words, Count):-
    maplist(prefix_match(Prefix), Words, Matches),
    sum_list(Matches, Count).

Sample Run


$ gprolog --consult-file prolog/ch-2.p
| ?- count_words(at, [pay, attention, practice, attend], Count).

Count = 2 ? 

yes
| ?- count_words(ja, [janet, julia, java, javascript], Count).  

Count = 3 ? 

(1 ms) yes
| ?- 

Notes

Another nice use of maplist, but a bit less gratuitous. In this solution to TWC230.2 we use maplist to generate a list of 0s or 1s, depending on whether a given word starts with the given prefix. The count of matching words is then the sum_list/2 of those results.

References

Challenge 230

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

Separate and Count

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

Part 1

You are given an array of positive integers. Write a script to separate the given array into single digits.

Solution


use v5.38;
sub separate_digits{
    return separater([], @_); 
}

sub separater{
    my $seperated = shift;
    return @{$seperated} if @_ == 0;
    my @digits = @_;
    push @{$seperated}, split //, shift @digits;
    separater($seperated, @digits);
}

MAIN:{
    say join q/,/, separate_digits 1, 34, 5, 6;
}

Sample Run


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

Notes

It has been a while since I wrote recursive Perl code, this week's TWC offered two nice chances to do so. The first call to separate_digits invokes the call to the recursive subroutine separater, adding an array reference for the convenience of accumulating the individual digits at each recursive step.

Within separater each number in the array is taken one at a time and expanded to its individual digits. The digits are pushed into the accumulator. When we run of digits we return the complete list of digits.

Part 2

You are given an array of words made up of alphabetic characters and a prefix. Write a script to return the count of words that starts with the given prefix.

Solution


use v5.38;
sub count_words{
    return counter(0, @_); 
}

sub counter{
    my $count = shift;
    my $prefix = shift;
    return $count if @_ == 0;
    my $word = shift;
    $count++ if $word =~ m/^$prefix/;
    counter($count, $prefix, @_);
}

MAIN:{
    say count_words qw/at pay attention practice attend/;
    say count_words qw/ja janet julia java javascript/;
}

Sample Run


$ perl perl/ch-2.pl 
2
3

Notes

The exact same approach used for Part 1 is used here in the second part. Instead of accumulating am array of digits instead we increment the counter of words which start with the prefix characters.

References

Challenge 230

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

2023-07-23

Shuffled Operations

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

Part 1

You are given a string and an array of indices of same length as string. Write a script to return the string after re-arranging the indices in the correct order.

Solution


use v5.38;
sub shuffle_string{
    my($s, $indices) = @_;
    my @s = split(//, $s);
    my @t;
    do { $t[$_] = shift @s } for @{$indices};
    return join(q//, @t);
}

MAIN:{
    say shuffle_string(q/lacelengh/, [3, 2, 0, 5, 4, 8, 6, 7, 1]);
    say shuffle_string(q/rulepark/, [4, 7, 3, 1, 0, 5, 2, 6]);
}

Sample Run


$ perl perl/ch-1.pl 
challenge
perlraku

Notes

I had to think of this one a bit! What we need to do is take each letter, from left to right, and assign it a new position. It's not often you see a shift within another loop but here that is the key to getting everything working.

Part 2

You are given an array of non-negative integers, @ints. Write a script to return the minimum number of operations to make every element equal zero.

Solution


use v5.38;
sub zero_array{
    my $operations = 0;
    do{
        return $operations if 0 == unpack(q/%32I*/, pack(q/I*/, @_));
        my $minimum = (sort { $a <=> $b } grep { $_ > 0 } @_)[0];
        @_ = map { $_ > 0 ? $_ - $minimum : 0 } @_; 
        $operations++;
    } for @_;
}

MAIN:{
    say zero_array 1, 5, 0, 3, 5;
    say zero_array 0;
    say zero_array 2, 1, 4, 0, 3
}

Sample Run


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

Notes

Usually I assign function arguments new names, even if I am just passing in a single array of values like in this example. I decided this time to not do it, I don't think readability is sacrificed. Provided the reader actually knows what @_ is I think for a short function such as this it's fine. In fact, I think an argument could be made that readability is actually enhanced since lines such as the one with both a sort and a grep are kept to a shorter length.

References

Challenge 226

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

The Weekly Challenge 226 (Prolog Solutions)

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

Part 1

You are given a string and an array of indices of same length as string. Write a script to return the string after re-arranging the indices in the correct order.

Solution


letter_shuffle(Shuffled, Letter, Index):-
    nth(Index, Shuffled, Letter).

Sample Run


$ gprolog --consult-file prolog/ch-1.p
| ?- length(L, 9), maplist(letter_shuffle(L), "lacelengh", [4, 3, 1, 6, 5, 9, 7, 8, 2]), atom_codes(A, L).

A = challenge
L = [99,104,97,108,108,101,110,103,101]

yes

Notes

Many Prologs, including GNU Prolog, treat double quoted strings as lists of the character codes representing each letter. So here maplist/3 is presented such a list as well as the given list of indices. We give a letter_shuffle/3 an empty list of the right length and all that is left is for nth/3 to assign the letters as needed.

Part 2

You are given an array of non-negative integers, @ints. Write a script to return the minimum number of operations to make every element equal zero.

Solution


subtract_minimum(Minimum, X, Y):-
    Y is X - Minimum.

zero_array(Numbers, Operations):-
    delete(Numbers, 0, NumbersNoZero),
    zero_array(NumbersNoZero, 0, Operations).
zero_array([], Operations, Operations).    
zero_array(Numbers, OperationsCounter, Operations):-
    delete(Numbers, 0, NumbersNoZero),
    min_list(NumbersNoZero, Minimum),
    maplist(subtract_minimum(Minimum), NumbersNoZero, NumbersSubtracted),
    succ(OperationsCounter, OperationsCounterNext), 
    delete(NumbersSubtracted, 0, NumbersSubtractedNoZero),
    zero_array(NumbersSubtractedNoZero, OperationsCounterNext, Operations).

Sample Run


$ gprolog --consult-file prolog/ch-2.p
| ?- zero_array([1, 5, 0, 3, 5], Operations).

Operations = 3 ? 

yes
| ?- zero_array([0], Operations).

Operations = 0 ? 

yes
| ?- zero_array([2, 1, 4, 0, 3], Operations).

Operations = 4 ? 

yes
| ?- 

Notes

A convenient issue with this problem is that once a list entry is zero we can ignore it. Since we can ignore it we can delete/3 it and thereby reduce the list eventually to the empty list, the base of our recursion. Each time we recurse we find the minimum element, subtract it from all others, and increment the number of operations.

References

Challenge 226

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

2023-07-13

Sentenced To Compute Differences

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

Part 1

You are given a list of sentences. Write a script to find out the maximum number of words that appear in a single sentence.

Solution


use v5.38;
sub max_sentence_length{
    my(@sentences) = @_;
    my $max_words = -1;
    do{
        my @word_matches = $_ =~ m/(\w+)/g; 
        $max_words = @word_matches if @word_matches > $max_words;
    } for @sentences;
    return $max_words;
}

MAIN:{
    my @list;
    @list = ("Perl and Raku belong to the same family.", "I love Perl.", 
"The Perl and Raku Conference.");
    say  max_sentence_length(@list);
    @list = ("The Weekly Challenge.", "Python is the most popular guest language.",
"Team PWC has over 300 members.");
    say  max_sentence_length(@list);
}

Sample Run


$ perl perl/ch-1.pl 
8
7

Notes

This is the perfect job for a regular expression! In fact \w is a special character sequence which matches word characters, so they heart of the solution is to apply it to the given sentences and count the matches.

The expression my @word_matches = $_ =~ m/(\w+)/g may look a little weird at first. What is happening here is that we are collecting all groups of matchs (enclosed in parentheses in the regex) into a single array. In this way, we immediately know the number of words in each sentence, it is just the size of the array.

Part 2

You are given an array of integers. Write a script to return left right sum difference array.

Solution


use v5.38;
sub left_right_sum{
    return unpack("%32I*", pack("I*", @_));
}

sub left_right_differences{
    my(@left_sum, @right_sum);
    for(my $i = 0; $i < @_; $i++){
        push @left_sum, left_right_sum(@_[0 .. $i - 1]);
        push @right_sum, left_right_sum(@_[$i + 1 .. @_ - 1]);
    }    
    return map { abs($left_sum[$_] - $right_sum[$_]) } 0 .. @_ - 1;
}

MAIN:{
    say join(q/, /, left_right_differences 10, 4, 8, 3);
    say join(q/, /, left_right_differences 1);
    say join(q/, /, left_right_differences 1, 2, 3, 4, 5);
}

Sample Run


$ perl perl/ch-2.pl 
15, 1, 11, 22
0
14, 11, 6, 1, 10

Notes

The problem statement may be a little confusing at first. What we are trying to do here is to get two lists the prefix sums and suffix sums, also called the left and right sums. We then pairwise take the absolute values of each element in these lists to get the final result. Iterating over the list the prefix sums are the partial sums of the list elements to the left of the current element. The suffix sums are the partial sums of the list elements to the right of the current element.

With that understanding in hand the solution becomes much more clear! We iterate over the list and then using slices get the prefix and suffix arrays for each element. Using my favorite way to sum a list of numbers, left_right_sum() does the job with pack/unpack. Finally, a map computes the set of differences.

References

Challenge 225

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

The Weekly Challenge 225 (Prolog Solutions)

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

Part 1

You are given a list of sentences. Write a script to find out the maximum number of words that appear in a single sentence.

Solution


check_and_read(32, [], _):-
    !.
check_and_read(46, [], _):-
    !. 
check_and_read(-1, [], _):-
    !.
check_and_read(Char, [Char|Chars], Stream):-
    get_code(Stream, NextChar),
    check_and_read(NextChar, Chars, Stream).

read_data(Stream, []):-
    at_end_of_stream(Stream).
read_data(Stream, [X|L]):-
    \+ at_end_of_stream(Stream),
    get_code(Stream, Char),
    check_and_read(Char, Chars, Stream),
    atom_codes(X, Chars),
    read_data(Stream, L).

sentence_atoms(Sentence, Atoms):-
    open_input_codes_stream(Sentence, Stream),
    read_data(Stream, Atoms).

max_sentence_length(Sentences, MaxLength):-
    maplist(sentence_atoms, Sentences, SentenceAtoms),
    maplist(length, SentenceAtoms, Lengths),
    max_list(Lengths, MaxLength).

Sample Run


$ gprolog --consult-file prolog/ch-1.p
| ?- max_sentence_length(["Perl and Raku belong to the same family.", "I love Perl.", "The Perl and Raku Conference."], MaxLength).            

MaxLength = 8 ? 

yes
| ?- max_sentence_length(["The Weekly Challenge.", "Python is the most popular guest language.", "Team PWC has over 300 members."], MaxLength).

MaxLength = 7 ? 

yes
| ?- 

Notes

Since these are programming challenges which are designed with Perl in mind the inputs sometimes require a little manipulation to make them more Prolog friendly. In this case the sentence strings need to be turned into lists of atoms. This is done here by use of Stream processing!

I don't think I've had much occasion to use open_input_codes_stream/2 before. What this does is take the double quoted string, which is seen by Prolog as a list of character codes, and open this as a Stream. We can then process this in the same way as we'd process any other input stream, more typically a file. In fact, much of the code for processing this Stream is re-used from other such code.

The solution, then, is that max_sentence_length/2 will take a list of sentences, call senetence_atoms/2 via a maplist/3 to get a list of list of atoms, then again with a maplist/3 get the lengths of the atom lists, and then finally get the maximum sentence length (the result) from max_list/2.

Part 2

You are given an array of integers. Write a script to return left right sum difference array.

Solution


difference(X, Y, Z):-
    Z is abs(X - Y).

differences(_, 0, LeftAccum, RightAccum, LeftRightDifferences):-
    maplist(difference, LeftAccum, RightAccum, LeftRightDifferences).
differences(Numbers, Index, LeftAccum, RightAccum, LeftRightDifferences):-
    length(Numbers, L),
    Left is Index - 1,
    Right is L - Index,
    length(Prefix, Left),
    length(Suffix, Right),
    prefix(Prefix, Numbers),
    suffix(Suffix, Numbers),
    sum_list(Prefix, LeftSum),
    sum_list(Suffix, RightSum),
    succ(IndexNext, Index),
    differences(Numbers, IndexNext, [LeftSum|LeftAccum], [RightSum|RightAccum], LeftRightDifferences).

left_right_differences(Numbers, LeftRightDifferences):-
    length(Numbers, L),
    differences(Numbers, L, [], [], LeftRightDifferences).

Sample Run


$ gprolog --consult-file prolog/ch-2.p
| ?- left_right_differences([10, 4, 8, 3], LeftRightDifferences).

LeftRightDifferences = [15,1,11,22] ? 

yes
| ?- left_right_differences([1], LeftRightDifferences). 

LeftRightDifferences = [0] ? 

yes
| ?- left_right_differences([1, 2, 3, 4, 5], LeftRightDifferences).

LeftRightDifferences = [14,11,6,1,10] ? 

(1 ms) yes
| ?- 

Notes

The problem statement may be a little confusing at first. What we are trying to do here is to get two lists the prefix sums and suffix sums, also called the left and right sums. We then pairwise take the absolute values of each element in these lists to get the final result. Recursively iterating over the list the prefix sums are the partial sums of the list elements to the left of the current element. The suffix sums are the partial sums of the list elements to the right of the current element.

Once the problem is understood the components of the solution start to come together:

  1. Iterate over the original list and build up the partial sums. prefix/2, suffix/2, and sum_list/2 are very helpful here!
  2. When we are done building the lists of partial sums take the pairwise differences. This could also be done iteratively, but more elegantly we can make use of maplist/4.
  3. Our use of maplist/4 uses the small utility predicate difference/3.

References

Challenge 225

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

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

Challenge 202

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

Challenge 201

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

Challenge 201

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

2023-01-15

The Weekly Challenge 199 (Prolog Solutions)

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

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

Challenge 199

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

Multiple Goods

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

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

Challenge 199

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

2023-01-08

Prime the Gaps!

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

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.

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

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

Challenge 198

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

The Weekly Challenge 198 (Prolog Solutions)

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

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

Challenge 198

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

2022-12-18

The Weekly Challenge 195 (Prolog Solutions)

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

Part 1

You are given a positive integer, $n > 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:

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

  2. Compute the frequency of each remaining even number.

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

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

Challenge 195

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

Especially Frequent Even

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

Part 1

You are given a positive integer, $n > 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

Challenge 195

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

2022-12-03

The Weekly Challenge 193 (Prolog Solutions)

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

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

Challenge 193

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

The Weekly Challenge 193

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

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

Challenge 193

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

2022-11-27

The Weekly Challenge 192 (Prolog Solutions)

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

Part 1

You are given a positive integer, $n. Write a script to find 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:

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

Challenge 192

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

Flipping to Redistribute

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

Part 1

You are given a positive integer, $n. Write a script to find 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:

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

oct

Challenge 192

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

2022-11-20

Twice Largest Once Cute

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

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:

  1. sort the list O(n log n)

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

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

Challenge 191

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

The Weekly Challenge 191 (Prolog Solutions)

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

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

Challenge 191

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