RabbitFarm
2022-06-19
The Weekly Challenge 169 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the first 20 Brilliant Numbers.
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).
brilliants(_) --> [].
brilliants(Seen) --> [X], {brilliant(X), \+ member(X, Seen)}, brilliants([X|Seen]).
brilliant(X):-
current_prolog_flag(max_integer, MAX_INTEGER),
between(1, MAX_INTEGER, X),
prime_factors(X, Factors),
length(Factors, 2),
nth(1, Factors, First),
nth(2, Factors, Second),
number_chars(First, FirstChars),
number_chars(Second, SecondChars),
length(FirstChars, FirstCharsLength),
length(SecondChars, SecondCharsLength),
FirstCharsLength == SecondCharsLength.
n_brilliants(N, Brilliants):-
length(Brilliants, N),
phrase(brilliants([]), Brilliants).
Sample Run
$ gprolog --consult-file prolog/ch-1.p
| ?- n_brilliants(20, Brilliants).
Brilliants = [4,6,9,10,14,15,21,25,35,49,121,143,169,187,209,221,247,253,289,299] ?
Notes
The use of a DCG here seems appropriate as we are generating a sequence of numbers of a DCG will allow us to reason on such lists. The logic for inclusion in the sequence is a bit complex and so it further seems natural to break that into its own predicate. That is not required, of course, but in terms of pure style it seems the DCG starts to look clunky or overstuffed when containing a lot of Prolog code in curly braces. Perhaps that is especially true here where we further need additional predicates for computing the prime factors.
Part 2
Write a script to generate the first 20 Achilles Numbers.
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).
powerful(N, X):-
M is mod(N, X * X),
M == 0.
imperfect(N):-
Sqrt is round(sqrt(N)),
S is Sqrt - 1,
length(I, S),
fd_domain(I, 2, Sqrt),
fd_all_different(I),
fd_labeling(I),!,
maplist(imperfect(N), I).
imperfect(N, X):-
D is log(N) / log(X),
Check is abs(D - round(D)),
\+ Check < 0.000001.
achilles(_) --> [].
achilles(Seen) --> [X], {current_prolog_flag(max_integer, MAX_INTEGER),
between(2, MAX_INTEGER, X), \+ member(X, Seen), achilles(X)},
achilles([X|Seen]).
achilles(X):-
prime_factors(X, Factors),
maplist(powerful(X), Factors),
imperfect(X).
n_achilles(N, Achilles):-
length(Achilles, N),
phrase(achilles([]), Achilles).
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- n_achilles(20, Achilles).
Achilles = [72,108,200,288,392,432,500,648,675,800,864,968,972,1125,1152,1323,1352,1372,1568,1800] ?
Notes
The approach here for the second task is similar to that of the first. Somewhat
surprisingly while the conditions of this sequence are more complex the code itself is
represented in a cleaner way. I attribute that to the use of maplist/2 which streamlines
the checking of lists for the two criteria of Achilles numbers: that they are powerful
but imperfect.
References
posted at: 12:39 by: Adam Russell | path: /prolog | permanent link to this entry
2022-06-12
The Weekly Challenge 168 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Calculate the first 13 Perrin Primes.
Solution
perrin_primes(A, B, C) --> {D is B + A, fd_not_prime(D)},
perrin_primes(B, C, D).
perrin_primes(A, B, C) --> {D is B + A, fd_prime(D), D \== C},
[D], perrin_primes(B, C, D).
perrin_primes(A, B, C) --> {D is B + A, fd_prime(D), D == C},
[], perrin_primes(B, C, D).
perrin_primes(_, _, _) --> [], !.
n_perrin_primes(N, PerrinPrimes):-
length(PerrinPrimes, N),
phrase(perrin_primes(3, 0, 2), PerrinPrimes).
Sample Run
$ gprolog --consult-file prolog/ch-1.p
| ?- n_perrin_primes(13, PerrinPrimes).
PerrinPrimes = [3,2,5,7,17,29,277,367,853,14197,43721,1442968193,792606555396977] ?
Notes
This is a pretty cut and dry use of a DCG to generate this interesting mathematical
sequence. A couple of things that stand out are (1) the condition that D \== C which is
to remove the duplicate 5 which occurs naturally at the beginning of the sequence.
Afterwards all of the terms strictly increase. Also, (2) although the first two terms are
indeed 3, 2 it is a convention to sort these and present them as 2, 3 although I did
not happen to do so here.
Part 2
You are given an integer greater than 1. Write a script to find the home prime of the given number.
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).
factor_concat(Factors, Atom):-
factor_concat(Factors, '', Atom).
factor_concat([], Atom, Atom).
factor_concat([H|T], AtomAccum, Atom):-
number_atom(H, A),
atom_concat(AtomAccum, A, UpdatedAtomAccum),
factor_concat(T, UpdatedAtomAccum, Atom).
home_prime(N, HomePrime):-
prime_factors(N, Factors),
factor_concat(Factors, A),
number_atom(Number, A),
fd_not_prime(Number),
home_prime(Number, HomePrime).
home_prime(N, HomePrime):-
prime_factors(N, Factors),
factor_concat(Factors, A),
number_atom(Number, A),
fd_prime(Number),
HomePrime = Number.
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- home_prime(16, HomePrime).
HomePrime = 31636373 ?
(4 ms) yes
| ?- home_prime(54, HomePrime).
HomePrime = 2333 ?
(1 ms) yes
| ?- home_prime(108, HomePrime).
HomePrime = 23971 ?
yes
Notes
Here we are asked to compute the Home Prime of any given number. The process
for doing so is, given N to take the prime factors for N and concatenate them
together. If the result is prime then we are done, that is the Home Prime of N,
typically written HP(N). This is an easy process to repeat, and in many cases the
computation is a very quick one. However, in some cases, the size of the interim numbers
on the path to HP(N) grow extremely large and the computation bogs down. I have used the
prime factorization code here in several other weekly challenges and it is quite
performant but even this runs rather slowly as we are faced with extremely large numbers.
References
posted at: 19:21 by: Adam Russell | path: /prolog | permanent link to this entry
2022-05-22
The Weekly Challenge 165 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Plot lines and points in SVG format.
Solution
svg-->svg_begin, svg_body, svg_end.
svg_body-->[].
svg_body-->svg_line(_, _, _, _), svg_body.
svg_body-->svg_point(_, _), svg_body.
svg_begin-->['<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd"><svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">'].
svg_point(X, Y)-->['<circle cx="', X,'" cy="', Y, '" r="1" />'].
svg_line(X1, Y1, X2, Y2)-->['<line x1="', X1, '" x2="', X2, '" y1="', Y1, '" y2="', Y2, '" style="stroke:#006600;" />'].
svg_end-->[''].
plot([], SVGAccum, SVG):-
phrase(svg_begin, Begin),
flatten([Begin|SVGAccum], SVG).
plot([H|T], SVGAccum, SVG):-
length(H, 2),
[X, Y] = H,
phrase(svg_point(X, Y), Point),
plot(T, [Point|SVGAccum], SVG).
plot([H|T], SVGAccum, SVG):-
length(H, 4),
[X1, Y1, X2, Y2] = H,
phrase(svg_line(X1, Y1, X2, Y2), Line),
plot(T, [Line|SVGAccum], SVG).
plot(Lines, SVG):-
phrase(svg_end, End),
plot(Lines, [End], SVG).
main:-
plot([[53,10], [53, 10, 23, 30], [23, 30]], SVG),
maplist(write, SVG), nl,
halt.
Sample Run
$ gprolog --consult-file prolog/ch-1.p
<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd"><svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink"><circle cx="23" cy="30" r="1" /><line x1="53" x2="23" y1="10" y2="30" /><circle cx="53" cy="10" r="1" /></svg>
Notes
SVG is an XML based format, and so the use of a DCG like this may be unexpected. After all, the "grammar" is really dictated by a known XML schema. Still, the DCG is helpful in that we can describe the sequence and formatting of the statements we expect. From this we can generate the required SVG and even do some basic validation.
Part 2
Given a list of numbers, generate the skip summations.
Solution
avg_difference(Avg, V, Difference):-
Difference is V - Avg.
square(X, XSquared):-
XSquared is X * X.
xy(X, Y, XY):-
XY is X * Y.
linear_regression(Points, RegressionLineEndpoints):-
length(Points, NumberPoints),
% 1. Calculate average of your X variable.
maplist(nth(1), Points, Xs),
msort(Xs, XSorted),
nth(NumberPoints, XSorted, XMax),
sum_list(Xs, XSum),
XAvg is XSum / NumberPoints,
% 2. Calculate the difference between each X and the average X.
maplist(avg_difference(XAvg), Xs, XDifferences),
% 3. Square the differences and add it all up. This is Sx.
maplist(square, XDifferences, XDifferencesSquared),
sum_list(XDifferencesSquared, Sx),
% 4. Calculate average of your Y variable.
maplist(nth(2), Points, Ys),
sum_list(Ys, YSum),
YAvg is YSum / NumberPoints,
% 5. Multiply the differences (of X and Y from their respective averages) and add them all together. This is Sxy.
maplist(avg_difference(YAvg), Ys, YDifferences),
maplist(xy, XDifferences, YDifferences, XY),
sum_list(XY, Sxy),
% 6. Using Sx and Sxy, you calculate the intercept by subtracting Sx / Sxy * AVG(X) from AVG(Y).
M is Sxy / Sx,
B is YAvg - (Sxy / Sx * XAvg),
EndX is XMax + 10,
EndY is M * EndX + B,
RegressionLineEndpoints = [0, B, EndX, EndY].
main:-
Points = [[333,129], [39, 189], [140, 156], [292, 134], [393, 52], [160, 166], [362, 122], [13, 193], [341, 104], [320, 113], [109, 177], [203, 152], [343, 100], [225, 110], [23, 186], [282, 102], [284, 98], [205, 133], [297, 114], [292, 126], [339, 112], [327, 79], [253, 136], [61, 169], [128, 176], [346, 72], [316, 103], [124, 162], [65, 181], [159, 137], [212, 116], [337, 86], [215, 136], [153, 137], [390, 104], [100, 180], [76, 188], [77, 181], [69, 195], [92, 186], [275, 96], [250, 147], [34, 174], [213, 134], [186, 129], [189, 154], [361, 82], [363, 89]],
linear_regression(Points, RegressionLine),
write(RegressionLine), nl.
Sample Run
$ gprolog --consult-file prolog/ch-1.p --consult-file prolog/ch-2.p
| ?- Points = [[333,129], [39, 189], [140, 156], [292, 134], [393, 52], [160, 166], [362, 122], [13, 193], [341, 104], [320, 113], [109, 177], [203, 152], [343, 100], [225, 110], [23, 186], [282, 102], [284, 98], [205, 133], [297, 114], [292, 126], [339, 112], [327, 79], [253, 136], [61, 169], [128, 176], [346, 72], [316, 103], [124, 162], [65, 181], [159, 137], [212, 116], [337, 86], [215, 136], [153, 137], [390, 104], [100, 180], [76, 188], [77, 181], [69, 195], [92, 186], [275, 96], [250, 147], [34, 174], [213, 134], [186, 129], [189, 154], [361, 82], [363, 89]],
linear_regression(Points, RegressionLine), append(Points, [RegressionLine], PointsLine), plot(PointsLine, SVG), maplist(write, SVG), nl.
<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd"><svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink"><line x1="0" x2="403" y1="200.13227253558171" y2="79.249802930305563" style="stroke:#006600;" /><circle cx="363" cy="89" r="1" /><circle cx="361" cy="82" r="1" /><circle cx="189" cy="154" r="1" /><circle cx="186" cy="129" r="1" /><circle cx="213" cy="134" r="1" /><circle cx="34" cy="174" r="1" /><circle cx="250" cy="147" r="1" /><circle cx="275" cy="96" r="1" /><circle cx="92" cy="186" r="1" /><circle cx="69" cy="195" r="1" /><circle cx="77" cy="181" r="1" /><circle cx="76" cy="188" r="1" /><circle cx="100" cy="180" r="1" /><circle cx="390" cy="104" r="1" /><circle cx="153" cy="137" r="1" /><circle cx="215" cy="136" r="1" /><circle cx="337" cy="86" r="1" /><circle cx="212" cy="116" r="1" /><circle cx="159" cy="137" r="1" /><circle cx="65" cy="181" r="1" /><circle cx="124" cy="162" r="1" /><circle cx="316" cy="103" r="1" /><circle cx="346" cy="72" r="1" /><circle cx="128" cy="176" r="1" /><circle cx="61" cy="169" r="1" /><circle cx="253" cy="136" r="1" /><circle cx="327" cy="79" r="1" /><circle cx="339" cy="112" r="1" /><circle cx="292" cy="126" r="1" /><circle cx="297" cy="114" r="1" /><circle cx="205" cy="133" r="1" /><circle cx="284" cy="98" r="1" /><circle cx="282" cy="102" r="1" /><circle cx="23" cy="186" r="1" /><circle cx="225" cy="110" r="1" /><circle cx="343" cy="100" r="1" /><circle cx="203" cy="152" r="1" /><circle cx="109" cy="177" r="1" /><circle cx="320" cy="113" r="1" /><circle cx="341" cy="104" r="1" /><circle cx="13" cy="193" r="1" /><circle cx="362" cy="122" r="1" /><circle cx="160" cy="166" r="1" /><circle cx="393" cy="52" r="1" /><circle cx="292" cy="134" r="1" /><circle cx="140" cy="156" r="1" /><circle cx="39" cy="189" r="1" /><circle cx="333" cy="129" r="1" /></svg>
Notes
This is mainly an implementation of the same linear regression procedure as used in the Perl solution to the same problem. By consulting the solution to the first problem we can then re-use the same plotting code.
References
posted at: 23:28 by: Adam Russell | path: /prolog | permanent link to this entry
2022-05-15
The Weekly Challenge 164 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to find all prime numbers less than 1000, which are also palindromes in base 10.
Solution
:-initialization(main).
palindrome(X):-
fd_labeling(X),
number_codes(X, C),
reverse(C, CR),
number_codes(X, CR).
palindrome_primes(N, PalindromePrimes, NumberPrimes):-
fd_labeling(NumberPrimes),
length(Primes, NumberPrimes),
fd_domain(Primes, 1, N),
fd_all_different(Primes),
maplist(palindrome, Primes),
maplist(fd_prime, Primes),
fd_labeling(Primes),
PalindromePrimes = Primes.
palindrome_primes(N, Primes):-
NP is N // 2,
fd_domain(NumberPrimes, 1, NP),
fd_maximize(palindrome_primes(N, Primes, NumberPrimes), NumberPrimes).
palindrome_prime(N, Prime):-
between(1, N, Prime),
palindrome(Prime),
fd_prime(Prime).
pp(_, _) --> [].
pp(N, Seen) --> [X], {palindrome_prime(N, X), \+ member(X, Seen)}, pp(N, [X|Seen]).
main:-
findall(Prime, palindrome_prime(1000, Prime), PalindromePrimes),
write(PalindromePrimes), nl.
Sample Run
$ gprolog --consult-file prolog/ch-1.p
[2,3,5,7,11,101,131,151,181,191,313,353,373,383,727,757,787,797,919,929]
| ?- phrase(pp(1000, []), PalindromePrimes).
PalindromePrimes = [] ? ;
PalindromePrimes = [2] ? ;
PalindromePrimes = [2,3] ? ;
PalindromePrimes = [2,3,5] ? ;
PalindromePrimes = [2,3,5,7] ? ;
PalindromePrimes = [2,3,5,7,11] ? ;
PalindromePrimes = [2,3,5,7,11,101] ? ;
PalindromePrimes = [2,3,5,7,11,101,131] ? ;
PalindromePrimes = [2,3,5,7,11,101,131,151] ? ;
PalindromePrimes = [2,3,5,7,11,101,131,151,181] ? ;
PalindromePrimes = [2,3,5,7,11,101,131,151,181,191] ? ;
PalindromePrimes = [2,3,5,7,11,101,131,151,181,191,313] ?
.
.
.
Notes
I experimented with a few different ways to generate Palindrome Primes. The quickest and
most efficient way is what is used in main/0. Now, suppose we wanted to reason about
lists of such numbers versus just generating them there is also a DCG option as shown
which will generate or validate all possible lists of Palindrome Primes. Finally, there is
the extremely inefficient method using constraints to maximize the size of the list of
Palindrome Primes under 1000. This works! Now, does it work "well"? Absolutely not! This
is not a very good method for performing the task and is many orders of magnitude slower
than the other two. I will admit to an odd satisfaction to getting this unusual approach
work, however.
Part 2
Given a list of numbers, generate the skip summations.
Solution
:-initialization(main).
pdi(0, Total, Total).
pdi(N, Total_, Total):-
N_ is N // 10,
Total__ is Total_ + round(mod(N, 10) ** 2),
pdi(N_, Total__, Total).
pdi(N, Total):-
pdi(N, 0, Total).
happy(1, _).
happy(N, Seen):-
\+ member(N, Seen),
pdi(N, Total),!,
N_ is Total,
happy(N_, [N|Seen]).
happy(N):-
happy(N, []).
happy(_) --> [].
happy(Seen) --> [X], {between(1, 100, X), \+ member(X, Seen), happy(X)}, happy([X|Seen]).
main:-
length(Happy, 8),
phrase(happy([]), Happy),
write(Happy), nl.
Sample Run
$ gprolog --consult-file prolog/ch-2.p
[1,7,10,13,19,23,28,31]
Notes
As with the code in the first part I also implemented this as a DCG. Here a DCG is more practical since we are asked specifically to generate a list of the first 8 Happy Numbers. This is more of a "list reasoning" task than how the Palindrome Prime question was asked.
References
posted at: 23:58 by: Adam Russell | path: /prolog | permanent link to this entry
2022-05-08
The Weekly Challenge 163 (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 numbers. Write a script to calculate the sum of the bitwise & operator for all unique pairs.
Solution
and(N, X, And):-
And is N /\ X.
sum_and([], 0).
sum_and([H|T], SumAnd):-
sum_and(T, Sum),
maplist(and(H), T, Ands),
sum_list(Ands, AndSum),
SumAnd is Sum + AndSum.
Sample Run
$ gprolog --consult-file prolog/ch-1.p
| ?- sum_and([1, 2, 3], SumAnd).
SumAnd = 3
yes
| ?- sum_and([2, 3, 4], SumAnd).
SumAnd = 2
yes
| ?- sum_and([1, 2, 3], 99).
no
| ?- sum_and([1, 2, 3], 3).
yes
Notes
It is not too often you see the bitwise operators used in Prolog code! I am kind of a fan
of the /\ operator, I mean, it even looks like an upper case 'A', right?
Other than the novelty of the bitwise and I found this task to be well suited for the use
of maplist/3 for computing the pairwise and operations across the list of numbers. This
is something of a "nested loop" in the sense that recursively the head of the list of
numbers is removed and upon each recursive step the maplist is re-performed on the
increasingly shorter list.
Part 2
Given a list of numbers, generate the skip summations.
Solution
skip_sum(Numbers, N, Sum):-
append(Left, [N|_], Numbers),
sum_list(Left, SumLeft),
Sum is N + SumLeft.
skip_summations(Numbers, Summations):-
skip_summations(Numbers, [Numbers], Summations).
skip_summations([], Summations, Summations).
skip_summations([_|T], SummationsAccum, Summations):-
maplist(skip_sum(T), T, Sums),
skip_summations(Sums, [Sums|SummationsAccum], Summations).
print_summation(S):-
write(S),
write(' ').
print_summations([]).
print_summations([H|T]):-
print_summations(T),
maplist(print_summation, H), nl.
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- skip_summations([1, 2, 3, 4, 5], Summations), print_summations(Summations).
1 2 3 4 5
2 5 9 14
5 14 28
14 42
42
Summations = [[],[42],[14,42],[5,14,28],[2,5,9,14],[1,2,3,4,5]] ?
yes
| ?- skip_summations([1, 3, 5, 7, 9], Summations), print_summations(Summations).
1 3 5 7 9
3 8 15 24
8 23 47
23 70
70
Summations = [[],[70],[23,70],[8,23,47],[3,8,15,24],[1,3,5,7,9]] ?
yes
| ?- skip_summations([1, 3, 5, 7, 9], [[],[70],[23,70],[8,23,47],[3,8,15,24],[1,3,5,27,9]]).
no
| ?- skip_summations([1, 3, 5, 7, 9], [[],[70],[23,70],[8,23,47],[3,8,15,24],[1,3,5,7,9]]).
true ?
yes
Notes
Much like the task above we use a maplist/3 within a recursive step. Here the
maplist/3 is used to do the partial sums for each "line" of the output. There is also a
maplist/2 used to print the output lines with a space between each element.
Satisfyingly, as shown above, the same code not only generates the skip summations but also validates them as well. This sort of intrinsic Prolog behavior brings joy!
References
posted at: 13:52 by: Adam Russell | path: /prolog | permanent link to this entry
2022-05-01
The Weekly Challenge 162 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the check digit of a given ISBN-13 code.
Solution
weight(-1, 1).
weight(1, 3).
check_sum([], _, 0).
check_sum([H|T], I, CheckSum):-
N is I * -1,
check_sum(T, N, C),
weight(I, Weight),
CheckSum is H * Weight + C.
isbn_check_digit(ISBN, CheckDigit):-
check_sum(ISBN, -1, CheckSum),
Check is mod(CheckSum, 10),
CheckDigit is 10 - Check.
Sample Run
$ gprolog --consult-file prolog/ch-1.p
| ?- isbn_check_digit([9, 7, 8, 0, 3, 0, 6, 4, 0, 6, 1, 5], CheckDigit).
CheckDigit = 7
(1 ms) yes
$ gprolog --consult-file prolog/ch-1.p
| ?- isbn_check_digit([9, 7, 8, 0, 3, 0, 6, 4, 0, 6, 1, 5], 3).
(1 ms) no
$ gprolog --consult-file prolog/ch-1.p
| ?- isbn_check_digit([9, 7, 8, 0, 3, 0, 6, 4, 0, 6, 1, 5], 7).
yes
Notes
Sometimes when writing this sort of code I feel the urge to really unleash the power of Prolog and make the most general solution. What would that mean here though? Generate ISBNs for which a given check digit would be valid? While possible it seems like a kind of weird thing to do. Is it interesting to reason about ISBNs in this way? I seem to think that is unlikely.
This code does what seems to reasonable: generate a check digit given an ISBN, or, given both an ISBN and a check digit confirm that the given check digit is the correct one.
References
posted at: 14:34 by: Adam Russell | path: /prolog | permanent link to this entry
2022-04-24
The Weekly Challenge 161 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Output or return a list of all abecedarian words in the dictionary, sorted in decreasing order of length.
Solution
check_and_read(10, [] ,_):-
!.
check_and_read(13, [], _):-
!.
check_and_read(32, [], _):-
!.
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).
abecedarian(Words, Abecedarian):-
member(Word, Words),
atom_chars(Word, Chars),
sort(Chars, SortedChars),
atom_chars(W, SortedChars),
W = Word,
Abecedarian = Word.
word_length(Word, LengthWord):-
atom_chars(Word, Chars),
length(Chars, Length),
LengthWord = Length-Word.
abecedarians(Words, Abecedarians):-
findall(Abecedarian, abecedarian(Words, Abecedarian), A),
maplist(word_length, A, AL),
keysort(AL, ALSorted),
reverse(ALSorted, Abecedarians).
main:-
open('dictionary', read, Stream),
read_data(Stream, Dictionary),
close(Stream),
abecedarians(Dictionary, Abecedarians),
write(Abecedarians), nl,
halt.
Sample Run
$ gprolog --consult-file prolog/ch-1.p --entry-goal main
[6-chintz,6-chimps,6-begins,6-almost,6-abhors,5-glory,5-ghost,5-forty,5-flops,5-first,5-filmy,5-films,5-empty,5-dirty,5-deity,5-chops,5-chips,5-chins,5-chimp,5-below,5-begin,5-befit,5-aglow,5-adopt,5-adept,5-abort,5-abhor,4-nosy,4-most,4-mops,4-lost,4-lops,4-know,4-knot,4-imps,4-host,4-hops,4-hips,4-hint,4-hims,4-hilt,4-gory,4-glow,4-gist,4-gins,4-gilt,4-foxy,4-fort,4-flux,4-flow,4-flop,4-fist,4-firs,4-fins,4-film,4-envy,4-elms,4-egos,4-dirt,4-dips,4-dins,4-dims,4-deny,4-dent,4-dens,4-defy,4-deft,4-crux,4-cost,4-copy,4-cops,4-clot,4-city,4-chow,4-chop,4-chip,4-chin,4-cent,4-blow,4-blot,4-bins,4-best,4-bent,4-belt,4-begs,4-amps,4-alms,4-airy,4-airs,4-aims,4-ails,4-ahoy,4-aces,4-ably,4-abet,3-pry,3-opt,3-now,3-not,3-nor,3-mow,3-mop,3-low,3-lot,3-lop,3-joy,3-jot,3-ivy,3-ins,3-imp,3-how,3-hot,3-hop,3-hit,3-his,3-hip,3-him,3-guy,3-got,3-gnu,3-gin,3-fry,3-fox,3-for,3-fly,3-flu,3-fix,3-fit,3-fir,3-fin,3-elm,3-ego,3-dry,3-dot,3-dos,3-dip,3-din,3-dim,3-dew,3-den,3-cry,3-coy,3-cox,3-cow,3-cot,3-cop,3-chi,3-buy,3-boy,3-box,3-bow,3-bop,3-bit,3-bin,3-bet,3-beg,3-art,3-apt,3-any,3-ant,3-amp,3-air,3-aim,3-ail,3-ago,3-ads,3-ado,3-act,3-ace,2-qt,2-ox,2-or,2-no,2-my,2-mu,2-ms,2-ix,2-iv,2-it,2-(is),2-in,2-ho,2-hi,2-go,2-em,2-eh,2-do,2-cs,2-by,2-be,2-ax,2-at,2-as,2-an,2-am,2-ah,2-ad,1-x,1-m,1-a]
Notes
Most of the code here is just for reading the provided dictionary of words. Once that is
complete Prolog really shines. abecedarian/2 is the majority of the logic: if a word's
characters when sorted and re-assembled are the original word then it is an Abecedarian.
abecedarians/2 is necessary only to fulfill the requirements of the problem
specification which is that all Abecedarians be sorted by length and returned in
descending order.
References
posted at: 14:27 by: Adam Russell | path: /prolog | permanent link to this entry
2022-04-17
The Weekly Challenge 160 (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 number, $n < 10. Write a script to generate english text sequence starting with the English cardinal representation of the given number, the word "is" and then the English cardinal representation of the count of characters that made up the first word, followed by a comma. Continue until you reach four.
Solution
cardinal(1, one).
cardinal(2, two).
cardinal(3, three).
cardinal(4, four).
cardinal(5, five).
cardinal(6, six).
cardinal(7, seven).
cardinal(8, eight).
cardinal(9, nine).
cardinal(10, ten).
four_is_magic(N) --> {between(1, 9, N), \+N == 4,
cardinal(N, Cardinal),
atom_codes(Cardinal, Codes),
length(Codes, Count)},
[N-Count], four_is_magic(Count).
four_is_magic(N) --> {between(1, 9, N), N == 4}, [N-magic].
print_magic([]):-
nl.
print_magic([H|T]):-
N-Count = H,
\+ N == 4,
cardinal(N, Cardinal),
cardinal(Count, CountCardinal),
format("~a is ~a, ", [Cardinal, CountCardinal]),
print_magic(T).
print_magic([H|T]):-
N-_ = H,
N == 4,
cardinal(N, Cardinal),
format("~a is ~a", [Cardinal, magic]),
print_magic(T).
main(N) :-
phrase(four_is_magic(N), FourIsMagic),
print_magic(FourIsMagic).
Sample Run
$ gprolog --consult-file prolog/ch-1.p
| ?- main(6).
six is three, three is five, five is four, four is magic
true ?
(1 ms) yes
| ?- main(_).
one is three, three is five, five is four, four is magic
true ? ;
two is three, three is five, five is four, four is magic
true ? ;
three is five, five is four, four is magic
true ? ;
five is four, four is magic
true ? ;
six is three, three is five, five is four, four is magic
true ? ;
seven is five, five is four, four is magic
true ? ;
eight is five, five is four, four is magic
true ?
(1 ms) yes
Notes
Prolog has an interesting history of generating text. This is one of the more simple applications I will admit. Here I use a DCG to generate the sequence and then a recursive set of predicates to print the associated text.
In typical Prolog fashion, as shown in the sample output, we can not only generate a sequence with a specified starting point, but all such sequences.
Part 2
You are give an array of integers, @n. Write a script to find out the Equilibrium Index of the given array, if found.
Solution
equilibrium_index(Numbers, I):-
member(N, Numbers),
append(Left, [N|Right], Numbers),
sum_list(Left, SumLeft),
sum_list(Right, SumRight),
SumLeft == SumRight,
nth(I, Numbers, N).
main:-
(equilibrium_index([1, 3, 5, 7, 9], I), format("~d~n", [I]); format("-1~n", _)),
(equilibrium_index([1, 2, 3, 4, 5], J), format("~d~n", [J]); format("-1~n", _)),
(equilibrium_index([2, 4, 2], K), format("~d~n", [K]); format("-1~n", _)), halt.
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- main.
4
-1
2
Notes
This problem was very "Prolog shaped" in my opinion! Just from reading the problem statement I could picture the standard Prolog predicates that could be used here. Prolog is not a language which naturally lends itself to code golf contests but in terms of simple elegance this is quite a compact solution!
References
posted at: 09:59 by: Adam Russell | path: /prolog | permanent link to this entry
2022-03-20
The Weekly Challenge 156 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate the first 10 Pernicious Numbers.
Solution
pernicious(_) --> [].
pernicious(Seen) --> [X], x(Seen, X), {set_bits(X, Bits), fd_prime(Bits)}, pernicious([X|Seen]).
x(Seen, X) --> {between(1, 100, X), \+ member(X, Seen)}.
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), !.
Sample Run
$ gprolog --consult-file prolog/ch-1.p
| ?- length(Pernicious, 10), phrase(pernicious([]), Pernicious).
Pernicious = [3,5,6,7,9,10,11,12,13,14] ?
(115 ms) yes
| ?- phrase(pernicious([]), [3, 5, 6]).
true ?
(95 ms) yes
Notes
DCGs are great aren't they? The ability to have two modes, one to test and the other to create is a joy! The logic here is pretty straightforward and more or less follows straight fromt he definition.
Part 2
Write a script to compute the first 10 distinct Padovan Primes.
Solution
weird(_) --> [].
weird(Seen) --> [X], x(Seen, X), {
findall(F, factor(X, F), Factors), flatten([1, Factors], FlatFactors),
sum_list(FlatFactors, FactorSum),
FactorSum > X,
powerset(FlatFactors, FactorSets),
maplist(sum_list, FactorSets, FactorSetSums),
\+ member(X, FactorSetSums)
},
weird([X|Seen]).
x(Seen, X) --> {between(1, 1000, X), \+ member(X, Seen)}.
powerset(X,Y):- bagof(S, subseq(S,X), Y).
subseq([], []).
subseq([], [_|_]).
subseq([X|Xs], [X|Ys] ):- subseq(Xs, Ys).
subseq([X|Xs], [_|Ys] ):- append(_, [X|Zs], Ys), subseq(Xs, Zs).
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].
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- phrase(weird([]), [70]).
true ?
yes
| ?- length(Weird, 1), phrase(weird([]), Weird).
Weird = [70] ?
(4 ms) yes
Notes
This solution follows the same generate and test approach I used in the Perl Solution, as far as the testing of the powerset of divisors is concerned anyway. (I'll admit I was too lazy to write my own powerset code so I grabbed someone else's. See the references for a link to the source.)
In my ongoing attempts to improve my DCG skills I implemented this as a DCG which is a bit of overkill for this problem, but it is always nice to be able to generate the sequence as well as validate.
References
posted at: 18:26 by: Adam Russell | path: /prolog | permanent link to this entry
2022-03-06
The Weekly Challenge 154 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to compute the first 10 distinct Padovan Primes.
Solution
:-initialization(main).
make_lists([], []).
make_lists([Word|Words], [List|Rest]):-
atom_chars(Word, List),
make_lists(Words, Rest).
missing_permutation(Word, Permutations, Missing):-
atom_chars(Word, Chars),
permutation(Chars, Permutation),
\+ member(Permutation, Permutations),
atom_chars(Missing, Permutation).
main:-
make_lists(['PELR', 'PREL', 'PERL', 'PRLE', 'PLER', 'PLRE', 'EPRL', 'EPLR', 'ERPL',
'ERLP', 'ELPR', 'ELRP', 'RPEL', 'RPLE', 'REPL', 'RELP', 'RLPE', 'RLEP',
'LPER', 'LPRE', 'LEPR', 'LRPE', 'LREP'], Permutations),
missing_permutation('PERL', Permutations, Missing),
write(Missing), nl,
halt.
Sample Run
$ gprolog --consult-file prolog/ch-1.p
LERP
Notes
This is a nice place where Prolog really shines compared to the Perl solution
to the same problem. That approach requires a good deal of care to properly generalize.
The Prolog solution is completely general without any extra work! Here we need only split
the starting word into characters and then backtrack through any possible missing
permutations with permutation/2 and member/2. Elegant!
Part 2
Write a script to compute the first 10 distinct Padovan Primes.
Solution
padovan_primes(Size, Primes, PrimesAccum, A, B, C) --> {D is B + A, fd_not_prime(D)}, [A], padovan_primes(Size, Primes, PrimesAccum, B, C, D).
padovan_primes(Size, Primes, PrimesAccum, A, B, C) --> {D is B + A, fd_prime(D), append(PrimesAccum, [D], NewPrimesAccum), length(NewPrimesAccum, L), L < Size}, [A], padovan_primes(Size, Primes, NewPrimesAccum, B, C, D).
padovan_primes(Size, Primes, PrimesAccum, A, B, _) --> {D is B + A, fd_prime(D), append(PrimesAccum, [D], NewPrimesAccum), length(NewPrimesAccum, L), L >= Size, Primes = NewPrimesAccum}, [D].
n_padovan_primes(N, Primes):-
succ(N, X),
phrase(padovan_primes(X, PadovanPrimes, [], 1, 1, 1), _),
[_|Primes] = PadovanPrimes.
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- n_padovan_primes(7, Primes).
Primes = [2,3,5,7,37,151,3329] ?
(113 ms) yes
| ?-
Notes
If you watch any of the videos on The Power of Prolog YouTube channel you'll learn
from Markus Triska that a DCG is the preferable way to handle this sort of problem.
Not just because DCGs are a convenient way to process a list in Prolog, but because they
can be used to both generate and test solutions. Excellent advice! This code above shows
this for a somewhat complicated problem. We must generate the sequence and also determine
which of the sequence terms are prime. Primality testing is performed by GNU Prolog's
fd_prime/1 and fd_not_prime/1. As the primes are found they are added, along with the
most recently computed three sequence terms, as extra arguments.
This solution is very similar to a previous bit of code for Fibonacci Strings.
References
posted at: 19:25 by: Adam Russell | path: /prolog | permanent link to this entry
2022-02-06
The Weekly Challenge 150 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given two strings having the same number of digits, $a and $b. Write a script to
generate Fibonacci Words by concatenation of the previous two strings. Print the 51st
of the first term having at least 51 digits.
Solution
fibonacci_words(Size, A, B) --> {atom_concat(A, B, C), atom_chars(C, Chars), length(Chars, N), N < Size}, [A], fibonacci_words(Size, B, C).
fibonacci_words(Size, A, B) --> {atom_concat(A, B, C), atom_chars(C, Chars), length(Chars, N), N >= Size}, [C].
fibonacci_words_nth_character(A, B, N, NthChar) :-
phrase(fibonacci_words(N, A, B), FibonacciWords),
last(FibonacciWords, LongestTerm),
atom_chars(LongestTerm, LongestTermChars),
nth(N, LongestTermChars, NthChar).
Sample Run
$ gprolog --consult-file prolog/ch-1.p
| ?- fibonacci_words_nth_character('1234', '5678', 51, N).
N = '7' ?
(2 ms) yes
| ?-
Notes
This little bit of code might be the thing I am proudest of in a while! You see, modern Prolog style generally promotes the use of DCGs for almost any list processing you might want to do. The reasons for this are that DCG code is usually easily bimodal and also testing of code is much easier. Furthermore, DCG code can be said to rely more on the Prolog engine itself backtracking versus more manual recursive style code. Of course these are general statements which are not always necessarily true. In any event I default to not using DCGs so generally, but have been making a conscious attempt to do so. This Fibonacci Words task is well suited for DCGs.
Size, A, and B are passed as extra arguments to the DCG. Some parts of the DCG might
appear a little mysterious so here is what the DCG code looks like when expanded
fibonacci_words(A, B, C, D, E) :-
atom_concat(B, C, F),
atom_chars(F, G),
length(G, H),
H < A,
D = [B|I],
fibonacci_words(A, C, F, I, E).
fibonacci_words(A, B, C, D, E) :-
atom_concat(B, C, F),
atom_chars(F, G),
length(G, H),
H >= A,
D = [F|E].
while the variable names are changed during the term expansion you can see the behavior
which may at first seem odd. The first three variables for each predicate are the "extra"
ones which carry the size information, and the most recent two terms of the sequence which
are used to compute the next term. In the DCG when we have [A] you can see what happens,
that it is expanded to unify with the first implicit argument. In the expanded version
we see D = [B|I], and in this way we create the recursive relationship to build the
sequence list. Well, of course the recursive call which follows is important too, but see
how we've now passed as the first implicit argument I which represents the
uninstantiated tail of a list and on the next call will recursively be added to.
Part 2
Write a script to generate all square-free integers <= 500.
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).
square_free(N, SquareFree):-
findall(X,
(between(1, N, X),
prime_factors(X, PrimeFactors),
sort(PrimeFactors, PrimeFactorsSorted),
msort(PrimeFactors, PrimeFactorsMSorted),
length(PrimeFactorsSorted, SortedLength),
length(PrimeFactorsMSorted, MSortedLength),
SortedLength == MSortedLength), SquareFree).
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- square_free(500, SquareFree).
SquareFree = [1,2,3,5,6,7,10,11,13,14,15,17,19,21,22,23,26,29,30,31,33,34,35,37,38,39,41,42,43,46,47,51,53,55,57,58,59,61,62,65,66,67,69,70,71,73,74,77,78,79,82,83,85,86,87,89,91,93,94,95,97,101,102,103,105,106,107,109,110,111,113,114,115,118,119,122,123,127,129,130,131,133,134,137,138,139,141,142,143,145,146,149,151,154,155,157,158,159,161,163,165,166,167,170,173,174,177,178,179,181,182,183,185,186,187,190,191,193,194,195,197,199,201,202,203,205,206,209,210,211,213,214,215,217,218,219,221,222,223,226,227,229,230,231,233,235,237,238,239,241,246,247,249,251,253,254,255,257,258,259,262,263,265,266,267,269,271,273,274,277,278,281,282,283,285,286,287,290,291,293,295,298,299,301,302,303,305,307,309,310,311,313,314,317,318,319,321,322,323,326,327,329,330,331,334,335,337,339,341,345,346,347,349,353,354,355,357,358,359,362,365,366,367,370,371,373,374,377,379,381,382,383,385,386,389,390,391,393,394,395,397,398,399,401,402,403,406,407,409,410,411,413,415,417,418,419,421,422,426,427,429,430,431,433,434,435,437,438,439,442,443,445,446,447,449,451,453,454,455,457,458,461,462,463,465,466,467,469,470,471,473,474,478,479,481,482,483,485,487,489,491,493,494,497,498,499]
(26 ms) yes
| ?-
Notes
I am re-using the prime factorization code I have use din the past, most recently in
Challenge 123.
Getting the factors is really the hardest part. Once that is doine we need to only check
to see if a number has duplicate prime factors indicating a square. To do that we sort
using msort/2 and sort/2 and see if the resulting lists are the same length. Recall
that sort/2 will remove duplicates whereas msort/2 does not. If the results of both
are the same length then we can conclude there were no square factors.
References
posted at: 16:44 by: Adam Russell | path: /prolog | permanent link to this entry
2022-01-16
The Weekly Challenge 147 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate first 20 left-truncatable prime numbers in base 10.
Solution
:-initialization(main).
left_truncatable(X):-
fd_labeling(X),
number_codes(X, C),
\+ member(48, C),
length(C, L),
findall(Truncatable, (
between(1, L, N),
length(T, N),
append(_, T, C),
number_codes(Truncatable, T),
fd_prime(Truncatable)), Truncatables),
length(Truncatables, NumberTruncatable),
L == NumberTruncatable.
first_twenty_left_truncatable(FirstTwenty):-
length(FirstTwenty, 20),
fd_domain(FirstTwenty, 1, 200),
fd_all_different(FirstTwenty),
maplist(left_truncatable, FirstTwenty),
fd_labeling(FirstTwenty).
main:-
first_twenty_left_truncatable(FirstTwenty),
write(FirstTwenty), nl,
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
[2,3,5,7,13,17,23,37,43,47,53,67,73,83,97,113,137,167,173,197]
Notes
I thought quite a while on how to best approach this problem in Prolog. The code here works well. Some knowledge of the size of the left truncatable primes lets us set the upper bound of the domain pretty tightly, but at best that is a very small optimization, if we can even really claim it as such. The change which might most effect performance is to start with a pre-generated list of primes. Especially since the density of primes is much more sparse as the numbers increase the number of unnecessary checks would be greatly reduced.
Part 2
Write a script to find the first pair of Pentagon Numbers whose sum and difference are also a Pentagon Number.
Solution
n_pentagon_numbers(0, []).
n_pentagon_numbers(N, [H|T]):-
H #= N * (3 * N - 1) / 2,
Next #= N - 1,
n_pentagon_numbers(Next, T).
first_pair_pentagon(FirstPair):-
n_pentagon_numbers(10000, Pentagons),
fd_domain([X, Y, Sum, AbsoluteDifference], Pentagons),
Sum #= X + Y,
Difference #= X - Y,
((
Difference #< 0,
AbsoluteDifference #= -1 * Difference
); AbsoluteDifference #= Difference),
fd_labeling([X, Y]),
FirstPair = [X, Y].
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- first_pair_pentagon(FirstPair).
FirstPair = [7042750,1560090] ?
Notes
Apparently GNU Prolog does not define an absolute value function for FD vars. Perhaps because of some theoretical limitation I am unaware of? No matter, some extra code takes care of that. Frankly, the bigger issue is that in this case the use of an FD solver doesn't really help much beyond a pure Prolog one. Again, I may be unaware of what is happening under the hood, but performance wise it doesn't seem any better to constrain the domains of the variables versus an outright "generate and test".
References
posted at: 13:06 by: Adam Russell | path: /prolog | permanent link to this entry
2021-12-19
The Weekly Challenge 143 (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, $s, containing mathematical expression. Write a script to print the result of the mathematical expression. To keep it simple, please only accept + - * ().
Solution
:-initialization(main).
expression(Answer) --> term(Answer).
expression(Answer) --> term(Answer0), [(+)], expression(Answer1), {Answer is Answer0 + Answer1}.
expression(Answer) --> term(Answer0), [(-)], expression(Answer1), {Answer is Answer0 - Answer1}.
term(Answer) --> operand(Answer).
term(Answer) --> operand(Answer0), [(*)], term(Answer1), {Answer is Answer0 * Answer1}.
term(Answer) --> operand(Answer0), [(/)], term(Answer1), {Answer is Answer0 / Answer1}.
operand(X) --> [X], {number(X)}.
operand(Answer) --> ['('], expression(Answer), [')'].
calculator(Expression, Answer):-
phrase(expression(Answer), Expression).
main:-
calculator([10, (+), 20, (-), 5], AnswerA),
write(AnswerA), nl,
calculator(['(', 10, (+), 20, (-), 5, ')', (*), 2], AnswerB),
write(AnswerB), nl,
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
25
50
Notes
This is the sort of problem which is just so clean and straightforward to implement in Prolog. A DCG is used to describe the expected infix notation of the calculator and that pretty much takes care of it.
Part 2
You are given a positive number, $n. Write a script to find out if the given number is a Stealthy Number.
Solution
:-initialization(main).
stealthy(N):-
fd_domain(S, 2, N),
fd_domain(T, 2, N),
fd_domain(U, 2, N),
fd_domain(V, 2, N),
S * T #= N,
U * V #= N,
S + T #= U + V + 1,
fd_labeling([S, T, U, V]).
main:-
(stealthy(36), format("~d~n", [1]);format("~d~n", [0])),
(stealthy(12), format("~d~n", [1]);format("~d~n", [0])),
(stealthy(6), format("~d~n", [1]);format("~d~n", [0])),
halt.
Sample Run
$ gplc prolog/ch-2.p
$ prolog/ch-2
1
1
0
Notes
Much like Part 1 of this weeks challenge Prolog really shines in terms of providing a short clean solution. Here we describe the desired property in terms of finite domain variables and Prolog let's us know if any values exist which match those constraints.
References
posted at: 19:56 by: Adam Russell | path: /prolog | permanent link to this entry
2021-12-13
Constructing a Plot in gnuplot Using Gnu Prolog
Part 1
Advent of Code 2021 Day 13, in summary, involves the simulation of folding a transparent piece of paper. When "folded" properly a correct solution yields points which when plotted reveal a code which is the solution to a puzzle!
Not wanting to spend too much time on plotting I first considered dumping the points to a
file and then using a plotting program like gnuplot directly. In the spirit of having a
complete self-contained solution, however, I explored what could be done be interfacing
with gnuplot using GNU Prolog's popen/3. This worked very well!
Solution
:-dynamic(dots/1).
:-initialization(main).
check_and_read(10, [] ,_):-
!.
check_and_read(13, [], _):-
!.
check_and_read(32, [], _):-
!.
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).
gnuplot_command(Command, PlotStream):-
repeat, % START REPEAT
length(Command, CommandLength),
between(1, CommandLength, N),
nth(N, Command, CommandCode),
put_code(PlotStream, CommandCode),
N == CommandLength, % END REPEAT
nl(PlotStream).
plot_configuration(PlotStream):-
popen('/usr/pkg/bin/gnuplot', 'write', PlotStream),
gnuplot_command("set terminal postscript eps size 9, 2 enhanced color font 'Courier, 11'", PlotStream),
gnuplot_command("set output '13.eps'", PlotStream),
gnuplot_command("set yrange [:] reverse", PlotStream),
gnuplot_command("plot '-' u 1:2 t 'Code' with points pointtype 7 pointsize 2", PlotStream).
plot_dots(PlotStream):-
findall(_,(
dots(X-Y),
atom_codes(X, CodesA),
atom_codes(Y, CodesY),
append(CodesA, [32|CodesY], DataCodes),
length(DataCodes, CodesLength),
findall(_,(
between(1, CodesLength, N),
nth(N, DataCodes, DataCode),
put_code(PlotStream, DataCode)
),_),
nl(PlotStream)
), _).
plot:-
plot_configuration(PlotStream),
plot_dots(PlotStream),
[Exit] = "e",
put_code(PlotStream, Exit),
nl(PlotStream),
close(PlotStream).
make_transparency(Records, Folds):-
make_transparency(Records, [], Folds).
make_transparency([], Folds, Folds).
make_transparency([fold, along, Fold|Records], FoldAccum, Folds):-
make_transparency(Records, [Fold|FoldAccum], Folds).
make_transparency([H|Records], FoldAccum, Folds):-
atom_codes(H, C),
C \== [],
append([Y], Rest, Records),
asserta(dots(H-Y)),
make_transparency(Rest, FoldAccum, Folds).
make_transparency([H|Records], FoldAccum, Folds):-
atom_codes(H, C),
C == [],
make_transparency(Records, FoldAccum, Folds).
fold_up(Line):-
findall(Yn, (dots(X-Y), number_atom(Yn, Y)), Yns),
max_list(Yns, MaxY),
Half is div(MaxY, 2),
number_atom(LineN, Line),
findall(_,(
dots(X-Y),
number_atom(Yn, Y),
Yn > LineN,
Y0 is LineN - Yn + Half,
number_atom(Y0, Ya),
retract(dots(X-Y)),
retractall(dots(X-Ya)),
asserta(dots(X-Ya))
), _).
fold_left(Line):-
findall(Xn, (dots(X-Y), number_atom(Xn, X)), Xns),
max_list(Xns, MaxX),
Half is div(MaxX, 2),
number_atom(LineN, Line),
findall(_,(
dots(X-Y),
number_atom(Xn, X),
Xn > LineN,
X0 is LineN - Xn + Half,
number_atom(X0, Xa),
retract(dots(X-Y)),
retractall(dots(Xa-Y)),
asserta(dots(Xa-Y))
), _).
fold_transparency([], _).
fold_transparency(Folds, Count):-
append(F, [Fold], Folds),
atom_codes(Fold, [Axis, 61|Location]),
atom_codes(Direction, [Axis]),
atom_codes(Line, Location),
((Direction == x, fold_left(Line))
;
(Direction == y, fold_up(Line))),
findall(X-Y,dots(X-Y), Dots),
length(Dots, Count),
fold_transparency(F, _).
transparency(Records, Count):-
make_transparency(Records, Folds),
fold_transparency(Folds, Count),
plot.
main:-
open('data', read, Stream),
read_data(Stream, Records),
close(Stream),
transparency(Records, _),
halt.
The results
Notes
When first plotted the data I did not set the image size and so the default resulted in a
squared image which obscured the characters which are supposed to be visible. The
size 9, 2 part of the terminal configuration is to set an aspect ratio for easy reading
of the resulting characters. set yrange [:] reverse is necessary to re-orient the
gnuplot axis to match the axis of the puzzle data.
Anyway, I've never used popen/3 before and was very happy to find that it was so easy to
use to come up quickly with fully working solution. Especially when rushing to complete a
coding puzzle as quickly as I could. Another testament to GNU Prolog's clean design!
References
posted at: 15:42 by: Adam Russell | path: /prolog | permanent link to this entry
2021-11-28
The Weekly Challenge 140 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given two decimal-coded binary numbers, $a and $b. Write a script to simulate the addition of the given binary numbers.
Solution
:-initialization(main).
sum_carry(0, 0, 1, 1, 1).
sum_carry(1, 0, 1, 0, 0).
sum_carry(0, 1, 1, 1, 0).
sum_carry(0, 1, 0, 1, 1).
sum_carry(0, 0, 0, 0, 0).
sum_carry(1, 0, 0, 0, 1).
sum_carry(0, 1, 1, 0, 1).
sum_carry(1, 0, 0, 1, 0).
sum_carry(0, 1, 1, 1).
sum_carry(1, 0, 0, 1).
sum_carry(0, 0, 0, 0).
sum_carry(1, 0, 1, 0).
add_binary(A, B, Sum):-
number_chars(A, AChars),
number_chars(B, BChars),
reverse(AChars, ACharsReverse),
reverse(BChars, BCharsReverse),
add_binary(ACharsReverse, BCharsReverse, 0, [], Sum).
add_binary([], [], 0, SumAccum, Sum):-
number_chars(Sum, SumAccum).
add_binary([], [], 1, SumAccum, Sum):-
number_chars(Sum, ['1'|SumAccum]).
add_binary([H|T], [], Carry, SumAccum, Sum):-
number_chars(D, [H]),
sum_carry(S, C, D, Carry),
number_chars(S, [N]),
add_binary(T, [], C, [N | SumAccum], Sum).
add_binary([H0|T0], [H1|T1], Carry, SumAccum, Sum):-
number_chars(D0, [H0]),
number_chars(D1, [H1]),
sum_carry(S, C, D0, D1, Carry),
number_chars(S, [N]),
add_binary(T0, T1, C, [N | SumAccum], Sum).
main:-
add_binary(11, 1, X0),
write(X0), nl,
add_binary(101, 1, X1),
write(X1), nl,
add_binary(100, 11, X2),
write(X2), nl,
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
100
110
111
Notes
The approach here may seem just a little strange for "simulating a binary addition", but it seemed like a fun idea, given the small number of combinations, to just store all the intermediate results and then retrieve them as needed. This all seems to work ok, except that maybe going back and forth between numbers and chars is a little clunky.
Part 2
You are given 3 positive integers, $i, $j and $k. Write a script to print the $kth element in the sorted multiplication table of $i and $j.
Solution
:-initialization(main).
multiply(I, J, N):-
between(1, I, Ith),
between(1, J, Jth),
N is Ith * Jth.
multiplication_table(I, J, Table):-
bagof(N, multiply(I, J, N), Table).
nth_from_table(I, J, K, N):-
multiplication_table(I, J, Table),
msort(Table, SortedTable),
nth(K, SortedTable, N).
main:-
nth_from_table(2, 3, 4, N0),
write(N0), nl,
nth_from_table(3, 3, 6, N1),
write(N1), nl,
halt.
Sample Run
$ gplc prolog/ch-2.p
$ prolog/ch-2
3
4
Notes
It's maybe a little confusing, to me anyway, that GNU Prolog's msort/2 does not merge
duplicates but sort/2 does. Other than that I have to say that I really like this bit of
Prolog. It seems very clean to me in that no recursion was required, everything is handled
via Prolog itself.
References
posted at: 16:59 by: Adam Russell | path: /prolog | permanent link to this entry
2021-11-21
The Weekly Challenge 139 (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 numbers. Write a script to implement JortSort. It should return true/false depending if the given list of numbers are already sorted.
Solution
:-initialization(main).
jort([]).
jort([H0, H1|[]]):-
H1 >= H0.
jort([H0, H1|T]):-
H1 >= H0,
jort([H1|T]).
main:-
(jort([1, 2, 3, 4, 5]), format("1~n", _); format("0~n", _)),
(jort([1, 3, 2, 4, 5]), format("1~n", _); format("0~n", _)),
(jort([1, 2, 3, 4, 5, 6]), format("1~n", _); format("0~n", _)),
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
1
0
1
Notes
I had never heard of a Jort Sort before this week. Once I understand what it was, a joke function which just returns true or false based on whether a given list is already sorted, I am still not sure I really get it. Or, at least, I don't really get the "joke". Apparently it started as a JavaScript thing so maybe there is something inherently funny about the JavaScript code for it.
Anyway, this is pretty easily done in Prolog especially in this case where we only are
to be given a list of numbers. The code as written only goes in one direction in that it
only verifies a list as requested. This could go in the other direction with a little
use of between/3 and generate a sorted list too. But would that ruin the joke? Make it
funnier? I found the whole exercise so unamusing I didn't bother!
Maybe the amusing part of this whole "joke" sort was, ironically, just how stupid I found the whole thing.
References
posted at: 16:33 by: Adam Russell | path: /prolog | permanent link to this entry
2021-10-31
The Weekly Challenge 136 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given 2 positive numbers, $m and $n. Write a script to find out if the given two numbers are Two Friendly.
Solution
:-initialization(main).
two_friendly(M, N):-
current_prolog_flag(max_integer, MAX_INTEGER),
between(1, MAX_INTEGER, M),
between(1, MAX_INTEGER, N),
GCD is gcd(M, N),
P is log(2, GCD),
P0 is ceiling(P),
P1 is floor(P),
P0 == P1.
main:-
(two_friendly(8, 24), format("1~n", _); format("0~n", _)),
(two_friendly(26, 39), format("1~n", _); format("0~n", _)),
(two_friendly(4, 10), format("1~n", _); format("0~n", _)),
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
1
0
1
Notes
Evn after years of writing Prolog I still get quite a kick out of its inherent power. Here
the two_friendly/2 predicate not only verifies for any M and N but also is
multi-modal and can generate pairs for any M and N as well!
Part 2
You are given a positive number $n. Write a script to find how many different sequences you can create using Fibonacci numbers where the sum of unique numbers in each sequence are the same as the given number.
Solution
fibonaccis_below_n(N, Fibonaccis):-
fibonaccis_below_n(N, Fibonaccis, 0, [1, 1]).
fibonaccis_below_n(-1, Fibonaccis, _, Fibonaccis):- !.
fibonaccis_below_n(N, Fibonaccis, Sum, PartialFibonaccis):-
[H0, H1 | _] = PartialFibonaccis,
F is H0 + H1,
F < N,
fibonaccis_below_n(N, Fibonaccis, Sum, [F|PartialFibonaccis]).
fibonaccis_below_n(N, Fibonaccis, Sum, PartialFibonaccis):-
[H0, H1 | _] = PartialFibonaccis,
F is H0 + H1,
F > N,
fibonaccis_below_n(-1, Fibonaccis, Sum, PartialFibonaccis).
sum_x([], 0).
sum_x([X|Xs], X+Xse):-
sum_x(Xs, Xse).
sum_lists(X, N, Xsub):-
sublist(Xsub, X),
sum_x(Xsub, Xe),
N #= Xe.
fibonacci_sum_clp(N, Summands):-
fibonaccis_below_n(N, Fibonaccis),
sum_lists(Fibonaccis, N, Summands).
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- setof(Summands, fibonacci_sum_clp(16, Summands), S).
S = [[8,5,2,1],[8,5,3],[13,2,1],[13,3]]
(1 ms) yes
Notes
Instead of using a pre-computed list of Fibonacci numbers we generate them as needed. No
particular reason other than it's a little more fun, and also it allows us to flexibly
allow for virtually any value for N.
I just realized as I am looking at the code that I may have slightly misnamed the
fibonacci_sum_clp/2 predicate! I was experimenting with different approaches including
a clpfd one. This is clearly not really using clpfd though! Instead sublist/2 is used
to generate and test all possible sublists of the Fibonacci subsequence with values
less than N.
References
posted at: 20:09 by: Adam Russell | path: /prolog | permanent link to this entry
2021-10-24
The Weekly Challenge 135 (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. Write a script find out the middle 3-digits of the given integer, if possible, otherwise show a sensible error message.
Solution
:-initialization(main).
middle_three(N, Middle3):-
number_chars(N, Chars),
N > 0,
length(Chars, Length),
Length > 2,
IsOdd is Length mod 2, IsOdd == 1,
length(M3, 3),
PrefixLength is ceiling(Length / 2) - 2,
length(Prefix, PrefixLength),
append(Prefix, Middle, Chars),
append(M3, _, Middle),
number_chars(Middle3, M3).
middle_three(N, Middle3):-
(N < 0, N0 is abs(N), middle_three(N0, Middle3));
(number_chars(N, Chars), length(Chars, Length), Length < 3, format("too short~n", _));
(number_chars(N, Chars), length(Chars, Length), IsOdd is Length mod 2, IsOdd == 0, format("even number of digits~n", _));
middle_three(N, Middle3).
main:-
middle_three(1234567, Middle3),
((nonvar(Middle3), format("~d~n", [Middle3]), halt);
halt).
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
345
Notes
Interestingly this is one of the rare cases where a Prolog solution follows a fairly similar approach a [Perl solution to the same problem0(http://www.rabbitfarm.com/cgi-bin/blosxom/2021/10/24/perl).
Part 2
You are given 7-characters alphanumeric SEDOL. Write a script to validate the given SEDOL. Print 1 if it is a valid SEDOL otherwise 0.
Solution
:-initialization(main).
weight(1, 1).
weight(2, 3).
weight(3, 1).
weight(4, 7).
weight(5, 3).
weight(6, 9).
base --> alphanumeric, alphanumeric, alphanumeric, alphanumeric, alphanumeric, alphanumeric.
alphanumeric --> [AlphaNumeric], {letter_or_digit(AlphaNumeric)}.
sedol(Sedol):-
var(Sedol),
sedol(_, Sedol).
sedol(Sedol):-
nonvar(Sedol),
length(Base, 6),
append(Base, [CheckDigit], Sedol),
phrase(base, Base),
compute_check(Base, ComputedCheckDigit),
CheckDigit == ComputedCheckDigit.
sedol(Base, Sedol):-
phrase(base, Base),
check_digit(Base, Sedol).
letter_or_digit(A):-
nonvar(A),
atom_codes(A, C),
((C >= 66, C =< 90);
(C >= 48, C =< 57)).
letter_or_digit(A):-
var(A),
((between(66, 90, C)); %B through Z
(between(48, 57, C))), %0-9
atom_codes(A, [C]).
compute_check(Base, CheckSum):-
compute_check(Base, 1, CheckSum, 0).
compute_check([], _, CheckSum, PartialCheckSum):-
CheckSum is mod(10 - mod(PartialCheckSum, 10), 10).
compute_check([H|T], Index, CheckSum, PartialCheckSum):-
atom_codes(H, [C]),
between(66, 90, C),
weight(Index, Weight),
LetterValue is C - 64 + 9,
Partial is PartialCheckSum + (LetterValue * Weight),
succ(Index, I),
compute_check(T, I, CheckSum, Partial).
compute_check([H|T], Index, CheckSum, PartialCheckSum):-
atom_codes(H, [C]),
between(48, 57, C),
weight(Index, Weight),
NumeralValue is C - 48,
Partial is PartialCheckSum + (NumeralValue * Weight),
succ(Index, I),
compute_check(T, I, CheckSum, Partial).
check_digit(Base, BaseCheckDigit):-
compute_check(Base, CheckDigit),
append(Base, [CheckDigit], BaseCheckDigit).
main:-
(sedol(['2','9','3','6','9','2',1]), format("1~n", _);
format("0~n", _)),
(sedol(['1','2','3','4','5','6',7]), format("1~n", _);
format("0~n", _)),
(sedol(['B','0','Y','B','K','L',9]), format("1~n", _);
format("0~n", _)),
halt.
Sample Run
$ gplc prolog/ch-2.p
$ prolog/ch-2
1
0
1
Notes
I had originally hoped to have all code for this using almost exclusively DCGs. Things got a bit unwieldy with the checksum computation and so I dialed that back a bit, so to speak. Here the DCG part is for validating or generating a SEDOL base 6 digits sequence and the check digit is computed using regular Prolog predicates.
The rules around SEDOLs are a bit more complex than this problem lets on. I won't recount them all here, but suffice to say we are dealing with a quite idealized set of validations here. For example, prior to 2004 only numerals were allowed, but since then letters are allowed. But only a numeral can follow a letter. Again, though, those are only rules that apply for a certain time range.
Here we are just checking on length, whether or not the SEDOl contains all numerals and/or (uppercase) letter, and the checksum validation.
References
posted at: 15:17 by: Adam Russell | path: /prolog | permanent link to this entry
2021-10-17
The Weekly Challenge 134 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate first 5 Pandigital Numbers in base 10.
Solution
:-initialization(first_5_pandigitals).
pandigital(Pandigitals):-
Digits = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9],
Pandigitals = [A, B, C, D, E, F, G, H, I, J],
fd_domain([A, B, C, D, E, F, G, H, I, J], Digits),
A #= 1,
B #= 0,
fd_labeling(Pandigitals).
first_5_pandigitals:-
setof(P, pandigital(P), Pandigitals),
sort(Pandigitals, [A, B, C, D, E | _ ]),
print_pandigitals([A, B, C, D, E]).
print_pandigitals([]).
print_pandigitals([H|T]):-
maplist(number_codes, H, Codes),
flatten(Codes, DigitCodes),
number_codes(Number, DigitCodes),
write(Number), nl,
print_pandigitals(T).
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
1023456789
1023456798
1023456879
1023456897
1023456978
Notes
Rather than recursively iterate over numbers like in the Perl solution I instead use a bit of constraint programming to generate and test a large number of candidates. I then take only the first five as required. A bit of intuition, based on the definition, reduces the number of candidates generated: the first digit will clearly be a 1, the second a 0.
This runs pretty quickly, yet another testimonial to the design and implementation of GNU Prolog's FD solver. On my 2018 Mac Mini it ran to completion in about second. This is much faster than the brute force Perl solution which takes about 20s on the same machine.
Part 2
You are given 2 positive numbers, $m and $n. Write a script to generate multiplication table and display count of distinct terms.
Solution
:-initialization(main).
table(M, N, K):-
between(1, M, I),
between(1, N, J),
K is I * J.
print_table(M, N, Distinct):-
findall(K, table(M, N, K), Ks),
setof(K, table(M, N, K), Distinct),
print_header(M, N),
print_seperator(M, N),
print_rows(M, N, Ks),
maplist(number_chars, Distinct, DistinctRow),
maplist(add_space, DistinctRow, DistinctSpaced),
flatten(DistinctSpaced, DistinctSpacedFlattened),
format("~nDistinct Terms: ~S~n", [DistinctSpacedFlattened]),
length(Distinct, Count),
format("Count: ~d ~n", [Count]).
print_rows(0, _, _).
print_rows(M, N, Products):-
length(Row, N),
append(Rest, Row, Products),
M0 is M - 1,
print_rows(M0, N, Rest),
maplist(number_chars, Row, RowChars),
maplist(add_space, RowChars, CharsSpaced),
flatten(CharsSpaced, CharsSpacedFlattened),
format(" ~n ~d | ~S ", [M, CharsSpacedFlattened]).
print_header(_, N):-
format(" x | ", _),
print_header(N).
print_header(0).
print_header(N):-
N0 is N - 1,
print_header(N0),
format("~d ", [N]).
print_seperator(_, N):-
format("~n --+-", _),
print_seperator(N).
print_seperator(0).
print_seperator(N):-
N0 is N - 1,
print_seperator(N0),
format("~a", ['--']).
add_space(C, CS):-
flatten(C, F),
append(F, [' '], FS),
atom_chars(A, FS),
atom_chars(A, CS).
main:-
print_table(3, 3, _), nl, nl,
print_table(3, 5, _),
halt.
Sample Run
$ gplc prolog/ch-2.p
$ prolog/ch-2
x | 1 2 3
--+-------
1 | 1 2 3
2 | 2 4 6
3 | 3 6 9
Distinct Terms: 1 2 3 4 6 9
Count: 6
x | 1 2 3 4 5
--+-----------
1 | 1 2 3 4 5
2 | 2 4 6 8 10
3 | 3 6 9 12 15
Distinct Terms: 1 2 3 4 5 6 8 9 10 12 15
Count: 11
Notes
This was an interesting exercise in formatting output in Prolog! As can be seen, the vast
majority of the code here is to format the table in the required way. I haven't ever done
all that much with format/2, but it is quite versatile. As far as formatting output goes
it provides a solid set of primitives in the spirit of C's printf that allow for
us to do whatever we want, albeit with a bit of work.
The actual computation of the value takes no more than the first half dozen or so lines of
code in table/3 and print_table/3.
References
posted at: 12:55 by: Adam Russell | path: /prolog | permanent link to this entry
2021-08-29
The Weekly Challenge 127 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given two sets with unique numbers. Write a script to figure out if they are disjoint.
Solution
:-initialization(main).
conflicts(List0, List1):-
member(X, List0),
member(X, List1).
disjoint(List0, List1):-
\+ conflicts(List0, List1).
main:-
((disjoint([1, 2, 5, 3, 4], [4, 6, 7, 8, 9]), write(1)); (write(0))),
nl,
((disjoint([1, 3, 5, 7, 9], [0, 2, 4, 6, 8]), write(1)); (write(0))),
nl,
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
0
1
Notes
The conflcts/2 predicate establishes whether or not if there is any overlapping elements
in the two lists. To establish whether the sets are disjoint disjoint/2 examines the
negation of this result.
Remember, Prolog only backtracks on failure and not success. This fits nicely for what we
want. We only care if the lists have any overlap whatsoever. So using backtracking
conflicts/2 will backtrack for all members of List0 until it either succeeds in finding
an element that is also in List1 or, if none, fails completely indicating a disjoint set.
Since we actually consider the discovery of disjoint sets a success we negate the result
with \+ in disjoint/2.
Part 2
You are given a list of intervals. Write a script to determine conflicts between the intervals.
Solution
:-initialization(main).
conflicts(Intervals, Conflicts):-
conflicts(Intervals, Conflicts, []).
conflicts([_|[]], Conflicts, ConflictsAccum):-
sort(ConflictsAccum, Conflicts).
conflicts([H|T], Conflicts, ConflictsAccum):-
last(T, Last),
append(Intervals, [Last], T),
append([H], Intervals, CompareIntervals),
comparisons(Last, CompareIntervals, HasConflicts),
append(ConflictsAccum, HasConflicts, ConflictsAccumUpdated),
conflicts(CompareIntervals, Conflicts, ConflictsAccumUpdated).
comparisons(Interval, CompareIntervals, Conflicts):-
comparisons(Interval, CompareIntervals, Conflicts, []).
comparisons(_, [], Conflicts, Conflicts).
comparisons(Interval, [[H0|T0]|T], Conflicts, ConflictsAccum):-
[I|J] = Interval,
I >= H0,
I =< T0,
comparisons([I|J], T, Conflicts, [Interval|ConflictsAccum]).
comparisons([I|J], [_|T], Conflicts, ConflictsAccum):-
comparisons([I|J], T, Conflicts, ConflictsAccum).
main:-
conflicts([[1, 4], [3, 5], [6, 8], [12, 13], [3, 20]], Conflicts0),
write(Conflicts0), nl,
conflicts([[3, 4], [5, 7], [6, 9], [10, 12], [13, 15]], Conflicts1),
write(Conflicts1), nl,
halt.
Sample Run
$ gplc prolog/ch-2.p
$ prolog/ch-2
[[3,5],[3,20]]
[[6,9]]
Notes
The examples given in the problem statement are with the [minimum, maximum] intervals
sorted by the maximum value. This makes the problem a bit easier since then we need only
check to see if, when working down the sorted list, if the minimum is in one of the other
intervals.
This is mostly all handled using recursion which keeps with the nature of the examples in the problem statement. This is fine, and obviously works, but after having worked out the details of finding a solution it seems there is room to make this more, well, logical?
Preferring reasoning over recursion as a principle of Prolog development seems to be reasonable (pun intended!). Here we might, for example, arrange the intervals in Key-Value pairs stored in the Prolog database and make better use of built in backtracking. But even that would include a little extra work as we would need to sort the pairs by value and ultimately the same number of lines of code would be written as shown here, it would just arguably be a bit more Prological.
Sometimes the best solution to a problem is only discovered after working on it for a bit using alternative means!
References
posted at: 11:21 by: Adam Russell | path: /prolog | permanent link to this entry
2021-08-22
The Weekly Challenge 126 (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 print count of numbers from 1 to $N that don’t contain digit 1.
Solution
:-initialization(main).
has_1(N):-
number_codes(N, Codes),
memberchk(49, Codes).
count_numbers_without_1(N, Count):-
count_numbers_without_1(N, 0, Count).
count_numbers_without_1(1, Count, Count).
count_numbers_without_1(N, CountAccum, Count):-
\+ has_1(N),
succ(CountAccum, C),
N0 is N - 1,
count_numbers_without_1(N0, C, Count).
count_numbers_without_1(N, CountAccum, Count):-
has_1(N),
N0 is N - 1,
count_numbers_without_1(N0, CountAccum, Count).
main:-
count_numbers_without_1(15, Count0),
write(Count0), nl,
count_numbers_without_1(25, Count1),
write(Count1), nl,
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
8
13
Notes
The count_numbers_without_1 predicates recurse over the range of numbers and tally the
qualifying numbers at each step. has_1/1 converts the numeral to the list of associated
ascii codes and then we see if the ascii code for '1' (49) is present.
Part 2
You are given a rectangle with points marked with either x or *. Please consider the x as a land mine. Write a script to print a rectangle with numbers and x as in the Minesweeper game.
Solution
:-initialization(main).
rows(5).
columns(10).
grid([x, '*', '*', '*', x, '*', x, x, x, x,
'*', '*', '*', '*', '*', '*', '*', '*', '*', x,
'*', '*', '*', '*', x, '*', x, '*', x, '*',
'*', '*', '*', x, x, '*', '*', '*', '*', '*',
x, '*', '*', '*', x, '*', '*', '*', '*', x]).
write_grid([H|T]):-
write('\t'),
write_grid([H|T], 0).
write_grid([], _).
write_grid([H|T], Counter):-
columns(Columns),
succ(Counter, C),
M is C mod Columns,
M \== 0,
write(H),
write(' '),
write_grid(T, C).
write_grid([H|T], Counter):-
columns(Columns),
C is Counter + 1,
M is C mod Columns,
M == 0,
write(H),
((rows(Rows),
columns(Columns),
Cells is Rows * Columns,
C \== Cells,
nl,
write('\t'),
write_grid(T, C)
);
(
write_grid(T, C)
)).
minecount(List, MineCount):-
minecount(List, 0, MineCount).
minecount([], MineCount, MineCount).
minecount([H|T], MineCountPartial, MineCount):-
H == x,
MCP is MineCountPartial + 1,
minecount(T, MCP, MineCount).
minecount([H|T], MineCountPartial, MineCount):-
H \== x,
minecount(T, MineCountPartial, MineCount).
adjacent_bottomleft(Cell, Grid, AdjacentCell):-
columns(Columns),
Columns1 is Columns - 1,
C is Cell + Columns1,
C > 0,
M0 is Cell mod Columns,
M1 is C mod Columns,
((M0 \== 0, M0 \==1, M1 < M0);
(M0 == 0, M1 == Columns1)),
nth(C, Grid, AdjacentCell).
adjacent_bottomleft(_, _, AdjacentCell):-
AdjacentCell = null.
adjacent_left(Cell, Grid, AdjacentCell):-
columns(Columns),
Columns1 is Columns - 1,
C is Cell - 1,
C > 0,
M0 is Cell mod Columns,
M1 is C mod Columns,
((M0 \== 0, M0 \==1, M1 < M0);
(M0 == 0, M1 == Columns1)),
nth(C, Grid, AdjacentCell).
adjacent_left(_, _, AdjacentCell):-
AdjacentCell = null.
adjacent_topleft(Cell, Grid, AdjacentCell):-
columns(Columns),
Columns1 is Columns - 1,
C is Cell - (Columns + 1),
C > 0,
M0 is Cell mod Columns,
M1 is C mod Columns,
((M0 \== 0, M0 \==1, M1 < M0);
(M0 == 0, M1 == Columns1)),
nth(C, Grid, AdjacentCell).
adjacent_topleft(_, _, AdjacentCell):-
AdjacentCell = null.
adjacent_bottomright(Cell, Grid, AdjacentCell):-
columns(Columns),
Columns1 is Columns - 1,
C is Cell + (Columns + 1),
C > 0,
M0 is Cell mod Columns,
M1 is C mod Columns,
((M1 > M0, M0 \== 0);
(M1 == 0, M0 == Columns1)),
nth(C, Grid, AdjacentCell).
adjacent_bottomright(_, _, AdjacentCell):-
AdjacentCell = null.
adjacent_right(Cell, Grid, AdjacentCell):-
columns(Columns),
Columns1 is Columns - 1,
C is Cell + 1,
C > 0,
M0 is Cell mod Columns,
M1 is C mod Columns,
((M1 > M0, M0 \== 0);
(M1 == 0, M0 == Columns1)),
nth(C, Grid, AdjacentCell).
adjacent_right(_, _, AdjacentCell):-
AdjacentCell = null.
adjacent_topright(Cell, Grid, AdjacentCell):-
columns(Columns),
Columns1 is Columns - 1,
C is Cell - Columns1,
M0 is Cell mod Columns,
M1 is C mod Columns,
((M1 > M0, M0 \== 0);
(M1 == 0, M0 == Columns1)),
nth(C, Grid, AdjacentCell).
adjacent_topright(_, _, AdjacentCell):-
AdjacentCell = null.
adjacent_up(Cell, Grid, AdjacentCell):-
columns(Columns),
C is Cell - Columns,
C > 0,
nth(C, Grid, AdjacentCell).
adjacent_up(_, _, AdjacentCell):-
AdjacentCell = null.
adjacent_down(Cell, Grid, AdjacentCell):-
columns(Columns),
C is Cell + Columns,
C > 0,
nth(C, Grid, AdjacentCell).
adjacent_down(_, _, AdjacentCell):-
AdjacentCell = null.
adjacent(Cell, Grid, AdjacentCells):-
adjacent_left(Cell, Grid, AdjacentCellLeft),
adjacent_right(Cell, Grid, AdjacentCellRight),
adjacent_up(Cell, Grid, AdjacentCellUp),
adjacent_down(Cell, Grid, AdjacentCellDown),
adjacent_topleft(Cell, Grid, AdjacentCellTopLeft),
adjacent_topright(Cell, Grid, AdjacentCellTopRight),
adjacent_bottomleft(Cell, Grid, AdjacentCellBottomLeft),
adjacent_bottomright(Cell, Grid, AdjacentCellBottomRight),
AdjacentCells = [AdjacentCellLeft, AdjacentCellRight, AdjacentCellUp, AdjacentCellDown,
AdjacentCellTopLeft, AdjacentCellTopRight, AdjacentCellBottomLeft,
AdjacentCellBottomRight],!.
make_grid(Grid, NewGrid):-
make_grid(Grid, 1, [], NewGrid).
make_grid(Grid, Counter, NewGridPartial, NewGrid):-
nth(Counter, Grid, CurrentCell),
CurrentCell \== x,
adjacent(Counter, Grid, AdjacentCells),
minecount(AdjacentCells, MineCount),
append(NewGridPartial, [MineCount], NGP),
((rows(Rows),
columns(Columns),
Cells is Rows * Columns,
Counter == Cells,
!,
NewGrid = NGP
);
(succ(Counter, C),
make_grid(Grid, C, NGP, NewGrid))).
make_grid(Grid, Counter, NewGridPartial, NewGrid):-
nth(Counter, Grid, CurrentCell),
CurrentCell == x,
append(NewGridPartial, [CurrentCell], NGP),
((rows(Rows),
columns(Columns),
Cells is Rows * Columns,
Counter == Cells,
!,
NewGrid = NGP
);
(succ(Counter, C),
make_grid(Grid, C, NGP, NewGrid))).
main:-
grid(Grid),
write('Input:'), nl,
write_grid(Grid), nl,
make_grid(Grid, NewGrid),
write('Output:'), nl,
write_grid(NewGrid), nl,
halt.
Sample Run
$ gplc prolog/ch-2.p
$ prolog/ch-2
Input:
x * * * x * x x x x
* * * * * * * * * x
* * * * x * x * x *
* * * x x * * * * *
x * * * x * * * * x
Output:
x 1 0 1 x 2 x x x x
1 1 0 2 2 4 3 5 5 x
0 0 1 3 x 3 x 2 x 2
1 1 1 x x 4 1 2 2 2
x 1 1 3 x 2 0 0 1 x
Notes
For every cell C which does not contain a mine (x) we need to look at all eight adjacent cells and count the number of mines they contain. The number of mines in the adjacent cells is then set as C's label.
Obtaining the contents of the adjacent cells gets a little tedious. In fact, doing so is the majority of the code here. Care must be taken to make sure that we do not accidentally look for a cell which does not exist or is not actually adjacent. The logic for find the adjacent cells in this way is re-used from a coding challenge I did last year. The Advent of Code 2020 Day 11, in part, had a similar requirement.
After the logic of determining the contents of adjacent cells is worked out, the rest proceeds in a much less complicated way. The contents of all the adjacent cells are examined for mines and the cell labels are set appropriately.
References
posted at: 17:38 by: Adam Russell | path: /prolog | permanent link to this entry
2021-08-01
The Weekly Challenge 123 (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 >= 1. Write a script to find the nth Ugly Number.
Solution
:-initialization(main).
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).
ugly(N, UglyNumber):-
ugly(N, 1, 1, _, UglyNumber).
ugly(1, _, _, _, 1).
ugly(N, _, N, UglyNumber, UglyNumber).
ugly(N, X, I, _, UglyNumber):-
prime_factors(X, Factors),
member(Factor, Factors),
(Factor == 2; Factor == 3; Factor == 5),
X0 is X + 1,
I0 is I + 1,
ugly(N, X0, I0, X, UglyNumber).
ugly(N, X, I, UglyNext, UglyNumber):-
X0 is X + 1,
ugly(N, X0, I, UglyNext, UglyNumber).
main:-
ugly(10, UglyNumber),
write(UglyNumber), nl,
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
12
Notes
Here the first N ugly numbers are generated in a pretty routine way. Much of the code is related to computing the prime factors. Once that is out of way the rest of the code seems to be straightforward to follow: recursively counting up each Ugly Number until we reach the Nth one.
Part 2
You are given coordinates of four points. Write a script to find out if the given four points form a square.
Solution
:-initialization(main).
dot_product(X0-Y0, X1-Y1, N):-
N0 is X0 * X1,
N is N0 + Y0 * Y1.
swap_key_value([], []).
swap_key_value([A-B|R], [B-A|S]):-
swap_key_value(R, S).
square(Points):-
setof(X, member(X-_, Points), Xs),
setof(Y, member(_-Y, Points), Ys),
length(Xs, LXs),
length(Ys, LYs),
keysort(Points, PointsByX),
swap_key_value(Points, Swapped),
keysort(Swapped, PointsByY0),
swap_key_value(PointsByY0, PointsByY),
last(PointsByY, Sx-Sy),
last(PointsByX, Tx-Ty),
nth(1, PointsByY, Ux-Uy),
nth(1, PointsByX, Vx-Vy),
SUx is Sx + Ux,
TVx is Tx + Vx,
SUy is Sy + Uy,
TVy is Ty + Vy,
SUym is Sy - Uy,
TVxm is Tx - Vx,
DVSTx is Sx - Tx,
DVSTy is Sy - Ty,
DVTUx is Tx - Ux,
DVTUy is Ty - Uy,
DVUVx is Ux - Vx,
DVUVy is Uy - Vy,
DVVSx is Vx - Sx,
DVVSy is Vy - Sy,
dot_product(DVSTx-DVSTy, DVTUx-DVTUy, DPSTU),
dot_product(DVTUx-DVTUy, DVUVx-DVUVy, DPTUV),
dot_product(DVUVx-DVUVy, DVVSx-DVVSy, DPUVS),
((LXs == 2, LYs == 2); (SUx == TVx, SUy == TVy, SUym == TVxm, DPSTU == 0, DPTUV == 0, DPUVS == 0)).
main:-
((square([10-20, 20-20, 20-10, 10-10]), write(1)); (write(0))),
nl,
((square([12-24, 16-10, 20-12, 18-16]), write(1)); (write(0))),
nl,
((square([-3-1, 4-2, -(9,-3), -(2,-4)]), write(1)); (write(0))),
nl,
((square([0-0, 2-1, -(3,-1), -(1,-2)]), write(1)); (write(0))),
nl,
halt.
Sample Run
$ gplc prolog/ch-2.p
$ prolog/ch-2
1
0
0
1
Notes
This is most likely the most tedious Prolog code I have written in a long time! The actual logic of determining if the points determine a square is not so bad:
- Are there only two each of X and Y co-ordinates? Then that is enough to establish that we have a square.
- Otherwise, make sure the side lengths are all equivalent and that the angles between the sides are all 90 degrees.
The tedious part is just all the computation of the distance vectors, the sorting and arranging of the points, and so forth.
The points are represented as pairs. To
orient the points they are sorted by X (key) or Y (value). This is both done by the
builtin keysort/2 predicate, with keys and values swapped to facilitate the sorting
by value.
In the case of negative co-ordinates we use the alternative (-)/2 syntax. For example,
-(3,-1) is used since 3--1 is not valid syntactically.
In the example output we see that the first and last sets of points are both squares. The first is an example of a square with two unique X and Y co-ordinates. The third example is a rhombus and so is a good test to make sure the angles are being checked correctly.
References
posted at: 16:58 by: Adam Russell | path: /prolog | permanent link to this entry
2021-07-25
The Weekly Challenge 122 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
You are given a stream of numbers, @N. Write a script to print the average of the stream at every point.
Solution
:-initialization(main).
moving_average(N):-
moving_average(0, N, 1).
moving_average(Sum, N, I):-
I \== N,
Sum0 is Sum + (I * 10),
Average is Sum0 / I,
write(Average), nl,
I0 is I + 1,
moving_average(Sum0, N, I0).
moving_average(_, N, I):-
I == N.
main:-
moving_average(10),
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
10.0
15.0
20.0
25.0
30.0
35.0
40.0
45.0
50.0
Notes
Typically when one thinks of a stream the idea is of a virtually endless source of data.
Or, at least, data which is handled as if this were the case. Here the "stream" is
simulated by a generated sequence of numbers. For each recursive call to
moving_average/3 we increase the simulated "stream" by 10 and compute the moving
average.
(The idea of a stream in Prolog is fairly specific. My preferred Prolog is Gnu Prolog, which has a very nice write up of the subject.)
Part 2
You are given a score $S. You can win basketball points e.g. 1 point, 2 points and 3 points. Write a script to find out the different ways you can score $S.
Solution
:-initialization(main).
points --> [].
points --> point, points.
point --> [0]; [1]; [2]; [3].
basketball_points(Points, Goal):-
length(Points, Goal),
phrase(points, Points),
sum_list(Points, Goal).
zero_remove([], []).
zero_remove([H|T], [ZR_H|ZR_T]):-
delete(H, 0, ZR_H),
zero_remove(T, ZR_T).
main:-
findall(Ps, basketball_points(Ps, 4), Points),
zero_remove(Points, PointsZR),
sort(PointsZR, PointsZR_Unique),
write(PointsZR_Unique), nl,
halt.
Sample Run
$ gplc prolog/ch-2.p
$ prolog/ch-2
[[1,1,1,1],[1,1,2],[1,2,1],[1,3],[2,1,1],[2,2],[3,1]]
Notes
This is almost exactly identical to a solution for Challenge 112. The only difference is that I changed the predicate and variable names to match the current problem statement!
References
posted at: 18:09 by: Adam Russell | path: /prolog | permanent link to this entry
2021-07-18
The Weekly Challenge 121 (Prolog Solutions)
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
posted at: 23:35 by: Adam Russell | path: /prolog | permanent link to this entry
2021-07-11
The Weekly Challenge 120 (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 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
posted at: 14:37 by: Adam Russell | path: /prolog | permanent link to this entry
2021-06-20
The Weekly Challenge 117 (Prolog Solutions)
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
posted at: 22:53 by: Adam Russell | path: /prolog | permanent link to this entry
2021-05-30
The Weekly Challenge 114 (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 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
posted at: 15:59 by: Adam Russell | path: /prolog | permanent link to this entry
2021-05-23
The Weekly Challenge 113 (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 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/1is 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
posted at: 15:32 by: Adam Russell | path: /prolog | permanent link to this entry
2021-05-16
The Weekly Challenge 112 (Prolog Solutions)
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
Goalusing 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
posted at: 18:20 by: Adam Russell | path: /prolog | permanent link to this entry
2021-05-02
The Weekly Challenge 110 (Prolog Solutions)
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
posted at: 18:44 by: Adam Russell | path: /prolog | permanent link to this entry
2021-04-25
The Weekly Challenge 109 (Prolog Solutions)
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
posted at: 16:37 by: Adam Russell | path: /prolog | permanent link to this entry
2021-04-18
The Weekly Challenge 108 (Prolog Solutions)
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
posted at: 15:54 by: Adam Russell | path: /prolog | permanent link to this entry
2021-03-07
The Weekly Challenge 102 (Prolog Solutions)
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
posted at: 16:27 by: Adam Russell | path: /prolog | permanent link to this entry
2021-02-21
The Weekly Challenge 100 (Prolog Solutions)
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
posted at: 17:08 by: Adam Russell | path: /prolog | permanent link to this entry
2021-02-07
The Weekly Challenge 098 (Prolog Solutions)
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
posted at: 14:12 by: Adam Russell | path: /prolog | permanent link to this entry
2021-01-31
The Weekly Challenge 097 (Prolog Solutions)
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
posted at: 18:48 by: Adam Russell | path: /prolog | permanent link to this entry
2021-01-18
Making Prolog Code Bimodal
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/1is being given a valid integer N > 0requires an instantiated number variableN, as shown in the error message.- The list of digits we evaluate to be a palindrome is created by
number_chars/2which, 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 is268435455. - When the third argument to
between/3is uninstantiated it will be instantiated to be an integer in the range given by the first two arguments. - The check if
Nis 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
posted at: 17:46 by: Adam Russell | path: /prolog | permanent link to this entry
2021-01-17
The Weekly Challenge 095 (Prolog Solutions)
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
AI Algorithms, Data Structures, and Idioms in Prolog, Lisp, and Java
posted at: 16:03 by: Adam Russell | path: /prolog | permanent link to this entry
2021-01-10
The Weekly Challenge 094 (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 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/1Word-Product pairs for all the given anagrams and once done usefindall/3withbagof/3to 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
posted at: 12:09 by: Adam Russell | path: /prolog | permanent link to this entry
2021-01-03
The Weekly Challenge 093 (Prolog Solutions)
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
posted at: 16:36 by: Adam Russell | path: /prolog | permanent link to this entry