How could I merge two dictionaries, summing values of same keys? - prolog

What I want is something like merge(Dict1, Dict2, Merged) that behaves like the following:
?- merge(counter{a: 1, b: 2}, counter{a: 3, c: 4, d: 5}, Merged).
Merged = counter{a: 4, b: 2, c: 4, d: 5}
What should I do to achieve this? I'm totally new to logic programming, so I end up failing trying to write something that looks like a terrible port of for loop of other languages.

dicts_merge_add(Dict1, Dict2, DictMerged) :-
% Convert to sorted key-value pairs
dict_pairs(Dict1, Tag, Pairs1),
dict_pairs(Dict2, Tag, Pairs2),
% Merge the pairs
pairs_merge_add(Pairs1, Pairs2, PairsMerged),
% Convert to dict
dict_pairs(DictMerged, Tag, PairsMerged).
% When reached end of 1 list, insert the remains of the other list
pairs_merge_add([], T, T) :- !.
pairs_merge_add(T, [], T) :- !.
pairs_merge_add([K-V1|T1], [K-V2|T2], L) :-
% Keys are same
!,
Sum is V1 + V2,
L = [K-Sum|Merg],
pairs_merge_add(T1, T2, Merg).
pairs_merge_add([K1-V1|T1], [K2-V2|T2], L) :-
K1 #< K2,
!,
L = [K1-V1|Merg],
pairs_merge_add(T1, [K2-V2|T2], Merg).
pairs_merge_add([K1-V1|T1], [K2-V2|T2], L) :-
K1 #> K2,
!,
L = [K2-V2|Merg],
pairs_merge_add([K1-V1|T1], T2, Merg).
Result in swi-prolog:
?- D1 = counter{a: 1, b: 2, z:6},
D2 = counter{a: 3, c: 4, z:8, d: 5},
time(dicts_merge_add(D1, D2, Merg)).
% 17 inferences, 0.000 CPU in 0.000 seconds (88% CPU, 389265 Lips)
D1 = counter{a:1,b:2,z:6},
D2 = counter{a:3,c:4,d:5,z:8},
Merg = counter{a:4,b:2,c:4,d:5,z:14}.
Simple performance test:
?- C = 30_000, numlist(1, C, L1N),
findall(N-N, member(N, L1N), L1),
dict_pairs(D1, v, L1), numlist(1, C, L2N),
findall(N-N, member(N, L2N), L2), dict_pairs(D2, v, L2),
time(merge(D1, D2, D3)), sleep(10).
% 180,005 inferences, 5.475 CPU in 5.486 seconds (100% CPU, 32877 Lips)
Vs mine: time(dicts_merge_add(D1, D2, D3))
% 60,005 inferences, 0.012 CPU in 0.012 seconds (100% CPU, 4987461 Lips)
This shows the huge performance advantage from using the fact that the lists are sorted.

This approach gets the entries from A, recurses over them and merges them into B:
merge(A, B, Merged) :-
dict_pairs(A, _, Pairs), % Pairs are an ordered set
merge_(Pairs, B, Merged).
merge_([], Merged, Merged). % No more pairs, merge finished.
merge_([K-V|Ps], B, Merged) :- % Merge Key-Value from A.
(get_dict(K, B, Bval) -> % Get the matching item from B.
Sum is V + Bval % if success, sum their values.
; Sum is V), % if not, just the value from A.
put_dict(K, B, Sum, B_), % merge into B.
merge_(Ps, B_, Merged). % merge remaining pairs into B.
On SWISH:
?- _D1 = counter{a: 1, b: 2, z:6},
_D2 = counter{a: 3, c: 4, z:8, d: 5},
time(merge(_D1, _D2, Merg)).
Merg = counter{a:4, b:2, c:4, d:5, z:14}
19 inferences, 0.000 CPU in 0.000 seconds (116% CPU, 827526 Lips)

Related

Need help programming a list in Prolog

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)

Sublist from list

