I'm not happy with this tent predicate of arity 7.
How about this skeleton code. It took me a bit to recover lost Prolog knowledge. I'm using "negation as failure" to make sure the constraints are followed. It works in SWISH.
This might be easier to encode in a Prolog-like language that is made for constraint satisfaction (ECLiPSe or ASP/Potassco maybe? I have never tried to do that though.)
Writing this, it turns out that
- The fun thing with Prolog is that you never really know whether the solution you get is what you actually want.
- Solution too short, too large, won't return, gives false only. Argh!
- You don't need complex datastructures ... but you need assertions to check intermediate, partial solutions.
- One gets the feeling that one is way, way slower than when coding in imperative language, but this not really true. There are more inferences to handle when looking a single line, which would be equivalent to a paragraph of confusing boredom in an imperative language.
So:
% Create tents and indicate their positions, too. These are basically "tent names"
% in the form of a literal where the name carries the x and y position.
% We won't need this but "in front of" means: in_front_of(tent(X,1),tent(X,2)).
tent(1,1).
tent(2,1).
tent(3,1).
tent(1,2).
tent(2,2).
tent(3,2).
% Create colors (just as an example)
color(blue).
color(red).
color(green).
color(white).
color(black).
color(mauve).
% Create cars (just as an example)
car(mazda).
car(ford).
car(renault).
car(tesla).
car(skoda).
car(unimog).
% Create surnames (just as an example)
surname(skywalker).
surname(olsndot).
surname(oneagle).
% Create names (just as an example) and give the traditional sex
name(peter,male).
name(marvin,male).
name(ian,male).
name(sheila,female).
name(mary,female).
name(ann,female).
% Give traditional family pair. male is first element in pair.
pair(Nm,Nf,Sn) :- name(Nm,male),name(Nf,female),surname(Sn).
% Our logic universe is now filled with floating stuff: tents, colors, cars, names.
% A "solution" consists in linking these together into a consistent whole respecting
% all the constraints given by the "zebra puzzle"
% A "solution" is a data structure like any other. We choose to have a big list with
% literals. Every literal expresses an assignment between a tent and an attribute:
%
% attribute_nameΔ(tent_x,tent_y,attribute_value)
%
% Other representations are possible. (Why the "Δ"? Because I like it!)
% We need a list of all tents over which to recurse/induct when generating a "solution".
% ... bagof provides!
% This could possibly be done by directly backtracking over the tent/2 predicate.
all_tents(LTs) :- bagof(tent(X,Y), tent(X,Y), LTs).
% We need a list of all pairs over which to recurse/induct when generating a "solution".
% ... bagof provides!
% This could possibly be done by directly backtracking over the pair/2 predicate.
all_pairs(Ps) :- bagof(pair(Nm,Nf,Sn), pair(Nm,Nf,Sn), Ps).
% Select possible assignments of "color<->tent", adding the possible assignments to
% an existing list of selected assignments.
%
% assign_colors(List-of-Tents-to-recurse-over,List-with-Assignments(In),List-with-more-Assignments(Out)).
assign_colors([],Bounce,Bounce).
assign_colors([tent(X,Y)|Ts], Acc, Out) :-
color(Co),
\+is_color_used(Acc,Co),
assign_colors(Ts, [colorΔ(X,Y,Co)|Acc], Out).
is_color_used([colorΔ(_,_,Co)|_],Co) :- !. % cut to make this deterministic
is_color_used([_|R],Co) :- is_color_used(R,Co).
% Select possible assignment of "car<->tent", adding the possible assignments to
% an existing list of selected assignments.
%
% assign_cars(List-of-Tents-to-recurse-over,List-with-Assignments(In),List-with-more-Assignments(Out)).
assign_cars([],Bounce,Bounce).
assign_cars([tent(X,Y)|Ts], Acc, Out) :-
car(Ca),
\+is_car_used(Acc,Ca),
assign_cars(Ts, [carΔ(X,Y,Ca)|Acc], Out).
is_car_used([carΔ(_,_,Ca)|_],Ca) :- !. % cut to make this deterministic
is_car_used([_|R],Ca) :- is_car_used(R,Ca).
% Select possible assignment of "name<->tent", adding the possible assignments to
% an existing list of selected assignments.
%
% In this case, we have to check additional constraints when choosing a possible assignment:
%
% 1) A name may only be used once
% 2) Ian and Peter's are not in front of each other
%
% assign_names(List-of-Tents-to-recurse-over,List-with-Assignments(In),List-with-more-Assignments(Out)).
assign_names([],Bounce,Bounce).
assign_names([tent(X,Y)|Ts], Acc, Out) :-
name(Na,_),
\+is_name_used(Acc,Na),
\+is_ian_in_front_of_peter([nameΔ(X,Y,Na)|Acc]),
assign_names(Ts, [nameΔ(X,Y,Na)|Acc], Out).
is_name_used([nameΔ(_,_,Na)|_],Na) :- !. % cut to make this deterministic
is_name_used([_|R],Na) :- is_name_used(R,Na).
is_ian_in_front_of_peter(S) :-
pick_name(S,nameΔ(X,_,_),peter),
pick_name(S,nameΔ(X,_,_),ian),
write("IAN vs PETER confirmed!\n").
pick_name([nameΔ(X,Y,Name)|_],nameΔ(X,Y,Name),Name).
pick_name([_|R],Found,Name) :- pick_name(R,Found,Name).
% Select possible pairs, adding the possible pairs to an existing list of selected pairs (the same
% as the list of selected assignments). The nature of this selection is **different than the two
% others** as we backtrack over the list of pairs, instead of just recursing over it. Hence,
% three clauses^and a verification that we have 3 pairs in the end.
%
% In this case, we have to check additional constraints when choosing a possible assignment:
%
% 1) Peter's wife name is not Ann
%
% assign_pairs(List-of-Pairs-to-recurse-over,List-with-Assignments(In),List-with-more-Assignments(Out)).
assign_pairs([],Bounce,Bounce) :- count_pairs(Bounce,3). % hardcoded number of surnames; we need 3 pairs!
assign_pairs([pair(Nm,Nf,Sn)|Ps], Acc, Out) :-
\+is_any_name_already_paired(Acc,Nm,Nf,Sn),
\+is_peter_married_ann([pairΔ(Nm,Nf,Sn)|Acc]),
assign_pairs(Ps, [pairΔ(Nm,Nf,Sn)|Acc], Out).
assign_pairs([_|Ps], Acc, Out) :- assign_pairs(Ps, Acc, Out).
is_any_name_already_paired([pairΔ(N,_,_)|_],N,_,_) :- !. % cut to make this deterministic
is_any_name_already_paired([pairΔ(_,N,_)|_],_,N,_) :- !. % cut to make this deterministic
is_any_name_already_paired([pairΔ(_,_,S)|_],_,_,S) :- !. % cut to make this deterministic
is_any_name_already_paired([_|R],Nm,Nf,Sn) :- is_any_name_already_paired(R,Nm,Nf,Sn).
count_pairs([],0).
count_pairs([pairΔ(_,_,_)|R],C) :- !,count_pairs(R,C2), C is C2+1. % red cut
count_pairs([_|R],C) :- count_pairs(R,C).
% this would be more advantageously done by eliminating that pair in the list of
% possible pairs; but leave it here to make the solution less "a bag of special cases"
is_peter_married_ann([pairΔ(peter,ann,_)|_]) :- !. % cut to make this deterministic
is_peter_married_ann([_|R]) :- is_peter_married_ann(R).
% Find a consistent solution by adding assignements for the various attributes
% while checking constraints
solution(SOut) :-
all_tents(Tents),
all_pairs(Pairs),
assign_colors(Tents,[],S1),
assign_cars(Tents,S1,S2),
assign_names(Tents,S2,S3),
assign_pairs(Pairs,S3,SOut).
Run it
?- solution(SOut).
SOut = [pairΔ(ian, ann, oneagle), pairΔ(marvin, mary, olsndot),
pairΔ(peter, sheila, skywalker), nameΔ(3, 2, ann), nameΔ(2, 2, mary),
nameΔ(1, 2, sheila), nameΔ(3, 1, ian), nameΔ(2, 1, marvin),
nameΔ(1, 1, peter), carΔ(3, 2, unimog), carΔ(2, 2, skoda),
carΔ(1, 2, tesla), carΔ(3, 1, renault), carΔ(2, 1, ford),
carΔ(1, 1, mazda), colorΔ(3, 2, mauve), colorΔ(2, 2, black),
colorΔ(1, 2, white), colorΔ(3, 1, green), colorΔ(2, 1, red),
colorΔ(1, 1, blue)]
