8queen.ml

type 'a m = 'a list
let (>>=) x f = List.concat (List.map f x)
let return x = [x]
let guard b = if b then return () else []

let numbers = [1; 2; 3; 4; 5; 6; 7; 8]

let rec remove l n = 
  match l with
  | []           -> []
  | x :: xs      -> if x = n then xs else x :: (remove xs n)

(* 対角線上に2駒が無いかどうかの判定 *)
let not_diagonal (p, q) (r, s) =
  if ((p - r) = (q - s)) || ((p - r) = (s - q)) then
    false
  else
    true

let rec not_diagonal_all l (r, s) =
  match l with
    | []             -> true
    | (p, q) :: rest ->
      if not_diagonal (p, q) (r, s) then
        not_diagonal_all rest (r,s)
      else
        false

let find =
  numbers  >>= (fun a ->
  let numbers2 = remove numbers a in
  numbers2 >>= (fun b ->
  (guard (not_diagonal_all [(1, a)] (2, b))) >>= (fun _ ->
  let numbers3 = remove numbers2 b in
  numbers3 >>= (fun c->
  (guard (not_diagonal_all [(1, a); (2, b)] (3, c))) >>= (fun _ ->
  let numbers4 = remove numbers3 c in
  numbers4 >>= (fun d ->
  (guard (not_diagonal_all [(1, a); (2, b); (3, c)] (4, d))) >>= (fun _ ->
  let numbers5 = remove numbers4 d in
  numbers5 >>= (fun e ->
  (guard (not_diagonal_all [(1, a); (2, b); (3, c); (4, d)] (5, e))) >>= (fun _ ->
  let numbers6 = remove numbers5 e in
  numbers6 >>= (fun f ->
  (guard (not_diagonal_all [(1, a); (2, b); (3, c); (4, d); (5, e)] (6, f))) >>= (fun _ ->
  let numbers7 = remove numbers6 f in
  numbers7 >>= (fun g ->
  (guard (not_diagonal_all [(1, a); (2, b); (3, c); (4, d); (5, e); (6, f)] (7, g))) >>= (fun _ ->
  let numbers8 = remove numbers7 g in
  numbers8 >>= (fun h ->
  (guard (not_diagonal_all [(1, a); (2, b); (3, c); (4, d); (5, e); (6, f); (7, g)] (8, h))) >>= (fun _ ->
    return ((1, a), (2, b), (3, c), (4, d), (5, e), (6, f), (7, g), (8, h)))))))))))))))))