Ieed to select a sublist from the list, from K to N indexes.
Example:
?- sublist(2, 5, [1, 2, 3, 4, 5, 6, 7, 8, 9], Res)
Res = [2, 3, 4, 5]
Given both integers K and N, you may use length/2 and append/3:
sublist(K, N, L, SL):-
N >= K,
length(L1, N), % L1 is a list with N elements
length([_|L2], K), % and L2 has K-1 elements.
append(L2, SL, L1), % Therefore SL has the last N-K+1 elements of L1
append(L1, _, L). % and L starts with L1 and may have some other elements after
Sample run:
?- sublist(2, 5, [1, 2, 3, 4, 5, 6, 7, 8, 9], Res).
Res = [2, 3, 4, 5].
sublist(StartPos, EndPos, Lst, SubLst) :-
% Check for sensible inputs
must_be(integer, StartPos),
must_be(integer, EndPos),
StartPos >= 1,
EndPos >= StartPos,
% Loop through the list
sublist_(Lst, StartPos, EndPos, 1, SubLst).
sublist_(Lst, StartPos, EndPos, StartPos, SubLst) :-
!,
% At start of sublist
sublist_within_(Lst, StartPos, EndPos, StartPos, SubLst).
sublist_(Lst, StartPos, EndPos, Pos, SubLst) :-
% Otherwise, is before the start of the sublist
Pos1 is Pos + 1,
% Don't care about the current element in the list
Lst = [_|Tail],
sublist_(Tail, StartPos, EndPos, Pos1, SubLst).
sublist_within_(Lst, StartPos, EndPos, Pos, SoFar) :-
Pos < EndPos,
% Within the sublist
!,
Pos1 is Pos + 1,
% Remember the current element in the list (in the correct order)
Lst = [Head|Tail],
SoFar = [Head|SubLst],
sublist_within_(Tail, StartPos, EndPos, Pos1, SubLst).
% End of the sublist - instantiate the end of SubLst
sublist_within_([Head|_], _StartPos, EndPos, EndPos, [Head]).
Result in swi-prolog:
?- time(sublist(2, 5, [1, 2, 3, 4, 5, 6, 7, 8, 9], Res)).
% 17 inferences, 0.000 CPU in 0.000 seconds (91% CPU, 514388 Lips)
Res = [2,3,4,5].
A smaller but slower alternative is:
sublist_slow(StartPos, EndPos, Lst, SubLst) :-
succ(BeforeLen, StartPos),
SubLstLen is EndPos - StartPos + 1,
length(BeforeLst, BeforeLen),
length(SubLst, SubLstLen),
% append is slow because it needs to iterate through the entire list
append([BeforeLst, SubLst, _AfterLst], Lst),
% Don't look for other potentials for _AfterLst
!.
But the "append" method has the disadvantage of having to iterate through the rest of the list, whereas the first method can stop at the end of SubLst - performance comparison:
test_sublists :-
numlist(1, 1000000, NL),
time(sublist(2, 5, NL, _)),
time(sublist_slow(2, 5, NL, _)).
Result in swi-prolog:
?- test_sublists.
% 17 inferences, 0.000 CPU in 0.000 seconds (90% CPU, 460256 Lips)
% 2,000,015 inferences, 0.249 CPU in 0.247 seconds (101% CPU, 8016137 Lips)
gusbro's method is in the middle, performance-wise:
test_sublists2 :-
numlist(1, 1000000, NL),
I = 100000,
time(sublist(I, I, NL, _)),
time(sublist_gusbro(I, I, NL, _)),
time(sublist_slow(I, I, NL, _)).
Performance result:
?- test_sublists2.
% 100,009 inferences, 0.011 CPU in 0.011 seconds (100% CPU, 8970530 Lips)
% 200,009 inferences, 0.015 CPU in 0.015 seconds (100% CPU, 13718721 Lips)
% 1,900,020 inferences, 0.198 CPU in 0.196 seconds (101% CPU, 9585032 Lips)
Here is a variant of Evgeny's code, with improved performance and termination:
sublist_evgeny(St, En, [_ | T], SubT) :-
St > 1, !,
% Move closer to the start element
St0 is St - 1,
En0 is En - 1,
sublist_evgeny(St0, En0, T, SubT).
sublist_evgeny(1, 0, _, SL) :-
!,
% Finished - the remaining sublist will be empty
SL = [].
sublist_evgeny(1, En, [H | T], [H | SubT]) :-
% Populate the sublist
En0 is En - 1,
sublist_evgeny(1, En0, T, SubT).
Performance is great:
% 200,001 inferences, 0.010 CPU in 0.010 seconds (100% CPU, 19344211 Lips)
Here is solution without any library functions:
sublist(1, 0, _, []).
sublist(A, B, [H | T], [H | SubT]) :-
A = 1,
B1 is B - 1,
sublist(A, B1, T, SubT).
sublist(A, B, [_ | T], SubT) :-
A > 1,
A1 is A - 1,
B1 is B - 1,
sublist(A1, B1, T, SubT).

