Mrs. Rosencrantz' Jess query (a Zebra Puzzle) expressed in Prolog - prolog

Question

In the book Jess in Action - Rule-Based Systems in Java (written more than 10 years back; I think Drools is the system to use today?), Ernest Friedman-Hill solves the constraint problem given below using Jess, an OPS5-style forward-chaining production system written in Java. I want to solve it using Prolog.
The question is: do I solve it correctly?
The problem
A foursome of golfers is standing at a tee, in a line from left to
right. Each golfer wears different colored pants; one is wearing red
pants. The golfer to Fed’s immediate right is wearing blue pants. Joe
is second in line. Bob is wearing plaid pants. Tom isn’t in position
one or four, and he isn’t wearing the hideous orange pants.
In what
order will the four golfers tee off, and what color are each golfer’s
pants?
This is an instance of a Zebra Puzzle. See also this presentation for a beautifully illustrated solution to a more complex one.
Using Jess, by Ernest Friedman-Hill
Using the Jess production system the code would be as follows. This is from the above-mentioned book, with variables renamed for clarity.
The working memory is filled with 32 links from golfers to their possible positions and pant-colors. The find-solution rule fires for the link set fulfilling the constraints.
This seems hard to think about because one does not test "possible worlds" for whether they fulfill the constraints but one selects a set of links that fulfill the constraints. Is not clear that this indeed what one is looking for.
;; Templates for working memory, basically the links golfer<->pantscolor,
;; and golfer<->position.
(deftemplate pants-color (slot of) (slot is))
(deftemplate position (slot of) (slot is))
;; Generate all possible 'pants-color' and 'position' facts
;; 4 names, each with 4 pants-color: 16 entries
;; 4 names, each with 4 positions: 16 entries
;; This gives the 32 facts describing the links
(defrule generate-possibilities
=>
(foreach ?name (create$ Fred Joe Bob Tom)
(foreach ?color (create$ red blue plaid orange)
(assert (pants-color (of ?name) (is ?color))))
(foreach ?position (create$ 1 2 3 4)
(assert (position (of ?name) (is ?position))))))
;; The “find solution” rule forward-chains and prints out a solution
(defrule find-solution
;; There is a golfer named Fred, whose position is ?p_fred and
;; pants color is ?c_fred
(position (of Fred) (is ?p_fred))
(pants-color (of Fred) (is ?c_fred))
;; The golfer to Fred's immediate right (who is not Fred) is wearing
;; blue pants.
(position (of ?n&~Fred) (is ?p&:(eq ?p (+ ?p_fred 1))))
(pants-color (of ?n&~Fred) (is blue&~?c_fred))
;; Joe is in position #2
(position (of Joe) (is ?p_joe&2&~?p_fred))
(pants-color (of Joe) (is ?c_joe&~?c_fred))
;; Bob is wearing the plaid pants (so his position is not “n” either
;; because “n” has blue pants)
(position (of Bob) (is ?p_bob&~?p_fred&~?n&~?p_joe))
(pants-color (of Bob&~?n) (is plaid&?c_bob&~?c_fred&~?c_joe))
;; Tom isn't in position 1 or 4 and isn't wearing orange (and not blue
;; either)
(position (of Tom&~?n) (is ?p_tom&~1&~4&~?p_fred&~?p_joe&~?p_bob))
(pants-color (of Tom) (is ?c_tom&~orange&~blue&~?c_fred&~?c_joe&~?c_bob))
=>
(printout t Fred " " ?p_fred " " ?c_fred crlf)
(printout t Joe " " ?p_joe " " ?c_joe crlf)
(printout t Bob " " ?p_bob " " ?c_bob crlf)
(printout t Tom " " ?p_tom " " ?c_tom crlf crlf))
My first solution in Prolog
Turns out this is inelegant & heavy-handed (see other answers)
Let's look for a datastructure to describe the solution, given as follows: Choose a list, at each position there is a "golfer" having a "Name" and a "Pants Color": [golfer(N0,C0),golfer(N1,C1),golfer(N2,C2),golfer(N3,C3)]. Each golfer also has the teeing position from 0 to 3 given by the actual position in the list; the position is not given explicitly as in golfer(Name,Color,Position).
solution(L) :-
% select possible pants colors which must be pairwise different; for
% fast fail, we check often
is_pants_color(C0),
is_pants_color(C1),are_pairwise_different([C0,C1]),
is_pants_color(C2),are_pairwise_different([C0,C1,C2]),
is_pants_color(C3),are_pairwise_different([C0,C1,C2,C3]),
% select possible golfer names which must be pairwise different; for
% fast fail, we check often
is_name(N0),
% we know that joe is second in line, so we can plonck that condition
% in here immediately
N1 = joe,
is_name(N1),are_pairwise_different([N0,N1]),
is_name(N2),are_pairwise_different([N0,N1,N2]),
is_name(N3),are_pairwise_different([N0,N1,N2,N3]),
% instantiate the solution in a unique order (we don't change the order
% as we permute exhuastively permute colors and names)
L = [golfer(N0,C0),golfer(N1,C1),golfer(N2,C2),golfer(N3,C3)],
% tom is not in position one or four; express this clearly using
% "searchWithPosition" instead of implicitly by unification with L
search(tom,L,golfer(_,_,TomPosition)),
TomPosition \== 0,
TomPosition \== 3,
% check additional constraints using L
rightOf(fred,L,golfer(_,blue)),
search(bob,L,golfer(_,plaid,_)),
\+search(tom,L,golfer(_,hideous_orange,_)).
% here we stipulate the colors
is_pants_color(red).
is_pants_color(blue).
is_pants_color(plaid).
is_pants_color(hideous_orange).
% here we stipulate the names
is_name(joe).
is_name(bob).
is_name(tom).
is_name(fred).
% helper predicate
are_pairwise_different(L) :- sort(L,LS), length(L,Len), length(LS,Len).
% Search a golfer by name in the solution list, iteratively.
% Also return the position 0..3 for fun and profit (allows to express the
% constraint on the position)
% We "know" that names are unique, so cut on the first clause.
search(Name,L,golfer(Name,C,Pos)) :-
searchWithPosition(Name,L,golfer(Name,C,Pos),0).
searchWithPosition(Name,[golfer(Name,C)|_],golfer(Name,C,Pos),Pos) :- !.
searchWithPosition(Name,[_|R],golfer(Name,C,PosOut),PosIn) :-
PosDown is PosIn+1, searchWithPosition(Name,R,golfer(Name,C,PosOut),PosDown).
% Search the golfer to the right of another golfer by name in the list,
% iteratively. We "know" that names are unique, so cut on the first clause
rightOf(Name,[golfer(Name,_),golfer(N,C)|_],golfer(N,C)) :- !.
rightOf(Name,[_|R],golfer(N,C)) :- rightOf(Name,R,golfer(N,C)).
Let's run this:
?:- solution(L).
L = [golfer(fred, hideous_orange),
golfer(joe, blue),
golfer(tom, red),
golfer(bob, plaid)]

