Generalizing the Zebra Puzzle Format

We’re able to solve Einstein’s Riddle using a straightforward “we either know this variable’s value or we don’t” model of thought. It’s blatantly suboptimal. But it’s too fast to be noticeable. So we need a better problem.

This in installment 2 in this series.

There’s a nice set of this class of problems over at brainzilla.¹ Our old friend, Einstein’s, is there too, rated medium. There are five puzzles available in the “very hard” category.

Here’s the plan:

upgrade my code to be able to read a puzzle in the site’s format
check it works using Einstein
proceed to time various ways of solving them on a harder one.

Of course, I may get bored halfway through, or find something else shiny enough to distract me, or it may just plain old be too hard for me. We’ll see how that pans out…

The first thing to notice is Einstein there isn’t the same one as Wikipedia’s. Sigh. Oh well. The gist of it is similar enough.

Brainzilla features a nifty PDF export of their puzzles. It’s the cleanest way I’ve found to extract the relevant information our of them. So, what do we have?

Color: blue, green, red, white, yellow
Nationality: Brit, Dane, German, Norwegian, Swede
Drink: beer, coffee, milk, tea, water
Cigarette: Blends, Blue Master, Dunhill, Pall Mall, Prince
Pet: birds, cats, dogs, horses, fish
- The Brit lives in the Red house.
- The Swede keeps Dogs as pets.
- The Dane drinks Tea.
- The Green house is exactly to the left of the White house.
- The owner of the Green house drinks Coffee.
- The person who smokes Pall Mall rears Birds.
- The owner of the Yellow house smokes Dunhill.
- The man living in the centre house drinks Milk.
- The Norwegian lives in the first house.
- The man who smokes Blends lives next to the one who keeps Cats.
- The man who keeps Horses lives next to the man who smokes Dunhill.
- The man who smokes Blue Master drinks Beer.
- The German smokes Prince.
- The Norwegian lives next to the Blue house.
- The man who smokes Blends has a neighbour who drinks Water.

They’re kind enough to give us the property names and values. Having to guess them is fun when you’re solving by hand; it’s a nuisance when automating. So I’m glad they do. We notice two-word “orange juice” is gone, but there’s still “Pall Mall” and “Blue Master”. I’ll search-and-replace them to single words. I’ll also add a period at the end of the property list lines, so I can mostly use the same word-based tokenizer between both parts. And remove the leading dashes in the constraint listing.

Then I’ll highlight the actually interesting remaining parts of the text, to see what we really need to keep from this.

Color: blue, green, red, white, yellow.
Nationality: Brit, Dane, German, Norwegian, Swede.
Drink: beer, coffee, milk, tea, water.
Cigarette: Blends, BlueMaster, Dunhill, PallMall, Prince.
Pet: birds, cats, dogs, horses, fish.
The Brit lives in the Red house.
The Swede keeps Dogs as pets.
The Dane drinks Tea.
The Green house is exactly to the left of the White house.
The owner of the Green house drinks Coffee.
The person who smokes PallMall rears Birds.
The owner of the Yellow house smokes Dunhill.
The man living in the centre house drinks Milk.
The Norwegian lives in the first house.
The man who smokes Blends lives next to the one who keeps Cats.
The man who keeps Horses lives next to the man who smokes Dunhill.
The man who smokes BlueMaster drinks Beer.
The German smokes Prince.
The Norwegian lives next to the Blue house.
The man who smokes Blends has a neighbour who drinks Water.

That text doesn’t have much efficiency, huh?

I’m keeping the colon and period punctuation marks as individual token to help at:

distinguishing feature lines from constrain lines
future extensibility when we’ll have more complex sentences

The features’ actual names aren’t needed per se, but I do need to know which values go together, so that name is as good as another to group them under.

Now to implement this. I’ll use the usual Prolog DCGs.

First to split on words.

:- [library(dcg/basics)].

words([W|Ws]) --> word(W), blanks, !, words(Ws).
words([]) --> eos.

To scan for a word, take anything that’s not ignored. We’re ignoring whitespace as a separator, and some punctuation marks as tokens of their own. I’m defining those lists in separate predicates to help further evolution.