Prolog - generate fibonacci series

I want to write predicate that generates the Fibonacci series for given N.
fibon(6, X) -> X = [0,1,1,2,3,5].
I have a predicate to generate the N-th element of the Fibonacci series:
fib(0, 0).
fib(1, 1).
fib(N, F) :-
N > 1,
N1 is N - 1,
N2 is N - 2,
fib(N1, F1),
fib(N2, F2),
F is F1 + F2.
And I try to write fibon/2, but it doesn't work:
fibon(N, [H|T]) :-
fib(N, H),
N1 is N - 1,
fibon(N1, T).
I solved it like the following:
at_the_end(X, [], [X]).
at_the_end(X, [H|T], [H|T2]) :-
at_the_end(X, T, T2).
revert([], []).
revert([H|T], Out) :-
revert(T, Out1),
at_the_end(H, Out1, Out).
fib(0, 0).
fib(1, 1).
fib(N, F) :-
N > 1,
N1 is N - 1,
N2 is N - 2,
fib(N1, F1),
fib(N2, F2),
F is F1 + F2.
fibon(0, [0]).
fibon(N, [H|T]) :-
fib(N, H),
N1 is N - 1,
fibon(N1, T).
fibonacci(In, Out) :-
fibon(In, Out1),
revert(Out1, Out).
You can squeeze out a little more speed by making the recursive predicate tail recursive:
fib_seq(0,[0]). % <- base case 1
fib_seq(1,[0,1]). % <- base case 2
fib_seq(N,Seq) :-
N > 1,
fib_seq_(N,SeqR,1,[1,0]), % <- actual relation (all other cases)
reverse(SeqR,Seq). % <- reverse/2 from library(lists)
fib_seq_(N,Seq,N,Seq).
fib_seq_(N,Seq,N0,[B,A|Fs]) :-
N > N0,
N1 is N0+1,
C is A+B,
fib_seq_(N,Seq,N1,[C,B,A|Fs]). % <- tail recursion
First let's observe that your example query works as expected:
?- fib_seq(6,L).
L = [0, 1, 1, 2, 3, 5, 8] ;
false.
Note that the list doesn't have six elements, as in your example at the beginning of your post, but seven. This is because the predicate starts counting at zero (BTW this is the same behaviour as that of the predicate fibonacci/2 that you added to your post).
For comparison (with fib/2 from #Enigmativity's post) reasons, let's either remove the goal reverse/2 from fib_seq/2 (then you'd get all solutions except N=0 and N=1 in reverse order):
?- time((fib(50000,L),false)).
% 150,001 inferences, 0.396 CPU in 0.396 seconds (100% CPU, 379199 Lips)
false.
?- time((fib_seq(50000,L),false)).
% 150,002 inferences, 0.078 CPU in 0.078 seconds (100% CPU, 1930675 Lips)
false.
Or leave fib_seq/2 as it is and measure fib/2 with an additional goal reverse/2 (then R in the fib/2 solution corresponds to L in the fib_seq/2 solution):
?- time((fib(50000,L),reverse(L,R),false)).
% 200,004 inferences, 0.409 CPU in 0.409 seconds (100% CPU, 488961 Lips)
false.
?- time((fib_seq(50000,L),false)).
% 200,005 inferences, 0.088 CPU in 0.088 seconds (100% CPU, 2267872 Lips)
false.
On a side note, I would urge you to compare your predicate fibonacci/2 with the posted solutions when trying to get bigger lists, say N > 30.
If you're happy to reverse the order of the results for the sequence then this works:
fib(0, [0]).
fib(1, [1,0]).
fib(N, [R,X,Y|Zs]) :-
N > 1,
N1 is N - 1,
fib(N1, [X,Y|Zs]),
R is X + Y.
Then ?- fib(15,Z). gives me [610, 377, 233, 144, 89, 55, 34, 21, 13, 8, 5, 3, 2, 1, 1, 0].
It would be easy to throw in a reverse/3 predicate:
reverse([],Z,Z).
reverse([H|T],Z,A) :- reverse(T,Z,[H|A]).
Just for fun using scanl. and some standard dcgs.
:-use_module(library(clpfd)).
my_plus(X,Y,Z):-
Z#>=0,
Z#=<1000, % Max size optional
Z#=X+Y.
list([]) --> [].
list([L|Ls]) --> [L], list(Ls).
concatenation([]) --> [].
concatenation([List|Lists]) -->
list(List),
concatenation(Lists).
fib(Len,List1):-
X0=1,
length(List1,Len),
length(End,2),
MiddleLen #= Len - 3,
length(Middle,MiddleLen),
phrase(concatenation([[X0],Middle,End]), List1),
phrase(concatenation([[X0],Middle]), List2),
phrase(concatenation([Middle,End]), List3),
scanl(my_plus,List2,X0,List3).
If you want to collect a list of the first N elements of the Fibonacci series you can use the rule below. Just remember to initialize the first 2 predicates.
fib(0, [1]).
fib(1, [1, 1]).
fib(N, L) :-
N > 1,
N1 is N - 1,
N2 is N - 2,
fib(N1, F1),
last(F1, L1),
fib(N2, F2),
last(F2, L2),
L_new is L1 + L2,
append(F1, [L_new], L).

prolog write langford sequence ERROR: toplevel: Undefined procedure: langford/1

I'm trying to write langford sequence.
like this:
73 ?- langford4(L).
L = [4, 1, 3, 1, 2, 4, 3, 2] ;
L = [2, 3, 4, 2, 1, 3, 1, 4] ;
This is what i have done:
prefix([H|T],L):-cat([H|T],_,L).
sublist(S,L):-prefix(P,L), posfix(S,P).
posfix([H|T],L):-cat(_,[H|T],L).
langford42(L):-
L = [_,_,_,_,_,_,_,_],
sublist([1,_,1], L),
sublist([2,_,_,2], L),
sublist([3,_,_,_,3], L),
sublist([4,_,_,_,_,4], L).
or this:
langford(L):-
[X,_,_,_,_,X,_,_],
[_,Y,_,Y,_,_,_,_],
[_,_,Z,_,_,_,Z,_],
[_,_,_,_,P,_,_,P].
thanks.
don't get your question, your code seems fine, but anyway the problem, when generalized, is nice: I tried solving with CLP(FD) and the simpler library builtins
% two copies of each number k are k units apart
% constraint solution: would be nice to know how we could speedup this one...
langford_c(N, S) :-
M is N*2,
length(S, M),
S ins 1..N,
distances(S, S),
findall(I-2, between(1,N,I), Cs),
global_cardinality(S, Cs),
label(S).
distances([N|T], S) :-
element(I, S, N),
element(J, S, N),
J #= I + N + 1,
distances(T, S).
distances([], _).
% simple nth1/3 based solution
langford_n(N, S) :-
M is N*2,
length(S, M),
distances(S, 1, N).
distances(S, P, C) :-
P =< C, !,
nth1(I, S, P),
nth1(J, S, P),
J is I + P + 1,
Q is P + 1,
distances(S, Q, C).
distances(_, _, _).
with these result
?- time(langford_n(4, S)).
% 1,102 inferences, 0.000 CPU in 0.000 seconds (98% CPU, 2598909 Lips)
S = [4, 1, 3, 1, 2, 4, 3, 2] ;
% 1,404 inferences, 0.001 CPU in 0.001 seconds (99% CPU, 2679103 Lips)
S = [2, 3, 4, 2, 1, 3, 1, 4] ;
% 1,234 inferences, 0.001 CPU in 0.001 seconds (54% CPU, 2064308 Lips)
false.
?- time(langford_c(4, S)).
% 1,302,863 inferences, 0.489 CPU in 0.491 seconds (100% CPU, 2664067 Lips)
S = [2, 3, 4, 2, 1, 3, 1, 4] ;
% 958,979 inferences, 0.367 CPU in 0.371 seconds (99% CPU, 2611630 Lips)
S = [4, 1, 3, 1, 2, 4, 3, 2] ;
% 359,396 inferences, 0.137 CPU in 0.141 seconds (98% CPU, 2614215 Lips)
false.

Board Assembly with constraints

I am doing this problem but I am completely new to Prolog and I have no idea how to do it.
Nine parts of an electronic board have square shape, the same size and each edge of every part is marked with a letter and a plus or minus sign. The parts are to be assembled into a complete board as shown in the figure below such that the common edges have the same letter and opposite signs. Write a planner in Prolog such that the program takes 'assemble' as the query and outputs how to assemble the parts, i.e. determine the locations and positions of the parts w.r.t. the current positions so that they fit together to make the complete board.
I have tried solving it and I have written the following clauses:
complement(a,aNeg).
complement(b,bNeg).
complement(c,cNeg).
complement(d,dNeg).
complement(aNeg,a).
complement(bNeg,b).
complement(cNeg,c).
complement(dNeg,d).
% Configuration of boards, (board,left,top,right,bottom)
conf(b1,aNeg,bNeg,c,d).
conf(b2,bNeg,a,d,cNeg).
conf(b3,dNeg,cNeg,b,d).
conf(b4,b,dNeg,cNeg,d).
conf(b5,d,b,cNeg,aNeg).
conf(b6,b,aNeg,dNeg,c).
conf(b7,aNeg,bNeg,c,b).
conf(b8,b,aNeg,cNeg,a).
conf(b9,cNeg,bNeg,a,d).
position(b1,J,A).
position(b2,K,B).
position(b3,L,C).
position(b4,M,D).
position(b5,N,E).
position(b6,O,F).
position(b7,P,G).
position(b8,Q,H).
position(b9,R,I).
assemble([A,B,C,E,D,F,G,H,I,J,K,L,M,N,O,P,Q,R]) :-
Variables=[(A,J),(B,K),(C,L),(D,M),(E,N),(F,O),(G,P),(H,Q),(I,R)],
all_different(Variables),
A in 1..3, B in 1..3, C in 1..3, D in 1..3, E in 1..3,
F in 1..3, G in 1..3, H in 1..3, I in 1..3, J in 1..3,
K in 1..3, L in 1..3, M in 1..3, N in 1..3, O in 1..3,
P in 1..3, Q in 1..3, R in 1..3,
% this is where I am stuck, what to write next
I don't know even if they are correct and I am not sure how to proceed further to solve this problem.
Trivial with CLP(FD):
:- use_module(library(clpfd)).
board(Board) :-
Board = [[A1,A2,A3],
[B1,B2,B3],
[C1,C2,C3]],
maplist(top_bottom, [A1,A2,A3], [B1,B2,B3]),
maplist(top_bottom, [B1,B2,B3], [C1,C2,C3]),
maplist(left_right, [A1,B1,C1], [A2,B2,C2]),
maplist(left_right, [A2,B2,C2], [A3,B3,C3]),
pieces(Ps),
maplist(board_piece(Board), Ps).
top_bottom([_,_,X,_], [Y,_,_,_]) :- X #= -Y.
left_right([_,X,_,_], [_,_,_,Y]) :- X #= -Y.
pieces(Ps) :-
Ps = [[-2,3,4,-1], [1,4,-3,-4], [-3,2,4,-4],
[-4,-3,4,2], [2,-3,-1,4], [-1,-4,3,2],
[-2,3,2,-1], [-1,-3,1,2], [-2,1,4,-3]].
board_piece(Board, Piece) :-
member(Row, Board),
member(Piece0, Row),
rotation(Piece0, Piece).
rotation([A,B,C,D], [A,B,C,D]).
rotation([A,B,C,D], [B,C,D,A]).
rotation([A,B,C,D], [C,D,A,B]).
rotation([A,B,C,D], [D,A,B,C]).
Example query and its result:
?- time(board(Bs)), maplist(writeln, Bs).
11,728,757 inferences, 0.817 CPU in 0.817 seconds
[[-3, -4, 1, 4], [-1, -2, 3, 4], [4, -4, -3, 2]]
[[-1, 4, 2, -3], [-3, 4, 2, -4], [3, 2, -1, -4]]
[[-2, 1, 4, -3], [-2, 3, 2, -1], [1, 2, -1, -3]]
This representation uses 1,2,3,4 to denote positive a,b,c,d, and -1,-2,-3,-4 for the negative ones.
This is only a tiny improvement to #mat's beautiful solution. The idea is to reconsider the labeling process. That is maplist(board_piece,Board,Ps) which reads (semi-procedurally):
For all elements in Ps, thus for all pieces in that order: Take one piece and place it anywhere on the board rotated or not.
This means that each placement can be done in full liberty. To show you a weak order, one might take: A1,A3,C1,C3,B2 and then the rest. In this manner, the actual constraints are not much exploited.
However, there seems to be no good reason that the second tile is not placed in direct proximity to the first. Here is such an improved order:
...,
pieces(Ps),
TilesOrdered = [B2,A2,A3,B3,C3,C2,C1,B1,A1],
tiles_withpieces(TilesOrdered, Ps).
tiles_withpieces([], []).
tiles_withpieces([T|Ts], Ps0) :-
select(P,Ps0,Ps1),
rotation(P, T),
tiles_withpieces(Ts, Ps1).
Now, I get
?- time(board(Bs)), maplist(writeln, Bs).
% 17,179 inferences, 0.005 CPU in 0.005 seconds (99% CPU, 3363895 Lips)
[[-3,1,2,-1],[-2,3,2,-1],[2,4,-4,-3]]
[[-2,1,4,-3],[-2,3,4,-1],[4,2,-4,-3]]
[[-4,3,2,-1],[-4,1,4,-3],[4,2,-3,-1]]
and without the goal maplist(maplist(tile), Board),
% 11,010 inferences, 0.003 CPU in 0.003 seconds (100% CPU, 3225961 Lips)
and to enumerate all solutions
?- time((setof(Bs,board(Bs),BBs),length(BBs,N))).
% 236,573 inferences, 0.076 CPU in 0.154 seconds (49% CPU, 3110022 Lips)
BBs = [...]
N = 8.
previously (#mat's original version) the first solution took:
% 28,874,632 inferences, 8.208 CPU in 8.217 seconds (100% CPU, 3518020 Lips)
and all solutions:
% 91,664,740 inferences, 25.808 CPU in 37.860 seconds (68% CPU, 3551809 Lips)
In terms of performance, the following is no contender to #false's very fast solution.
However, I would like to show you a different way to formulate this, so that you can use the constraint solver to approximate the faster allocation strategy that #false found manually:
:- use_module(library(clpfd)).
board(Board) :-
Board = [[A1,A2,A3],
[B1,B2,B3],
[C1,C2,C3]],
maplist(top_bottom, [A1,A2,A3], [B1,B2,B3]),
maplist(top_bottom, [B1,B2,B3], [C1,C2,C3]),
maplist(left_right, [A1,B1,C1], [A2,B2,C2]),
maplist(left_right, [A2,B2,C2], [A3,B3,C3]),
pieces(Ps0),
foldl(piece_with_id, Ps0, Pss, 0, _),
append(Pss, Ps),
append(Board, Bs0),
maplist(tile_with_var, Bs0, Bs, Vs),
all_distinct(Vs),
tuples_in(Bs, Ps).
tile_with_var(Tile, [V|Tile], V).
top_bottom([_,_,X,_], [Y,_,_,_]) :- X #= -Y.
left_right([_,X,_,_], [_,_,_,Y]) :- X #= -Y.
pieces(Ps) :-
Ps = [[-2,3,4,-1], [1,4,-3,-4], [-3,2,4,-4],
[-4,-3,4,2], [2,-3,-1,4], [-1,-4,3,2],
[-2,3,2,-1], [-1,-3,1,2], [-2,1,4,-3]].
piece_with_id(P0, Ps, N0, N) :-
findall(P, (rotation(P0,P1),P=[N0|P1]), Ps),
N #= N0 + 1.
rotation([A,B,C,D], [A,B,C,D]).
rotation([A,B,C,D], [B,C,D,A]).
rotation([A,B,C,D], [C,D,A,B]).
rotation([A,B,C,D], [D,A,B,C]).
You can now use the "first fail" strategy of CLP(FD) and try the most constrained elements first. With this formulation, the time needed to find all 8 solutions is:
?- time(findall(t, (board(B), term_variables(B, Vs), labeling([ff],Vs)), Ts)).
2,613,325 inferences, 0.208 CPU in 0.208 seconds
Ts = [t, t, t, t, t, t, t, t].
In addition, I would like to offer the following contender for the speed contest, which I obtained with an extensive partial evaluation of the original program:
solution([[[-4,-3,2,4],[2,-1,-4,3],[2,-1,-3,1]],[[-2,3,4,-1],[4,2,-4,-3],[3,2,-1,-2]],[[-4,1,4,-3],[4,2,-3,-1],[1,4,-3,-2]]]).
solution([[[-3,-4,1,4],[-1,-2,3,4],[4,-4,-3,2]],[[-1,4,2,-3],[-3,4,2,-4],[3,2,-1,-4]],[[-2,1,4,-3],[-2,3,2,-1],[1,2,-1,-3]]]).
solution([[[-3,-2,1,4],[-3,-1,4,2],[4,-3,-4,1]],[[-1,-2,3,2],[-4,-3,4,2],[4,-1,-2,3]],[[-3,1,2,-1],[-4,3,2,-1],[2,4,-4,-3]]]).
solution([[[-3,1,2,-1],[-2,3,2,-1],[2,4,-4,-3]],[[-2,1,4,-3],[-2,3,4,-1],[4,2,-4,-3]],[[-4,3,2,-1],[-4,1,4,-3],[4,2,-3,-1]]]).
solution([[[-3,-1,4,2],[4,-3,-4,1],[2,-1,-4,3]],[[-4,-3,4,2],[4,-1,-2,3],[4,-3,-2,1]],[[-4,-3,2,4],[2,-1,-2,3],[2,-1,-3,1]]]).
solution([[[-1,-3,1,2],[2,-1,-2,3],[4,-3,-2,1]],[[-1,-4,3,2],[2,-4,-3,4],[2,-3,-1,4]],[[-3,2,4,-4],[3,4,-1,-2],[1,4,-3,-4]]]).
solution([[[-1,-4,3,2],[-3,-2,1,4],[-1,-3,1,2]],[[-3,-4,1,4],[-1,-2,3,4],[-1,-2,3,2]],[[-1,4,2,-3],[-3,4,2,-4],[-3,2,4,-4]]]).
solution([[[4,-4,-3,2],[2,-4,-3,4],[2,-3,-1,4]],[[3,2,-1,-2],[3,4,-1,-2],[1,4,-3,-4]],[[1,2,-1,-3],[1,4,-3,-2],[3,2,-1,-4]]]).
The 8 solutions are found very rapidly with this formulation:
?- time(findall(t, solution(B), Ts)).
19 inferences, 0.000 CPU in 0.000 seconds
Ts = [t, t, t, t, t, t, t, t].

Resources