Mrs. Rosencrantz' Jess query (a Zebra Puzzle) expressed in 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).