# Elegant solution to the Zebra [logic] Puzzle ("Einstein's Riddle")

The famous Zebra Puzzle (Wikipedia), often called "Einstein's Riddle," is a logic puzzle that can be solved deductively by applying a list of logical rules.

One version of the riddle (from Wikipedia) begins:

1. There are five houses.
2. The Englishman lives in the red house.
3. The Spaniard owns the dog. ...

The idea is that there are five houses, painted different colors, with occupants (one in each house) of different nationalities each of whom smokes a different brand, drinks a different beverage, and keeps a different pet. Given the "clues," the puzzle asks which resident owns the zebra.

Given that Mathematica is a rule-based language, it seems that there should be a way of solving the puzzle without resorting to brute-force (i.e. while loops or searching). Can Mathematica be used to elegantly deduce the solution? How?

• Yes. See library.wolfram.com/infocenter/MathSource/7177 . I've got buried somewhere a generalized solver for these kinds of puzzles based on an implementation of continuations with aborts, I'll try and dig it up.
– ciao
Commented May 3, 2014 at 6:56
• Commented May 3, 2014 at 7:12
• @rasher Thank you for that reference! I'm interested to see your generalized solver. Commented May 3, 2014 at 15:32
• @belisarius Thank you for restoring my faith that you can buy anything on the interwebs. Commented May 3, 2014 at 15:34
• A solution method is given here. See also this talk which has a couple of related puzzles. Another PDF along with Mathematica notebook is available here and probably also somewhere at library.wolfram.com (I've become too timid to search there). Commented May 3, 2014 at 19:30

You can use LinearProgramming or more simply Minimize to solve this problem. The idea is to minimize an objective function of some decision variables subject to some constraints. The objective function doesn't matter, can be a constant function, the only relevant thing is the constraint satisfaction.

First, setup the parameters, sets and clues (in an abstract way):

n = 5;
set[] = {"Color", "Nationality", "Drink", "Pet", "Smoke"};
set["Color"] = {"Yellow", "Red", "Green", "Ivory", "Blue"};
set["Nationality"] = {"Norwegian", "Ukrainian", "Englishman", "Spaniard", "Japanese"};
set["Pet"] = {"Fox", "Horse", "Dog", "Snails", "Zebra"};
set["Drink"] = {"Water", "Orange Juice", "The", "Coffee", "Milk"};
set["Smoke"] = {"Kools", "Lucky Strike", "Chesterfield", "Old Gold", "Parliament"};
clues = {
(* 02 *) PairConstraint["Nationality", "Englishman", "Color", "Red"],
(* 03 *) PairConstraint["Nationality", "Spaniard", "Pet", "Dog"],
(* 04 *) PairConstraint["Drink", "Coffee", "Color", "Green"],
(* 05 *) PairConstraint["Drink", "The", "Nationality", "Ukrainian"],
(* 06 *) OrderConstraint["Color", "Ivory", "Color", "Green"],
(* 07 *) PairConstraint["Smoke", "Old Gold", "Pet", "Snails"],
(* 08 *) PairConstraint["Smoke", "Kools", "Color", "Yellow"],
(* 09 *) PositionConstraint[3, "Drink", "Milk"],
(* 10 *) PositionConstraint[1, "Nationality", "Norwegian"],
(* 11 *) NeighborConstraint["Smoke", "Chesterfield", "Pet", "Fox"],
(* 12 *) NeighborConstraint["Smoke", "Kools", "Pet", "Horse"],
(* 13 *) PairConstraint["Smoke", "Lucky Strike", "Drink", "Orange Juice"],
(* 14 *) PairConstraint["Nationality", "Japanese", "Smoke", "Parliament"],
(* 15 *) NeighborConstraint["Nationality", "Norwegian", "Color", "Blue"]
};
search = {"Water", "Zebra"};


Then build decision variables. Every variable x[i_, p_, v_] is 1 if the property value v (Red, Englishman, ...) is assigned for the property p (Color, Nationality, ...) to the house number i and 0 otherwise.

vars = Outer[\[FormalX], Range[n], {#}, set[#]] & /@ set[];


Then build constraints.

1. Each decision variable should be greather than or equal to 0 (and also less than or equal to 1, but this is taken into account at 2., and also an integer, but this is taken into during optimization).
2. Sums of decisions variables x[i_, p_, v_] for fixed {p,v} or for fixed {i,p} should be 1, because each property value ("Red", "Englishman" and so on) should be assigned exactly once, and because each house should have assigned exactly one property value per property (color, nationality and so on).
3. Each of the previous 4 types of clues can then be translated to a (set of) relation between decision variables.

Specifically:

1. PositionConstraint[i_, p_, v_] means the property value v should be assigned for property p to the house number i, so simply x[i, p, v] == 1.
2. PairConstraint[p1_, v1_, p2_, v2_] means that if the property value v1 is assigned for property p1 to some house number i_, also the property value v2 should be assigned for property p2 to the same house number i. For every {i, n} we need to have x[i, p1, v1] == x[i, p2, v2].
3. OrderConstraint[p1_, v1_, p2_, v2_] means that the property value v2 for property p2 should assigned to house number i+1 iff the property value v1 is assigned for property p1 to the number i_. So for every {i, 0, n} we need to have x[i, p1, v1] == x[i+1, p2, v2]. At the end of building constraints a replacement x[0 | (n + 1), _, _] -> 0 is done.
4. NeigborConstraint[p1_, v1_, p2_, v2_] means that if v1 for p1 is assigned to house i_, v2 for p2 should be assigned to house i-1 or i+1 and if v2 for p2 is assigned to house i_, v1 for p1 should be assigned to house i-1 or i+1. For every {i, n} the first requirement can be formultad asking that x[i, p1, v1] <= x[i-1, p2, v2] + x[i+1, p2, v2] and the second with x[i, p2, v2] <= x[i-1, p1, v1] + x[i+1, p1, v1]

Joinin all these kind of constraints is done with:

constraints = Join[

(* Every Decision Variable is an assignment, should be \[GreaterEqual] 0 (and \[LessEqual] 1, and \[Element] Integers) *)
Map[# >= 0 &, vars, {4}],

(* Each property value ("Red", "Englishman" and so on) should be assigned exactly once *)
(* Each house should have assigned exactly one property value per propery (color, nationality and so on) *)
Map[Plus @@ # == 1 &, #, {4}] &@({#, Transpose[#, {1, 4, 3, 2}]} &@ vars),

(* Clues constraints translated *)
clues /. {
PositionConstraint[i_, p_, v_] :> \[FormalX][i, p, v] == 1,
PairConstraint[p1_, v1_, p2_, v2_] :> Table[\[FormalX][i, p1, v1] == \[FormalX][i, p2, v2], {i, n}],
OrderConstraint[p1_, v1_, p2_, v2_] :> Table[\[FormalX][i, p1, v1] == \[FormalX][i + 1, p2, v2], {i, 0, n}],
NeighborConstraint[p1_, v1_, p2_, v2_] :> Table[{
\[FormalX][i, p1, v1] <= \[FormalX][i - 1, p2, v2] + \[FormalX][i + 1, p2, v2],
\[FormalX][i, p2, v2] <= \[FormalX][i - 1, p1, v1] + \[FormalX][i + 1, p1, v1]
}, {i, n}]
} /. \[FormalX][0 | (n + 1), _, _] :> 0
];


Compute the solution. Compute the minimum value of constant function 0 subject to the constraints, with integers decision variables. Discard the optimal value and keep only rules for devision variables values.

solution = Last@Minimize[{0, constraints}, Flatten[vars], Integers];


Finally display the result:

Outer[First@Cases[solution, HoldPattern[\[FormalX][#2, #1, v_] -> 1] :> v] &,
set[], Range[n]] /.
{p : Alternatives @@ search -> Style[p, Bold, Red]} //
MapThread[Prepend[#1, #2] &, {#, set[]}] & //
Prepend[#, Prepend[Range[n], ""]] & //
Grid[#, Dividers -> All, ItemSize -> {8, 1.5}, Alignment -> Center] & //
Style[#, "DialogStyle"] &


This is the output:

## UPDATE

Maybe it would be easier to use

solution = ToRules@Reduce[Flatten[constraints], Flatten[vars], Integers];


but on my machine this command is slower.

Using LinearProgramming instead is a bit more complicated because we need to construct the cost vector and Matrix, but the function is very fast.

vars = Flatten[vars];
constraints = DeleteCases[Flatten@constraints, \[FormalX][__] >= 0];
bm = CoefficientArrays[Equal @@@ constraints, vars]
Table[0, Length[vars]],
bm[[2]],
Transpose@{-bm[[1]],
constraints[[All, 0]] /. {Equal -> 0, LessEqual -> -1,             GreaterEqual -> 1}},
0,
Integers]];

• It's not like "the one who smokes Chesterfield lives near the one who has a Fox" (11, 12, 15)? Commented Jul 20, 2014 at 9:15
• @unlikely...thank you for an education...you get my vote Commented Jul 20, 2014 at 11:15
• @ubpdqn thanks, linear programming is interesting... Commented Jul 21, 2014 at 17:15

I wrote an unification-based program as used in Prolog language.

First, I setup a simple unification functions:

Clear[unify];
unify[var1_Symbol, var2_Symbol] :=
If[var1 === var2, {}, {var1 -> var2}];
unify[const1_?StringQ, const2_?StringQ] :=
If[const1 == const2, {}, $Failed]; unify[var_Symbol, const_?StringQ] := {var -> const}; unify[const_?StringQ, var_Symbol] := unify[var, const]; unify[{exp1_, others1___}, {exp2_, others2___}] := Module[{car = unify[exp1, exp2], cdr}, If[car ===$Failed, Return[$Failed]]; (*else*) cdr = unify[{others1} /. car, {others2} /. car]; If[cdr ===$Failed, Return[$Failed]]; (*else*) car~Join~cdr ]; unify[{}, {}] = {}; unify[exp_, _Blank] = unify[_Blank, exp_] = {};  "There are five houses" (clue 1), each of which has its resident: Clear[houses]; houses0 = houses[ {man1, color1, drink1, smoke1, pet1}(*house 1*), {man2, color2, drink2, smoke2, pet2}(*house 2*), {man3, color3, drink3, smoke3, pet3}(*house 3*), {man4, color4, drink4, smoke4, pet4}(*house 4*), {man5, color5, drink5, smoke5, pet5}(*house 5*) ]; printHouses[h_houses] := Transpose@(List @@ h) // Grid[#, Frame -> All] &;  This is our target: printHouses[houses0] We have clues: Clear[clue, houseClue]; dC(*don't Care*)= {_, _, _, _, _}; clue[2] = {"Englishman", "red", _, _, _}; clue[3] = {"Spaniard", _, _, _, "dog"}; clue[4] = {_, "green", "coffee", _, _}; clue[5] = {"Ukrainian", _, "tea", _, _}; clue[6] = houseClue @@ { {{_, "ivory", _, _, _}, {_, "green", _, _, _}, dC, dC, dC}, {dC, {_, "ivory", _, _, _}, {_, "green", _, _, _}, dC, dC}, {dC, dC, {_, "ivory", _, _, _}, {_, "green", _, _, _}, dC}, {dC, dC, dC, {_, "ivory", _, _, _}, {_, "green", _, _, _}} }; clue[7] = {_, _, _, "Old Gold", "snail"}; clue[8] = {_, "yellow", _, "Kool", _}; clue[9] = drink3 -> "milk"; clue[10] = man1 -> "Norwegian"; clue[11] = houseClue @@ { {{_, _, _, _, "fox"}, {_, _, _, "Chesterfield", _}, dC, dC, dC}, {dC, {_, _, _, _, "fox"}, {_, _, _, "Chesterfield", _}, dC, dC}, {dC, dC, {_, _, _, _, "fox"}, {_, _, _, "Chesterfield", _}, dC}, {dC, dC, dC, {_, _, _, _, "fox"}, {_, _, _, "Chesterfield", _}}, {{_, _, _, "Chesterfield", _}, {_, _, _, _, "fox"}, dC, dC, dC}, {dC, {_, _, _, "Chesterfield", _}, {_, _, _, _, "fox"}, dC, dC}, {dC, dC, {_, _, _, "Chesterfield", _}, {_, _, _, _, "fox"}, dC}, {dC, dC, dC, {_, _, _, "Chesterfield", _}, {_, _, _, _, "fox"}} }; clue[12] = houseClue @@ { {{_, _, _, _, "horse"}, {_, _, _, "Kool", _}, dC, dC, dC}, {dC, {_, _, _, _, "horse"}, {_, _, _, "Kool", _}, dC, dC}, {dC, dC, {_, _, _, _, "horse"}, {_, _, _, "Kool", _}, dC}, {dC, dC, dC, {_, _, _, _, "horse"}, {_, _, _, "Kool", _}}, {{_, _, _, "Kool", _}, {_, _, _, _, "horse"}, dC, dC, dC}, {dC, {_, _, _, "Kool", _}, {_, _, _, _, "horse"}, dC, dC}, {dC, dC, {_, _, _, "Kool", _}, {_, _, _, _, "horse"}, dC}, {dC, dC, dC, {_, _, _, "Kool", _}, {_, _, _, _, "horse"}} }; clue[13] = {_, _, "orange juice", "Lucky Strike", _}; clue[14] = {"Japanese", _, _, "Parliament", _}; clue[15] = color2 -> "blue"; clue[16] = {whoDrinksWater, _, "water", _, _}; clue[17] = {whoOwnsZebra, _, _, _, "zebra"};  Then, I did unification one clue after another removing failed results to obtain all the possible answers: Clear[applyClue]; applyClue[h_houses, clue_List] := Module[{u = DeleteCases[unify[clue, #] & /@ (List @@ h),$Failed]},
If[u == {}, $Failed, h /. u]]; applyClue[hs_List, clue_List] := DeleteCases[Flatten[applyClue[#, clue] & /@ hs],$Failed];
applyClue[h_houses, clues_houseClue] :=
Module[{u =
List @@ DeleteCases[unify[List @@ h, #] & /@ clues, $Failed]}, If[u == {},$Failed, h /. u]];
applyClue[hs_List, clues_houseClue] :=
DeleteCases[Flatten[applyClue[#, clues] & /@ hs], $Failed]; possibilities = Fold[applyClue, houses0 /. {clue[9], clue[10], clue[15]}, Table[clue[ i], {i, {2, 3, 4, 5, 6, 7, 8, 11, 12, 13, 14, 16, 17}}]];  This is the result: printHouses /@ possibilities And our interests: DeleteCases[ List @@ (unify[clue[16], #] & /@ #),$Failed] & /@ possibilities
(*{{{whoDrinksWater -> "Norwegian"}}}*)
DeleteCases[
List @@ (unify[clue[17], #] & /@ #), \$Failed] & /@ possibilities
(*{{{whoOwnsZebra -> "Japanese"}}}*)


By the way, I am a Japanese, but I have not obtained my zebra yet!

• Don't worry, there are enough fake zebras in japan: link. Thanks for your excellent answer :)
– eldo
Commented Jul 24, 2014 at 19:55
• This looks very nice. If one were to write a function to mutate e.g. {{_, _, _, _, "fox"}, {_, _, _, "Chesterfield", _}, dC, dC, dC} into all variations one could save some code length. Commented Jul 24, 2014 at 20:32
• Tetsuo Ichii may I attempt to implement the shortening I described above and edit it into your answer? Commented Oct 2, 2014 at 15:49

EDIT

This edit (I hope corrects the problem identified by Mr. Wizard: (i) there was a typographical error "Kools", should have been "Kool", and the styling of desired targets has now been left to the end).

I post this not as elegant but I spent some time and particularly like "unlikely"'s answer.

The puzzle:

Setting up:

housenumber = Range[5];
housecolour = {"red", "green", "ivory", "yellow", "blue"};
country = {"English", "Spaniard", "Ukrainian", "Japanese",
"Norwegian"};
drink = {"coffee", "tea", "milk", "orange juice", "water"};
smoke = {"Old Gold", "Chesterfields", "Kool", "Lucky Strike",
"Parliaments"};
pet = {"dog", "zebra", "snails", "fox", "horse"};
all = {housenumber, housecolour, country, drink, smoke, pet};


Using the data from the material:

sp = Association /@ {{"house" -> 1,
"nationality" -> "Norwegian"}, {"house" -> 2,
"colour" -> "blue"}, {"house" -> 3,
"drink" -> "milk"}, {"house" -> 4}, {"house" -> 5}};
kn = Association /@ {{"nationality" -> "English",
"colour" -> "red"}, {"nationality" -> "Spaniard",
"pet" -> "dog"}, {"drink" -> "coffee",
"colour" -> "green"}, {"colour" -> "ivory"}, {"nationality" ->
"Ukrainian", "drink" -> "tea"}, {"smoke" -> "Old Gold",
"pet" -> "snails"}, {"smoke" -> "Kool",
"colour" -> "yellow"}, {"smoke" -> "Chesterfields"}, {"pet" ->
"fox"}, {"pet" -> "horse"}, {"smoke" -> "Lucky Strike",
"drink" -> "orange juice"}, {"nationality" -> "Japanese",
"smoke" -> "Parliaments"}, {"drink" ->
"water"}, {"pet" ->"zebra"}};
not = {{1, "green"}, {2, "green"}, {3, "green"}, {"ivory",
5}, {"ivory", 1}, {"ivory", 2}, {"Chesterfields",
"fox"}, {"Kool", "horse"}};
full = {"house", "colour", "nationality", "drink", "smoke", "pet"};
MapThread[Map[Function[q, cl[q] := #2;], #1] &, {all, full}];


The last function just to allow reordering at the end. Now trying to fit pieces into the empty slots (each house must have six slots: number, colour, nationality,drink, smoke, pet).

func[v_] :=
Map[Flatten,
Select[Select[Merge[{v, #}, Identity] & /@ kn,
Times @@ (Length /@ Values[#]) == 1 &]
, Not[Or @@
Map[Function[u, SubsetQ[Flatten@Values[#], u]], not]] &], {2}]
genf[t_] := Module[{coll = {}, s1, s2},
Select[NestWhileList[(s1 = Flatten[func /@ #];
s2 = Select[s1, Length@# == 6 &]; AppendTo[coll, s2];
Complement[s1, s2]) &, func[t], Length@# > 0 &][[-2]],
Length@# == 6 &];
Join @@ coll
]
res = genf /@ sp;
cand = Map[First /@ Values[#] &, res, {2}];
{a, b, c, d, e} = Union /@ Map[Sort, cand, {2}];
tp = Tuples[{a, b, c, d, e}];


Now tp contains the candidate solutions that need to be paired down. Firstly removing duplicate entries, then using the boundary criteria: green house on right of ivory, locations of horse and fox etc.

sq[u_] := Times @@ (Tally[Flatten[u]][[All, 2]]) == 1
bf1[u_] := Module[{g, i},
g = Select[u, MemberQ[#, "green"] &][[1, 1]];
i = Select[u, MemberQ[#, "ivory"] &][[1, 1]];
g - i == 1]
bf2[u_] := Module[{k, h},
k = Select[u, MemberQ[#, "Kool"] &][[1, 1]];
h = Select[u, MemberQ[#, "horse"] &][[1, 1]];
Abs[k - h] == 1]
bf3[u_] := Module[{c, f},
c = Select[u, MemberQ[#, "Chesterfields"] &][[1, 1]];
f = Select[u, MemberQ[#, "fox"] &][[1, 1]];
Abs[c - f] == 1]
ans = Fold[Select[#1, #2] &, tp, {sq, bf1, bf2, bf3}];
answer = Map[(cl[#] -> #) &, First@ans, {2}];
Grid[Prepend[full /. answer, Style[#, Bold] & /@ full]/.{"water"->Style["water",Red],"zebra"->Style["zebra",Red]}, Frame -> All]


ans had one element the unique solution selected from candidate entries compatible with partitioning requirement and boundary criteria:

Fun to participate even though my approach rather ugly and inefficient.

Another option, sort of like pattern matching on training wheels.

First apply criteria for individual houses.

ClearAll@"Global*";

colors = {red, blue, yellow, ivory, green};
nations = {norway, ukraine, england, spain, japan};
drinks = {water, tea, milk, oj, coffee};
smokes = {kools, chesterfields, golds, luckys, parliaments};
pets = {fox, horse, snails, dog, zebra};

notBoth[alts__] := Count[#, Alternatives[alts]] == 1 &;
both[alts__] := Count[#, Alternatives[alts]] == 2 &;

Tuples[Sort /@ {colors, nations, drinks, smokes, pets}];
tups = DeleteCases[%,
x_ /; Or[
notBoth[england, red]@x,
notBoth[spain, dog]@x,
notBoth[coffee, green]@x,
notBoth[ukraine, tea]@x,
notBoth[golds, snails]@x,
notBoth[kools, yellow]@x,
notBoth[luckys, oj]@x,
notBoth[japan, parliaments]@x,
both[chesterfields, fox]@x,
both[kools, horse]@x,
both[norway, blue]@x,
both[norway, milk]@x]];

subsets =
Select[Subsets[tups, {5}],
Length@DeleteDuplicates@Flatten@# == 25 &];


And then the structural conditions.

Cases[
Flatten[Permutations[#, {5}] & /@ subsets, 1],
u : {{_, norway, __}, {blue, __}, {__, milk, __}, {__}, {__}} /; And[
MatchQ[u[[All, 1]], {___, ivory, green, ___}],
MatchQ[u[[All, {4, 5}]], {___, Repeated[{chesterfields, _} | {_, fox}, {2}], ___}],
MatchQ[u[[All, {4, 5}]], {___, Repeated[{kools, _} | {_, horse}, {2}], ___}]]]


{{{yellow, norway, water, kools, fox}, {blue, ukraine, tea, chesterfields, horse}, {red, england, milk, golds, snails}, {ivory, spain, oj, luckys, dog}, {green, japan, coffee, parliaments, zebra}}}

• What is your last statement? I can only read Cases[`
– eldo
Commented Jul 24, 2014 at 22:24
• @eldo I'll break it into 2 blocks so there is no scrolling Commented Jul 24, 2014 at 23:27