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

Part 1

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

Solution

:-initialization(main).

pad(Bits, Padded):-
    length(Bits, L),
    PadLength is 8 - L,
    length(Padding, PadLength),
    maplist(=(0), Padding),
    append(Padding, Bits, Padded).

bits(N, Bits):-
    bits(N, [], Bits).
bits(0, Bits, Bits).
bits(N, Bit_Accum, Bits):-
    B is N /\ 1,
    N0 is N >> 1,
    bits(N0, [B|Bit_Accum], Bits).

flip_nth_bit(N, Bits, NthFlipped):-
    N0 is 9 - N,
    N1 is 8 - N,
    nth(N0, Bits, B),
    Flipped is xor(B, 1),
    length(Bits0, N1),
    append(Bits0, [B|T], Bits),
    append(Bits0, [Flipped|T], NthFlipped).

decimal(Bits, Decimal):-
    decimal(Bits, 0, Decimal).
decimal([], Decimal, Decimal).
decimal([H|T], DecimalAccum, Decimal):-
    length([H|T], B),
    D is (H * 2 ** (B - 1)) + DecimalAccum,
    decimal(T, D, Decimal).

main:-
    bits(12, B),
    pad(B, Padded),
    flip_nth_bit(3, Padded, Flipped),
    decimal(Flipped, Decimal),
    write(Decimal), nl,
    halt.

Sample Run

$ gprolog --consult-file prolog/ch-1.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
| ?- consult('prolog/ch-1.p').
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-121/adam-russell/prolog/ch-1.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-121/adam-russell/prolog/ch-1.p compiled, 41 lines read - 4756 bytes written, 48 ms
8.0

Notes

This re-uses much code from last week. What is different here is flip_nth_bit/3 which finds the Nth bit specified, XORs it, and then sets the updated list.

References

Challenge 121

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

Part 1

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

Solution

:-initialization(main).

pad(Bits, Padded):-
    length(Bits, L),
    PadLength is 8 - L, 
    length(Padding, PadLength),  
    maplist(=(0), Padding),
    append(Padding, Bits, Padded).  

bits(N, Bits):-
    bits(N, [], Bits).
bits(0, Bits, Bits).    
bits(N, Bit_Accum, Bits):-    
    B is N /\ 1,
    N0 is N >> 1,
    bits(N0, [B|Bit_Accum], Bits).

swap([], []). 
swap([H0, H1|T], [H1, H0|ST]):-
    swap(T, ST).

decimal(Bits, Decimal):-
    decimal(Bits, 0, Decimal).
decimal([], Decimal, Decimal).
decimal([H|T], DecimalAccum, Decimal):-
    length([H|T], B), 
    D is (H * 2 ** (B - 1)) + DecimalAccum,
    decimal(T, D, Decimal).  

main:-
    bits(18, B),
    pad(B, Padded),  
    swap(Padded, Swapped), 
    decimal(Swapped, Decimal), 
    write(Decimal), nl,
    halt.

Sample Run

$ gprolog --consult-file prolog/ch-1.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-120/adam-russell/prolog/ch-1.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-120/adam-russell/prolog/ch-1.p compiled, 36 lines read - 3978 bytes written, 98 ms
33.0

Notes

Working with bitwise operators in Prolog is something I have done a bit before. This code most notably borrows from a solution to Challenge 079. Here that set_bit/2 predicate is repurposed as bits/2 which returns a list of bits for any given number.

The list of bits must be padded (pad/2), the bits swapped (swap/2), and then the decimal value of the swapped bits calculated (decimal/2).

Part 2

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

Solution

:-initialization(main).

clock_angle(Time, Angle):-
    append(H, [58|M], Time),  
    number_codes(Hour, H),
    number_codes(Minutes, M),
    A is abs(0.5 * (60 * Hour - 11 * Minutes)), 
    ((A > 180, Angle is 360 - A); Angle = A). 

main:-
    clock_angle("03:10", Angle),
    write(Angle), nl,  
    halt. 

Sample Run

$ gprolog --consult-file prolog/ch-2.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-120/adam-russell/prolog/ch-2.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-120/adam-russell/prolog/ch-2.p compiled, 13 lines read - 2384 bytes written, 40 ms
35.0

Notes

clock_angle/2 starts out by splitting the hh:mm formatted time into the hour and minute parts, by way of append. 58 is the character code for the ':'. Once this is done, and that is perhaps the most prological part of the code, the formula for the angle is applied.

References

Challenge 120

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

Part 1

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

Solution

:-initialization(main).

check_and_read(10, [] ,_):-
    !.
check_and_read(13, [], _):-
    !.
check_and_read(44, [], _):-
    !.
check_and_read(end_of_file, [], _):-
    !.
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).

line_numbers([], []).  
line_numbers([N0,_|T], [N1|N]):-
    number_atom(N1, N0),
    line_numbers(T, N). 

missing(Contents, Missing):-
    line_numbers(Contents, Numbers),
    max_list(Numbers, Max),
    min_list(Numbers, Min),
    between(Min, Max, X),
    \+ member(X, Numbers),
    Missing = X. 

main:-
    open('data', read, Stream),
    read_data(Stream, Contents),
    close(Stream),
    missing(Contents, Missing),
    format('Missing: ~d ~N', [Missing]), 
    halt.   

Sample Run

$ gprolog --consult-file prolog/ch-1.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-117/adam-russell/prolog/ch-1.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-117/adam-russell/prolog/ch-1.p compiled, 18 lines read - 1808 bytes written, 38 ms
Missing: 12

Notes

What interested me the most on this is the majority of the code here is to read in the data file. It's all boilerplate stuff, ordinarily it'd be in some other file of utilities. The work is all done in the seven lines of missing/2. Once we have all the line numbers we use member/2 to determine which one is missing.

As usual there was a second task in this week's challenge but I did not get around to coding up a solution in Prolog. I did get do it in Perl however. Given the nature of that problem my Prolog would have been a fairly close re-implementation of the same algorithm.

Happy Father's Day!

References

Challenge 117

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

Part 1

You are given a positive integer $N. Write a script to find out the next Palindrome Number higher than the given integer $N.

Solution

:-initialization(main).

next_palindrome(N, NextPalindrome):-
    current_prolog_flag(max_integer, MAX_INTEGER),
    N0 is N + 1,
    between(N0, MAX_INTEGER, X),
    number_chars(X, C),
    reverse(C, R),
    number_chars(NR, R),
    NR == X,
    NextPalindrome = NR.

main:-
    next_palindrome(1234, NextPalindrome0),
    write(NextPalindrome0), nl,
    next_palindrome(999, NextPalindrome1),
    write(NextPalindrome1), nl,
    halt.

Sample Run

$ gprolog --consult-file prolog/ch-1.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-114/adam-russell/prolog/ch-1.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-114/adam-russell/prolog/ch-1.p compiled, 18 lines read - 1808 bytes written, 38 ms
1331
1001

Notes

The solution to this task is probably the most intuitive: check numbers starting with N and for each one reverse and check.

Part 2

You are given a positive integer $N. Write a script to find the next higher integer having the same number of 1 bits in binary representation as $N.

Solution

:-initialization(main).

set_bits(N, X):-
    set_bits(N, 0, X).
set_bits(0, X, X).
set_bits(N, X_Acc, X):-
    B is N /\ 1,
    X0 is X_Acc + B,
    N0 is N >> 1,
    set_bits(N0, X0, X), !.

next_same_bits(N, NextSameBits):-
    current_prolog_flag(max_integer, MAX_INTEGER),
    set_bits(N, NumberBits),
    N0 is N + 1,
    between(N0, MAX_INTEGER, X),
    set_bits(X, B),
    B == NumberBits,
    NextSameBits = X.

main:-
    next_same_bits(3, NextSameBits0),
    write(NextSameBits0), nl,
    next_same_bits(12, NextSameBits1),
    write(NextSameBits1), nl,
    halt.

Sample Run

$ gprolog --consult-file prolog/ch-2.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-114/adam-russell/prolog/ch-2.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-114/adam-russell/prolog/ch-2.p compiled, 26 lines read - 2763 bytes written, 42 ms
5
17

Notes

set_bits/2 is code re-used from Challenge 079. Otherwise, the code is very similar to the solution to the first task.

References

Challenge 114

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

Part 1

You are given a positive integer $N and a digit $D. Write a script to check if $N can be represented as a sum of positive integers having $D at least once. If check passes print 1 otherwise 0.

Solution

:-initialization(main).

contains([], _, []).
contains([H|T], Digit, [N|R]):-
    number_chars(H, C),
    number_chars(Digit, [D]),
    member(D, C),
    N = H,
    contains(T, Digit, R).
contains([H|T], Digit, Contains):-
    number_chars(H, C),
    number_chars(Digit, [D]),
    \+ member(D, C),
    contains(T, Digit, Contains).

represented(N, D):-
    findall(X, between(1, N, X), Numbers),
    contains(Numbers, D, Contains),
    sum_list(Contains, N).

main:-
    (((represented(25, 7), write(1)); write(0)), nl),
    (((represented(24, 7), write(1)); write(0)), nl),
    halt.

Sample Run

$ gplc prolog/ch-1.p
$ prolog/ch-1
0
1

Notes

This is pretty straightforward Prolog. contains/3 is a list filter that gets the numbers from the list which contain Digit. After that is done we need only check to see if they sum to N. If represented/2 succeeds we print 1 and 0 otherwise.

Part 2

You are given a Binary Tree. Write a script to replace each node of the tree with the sum of all the remaining nodes.

Solution

:-dynamic(edge/3).

:-initialization(main).

root(1).
edge(old, 1, 2).
edge(old, 2, 4).
edge(old, 4, 7).
edge(old, 1, 3).
edge(old, 3, 5).
edge(old, 3, 6).

dfs_replace(GraphOld, GraphNew, Vertex):-
    dfs_replace(GraphOld, GraphNew, Vertex, _).
dfs_replace(GraphOld, GraphNew, Vertex, VertexPrevious):-
    (var(VertexPrevious),
     edge(GraphOld, Vertex, VertexNext),
     sum_remaining(GraphOld, Vertex, SumRemaining),
     dfs_replace(GraphOld, GraphNew, VertexNext, SumRemaining));
    sum_remaining(GraphOld, Vertex, SumRemaining),
    assertz(edge(GraphNew, VertexPrevious, SumRemaining)),
    findall(V, edge(GraphOld, _, V), VerticesOld),
    findall(V, edge(GraphNew, _, V), VerticesNew),
    length(VerticesOld, VOL),
    length(VerticesNew, VNL),
    VOL \== VNL,
    edge(GraphOld, Vertex, VertexNext),
    dfs_replace(GraphOld, GraphNew, VertexNext, SumRemaining).
