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