Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright Stephen Weeks (sweeks@sweeks.com). 1999-6-21. |
2 | * | |
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. | |
9 | * | |
10 | * Here is the puzzle. | |
11 | * | |
12 | * This word problem has 25 variables and 24 are given values. You must | |
13 | * solve | |
14 | * the 25th. | |
15 | * | |
16 | * The trick is HOW? | |
17 | * | |
18 | * If you look at the problem mathematically, no sweat. If you get lost | |
19 | * in the | |
20 | * English, you are dead. | |
21 | * | |
22 | * You will know you are right by checking the answer with all the | |
23 | * conditions. | |
24 | * | |
25 | * Less than 1 percent of the population can solve this problem. | |
26 | * | |
27 | * The question is: Based on the following clues, who owns the zebra? | |
28 | * | |
29 | * **There are five houses. | |
30 | * | |
31 | * **Each house has its own unique color. | |
32 | * | |
33 | * **All house owners are of different nationalities. | |
34 | * | |
35 | * **They all have different pets. | |
36 | * | |
37 | * **They all drink different drinks. | |
38 | * | |
39 | * **They all smoke different cigarettes. | |
40 | * | |
41 | * **The Englishman lives in the red house. | |
42 | * | |
43 | * **The Swede has a dog. | |
44 | * | |
45 | * **The Dane drinks tea. | |
46 | * | |
47 | * **The green house is adjacent to the white house on the left. | |
48 | * | |
49 | * **In the green house they drink coffee. | |
50 | * | |
51 | * **The man who smokes Pall Malls has birds. | |
52 | * | |
53 | * **In the yellow house they smoke Dunhills. | |
54 | * | |
55 | * **In the middle house they drink milk. | |
56 | * | |
57 | * **The Norwegian lives in the first house. | |
58 | * | |
59 | * **The man who smokes Blends lives in a house next to the house with | |
60 | * cats. | |
61 | * | |
62 | * **In a house next to the house where they have a horse, they smoke | |
63 | * Dunhills. | |
64 | * | |
65 | * **The man who smokes Blue Masters drinks beer. | |
66 | * | |
67 | * **The German smokes Princes. | |
68 | * | |
69 | * **The Norwegian lives next to the blue house. | |
70 | * | |
71 | * **They drink water in a house next to the house where they smoke | |
72 | * Blends. | |
73 | * | |
74 | * Who owns the zebra? | |
75 | *) | |
76 | ||
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 | |
80 | ||
81 | datatype cigarette = Blend | BlueMaster | Dunhill | PallMall | Prince | |
82 | val cigaretteToString = | |
83 | fn Blend => "Blend" | |
84 | | BlueMaster => "BlueMaster" | |
85 | | Dunhill => "Dunhill" | |
86 | | PallMall => "PallMall" | |
87 | | Prince => "Prince" | |
88 | datatype color = Blue | Green | Red | White | Yellow | |
89 | val colorToString = | |
90 | fn Blue => "Blue" | |
91 | | Green => "Green" | |
92 | | Red => "Red" | |
93 | | White => "White" | |
94 | | Yellow => "Yellow" | |
95 | datatype drink = Beer | Coffee | Milk | Tea | Water | |
96 | val drinkToString = | |
97 | fn Beer => "Beer" | |
98 | | Coffee => "Coffee" | |
99 | | Milk => "Milk" | |
100 | | Tea => "Tea" | |
101 | | Water => "Water" | |
102 | datatype nationality = Dane | English | German | Norwegian | Swede | |
103 | val nationalityToString = | |
104 | fn Dane => "Dane" | |
105 | | English => "English" | |
106 | | German => "German" | |
107 | | Norwegian => "Norwegian" | |
108 | | Swede => "Swede" | |
109 | datatype pet = Bird | Cat | Dog | Horse | Zebra | |
110 | val petToString = | |
111 | fn Bird => "Bird" | |
112 | | Cat => "Cat" | |
113 | | Dog => "Dog" | |
114 | | Horse => "Horse" | |
115 | | Zebra => "Zebra" | |
116 | ||
117 | type pos = int | |
118 | val poss = [1, 2, 3, 4, 5] | |
119 | val first = SOME 1 | |
120 | val middle = SOME 3 | |
121 | ||
122 | type 'a attribute = {poss: pos list, | |
123 | unknown: 'a list, | |
124 | known: (pos * 'a) list} | |
125 | ||
126 | exception Done | |
127 | fun 'a fluidLet (r: 'a ref, x: 'a, f: unit -> 'b): 'b = | |
128 | let val old = !r | |
129 | in r := x | |
130 | ; (f () before r := old) | |
131 | handle Done => raise Done | |
132 | | e => (r := old; raise e) | |
133 | end | |
134 | ||
135 | fun search () = | |
136 | let | |
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] | |
144 | ||
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 | |
151 | val pet = find pets | |
152 | ||
153 | fun display () = | |
154 | let | |
155 | fun loop (r: 'a attribute ref, toString) = | |
156 | (List.app (fn i => | |
157 | let | |
158 | val x = #2 (valOf (peek (#known (!r), | |
159 | fn (j, _) => i = j))) | |
160 | val s = toString x | |
161 | in print s | |
162 | ; print (CharVector.tabulate (12 - size s, | |
163 | fn _ => #" ")) | |
164 | end) poss | |
165 | ; print "\n") | |
166 | in | |
167 | loop (cigarettes, cigaretteToString) | |
168 | ; loop (colors, colorToString) | |
169 | ; loop (drinks, drinkToString) | |
170 | ; loop (nationalities, nationalityToString) | |
171 | ; loop (pets, petToString) | |
172 | end | |
173 | ||
174 | fun make f = | |
175 | fn (SOME x, SOME y) => f (x, y) | |
176 | | _ => true | |
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) | |
180 | ||
181 | val num = ref 0 | |
182 | fun isConsistent (): bool = | |
183 | (num := !num + 1 | |
184 | ; | |
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) | |
200 | ) | |
201 | ||
202 | fun tryEach (l, f) = | |
203 | let | |
204 | fun loop (l, ac) = | |
205 | case l of | |
206 | [] => () | |
207 | | x :: l => (f (x, l @ ac); loop (l, x :: ac)) | |
208 | in loop (l, []) | |
209 | end | |
210 | ||
211 | fun try (r: 'a attribute ref, | |
212 | f: unit -> (('a attribute -> unit) | |
213 | * ( unit -> unit))) = | |
214 | let val {poss, unknown, known} = !r | |
215 | in case unknown of | |
216 | [] => () | |
217 | | _ => | |
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, | |
222 | unknown = unknown, | |
223 | poss = poss} | |
224 | in fluidLet | |
225 | (r, attr, fn () => | |
226 | if isConsistent () then each attr else ()) | |
227 | end) | |
228 | ; done () | |
229 | end) | |
230 | end | |
231 | ||
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 | |
235 | *) | |
236 | exception Inconsistent | |
237 | exception Continue of unit -> unit | |
238 | fun loop (): unit = | |
239 | let | |
240 | fun test r = | |
241 | try | |
242 | (r, fn () => | |
243 | let | |
244 | datatype 'a attrs = None | One of 'a | Many | |
245 | val attrs = ref None | |
246 | fun each a = | |
247 | case !attrs of | |
248 | None => attrs := One a | |
249 | | One _ => attrs := Many | |
250 | | Many => () | |
251 | fun done () = | |
252 | case !attrs of | |
253 | None => raise Inconsistent | |
254 | | One a => raise (Continue (fn () => fluidLet (r, a, loop))) | |
255 | | Many => () | |
256 | in (each, done) | |
257 | end) | |
258 | fun explore r = | |
259 | try (r, fn () => | |
260 | let | |
261 | fun each _ = loop () | |
262 | fun done () = raise Inconsistent | |
263 | in (each, done) | |
264 | end) | |
265 | in (test cigarettes | |
266 | ; test colors | |
267 | ; test drinks | |
268 | ; test nationalities | |
269 | ; test pets | |
270 | ; explore cigarettes | |
271 | ; explore colors | |
272 | ; explore drinks | |
273 | ; explore nationalities | |
274 | ; explore pets | |
275 | ; raise Done) | |
276 | handle Inconsistent => () | |
277 | | Continue f => f () | |
278 | end | |
279 | val _ = loop () handle Done => () | |
280 | val _ = if 3342 = !num | |
281 | then () | |
282 | else raise Fail "bug" | |
283 | (* val _ = display () *) | |
284 | in () | |
285 | end | |
286 | ||
287 | structure Main = | |
288 | struct | |
289 | fun doit n = | |
290 | let | |
291 | fun loop n = | |
292 | if n < 0 | |
293 | then () | |
294 | else (search () | |
295 | ; loop (n - 1)) | |
296 | in loop (n * 1000) | |
297 | end | |
298 | end |