dfs_replace(GraphOld, GraphNew, _, _):-
    findall(V, edge(GraphOld, _, V), VerticesOld),
    findall(V, edge(GraphNew, _, V), VerticesNew),
    length(VerticesOld, VOL),
    length(VerticesNew, VNL),
    VOL == VNL.

sum_remaining(GraphOld, Vertex, SumRemaining):-
    findall(V, edge(GraphOld, _, V), Vertices),
    root(Root),
    delete([Root|Vertices], Vertex, RemainingVertices),
    sum_list(RemainingVertices, SumRemaining).

main:-
    root(Root),
    dfs_replace(old, new, Root),
    listing(edge/3),
    halt.

Sample Run

$ gplc prolog/ch-2.p
$ prolog/ch-2

% file: /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-113/adam-russell/prolog/ch-2.prolog

edge(old, 1, 2).
edge(old, 2, 4).
edge(old, 4, 7).
edge(old, 1, 3).
edge(old, 3, 5).
edge(old, 3, 6).
edge(new, 27, 26).
edge(new, 26, 24).
edge(new, 24, 21).
edge(new, 27, 25).
edge(new, 25, 23).
edge(new, 25, 22).

Notes

There are several ways to represent trees and graphs in Prolog. Here I chose to store the edges in the Prolog database along with a label containing the graph name. old is the original tree and new is the one containing the updated values fort eh vertices.

The overal approach is the same as I did for the Perl solution to this problem.

• Perform a Depth First traversal
• As each vertex is visited construct a new edge with the updated values in a new tree
• When the number of updated vertices is the same as the original tree then we are done
• listing/1 is used to show the original and updated trees

If we did not have the check on the number of updated vertices then dfs_replace/3 would simply fail when the traversal was complete. As thise code is designed this should instead succeed when complete.

References

Challenge 112

Depth First Traversal

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

Part 2

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

Solution

:-initialization(main).

steps --> [].
steps --> step, steps.
step  --> [0]; [1]; [2].

sum_steps(Steps, Goal):-
    length(Steps, Goal),
    phrase(steps, Steps),
    sum_list(Steps, Goal).

zero_remove([], []).
zero_remove([H|T], [ZR_H|ZR_T]):-
    delete(H, 0, ZR_H),
    zero_remove(T, ZR_T).

main:-
    findall(Steps, sum_steps(Steps, 4), S),
    zero_remove(S, SZR),
    sort(SZR, SZR_Unique),
    write(SZR_Unique), nl,
    halt.

Sample Run

$ gprolog --consult-file prolog/ch-2.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-112/adam-russell/prolog/ch-2.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-112/adam-russell/prolog/ch-2.p compiled, 22 lines read - 2790 bytes written, 43 ms
[[1,1,1,1],[1,1,2],[1,2,1],[2,1,1],[2,2]]

Notes

I've been trying to do more with DCGs. This is not the most algorithmically pure use of DCG's but the point here was just to try something new.

Overview of this brute force approach with DCGs:

• Generate all lists of numbers of length Goal using digits 0, 1, and 2.
• Keep all those lists that sum to Goal
• Remove zeroes from these matching lists
• Remove duplicate lists (using sort/2)

References

Challenge 112

The examples used here are from the weekly challenge problem statement and demonstrate the working solution. Also, the challenge statements are given in a Perl context although for Prolog solutions some adjustments are made to account for the differing semantics between the two languages.

Part 1

You are given a text file. Write a script to display all valid phone numbers in the given text file.

Solution

:-initialization(main).

test('0044 1148820341').  
test('+44 1148820341').  
test('44-11-4882-0341').  
test('(44) 1148820341').   
test('00 1148820341').  

phone_number --> prefx,  space, area_exchange_subscriber.
prefx  --> ['('], digit, digit, [')'].
prefx --> ['+'], digit, digit.
prefx --> digit, digit, digit, digit.
space --> [' '].
area_exchange_subscriber --> digit, digit, digit, digit, digit, digit, digit, digit, digit, digit.
digit --> ['0']; ['1']; ['2']; ['3']; ['4']; ['5']; ['6']; ['7']; ['8']; ['9'].

run_tests:-
    test(T),
    atom_chars(T, C),   
    phrase(phone_number, C),
    write(T), nl.

main:-
    run_tests.

Sample Run

$$ gprolog --consult-file prolog/ch-1.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-110/adam-russell/prolog/ch-1.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-110/adam-russell/prolog/ch-1.p compiled, 27 lines read - 5899 bytes written, 78 ms
| ?- run_tests.
0044 1148820341

true ? ;
+44 1148820341

true ? ;
(44) 1148820341

true ? ;

(1 ms) no

Notes

I skipped anything to do with actually reading the numbers from a file since that doesn’t really add to the interesting part of the problem. Instead the possible phone numbers to test are just stored in the Prolog db.

Testing is done via DCG. The DCG is a bit rotely written, for sure! DCG’s are a bit hard to debug so I thought I’d start out writing things out as obviously as possible and then come back to tighten things up. Coming back to the DCG later on, I thought there was something kind of attractive to the thing, as it is a bit close to the grammar I wrote in the Perl version of the solution. Perhaps someone looking at the Perl grammar would look at this and even not knowing Prolog be able to make perfect sense of it.

Part 2

You are given a text file. Write a script to transpose the contents of the given file.

Solution

:-initialization(main).

transpose(Columns, Transposed):-
    transpose(Columns, _, Transposed).
transpose([], Transposed, Transposed).
transpose([H|T], TransposedAccum, Transposed):-
    transpose_row(H, TransposedAccum, TransposedAccumNew),
    reverse(TransposedAccumNew, TransposedAccumNewReversed),
    transpose(T, TransposedAccumNewReversed, Transposed).

transpose_row(Row, TransposedAccum, RowTranspose):-
    transpose_row(Row, TransposedAccum, [], RowTranspose).
transpose_row([], [], RowTranspose, RowTranspose).
transpose_row([H|T], [HAccum|TAccum], RowTransposeAccum, RowTranspose):-
    append(HAccum, H, HAccum0),
    flatten(HAccum0, HAccum1),
    transpose_row(T, TAccum, [HAccum1 | RowTransposeAccum], RowTranspose).

main:-
    transpose([[1,2,3],[4,5,6]], Transposed),
    write(Transposed), nl.

Sample Run

$ gprolog --consult-file prolog/ch-2.p
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-110/adam-russell/prolog/ch-2.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-110/adam-russell/prolog/ch-2.p compiled, 23 lines read - 2766 bytes written, 43 ms
[[1,4],[2,5],[3,6]]

Notes

Again, I skip over reading test data from a file and focus just on transposing a hardcoded table. This is fairly straightforward, and is another list processing exercise that would be well served by using DCGs, but the non-DCG approach seems to otherwise be a fairly standard exercise in recursion.

References

Challenge 110

The examples used here are from the weekly challenge problem statement and demonstrate the working solution. Also, the challenge statements are given in a Perl context although for Prolog solutions some adjustments are made to account for the differing semantics between the two languages.

Part 1

Write a script to display the first 20 Chowla Numbers.

Solution

:-initialization(main).

print_with_comma([H|[]]):-
    write(H), nl.
print_with_comma([H|T]):-
    write(H),
    write(', '),
    print_with_comma(T).

factor(N, Factors):-
    S is round(sqrt(N)),
    fd_domain(X, 2, S),
    R #= N rem X,
    R #= 0,
    Q #= N // X,
    Q #\= X,
    fd_labeling([Q, X]),
    Factors = [Q, X].
factor(N, Factors):-
    S is round(sqrt(N)),
    fd_domain(X, 2, S),
    R #= N rem X,
    R #= 0,
    Q #= N // X,
    Q #= X,
    fd_labeling([Q]),
    Factors = [Q].    

chowla(ChowlaNumber):-
    between(1, 20, N),
    findall(F, factor(N, F), Fs), 
    flatten(Fs, Factors),
    sum_list(Factors, ChowlaNumber).

main:-
    findall(ChowlaNumber, chowla(ChowlaNumber), ChowlaNumbers),
    print_with_comma(ChowlaNumbers).

Sample Run

$ gprolog --consult-file prolog/ch-1.p 
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-109/adam-russell/prolog/ch-1.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-109/adam-russell/prolog/ch-1.p compiled, 41 lines read - 4116 bytes written, 44 ms
0, 0, 0, 2, 0, 5, 0, 6, 3, 7, 0, 15, 0, 9, 8, 14, 0, 20, 0, 21

Notes

Gnu Prolog’s builtin FD solver makes quick work of this problem! To compute a Chowla Number we must compute a number’s unique factors and then take their sum. 1 and the number itself are excluded. So, in the case of primes the Chowla Number is 0. In the case of numbers where a factor is repeated (e.g. 4 = 2 * 2) the repeated factor is only included once.

Part 2

Place the given unique numbers in the square box so that sum of numbers in each box is the same.

Solution

/*
 You are given four squares as below with numbers named a,b,c,d,e,f,g.
 to place the given unique numbers in the square box so that sum of 
 numbers in each box is the same. 
               (1)                    (3)
        +--------------+      +--------------+
        ?              ?      ?              ?
        ?      a       ?      ?      e       ?
        ?              ? (2)  ?              ?  (4)
        ?          +---+------+---+      +---+---------+
        ?          ?   ?      ?   ?      ?   ?         ?
        ?          ? b ?      ? d ?      ? f ?         ?
        ?          ?   ?      ?   ?      ?   ?         ?
        ?          ?   ?      ?   ?      ?   ?         ?
        +----------+---+      +---+------+---+         ?
                   ?       c      ?      ?      g      ?
                   ?              ?      ?             ?
                   ?              ?      ?             ?
                   +--------------+      +-------------+
*/

:-initialization(main).

print_with_tab([H|[]]):-
    write(H), nl.
print_with_tab([H|T]):-
    write(H),
    write('\t'),
    print_with_tab(T).

print_values([]).
print_values([H|T]):-
    print_with_tab(H), 
    print_values(T).

