The Einstein puzzle

Introduction
Program
Output
Discussion

Introduction

Richard Suchenwirth 2005-03-19 - Albert Einstein is said to have presented this puzzle (read [L1 ] for details, or just google for "Einstein puzzle" or "Einstein riddle"):

There are five houses in a row, each in a different color, inhabited by a different national who has a different pet, drinks a different beverage, and smokes a different brand of cigarettes.

Given the initial facts:

The Brit lives in the red house.
The Swede keeps dogs as pets.
The Dane drinks tea.
The green house is on the left of the white house.
The green house's owner drinks coffee.
The person who smokes Pall Mall rears birds.
The owner of the yellow house smokes Dunhill.
The man living in the center 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 the horse lives next to the man who smokes Dunhill.
The owner who smokes Bluemasters drinks beer.
The German smokes Prince.
The Norwegian lives next to the blue house.
The man who smokes Blends has a neighbor who drinks water.

The question is: "Who owns the fish?"

After doing it manually, I wanted to try Tcl on it too. I decided to number the houses as {1 2 3 4 5} from left to right, and implement a "predicate" as a variable which has one of the house numbers as value.
Some can be set immediately from the facts ("set milk 3" meaning "the person who drinks milk lives in house 3, i.e. the middle one").

Possible assignments are generated by permutations.
To make this code run faster on my 200MHz W95 box, I added quick tests that just cause the testing loop to continue.
All possibilities are tried, in case there is more than one solution.

Program

 proc EinsteinPuzzle {} {
    #-- Immediately resulting from the facts:
    set milk 3      ;# (8)
    set Norwegian 1 ;# (9)
    set blue 2      ;# (14)
    #-- let's try many things!
    try {Brit Swede Dane German} {2 3 4 5} {
        try {red white yellow green} {1 3 4 5} {
            if {$green != $white-1} continue        ;# (4)
            if {$Brit != $red}      continue        ;# (1)
            try {dog birds cats horse fish} {1 2 3 4 5} {
                if {$Swede != $dog} continue        ;# (2)
                try {tea coffee beer water} {1 2 4 5} {
                    if {$Dane != $tea}     continue ;# (3)
                    if {$green != $coffee} continue ;# (5)
                    try {PallMall Dunhill Bluemasters Prince Blends} \
                        {1 2 3 4 5} {
                          #-- test the leftover conditions
                          if {
                            $PallMall == $birds &&
                            $yellow == $Dunhill &&
                            [next $Blends $cats] &&
                            [next $horse $Dunhill] &&
                            $Bluemasters == $beer &&
                            $German == $Prince &&
                            [next $Blends $water]
                          } dump
                    }
                }
            }
        }
    }
 }
#-- This custom control structure was instigated by [Solving cryptarithms]
 proc try {atts values body} {
    foreach perm [permute $values] {
        uplevel 1 "assign {$atts} {$perm}; $body"
    }
 }
#-- assign {a b c} {1 2 3} == set a 1; set b 2; set c 3 
 proc assign {atts values} {
    foreach att $atts value $values {uplevel 1 set $att $value}
 }
#-- Borrowed from [Permutations], [Lars H]'s version:
 proc permute {list {prefix ""}} {
    if {![llength $list]} {return [list $prefix]}
    set res [list]
    set n 0
    foreach e $list {
        eval [list lappend res]\
          [permute [lreplace $list $n $n] [linsert $prefix end $e]]
        incr n
    }
    return $res
 }
#-- Neighborhood relation is factored out:
 proc next {x y} {expr {abs($x-$y)==1}}
 
if 0 {This dumps all local variables of the caller that have integer value,
sorted by that value (so that properties of houses come together):}
 proc dump {} {
    set res {}
    foreach var [lsort [uplevel 1 info locals]] {
        set val [uplevel 1 set $var]
        if {[string is integer -strict $val]} {
            lappend res [list $var $val]
        }
    }
    puts [lsort -index 1 $res]
 }
#-- Let's go, and see how long it takes: 
 set t [lindex [time EinsteinPuzzle] 0]
 puts "[expr {$t/1000000.}] sec"

Output

This comes out (newlines added; you young guys with your fast boxes will probably beat my time :^)

 C:\_Ricci\sep>tclsh puzzle.tcl
 {Dunhill 1} {Norwegian 1} {cats 1} {water 1} {yellow 1}
 {Blends 2} {Dane 2} {blue 2} {horse 2} {tea 2}
 {Brit 3} {PallMall 3} {birds 3} {milk 3} {red 3}
 {German 4} {Prince 4} {coffee 4} {fish 4} {green 4}
 {Bluemasters 5} {Swede 5} {beer 5} {dog 5} {white 5}
 107.666357 sec

So my (or Tcl's) answer is "The German in house #4 owns the fish."

Discussion

A Forth solution is at http://www.albany.net/~hello/Einstein.htm ,
Common Lisp at http://www.weitz.de/einstein.html ,
Logo at http://mail.python.org/pipermail/python-list/2001-March/033043.html ,
and more somewhere out there on the Web...

See also Brute force with velvet gloves

AM (23 march 2005) Studying this lovely little piece of software, I could not help myself but do a little arithmetic:

The number of potential solutions that have to be considered is 4!*4!*4!*5!*5!, about 200 million. Of course, many of these are not considered at all, due to the shortcuts Richard introduced. It seems rather tough to estimate how many will be searched, though.
To try and reduce the run time, one could instead incorporate many of the checks in the loops themselves. Rather than generate all the permutations and then check if the Dane still drinks tea, one can simply make tea equal to $Dane. You get into the realm of variations then. The number of variations is: 4!/1! * 4!/2! * 5!/1! * 4!/2! * 5!/4! =

roughly 2 million.

To implement this: replace the permutation proc by a procedure that produces variations. And:

    try {red white yellow green} {1 3 4 5} { ... }

becomes:

    try {white yellow} {1 3 4 5} {
        set red $Brit
        set green [expr {$white-1}]
        ...

(and so on)

Other variations on this puzzle:

The houses are put in a circle, so that house 5 neighbours house 1
Are there any redundancies? That is: Could we leave out a fact?
What happens if we change some fact?

RS: The suggested change won't work so easy, because the lists of variables and values must be of equal length. If in an early "variation", white is 1, and so green gets set to 0 untested... But it's true that earlier quick-kills can further reduce the number of full loops. Changing the order of try loops to color - nationality - beverage - pet - cigarettes brought runtime on my work machine down from 4.172 to 3.516 sec. But then again, doing those edits took me more than half a second... :^)

HJG 2015-05-05 - This puzzle is also known as the "Zebra puzzle".
There is another Tcl-solution at RosettaCode

Arts and Crafts of Tcl-Tk Programming

Category Puzzles

Category Whizzlet

Category RosettaCode