benchmark/tests/zebra.sml

   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