(* Copyright Stephen Weeks (sweeks@sweeks.com). 1999-6-21. * * This code solves the following "zebra" puzzle, and prints the solution. * There are 120^5 ~= 24 billion possibilities, so exhaustive search should * work fine, but I decided to write something that was a bit more clever. * It took me longer to write (2.5 hours) than to write exhaustive search, but * it runs fast (0.06 seconds on my 400MhZ P6). The code only needs to explore * 3342 posibilites to solve the puzzle. * * Here is the puzzle. * * This word problem has 25 variables and 24 are given values. You must * solve * the 25th. * * The trick is HOW? * * If you look at the problem mathematically, no sweat. If you get lost * in the * English, you are dead. * * You will know you are right by checking the answer with all the * conditions. * * Less than 1 percent of the population can solve this problem. * * The question is: Based on the following clues, who owns the zebra? * * **There are five houses. * * **Each house has its own unique color. * * **All house owners are of different nationalities. * * **They all have different pets. * * **They all drink different drinks. * * **They all smoke different cigarettes. * * **The Englishman lives in the red house. * * **The Swede has a dog. * * **The Dane drinks tea. * * **The green house is adjacent to the white house on the left. * * **In the green house they drink coffee. * * **The man who smokes Pall Malls has birds. * * **In the yellow house they smoke Dunhills. * * **In the middle house they drink milk. * * **The Norwegian lives in the first house. * * **The man who smokes Blends lives in a house next to the house with * cats. * * **In a house next to the house where they have a horse, they smoke * Dunhills. * * **The man who smokes Blue Masters drinks beer. * * **The German smokes Princes. * * **The Norwegian lives next to the blue house. * * **They drink water in a house next to the house where they smoke * Blends. * * Who owns the zebra? *) fun peek (l, p) = List.find p l fun map (l, f) = List.map f l fun fold (l, b, f) = List.foldl f b l datatype cigarette = Blend | BlueMaster | Dunhill | PallMall | Prince val cigaretteToString = fn Blend => "Blend" | BlueMaster => "BlueMaster" | Dunhill => "Dunhill" | PallMall => "PallMall" | Prince => "Prince" datatype color = Blue | Green | Red | White | Yellow val colorToString = fn Blue => "Blue" | Green => "Green" | Red => "Red" | White => "White" | Yellow => "Yellow" datatype drink = Beer | Coffee | Milk | Tea | Water val drinkToString = fn Beer => "Beer" | Coffee => "Coffee" | Milk => "Milk" | Tea => "Tea" | Water => "Water" datatype nationality = Dane | English | German | Norwegian | Swede val nationalityToString = fn Dane => "Dane" | English => "English" | German => "German" | Norwegian => "Norwegian" | Swede => "Swede" datatype pet = Bird | Cat | Dog | Horse | Zebra val petToString = fn Bird => "Bird" | Cat => "Cat" | Dog => "Dog" | Horse => "Horse" | Zebra => "Zebra" type pos = int val poss = [1, 2, 3, 4, 5] val first = SOME 1 val middle = SOME 3 type 'a attribute = {poss: pos list, unknown: 'a list, known: (pos * 'a) list} exception Done fun 'a fluidLet (r: 'a ref, x: 'a, f: unit -> 'b): 'b = let val old = !r in r := x ; (f () before r := old) handle Done => raise Done | e => (r := old; raise e) end fun search () = let fun init (unknown: 'a list): 'a attribute ref = ref {poss = poss, unknown = unknown, known = []} val cigarettes = init [Blend, BlueMaster, Dunhill, PallMall, Prince] val colors = init [Blue, Green, Red, White, Yellow] val drinks = init [Beer, Coffee, Milk, Tea, Water] val nationalities = init [Dane, English, German, Norwegian, Swede] val pets = init [Bird, Cat, Dog, Horse, Zebra] fun ''a find (r: ''a attribute ref) (x: ''a): pos option = Option.map #1 (peek (#known (!r), fn (_, y) => x = y)) val smoke = find cigarettes val color = find colors val drink = find drinks val nat = find nationalities val pet = find pets fun display () = let fun loop (r: 'a attribute ref, toString) = (List.app (fn i => let val x = #2 (valOf (peek (#known (!r), fn (j, _) => i = j))) val s = toString x in print s ; print (CharVector.tabulate (12 - size s, fn _ => #" ")) end) poss ; print "\n") in loop (cigarettes, cigaretteToString) ; loop (colors, colorToString) ; loop (drinks, drinkToString) ; loop (nationalities, nationalityToString) ; loop (pets, petToString) end fun make f = fn (SOME x, SOME y) => f (x, y) | _ => true val same = make (op =) val adjacent = make (fn (x, y) => x = y - 1 orelse y = x - 1) val left = make (fn (x, y) => x = y - 1) val num = ref 0 fun isConsistent (): bool = (num := !num + 1 ; same (nat English, color Red) andalso same (nat Swede, pet Dog) andalso same (nat Dane, drink Tea) andalso left (color Green, color White) andalso same (color Green, drink Coffee) andalso same (smoke PallMall, pet Bird) andalso same (color Yellow, smoke Dunhill) andalso same (middle, drink Milk) andalso same (nat Norwegian, first) andalso adjacent (smoke Blend, pet Cat) andalso adjacent (pet Horse, smoke Dunhill) andalso same (drink Beer, smoke BlueMaster) andalso same (nat German, smoke Prince) andalso adjacent (nat Norwegian, color Blue) andalso adjacent (drink Water, smoke Blend) ) fun tryEach (l, f) = let fun loop (l, ac) = case l of [] => () | x :: l => (f (x, l @ ac); loop (l, x :: ac)) in loop (l, []) end fun try (r: 'a attribute ref, f: unit -> (('a attribute -> unit) * ( unit -> unit))) = let val {poss, unknown, known} = !r in case unknown of [] => () | _ => tryEach (unknown, fn (x, unknown) => let val (each, done) = f () in tryEach (poss, fn (p, poss) => let val attr = {known = (p, x) :: known, unknown = unknown, poss = poss} in fluidLet (r, attr, fn () => if isConsistent () then each attr else ()) end) ; done () end) end (* loop takes the current state and either * - terminates in the same state if there is no consistent extension * - raises Done with the state set at the consistent extension *) exception Inconsistent exception Continue of unit -> unit fun loop (): unit = let fun test r = try (r, fn () => let datatype 'a attrs = None | One of 'a | Many val attrs = ref None fun each a = case !attrs of None => attrs := One a | One _ => attrs := Many | Many => () fun done () = case !attrs of None => raise Inconsistent | One a => raise (Continue (fn () => fluidLet (r, a, loop))) | Many => () in (each, done) end) fun explore r = try (r, fn () => let fun each _ = loop () fun done () = raise Inconsistent in (each, done) end) in (test cigarettes ; test colors ; test drinks ; test nationalities ; test pets ; explore cigarettes ; explore colors ; explore drinks ; explore nationalities ; explore pets ; raise Done) handle Inconsistent => () | Continue f => f () end val _ = loop () handle Done => () val _ = if 3342 = !num then () else raise Fail "bug" (* val _ = display () *) in () end structure Main = struct fun doit n = let fun loop n = if n < 0 then () else (search () ; loop (n - 1)) in loop (n * 1000) end end