Related
I have a predict which gets first N elements:
nfirst(N, _, Lnew) :- N =< 0, Lnew = [].
nfirst(_, [], []).
nfirst(N, [X|Y], [X|Y1]) :- N1 is N - 1, nfirst(N1, Y, Y1).
It works:
% nfirst(3,[1,2,3,4,5,6],X).
% X = [1, 2, 3]
I need a predict for divide list like below:
% divide([a,b,c,d,e,f,g,h],[3,2,1,2],X).
% X = [[a,b,c],[d,e],[f],[g,h]]
The best way is using nfirst.
Very similar question to the one I answered here. Again, the trick is to use append/3 plus length/2 to "bite off" a chunk of list, per my comment above:
split_at(N, List, [H|[T]]) :- append(H, T, List), length(H, N).
If you run that, you'll see this:
?- split_at(4, [1,2,3,4,5,6,7,8], X).
X = [[1, 2, 3, 4], [5, 6, 7, 8]] ;
So this is the backbone of your program, and now you just need the usual recursive stuff around it. First, the base case, which says, if I'm out of list, I should be out of split locations, and thus out of result:
divide([], [], []).
Note that explicit base cases like this make your program more correct than something like divide([], _, _) because they will cause you to fail if you get too many split locations for your list size.
Now the recursive case is not difficult, but because split_at/3 puts two things together in a list (probably a bad choice, you could make split_at/4 as an improvement) you have to take them out, and it clouds the logic a bit here while making (IMO) a nicer API on its own.
divide(List, [Split|Splits], [Chunk|Rest]) :-
split_at(Split, List, [Chunk, Remainder]),
divide(Remainder, Splits, Rest).
This should be fairly straightforward: we're just taking a Split location, using it to chop up the List, and repeating the processing on what's left over. It seems to work as you expect:
?- divide([a,b,c,d,e,f,g,h],[3,2,1,2],X).
X = [[a, b, c], [d, e], [f], [g, h]] ;
false.
Hope this helps! Compare to the other answer, it may illuminate things.
I have tried to solve the 'Escape from Zurg' problem with clpfd. https://web.engr.oregonstate.edu/~erwig/papers/Zurg_JFP04.pdf
Toys start on the left and go to the right. This is what I have:
:-use_module(library(clpfd)).
toy(buzz,5).
toy(woody,10).
toy(res,20).
toy(hamm,25).
%two toys cross, the time is the max of the two.
cross([A,B],Time):-
toy(A,T1),
toy(B,T2),
dif(A,B),
Time#=max(T1,T2).
%one toy crosses
cross(A,T):-
toy(A,T).
%Two toys travel left to right
solve_L(Left,Right,[l_r(A,B,T)|Moves]):-
select(A,Left,L1),
select(B,L1,Left2),
cross([A,B],T),
solve_R(Left2,[A,B|Right],Moves).
%One toy has to return with the flash light
solve_R([],_,[]).
solve_R(Left,Right,[r_l(A,empty,T)|Moves]):-
select(A,Right,Right1),
cross(A,T),
solve_L([A|Left],Right1,Moves).
solve(Moves,Time):-
findall(Toy,toy(Toy,_),Toys),
solve_L(Toys,_,Moves),
all_times(Moves,Times),
sum(Times,#=,Time).
all_times([],[]).
all_times(Moves,[Time|Times]):-
Moves=[H|Tail],
H=..[_,_,_,Time],
all_times(Tail,Times).
Querying ?-solve(M,T) or ?-solve(Moves,T), labeling([min(T)],[T]). I get a solution but not one =< 60. (I cant see one either..)
How would I do this with clpfd? Or is it best to use the method in the link?
FYI: I have also found this http://www.metalevel.at/zurg/zurg.html
Which has a DCG solution. In it the constraint Time=<60 is built in, it does not find the lowest time.
Here is a CLP(FD) version, based on the code you linked to.
The main difference is that in this version, Limit is a parameter instead of a hardcoded value. In addition, it also uses the flexibility of CLP(FD) constraints to show that, compared to low-level arithmetic, you can much more freely reorder your goals when using constraints, and reason about your code much more declaratively:
:- use_module(library(clpfd)).
toy_time(buzz, 5).
toy_time(woody, 10).
toy_time(rex, 20).
toy_time(hamm, 25).
moves(Ms, Limit) :-
phrase(moves(state(0,[buzz,woody,rex,hamm],[]), Limit), Ms).
moves(state(T0,Ls0,Rs0), Limit) -->
[left_to_right(Toy1,Toy2)],
{ T1 #= T0 + max(Time1,Time2), T1 #=< Limit,
select(Toy1, Ls0, Ls1), select(Toy2, Ls1, Ls2),
Toy1 #< Toy2,
toy_time(Toy1, Time1), toy_time(Toy2, Time2) },
moves_(state(T1,Ls2,[Toy1,Toy2|Rs0]), Limit).
moves_(state(_,[],_), _) --> [].
moves_(state(T0,Ls0,Rs0), Limit) -->
[right_to_left(Toy)],
{ T1 #= T0 + Time, T1 #=< Limit,
select(Toy, Rs0, Rs1),
toy_time(Toy, Time) },
moves(state(T1,[Toy|Ls0],Rs1), Limit).
Usage example, using iterative deepening to find fastest solutions first:
?- length(_, Limit), moves(Ms, Limit).
Limit = 60,
Ms = [left_to_right(buzz, woody), right_to_left(buzz), left_to_right(hamm, rex), right_to_left(woody), left_to_right(buzz, woody)] ;
Limit = 60,
Ms = [left_to_right(buzz, woody), right_to_left(woody), left_to_right(hamm, rex), right_to_left(buzz), left_to_right(buzz, woody)] ;
Limit = 61,
Ms = [left_to_right(buzz, woody), right_to_left(buzz), left_to_right(hamm, rex), right_to_left(woody), left_to_right(buzz, woody)] ;
etc.
Note that this version uses a combination of CLP(FD) constraints (for pruning and arithmetic) and built-in Prolog backtracking, and such a combination is perfectly legitimate. In some cases, global constraints (like automaton/8 mentioned by CapelliC) can express a problem in its entirety, but combining constraints with normal backtracking is a good strategy too for many tasks.
In fact, just posting CLP(FD) constraints is typically not enough anyways: You typically also need a (backtracking) search, provided by labeling/2 in the case of CLP(FD), to obtain concrete solutions. So, this iterative deepening is similar to the search that labeling/2 would otherwise perform if you succeed to express the problem deterministically with CLP(FD) constraints alone.
Nicely, we can also show:
?- Limit #< 60, moves(Ms, Limit).
false.
EDIT: Since the thirst for automaton/8 seems to be almost unquenchable among interested users of CLP(FD) constraints, which is nice, I have also created a solution with this powerful global constraint for you. If you find this interesting, please also upvote #CapelliC's answer, since he had the initial idea to use automaton/8 for this. The idea is to let each possible (and sensible) movement of either one or two toys correspond to a unique integer, and these movements induce transitions between different states of the automaton. Notice that the side of the flash light also plays an important role in states. In addition, we equip each arc with an arithmetic expression to keep track of the time taken so far. Please try out ?- arc(_, As). to see the arcs of this automaton.
:- use_module(library(clpfd)).
toy_time(b, 5).
toy_time(w, 10).
toy_time(r, 20).
toy_time(h, 25).
toys(Toys) :- setof(Toy, T^toy_time(Toy, T), Toys).
arc0(arc0(S0,M,S)) :-
state(S0),
state0_movement_state(S0, M, S).
arcs(V, Arcs) :-
findall(Arc0, arc0(Arc0), Arcs0),
movements(Ms),
maplist(arc0_arc(V, Ms), Arcs0, Arcs).
arc0_arc(C, Ms, arc0(S0,M,S), arc(S0, MI, S, [C+T])) :-
movement_time(M, T),
nth0(MI, Ms, M).
movement_time(left_to_right(Toy), Time) :- toy_time(Toy, Time).
movement_time(left_to_right(T1,T2), Time) :-
Time #= max(Time1,Time2),
toy_time(T1, Time1),
toy_time(T2, Time2).
movement_time(right_to_left(Toy), Time) :- toy_time(Toy, Time).
state0_movement_state(lrf(Ls0,Rs0,left), left_to_right(T), lrf(Ls,Rs,right)) :-
select(T, Ls0, Ls),
sort([T|Rs0], Rs).
state0_movement_state(lrf(Ls0,Rs0,left), left_to_right(T1,T2), S) :-
state0_movement_state(lrf(Ls0,Rs0,left), left_to_right(T1), lrf(Ls1,Rs1,_)),
state0_movement_state(lrf(Ls1,Rs1,left), left_to_right(T2), S),
T1 #< T2.
state0_movement_state(lrf(Ls0,Rs0,right), right_to_left(T), lrf(Ls,Rs,left)) :-
select(T, Rs0, Rs),
sort([T|Ls0], Ls).
movements(Moves) :-
toys(Toys),
findall(Move, movement(Toys, Move), Moves).
movement(Toys, Move) :-
member(T, Toys),
( Move = left_to_right(T)
; Move = right_to_left(T)
).
movement(Toys0, left_to_right(T1, T2)) :-
select(T1, Toys0, Toys1),
member(T2, Toys1),
T1 #< T2.
state(lrf(Lefts,Rights,Flash)) :-
toys(Toys),
phrase(lefts(Toys), Lefts),
foldl(select, Lefts, Toys, Rights),
( Flash = left ; Flash = right ).
lefts([]) --> [].
lefts([T|Ts]) --> ( [T] | [] ), lefts(Ts).
And now, at long last, we can finally use automaton/8 which we so deeply desire for a solution we truly deem worthy of carrying the "CLP(FD)" banner, orgiastically mixed with the min/1 option of labeling/2:
?- time((arcs(C, Arcs),
length(Vs, _),
automaton(Vs, _, Vs, [source(lrf([b,h,r,w],[],left)),
sink(lrf([],[b,h,r,w],right))],
Arcs, [C], [0], [Time]),
labeling([min(Time)], Vs))).
yielding:
857,542 inferences, 0.097 CPU in 0.097 seconds(100% CPU, 8848097 Lips)
Arcs = [...],
Time = 60,
Vs = [10, 1, 11, 7, 10] ;
etc.
I leave translating such solutions to readable state transitions as an easy exercise (~3 lines of code).
For extra satisfaction, this is much faster than the original version with plain Prolog, for which we had:
?- time((length(_, Limit), moves(Ms, Limit))).
1,666,522 inferences, 0.170 CPU in 0.170 seconds (100% CPU, 9812728 Lips)
The moral of this story: If your straight-forward Prolog solution takes more than a tenth of a second to yield solutions, you better learn how to use one of the most complex and powerful global constraints in order to improve the running time by a few milliseconds! :-)
On a more serious note though, this example shows that constraint propagation can pay off very soon, even for comparatively small search spaces. You can expect even larger relative gains when solving more complex search problems with CLP(FD).
Note though that the second version, although it propagates constraints more globally in a sense, lacks an important feature that is also related to propagation and pruning: Previously, we were able to directly use the program to show that there is no solution that takes less than 60 minutes, using a straight-forward and natural query (?- Limit #< 60, moves(Ms, Limit)., which failed). This follows from the second program only implicitly, because we know that, ceteris paribus, longer lists can at most increase the time taken. Unfortunately though, the isolated call of length/2 did not get the memo.
On the other hand, the second version is able to prove something that is in a sense at least equally impressive, and it does so more efficiently and somewhat more directly than the first version: Without even constructing a single explicit solution, we can use the second version to show that any solution (if there is one) takes at least 5 crossings:
?- time((arcs(C, Arcs),
length(Vs, L),
automaton(Vs, _, Vs, [source(lrf([b,h,r,w],[],left)),
sink(lrf([],[b,h,r,w],right))],
Arcs, [C], [0], [Time]))).
yielding:
331,495 inferences, 0.040 CPU in 0.040 seconds (100% CPU, 8195513 Lips)
...,
L = 5
... .
This works by constraint propagation alone, and does not involve any labeling/2!
I think that modelling with CLPFD this puzzle could be done with automaton/8.
In Prolog I would write
escape_zurg(T,S) :-
aggregate(min(T,S), (
solve([5,10,20,25], [], S),
sum_timing(S, T)), min(T,S)).
solve([A, B], _, [max(A, B)]).
solve(L0, R0, [max(A, B), C|T]) :-
select(A, L0, L1),
select(B, L1, L2),
append([A, B], R0, R1),
select(C, R1, R2),
solve([C|L2], R2, T).
sum_timing(S, T) :-
aggregate(sum(E), member(E, S), T).
that yields this solution
?- escape_zurg(T,S).
T = 60,
S = [max(5, 10), 5, max(20, 25), 10, max(10, 5)].
edit
well, automaton/8 is well beyond my reach...
let's start simpler: what could be a simple representation of state ?
on left/right we have 4 slots, that can be empty: so
escape_clpfd(T, Sf) :-
L0 = [_,_,_,_],
Zs = [0,0,0,0],
L0 ins 5\/10\/20\/25,
all_different(L0),
...
now, since the problem it's so simple, we can 'hardcode' the state change
...
lmove(L0/Zs, 2/2, L1/R1, T1), rmove(L1/R1, 1/3, L2/R2, T2),
lmove(L2/R2, 3/1, L3/R3, T3), rmove(L3/R3, 2/2, L4/R4, T4),
lmove(L4/R4, 4/0, Zs/ _, T5),
...
the first lmove/4 must shift 2 elements from left to right, and after it have done, we will have 2 zeros at left, and 2 at right. The timing (T1) will be max(A,B), where A,B are incognite by now.
rmove/4 is similar, but will 'return' in T2 the only element (incognito) it will move from right to left. We are encoding the evolution asserting the number of 0s on each side (seems not difficult to generalize).
Let's complete:
...
T #= T1 + T2 + T3 + T4 + T5,
Sf = [T1,T2,T3,T4,T5].
Now, rmove/4 is simpler, so let's code it:
rmove(L/R, Lz/Rz, Lu/Ru, M) :-
move_one(R, L, Ru, Lu, M),
count_0s(Ru, Rz),
count_0s(Lu, Lz).
it defers to move_one/5 the actual work, then applies the numeric constraint we hardcoded above:
count_0s(L, Z) :-
maplist(is_0, L, TF),
sum(TF, #=, Z).
is_0(V, C) :- V #= 0 #<==> C.
is_0/2 reifies the empty slot condition, that is makes countable the truth value. It's worth to test it:
?- count_0s([2,1,1],X).
X = 0.
?- count_0s([2,1,C],1).
C = 0.
?- count_0s([2,1,C],2).
false.
Coding move_one/5 in CLP(FD) seems difficult. Here Prolog nondeterminism seems really appropriate...
move_one(L, R, [Z|Lt], [C|Rt], C) :-
select(C, L, Lt), is_0(C, 0),
select(Z, R, Rt), is_0(Z, 1).
select/3 it's a pure predicate, and Prolog will backtrack when labeling will need...
There is no minimization, but that is easy to add after we get the solutions.
So far, all seems 'logical' to me. But, of course...
?- escape_clpfd(T, S).
false.
So, here be dragons...
?- spy(lmove),escape_clpfd(T, S).
% Spy point on escape_zurg:lmove/4
* Call: (9) escape_zurg:lmove([_G12082{clpfd = ...}, _G12164{clpfd = ...}, _G12246{clpfd = ...}, _G12328{clpfd = ...}]/[0, 0, 0, 0], 2/2, _G12658/_G12659, _G12671) ? creep
Call: (10) escape_zurg:move_one([_G12082{clpfd = ...}, _G12164{clpfd = ...}, _G12246{clpfd = ...}, _G12328{clpfd = ...}], [0, 0, 0, 0], _G12673, _G12674, _G12661) ? sskip
... etc etc
Sorry, will post a solution if I'll get some spare time to debug...
edit there were several bugs... with this lmove/4
lmove(L/R, Lz/Rz, Lu/Ru, max(A, B)) :-
move_one(L, R, Lt, Rt, A),
move_one(Lt, Rt, Lu, Ru, B),
count_0s(Lu, Lz),
count_0s(Ru, Rz).
at least we start getting solutions (added variables to interface to label from outside...)
escape_clpfd(T, Sf, L0) :- ...
?- escape_clpfd(T, S, Vs), label(Vs).
T = 85,
S = [max(5, 10), 10, max(10, 20), 20, max(20, 25)],
Vs = [5, 10, 20, 25] ;
T = 95,
S = [max(5, 10), 10, max(10, 25), 25, max(25, 20)],
Vs = [5, 10, 25, 20] ;
...
edit
the code above works, but is painfully slow:
?- time((escape_clpfd(60, Sf, L0),label(L0))).
% 15,326,054 inferences, 5.466 CPU in 5.485 seconds (100% CPU, 2803917 Lips)
Sf = [max(5, 10), 10, max(20, 25), 5, max(5, 10)],
L0 = [5, 10, 20, 25]
with this change to move_one/5:
move_one([L|Ls], [R|Rs], [R|Ls], [L|Rs], L) :-
L #\= 0,
R #= 0.
move_one([L|Ls], [R|Rs], [L|Lu], [R|Ru], E) :-
move_one(Ls, Rs, Lu, Ru, E).
I have better performance:
?- time((escape_clpfd(60, Sf, L0),label(L0))).
% 423,394 inferences, 0.156 CPU in 0.160 seconds (97% CPU, 2706901 Lips)
Sf = [max(5, 10), 5, max(20, 25), 10, max(5, 10)],
L0 = [5, 10, 20, 25]
then, adding to lmove/4
... A #< B, ...
i get
% 233,953 inferences, 0.089 CPU in 0.095 seconds (94% CPU, 2621347 Lips)
Sf = [max(5, 10), 5, max(20, 25), 10, max(5, 10)],
the whole it's still a lot slower than my pure Prolog solution...
edit
other small improvements:
?- time((escape_clpfd(60, Sf, L0),maplist(#=,L0,[5,10,20,25]))).
% 56,583 inferences, 0.020 CPU in 0.020 seconds (100% CPU, 2901571 Lips)
Sf = [max(5, 10), 5, max(20, 25), 10, max(5, 10)],
where all_different/1 has been replaced by
...
chain(L0, #<),
...
Another improvement: counting both side for zeros is useless: removing (arbitrarly) one side in both lmove and rmove we get
% 35,513 inferences, 0.014 CPU in 0.014 seconds (100% CPU, 2629154 Lips)
Sf = [max(5, 10), 5, max(20, 25), 10, max(5, 10)],
edit
Just for fun, here is the same pure (except aggregation) Prolog solution, using a simple deterministic 'lifting' of variables (courtesy 'lifter'):
:- use_module(carlo(snippets/lifter)).
solve([A, B], _, [max(A, B)]).
solve(L0, R0, [max(A, B), C|T]) :-
solve([C|select(B, select(A, L0, °), °)],
select(C, append([A, B], R0, °), °),
T).
btw, it's rather fast:
?- time(escape_zurg(T,S)).
% 50,285 inferences, 0.065 CPU in 0.065 seconds (100% CPU, 769223 Lips)
T = 60,
S = [max(5, 10), 5, max(20, 25), 10, max(10, 5)].
(the absolute timing is not so good because I'm running a SWI-Prolog compiled for debugging)
I think #mat has come up with a good answer for what I was originally trying to do but I did try and also use automaton/4, alongside backtracking search to add arcs. This is as far I got. But I get the error ERROR: Arguments are not sufficiently instantiated when calling bridge/2. Just posting here if anyone has any comments on this approach or knows why this would come up with this error, or if I am using automaton/4 completely wrong!
fd_length(L, N) :-
N #>= 0,
fd_length(L, N, 0).
fd_length([], N, N0) :-
N #= N0.
fd_length([_|L], N, N0) :-
N1 is N0+1,
N #>= N1,
fd_length(L, N, N1).
left_to_right_arc(L0,R0,Arc):-
LenL#=<4,
fd_length(L0,LenL),
LenR #=4-LenL,
fd_length(R0,LenR),
L0 ins 5\/10\/20\/25,
R0 ins 5\/10\/20\/25,
append(L0,R0,All),
all_different(All),
Before =[L0,R0],
select(A,L0,L1),
select(B,L1,L2),
append([A,B],R0,R1),
After=[L2,R1],
Cost #=max(A,B),
Arc =arc(Before,Cost,After).
right_to_left_arc(L0,R0,Arc):-
LenL#=<4,
fd_length(L0,LenL),
LenR #=4-LenL,
fd_length(R0,LenR),
L0 ins 5\/10\/20\/25,
R0 ins 5\/10\/20\/25,
append(L0,R0,All),
all_different(All),
Before=[L0,R0],
select(A,R0,R1),
append([A],L0,L1),
After=[L1,R1],
Cost#=A,
Arc =arc(After,Cost,Before).
pair_of_arcs(Arcs):-
left_to_right_arc(_,_,ArcLR),
right_to_left_arc(_,_,ArcRL),
Arcs =[ArcLR,ArcRL].
pairs_of_arcs(Pairs):-
L#>=1,
fd_length(Pairs,L),
once(maplist(pair_of_arcs,Pairs)).
bridge(Vs,Arcs):-
pairs_of_arcs(Arcs),
flatten(Arcs,FArcs),
automaton(Vs,[source([[5,10,20,25],[]]),sink([[],[5,10,20,25]])],
FArcs).
This is not an answer for using CLP(FD) but just to show the two solutions that exist for this puzzle with cost equal or lower than 60 (the text is too big to put in a comment).
There are several variations of this puzzle. Logtalk includes one, in its searching/bridge.lgt example, with different set of characters and corresponding times to cross the bridge. But we can patch it to solve instead for the variation in this question (using the current Logtalk git version):
?- set_logtalk_flag(complements, allow).
true.
?- {searching(loader)}.
...
% (0 warnings)
true.
?- create_category(patch, [complements(bridge)], [], [initial_state(start, ([5,10,20,25], left, [])), goal_state(end, ([], right, [5,10,20,25]))]).
true.
?- performance::init, bridge::initial_state(Initial), hill_climbing(60)::solve(bridge, Initial, Path, Cost), bridge::print_path(Path), performance::report.
5 10 20 25 lamp _|____________|_
20 25 _|____________|_ lamp 5 10
5 20 25 lamp _|____________|_ 10
5 _|____________|_ lamp 10 20 25
5 10 lamp _|____________|_ 20 25
_|____________|_ lamp 5 10 20 25
solution length: 6
state transitions (including previous solutions): 113
ratio solution length / state transitions: 0.05309734513274336
minimum branching degree: 1
average branching degree: 5.304347826086956
maximum branching degree: 10
time: 0.004001000000000032
Initial = ([5, 10, 20, 25], left, []),
Path = [([5, 10, 20, 25], left, []), ([20, 25], right, [5, 10]), ([5, 20, 25], left, [10]), ([5], right, [10, 20, 25]), ([5, 10], left, [20, 25]), ([], right, [5|...])],
Cost = 60 ;
5 10 20 25 lamp _|____________|_
20 25 _|____________|_ lamp 5 10
10 20 25 lamp _|____________|_ 5
10 _|____________|_ lamp 5 20 25
5 10 lamp _|____________|_ 20 25
_|____________|_ lamp 5 10 20 25
solution length: 6
state transitions (including previous solutions): 219
ratio solution length / state transitions: 0.0273972602739726
minimum branching degree: 1
average branching degree: 5.764705882352941
maximum branching degree: 10
time: 0.0038759999999999906
Initial = ([5, 10, 20, 25], left, []),
Path = [([5, 10, 20, 25], left, []), ([20, 25], right, [5, 10]), ([10, 20, 25], left, [5]), ([10], right, [5, 20, 25]), ([5, 10], left, [20, 25]), ([], right, [5|...])],
Cost = 60 ;
false.
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].
I'm trying to write a program that swaps the 1st and last elements.
The function takes 2 parameters. A list and a variable that's displayed as the newly swapped list.
I thought I was doing it the lazy way, but it's turning out to be just as hard for me.
I was going to grab the head, put it aside -- grab the last element of the tail, put it aside -- take the tail, remove the last element, put it aside also, then append all 3 together to make a list
I'm having trouble removing the last element of the tail.
I have something like this:
swap( [H|T], Y ) :-
% GET HEAD, LAST OF TAIL, AND TAIL WITH LAST ELEM REMOVED
% GET HEAD (NEW LAST ELEMENT)
H = NEW_LASTELEMENT,
% GET LAST ELEMENT (LAST OF TAIL, WILL BE NEW HEAD)
last(T,X), X = NEWHEAD,
% CUT END OF TAIL OFF
cutlast(T, Z), REST OF CODE . . .
.
% CUT LAST
cutlast([H | T], [H | T2]) :- T = [_|_], cutlast(T, T2).
I borrowed the cutlast predicate from the web, but I'm not sure how it's even supposed to work. I've been test passing parameters to it for an hour now and they all keep returning false. Any assistance is appreciated.
Could be just:
swap(A, B) :-
append([First | Mid], [Last], A),
append([Last | Mid], [First], B).
Additional facts to succeed with one element and empty lists, if it's needed:
swap([X], [X]).
swap([], []).
Here's a recursive solution that doesn't use the append/3 or reverse/2 built-ins. I think I found it to be a lot more efficient (in terms of number of inferences) than those:
swap_fl_recursive([First|A], [Last|B]) :-
swap_fl_recursive_(A, First, Last, B).
swap_fl_recursive_([Last], First, Last, [First]).
swap_fl_recursive_([X|A], First, Last, [X|B]) :-
swap_fl_recursive_(A, First, Last, B).
This solution passes the original First element down through the recursion until it can become the new last element, and instantiates the original Last back to become the new first element.
Like the others, for swap_fl_recursive([X], [X]) to be true or swap_fl_recursive([], []). to be true, those need to be added as facts/rules.
Timing/inferences for append/3 version:
?- numlist(1,10000,L), time(swap_fl_append(L, S)).
% 20,000 inferences, 0.021 CPU in 0.021 seconds (100% CPU, 950838 Lips)
L = [1, 2, 3, 4, 5, 6, 7, 8, 9|...],
S = [10000, 2, 3, 4, 5, 6, 7, 8, 9|...] ;
% 3 inferences, 0.000 CPU in 0.000 seconds (94% CPU, 38921 Lips)
false.
Timing/inferences for reverse/2 version:
?- numlist(1,10000,L), time(swap_fl_reverse(L, S)).
% 20,055 inferences, 0.024 CPU in 0.024 seconds (100% CPU, 841265 Lips)
L = [1, 2, 3, 4, 5, 6, 7, 8, 9|...],
S = [10000, 2, 3, 4, 5, 6, 7, 8, 9|...].
Timing/inferences for recursive version (shown in this answer):
?- numlist(1,10000,L), time(swap_fl_recursive(L, S)).
% 10,000 inferences, 0.009 CPU in 0.010 seconds (99% CPU, 1059142 Lips)
L = [1, 2, 3, 4, 5, 6, 7, 8, 9|...],
S = [10000, 2, 3, 4, 5, 6, 7, 8, 9|...] ;
% 2 inferences, 0.002 CPU in 0.002 seconds (100% CPU, 821 Lips)
false.
All three of these approaches are linear time proportional to the length of the list.
Here's an alternative version using the built-in reverse/2 instead of append/3.
swap_first_last([First|A], [Last|B]) :-
reverse(A, [Last|RevMid]),
reverse([First|RevMid], B).
It's perhaps slightly less efficient than the version Sergey showed with append/3. Like the append/3 version, if you want swap_first_last([X], [X]). and/or swap_first_last([], []). to be true, you have to add them as facts/predicates. But they aren't needed for lists of length 2 or greater.
This predicate says, [Last|B] is the same as [First|A] with the first and last elements swapped if [Last|RevMid] is the reverse of list A, and B is the reverse of [First|RevMid].
The first reverse reverses the tail of the first list (A) yielding a list which has its own head and tail, [Last|RevMid]. At this point, Last represents the last element of the first list, and RevMid represents the "middle" list, not including the first and last elements, but in reverse order.
The second reverse then takes the first list's head, First, and uses it as the head for a new list which is [First|RevMid]. If we reverse this list, we'll end up with the "middle" list in the correct order and First slapped on the end (this list is called B) so we've got the original first element as the last element of this list and all the right middle elements. All that's left is to have the first lists last element (Last) prepended as the head, which occurs in the head of the clause as [Last|B].
By way of example, let's take the query, swap_first_last([a,b,c,d,e], S).:
Unify [First|A] with [a,b,c,d,e] yielding, First = a and A = [b,c,d,e]
Query reverse([b,c,d,e], [Last|RevMid]) which yields, [Last|T] = [e,d,c,b], or, Last = e and RevMid = [d,c,b].
Query reverse([a|[d,c,b]], B) which is reverse([a,d,c,b], B) yielding, B = [b,c,d,a]
Instantiating [Last|B] as [e|[b,c,d,a]] or [e,b,c,d,a]
Using a dcg:
swap_first_last(Xs,Ys) :-
phrase(([First],seq(Seq),[Last]), Xs),
phrase(([Last], seq(Seq),[First]), Ys).
seq([]) --> [].
seq([E|Es]) --> [E], seq(Es).
But this - similarly to the other suggestions, does not terminate if only Ys is a list. A first attempt would be to constrain the lists to the same length:
same_length([], []).
same_length([_|Xs], [_|Ys]) :-
same_length(Xs, Ys).
swap_first_last(Xs,Ys) :-
same_length(Xs, Ys),
phrase(([First],seq(Seq),[Last]), Xs),
phrase(([Last], seq(Seq),[First]), Ys).
But what, if the lists differ in the second element? Like in
?- Xs = [_,a|_], Ys = [_,b|_], swap_first_last(Xs, Ys).
Xs = [b,a], Ys = [a,b]
; loops.
Our predicate still could terminate with:
swap_first_last(Xs, [Last|Ys]) :-
phrase(([First],dseq(Ys,[First]),[Last]), Xs).
dseq(Xs,Xs) --> [].
dseq([X|Xs0],Xs) --> [X], dseq(Xs0,Xs).
I need some help writing a predicate in Prolog that, given a number as input, returns a list of lists with numbers that add up to it.
Let's call the predicate addUpList/2, it should work like this:
?- addUpList(3,P).
P = [[1,2], [2,1], [1,1,1]]. % expected result
I'm having so much trouble figuring this out I'm beginning to think it's impossible. Any ideas? Thanks in advance.
Try this:
condense([], Rs, Rs).
condense([X|Xs], Ys, Zs) :-
condense(Xs, [X|Ys], Zs).
condense([X, Y|Xs], Ys, Zs) :-
Z is X + Y,
condense([Z|Xs], Ys, Zs).
condense(Xs, Rs) :-
condense(Xs, [], Rs).
expand(0, []).
expand(N, [1|Ns]) :-
N > 0,
N1 is N - 1,
expand(N1, Ns).
addUpList(N, Zs) :-
expand(N, Xs),
findall(Ys, condense(Xs, Ys), Zs).
Let me know what marks I get. :-)
The rule num_split/2 generates ways of splitting a number into a list, where the first element X is any number between 1 and N and the rest of the list is a split of N-X.
num_split(0, []).
num_split(N, [X | List]) :-
between(1, N, X),
plus(X, Y, N),
num_split(Y, List).
In order to get all such splits, just call findall/3 on num_split/2.
add_up_list(N, Splits) :-
findall(Split, num_split(N, Split), Splits).
Usage example:
?- add_up_list(4, Splits).
Splits =
[[1, 1, 1, 1], [1, 1, 2], [1, 2, 1], [1, 3], [2, 1, 1], [2, 2], [3, 1], [4]].
See also the post by #hardmath which gives the same answer with a bit more explanation.
The example given in the Question suggests that compositions (ordered partitions) of any positive integer N ≤ 10 are wanted. Note however that the solution [3] for N=3 seems to have been omitted/overlooked. The number of compositions of N is 2^(N-1), so N=10 gives a long list but not an unmanageable one.
It is also desired to collect all such solutions into a list, something that findall/3 can do generically after we write a predicate composition/2 that generates them.
The idea is to pick the first summand, anything between 1 and N, subtract it from the total and recurse (stopping with an empty list when the total reaches zero). SWI-Prolog provides a predicate between/3 that can generate those possible first summands, and Amzi! Prolog provides a similar predicate for/4. For the sake of portability we write our own version here.
summand(Low,High,_) :-
Low > High,
!,
fail.
summand(Low,High,Low).
summand(Low,High,Val) :-
Now is Low + 1,
summand(Now,High,Val).
composition(0,[ ]).
composition(N,[H|T]) :-
summand(1,N,H),
M is N - H,
composition(M,T).
Given the above Prolog source code, compiled or interpreted, a list of all solutions can be had in this way:
?- findall(C,composition(3,C),L).
C = H126
L = [[1, 1, 1], [1, 2], [2, 1], [3]]
Of course some arrangement of such a list of solutions or the omission of the singleton list might be required for your specific application, but this isn't clear as the Question is currently worded.
There are plenty of great answers to this question already, but here is another solution to this problem for you to consider. This program differs from the others in that it is very efficient, and generates non-redundant solutions of lists which are assumed to represent sets of integers which add up to the specified number.
gen(N, L) :-
gen(N-1, N, N, FL),
dup_n(FL, L).
gen(C-F, M, M, [C-F]).
gen(C-F, S, M, [C-F|R]) :-
S < M, C > 1,
C0 is C - 1,
F0 is floor(M / C0),
S0 is S + (C0 * F0),
gen(C0-F0, S0, M, R).
gen(C-F, S, M, R) :-
F > 0,
F0 is F - 1,
S0 is S - C,
gen(C-F0, S0, M, R).
dup_n([], []).
dup_n([_-0|R], L) :-
!, dup_n(R, L).
dup_n([V-F|R], [V|L]) :-
F0 is F - 1,
dup_n([V-F0|R], L).
Your implementation of addUpList/2 can be achieved by:
addUpList(N, P) :-
findall(L, gen(N, L), P).
Which should give you the following behaviour:
?- addUpList(4,L).
L = [[4], [3, 1], [2, 2], [2, 1, 1], [1, 1, 1, 1]].
Note that the list containing one 2 and two 1s only appears once in this result set; this is because gen/4 computes unique sets of integers which add up to the specified number.
This answer is somewhere between
#Kaarel's answer and
#sharky's "efficient" answer.
Like #sharky's code, we impose an ordering relation between adjacent list items to restrict the size of the solution space---knowing how to inflate it if we ever need to. So the solution sets of break_down/2 and gen/2 by #sharky are equal (disregarding list reversal).
And as for performance, consider:
?- time((break_down(40,_),false)).
% 861,232 inferences, 0.066 CPU in 0.066 seconds (100% CPU, 13127147 Lips)
false.
?- time((gen(40,_),false)).
% 8,580,839 inferences, 0.842 CPU in 0.842 seconds (100% CPU, 10185807 Lips)
false.