“Who is the barber” logic puzzle in Prolog

Question

I'm reading Raymond Smullyan's "To mock a Mockingbird". In the book there is a puzzle that goes like this:

Any resemblance between the Seville of this story and the famous Seville of Spain (which in fact there isn't) is purely coincidental. In this mythical town of Seville, the male inhabitants wear wigs on those and only those days when they feel like it. No two inhabitants behave alike on all days; that is, given any two male inhabitants, there is at least one day on which one of them wears a wig and the other doesn't. Given any male inhabitants X and Y, inhabitant Y is said to be a follower of X ifY wears a wig on all days that X does. Also, given any inhabitants X, Y, and Z, inhabitant Z is said to be a follower of X and Y if Z wears a wig on all days that X and Y both do.

Five of the inhabitants are named Alfredo, Bernardo, Ben- ito, Roberto, and Ramano. The following facts are known about them:

Fact 1.. Bernardo and Benito are opposite in their wig-wear- ing habits; that is, on any given day, one of them wears a wig and the other one doesn't.

Fact 2: Roberto and Ramano are likewise opposites.

Fact 3: Ramano wears a wig on those and only those days when Alfredo and Benito both wear one.

Seville has exactly one barber, and the following facts are known about him:

Fact 4: Bernardo is a follower of Alfredo and the barber.

Fact 5: Given any male inhabitant X, if Bernardo is a fol- lower of Alfredo and X, then the barber is a follower of X alone.

Alfredo wears only black wigs; Bernardo wears only white wigs; Benito wears only gray wigs; Roberto wears only red wigs; and Ramano wears only brown wigs.

One Easter morning, the barber was seen wearing a wig. What color was he wearing?

I figured out it would be fun to solve this in Prolog, but I got stuck rather early:

isOpposite( bernardo, benito   ).
isOpposite( benito  , bernardo ).
isOpposite( roberto , ramano   ).
isOpposite( ramano  , roberto  ).

wears( alfredo , black ).
wears( bernardo, white ).
wears( benito  , gray  ).
wears( roberto , red   ).
wears( ramano  , brown ).

whatWearsTheBarber( WigColor ) :-
  member( Barber, [ alfredo, benito, bernardo, roberto, ramano ] ),
  wears( Barber, WigColor ).

I don't know how to effectively encode that someone follows some other people and I don't know how to reason based on that information. I've followed solutions of some other logical puzzles in Prolog, but I couldn't figure out solutions for this one.

EDIT: Here's the solution copied from Smulyan's book:

Step 1: First, we prove that Roberto is a follower of the barber.

Well, consider any day on which the barber wears a wig. Either Alfredo wears a wig on that day or he doesn't. Suppose Alfredo does. Then Bernardo also wears a wig on that day, because Bernardo is a follower of Alfredo and the barber. So Benito can't wear a wig on that day, because he is opposite to Bernardo. Then Ramano can't wear a wig on that day, because he wears wigs only on those days when Alfredo and Benito both do, and Benito doesn't have one on this day. Since Ramano doesn't wear a wig on this day, then Roberto must, because Roberto is opposite to Ramano. This proves that on any day on which the barber wears a wig, if Alfredo also does, then so does Roberto.

Now, what about a day on which the barber wears a wig but Alfredo doesn't? Well, since Alfredo doesn't, then it cer- tainly is not the case that Alfredo and Benito both do; hence Ramano doesn't, by Fact 3, and therefore Roberto does, by Fact 2. So Roberto wears a wig on any day that the barber does and Alfredo doesn't-indeed, he wears a wig on all days that Alfredo doesn't, regardless of the barber. This proves that on any day on which the barber wears a wig, Roberto also does, regardless of whether Alfredo does or does not wear a wig on that day. So Roberto is indeed a follower of the barber.

Answer 1

Edit2: Since @killy9999 posted part of the solution from the book I decided to rewrite my Prolog to be able to mirror the reasoning of Smullyan. The original partial solution is preserved below.

First some basic structures

 person(alfredo).
 person(benito).
 person(roberto).
 person(ramano).
 person(bernardo).

 day([_Alfredo,_Benito,_Bernardo,_Roberto,_Romano]).

 % barber(alfredo). % Follows from Fact 4.
 barber(benito).
 % barber(bernardo). % Follows from Fact 4.
 barber(roberto).
 barber(romano).

 wearsWig(alfredo,[1,_X,_Y,_Z,_W]). 
 wearsWig(benito,[_X,1,_Y,_Z,_W]).
 wearsWig(bernardo,[_X,_Y,1,_Z,_W]).
 wearsWig(roberto,[_X,_Y,_Z,1,_W]).
 wearsWig(romano,[_X,_Y,_Z,_W,1]).

 noWig(alfredo,[0,_X,_Y,_Z,_W]).
 noWig(benito,[_X,0,_Y,_Z,_W]).
 noWig(bernardo,[_X,_Y,0,_Z,_W]).
 noWig(roberto,[_X,_Y,_Z,0,_W]).
 noWig(romano,[_X,_Y,_Z,_W,0]).

Then we have two types of consistency conditions. One follows from the fact that opposite parties never wear wigs simultaneously. The other comes from Fact 3 and Fact 4.

 consistent2(_D,[]).
 consistent2(D,[(X,Y)|Os]):-wearsWig(X,D),noWig(Y,D),consistent2(D,Os).
 consistent2(D,[(X,Y)|Os]):-noWig(X,D),wearsWig(Y,D),consistent2(D,Os).

 consistent3(O,G):-consistent3(O,_D,G).

 consistent3(_O,_D,[]).
 consistent3(O,D,[(X,Y,Z)|Gs]):-
     wearsWig(X,D),wearsWig(Y,D),wearsWig(Z,D),
     consistent2(D,O),consistent3(O,D,Gs).
 consistent3(O,D,[(_X,Y,_Z)|Gs]):-
     noWig(Y,D),consistent2(D,O),consistent3(O,D,Gs).
 consistent3(O,D,[(_X,_Y,Z)|Gs]):-
     noWig(Z,D),consistent2(D,O),consistent3(O,D,Gs).

fact3(D):-wearsWig(romano,D),wearsWig(alfredo,D),wearsWig(benito,D).
fact3(D):-noWig(alfredo,D),noWig(romano,D).
fact3(D):-noWig(benito,D),noWig(romano,D).

This is enough to prove that Roberto follows the Barber (Step 1):

 ?- person(Barber),barber(Barber),
    O = [(benito,bernardo),(roberto,romano)],
    G = [(bernardo,alfredo,Barber),(romano,alfredo,benito)],
    consistent3(O,D,G),fact3(D),
    wearsWig(Barber,D),noWig(roberto,D).
 false.

Hence rules out Romano as a Barber.

We also already have got (Step 2) that Bernardo follows Roberto and Alfredo:

 ?- person(Barber)barber(Barber),
    O = [(benito,bernardo),(roberto,romano)],
    G = [(bernardo,alfredo,Barber),(romano,alfredo,benito)],
    consistent3(O,D,G),fact3(D),
    wearsWig(alfredo,D),wearsWig(roberto,D),noWig(bernardo,D).
 false.

The next step (Step 3) requires the use of Fact 5, which is a universal statement (that holds for all male inhabitants of Seville) and is difficult to encode in Prolog.

 consistent4(_D,_Barber,[]).
 consistent4(D,Barber,[X|Xs]):-
    wearsWig(X,D1),wearsWig(alfredo,D1),
    noWig(bernardo,D1),consistent4(D,Barber,Xs).
 consistent4(D,Barber,[X|Xs]):-
    wearsWig(X,D),wearsWig(alfredo,D),
    wearsWig(bernardo,D),wearsWig(Barber,D),
    consistent4(D,Barber,Xs).

Now define the root predicate and fancy colors:

wears(alfredo, black).
wears(bernardo, white).
wears(benito, gray).
wears(roberto, red).
wears(ramano, brown).

whatWearsTheBarber(WigColor):-
   person(Barber),
   day(Easter),
   barber(Barber),
   wearsWig(Barber,Easter),
   fact3(Easter),
   G=[(bernardo,alfredo,Barber),(romano,alfredo,benito)],
   O=[(benito,bernardo),(roberto,romano)],
   consistent2(Easter,O), 
   consistent3(O,D,G),
   X=[alfredo,benito,bernardo,roberto,romano],
   consistent4(D,Barber,X),
   wears(Barber, WigColor).

The following SWI-Prolog query shows that RED is the only answer

 ?- findall(WigColor,whatWearsTheBarber(WigColor),B),list_to_set(B,R).
 B = [red, red, red, red, red, red, red, red, red|...],
 R = [red].

Thanks to Andrew Cooke. I have borrowed from his answer.

The text below is the answer that was posted originally and produced the comments.

---

Edit: The puzzle is actually quite difficult since one has to keep track of many days, not only the particular Easter. The following solution greatly reduces the search by considering the state of affairs in Seville only on that specific day.

It might be easier to consider the situation in the city of Seville as an unknown relation represented as a list:

 [ [WearsWig,IsBarber], ... , [WearsWig,IsBarber] ]

with the present population we may state

 seville(S) :- 
       S=[Benito,Bernardo,Roberto,Ramano,Alfredo], 
       opposite(Benito,Bernardo),
       opposite(Roberto,Ramano),
       fact3(Ramano,Alfredo,Benito),
       fact4(Bernardo,Alfredo),
       noBarber(Bernardo),noBarber(Alfredo),
       onlyOneBarberWearsWig(S).

the relevant predicates are defined as follows:

 noWig([0,_X]).
 wearsWig([1,_X]).

 isBarber([_X,1]).
 noBarber([_X,0]).

 opposite(X,Y):-noWig(X),wearsWig(Y). 
 opposite(X,Y):-noWig(Y),wearsWig(X).


 fact3(X,Y,Z):-wearsWig(X),wearsWig(Y),wearsWig(Z).
 fact3(X,Y,_Z):-noWig(X),noWig(Y).
 fact3(X,_Y,Z):-noWig(X),noWig(Z).

 fact4(X,Y):-wearsWig(X),wearsWig(Y),wearsWig(Z),isBarber(Z).
 fact4(_X,Y):-noWig(Y).

 onlyOneBarberWearsWig([X|Xs]):-isBarber(X),wearsWig(X),noBarbers(Xs).
 onlyOneBarberWearsWig([X|Xs]):-noBarber(X),onlyOneBarberWearsWig(Xs).
 noBarbers([]).
 noBarbers([X|Xs]):-noBarber(X),noBarbers(Xs).

 barbersWigColor([_X,_Y,_Z,_U,Alfredo],black):-isBarber(Alfredo).
 barbersWigColor([_X,Bernardo,_Y,_Z,_U],white):-isBarber(Bernardo).
 barbersWigColor([Benito,_X,_Y,_Z,_U],gray):-isBarber(Benito).
 barbersWigColor([_X,_Y,Roberto,_Z,_U],red):-isBarber(Roberto).
 barbersWigColor([_X,_Y,_Z,Ramano,_U],brown):-isBarber(Ramano).

 whatWearsTheBarber(Color):-seville(X),barbersWigColor(X,Color).

With the above definitions SWI quickly returns:

 ?- seville(X).
 X = [[0, 0], [1, 0], [1, 1], [0, 0], [0, 0]] ;
 X = [[0, 0], [1, 0], [1, 1], [0, 0], [1, 0]] ;
 X = [[0, 0], [1, 0], [1, 1], [0, 0], [0, 0]] ;
 X = [[1, 1], [0, 0], [1, 0], [0, 0], [0, 0]] ;
 X = [[1, 0], [0, 0], [1, 1], [0, 0], [0, 0]] ;
 false.


 ?- whatWearsTheBarber(Color).
 Color = red ;
 Color = red ;
 Color = red ;
 Color = gray ;
 Color = red ;
 false.

I do not quite understand how Fact 5 works. And I cannot rule out the case when Benito is the Barber. Yet I'd like to post this as an answer.

Answer 2

posting as an "answer" just because it's long for a comment. this is the first time i have tried something like this with prolog. i am not sure my use of not/1 is correct. gives white and brown as the two(!) answers (although brown would be excluded, i think, if fact 4 meant that Bernard cannot be the barber). the commented-out parts lead to infinite recursion.

person(bernardo).
person(benito).
person(roberto).
person(ramano).
person(alfredo).

opposite(bernardo, benito). % fact 1
opposite(benito, bernardo). % fact 1
opposite(roberto, ramano). % fact 2
opposite(ramano, roberto). % fact 2
opposite(X, Y):- dif(X, Y). % cannot be opposite to yourself
%opposite(X, Y):- opposite(Y, X). % symmetric

wears(alfredo, black).
wears(bernardo, white).
wears(benito, gray).
wears(roberto, red).
wears(ramano, brown).

follower(A, A).
follower(bernardo, alfredo). % fact 4
follower(ramano, alfredo):- % fact 3
  follower(alfredo, benito); follower(benito, alfredo).
follower(ramano, benito):- % fact 3
  follower(alfredo, benito); follower(benito, alfredo).
follower(X, ramano):- % fact 3
  follower(X, alfredo); follower(X, benito).
%follower(A, B):-
%  dif(A, B),
%  person(X),
%  follower(A, X),
%  follower(X, B).

follower(A, B):- not(opposite(A, B)).
follower(B, A):- not(opposite(A, B)).

fact5(Barber):-                                                                 
  not(follower(bernardo, X));                                                   
  not(follower(bernardo, alfredo));                                             
  person(X),                                                                    
  person(Y),                                                                    
  follower(Barber, X),                                                          
  dif(Y, X),                                                                    
  not(follower(Barber, Y)).                                                     

whatWearsTheBarber(WigColor):-                                                  
  person(Barber), % implicit in question?                                       
  dif(alfredo, Barber), % fact 4                                                
  follower(bernardo, Barber), % fact 4                                          
  fact5(Barber),                                                                
  wears(Barber, WigColor).