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

Question

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?

Answer 1

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]
solution = Thread[vars -> LinearProgramming[
     Table[0, Length[vars]],
     bm[[2]],
     Transpose@{-bm[[1]], 
       constraints[[All, 0]] /. {Equal -> 0, LessEqual -> -1,             GreaterEqual -> 1}},
     0,
     Integers]];

Answer 2

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!

Answer 3

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.

Answer 4

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}}}