punct(".:").
skip(",").
whitespace(" \n").

word_complement(Cs) :-
    punct(P), skip(S), whitespace(W),
    string_concat(P,S,T), string_concat(T,W,Cs).

word(T) -->
    { word_complement(Cp) },
    string_without(Cp, Codes),
    { Codes \= [] },
    { read_codes(Codes,T) }.
word(T) --> [C], { punct(P), string_codes(P,Cs), member(C,Cs), atom_codes(T,[C]) }.
word(T) --> [C], { skip(S), string_codes(S,Cs), member(C,Cs) }, blanks, word(T).

read_codes(Codes,Token) :- atom_codes(Token,Codes).

Let’s try it out.

?- string_codes(“:hello, world.”, Codes),
phrase(words(Words), Codes).
Codes = [58, 104, 101, 108, 108, 111, 44, 32, 119, 111, 114, 108, 100, 46],
Words = [:, hello, world, ‘.’].

It’s extracted the two interesting punctuation marks as individual tokens. It skipped spaces and commas. It converted the two words to atoms. Seems all right for now.

Let’s see what it makes of the entire input file.

?- phrase_from_file(words(Words), “einstein.txt”).
Words = [color, :, blue, green, red, white, yellow, ‘.’, nationality, :, brit, dane, german, norwegian, swede, ‘.’, drink, :, beer, coffee, milk, tea, water, ‘.’, cigarette, :, blends, bluemaster, dunhill, pallmall, prince, ‘.’, pet, :, birds, cats, dogs, horses, fish, ‘.’, the, brit, lives, in, the, red, house, ‘.’, the, swede, keeps, dogs, as, pets, ‘.’, the, dane, drinks, tea, ‘.’, the, green, house, is, exactly, to, the, left, of, the, white, house, ‘.’, the, owner, of, the, green, house, drinks, coffee, ‘.’, the, person, who, smokes, pallmall, rears, birds, ‘.’, the, owner, of, the, yellow, house, smokes, dunhill, ‘.’, the, man, living, in, the, centre, house, drinks, milk, ‘.’, the, norwegian, lives, in, the, first, house, ‘.’, the, man, who, smokes, blends, lives, next, to, the, one, who, keeps, cats, ‘.’, the, man, who, keeps, horses, lives, next, to, the, man, who, smokes, dunhill, ‘.’, the, man, who, smokes, bluemaster, drinks, beer, ‘.’, the, german, smokes, prince, ‘.’, the, norwegian, lives, next, to, the, blue, house, ‘.’, the, man, who, smokes, blends, has, a, neighbour, who, drinks, water, ‘.’].

Ok.

Now to strip anything we’re not interested in. We’ll need to extract our domain first. The domain is a list of features, where each feature presents as its name, a colon, a list of value words, and a period.

domain([F|Fs]) --> feature(F), domain(Fs).
domain([]) --> [].
feature(feature(Name,Vs)) --> [Name,':'], values(Vs).

values([]) --> ['.'], !.
values([V|Vs]) --> [V], values(Vs).

?- phrase_from_file(words(Words), “einstein.txt”),
phrase(domain(Dom), Words, _).
Dom = [feature(color, [blue, green, red, white, yellow]), feature(nationality, [brit, dane, german, norwegian, swede]), feature(drink, [beer, coffee, milk, tea, water]), feature(cigarette, [blends, bluemaster, dunhill, pallmall, prince]), feature(pet, [birds, cats, dogs, horses, fish])]

Sweet.

Flattening that and referencing a few connector words now lets us filter the constraints.

domain_values(D,Vs) :- maplist(feature_values,D,Vss), append(Vss,Vs).
feature_values(feature(_,Vs),Vs).

connectors([left,next,neighbour,'.']).

cleanse(D,Ts,C) :-
    connectors(Cs), domain_values(D,Vs), append(Cs,Vs,K),
    include(member_(K),Ts,C).
member_(L,E) :- member(E,L).

