Solve Einstein's puzzle

ZebraPuzzle.tq

type Nation = British | Swedish | Danish | Norwegian | German
type House = Red | Green | Blue | White | Yellow
type Drink = Milk | Coffee | Water | Beer | Tea
type Smoke = PallMall | Dunhill | Marlboro | Rothmans | Winfield
type Pet = Dog | Cat | Fish | Horse | Bird

let nations = {British; Swedish; Danish; Norwegian; German}
let houses = {Red; Green; Blue; White; Yellow}
let drinks = {Milk; Coffee; Water; Beer; Tea}
let smokes = {PallMall; Dunhill; Marlboro; Rothmans; Winfield}
let pets = {Dog; Cat; Fish; Horse; Bird}

let find xs x = Option.default 0 (Array.findIndex [y -> x=y] xs) + 1

let nextTo i j = abs(i-j)=1

let solution =
  Array.permutations nations
  @ Array.collect [nations ->
      if find nations Norwegian = 1 then
        Array.permutations houses
        @ Array.collect [houses ->
          if find nations British = find houses Red &&
            find houses Green = find houses White-1 &&
            nextTo (find nations Norwegian) (find houses Blue) then
            Array.permutations drinks
            @ Array.collect [drinks ->
              if find nations Danish = find drinks Tea &&
                find houses Green = find drinks Coffee &&
                3 = find drinks Milk then
                Array.permutations smokes
                @ Array.collect [smokes ->
                  if find houses Yellow = find smokes Dunhill &&
                     find smokes Winfield = find drinks Beer &&
                     find nations German = find smokes Rothmans &&
                     nextTo (find smokes Marlboro) (find drinks Water) then
                    Array.permutations pets
                    @ Array.collect [pets ->
                      if find nations Swedish = find pets Dog &&
                         find smokes PallMall = find pets Bird &&
                         nextTo (find pets Cat) (find smokes Marlboro) &&
                         nextTo (find pets Horse) (find smokes Dunhill) then
                        let n = find pets Fish - 1 in
                        let g xs = Array.get xs n in
                        {g nations, g houses, g drinks, g smokes, g pets}
                      else {}]
                  else {}]
              else {}]
          else {}]
      else {}]

let {nation, house, drink, smoke, pet} = solution

let () =
  { "The "; String.of nation; " person living in the "; String.of house;
    " house "; " drinks "; String.of drink; ", smokes "; String.of smoke;
    " and keeps a pet "; String.of pet; "." }
  @ String.concat
  @ Html.of
  @ Html.p
  @ yield