print_solutions(Solutions):-
    print_with_tab([a, b, c, d, e, f, g]),
    print_values(Solutions).  

all_unique(_, []).
all_unique(L, [V|T]) :-
    fd_exactly(1, L, V),
    all_unique(L, T).

sums_in_squares_naive(Numbers, [A, B, C, D, E, F, G]):-  
    member(A, Numbers), 
    member(B, Numbers),
    member(C, Numbers),
    member(D, Numbers),
    member(E, Numbers),
    member(F, Numbers),
    member(G, Numbers),
    \+ (A == B; A == C; A == D; A == E; A == F; A == G),
    \+ (B == A; B == C; B == D; B == E; B == F; B == G),
    \+ (C == A; C == B; C == D; C == E; C == F; C == G),
    \+ (D == A; D == B; D == C; D == E; D == F; D == G),
    \+ (E == A; E == B; E == C; E == D; E == F; E == G),
    \+ (F == A; F == B; F == C; F == D; F == E; F == G),
    \+ (G == A; G == B; G == C; G == D; G == E; G == F),
    Box1 is A + B,
    Box2 is B + C + D,
    Box3 is D + E + F,
    Box4 is F + G,
    Box1 == Box2,
    Box2 == Box3,
    Box3 == Box4.

sums_in_squares_fd(Numbers, [A, B, C, D, E, F, G]):-  
    fd_domain([A, B, C, D, E, F, G], Numbers),
    all_unique([A, B, C, D, E, F, G], Numbers),
    Box1 = A + B,
    Box2 = B + C + D,
    Box3 = D + E + F,
    Box4 = F + G,
    Box1 #= Box2,
    Box2 #= Box3,
    Box3 #= Box4,
    fd_labeling([A, B, C, D, E, F, G]).
    
main:-
    setof(S, sums_in_squares_fd([1,2,3,4,5,6,7], S), Squares),
    print_solutions(Squares).

Sample Run

$ gprolog --consult-file prolog/ch-2.p 
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
compiling /home/adamcrussell/Projects/perlweeklychallenge-club/challenge-109/adam-russell/prolog/ch-2.p for byte code...
/home/adamcrussell/Projects/perlweeklychallenge-club/challenge-109/adam-russell/prolog/ch-2.p compiled, 82 lines read - 13210 bytes written, 66 ms
a       b       c       d       e       f       g
3       7       2       1       5       4       6
4       5       3       1       6       2       7
4       7       1       3       2       6       5
5       6       2       3       1       7       4
6       4       1       5       2       3       7
6       4       5       1       2       7       3
7       2       6       1       3       5       4
7       3       2       5       1       4       6

Notes

The Perl solution to this problem used a builtin Prolog available as a Perl module on CPAN. The “naive” version of the solution is effectively the same code as what was used there. I repeated it here to make a couple of comparisons, but that perl module, AI::Prolog, is little better than a toy implementation. Here with Gnu Prolog we can see that with an FD solver this problem can be very quickly computed with a minimum of code.

References

Challenge 109

Sarvadaman D. S. Chowla

AI::Prolog

The examples used here are from the weekly challenge problem statement and demonstrate the working solution. Also, the challenge statements are given in a Perl context although for Prolog solutions some adjustments are made to account for the differing semantics between the two languages.

Part 1

Write a script to declare a variable or constant and print it’s location in the memory.

Notes

This is a strange thing to do in Prolog since the very idea of a “variable” is dissimilar to that of imperative programming languages. Still, it is possible to do, especially with Gnu Prolog’s foreign/2, part of the Foreign Language Interface. This requires us to write some code in C and in this way we can surely report on the memory address used by whatever Prolog variable we want to examine. I will admit to being intrigued by this but at present did not have the opportunity to explore this. For now I am leaving these notes here as a placeholder to investigate this further if/when the opportunity allows.

Part 2

Write a script to display the first 10 Bell Numbers.

Solution

:-initialization(main).

addElement(Element, [FirstList | OtherLists], [ [Element|FirstList] | OtherLists]).
addElement(Element, [FirstList | OtherLists], [ FirstList | Temp] ):- 
    addElement(Element, OtherLists, Temp).

partition([Single], [[Single]]).
partition([First|Others], [[First] | Result]) :-
    partition(Others, Result).
partition([First|Others], Result) :-
    partition(Others, Temp),
    addElement(First, Temp, Result).

bell_numbers(N):-
    \+ N == 0,  
    N < 10,
    length(L0, N), 
    setof(P, partition(L0, P), Partitions), 
    length(Partitions, L),
    write('B_'), write(N), write(': '), write(L), nl,
    N0 is N + 1, 
    bell_numbers(N0).   
bell_numbers(N):-
    N == 0,
    write('B_'), write(N), write(': '), write(1), nl,
    N0 is N + 1,
    bell_numbers(N0).     
bell_numbers(_).   

main:-
    bell_numbers(0), 
    halt.    

Sample Run

$ gplc ch-2.p 
$ prolog/ch-2
B_0: 1
B_1: 1
B_2: 2
B_3: 5
B_4: 15
B_5: 52
B_6: 203
B_7: 877
B_8: 4140
B_9: 21147

Notes

This code uses a known Prolog idiom for computing partitions of the list for each Bell Number. It is, of course, possible to simply compute these using a closed form approach as I did for the Perl solution for this same problem. Since this is Prolog I figured this method may be a bit more fun!

Since we don’t really care about what is in the list, only that the elements be unique to allow for proper partitioning, that a list of uninstantiated variables works just fine.

And yeah, probably I should have started computing the numbers with 10 instead of 0 and used format/2 instead of a bunch of write/1s, but this code was just a quick bit of fun.

References

Challenge 108

Bell Numbers

Bell Triangle

The examples used here are from the weekly challenge problem statement and demonstrate the working solution. Also, the challenge statements are given in a Perl context although for Prolog solutions some adjustments are made to account for the differing semantics between the two languages.

Part 1

You are given a positive integer $N. Write a script to generate all Rare Numbers of size $N if any exist.

Solution

:-initialization(main).

perfect_square(N):-
    A is floor(sqrt(N)), 
    N is A * A.

rare(N, N, Rares, Rares). 
rare(Lower, Upper, RareAccum, Rares):-
    number_codes(Lower, C),
    reverse(C, CR), 
    number_codes(R1, CR),
    X0 is Lower + R1,
    X1 is Lower - R1,
    perfect_square(X0),
    perfect_square(X1),
    Next is Lower + 1,
    rare(Next, Upper, [Lower|RareAccum], Rares).
rare(Lower, Upper, RareAccum, Rares):-
    Next is Lower + 1,
    rare(Next, Upper, RareAccum, Rares).

rare_numbers(N, Rares):-
    Lower is 10 ^ (N - 1),   
    Upper is (10 ^ N) - 1,
    rare(Lower, Upper, [], Rares). 

main:-
    rare_numbers(2, Rares2),
    write(Rares2), nl, 
    rare_numbers(6, Rares6),
    write(Rares6), nl, 
    rare_numbers(9, Rares9),
    write(Rares9), nl,
    halt.

Sample Run

$ gplc prolog/ch-1.p
$ prolog/ch-1
[65]
[621770]
[281089082]

Notes

This is maybe straightforward bit of Prolog with arithmetic. One might say that I missed an opportunity to use between/3 but, in fact, I was happy to terminate the recursion of rare/4 by identifying the case where the first two arguments (Lower and Upper) are equal.

Part 2

You are given a positive integer $N. Write a script to produce hash counting string of that length.

Solution

:-initialization(main).

hcs(0, String, String).
hcs(1, StringAccum, String):-
    hcs(0, [35|StringAccum], String). 
hcs(N, StringAccum, String):-
    number_codes(N, C),
    append(C, "#", Accum), 
    length(Accum, L),
    N0 is N - L, 
    append(Accum, StringAccum, StringAccum0), 
    hcs(N0, StringAccum0, String). 

hash_counting_string(N, String):-
    hcs(N, [], S),
    atom_codes(String, S).

main:-
    hash_counting_string(1, String1), 
    write(String1), nl,
    hash_counting_string(2, String2), 
    write(String2), nl, 
    hash_counting_string(3, String3), 
    write(String3), nl, 
    hash_counting_string(10, String10), 
    write(String10), nl, 
    hash_counting_string(14, String14), 
    write(String14), nl,
    halt.

Sample Run

$ gplc ch-2.p 
$ prolog/ch-2
#
2#
#3#
#3#5#7#10#
2#4#6#8#11#14#

Notes

As mentioned elsewhere I first wrote a solution to this in Perl. This code, follows pretty directly from that, a clean bit of recursion. Probably we should prefer a more prological piece of code versus this which is more …what should we call it…procursive? That is, recursive fairly functional style code which does not make much use of the power of Prolog backtracking.

Time is running out to submit solutions for Weekly Challenge 102, but I can imagine a solution which uses DCGs perhaps? The hash counting string being assembled by processing a list of success numbers which in turn generate the appropriate characters. I’ll update this article if I get a chance.

References

Challenge 102 Rare Numbers

The examples used here are from the weekly challenge problem statement and demonstrate the working solution. Also, the challenge statements are given in a Perl context although for Prolog solutions some adjustments are made to account for the differing semantics between the two languages.

Part 1

You are given a time (12 hour / 24 hour). Write a one-liner to convert the given time from 12 hour format to 24 hour format and vice versa.

Solution

:-initialization(main).

hour_to_12(H12, H24):-
    append(H, [58|R], H24), 
    number_codes(N0, H),
    N is N0 - 12,
    number_codes(N, C0),
    flatten([C0, 58, R], C),  
    atom_codes(A, C), 
    H12 = A. 

hour_to_24(H12, H24):-
    append(H, [58|R], H12), 
    number_codes(N0, H),
    N is N0 + 12,
    number_codes(N, C0),
    flatten([C0, 58, R], C),  
    atom_codes(A, C), 
    H24 = A. 

twenty_four_hour(H12, H24):-
    nonvar(H12),
    hour_to_24(H12, H24). 
twenty_four_hour(H12, H24):-
    nonvar(H24),
    hour_to_12(H12, H24). 

main:-
    twenty_four_hour("05:15 pm", HOUR_24),
    write(HOUR_24), nl,
    twenty_four_hour(HOUR_12, "17:15 pm"),
    write(HOUR_12), nl,
    halt. 

Sample Run