Answer 1

Compact solution
golfers(S) :-
length(G, 4),
choices([
g(1, _, _),
g(2, joe, _), % Joe is second in line.
g(3, _, _),
g(4, _, _),
g(_, _, orange),
g(_, _, red), % one is wearing red pants
g(_, bob, plaid), % Bob is wearing plaid pants
g(P, fred, _), % The golfer to Fred’s immediate right
g(Q, _, blue), % ....is wearing blue pants
g(Pos, tom, Pants) % Tom isn’t in position one or four, and
% ... he isn’t wearing the orange pants
], G),
Q is P+1,
Pos \= 1, Pos \= 4, Pants \= orange, sort(G,S).
choices([],_).
choices([C|Cs],G) :- member(C,G), choices(Cs,G).
Note added by OP: Why this works
Create a list G of 4 uninitialized elements using length/2
For every element C in the first argument passed to choices/2, make sure C is a member of G.
The first 4 entries will be assigned in order (hopefully deterministically) and as they cannot unify, this will result in something like [g(1, _G722, _G723), g(2, joe, _G730), g(3, _G736, _G737), g(4, _G743, _G744)] after the 4th call to member/2.
After choices/2 returns, G has been unified to a structure that fulfills each constraint in the list of constraints passed to choices/2, in particular:
Positions 1,2,3,4 are listed
Names joe, bob, fred, tom are listed
Colors orange, plaid, red, blue listed
...and this means we don't have to even check for whether a color or name or position appears twice - it can only appear exactly once.
Additional constraints could not be passed to choices/2 (there is no way to say things like g(P, fred, _), g(P+1, _, blue), g(not-in{1,4}, tom, not-in{orange}) and pass this to choices/2). So these additional constraints are checked via the variables unified with G contents.
If these additional constraints fail, a backtracking over choices/2 and thus over member/2 will occur. There are 9 member/2 calls on-stack at that point, which will be exhaustively tried, although backtracking back past member assignment for g(4, _, _) is not useful.
Once an acceptable solution has been found, it is sorted and the program succeeds.
Compact solution, modified
Added by OP:
The above shows that a slight improvement is possible. This program does not find any additional (identical) solutions after the first one:
golfers(G) :-
G=[g(1,_,_),g(2,_,_),g(3,_,_),g(4,_,_)],
choices([
g(2, joe, _), % Joe is second in line.
g(_, _, orange),
g(_, _, red), % one is wearing red pants
g(_, bob, plaid), % Bob is wearing plaid pants
g(P, fred, _), % The golfer to Fred’s immediate right is
g(Q, _, blue), % ...wearing blue pants
g(Pos, tom, Pants) % Tom isn’t in position one or four, and
% ...he isn’t wearing the hideous orange pants
], G),
Q is P+1,
Pos \= 1, Pos \= 4, Pants \= orange.
choices([],_).
choices([C|Cs],G) :- member(C,G), choices(Cs,G).
Why this works
Define immediately the structure of the resulting G instead of creating a list of four as-yet-unknown elements using "length"
In this "proto-G" the list elements are sorted naturally by position; we will not be finding different solutions where the g(P,_,_) are permuted by position
We can thus get rid of the g(1,_,_), g(3,_,_), g(4,_,_) constraints
If one additionally wanted to make sure that names and colors are used exactly once (which is not necessary as this must be true by construction), one would capture the names and colors via choices/2 using g(1,N1,C1), g(2,N2,C2), g(3,N3,C3), g(4,N4,C4) and make sure the Ni and Ci are unique via a sort/2: sort([N1,N2,N3,N4],[bob,fred,joe,tom]), sort([C1,C2,C3,C4],[blue,orange,plaid,red])
Another solution
Prolog make easy to write 'languages'. Let's declare the problem, and craft a micro DSL to solve:
golfers_pants([G1,G2,G3,G4]) :-
maplist(choice([G1,G2,G3,G4]),[
% my note: we are going to compute on positions, so fill the 'column' with domain values
g(1, _, _),
% Joe is second in line.
g(2, joe, _),
g(3, _, _),
g(4, _, _),
% my note: someone is wearing 'hideous orange pants' not mentioned positively elsewhere
g(_, _, orange),
% one is wearing red pants
g(_, _, red),
% Bob is wearing plaid pants
g(_, bob, plaid),
% The golfer to Fred’s immediate right is wearing blue pants
g(P, fred, _), g(Q, _, blue), Q is P+1,
% Tom isn’t in position one or four, and he isn’t wearing the hideous orange pants
g(Pos, tom, Pants), Pos \= 1, Pos \= 4, Pants \= orange
]).
choice(G,C) :- C = g(_,_,_) -> member(C,G) ; call(C).