?- phrase_from_file(words(Words), “einstein.txt”),
phrase(domain(Dom), Words, Verbose),
cleanse(Dom, Verbose, Terse).
Terse = [brit, red, ‘.’, swede, dogs, ‘.’, dane, tea, ‘.’, green, left, white, ‘.’, green, coffee, ‘.’, pallmall, birds, ‘.’, yellow, dunhill, ‘.’, milk, ‘.’, norwegian, ‘.’, blends, next, cats, ‘.’, horses, next, dunhill, ‘.’, bluemaster, beer, ‘.’, german, prince, ‘.’, norwegian, next, blue, ‘.’, blends, neighbour, water, ‘.’]

It’s reduced to all that’s needed. Parsing is now trivial:

constraints(Dom,[C|Cs]) --> constraint(Dom,C), ['.'], constraints(Dom,Cs).
constraints(_,[]) --> [].

constraint(Dom,same(A,B)) --> attribute(Dom,A), attribute(Dom,B).
constraint(Dom,seq([A,B])) --> attribute(Dom,A), [left], attribute(Dom,B).
constraint(Dom,neighbors(A,B)) -->
    attribute(Dom,A),
    [N], { member(N,[next,neighbour]) },
    attribute(Dom,B).

This recognizes three kinds of constraints:

the most commone one: “feature A is in the same place as feature B”
ordered sequence: “features A directly precedes feature B”
unordered sequence: “features A and B are directly next to each other”

It needs an attribute parser, recognizing values from the domain:

attribute(Dom,attr(F,V)) --> [V], { member(feature(F,Vs),Dom), member(V,Vs) }.
attribute(_,attr(position,P)) --> [P], { positions(Ps), member(P,Ps) }.

We can now parse the entire constraint list:

?- phrase_from_file(words(Words), “einstein.txt”),
phrase(domain(Dom), Words, Verbose),
cleanse(Dom, Verbose, Terse),
phrase(constraints(Dom,Constraints),Terse).
Constraints = [
same(attr(nationality, brit),attr(color, red)),
same(attr(nationality, swede),attr(pet, dogs)),
same(attr(nationality, dane),attr(drink, tea)),
seq([attr(color, green),attr(color, white)]),
same(attr(color, green),attr(drink, coffee)),
same(attr(cigarette, pallmall),attr(pet, birds)),
same(attr(color, yellow),attr(cigarette, dunhill)),
same(attr(position, centre),attr(drink, milk)),
same(attr(nationality, norwegian),attr(position, first)),
neighbors(attr(cigarette, blends),attr(pet, cats)),
neighbors(attr(pet, horses),attr(cigarette, dunhill)),
same(attr(cigarette, bluemaster),attr(drink, beer)),
same(attr(nationality, german),attr(cigarette, prince)),
neighbors(attr(nationality, norwegian),attr(color, blue)),
neighbors(attr(cigarette, blends),attr(drink, water))
]

Let’s package that.

read_zebra(FileName,puzzle(Dom,Constraints)) :-
    phrase_from_file(words(Words),FileName),
    phrase(domain(Dom),Words,Verbose),
    cleanse(Dom,Verbose,Terse),
    phrase(constraints(Dom,Constraints),Terse).

With a parsed AST, all we have left to do is convert it to a search, in the same form as last installment’s. In a nutshell: give the search space a shape, then unify it with the constraints, in order.

solve(puzzle(Dom,Constraints),Sol) :-
    shape(Dom,Sol),
    maplist(apply(Dom,Sol),Constraints).

The shaping phase will unify the solution with a list as long as the domain’s value count per feature. Each list element will be a place functor, with as many arguments as there are features in the puzzle’s domain.

shape(Dom,Sol) :-
    inner_length(Dom,N),
    length(Sol,N),
    length(Dom,F),
    maplist(place(F),Sol).

place(F,P) :- length(X,F), P =.. [place|X].

inner_length([feature(_,H)|T],N) :-
    length(H,N),
    \+ ( member(feature(_,X),T), length(X,N2), N2 \= N ).

It’s probably easier to visualize than decode:

?- read_zebra(“einstein.txt”,puzzle(D,_)),shape(D,S).
S = [place(_2154, _2160, _2166, _2172, _2178), place(_2202, _2208, _2214, _2220, _2226), place(_2250, _2256, _2262, _2268, _2274), place(_2298, _2304, _2310, _2316, _2322), place(_2346, _2352, _2358, _2364, _2370)]

