Goldberg%Rand-UNIX@sri-unix.UUCP (01/30/84)
/* I offer yet another program that solves the women, job,
dress problem. I find this one easier to understand than
the previous solutions presented here. Perhaps you will
also.
This program tries all possible triples (woman, job, dress).
When it is first called the sets Women, Jobs and Dresses each
contain all possibilities, and the PartialSolution is empty.
Each call to wjd tries all possible triples, chosen from the
sets Women, Jobs and Dresses. So the first call tries all
solutions, and subsequent recursive calls try all potential
triples given the partial solution already chosen.
We use a generate and test approach. The three member
clauses generate a potential triple, which is then tested.
If the triple is not impossible, as determined by test, then wjd
is called recursively with a larger partial solution and
sets of women, jobs and dresses that are one smaller.
If test or wjd fails then backtracking at member produces
all possible triples (woman, job, dress). */
/* solve the women, jobs, dresses problem. */
solve :-
wjd([alice,betty,carol,dorothy],
[pilot,lifeguard,housewife,professor],
[pink,yellow,blue,white],[]).
/* The answer has been found if the Solution contains four entries. */
wjd(_, _, _, Solution) :-
length(Solution,Length),
Length=4,
write(Solution), !.
wjd(Women,Jobs,Dresses,PartialSolution) :-
member(Woman, Women),
member(Job, Jobs),
member(Dress, Dresses),
test([Woman, Job, Dress]),
remove(Woman, Women, RemainingWomen),
remove(Job, Jobs, RemainingJobs),
remove(Dress, Dresses, RemainingDresses),
wjd(RemainingWomen, RemainingJobs, RemainingDresses,
[[Woman,Job,Dress]|PartialSolution]).
/* I learned a good lesson here. One would be tempted to replace the
last call to wjd with
append(PartialSolution,[[Woman,Job,Dress]],NewPartialSolution),
wjd(RemainingWomen, RemainingJobs, RemainingDresses,
NewPartialSolution]).
so that the append would obtain the NewPartialSolution.
This program would run much slower, because when wjd fails
append tries to find another match. It succeeds -
with the same NewPartialSolution - and wjd is called
with the same arguments that made it fail the previous time. */
member(Head,[Head|_]).
member(Head,[_|Tail]) :- member(Head,Tail).
/* remove(Item, List, Answer) succeeds when Item
removed from List equals Answer. It will work
with any two arguments instantiated. The cuts
prevent remove from satisfying the goal
remove(b, [a,b,c], X) more than once, since this
would cause wjd to be called repeatedly with the
same arguments. */
remove(_,[],[]).
remove(Item,[Item|Tail],Tail) :- !.
remove(Item,[NotItem|Tail],Answer) :-
remove(Item,Tail,AnswerPrime),
append([NotItem],AnswerPrime,Answer),
!.
append([],List,List).
append([Head|Tail1],List1,[Head|Tail2]) :-
append(Tail1,List1,Tail2).
/* I've interpreted much of the information given with the
puzzle as negative constraints. I like the uniformity and
semantic simplicity of these facts. */
test(Triple) :-
not(impossible(Triple)).
impossible([_,pilot,pink]).
impossible([_,pilot,blue]).
impossible([carol,pilot,_]).
impossible([carol,_,pink]).
impossible([carol,_,blue]).
impossible([betty,lifeguard,_]).
impossible([alice,professor,_]).
impossible([alice,_,blue]).
impossible([_,professor,blue]).
/* One of the clues states a truth. A proposed solution tuple
is not possible if a member of the tuple matches a member of
a truth list and a pair of members of the tuple and the truth
list are different. */
impossible(L) :-
truth(Truthlist),
match(L,Truthlist),
difference(L,Truthlist).
match([H1|_],[H2|_]) :- H1 == H2.
match([_|T1],[_|T2]) :- match(T1,T2).
difference([H1|_],[H2|_]) :- atom(H1), atom(H2), not(H1 = H2).
difference([_|T1],[_|T2]) :- difference(T1,T2).
truth([_,housewife,white]).
-- Arthur P. Goldberg