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.
Related
Can you help me, I can't figure out how to do this: the replace_last predicate to replace the last occurrence of a given element in the list with the specified new value
replace_last(InList, OutList) :-
append([[First], Middle, [Last]], InList),
append([[Last], Middle, [First]], OutList).
I would use negation:
replace_last(Input,Find,Replace,Output) :-
append(X,[Find|Y],Input),
\+ memberchk(Find,Y),
append(X,[Replace|Y],Output).
Using backtracking:
replace_last_elem_match(Find, Replacement, Lst, LstReplaced) :-
last_elem_match_copy(Find, Lst, LstReplaced, Tail, After),
Tail = [Replacement|After].
last_elem_match_copy(Find, Lst, LstReplaced, Tail, After) :-
last_elem_match_copy_(Lst, Find, LstReplaced, Tail, After).
last_elem_match_copy_([H|T], Find, [H|LstReplaced], Tail, After) :-
last_elem_match_copy_(T, Find, LstReplaced, Tail, After), !.
last_elem_match_copy_([Find|T], Find, Tail, Tail, T).
Result in swi-prolog:
?- time(replace_last_elem_match(a, z, [a,a,b,a,c,a], R)).
% 9 inferences, 0.000 CPU in 0.000 seconds (87% CPU, 399078 Lips)
R = [a,a,b,a,c,z].
However, #CapelliC's solution is faster (presumably because memberchk is native in swi-prolog) - performance comparisons:
?- numlist(1, 1_000_000, L), time(replace_last_elem_match(99999, z, L, R)).
% 1,000,003 inferences, 1.469 CPU in 1.472 seconds (100% CPU, 680792 Lips)
?- numlist(1, 1_000_000, L), time(replace_last(L, 99999, z, R)).
% 200,001 inferences, 0.023 CPU in 0.024 seconds (100% CPU, 8517234 Lips)
?- length(L, 1_000_000), maplist(=(a), L), time(replace_last_elem_match(a, z, L, R)).
% 1,000,003 inferences, 0.696 CPU in 0.698 seconds (100% CPU, 1436214 Lips)
?- length(L, 1_000_000), maplist(=(a), L), time(replace_last(L, a, z, R)).
% 4,000,001 inferences, 0.453 CPU in 0.454 seconds (100% CPU, 8824459 Lips)
I suppose you could use append/3 to do this, but that seems like using a shotgun to swat a fly:
replace_last( A , Bs , Cs ) :-
append( B1 , [_] , Bs ) ,
append( B1 , [A] , Cs )
.
But is that any simpler, or easier to understand than this?
replace_last( A , [_] , [A] ) .
replace_last( A , [B|Bs] , [B|Cs] ) :- replace_last(A,Bs,Cs) .
[It's certainly not as performant.]
You can fiddle with it at https://swish.swi-prolog.org/p/tAnrXzKn.pl
I think this is the fastest method found so far:
last_match_replace(Find, Replace, Lst, LstReplaced) :-
phrase(last_match_replace_(Find, Replace, LstReplaced, Tail), Lst, Tail), !.
last_match_replace_(Find, Replace, Before, BeforeTail, Lst, [Replace|Rem]) :-
match_find(Lst, Find, Before, BeforeTail, Rem),
\+ memberchk(Find, Rem).
match_find([Find|L], Find, T, T, L).
match_find([E|L], Find, [E|T], Tail, Rem) :-
match_find(L, Find, T, Tail, Rem).
Results in swi-prolog:
?- numlist(1, 1_000_000, L), time(last_match_replace(99999, z, L, R)).
% 100,011 inferences, 0.028 CPU in 0.028 seconds (100% CPU, 3514803 Lips)
?- length(L, 1_000_000), maplist(=(a), L), time(last_match_replace(a, z, L, R)).
% 3,000,010 inferences, 0.177 CPU in 0.177 seconds (100% CPU, 16962407 Lips)
I am using Prolog and I am trying to find the intersection or the common elements between two lists and the result should not contain duplicates. In addition, the case of lists with different lengths should be handled. The result of the predicate should be as follows:
?-no_duplicates_intersection([a,v,a,c],[a,a,a,a,a],L).
L = a.
Actually, I found a question or two tackling the same issue, but the answers were way too long. I was wondering if there was a more straightforward and easier method using the following predicate, which returns the intersection between two lists with duplicates:
intersection_with_dulpicates([], [], []).
intersection_with_dulpicates([],M,[]).
intersection_with_dulpicates([X|Y],M,[X|Z]):-
member(X,M),
intersection_with_dulpicates(Y,M,Z).
intersection_with_dulpicates([X|Y],M,Z):-
\+member(X,M),
intersection_with_dulpicates(Y,M,Z).
Taking advantage of the built-in sort (which also removes duplicates):
intersection_without_duplicates(Lst1, Lst2, Intersection) :-
% Sort and remove duplicates from both
% The built-in sort is quick
sort(Lst1, Lst1Sorted),
sort(Lst2, Lst2Sorted),
intersect_sorted(Lst1Sorted, Lst2Sorted, Intersection).
intersect_sorted([], _Lst2Sorted, []).
intersect_sorted([H|T], LstSorted, Intersection) :-
( member_listsorted(H, LstSorted)
-> Intersection = [H|Intersection0]
; Intersection0 = Intersection
),
intersect_sorted(T, LstSorted, Intersection0).
member_listsorted(H, LstSorted) :-
member_listsorted_(LstSorted, H).
member_listsorted_([H|T], Elem) :-
( H #< Elem
-> member_listsorted_(T, Elem)
; H = Elem
).
Sample output in swi-prolog:
?- time(intersection_without_duplicates([a, b, c, d, b, c, d], [b, c, b, c, d],
I)).
% 31 inferences, 0.000 CPU in 0.000 seconds (89% CPU, 586277 Lips)
I = [b,c,d].
?- numlist(1, 10000, Lst1), numlist(5000, 12345, Lst2), time((intersection_without_duplicates(Lst1, Lst2, Intersection))).
% 25,060,003 inferences, 1.313 CPU in 1.297 seconds (101% CPU, 19090034 Lips)
Performance comparison with #TessellatingHeckler's suggestion:
?- numlist(1, 10000, Lst1), numlist(5000, 12345, Lst2), time((intersection(Lst1, Lst2, Both), sort(Both, Answer))).
% 35,001 inferences, 2.193 CPU in 2.167 seconds (101% CPU, 15957 Lips)
Following the design of intersection_with_dulpicates you can try
no_duplicates_intersection([], _L2, []).
no_duplicates_intersection([X|Y],L, Intersection):-
no_duplicates_intersection(Y,L,Cur_intersection),
( (member(X, Cur_intersection); \+ member(X,L))
-> Intersection = Cur_intersection
; Intersection = [X | Cur_intersection]).
I need help coding a program in Prolog that returns true if a list has n number of [a, c] and m number of b. But it must be in this order: a,b,c if there are the letters a,b,c in the list. In the list, the numbers of a and c must be the same, and the number of b can be whatever. Example : [] is true, [b] is true, [a,b,c] is true, [a,c] is true, [a,b,b,b,b,c] is true, [a,a,b,c,c] is true. But [b,c] is false, [a,b] is false, [a,a,b,c] is false.
Here is what I tried to do, I have n numbers of a and m numbers of b, but I just need to have the list to end with n numbers of c (same amount as a) :
langageAB([b]).
langageAB([b | S]):-
langageAB(S).
langage8([]).
langage8([a,b]).
langage8([a | S]):-
langage8(S).
langage8([a |S]):-
langageAB(S).
More performant answer:
abc_list3(ABCs) :-
length(ABCs, ABCsLen),
MaxAsLen is ABCsLen div 2,
between(0, MaxAsLen, AsLen),
% Same length for as and cs
length(As, AsLen),
length(Cs, AsLen),
BsLen is ABCsLen - (AsLen * 2),
length(Bs, BsLen),
% Length of As, Bs and Cs has already been defined
append([As, Bs, Cs], ABCs),
% Contents of the 3 segments
maplist(=(a), As),
maplist(=(b), Bs),
maplist(=(c), Cs).
Result in swi-prolog:
?- time(findnsols(13, L, abc_list3(L), Ls)).
% 554 inferences, 0.000 CPU in 0.000 seconds (100% CPU, 1735654 Lips)
Ls = [[],[b],[b,b],[a,c],[b,b,b],[a,b,c],[b,b,b,b],[a,b,b,c],[a,a,c,c],[b,b,b,b,b],[a,b,b,b,c],[a,a,b,c,c],[b,b,b,b,b,b]]
Original, less performant answer:
abc_list2(ABCs) :-
% Start at length 0, if ABCs is uninstantiated
length(ABCs, _ABCsLen),
append([As, Bs, Cs], ABCs),
% Same length for as and cs
length(As, AsLen),
length(Cs, AsLen),
% Contents of the 3 segments
maplist(=(a), As),
maplist(=(b), Bs),
maplist(=(c), Cs).
Result in swi-prolog:
?- time(findnsols(13, L, abc_list2(L), Ls)).
% 982 inferences, 0.001 CPU in 0.001 seconds (100% CPU, 1957806 Lips)
Ls = [[], [b], [b, b], [a, c], [b, b, b], [a, b, c], [b, b, b, b], [a, b, b, c], [a, a, c, c], [b, b, b, b, b], [a, b, b, b, c], [a, a, b, c, c], [b, b, b, b, b, b]]
Performance comparison:
?- time(findnsols(5000, _, abc_list3(_), _)).
% 1,542,075 inferences, 0.125 CPU in 0.124 seconds (101% CPU, 12337474 Lips)
?- time(findnsols(5000, _, abc_list2(_), _)).
% 37,702,800 inferences, 4.226 CPU in 4.191 seconds (101% CPU, 8921614 Lips)
I am trying to find a sequence of steps from the starting board below to a solved state.
[[x,x,x,x,x],
[x,x,x,x,x],
[x,x,o,x,x],
[x,x,x,x,x],
[x,x,x,x,x]]
However, it takes a very long time. I have left my program running for 5 hours and have still not found a solution. Is there any way I can optimize this?
:- use_module(library(clpfd)).
rotate_clock(Xss, Zss) :-
transpose(Xss, Yss),
maplist(reverse, Yss, Zss).
rotate_anti(Xss, Zss) :-
maplist(reverse, Xss, Yss),
transpose(Yss, Zss).
linjmp([x, x, o | T], [o, o, x | T]).
linjmp([o, x, x | T], [x, o, o | T]).
linjmp([H|T1], [H|T2]) :- linjmp(T1,T2).
horizjmp([A|T],[B|T]) :- linjmp(A,B).
horizjmp([H|T1],[H|T2]) :- horizjmp(T1,T2).
jump(B,A) :- horizjmp(B,A).
jump(B,A) :- rotate_clock(B,BR), horizjmp(BR,BRJ), rotate_anti(BRJ, A).
num_x(A, C) :- count(A, x, C).
count([],X,0).
count([X|T],X,Y):- count(T,X,Z), Y is 1+Z.
count([H|T],X,Z):- dif(H, X), count(T,X,Z).
sum_list([], 0).
sum_list([H|T], Sum) :-
sum_list(T, Rest),
Sum is H + Rest.
solved(A) :-
maplist(num_x, A, B),
sum_list(B, C),
C == 1.
jumps([B1, B2 | []]) :-
jump(B1, B2),
solved(B2).
jumps([B1, B2 | Bs]) :-
jump(B1, B2),
jumps([B2 | Bs]).
?- jumps([[[x,x,x,x,x], [x,x,x,x,x], [x,x,o,x,x], [x,x,x,x,x], [x,x,x,x,x]]|X]), write(X), !.
Nice puzzle, 2 dimensional constraints are worth to try, even if I think, from what I read, there could be no solution...
Your code is a rather naive brute force solver. Calling transpose/2 (twice!) at every search tree node just to test a vertical pattern sounds overkill.
I'll show my attempt, starting from 'symbolic processing' (and brute force, like yours :) to model the problem.
solve_brute_force(S) :-
build(at(3,3,o),x,I),
/* uncomment to test...
I=[[x,x,x,x,x],
[x,x,x,x,x],
[x,x,o,x,x],
[x,x,x,x,x],
[x,x,x,x,x]],
*/
% try all...
% between(1,5,P),between(1,5,Q),build(at(P,Q,x),o,F),
% or just a specific pattern
build(at(2,4,x),o,F),
steps(I,F,S).
steps(F,F,[F]).
steps(A,F,[A|R]) :-
step(A,B), %show(B),
steps(B,F,R).
step(A,B) :-
append(L,[R|Rs],A),
hmove(R,U),
append(L,[U|Rs],B).
step(A,B) :-
append(L,[U0,V0,Z0|Rs],A),
vmove(U0,V0,Z0, U2,V2,Z2),
append(L,[U2,V2,Z2|Rs],B).
hmove(R,U) :-
append(Rl,[x,x,o|Rr],R),
append(Rl,[o,o,x|Rr],U).
hmove(R,U) :-
append(Rl,[o,x,x|Rr],R),
append(Rl,[x,o,o|Rr],U).
vmove(U0,V0,Z0, U2,V2,Z2) :-
nth0(C,U0,x,U1),nth0(C,V0,x,V1),nth0(C,Z0,o,Z1),!,
nth0(C,U2,o,U1),nth0(C,V2,o,V1),nth0(C,Z2,x,Z1).
vmove(U0,V0,Z0, U2,V2,Z2) :-
nth0(C,U0,o,U1),nth0(C,V0,x,V1),nth0(C,Z0,x,Z1),!,
nth0(C,U2,x,U1),nth0(C,V2,o,V1),nth0(C,Z2,o,Z1).
/*
at_least_2([R|Rs],C,S) :-
aggregate_all(count,member(S,R),T),
U is C+T,
( U >= 2 -> true ; at_least_2(Rs,U,S) ).
count(B,S,N) :-
aggregate_all(sum(Xs),
(member(R,B), aggregate_all(count, member(S,R), Xs)),
N).
*/
build(Cx,Cy,at(X,Y,A),B,P) :-
findall(Rs,(between(1,Cy,R),
findall(S,(between(1,Cx,C),
(R=Y,C=X -> S=A ; S=B)), Rs)), P).
build(A_at,B,P) :-
build(5,5,A_at,B,P).
Sorry, it doesn't terminate... but it gives us a small set of tools we can use to better understand the problem.
Did you noticed that every step there will be a peg less ?
Then, we can avoid counting pegs, and this is my better hint for optimization so far.
solve(S,R) :-
build(at(3,3,o),x,I),
steps_c(I,24,R,S).
steps_c(F,N,N,[F]).
steps_c(A,C,N,[A|R]) :-
step(A,B), % to debug... show(B),
succ(D,C), % or D is C-1,
steps_c(B,D,N,R).
Alas, it will not help too much: now we can choice the 'solution' level:
?- time(solve(S,3)),maplist([T]>>(maplist(writeln,T),nl),S).
% 155,322 inferences, 0.110 CPU in 0.111 seconds (99% CPU, 1411851 Lips)
[x,x,x,x,x]
[x,x,x,x,x]
[x,x,o,x,x]
[x,x,x,x,x]
[x,x,x,x,x]
[x,x,x,x,x]
[x,x,x,x,x]
[o,o,x,x,x]
[x,x,x,x,x]
[x,x,x,x,x]
...
Let's evaluate some solutions with 3 poles left:
?- time(call_nth(solve(S,3),1000)).
% 4,826,178 inferences, 2.913 CPU in 2.914 seconds (100% CPU, 1656701 Lips)
S = [[[x, x, x, x, x], ....
?- time(call_nth(solve(S,3),10000)).
% 53,375,354 inferences, 31.968 CPU in 31.980 seconds (100% CPU, 1669646 Lips)
S = [[[x, x, x, x, x],
We have about 5K inferences / solution at level 3. But it's clear there are a lot of them. So, it's hopeless to attempt ?- solve(S, 1). This brute force approach doesn't work...
Maybe I will try using better problem domain encoding, and modelling with library(clpfd).
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, ..., ...;..., ...;...;...)