Constraint application unifies the places’ attributes, depending on the connector. As a special case, “position” attributes are special-cased so that they can apply to a specific place instead of trying them all.

apply(Dom,Sol,same(attr(position,Pos),A)) :-
    ( Pos = centre -> length(Sol,L), M is L//2 ;
      Pos = first -> M = 0 ;
      throw(invalid_position(Pos)) ),
    nth0(M,Sol,P),
    unify(Dom,P,A).
apply(Dom,Sol,same(A,attr(position,Pos))) :-
    apply(Dom,Sol,same(attr(position,Pos),A)).
apply(Dom,Sol,same(A,B)) :-
    member(P,Sol),
    unify(Dom,P,A),
    unify(Dom,P,B).
apply(Dom,Sol,seq(A,B)) :-
    nextto(Pa,Pb,Sol),
    unify(Dom,Pa,A),
    unify(Dom,Pb,B).
apply(Dom,Sol,neighbors(A,B)) :-
    apply(Dom,Sol,seq(A,B)) ;
    apply(Dom,Sol,seq(B,A)).

Unification simply locates the place functor argument by cross-referencing the domain.

unify(Dom,P,attr(F,V)) :-
    nth0(N,Dom,feature(F,_)), !,
    P =.. [place|Vs],
    nth0(N,Vs,V).

And we’re done! Let’s try it out.

?- read_zebra(“einstein.txt”,P),solve(P,Sol).
Sol = [place(yellow, norwegian, water, dunhill, cats), place(blue, dane, tea, blends, horses), place(red, brit, milk, pallmall, birds), place(green, german, coffee, prince, _25176), place(white, swede, beer, bluemaster, dogs)]

A solution is found instantly. As was the case previously, the actual pet the statement asks for isn’t reified: it’s still a free variable. As it’s the only one left in the solution space, it’s unambiguous.

With this new generic infrastructure at the ready, let’s try for a harder puzzle: delightful dresses. Parsing difficulties:

new relations: “somewhere to the right/left”, “somewhere between”
new positions: “at one of the ends”
indirect attributes: “oldest”, “youngest”, “smallest discount”

I’ll introduce a new constraint type, ordered, to account for the “somewhere” class of new relations. Recognition will consist in adding “right”, “somewhere”, “between” and “and” to the list of connector words. Parsing is a few additional clauses of the constraint predicate.

connectors([left,right,next,neighbour,'.',somewhere,between,and]).

constraint(Dom,ordered([A,B])) -->
    attribute(Dom,A), [somewhere,left], attribute(Dom,B).
constraint(Dom,ordered([A,B])) --> 
    attribute(Dom,B), [somewhere,right], attribute(Dom,A).

constraint(Dom,seq(A,B)) --> attribute(Dom,B), [right], attribute(Dom,A).

The “at-end” one will be a new position pseudo-feature value by virtue of adding a keyword to the list.

positions([centre,first,ends]).

The indirect attributes are going to be slightly trickier. We know the domain, so we can resolve them at parse time. To do it cleanly, I’ll need to interpret their values as numbers, instead of the symbols I currently have. So I’ll update the tokenizer slightly:

skip(",%").

read_codes(Codes,Number) :-
    catch(number_codes(Number,Codes),
          error(syntax_error(illegal_number),_),
          fail).
read_codes(Codes,Token) :- atom_codes(Atom,Codes), downcase_atom(Atom,Token).

I added % to the list of skipped characters so it wouldn’t confuse the number parser. The puzzle author was nice enough not to make the discounts collide with the ages. Then I inserted a number parsing clause above the regular atom one: if it’s a number it’ll parse as such, else it will be a simple symbol.

I’ll new list the relatives as recognized words, and update the word purge to save those too.

relatives([youngest,oldest]).

cleanse(D,Ts,C) :-
    connectors(Cs),
    positions(Ps),
    relatives(Rs),
    domain_values(D,Vs),
    append([Cs,Ps,Rs,Vs],K),
    include(member_(K),Ts,C).

