Today, I found a puzzle at https://puzzling.stackexchange.com/questions/22064/the-5040-square:
Fill a 4x4 grid with positive integers so that:
Every cell has a different integer
The product of the numbers in each row is 5040, and similarly for the columns
Source: This was an NPR weekly listener challenge, aired on 2005-10-09
Here's my first shot at solving the puzzle using clpfd:
:- use_module(library(clpfd)).
m5040_(Mss,Zs) :-
Mss = [[A1,A2,A3,A4],
[B1,B2,B3,B4],
[C1,C2,C3,C4],
[D1,D2,D3,D4]],
Zs = [A1,A2,A3,A4,B1,B2,B3,B4,C1,C2,C3,C4,D1,D2,D3,D4],
Zs ins 1..sup, % domain: positive integers
5040 #= A1*A2*A3*A4, % rows
5040 #= B1*B2*B3*B4,
5040 #= C1*C2*C3*C4,
5040 #= D1*D2*D3*D4,
5040 #= A1*B1*C1*D1, % columns
5040 #= A2*B2*C2*D2,
5040 #= A3*B3*C3*D3,
5040 #= A4*B4*C4*D4,
all_different(Zs). % pairwise inequality
Sample query:
?- m5040_(Mss,Zs), time(labeling([],Zs)).
% 416,719,535 inferences, 55.470 CPU in 55.441 seconds (100% CPU, 7512588 Lips)
Mss = [[1,3,16,105],[10,14,9,4],[21,8,5,6],[24,15,7,2]], Zs = [1,3,16,105|...] ;
...
My actual question is twofold:
How can I speed up the backtracking search process for one / for all solutions?
Which symmetries / redundancies could I exploit?
my inference counters (using your code) don't match yours... not sure why...
the first solution i get (with your code)
?- puzzle_5040.
% 464,043,891 inferences, 158.437 CPU in 160.191 seconds (99% CPU, 2928894 Lips)
[[1,3,16,105],[10,14,9,4],[21,8,5,6],[24,15,7,2]]
true
I thought that reducing the domain could speedup the result
:- use_module(library(clpfd)).
:- use_module(library(ordsets)).
:- use_module(library(apply)).
m5040_(Mss,Zs) :-
matrix(Mss),
flatten(Mss, Zs),
all_factors(Fs),
make_domain(Fs, Dom),
Zs ins Dom,
all_distinct(Zs),
maplist(m5040, Mss),
transpose(Mss, Tss), maplist(m5040, Tss).
m5040([A,B,C,D]) :- 5040 #= A * B * C * D.
length_(L, Xs) :- length(Xs, L).
matrix(Mss) :-
length_(4, Mss),
maplist(length_(4), Mss).
factors(L) :-
L = [A,B,C,D],
5040 #= 1 * 2 * 3 * U,
L ins 1..U,
all_distinct(L),
A #< B, B #< C, C #< D,
5040 #= A * B * C * D.
all_factors(AllFs) :-
findall(L, (factors(L),label(L)), Fs),
foldl(ord_union, Fs, [], AllFs).
but I was wrong, it was slower actually...
Since some time ago I tried CLP(FD) solving some Project Euler, and in some cases I found it was slower than raw arithmetic, I arranged a program that doesn't use CLP(FD), but reduces the domain to make it manageable:
puzzle_5040_no_clp :- time(puzzle_5040_no_clp(S)), writeln(S).
puzzle_5040_no_clp(S) :-
findall(F, factors(F), Fs),
factors_group(Fs, G),
once(solution(G, S)).
disjoint(A, B) :-
forall(member(X, A), \+ memberchk(X, B)).
eq5040([A,B,C,D]) :-
5040 =:= A * B * C * D.
factors([A, B, C, D]) :-
5040 #= 1 * 2 * 3 * U,
[A, B, C, D] ins 1..U,
A #< B, B #< C, C #< D,
5040 #= A * B * C * D,
label([A, B, C, D]).
all_factors(AllFs) :- % no more used
findall(L, factors(L), Fs),
foldl(ord_union, Fs, [], AllFs).
factors_group(Fs, [A, B, C, D]) :-
nth1(Ap, Fs, A),
nth1(Bp, Fs, B), Ap < Bp, disjoint(A, B),
nth1(Cp, Fs, C), Bp < Cp, disjoint(A, C), disjoint(B, C),
nth1(Dp, Fs, D), Cp < Dp, disjoint(A, D), disjoint(B, D), disjoint(C, D).
/*
solution([A,B,C,D], S) :-
maplist(permutation, [B,C,D], [U,V,Z]),
transpose([A,U,V,Z], S),
maplist(eq5040, S).
*/
solution(T0, [U,V,X,Y]) :-
peek5040(T0, U, T1),
peek5040(T1, V, T2),
peek5040(T2, X, T3),
peek5040(T3, Y, [[],[],[],[]]).
peek5040([A,B,C,D], [M,N,P,Q], [Ar,Br,Cr,Dr]) :-
select(M,A,Ar),
select(N,B,Br), M*N < 5040,
select(P,C,Cr), M*N*P < 5040,
select(Q,D,Dr), M*N*P*Q =:= 5040.
% only test
validate(G) :- maplist(eq5040, G), transpose(G, T), maplist(eq5040, T).
with this approach, getting all solutions
?- time(aggregate(count,puzzle_5040_no_clp,N)).
% 6,067,939 inferences, 1.992 CPU in 1.994 seconds (100% CPU, 3046002 Lips)
[[1,24,14,15],[3,21,10,8],[16,5,9,7],[105,2,4,6]]
% 111,942 inferences, 0.041 CPU in 0.052 seconds (79% CPU, 2758953 Lips)
[[1,24,10,21],[3,15,14,8],[16,7,9,5],[105,2,4,6]]
...
% 62,564 inferences, 0.033 CPU in 0.047 seconds (70% CPU, 1894080 Lips)
[[1,10,12,42],[15,28,3,4],[16,9,7,5],[21,2,20,6]]
% 37,323 inferences, 0.017 CPU in 0.027 seconds (65% CPU, 2164774 Lips)
[[1,14,12,30],[15,2,28,6],[16,9,5,7],[21,20,3,4]]
% 2,281,755 inferences, 0.710 CPU in 0.720 seconds (99% CPU, 3211625 Lips)
% 48,329,065 inferences, 18.072 CPU in 27.535 seconds (66% CPU, 2674185 Lips)
N = 354.
Here I propose to find a solution to Smullyan's numerical machines as defined here.
Problem statement
They're machines that take a list of digits as input, and transform it to another list of digits following some rules based on the pattern of the input.
Here are the rules of the machine given in the link above, expressed a bit more formally.
Let say M is the machine, and M(X) is the transformation of X.
We define a few rules like this:
M(2X) = X
M(3X) = M(X)2M(X)
M(4X) = reverse(M(X)) // reverse the order of the list.
M(5X) = M(X)M(X)
And anything that does not match any rule is rejected.
Here are a few examples:
M(245) = 45
M(3245) = M(245)2M(245) = 45245
M(43245) = reverse(M(3245)) = reverse(45245) = 54254
M(543245) = M(43245)M(43245) = 5425454254
And the questions are, find X such that:
M(X) = 2
M(X) = X
M(X) = X2X
M(X) = reverse(X)
M(X) = reverse(X2X)reverse(X2X)
Here is a second example a bit more complex with the exhaustive search (especially if I want the first 10 or 100 solutions).
M(1X2) = X
M(3X) = M(X)M(X)
M(4X) = reverse(M(X))
M(5X) = truncate(M(X)) // remove the first element of the list truncate(1234) = 234. Only valid if M(X) has at least 2 elements.
M(6X) = 1M(X)
M(7X) = 2M(X)
Questions:
M(X) = XX
M(X) = X
M(X) = reverse(X)
(Non-)Solutions
Writing a solver in Prolog is pretty straightforward. Except that it's just exhaustive exploration (a.k.a brute force) and may take some time for some set of rules.
I tried but couldn't express this problem in terms of logic constraints with CLP(FD), so I tried CHR (Constraint Handling Rules) to express this in terms of constraints on lists (especially append constraints), but no matter how I express it, it always boils down to an exhaustive search.
Question
Any idea what approach I could take to resolve any problem of this kind in a reasonable amount of time?
Ideally I would like to be able to generate all the solutions shorter than some bound.
Let's look at your "a bit more complex" problem. Exhaustive search works excellently!
Here is a comparison with Серге́й's solution which can be improved significantly by factoring the common goals:
m([1|A], X) :-
A = [_|_],
append(X, [2], A).
m([E | X], Z) :-
m(X, Y),
( E = 3,
append(Y, Y, Z)
; E = 4,
reverse(Y, Z)
; E = 5,
Y = [_ | Z]
; E = 6,
Z = [1 | Y]
; E = 7,
Z = [2 | Y]
).
For query time(findall(_, (question3(X), write(X), nl), _)). I get with B 8.1, SICStus 4.3b8:
Серге́й B tabled 104.542s
Серге́й B 678.394s
false B 16.013s
false B tabled 53.007s
Серге́й SICStus 439.210s
false SICStus 7.990s
Серге́й SWI 1383.678s, 5,363,110,835 inferences
false SWI 44.743s, 185,136,302 inferences
The additional questions are not that difficult to answer. Only SICStus with above m/2 and
call_nth/2:
| ?- time(call_nth( (
length(Xs0,N),append(Xs0,Xs0,Ys),m(Xs0,Ys),
writeq(Ys),nl ), 10)).
[4,3,7,4,3,1,4,3,7,4,3,1,2,4,3,7,4,3,1,4,3,7,4,3,1,2]
[3,4,7,4,3,1,3,4,7,4,3,1,2,3,4,7,4,3,1,3,4,7,4,3,1,2]
[4,3,7,3,4,1,4,3,7,3,4,1,2,4,3,7,3,4,1,4,3,7,3,4,1,2]
[3,4,7,3,4,1,3,4,7,3,4,1,2,3,4,7,3,4,1,3,4,7,3,4,1,2]
[3,5,4,5,3,1,2,2,1,3,5,4,5,3,1,2,3,5,4,5,3,1,2,2,1,3,5,4,5,3,1,2]
[3,5,5,3,4,1,2,1,4,3,5,5,3,4,1,2,3,5,5,3,4,1,2,1,4,3,5,5,3,4,1,2]
[5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2]
[4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2]
[5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2]
[3,5,4,7,4,3,1,_2735,3,5,4,7,4,3,1,2,3,5,4,7,4,3,1,_2735,3,5,4,7,4,3,1,2]
196660ms
| ?- time(call_nth( (
length(Xs0,N),m(Xs0,Xs0),
writeq(Xs0),nl ), 10)).
[4,7,4,3,1,4,7,4,3,1,2]
[4,7,3,4,1,4,7,3,4,1,2]
[5,4,7,4,3,1,_2371,5,4,7,4,3,1,2]
[4,7,4,5,3,1,_2371,4,7,4,5,3,1,2]
[5,4,7,3,4,1,_2371,5,4,7,3,4,1,2]
[3,5,4,7,4,1,2,3,5,4,7,4,1,2]
[4,3,7,4,5,1,2,4,3,7,4,5,1,2]
[3,4,7,4,5,1,2,3,4,7,4,5,1,2]
[4,7,5,3,6,4,1,4,7,5,3,6,4,2]
[5,4,7,4,3,6,1,5,4,7,4,3,6,2]
6550ms
| ?- time(call_nth( (
length(Xs0,N),reverse(Xs0,Ys),m(Xs0,Ys),
writeq(Ys),nl ), 10)).
[2,1,3,4,7,1,3,4,7]
[2,1,4,3,7,1,4,3,7]
[2,1,3,5,4,7,_2633,1,3,5,4,7]
[2,1,5,4,7,3,2,1,5,4,7,3]
[2,4,6,3,5,7,1,4,6,3,5,7]
[2,6,3,5,4,7,1,6,3,5,4,7]
[2,_2633,1,5,3,4,7,_2633,1,5,3,4,7]
[2,_2633,1,5,4,3,7,_2633,1,5,4,3,7]
[2,1,3,4,4,4,7,1,3,4,4,4,7]
[2,1,3,4,5,6,7,1,3,4,5,6,7]
1500ms
Here is another improvement to #Celelibi's improved version (cele_n). Roughly, it gets a factor of two by constraining the length of the first argument, and another factor of two by pretesting the two versions.
cele_n SICStus 2.630s
cele_n SWI 12.258s 39,546,768 inferences
cele_2 SICStus 0.490s
cele_2 SWI 2.665s 9,074,970 inferences
appendh([], [], Xs, Xs).
appendh([_, _ | Ws], [X | Xs], Ys, [X | Zs]) :-
appendh(Ws, Xs, Ys, Zs).
m([H|A], X) :-
A = [_|_], % New
m(H, X, A).
m(1, X, A) :-
append(X, [2], A).
m(3, X, A) :-
appendh(X, B, B, X),
m(A, B).
m(4, X, A) :-
reverse(X, B),
m(A, B).
m(5, X, A) :-
X = [_| _],
m(A, [_|X]).
m(H1, [H2 | B], A) :-
\+ \+ ( H2 = 1 ; H2 = 2 ), % New
m(A, B),
( H1 = 6, H2 = 1
; H1 = 7, H2 = 2
).
answer3(X) :-
between(1, 13, N),
length(X, N),
reverse(X, A),
m(X, A).
run :-
time(findall(X, (answer3(X), write(X), nl), _)).
I propose here another solution which is basically exhaustive exploration. Given the questions, if the length of the first argument of m/2 is known, the length of the second is known as well. If the length of the second argument is always known, this can be used to cut down the search earlier by propagating some constraints down to the recursive calls. However, this is not compatible with the optimization proposed by false.
appendh([], [], Xs, Xs).
appendh([_, _ | Ws], [X | Xs], Ys, [X | Zs]) :-
appendh(Ws, Xs, Ys, Zs).
m([1 | A], X) :-
append(X, [2], A).
m([3 | A], X) :-
appendh(X, B, B, X),
m(A, B).
m([4 | A], X) :-
reverse(X, B),
m(A, B).
m([5 | A], X) :-
B = [_, _ | _],
B = [_ | X],
m(A, B).
m([H1 | A], [H2 | B]) :-
m(A, B),
( H1 = 6, H2 = 1
; H1 = 7, H2 = 2
).
answer3(X) :-
between(1, 13, N),
length(X, N),
reverse(X, A),
m(X, A).
Here is the time taken respectively by: this code, this code when swapping recursive calls with the constraints of each case (similar to solution of Sergey Dymchenko), and the solution of false which factor the recursive calls. The test is run on SWI and search for all the solution whose length is less or equal to 13.
% 36,380,535 inferences, 12.281 CPU in 12.315 seconds (100% CPU, 2962336 Lips)
% 2,359,464,826 inferences, 984.253 CPU in 991.474 seconds (99% CPU, 2397214 Lips)
% 155,403,076 inferences, 47.799 CPU in 48.231 seconds (99% CPU, 3251186 Lips)
All measures are performed with the call:
?- time(findall(X, (answer3(X), writeln(X)), _)).
(I assume that this is about a list of digits, as you suggest. Contrary to the link you gave, which talks about numbers. There might be differences with leading zeros. I did not take the time to think that through)
First of all, Prolog is an excellent language to search brute force. For, even in that case, Prolog is able to mitigate combinatorial explosion. Thanks to the logic variable.
Your problem statements are essentially existential statements: Does there exist an X such that such and such is true. That's where Prolog is best at. The point is the way how you are asking the question. Instead of asking with concrete values like [1] and so on, simply ask for:
?- length(Xs, N), m(Xs,Xs).
Xs = [3,2,3], N = 3
; ... .
And similarly for the other queries. Note that there is no need to settle for concrete values! This makes the search certainly more expensive!
?- length(Xs, N), maplist(between(0,9),Xs), m(Xs,Xs).
Xs = [3,2,3], N = 3
; ... .
In this manner it is quite efficiently possible to find concrete solutions, should they exist. Alas, we cannot decide that a solution does not exist.
Just to illustrate the point, here is the answer for the "most complex" puzzle:
?- length(Xs0,N),
append(Xs0,[2|Xs0],Xs1),reverse(Xs1,Xs2),append(Xs2,Xs2,Xs3), m(Xs0,Xs3).
Xs0 = [4, 5, 3, 3, 2, 4, 5, 3, 3], N = 9, ...
; ... .
It comes up in no time. However, the query:
?- length(Xs0,N), maplist(between(0,9),Xs0),
append(Xs0,[2|Xs0],Xs1),reverse(Xs1,Xs2),append(Xs2,Xs2,Xs3), m(Xs0,Xs3).
is still running!
The m/2 I used:
m([2|Xs], Xs).
m([3|Xs0], Xs) :-
m(Xs0,Xs1),
append(Xs1,[2|Xs1], Xs).
m([4|Xs0], Xs) :-
m(Xs0, Xs1),
reverse(Xs1,Xs).
m([5|Xs0],Xs) :-
m(Xs0,Xs1),
append(Xs1,Xs1,Xs).
The reason why this is more effective is simply that a naive enumeration of all n digits has 10n different candidates, whereas Prolog will only search for 3n given by the 3 recursive rules.
Here is yet another optimization: All 3 rules have the very same recursive goal. So why do this thrice, when once is more than enough:
m([2|Xs], Xs).
m([X|Xs0], Xs) :-
m(Xs0,Xs1),
( X = 3,
append(Xs1,[2|Xs1], Xs)
; X = 4,
reverse(Xs1,Xs)
; X = 5,
append(Xs1,Xs1,Xs)
).
For the last query, this reduces from 410,014 inferences, 0.094s CPU down to 57,611 inferences, 0.015s CPU.
Edit: In a further optimization the two append/3 goals can be merged:
m([2|Xs], Xs).
m([X|Xs0], Xs) :-
m(Xs0,Xs1),
( X = 4,
reverse(Xs1,Xs)
; append(Xs1, Xs2, Xs),
( X = 3, Xs2 = [2|Xs1]
; X = 5, Xs2 = Xs1
)
).
... which further reduces execution to 39,096 inferences and runtime by 1ms.
What else can be done? The length is bounded by the length of the "input". If n is the length of the input, then 2(n-1)-1 is the longest output. Is this helping somehow? Probably not.
Tabling (memoization) can help with harder variants of the problem.
Here is my implementation for the third question of second example in B-Prolog (returns all solutions of length 13 or less):
:- table m/2.
m(A, X) :-
append([1 | X], [2], A).
m([3 | X], Z) :-
m(X, Y),
append(Y, Y, Z).
m([4 | X], Z) :-
m(X, Y),
reverse(Y, Z).
m([5 | X], Z) :-
m(X, Y),
Y = [_ | Z].
m([6 | X], Z) :-
m(X, Y),
Z = [1 | Y].
m([7 | X], Z) :-
m(X, Y),
Z = [2 | Y].
question3(X) :-
between(1, 13, N),
length(X, N),
reverse(X, Z), m(X, Z).
Run:
B-Prolog Version 8.1, All rights reserved, (C) Afany Software 1994-2014.
| ?- cl(smullyan2).
cl(smullyan2).
Compiling::smullyan2.pl
compiled in 2 milliseconds
loading...
yes
| ?- time(findall(_, (question3(X), writeln(X)), _)).
time(findall(_, (question3(X), writeln(X)), _)).
[7,3,4,1,7,3,4,1,2]
[7,4,3,1,7,4,3,1,2]
[3,7,4,5,1,2,3,7,4,5,1,2]
[7,4,5,3,1,_678,7,4,5,3,1,2]
[7,4,5,3,6,1,7,4,5,3,6,2]
[7,5,3,6,4,1,7,5,3,6,4,2]
[4,4,7,3,4,1,4,4,7,3,4,1,2]
[4,4,7,4,3,1,4,4,7,4,3,1,2]
[5,6,7,3,4,1,5,6,7,3,4,1,2]
[5,6,7,4,3,1,5,6,7,4,3,1,2]
[5,7,7,3,4,1,5,7,7,3,4,1,2]
[5,7,7,4,3,1,5,7,7,4,3,1,2]
[7,3,4,4,4,1,7,3,4,4,4,1,2]
[7,3,4,5,1,_698,7,3,4,5,1,_698,2]
[7,3,4,5,6,1,7,3,4,5,6,1,2]
[7,3,4,5,7,1,7,3,4,5,7,1,2]
[7,3,5,6,4,1,7,3,5,6,4,1,2]
[7,3,5,7,4,1,7,3,5,7,4,1,2]
[7,3,6,5,4,1,7,3,6,5,4,1,2]
[7,4,3,4,4,1,7,4,3,4,4,1,2]
[7,4,3,5,1,_698,7,4,3,5,1,_698,2]
[7,4,3,5,6,1,7,4,3,5,6,1,2]
[7,4,3,5,7,1,7,4,3,5,7,1,2]
[7,4,4,3,4,1,7,4,4,3,4,1,2]
[7,4,4,4,3,1,7,4,4,4,3,1,2]
[7,4,5,6,3,1,7,4,5,6,3,1,2]
[7,4,5,7,3,1,7,4,5,7,3,1,2]
[7,5,6,3,4,1,7,5,6,3,4,1,2]
[7,5,6,4,3,1,7,5,6,4,3,1,2]
[7,5,7,3,4,1,7,5,7,3,4,1,2]
[7,5,7,4,3,1,7,5,7,4,3,1,2]
[7,6,5,3,4,1,7,6,5,3,4,1,2]
[7,6,5,4,3,1,7,6,5,4,3,1,2]
CPU time 25.392 seconds.
yes
So it's less than a minute for this particular problem.
I don't think constraint programming will be of any help with this type of problem, especially with "find 20 first solutions" variant.
Update: running times of the same program on my computer on different systems:
B-Prolog 8.1 with tabling: 26 sec
B-Prolog 8.1 without tabling: 128 sec
ECLiPSe 6.1 #187: 122 sec
SWI-Prolog 6.2.6: 330 sec
I'm new at Prolog, and i need to convert from the truth table the result into disjunctive normal form.
I have been able to produce the truth table as given:
?- table(p or(q and not r) or not s or r).
[p,q,r,s] | (p or (q and not r) or not s or r) ----------------------------------------------|[0,0,0,0] | 1 |[0,0,0,1] | 0 |[0,0,1,0] | 1 |[0,0,1,1] | 1 |[0,1,0,0] | 1 |[0,1,0,1] | 1 |[0,1,1,0] | 1 |[0,1,1,1] | 1 |[1,0,0,0] | 1 |[1,0,0,1] | 1 |[1,0,1,0] | 1 |[1,0,1,1] | 1 |[1,1,0,0] | 1 |[1,1,0,1] | 1 |[1,1,1,0] | 1 |[1,1,1,1] | 1 |-----------------------------------------------
if anyone can help me make from this table to the disjunctive normal form i would apreciate it.
let's implement a generic truth table evaluator, translating to Prolog evaluable formula in CDNF, then, by definition, we will disjoin each minterm:
:- op(900, fy, neg).
:- op(1000, xfy, and).
:- op(1100, xfy, or).
formula(p or (q and neg r) or neg s or r).
cnf(F, CNF) :-
setof(V, literal(F, V), Ls),
setof(La, T^(assign(Ls, La), translate(F, La, T), T), CNF).
literal((X or Y), L) :- literal(X,L) ; literal(Y,L).
literal((X and Y), L) :- literal(X,L) ; literal(Y,L).
literal(neg X, L) :- literal(X,L).
literal(L, L) :- atom(L).
assign(Ls, La) :- maplist(assign_literal, Ls, La).
assign_literal(L, L=true).
assign_literal(L, L=false).
translate((X or Y), Ls, (A;B)) :- translate(X, Ls, A), translate(Y, Ls, B).
translate((X and Y), Ls, (A,B)) :- translate(X, Ls, A), translate(Y, Ls, B).
translate(neg X, Ls, \+ A) :- translate(X, Ls, A).
translate(L, Ls, V) :- memberchk(L=V, Ls).
yields:
?- formula(F),cnf(F,CNF),maplist(writeln,CNF).
[p=false,q=false,r=false,s=false]
[p=false,q=false,r=true,s=false]
[p=false,q=false,r=true,s=true]
[p=false,q=true,r=false,s=false]
[p=false,q=true,r=false,s=true]
[p=false,q=true,r=true,s=false]
[p=false,q=true,r=true,s=true]
[p=true,q=false,r=false,s=false]
[p=true,q=false,r=false,s=true]
[p=true,q=false,r=true,s=false]
[p=true,q=false,r=true,s=true]
[p=true,q=true,r=false,s=false]
[p=true,q=true,r=false,s=true]
[p=true,q=true,r=true,s=false]
[p=true,q=true,r=true,s=true]
F = or(p, or(and(q, neg(r)), or(neg(s), r))),
CNF = [[p=false, q=false, r=false, s=false], [p=false, q=false, r=true, s=false], [p=false, q=false, r=true, s=true], [p=false, q=true, r=false, s=false], [p=false, q=true, r=false, ... = ...], [p=false, q=true, ... = ...|...], [p=false, ... = ...|...], [... = ...|...], [...|...]|...].
Sorry the output it's a bit verbose. Can be easily tailored on further spec.
I used neg/1 instead of not/1 (that's already a valid Prolog operator), just to make clear the distinction...
Edit
Here is a simplification, resulting in a syntactic generalization. Just literal/2 and translate/3 have changed, and translate/2 has been added:
literal(F, L) :- F =.. [_,X,Y], (literal(X,L) ; literal(Y,L)).
literal(F, L) :- F =.. [_,X], literal(X,L).
literal(L, L) :- atom(L).
translate(and, (,)).
translate(or, (;)).
translate(neg, (\+)).
translate(F, Ls, T) :-
F =.. [S,X,Y],
translate(S,O),
T =.. [O,A,B],
translate(X, Ls, A), translate(Y, Ls, B).
translate(F, Ls, T) :-
F =.. [S,X],
translate(S,O),
T =.. [O,A],
translate(X, Ls, A).
translate(F, Ls, T) :- memberchk(F=T, Ls).
More Edit
The code above can be made more efficient, just moving the translation out of the cycle
cnf(F, CNF) :-
setof(V, literal(F, V), Ls),
translate(F, La, T),
setof(La, (assign(Ls, La), T), CNF).
a minor modification is required in last translate/3 clause: use member/2 instead of memberchk
...
translate(F, Ls, T) :- member(F=T, Ls).
Timing: with the old version
4 ?- formula(F),time(cnf(F,CNF)).
% 1,788 inferences, 0.002 CPU in 0.002 seconds (98% CPU, 834727 Lips)
With the new one:
5 ?- formula(F),time(cnf(F,CNF)).
% 282 inferences, 0.001 CPU in 0.001 seconds (99% CPU, 315768 Lips)
about 6x better.
Old with memberchk:
6 ?- formula(F),time(cnf(F,CNF)).
% 1,083 inferences, 0.002 CPU in 0.002 seconds (98% CPU, 561426 Lips)
Well, still almost 4x better.
Edit Some more step is required to get a true Prolog formula
cdnf(F, CNDF, Prolog) :-
cdnf(F, CNDF), % well, was cnf/2, I renamed to be more precise
maplist(cj, CNDF, CJs),
reverse(CJs, [H|T]),
foldl(dj, T, H, Prolog).
dj(A, B, (A;B)).
cj(A, J) :-
maplist(tf, A, B),
reverse(B, [H|T]),
foldl(cj, T, H, J).
cj(A, B, (A,B)).
tf(S=true,S).
tf(S=false,\+S).
now, the result is more usable
?- formula(_,F), cdnf(F,_,P).
F = or(p, or(and(q, neg(r)), or(neg(s), r))),
P = (\+p, \+q, \+r, \+s;\+p, \+q, r, \+s;\+p, \+q, r, s;\+p, q, \+r, \+s;\+p, q, \+r, s;\+p, q, r, \+ ...;\+p, q, ..., ...;p, ..., ...;..., ...;...;...)