$ gplc ch-1.p
$ ch-1
17:15 pm
5:15 pm

Notes

Keep in mind that any two points determine a line. Therefore to consider all possible non-trivial lines we need to review all triples of points.

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

Part 2

You are given triangle array. Write a script to find the minimum path sum from top to bottom. When you are on index i on the current row then you may move to either index i or index i + 1 on the next row.

Solution

:-initialization(main).

minimum_sum(Triangle, Sum):-
    minimum_sum(Triangle, 1, 0, Sum).  
minimum_sum([H|[]], Index, PartialSum, Sum):-
    nth(Index, H, N),
    Sum is PartialSum + N.  
minimum_sum([H0, H1|T], Index, PartialSum, Sum):-
    nth(Index, H0, N0),
    PartialSum0 is PartialSum + N0,
    I0 is Index + 1, 
    nth(I0, H1, N1),
    nth(Index, H1, N2),
    N1 > N2,
    minimum_sum([H1|T], Index, PartialSum0, Sum). 
minimum_sum([H0, H1|T], Index, PartialSum, Sum):-
    nth(Index, H0, N0),
    PartialSum0 is PartialSum + N0,
    I0 is Index + 1, 
    nth(I0, H1, N1),
    nth(Index, H1, N2),
    N1 =< N2,
    minimum_sum([H1|T], I0, PartialSum0, Sum). 

main:-
    minimum_sum([[1], [2, 4], [6, 4, 9], [5, 1, 7, 2]], Sum0),  
    write(Sum0), nl, 
    minimum_sum([[3], [3, 1], [5, 2, 3], [4, 3, 1, 3]], Sum1), 
    write(Sum1), nl, 
    halt.  

Sample Run

$ gplc ch-2.p 
$ prolog/ch-2
8
7

Notes

This code is more functional than logical. Code is not written in a vacuum! The night before working this problem I was reading about Functional Programming in Java and it seems to have slightly warped my brain. Well, or at least I decided it would be fun to do things this way.

A more idiomatically Prolog solution would surely make use of Constraint Programming and just solve the more general case without the triangle restriction.

References

Challenge 100

The examples used here are from the weekly challenge problem statement and demonstrate the working solution. Also, the challenge statements are given in a Perl context although for Prolog solutions some adjustments are made to account for the differing semantics between the two languages.

Part 1

You are given file $FILE. Create subroutine readN($FILE, $number) returns the first n-characters and moves the pointer to the (n+1)th character.

Solution

:-dynamic(position/1).
:-initialization(main).

position(0).

read_n_chars(Stream, N, Chars):-
    read_n_chars(Stream, N, [], Chars).
read_n_chars(_, 0, ByteAccum, Chars):-
    atom_codes(Chars, ByteAccum).    
read_n_chars(Stream, N, ByteAccum, Chars):-
    \+ at_end_of_stream(Stream),
    get_byte(Stream, C),
    N0 is N - 1,
    append(ByteAccum, [C], ByteAccum0),
    read_n_chars(Stream, N0, ByteAccum0, Chars).
read_n_chars(Stream, _, ByteAccum, Chars):-
    at_end_of_stream(Stream),
    read_n_chars(Stream, 0, ByteAccum, Chars).
    
read_n(File, N, Chars):-
    open(File, read, Stream,[type(binary),reposition(true)]),
    position(Position),
    seek(Stream, bof, Position, _),
    read_n_chars(Stream, N, Chars),
    X is N + Position,
    retract(position(Position)),
    asserta(position(X)),
    close(Stream).
    
main:-
    read_n('../ch-1.dat', 4, Chars0),
    write(Chars0), nl,
    read_n('../ch-1.dat', 4, Chars1),
    write(Chars1), nl,
    read_n('../ch-1.dat', 4, Chars2),
    write(Chars2), nl,
    halt.

Sample Run

$ gplc ch-1.p
$ ./ch-1
1234
5678
90

Notes

Clearly given the semantics of Prolog we need to adjust the challenge specification slightly. For the Prolog version we’ll write a predicate read_n/3 which will instantiate the third argument each time it is called in the way described, resuming the file reads after the last read position. Because we want to initialize the position to 0 to start and then update with retract/1 and asserta/1 we use the dynamic/1 specification to allow for this. If not specified dynamic we’d see an error such as system_error(cannot_catch_throw(error(permission_error(modify,static_procedure,position/1),retract/1))) when trying to make alterations.

The last read position is stored as a Prolog fact after each read. Each read_n/3 call will use that last position to do a seek/4 and then read in the characters. While some Prologs will allow seeking within text files Gnu Prolog disallows this. This is easily worked around, however, by opening the file in binary mode, reading in the characters using get_byte/2 and then using atom_codes/2 to convert. To make this work we need to specify Options of [type(binary),reposition(true)] to open/4.

Part 2

