# Who owns the fish?

## A Common Lisp solution to "Einstein's Riddle"

This is a Common Lisp solution to a notorious logical puzzle known as "Einstein's riddle." (I doubt that Einstein really had something do with it, but that's another story.) The problem is stated below:

There are five houses in five different colours starting from left to right. In each house lives a person of a different nationality. These owners all drink a certain type of beverage, smoke a certain brand of cigarette and keep a certain type of pet. No two owners have the same pet, smoke the same brand or drink the same beverage. The question is: WHO OWNS THE FISH??? Hints:
1. The Brit lives in the red house
2. The Swede keeps dogs as pets
3. The Dane drinks tea
4. The green house is on the left of the white house
5. The green house's owner drinks coffee
6. The person who smokes Pall Mall rears birds
7. The owner of the yellow house smokes Dunhill
8. The man living in the centre house drinks milk
9. The Norwegian lives in the first house
10. The person who smokes Marlboro lives next to the one who keeps cats
11. The person who keeps horses lives next to the person who smokes Dunhill
12. The person who smokes Winfield drinks beer
13. The German smokes Rothmans
14. The Norwegian lives next to the blue house
15. The person who smokes Marlboro has a neigbor who drinks water

I wrote an ANSI Common Lisp solution to this problem mainly because I wanted to experiment with macros. The program tries to be abstract enough to solve similar problems as well - like, e.g., the "Zebra Problem." I also tried to build a solution that is sufficiently fast and produces readable code.

For want of better words I'll use the following terminology while explaining my code: The problem is described by a couple of property descriptors which consist of a name for the property and a list of the possible values, optionally followed (just for the sake of grammatical beauty) by the plural form of the property's name. Examples would be (cigarette '(marlboro winfield rothmans pallmall dunhill)) or (mouse '(mickey minny) :plural-name mice). The problem size is the dimension of the solution space which is equal to the number of different properties. In the case of Einstein's riddle, the problem size is 5.

The abstract form of a person in Einstein's riddle with all of its associated properties (drink, cigarette, nationality, ...) will be called a unit and will be stored in a CL structure named after the riddle. Every possible solution is called a selection, it is a list (an ordered n-tuple where n is the problem size) of units.

Solving the riddle with my program involves two steps:

1. initialize the data structures and prepare some macros by calling the macro PREPARE with the problem description
2. call the function SOLVE

To explain the program I will use a problem that is simpler than Einstein's riddle: Our problem consists of three mice living next to each other in three holes in the wall. Each mouse has a favorite cheese flavor and a favorite TV show. Here are the hints:

1. Mickey Mouse loves Gouda
2. Mighty Mouse's favorite TV show is Emergency Room
3. The mouse that lives in the left hole never misses an episode of Seinfeld
4. Mickey Mouse and Mighty Mouse have one mouse hole between them
5. The Simpsons fan does not live on the left of the Brie lover

(prepare mouse-hole
((mouse '(mickey minny mighty) :plural-name mice)
(cheese-flavor '(emmental gouda brie))
(tv-show '(seinfeld simpsons er)))
((cond1 mouse 'mickey cheese-flavor 'gouda)
(cond2 mouse 'mighty tv-show 'er)
(cond3 :position 0 tv-show 'seinfeld)
(cond4 mouse 'mickey mouse 'mighty :distance 2)
(cond5 tv-show 'simpsons cheese-flavor 'brie :distance 1 :directed t :negate t)))

The call syntax of PREPARE is (PREPARE riddle-name property-descriptor-list condition-list) where riddle-name will be used to name the structure that'll hold the units (see above). The second argument consists of a list of property descriptors which are detailed above. The property names will be become the names of the accessor functions for the structure RIDDLE-NAME.

Every condition in condition-list has the following syntax: (condition-name property1 value1 property2 value2) where each of property1 and property2 is one of the property-names, and value1 and value2 are possible values for these properties. Each property name can also be the keyword :POSITION in which case the associated value should be an integer ranging from zero to the problem size minus one. This feature is used to describe conditions like "The Norwegian lives in the first house." The position is zero-based.

The conditions in the condition list can also have one or more of three optional attributes: :DISTANCE, an integer, describes the distance between the units described by the two property/value pairs. :DIRECTED, if not NIL, means that positive and negative :DISTANCE values will be treated differently. In the default case only the absolute value is considered. :NEGATED, if not NIL, means that the reverse of the condition has to hold. The default values are (:DISTANCE 0 :DIRECTED NIL :NEGATED NIL).

We can now call the function SOLVE and get the following result:

(#(MICKEY GOUDA SEINFELD) #(MINNY BRIE SIMPSONS) #(MIGHTY EMMENTAL ER))

Presto!

Here's the function SOLVE that is built by PREPARE,

(DEFUN SOLVE ()
(LET ((MOUSE-PERMUTATIONS
(MAPCAR #'(LAMBDA (PERMUTATION) (MAKE-ARRAY 3 :INITIAL-CONTENTS PERMUTATION))
(PERMUTE '(MICKEY MINNY MIGHTY))))
(CHEESE-FLAVOR-PERMUTATIONS
(MAPCAR #'(LAMBDA (PERMUTATION) (MAKE-ARRAY 3 :INITIAL-CONTENTS PERMUTATION))
(PERMUTE '(EMMENTAL GOUDA BRIE))))
(TV-SHOW-PERMUTATIONS
(MAPCAR #'(LAMBDA (PERMUTATION) (MAKE-ARRAY 3 :INITIAL-CONTENTS PERMUTATION))
(PERMUTE '(SEINFELD SIMPSONS ER)))))
(DOLIST (MICE MOUSE-PERMUTATIONS)
(LET ((RESULT (POSSIBLE-P MICE)))
(WHEN RESULT
(DOLIST (CHEESE-FLAVORS CHEESE-FLAVOR-PERMUTATIONS)
(LET ((RESULT (POSSIBLE-P MICE CHEESE-FLAVORS)))
(WHEN RESULT
(DOLIST (TV-SHOWS TV-SHOW-PERMUTATIONS)
(LET ((RESULT (POSSIBLE-P MICE CHEESE-FLAVORS TV-SHOWS)))
(WHEN RESULT (PPRINT RESULT))))))))))
(VALUES))))

which uses the predicate POSSIBLE-P that is built at the same time:

(DEFUN POSSIBLE-P
(&OPTIONAL (MICE *NOT-YET-DEFINED*)
(CHEESE-FLAVORS *NOT-YET-DEFINED*)
(TV-SHOWS *NOT-YET-DEFINED*))
(DOTIMES (M 3)
(SETF (MOUSE (SVREF *SELECTION* M)) (SVREF MICE M))
(SETF (CHEESE-FLAVOR (SVREF *SELECTION* M)) (SVREF CHEESE-FLAVORS M))
(SETF (TV-SHOW (SVREF *SELECTION* M)) (SVREF TV-SHOWS M)))
(WHEN (AND (COND1 *SELECTION*)
(COND2 *SELECTION*)
(COND3 *SELECTION*)
(COND4 *SELECTION*)
(COND5 *SELECTION*))
*SELECTION*))

(Note that it's MICE, not MOUSES, here although this doesn't alter the correctness of the function... :)

POSSIBLE-P checks whether all conditions hold for one particular selection and returns this selection if they hold, NIL otherwise. This function's main duty is to convert its input values (a permutation of the three mice, a permutation of the three cheese flavors, and a permutation of the three TV shows) into a simple-vector (the special variable *SELECTION*) of three MOUSE-HOLE structures that can be handed to the conditions in the logical AND at the end of the function.

A typical condition from our example, also built by PREPARE, is here:

(DEFUN COND5 (SELECTION)
(LET ((POSITION1
(POSITION-IF #'(LAMBDA (UNIT)
(EQ (TV-SHOW UNIT) 'SIMPSONS))
SELECTION))
(POSITION2
(POSITION-IF #'(LAMBDA (UNIT)
(EQ (CHEESE-FLAVOR UNIT) 'BRIE))
SELECTION)))
(IF (OR (NULL POSITION1)
(NULL POSITION2))
T
(NOT (= 1 (- POSITION2 POSITION1))))))

Note that every condition has to return T if - during the backtracking algorithm - not all of its parameters are defined yet. Also note that SOLVE and POSSIBLE-P are different for each problem as they are built from the property descriptions and the conditions.

The problem definition for "Einstein's Riddle" is:

(prepare einstein
((nation '(british swedish norwegian german danish))
(house '(red green yellow blue white))
(animal '(dog horse cat bird fish))
(cigarette '(marlboro winfield rothmans pallmall dunhill))
(drink '(tea coffee milk beer water)))
((cond-position-first-norwegian :position 0 nation 'norwegian)
(cond-left-green-white house 'green house 'white :distance 1 :directed t)
(cond-british-red nation 'british house 'red)
(cond-neighbor-norwegian-blue nation 'norwegian house 'blue :distance 1)
(cond-swedish-dog nation 'swedish animal 'dog)
(cond-german-rothmans nation 'german cigarette 'rothmans)
(cond-yellow-dunhill house 'yellow cigarette 'dunhill)
(cond-green-coffee house 'green drink 'coffee)
(cond-danish-tea nation 'danish drink 'tea)
(cond-bird-pallmall animal 'bird cigarette 'pallmall)
(cond-neighbor-cat-marlboro animal 'cat cigarette 'marlboro :distance 1)
(cond-neighbor-horse-dunhill animal 'horse cigarette 'dunhill :distance 1)
(cond-winfield-beer cigarette 'winfield drink 'beer)
(cond-neighbor-marlboro-water cigarette 'marlboro drink 'water :distance 1)
(cond-position-middle-milk :position 2 drink 'milk)))

I got the following execution times for a compiled version of SOLVE on my machines:

• my laptop (Pentium III 850 MHz, 256 MB RAM) with Linux 2.4.10 (SuSE 7.3):
• 0.31 [0.04] seconds with Xanalys LispWorks 4.1.20
• 0.31 [0.05] seconds with CMUCL 18c
• 0.49 [0.07] seconds with SBCL 0.6.13
• 0.51 [0.07] seconds with Allegro CL 6.0
• 1.09 [0.19] seconds with ECLS 0.5
• 2.01 [1.93] seconds with CLISP 2000.03.06-56
• same laptop with Win2k:
• server 1 (Pentium III 650 MHz, 256 MB RAM, Linux 2.4.0, CMUCL 2.4.22): 0.38 [0.05] seconds
• server 2 (Pentium III 550 MHz, 256 MB RAM, FreeBSD 4.1, CMUCL 18c): 0.61 [0.07] seconds

That's not too shabby for a problem that has 24,883,200,000 possible solutions!

Notes:

• The code was significantly overhauled due to a conversation I had with Tim Moore in comp.lang.lisp. Tim helped me with the nested backquote syntax in an earlier incarnation of the program and, through his constructive criticism, urged me to write a version that is much better, IMHO, than my original code.
• Dr. Karsten Poeck sent me a CLOS-based solution that was twice as fast as my orginal code and consumed a lot less memory. His files can be found here, here, and here. This induced me to once again overhaul my code and improve its efficiency (mainly by replacing lists with simple vectors and by making *SELECTION* and *NOT-YET-DEFINED* special variables).
• Dr. Gabor Csanyi sent a C++ solution that uses about 2.23 seconds on my laptop if compiled widh -O3.
• Prof. Dr. Klaus Betzler sent another C++ solution which is very fast - about 0.004 to 0.005 seconds...
• Mark Jeffrey Tilford informed me that there's a fast C solution at http://rec-puzzles.org/sol.pl/logic/dell. (Not that I'm going to list every available solution to this puzzle here...)
• The consequences of redefining a structure are undefined in the ANSI Common Lisp standard. Therefore, it is not advisable to try to solve two or more different puzzles of the same name in one session. It works with LispWorks and CMUCL, though.
• Thanks to Fred Gilham who found a syntax error in my original DEFSTRUCT statement which was kindly ignored by LispWorks.
• The timing results above were achieved by applying COMPILE-FILE to a file that included the program code as well as the complete problem definition. I was measuring real time - as opposed to user CPU time or something like that - while a couple of other processes where running. (Off-topic: The results were slightly better with my previous installation - Linux 2.4.4 / SuSE 7.2. Oh well...)
• The conversation with Dr. Gabor Csanyi prompted me to write a new version of the code which automatically re-arranges the order of the properties and the conditions based on a heuristical analysis. As it turned out, the results were much better than before - see the green values above. [It is also interesting that while all implementations that compile to machine code benefit very much from this improvement, there was hardly any difference for CLISP - which compiles to byte-code.]
• Oh, yes: The German owns the fish...
\$Header: /usr/local/cvsrep/weitz.de/einstein.html,v 1.10 2004/12/25 21:20:29 edi Exp \$