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