Answer 2

The Jess solution, rewritten in Prolog
This is for completion.
Rewriting the Jess solution in SWI Prolog (but not in SWISH, because we now make use of assert) shows that:
There is a lot of exhaustive enumerative going on "underneath the hood"
Forward chaining production systems may not the best tool for this kind of "constraint satisfaction over a finite search space" problem
The rule conditions might profit from some conceptual cleanup
So, let's translate this directly:
% Define the possible names, colors and positions
names([fred,joe,bob,tom]).
colors([red,blue,plaid,orange]).
positions([1,2,3,4]).
run :- names(Ns),
colors(Cs),
positions(Ps),
fill_working_memory(pantscolor,Ns,Cs),
fill_working_memory(position,Ns,Ps).
fireable(SortedResult) :-
position(fred,P_fred),
pantscolor(fred,C_fred),
position(N,P) , N \== fred,
P is P_fred+1,
pantscolor(N,blue) , N \== fred,
\+member(C_fred,[blue]),
position(joe,P_joe) , P_joe == 2,
\+member(P_joe,[P_fred]),
pantscolor(joe,C_joe) , \+member(C_joe,[C_fred]),
position(bob, P_bob) , \+member(P_bob,[P_fred,N,P_joe]),
pantscolor(bob, C_bob), N \== bob,
C_bob = plaid,
\+member(C_bob, [C_fred,C_joe]),
position(tom, P_tom) , N \== tom,
\+member(P_tom,[1,4,P_fred,P_joe,P_bob]),
pantscolor(tom, C_tom), \+member(C_tom,[orange,blue,C_fred,C_joe,C_bob]),
% build clean result
Result = [g(P_fred,fred,C_fred),
g(P_bob,bob,C_bob),
g(P_joe,joe,C_joe),
g(P_tom,tom,C_tom)],
sort(Result,SortedResult).
% -- Helper to assert initial facts into the working memory
fill_working_memory(PredSym,Ns,Vs) :-
product(Ns,Vs,Cartesian),
forall(member([N,V], Cartesian), factify(PredSym,N,V)).
factify(PredSym,N,V) :- Term=..([PredSym,N,V]), writeln(Term), assertz(Term).
% -- These should be in a library somewhere --
% Via https://gist.github.com/raskasa/4282471
% pairs(+N,+Bs,-Cs)
% returns in Cs the list of pairs [N,any_element_of_B]
pairs(_,[],[]) :- !.
pairs(N,[B|Bs],[[N,B]|Cs]) :- pairs(N,Bs,Cs).
% product(+As,+Bs,-Cs)
% returns in Cs the cartesian product of lists As and Bs
% product([x,y], [a,b,c], [[x, a], [x, b], [x, c], [y, a], [y, b], [y, c]])
% Would be interesting to make this a product(+As,+Bs,?Cs)
product([],_,[]) :- !.
product([A|As],Bs,Cs) :- pairs(A,Bs,Xs),
product(As,Bs,Ys),
append(Xs,Ys,Cs).
Let's run this:
?- run, fireable(X).
X = [g(1, fred, orange),
g(2, joe, blue),
g(3, tom, red),
g(4, bob, plaid)] .
For some reason, swipl becomes dog-slow after the 5th execution or so. Garbage collection kicking in?