I’ll need to read them accurately. “Youngest” and “oldest” can reasonably be assumed to always refer to an “age” feature.

attribute(Dom,attr(age,Young)) --> [youngest], !, { feature_min(Dom,age,Young) }.
attribute(Dom,attr(age,Young)) --> [oldest], !, { feature_max(Dom,age,Young) }.

feature_min(Dom,F,Min) :-
    menber(feature(F,Vs),Dom),
    min_member(Min,Vs).
feature_max(Dom,F,Min) :-
    menber(feature(F,Vs),Dom),
    max_member(Min,Vs).

“Smallest discount” is tricker. Interpreting both words in the current framework would be quite nasty. Interpreting “smallest” to imply “discount” would be very oddly specific.

So I’ll take the side road. I’ll introduce an optional, puzzle-specific predicate to substitute a term for a word. It’ll serve as a hatch to help language recognition in those cases.

:- dynamic subst/2.

cleanse(D,Ts,C) :-
    connectors(Cs),
    positions(Ps),
    relatives(Rs),
    findall(S,subst(S,_),Ss),
    domain_values(D,Vs),
    append([Cs,Ps,Rs,Vs,Ss],K),
    include(member_(K),Ts,Tmp),
    maplist(perform_subst,Tmp,C).
perform_subst(F,T) :- once(subst(F,T)) ; F = T.

Here’s how to use it to interpret the smallest discount without leaking too much abstraction away:

