1 (* Copyright Stephen
Weeks (sweeks@sweeks
.com
). 1999-6-21.
3 * This code solves the following
"zebra" puzzle
, and prints the solution
.
4 * There are
120^
5 ~
= 24 billion possibilities
, so exhaustive search should
5 * work fine
, but I decided to write something that was a bit more clever
.
6 * It took me longer to
write (2.5 hours
) than to write exhaustive search
, but
7 * it runs
fast (0.06 seconds on my
400MhZ P6
). The code only needs to explore
8 * 3342 posibilites to solve the puzzle
.
12 * This
word problem has
25 variables
and 24 are given values
. You must
18 * If you look at the problem mathematically
, no sweat
. If you get lost
20 * English
, you are dead
.
22 * You will know you are right by checking the answer
with all the
25 * Less than
1 percent
of the population can solve this problem
.
27 * The question is
: Based on the following clues
, who owns the zebra?
29 * **There are five houses
.
31 * **Each house has its own unique color
.
33 * **All house owners are
of different nationalities
.
35 * **They all have different pets
.
37 * **They all drink different drinks
.
39 * **They all smoke different cigarettes
.
41 * **The Englishman lives
in the red house
.
43 * **The Swede has a dog
.
45 * **The Dane drinks tea
.
47 * **The green house is adjacent to the white house on the left
.
49 * **In the green house they drink coffee
.
51 * **The man who smokes Pall Malls has birds
.
53 * **In the yellow house they smoke Dunhills
.
55 * **In the middle house they drink milk
.
57 * **The Norwegian lives
in the first house
.
59 * **The man who smokes Blends lives
in a house next to the house
with
62 * **In a house next to the house
where they have a horse
, they smoke
65 * **The man who smokes Blue Masters drinks beer
.
67 * **The German smokes Princes
.
69 * **The Norwegian lives next to the blue house
.
71 * **They drink water
in a house next to the house
where they smoke
77 fun peek (l
, p
) = List.find p l
78 fun map (l
, f
) = List.map f l
79 fun fold (l
, b
, f
) = List.foldl f b l
81 datatype cigarette
= Blend | BlueMaster | Dunhill | PallMall | Prince
82 val cigaretteToString
=
84 | BlueMaster
=> "BlueMaster"
85 | Dunhill
=> "Dunhill"
86 | PallMall
=> "PallMall"
88 datatype color
= Blue | Green | Red | White | Yellow
95 datatype drink
= Beer | Coffee | Milk | Tea | Water
102 datatype nationality
= Dane | English | German | Norwegian | Swede
103 val nationalityToString
=
105 | English
=> "English"
107 | Norwegian
=> "Norwegian"
109 datatype pet
= Bird | Cat | Dog | Horse | Zebra
118 val poss
= [1, 2, 3, 4, 5]
122 type 'a attribute
= {poss
: pos list
,
124 known
: (pos
* 'a
) list
}
127 fun 'a
fluidLet (r
: 'a ref
, x
: 'a
, f
: unit
-> 'b
): 'b
=
130 ; (f () before r
:= old
)
131 handle Done
=> raise Done
132 | e
=> (r
:= old
; raise e
)
137 fun init (unknown
: 'a list
): 'a attribute ref
=
138 ref
{poss
= poss
, unknown
= unknown
, known
= []}
139 val cigarettes
= init
[Blend
, BlueMaster
, Dunhill
, PallMall
, Prince
]
140 val colors
= init
[Blue
, Green
, Red
, White
, Yellow
]
141 val drinks
= init
[Beer
, Coffee
, Milk
, Tea
, Water
]
142 val nationalities
= init
[Dane
, English
, German
, Norwegian
, Swede
]
143 val pets
= init
[Bird
, Cat
, Dog
, Horse
, Zebra
]
145 fun ''a
find (r
: ''a attribute ref
) (x
: ''a
): pos option
=
146 Option
.map #
1 (peek (#
known (!r
), fn (_
, y
) => x
= y
))
147 val smoke
= find cigarettes
148 val color
= find colors
149 val drink
= find drinks
150 val nat
= find nationalities
155 fun loop (r
: 'a attribute ref
, toString
) =
158 val x
= #
2 (valOf (peek (#
known (!r
),
159 fn (j
, _
) => i
= j
)))
162 ; print (CharVector
.tabulate (12 - size s
,
167 loop (cigarettes
, cigaretteToString
)
168 ; loop (colors
, colorToString
)
169 ; loop (drinks
, drinkToString
)
170 ; loop (nationalities
, nationalityToString
)
171 ; loop (pets
, petToString
)
175 fn (SOME x
, SOME y
) => f (x
, y
)
177 val same
= make (op =)
178 val adjacent
= make (fn (x
, y
) => x
= y
- 1 orelse y
= x
- 1)
179 val left
= make (fn (x
, y
) => x
= y
- 1)
182 fun isConsistent (): bool =
185 same (nat English
, color Red
)
186 andalso same (nat Swede
, pet Dog
)
187 andalso same (nat Dane
, drink Tea
)
188 andalso left (color Green
, color White
)
189 andalso same (color Green
, drink Coffee
)
190 andalso same (smoke PallMall
, pet Bird
)
191 andalso same (color Yellow
, smoke Dunhill
)
192 andalso same (middle
, drink Milk
)
193 andalso same (nat Norwegian
, first
)
194 andalso adjacent (smoke Blend
, pet Cat
)
195 andalso adjacent (pet Horse
, smoke Dunhill
)
196 andalso same (drink Beer
, smoke BlueMaster
)
197 andalso same (nat German
, smoke Prince
)
198 andalso adjacent (nat Norwegian
, color Blue
)
199 andalso adjacent (drink Water
, smoke Blend
)
207 | x
:: l
=> (f (x
, l @ ac
); loop (l
, x
:: ac
))
211 fun try (r
: 'a attribute ref
,
212 f
: unit
-> (('a attribute
-> unit
)
213 * ( unit
-> unit
))) =
214 let val {poss
, unknown
, known
} = !r
218 tryEach (unknown
, fn (x
, unknown
) =>
219 let val (each
, done
) = f ()
220 in tryEach (poss
, fn (p
, poss
) =>
221 let val attr
= {known
= (p
, x
) :: known
,
226 if isConsistent () then each attr
else ())
232 (* loop takes the current state
and either
233 * - terminates
in the same state
if there is no consistent extension
234 * - raises Done
with the state set at the consistent extension
236 exception Inconsistent
237 exception Continue
of unit
-> unit
244 datatype 'a attrs
= None | One
of 'a | Many
248 None
=> attrs
:= One a
249 | One _
=> attrs
:= Many
253 None
=> raise Inconsistent
254 | One a
=> raise (Continue (fn () => fluidLet (r
, a
, loop
)))
262 fun done () = raise Inconsistent
273 ; explore nationalities
276 handle Inconsistent
=> ()
279 val _
= loop () handle Done
=> ()
280 val _
= if 3342 = !num
282 else raise Fail
"bug"
283 (* val _
= display () *)