Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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?

share|improve this question
3  
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. –  rasher May 3 at 6:56
3  
    
@rasher Thank you for that reference! I'm interested to see your generalized solver. –  Rico Picone May 3 at 15:32
1  
@belisarius Thank you for restoring my faith that you can buy anything on the interwebs. –  Rico Picone May 3 at 15:34
2  
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). –  Daniel Lichtblau May 3 at 19:30

4 Answers 4

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:

Result Table

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];
bm = DeleteCases[Flatten[constraints], \[FormalX][__] >= 0] /. 
    op_[lhs_, rhs_] :>
     (Normal@CoefficientArrays[lhs - rhs, vars] // 
       MapAt[{-#, 
           Switch[op, Equal, 0, LessEqual, -1, GreaterEqual, 
            1]} &, #, {1}] &) // Transpose;
solution = Thread[vars -> LinearProgramming[Table[0, {Length[vars]}], bm[[2]], bm[[1]], 0, Integers]];
share|improve this answer
    
It's not like "the one who smokes Chesterfield lives near the one who has a Fox" (11, 12, 15)? –  unlikely Jul 20 at 9:15
    
@unlikely...thank you for an education...you get my vote –  ubpdqn Jul 20 at 11:15
    
@ubpdqn thanks, linear programming is interesting... –  unlikely Jul 21 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]

printHouses

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

result

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!

share|improve this answer
    
Don't worry, there are enough fake zebras in japan: link. Thanks for your excellent answer :) –  eldo Jul 24 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. –  Mr.Wizard Jul 24 at 20:32

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:

enter image description here

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:

enter image description here

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

share|improve this answer
    
@Mr.Wizard have edited what seem to have been mistakes...if still wrong let me know –  ubpdqn Jul 25 at 2:28

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

share|improve this answer
    
What is your last statement? I can only read Cases[ –  eldo Jul 24 at 22:24
    
@eldo I'll break it into 2 blocks so there is no scrolling –  mfvonh Jul 24 at 23:27

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.