subst(smallest,min(discount).

attribute(Dom,attr(F,Min)) --> [min(F)], { feature_min(Dom,F,Min) }.

And we’ve got the whole file parsed. Of course, it’s parsed wrong because I’m not interpreting “immediately before” correctly yet. But this is trivial now I’ve got a substitution facility.

subst(before,left).

?- read_zebra(“dresses.txt”,Puzzle).
Puzzle = puzzle([feature(dress, [black, blue, purple, red, white]),
feature(name, [anna, erica, lauren, megan, sara]),
feature(profession, [actress, electrician, programmer, psychologist, surgeon]),
feature(type, [‘a-line’, bodycon, sheath, sundress, wrap]),
feature(discount, [5, 10, 15, 20, 25]),
feature(age, [30, 33, 36, 39, 41])],
[seq(attr(profession, surgeon), attr(profession, programmer)),
ordered([attr(discount, 10), attr(dress, black)]),
neighbors(attr(profession, actress), attr(dress, black)),
neighbors(attr(profession, psychologist), attr(type, bodycon)),
same(attr(name, megan), attr(age, 41)),
ordered([attr(dress, white), attr(age, 36)]),
neighbors(attr(type, sheath), attr(discount, 15)),
ordered([attr(age, 30), attr(dress, purple), attr(dress, white)]),
seq(attr(discount, 5), attr(discount, 15)),
ordered([attr(dress, white), attr(discount, 20)]),
seq(attr(profession, surgeon), attr(type, sundress)),
same(attr(name, anna), attr(dress, white)),
seq(attr(name, megan), attr(discount, 5)),
same(attr(type, sheath), attr(dress, red)),
same(attr(position, ends), attr(age, 33)),
seq(attr(type, bodycon), attr(name, sara)),
same(attr(name, lauren), attr(age, 33)),
same(attr(position, ends), attr(type, sheath)),
seq(attr(discount, 10), attr(discount, 5)),
same(attr(type, ‘a-line’), attr(dress, purple))])

I love the smell of a freshly ~~roasted~~ parsed puzzle in the morning.

To be able to solve it, we’ll need to implement the new ordered subsequence predicate.

apply(Dom,Sol,ordered(S)) :- apply_list(Dom,Sol,S).

apply_list(Dom,[Sh|St],[Ah|At]) :- unify(Dom,Sh,Ah), apply_list(Dom,St,At).
apply_list(Dom,[_|St],As) :- apply_list(Dom,St,As).
apply_list(_,_,[]).

And we’ll need to implement the new “at one of the ends” position.

apply(Dom,Sol,same(attr(position,Pos),A)) :-
    ( Pos = centre -> length(Sol,L), M is (L+1)//2 ;
      Pos = first -> M = 1 ;
      Pos = ends -> (M = 1 ; length(Sol,M) ) ;
      throw(invalid_position(Pos)) ),
    nth1(M,Sol,P),
    unify(Dom,P,A).

And merrily solve our puzzle.

?- read_zebra(“dresses.txt”,Puzzle), solve(Puzzle,Sol).
Sol = [place(red, lauren, surgeon, sheath, 10, 33), place(black, megan, programmer, sundress, 5, 30), place(purple, megan, psychologist, ‘a-line’, 15, 41), place(white, anna, actress, bodycon, 15, _17180), place(black, sara, _17218, sheath, 20, 36)]

Wait a second. This won’t do! Notwithstanding the remaining free variables, this solution is incorrect! Spot the problem yet?

Allow me to reformat to make it more apparent:

place(red, lauren, surgeon, sheath, 10, 33)
place(black, megan, programmer, sundress, 5, 30)
place(purple, megan, psychologist, ‘a-line’, 15, 41)
place(white, anna, actress, bodycon, 15, Age)
place(black, sara, Job, sheath, 20, 36)

Yup. Two black dresses, two Megans, two sheathes, two 15% discounts. Contrary to Einstein, this puzzle’s constraints aren’t sufficient to rule out duplication.

Well, at least that isn’t not too hard to include.

assert_domain(Dom,Sol) :-
    length(Dom,L),
    foreach(between(1,L,X),assert_feature(X,Dom,Sol)).
assert_feature(X,Dom,Sol) :-
    nth1(X,Dom,feature(_,Vs)),
    maplist(assert_value(X,Sol),Vs).
assert_value(X,Sol,V) :-
    member(P,Sol),
    P =.. PVs,
    nth0(X,PVs,V).

solve(puzzle(Dom,Constraints),Sol) :-
    shape(Dom,Sol),
    maplist(apply(Dom,Sol),Constraints),
    assert_domain(Dom,Sol).

The astute reader will have noticed I’m actually checking the converse, namely that each feature value is represented. As there are as many women as values, they’re equivalent.

?- read_zebra(“dresses.txt”,Puzzle), solve(Puzzle,Sol).
Sol = [place(blue, erica, electrician, wrap, 25, 30), place(purple, megan, psychologist, ‘a-line’, 10, 41), place(white, anna, surgeon, bodycon, 5, 39), place(black, sara, programmer, sundress, 15, 36), place(red, lauren, actress, sheath, 20, 33)] ;

Victory!

Let’s implement blood donation, another “very hard” puzzle from the site, to make sure it wasn’t an accident.

I’m not going to delve too much into the details this time. There were two hurdles.

Donors can be referred to as “universal donor” or “universal recipient”. This is completely out-of-the-box information. I just inserted “O-” and “AB+” in the relevant places in the constraints. This leads to…
The Rhesus signs in the PDF are U+00AD SOFT HYPHENs instead of the more usual U+0045 HYPHEN-MINUS. Don’t get mixed up!
² Oh, and the usual: “feature names are expected to be single words”.

Barring that, it all runs as smoothly as expected:

?- read_zebra(“blood-donation.txt”,Puzzle), solve(Puzzle,Sol).
Sol = [place(black, brooke, ‘b-’, 45, 130, actress), place(green, nichole, ‘o-’, 35, 160, chef), place(purple, andrea, ‘ab+’, 30, 120, policewoman), place(blue, meghan, ‘a+’, 25, 150, florist), place(red, kathleen, ‘b+’, 40, 140, engineer)]

Victory again. This will conclude today’s installment.

So where are we, exactly?

We’ve got Prolog code to solve the Einstein riddle. With a bit of careful generalization, we can mock NLP and parse brainzilla’s puzzles, and solve two “very hard” of those too. Performance, on the other hand, is debatable. Einstein is instant, but delightful dresses and blood donation take entire minutes.

So that gives us something to work with for next time. Don’t you love it when a plan comes together?

The code is available on my Github.

I’m not affiliated with them in any way. But their presentation is nice, there’s a good selection, and I have a fair chance at them being written in a homogeneous style, which is desirable if I’m going to have a machine read them.↩︎
I know, right?↩︎