You are given a sorted array of distinct integers @N and a target `$N``. Write a script to return the index of the given target if found otherwise place the target in the sorted array and return the index.

Solution

:-initialization(main).

needle_haystack([H|T], N, Index):-
    ((N < H, Index is 0); 
       (last(T, Last), N > Last, 
       length([H|T], Length), Index is Length)).
needle_haystack([H|T], N, Index):-
    needle_haystack([H|T], N, 0, Index).
needle_haystack([], _, Index, Index).    
needle_haystack([_|[]], _, Index, Index).
needle_haystack([H0, _|_], N, Counter, Index):-
    H0 == N,
    Index is Counter.
needle_haystack([_, H1|_], N, Counter, Index):-
    H1 == N,
    Index is Counter + 1.
needle_haystack([H0, H1|T], N, Counter, Index):-
    H0 \== N,
    H1 \== N,
    \+ between(H0, H1, N),
    C is Counter + 2,
    needle_haystack(T, N, C, Index).
needle_haystack([H0, H1|_], N, Counter, Index):-
    H0 \== N,
    H1 \== N,
    between(H0, H1, N),
    Index is Counter + 1.
            
main:-
    needle_haystack([1, 2, 3, 4], 3, Index0),
    write(Index0), nl,
    needle_haystack([1, 3, 5, 7], 6, Index1),
    write(Index1), nl,
    needle_haystack([12, 14, 16, 18], 10, Index2),
    write(Index2), nl,
    needle_haystack([11, 13, 15, 17], 19, Index3),
    write(Index3), nl,
    halt.

Sample Run

$ gplc prolog/ch-2.p
$ ./ch-2
2
3
0
4

Notes

This is a somewhat convoluted sounding problem at first but it actually ends up being straight forward to solve, albeit slightly tedious. The code is largely an examination of the possible cases where N may be. If it would occur before the head of the list or after the last element we are done immediately. Otherwise we evaluate the list in search of N, returning the index if we find it. If we find two successive elements in which N would be between, but is not in the list, we have identified the point in which N would be inserted.

While the challenge statement indicates N should be inserted we only really seem to care about the index and so I don’t actually provide an updated list. To do so we could add an additional argument to needle_haystack/3 which would be instantiated to an updated list.

References

Challenge 098

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

Part 1

You are given string $S containing alphabets A..Z only and a number $N. Write a script to encrypt the given string $S using Caesar Cipher with left shift of size $N.

Solution

:-initialization(main).

caesar([], [], _).
caesar([H|T], [C|Cypher], N):-
    C is H - N,
    C >= 65,
    caesar(T, Cypher, N).
caesar([H|T], [C|Cypher], N):-
    C0 is H - N,
    C0 < 65,
    C is C0 + 26,
    caesar(T, Cypher, N).

main:-
    caesar("ABCDEFGHIJKLMNOPQRSTUVWXYZ", C, 3),
    atom_codes(CypherText, C),
    write(CypherText), nl,
    halt.

Sample Run

$ gplc ch-1.p
$ ./ch-1
XYZABCDEFGHIJKLMNOPQRSTUVW

Part 2

You are given a binary string $B and an integer $S. Write a script to split the binary string $B of size $S and then find the minimum number of flips required to make it all the same.

Solution

:-initialization(main).

substrings(BinaryString, N, SubStrings):-
    substrings(BinaryString, N, [], SubStrings).
substrings([], _, SubStrings, SubStrings).    
substrings(BinaryString, N, SubStringAccum, SubStrings):-
    length(L, N),
    append(L, X, BinaryString),
    substrings(X, N, [L|SubStringAccum], SubStrings).

count_flips(B, [H|T], Flips):-
    count_flips(B, [H|T], 0, Flips).
count_flips(_, [], Flips, Flips).    
count_flips(B, [H|T], FlipsSum, Flips):-
    number_codes(B0, B),
    number_codes(H0, H),
    X is xor(B0, H0),
    Flips0 is X + FlipsSum,
    count_flips(B, T, Flips0, Flips).
    
min_flips(SubStrings, MinFlips):-
    min_flips(SubStrings, [], Flips),
    sort(Flips,[MinFlips|_]).
min_flips([_], Flips, Flips).    
min_flips([H|T], FlipsAccum, Flips):-
    count_flips(H, T, Flips0),
    min_flips(T, [Flips0|FlipsAccum], Flips).

main:-
    substrings("101100101", 3, SubStrings),
    min_flips(SubStrings, Flips),
    write(Flips),nl,
    halt.

Sample Run

$ gplc prolog/ch-2.p
$ ./ch-2
1

References

xor

Palindromic Numbers

Suppose we are asked the following, as was the case for The Weekly Challenge 095.

Write a script to figure out if the given number is Palindrome. Print 1 if true otherwise 0.

Here is my original solution to this.

Solution

:-initialization(main).

palindrome_even([]).  
palindrome_even([H|T]):-
    last(T, Last), 
    H == Last, 
    append(L, [Last], T), 
    palindrome_even(L).   

palindrome_odd([_|[]]).  
palindrome_odd([H|T]):-
    last(T, Last), 
    H == Last, 
    append(L, [Last], T), 
    palindrome_odd(L).   

palindrome(N):-
    N > 0, 
    number_chars(N, C), 
    length(C, Length), 
    M is Length mod 2,
    M == 0,
    palindrome_even(C).   
palindrome(N):-
    N > 0, 
    number_chars(N, C), 
    length(C, Length), 
    M is Length mod 2,
    M == 1,
    palindrome_odd(C).  

is_palindrome(N):-
    palindrome(N),
    write(1), nl.
is_palindrome(N):-
    \+ palindrome(N),
    write(0), nl.

main:-
    is_palindrome(1221),
    is_palindrome(-101),
    is_palindrome(90),
    halt.  

Sample Run

$ gplc prolog/ch-1.p
$ prolog/ch-1
1
0
0

Notes

I wrote a short description of this code before.

To repeat a little here: this is a Prolog version of Perl code I wrote for the same problem. The basic approach is roughly the same as the Perl implementation: starting at both ends of the number work inwards comparing one pair of digits at a time. Here we define all negative numbers as being non-palindromic due to the inherent asymmetry of the ‘-’.

It is slightly odd in Prolog to print out a 0 or 1 as asked in this problem statement. In languages like Perl doing so is really just as simple as printing out a boolean value returned from some comparison or function call. Although odd it is not unheard of, however, and the best advice I have seen on the matter is to define a small predicate to wrap the predicate(s) doing the real work and print whatever is needed. That job here is done by is_palindrome/1.

Let’s ignore is_palindrome/1, though, and consider something else.

This code works fine, as is shown, but it is unsatisfying from the perspective in that it only works one way. If we have defined the validation of palindromic numbers correctly then in fact Prolog should also be able to generate palindromic numbers as well! That is,
a bimodal predicate that used in one mode will validate palindromic numbers and in another mode create them.

Trying the existing code out with an uninstantiated variable this is the result

?- palindrome(N).
uncaught exception: error(instantiation_error,(>)/2)

Of course it does not take a Prolog genius to see pretty quickly why this does not work. A couple of things that jump out right away:

• We are assuming that palindrome/1 is being given a valid integer
• N > 0 requires an instantiated number variable N, as shown in the error message.
• The list of digits we evaluate to be a palindrome is created by number_chars/2 which, for our purposes, also requires an instantiated number variable.

To adjust this code to work both ways need to handle whether N is in fact instantiated or not. But here we need to be careful, we need to create one in such a way that when a non-palindromic number is created a new one is created upon backtracking. We want to be as general as possible.

Also, we already have two instances of palindrome/1 predicates to handle the two cases of even/odd number of digits. Let’s take care to not write more code than necessary when modifying this code.

So, taking all this into account, what is to be done? Well, it turns out we can make this code work both ways by adding adding two lines (and removing 1 existing line) from palindrome/1.

The changes are:

• Check to see if N is between 1 and the largest possible integer available using between/3. Here I am using Gnu Prolog on a 32-bit platform (NetBSD/macppc) and this value is 268435455.
• When the third argument to between/3 is uninstantiated it will be instantiated to be an integer in the range given by the first two arguments.
• The check if N is positive is no longer necessary and can be removed.

The updated code looks like this.

palindrome(N):-
    current_prolog_flag(max_integer, MAX_INTEGER),
    between(1, MAX_INTEGER, N),
    number_chars(N, C), 
    length(C, Length), 
    M is Length mod 2,
    M == 0,
    palindrome_even(C).   

From the Gnu Prolog top level we can see this in action. The output is truncated to just show some of the solutions generated upon backtracking.

| ?- palindrome(1200021).

true ? 

yes
| ?- palindrome(X).      

X = 11 ? ;

X = 22 ? ;
    .
    .
    .

How many palindromic numbers are there between 1 and MAX_INTEGER?

| ?- findall(X, palindrome(X), Xs), length(Xs, L).
L = 36842.

36842 palindromic numbers is about 0.01% of all integers in this range.

The full code for this is below. I’ve left the main/0 predicate alone as it demonstrates what was necessary for the original problem. Output showing the bimodal functionality was run in the Gnu Prolog top level. If this code interests you the palindrome/1 predicate can be used directly as shown.

:-initialization(main).

palindrome_even([]).  
palindrome_even([H|T]):-
    last(T, Last), 
    H == Last, 
    append(L, [Last], T), 
    palindrome_even(L).   

palindrome_odd([_|[]]).  
palindrome_odd([H|T]):-
    last(T, Last), 
    H == Last, 
    append(L, [Last], T), 
    palindrome_odd(L).   

palindrome(N):-
    current_prolog_flag(max_integer, MAX_INTEGER),
    between(1, MAX_INTEGER, N),
    number_chars(N, C), 
    length(C, Length), 
    M is Length mod 2,
    M == 0,
    palindrome_even(C).   
palindrome(N):-
    current_prolog_flag(max_integer, MAX_INTEGER),
    between(1, MAX_INTEGER, N),
    number_chars(N, C), 
    length(C, Length), 
    M is Length mod 2,
    M == 1,
    palindrome_odd(C).  

is_palindrome(N):-
    palindrome(N),
    write(1), nl.
is_palindrome(N):-
    \+ palindrome(N),
    write(0), nl.

main:-
    is_palindrome(1221),
    is_palindrome(-101),
    is_palindrome(90).      

References

Challenge 095

Previous work on the same problem

Gnu Prolog

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

Part 1

Write a script to figure out if the given number is Palindrome. Print 1 if true otherwise 0.

Solution

:-initialization(main).

palindrome_even([]).  
palindrome_even([H|T]):-
    last(T, Last), 
    H == Last, 
    append(L, [Last], T), 
    palindrome_even(L).   

palindrome_odd([_|[]]).  
palindrome_odd([H|T]):-
    last(T, Last), 
    H == Last, 
    append(L, [Last], T), 
    palindrome_odd(L).   

palindrome(N):-
    N > 0, 
    number_chars(N, C), 
    length(C, Length), 
    M is Length mod 2,
    M == 0,
    palindrome_even(C).   
palindrome(N):-
    N > 0, 
    number_chars(N, C), 
    length(C, Length), 
    M is Length mod 2,
    M == 1,
    palindrome_odd(C).  

is_palindrome(N):-
    palindrome(N),
    write(1), nl.
is_palindrome(N):-
    \+ palindrome(N),
    write(0), nl.

main:-
    is_palindrome(1221),
    is_palindrome(-101),
    is_palindrome(90),
    halt.  

Sample Run

$ gplc prolog/ch-1.p
$ prolog/ch-1
1
0
0

Notes

This is a Prolog version of Perl code I wrote for the same problem. The basic approach is roughly the same as the Perl implementation: starting at both ends of the number work inwards comparing one pair of digits at a time. Here we define all negative numbers as being non-palindromic due to the inherent asymmetry of the ‘-’.

It is slightly odd in Prolog to print out a 0 or 1 as asked in this problem statement. In languages like Perl doing so is really just as simple as printing out a boolean value returned from some comparison or function call. Although odd it is not unheard of, however, and the best advice I have seen on the matter is to define a small predicate to wrap the predicate(s) doing the real work and print whatever is needed. That job here is done by is_palindrome/1

Part 2

Demonstrate Stack operations.

Solution

:-initialization(main).

new_stack([]).

push(Stack, Value, [Value|Stack]).

pop([H|T], H, T).

top([H|_], H).

min(Stack, Min):-
    min_list(Stack, Min).

main:-
    new_stack(Stack),
    push(Stack, 2, NewStack0),
    push(NewStack0, -1, NewStack1),
    push(NewStack1, 0, NewStack2),
    pop(NewStack2, Top0, NewStack3),
    write(Top0), nl,
    top(NewStack3, Top1),
    write(Top1), nl,
    push(NewStack3, 0, NewStack4),
    min(NewStack4, Min),
    write(Min), nl,
    halt.

Sample Run

$ gplc prolog/ch-2.p
$ prolog/ch-2
0
-1
-1

Notes

Just writing this code made me feel like I was committing a crime against Prolog! Implementing this sort of data structure in Prolog is really just writing some small predicates which wrap otherwise ordinary list operations. Then again, implementing Stacks in Prolog is not entirely unheard of. This sort of thing is done as an exercise when studying data structures. The excellent text by Luger and Stubblefield describes a Stack implementation, among other Abstract Data Types, in Prolog.

References

Challenge 095

AI Algorithms, Data Structures, and Idioms in Prolog, Lisp, and Java

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

Part 1

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

Solution

:-initialization(main).

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

chars_product([], 1).
chars_product([H|T], Product):-
    letter_factor(H, Factor),
    chars_product(T, Product0), 
    Product is Factor * Product0.  

word_product(Word, Product):-
    atom_chars(Word, Chars),
    chars_product(Chars, Product).  

organize([]):-
    findall(Words, bagof(Word, word_product(Word-_), Words), WordsList),
    write(WordsList). 
organize([H|T]):-
    word_product(H, P),
    assertz(word_product(H-P)),
    organize(T). 

main:-
    Anagrams = [opt, bat, saw, tab, pot, top, was],
    organize(Anagrams), nl,
    halt.

Sample Run

$ gplc ch-1.p
$ ./ch-1
[[bat,tab],[opt,pot,top],[saw,was]]

Notes

This is a Prolog version of Perl code I wrote for the same problem. In translating the approach of using the Fundamental Theorem of Arithmetic I tried to make sure the result was idiomatic Prolog as much as I could. I think I pulled that off!?!? In Prolog there is sometimes an over temptation to end up writing a bunch of mostly functional code. That is, code that could just as easily be written in, say, Haskell or ML. The organize/1 predicate is pretty much that sort of functional code but it is very short and wraps Prolog concepts such as assertz/1, findall/3, and bagof/3.

• I am using the same mathematical trick that I have used for anagrams in the past, starting with Challenge 005. The By the Fundamental Theorem of Arithmetic every integer greater than 1 is either a prime number itself or can be represented as the unique product of prime numbers. We use that to our advantage by having a prime number associated with each letter. Each word is a product of these numbers and words with the same product are anagrams.

• In this way we assert/1 Word-Product pairs for all the given anagrams and once done use findall/3 with bagof/3 to collect the solutions for printing as desired. This method of collecting solutions is given a nice description here.

• The choice of letters and prime numbers is based on the Lewand Ordering and it isn’t at all necessary (it stems from an early, unnecessary, design decision) but it does little harm so I left it in anyway.

Part 2

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

Solution

:-initialization(main).
 
dfs(Node, Graph, [Node|Path]):- 
    dfs(Node, Graph, Path, []).
dfs(_, _, [], _).
dfs(Node, Graph, [AdjNode|Path], Seen) :-
    member(r(Node, Adjacent), Graph),
    member(AdjNode, Adjacent),
    \+ memberchk(AdjNode, Seen),
    dfs(AdjNode, Graph, Path, [Node|Seen]).

unseen_nodes(Nodes, NodeList, Unseen):-
    unseen_nodes(Nodes, NodeList, [], Unseen).
unseen_nodes([], _, Unseen, Unseen).
unseen_nodes([H|T], NodeList, UnseenAccum, Unseen):- 
    \+ memberchk(H, NodeList),
    unseen_nodes(T, NodeList, [H|UnseenAccum], Unseen).  
unseen_nodes([H|T], NodeList, UnseenAccum, Unseen):-
    memberchk(H, NodeList),
    unseen_nodes(T, NodeList, UnseenAccum, Unseen).  

paths_list(Paths, List):-
    paths_list(Paths, [], List).
paths_list([], List, List).
paths_list([H|T], ListAccum, List):-
    unseen_nodes(H, ListAccum, Unseen),
    append(ListAccum, Unseen, ListAccum0), 
    paths_list(T, ListAccum0, List).    

print_list([H|[]]):-
    format("~d~n", [H]).  
print_list([H|T]):-
    format("~d -> ", [H]),   
    print_list(T).

main:-
    findall(Path, dfs(1,[r(1,[2]),r(1,[3]),r(2,[4,5]),r(5,[6,7])], Path), Paths),
    paths_list(Paths, List),  
    print_list(List), halt.

Sample Run

$ gplc ch-2.p
-bash-5.0$ ./ch-2
1 -> 2 -> 4 -> 5 -> 6 -> 7 -> 3

Notes

• Some of this code is re-used from last week

• The idea of a (singly) Linked List in Prolog is fundamental. We might consider any ordinary list in this way since Prolog allows direct access to the head and tail of
  lists. This solution, therefore ends up being simpler than even the Perl solution to the same problem.

• The code above simply does a DFS of the given tree and then adds new nodes to a list in the order in which they are seen.

References

Challenge 094

Fundamental Theorem of Arithmetic

Lewand Ordering

Part 1

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

Solution

:-initialization(main).

triangle_area(Points, Area):-
    [[X1, Y1], [X2, Y2], [X3, Y3]] = Points,
    Area is (X1 * (Y2 - Y3)) + (X2 * (Y3 - Y1)) + (X3 * (Y1 - Y2)).

collinear_points(Points, CollinearPoints):-
    member(A, Points),
    member(B, Points),
    member(C, Points),
    A \== B, A \== C, B \== C,
    triangle_area([A, B, C], Area),
    Area == 0,
    CollinearPoints = [A, B, C].

main:-
    N = [[5,3], [1,1], [2,2], [3,1], [1,3]],
    collinear_points(N, CollinearPoints),
    write(CollinearPoints), nl,
    halt.

Sample Run

$ gplc ch-1.p
$ ch-1
[[2,2],[3,1],[1,3]]

Notes

Keep in mind that any two points determine a line. Therefore to consider all possible non-trivial lines we need to review all triples of points.

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

Part 2

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

Solution

:-initialization(main).
 
dfs(Node, Graph, [Node|Path]):- 
    dfs(Node, Graph, Path, []).
dfs(_, _, [], _).
dfs(Node, Graph, [AdjNode|Path], Seen) :-
    member(r(Node, Adjacent), Graph),
    member(AdjNode, Adjacent),
    \+ memberchk(AdjNode, Seen),
    dfs(AdjNode, Graph, Path, [Node|Seen]).

sum_paths(Paths, Sum):-
    sum_paths(Paths, 0, Sum).
sum_paths([], Sum, Sum).
sum_paths([H|T], PartialSum, Sum):-
    sum_list(H, ListSum),
    S is PartialSum + ListSum,
    sum_paths(T, S, Sum).

path_lengths([], _).
path_lengths([H|T], [L|Lengths]):-
    length(H, L),
    path_lengths(T, Lengths).

partial_path(_, _, []). 
partial_path(Path, MaxPathLength, [H|T]):-
    length(Path, PathLength),
    length(H, HLength),
    (PathLength < MaxPathLength ; (subtract(Path, H, Remaining), length(Remaining, 0))),
    partial_path(Path, MaxPathLength, T).
partial_path(Path, MaxPathLength, [H|_]):-
    length(Path, PathLength),
    length(H, HLength),
    PathLength =< MaxPathLength,
    subtract(Path, H, Remaining),
    \+ length(Remaining, 0),
    fail.
    
complete_paths(Paths, CompletePaths):-
    path_lengths(Paths, PathLengths),
    max_list(PathLengths, MaxPathLength),
    complete_paths(Paths, Paths, MaxPathLength, [], CompletePaths).
complete_paths([], _, _, CompletePaths, CompletePaths).    
complete_paths([H|T], Paths, MaxPathLength, CompletePathsAccum, CompletePaths):-
    \+ partial_path(H, MaxPathLength, Paths),
    complete_paths(T, Paths, MaxPathLength, [H|CompletePathsAccum], CompletePaths).   
complete_paths([H|T], Paths, MaxPathLength, CompletePathsAccum, CompletePaths):-
    partial_path(H, MaxPathLength, Paths),
    complete_paths(T, Paths, MaxPathLength, CompletePathsAccum, CompletePaths). 
    
main:-
   findall(Path0, dfs(1,[r(1,[2]),r(2,[3,4])], Path0), Paths0),
   complete_paths(Paths0, CompletePaths0),
   sum_paths(CompletePaths0, Paths0Sum),
   write(Paths0Sum), nl,
   findall(Path1, dfs(1,[r(1,[2,3]), r(3,[5,6]), r(2,[4])], Path1), Paths1),
   complete_paths(Paths1, CompletePaths1),
   sum_paths(CompletePaths1, Paths1Sum),
   write(Paths1Sum), nl, halt.

Sample Run

$ gplc ch-2.p 
$ prolog/ch-2
13
26

Notes

The depth first search is pretty idiomatic Prolog and the dfs/3 code was something I grabbed from SO (see references). That code is straightforward enough, it finds all paths in a depth first manner. We are only concerned with the complete root to leaf paths and so a bit of effort goes into filtering out the partial paths. Once that is done the paths are summed and we are done.

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

References

Challenge 093

Collinear Points

Find all possible paths w/o loops in Graph in Prolog

AoC 2020 in Prolog

I had never heard of Advent Of Code before this year although it seems to have been around for six years running now! On Twitter I noticed some related posts about a week into this year’s event. After checking out what this was all about I decided this would be a fun way to continue honing my Prolog skills. I have been making a serious attempt to master Prolog and part of that has been doing a variety of programming challenges to get experience with different capabilities and nuances of the language.

Between the late start, wrapping up work projects before the end of year, and personal tasks related to the upcoming holidays (such as they will be this year) I got about halfway through the tasks. Now that I am aware that this event exists I’ll make sure to start off on day one next year!

Below are links to my solutions. The problem statements are all fairly lengthy so refer to the AoC 2020 website for details on what these are supposed to be doing.

2020 Advent of Code Day 1

2020 Advent of Code Day 2

2020 Advent of Code Day 3

2020 Advent of Code Day 4

2020 Advent of Code Day 5

2020 Advent of Code Day 6

2020 Advent of Code Day 7

2020 Advent of Code Day 8

2020 Advent of Code Day 9

2020 Advent of Code Day 10

• The solution to Part 2 should finish running sometime in late 2021. My initial approach was to create a tree of all possible adapters and then just count the leaves. It runs in just milliseconds for test cases but for the data set given … Yikes! … the run time will be very long. This is what happens when you write code too late at night! After sleeping on it I realized that something along the lines of using memoization to count and sum all the branches of the adapter tree should run reasonably quickly. However, I was using a slightly older version of SWI-Prolog that seemed to have an incomplete tabling implementation so I had to upgrade, which is easy enough I suppose, but after doing so I just decided to move on to Day 11 since I already had a late start as it was.

2020 Advent of Code Day 11 (Part 1)

2020 Advent of Code Day 11 (Part 2)

2020 Advent of Code Day 12 (Part 1)

2020 Advent of Code Day 12 (Part 2)

Notes

I kept the solutions about as “vanilla” (i.e. no libraries) as can be. As a result all the solutions have some boilerplate code for reading and preparing the input data. Each of the solutions are otherwise fairly compact, a testament to the power of Prolog.

References

Advent of Code 2020

Part 1

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

Solution

:- initialization(main).

nucleotide_pair('A', 'T').
nucleotide_pair('C', 'G').

compliment([H|T], [Compliment|RestOfCompliment]):-
    var(Compliment), 
    atom_chars(A, [H]),  
    (nucleotide_pair(A, X); nucleotide_pair(X, A)),    
    atom_chars(X, [Compliment]),  
    compliment(T, RestOfCompliment).  
compliment([H|T], [Compliment|RestOfCompliment]):-
    (nucleotide_pair(A, Compliment); nucleotide_pair(Compliment, A)),    
    atom_chars(A, [H]),  
    compliment(T, RestOfCompliment).  
compliment([], _). 
compliment(_, []). 

main:-
    Sequence = 'GTAAACCCCTTTTCATTTAGACAGATCGACTCCTTATCCATTCTCAGAGATGTGTTGCTGGTCGCCG',
    atom_chars(Sequence, SequenceChars),
    length(SequenceChars, SequenceLength),
    format("Sequence length is ~d.~n", [SequenceLength]),
    length(Compliment, SequenceLength), 
    compliment(SequenceChars, Compliment),
    atom_chars(ACompliment, Compliment),
    compliment(OriginalSequence, Compliment),
    atom_chars(AOriginalSequence, OriginalSequence),
    format("Original sequence is ~a.~n", [AOriginalSequence]),
    format("Complimentary sequence is ~a.~n", [ACompliment]),
    halt.  

Sample Run

$ gplc ch-1.p
$ ch-1  
Sequence length is 67.
Original sequence is GTAAACCCCTTTTCATTTAGACAGATCGACTCCTTATCCATTCTCAGAGATGTGTTGCTGGTCGCCG.
Complimentary sequence is CATTTGGGGAAAAGTAAATCTGTCTAGCTGAGGAATAGGTAAGAGTCTCTACACAACGACCAGCGGC.

Notes

• The predicate compliment/2 will work with either of the arguments instantiated. In other words it is a bimodal predicate.This is maybe a little silly in this case in particular because of the nature of the mappings between base pairs it is not necessary. Still, getting predicates to be bimodal requires some care and skill and I thought I’d take a crack at it here.
• I am using Gnu Prolog here. gplc is the Gnu Prolog compiler. I love how it compiles Prolog to a single native executable. Beautiful!

Part 2

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

Solution

:- initialization(main).

ethiopean_multiplication(Operands, Product):-
    ethiopean_multiplication(Operands, [], Product).
ethiopean_multiplication([1, _], IntermediateTerms, Product):-
    sum_list(IntermediateTerms, Product).
ethiopean_multiplication(Operands, IntermediateTerms, Product):-
    [A0, B0] = Operands,
    A is A0 div 2,
    B is B0 * 2,
    M is A mod 2,
    M == 1,
    ethiopean_multiplication([A, B], [B|IntermediateTerms], Product).
ethiopean_multiplication(Operands, IntermediateTerms, Product):-
    [A0, B0] = Operands,
    A is A0 div 2,
    B is B0 * 2,
    M is A mod 2,
    M == 0,
    ethiopean_multiplication([A, B], IntermediateTerms, Product).

main:-
    [A, B] = [14, 12],
    ethiopean_multiplication([A, B], Product),
    format("Product of ~d x ~d (via Ethiopean Multiplication) is ~d.~n", [A, B, Product]),
    halt. 

Sample Run

$ gplc ch-2.p 
$ ch-2
Product of 14 x 12 (via Ethiopean Multiplication) is 168.

Notes

I think this is a fairly straightforward recursive Prolog solution. At each recursive step the two elements are either halved or doubled until the base step is hit and then the accumulated terms (the even elements from only the odd/even pairs) are summed.

References

Ethiopian Multiplication

Part 1

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

Solution

range_list(0, [0]).
range_list(N, List):-
    range_list(N, [], List).
range_list(0, List, List).
range_list(N, ListAccum, List):-
    N0 is N - 1,
    range_list(N0, [N|ListAccum], List).

unique_pairs(List, Pairs):-
    unique_pairs(List, List, [], Pairs).

unique_pairs([], [], Pairs, Pairs).
unique_pairs([_|T0], [], PairsAccum, Pairs):-
   unique_pairs(T0, T0, PairsAccum, Pairs).
unique_pairs([H0|T0], [H1|T1], PairsAccum, Pairs):-
   \+ member([H0, H1], PairsAccum),
   \+ member([H1, H0], PairsAccum),
   H0 \= H1,
   unique_pairs([H0|T0], T1, [[H0, H1]|PairsAccum], Pairs).
unique_pairs([H0|T0], [_|T1], PairsAccum, Pairs):-
   unique_pairs([H0|T0], T1, PairsAccum, Pairs).

write_gcd_pairs(Pairs):-
    write_gcd_pairs(Pairs, 0).
write_gcd_pairs([[I,J]|[]], Sum):-
    Sum0 is Sum + gcd(I, J),
    format("gcd(~d, ~d) = ~d ~n", [I, J, Sum0]).
write_gcd_pairs([[I,J]|T], Sum):-
    format("gcd(~d, ~d) + ", [I, J]),
    Sum0 is Sum + gcd(I, J),
    write_gcd_pairs(T, Sum0).

main:-
    range_list(4, L),
    unique_pairs(L, Pairs),
    write_gcd_pairs(Pairs),
    halt. 

Sample Run

$ gprolog
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
| ?- ['prolog/ch-1.p'].
compiling /home/adamcrussell/perlweeklychallenge-club/challenge-089/adam-russell/prolog/ch-1.p for byte code...
/home/adamcrussell/perlweeklychallenge-club/challenge-089/adam-russell/prolog/ch-1.p compiled, 36 lines read - 6945 bytes written, 52 ms

(26 ms) yes
| ?- main.
gcd(3, 4) + gcd(2, 4) + gcd(2, 3) + gcd(1, 4) + gcd(1, 3) + gcd(1, 2) = 7 

Notes

This mostly follows the approach of the Perl solution for this problem. The problem is broken down into the following pieces

• Generate all pairs of numbers between 1 and N. This is done here with range_list/2 and unique_pairs/2.
• The pairs then have their GCDs computed, summed, and printed. Here this is all done via write_gcd_pairs/1.

Part 2

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

Solution

all_unique(_, []).
all_unique(L, [V|T]) :-
    fd_exactly(1, L, V),
    all_unique(L, T).

pwc_matrix(R1,R2,R3) :-
    R1 = [A, B, C],
    R2 = [D, E, F],
    R3 = [G, H, I],
    /* each element is a number from 1 to 9 */  
    fd_domain([A, B, C], 1, 9),
    fd_domain([D, E, F], 1, 9),
    fd_domain([G, H, I], 1, 9),
    /* ensure each element is unique */
    all_unique([A, B, C, D, E, F, G, H, I], [1, 2, 3, 4, 5, 6, 7, 8, 9]),
    /* row constraints */
    A + B + C #= 15,
    D + E + F #= 15,
    G + H + I #= 15,
    /* column constraints */
    A + D + G #= 15,
    B + E + H #= 15,
    C + F + I #= 15,
    /* diagonal constraints */
    A + E + I #= 15,
    C + E + G #= 15,
    /* label all variables to instantiate one solution */  
    fd_labeling([A, B, C, D, E, F, G, H, I]).  

write_rows([]).
write_rows([H|T]):-
    format('[ ~d ~d ~d ]~n', H),
    write_rows(T).

write_solutions([]). 
write_solutions([H|T]):-
   write_rows(H), 
   nl,
   write_solutions(T). 

main :-
    findall([R1,R2,R3], pwc_matrix(R1,R2,R3), Solutions),  
    write_solutions(Solutions). 

Sample Run

$ gprolog
GNU Prolog 1.4.5 (32 bits)
Compiled Dec  3 2020, 00:37:14 with gcc
By Daniel Diaz
Copyright (C) 1999-2020 Daniel Diaz
| ?- ['prolog/ch-2.p'].
compiling /home/adamcrussell/perlweeklychallenge-club/challenge-089/adam-russell/prolog/ch-2.p for byte code...
/home/adamcrussell/perlweeklychallenge-club/challenge-089/adam-russell/prolog/ch-2.p compiled, 42 lines read - 6581 bytes written, 50 ms

(31 ms) yes
| ?- main.
[ 2 7 6 ]
[ 9 5 1 ]
[ 4 3 8 ]

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

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

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

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

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

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

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


(5 ms) yes

Notes

This is really not too tremendously different than a Sudoku, which just came up a couple of weeks ago. Obviously the constraints are different but the general approach is very similar. Here I am using Gnu Prolog’s finite domain (FD) constraint solver functions. In the past I primarily used SWI-Prolog and for this sort of problem I’d specifically make use of SWI-Prolog’s library(clpfd). Conceptually, the implementations are virtually identical which slightly different predicates. Gnu Prolog seems much faster, but I have neither confirm nor denied that with any sort of benchmarks.

Part 1

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

Solution

/*
    You are given an array of positive integers @N.
    Write a script to return an array @M where $M[i] is 
    the product of all elements of @N except the index $N[i].
*/
product_a_b(A, B, P):- 
    P is A*B.
list_product([], 1).
list_product([H|T], P) :-
        foldl(product_a_b, T, H, P).

list_products(List, Products):-
    length(List, L0),
    L is L0 - 1,
    list_products(List, L, [], Products). 
list_products(_, -1, Products, Products).       
list_products(List, Index, ProductsAccum, Products):-
    nth0(Index, List, _, Remainder),
    list_product(Remainder, Product),
    NewIndex is Index - 1,
    list_products(List, NewIndex, [Product|ProductsAccum], Products).
    
main:-
    list_products([5, 2, 1, 4, 3], Products),
    write(Products),
    halt.  

Sample Run

$ swipl -s prolog/ch-1.p -g main
[24,60,120,30,40]

Notes

A problem like this really underscores the nature of lists in Prolog. That is, if you are programming in most other languages you might think of lists and arrays as interchangeable concepts for the most part. In Prolog that is very clearly not the case: lists are lists and obtaining an element at a certain position in the list is not as straightforward as simply accessing it with the usual square bracket notation. Not to say it is all that hard to do in Prolog, it’s just … different. Or, at least, requires a different mindset. People with experience in pure functional languages have this mindset of thinking of lists in terms of recursions and maps but fluency in these techniques is, sadly, less common these days.

Part 2

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

Solution

/*
    You are given m x n matrix of positive integers.
    Write a script to print spiral matrix as a list.
*/
write_remove_top(Matrix, UpdatedMatrix):-
    nth0(0, Matrix, Top),
    atomic_list_concat(Top, ",", TopString),
    write(TopString),
    nth0(0, Matrix, _, UpdatedMatrix).

write_remove_last([], UpdatedMatrix, UpdatedMatrix).
write_remove_last([H|T], RemainderAccum, UpdatedMatrix):-
    length(H, L),
    Last is L - 1,
    nth0(Last, H, Right),
    write(Right),
    write(","),
    nth0(Last, H, _, UpdatedRow),
    write_remove_last(T, [UpdatedRow|RemainderAccum], UpdatedMatrix).

write_remove_right(Matrix, UpdatedMatrix):-
    write_remove_last(Matrix, [], UpdatedMatrix).

write_remove_first([], UpdatedMatrix, UpdatedMatrix).
write_remove_first([H|T], RemainderAccum, UpdatedMatrix):-
    nth0(0, H, Left),
    write(Left),
    write(","),
    nth0(0, H, _, UpdatedRow),
    write_remove_first(T, [UpdatedRow|RemainderAccum], UpdatedMatrix).

write_remove_left(Matrix, UpdatedMatrix):-
    write_remove_first(Matrix, [], UpdatedMatrix).

write_remove_bottom(Matrix, UpdatedMatrix):-
    length(Matrix, L),
    Last is L - 1,
    nth0(Last, Matrix, Bottom),
    reverse(Bottom, ReverseBottom),
    atomic_list_concat(ReverseBottom, ",", BottomString),
    write(BottomString),
    nth0(Last, Matrix, _, UpdatedMatrix).
    
    
spiral(Matrix):-
    spiral(Matrix, _).
spiral(Matrix, UpdatedMatrix):-
    write_remove_top(Matrix, UpdatedMatrix),
    write(","),
    write_remove_right(UpdatedMatrix, RightRemainder),
    reverse(RightRemainder, RemainderRight),
    write_remove_bottom(RemainderRight, BottomRemainder), 
    write(","),
    reverse(BottomRemainder, RemainderBottom),
    write_remove_left(RemainderBottom, LeftRemainder), 
    spiral(LeftRemainder, _).
spiral(_, []):-
    write("\b").
    
main:-
    spiral([
        [ 1, 2, 3 ],
        [ 4, 5, 6 ],
        [ 7, 8, 9 ]
    ]), halt.  

Sample Run

$ swipl -s prolog/ch-2.p -g main
1,2,3,6,9,8,7,4,5

Notes

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

• The matrix is a 2d list: a list with inner lists.
• For the spiral effect we need to print bottom up and right to left. In those cases I just use reverse/2 on the list being printed.
• I use a simple trick to remove a trailing comma in the final output; I print a backspace to the terminal which deletes it!
• Like Part 1 above I use nth0/4 as well as nth0/3 to directly access specific elements.

Part 1

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

Solution

:- use_module(library(optparse)).
/*
    You are given an array of integers @N and an integer $A.
    Write a script to find find if there exists a pair of elements 
    in the array whose difference is $A.
    Print 1 if exists otherwise 0.
*/
opts_spec(
    [
        [opt(numbers), 
        default([10, 8, 12, 15, 5]),
        longflags([numbers])],

        [opt(a), 
        default(7),
        longflags([a])]
    ]).

ch_1(L, N):-
    member(A, L),
    member(B, L),
    A =\= B,
    D is A - B,
    N = D,
    writeln(1).
    
ch_1(_, _):-  
    writeln(0).
    
main:-
    opts_spec(OptsSpec),
    opt_arguments(OptsSpec, [numbers(L), a(A)], _AdditionalArguments),
    ch_1(L, A),
    halt.

Sample Run

$ swipl -s ch-1.p -g main --numbers="[10, 30, 20, 50, 40]" --a=15
0
$ swipl -s ch-1.p -g main --numbers="[10, 8, 12, 15, 5]" --a=7
1

Notes

My approach here is very similar to what I did last week. Please do check that out if you’re interested in a slightly longer discussion of the use of optparse to handle the command line arguments.

Part 2

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

Solution

:- use_module(library(clpfd)).
 
sudoku(Puzzle, Solution) :-
        Solution = Puzzle,
        Puzzle = [S11, S12, S13, S14, S15, S16, S17, S18, S19,
                  S21, S22, S23, S24, S25, S26, S27, S28, S29,
                  S31, S32, S33, S34, S35, S36, S37, S38, S39,
                  S41, S42, S43, S44, S45, S46, S47, S48, S49,
                  S51, S52, S53, S54, S55, S56, S57, S58, S59,
                  S61, S62, S63, S64, S65, S66, S67, S68, S69,
                  S71, S72, S73, S74, S75, S76, S77, S78, S79,
                  S81, S82, S83, S84, S85, S86, S87, S88, S89,
                  S91, S92, S93, S94, S95, S96, S97, S98, S99],
 
        ins(Puzzle, 1..9),
 
        Row1 = [S11, S12, S13, S14, S15, S16, S17, S18, S19],
        Row2 = [S21, S22, S23, S24, S25, S26, S27, S28, S29],
        Row3 = [S31, S32, S33, S34, S35, S36, S37, S38, S39],
        Row4 = [S41, S42, S43, S44, S45, S46, S47, S48, S49],
        Row5 = [S51, S52, S53, S54, S55, S56, S57, S58, S59],
        Row6 = [S61, S62, S63, S64, S65, S66, S67, S68, S69],
        Row7 = [S71, S72, S73, S74, S75, S76, S77, S78, S79],
        Row8 = [S81, S82, S83, S84, S85, S86, S87, S88, S89],
        Row9 = [S91, S92, S93, S94, S95, S96, S97, S98, S99],
 
        Column1 = [S11, S21, S31, S41, S51, S61, S71, S81, S91],
        Column2 = [S12, S22, S32, S42, S52, S62, S72, S82, S92],
        Column3 = [S13, S23, S33, S43, S53, S63, S73, S83, S93],
        Column4 = [S14, S24, S34, S44, S54, S64, S74, S84, S94],
        Column5 = [S15, S25, S35, S45, S55, S65, S75, S85, S95],
        Column6 = [S16, S26, S36, S46, S56, S66, S76, S86, S96],
        Column7 = [S17, S27, S37, S47, S57, S67, S77, S87, S97],
        Column8 = [S18, S28, S38, S48, S58, S68, S78, S88, S98],
        Column9 = [S19, S29, S39, S49, S59, S69, S79, S89, S99],
 
        SubBox1 = [S11, S12, S13, S21, S22, S23, S31, S32, S33],
        SubBox2 = [S41, S42, S43, S51, S52, S53, S61, S62, S63],
        SubBox3 = [S71, S72, S73, S81, S82, S83, S91, S92, S93],
        SubBox4 = [S14, S15, S16, S24, S25, S26, S34, S35, S36],
        SubBox5 = [S44, S45, S46, S54, S55, S56, S64, S65, S66],
        SubBox6 = [S74, S75, S76, S84, S85, S86, S94, S95, S96],
        SubBox7 = [S17, S18, S19, S27, S28, S29, S37, S38, S39],
        SubBox8 = [S47, S48, S49, S57, S58, S59, S67, S68, S69],
        SubBox9 = [S77, S78, S79, S87, S88, S89, S97, S98, S99],
 
        valid([Row1, Row2, Row3, Row4, Row5, Row6, Row7, Row8, Row9,
               Column1, Column2, Column3, Column4, Column5, Column6, Column7, Column8, Column9,
               SubBox1, SubBox2, SubBox3, SubBox4, SubBox5, SubBox6, SubBox7, SubBox8, SubBox9]).
 
valid([]).
valid([H|T]) :-
    all_different(H),
    valid(T).

Sample Run

$ swipl -s prolog/ch-2.p
Welcome to SWI-Prolog (threaded, 64 bits, version 8.2.2)
SWI-Prolog comes with ABSOLUTELY NO WARRANTY. This is free software.
Please run ?- license. for legal details.

For online help and background, visit https://www.swi-prolog.org
For built-in help, use ?- help(Topic). or ?- apropos(Word).

?- sudoku([_,_,_,2,6,_,7,_,1,6,8,_,_,7,_,_,9,_,1,9,_,_,_,4,5,_,_,8,2,_,1,_,_,_,4,_,_,_,4,6,_,2,9,_,_,_,5,_,_,_,3,_,2,8,_,_,9,3,_,_,_,7,4,_,4,_,_,5,_,_,3,6,7,_,3,_,1,8,_,_,_],Solution).
Solution = [4, 3, 5, 2, 6, 9, 7, 8, 1|...].

?- halt.

Notes

How many Prolog programmers saw this part of the challenge and thought “finally my training has paid off!” For the unfamiliar, Sudoku is a natural fit for a language like Prolog and quite a few variations are possible. My approach here is to make some use of clpfd but favored a more verbose style so that what is happening should be fairly clear. The clpfd manual includes a much more terse example.

SWI-Prolog has a nice library which allows you to pass arguments on the command line to your Prolog programs. Here are a couple of example of it’s use done with the two parts of Perl Weekly Challenge 085 implemented in Prolog.

Part 1

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

Solution

:- use_module(library(optparse)).
/*
    You are given an array of real numbers greater than zero.
    Write a script to find if there exists a triplet (a,b,c) 
    such that 1 < a+b+c < 2. Print 1 if you succeed otherwise 0.
*/
opts_spec(
    [
        [opt(numbers), 
        default([1.2, 0.4, 0.1, 2.5]),
        longflags([numbers])]
    ]).

ch_1(L):-
    member(A, L),
    member(B, L),
    member(C, L),
    A =\= B,
    B =\= C,
    A =\= C,
    D is A + B + C,
    D > 1,
    D < 2,
    writeln(1).
    
ch_1(_):-  
    writeln(0).
    
main:-
    opts_spec(OptsSpec),
    opt_arguments(OptsSpec, [numbers(N)], _AdditionalArguments),
    ch_1(N),
    halt.

Sample Run

$ swipl -s ch-1.p -g main --numbers="[1.0, 0.2, 3.4, 0.1]"
1
$ swipl -s ch-1.p -g main --numbers="[1.0, 1.2, 3.4, 0.1]"
0

Notes

You can see from the Sample Run that we are passing a Prolog list as a command line argument. To avoid conflicts with the shell trying to interpret our square brackets and commas we put the list itself in quotes. But how does Prolog know what --numbers means?

To use library(optparse) you must define a specification for each of your command line arguments that you expect to take. Here we just have one. The line opt(numbers) specifies the term that will be used to obtain the value in your program, default([1.2, 0.4, 0.1, 2.5]) provides a default value if the argument is not used on the command line. longflags([numbers]) indicates that to look for a flag of the form --numbers. we could have also used shortflags([numbers]) instead if we would prefer to use -numbers. I don’t know of any strong arguments for either one but find, personally, that the long form is more intuitive.

The values passed on the command line are extracted using opt_arguments which will follow the specification you’ve provided. _AdditionalArguments refers to any arguments passed on the command line without dashes but here we do not have any. [numbers(N)] is a list of the parsed key(value) pairs from the command line. So for this example N is the list value we entered on the command line and it is then used as needed.

Part 2

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

Solution

:- use_module(library(clpfd)).
:- use_module(library(optparse)).
/*
    You are given a positive integer $N.
    Write a script to find if it can be expressed
    as a ^ b where a > 0 and b > 1. 
    Print 1 if you succeed otherwise 0.
*/
opts_spec(
    [
        [opt(number), 
        default(0),
        longflags([number])]
    ]).

/*
    Ok, I'll admit, this is a pretty silly use of clpfd when
    a simple logarithm calculation would do the job! Still clpfd 
    is more fun.
*/    
ch_2(N) :-
    N0 is N -1,
    A in 0 .. N0,    
    B in 1 .. N0,
    N #= A ^ B,
    label([A,B]),
    writeln(1).
ch_2(_) :-
    writeln(0).
    
main:-
    opts_spec(OptsSpec),
    opt_arguments(OptsSpec, [number(N)], _AdditionalArguments),
    ch_2(N),
    halt.

Sample Run

$ swipl -s ch-2.p -g main --number=7
0
$ swipl -s ch-2.p -g main --number=8
1

Notes

$ swipl -s ch-2.p -g main --number="100"
1

Reference

optparse documentation