OCaml で8クイーンを解く

電車の中で

作者: Bruce A. Tate,まつもとゆきひろ,田和勝
出版社/メーカー: オーム社
発売日: 2011/07/23
メディア: 単行本（ソフトカバー）
購入: 9人クリック: 230回
この商品を含むブログ (65件) を見る

を読んでいて, Prolog で数独や8クイーンを解いているのを見て, そういえば8クイーンという問題があったなというのを思い出して, そういえば OCaml で書けるなというのに気づいてさっき確認した

Nクイーン問題というのは, N * N の大きさのチェス盤に N 個のクイーンを, どの2つも互いに相手を取られないような位置に置く, という問題で, 昔 id:sifi_border に教えてもらいました. N = 8 のときは解が92通りある

こういうパズルっぽい問題でブルートフォースしたいときは, リストモナドを使って非決定性計算を表現するとカッコよく求めることができます. カッコいいだけであって, アルゴリズムが優れているわけでは全然ない...

では書きます
まず縦横に同じ列に駒があったらアウトなので, (1, a), (2, b) ... (8, h) に駒がある（a, ..., h は1から8をちょうど1回ずつ使う）としてよい
この 8! 通りを全部試します

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 []

リストモナドと guard. guard は制約を設定するために使う

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)

候補の数のリストと, 候補を減らすための関数

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

対角線上に 2 つの駒が無い場合 true を返すような関数

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)))))))))))))))))

これで計算おしまい. このfindというのが答えが格納されたリストになっています
以上を 8queen.ml として, インタプリタを起動

# #use "8queen.ml";;
type 'a m = 'a list
val ( >>= ) : 'a list -> ('a -> 'b list) -> 'b list = <fun>
val return : 'a -> 'a list = <fun>
val guard : bool -> unit list = <fun>
val numbers : int list = [1; 2; 3; 4; 5; 6; 7; 8]
val remove : 'a list -> 'a -> 'a list = <fun>
val not_diagonal : int * int -> int * int -> bool = <fun>
val not_diagonal_all : (int * int) list -> int * int -> bool = <fun>
val find :
  ((int * int) * (int * int) * (int * int) * (int * int) * (int * int) *
   (int * int) * (int * int) * (int * int))
  list =
  [((1, 1), (2, 5), (3, 8), (4, 6), (5, 3), (6, 7), (7, 2), (8, 4));
   ((1, 1), (2, 6), (3, 8), (4, 3), (5, 7), (6, 4), (7, 2), (8, 5));
   ((1, 1), (2, 7), (3, 4), (4, 6), (5, 8), (6, 2), (7, 5), (8, 3));
   ((1, 1), (2, 7), (3, 5), (4, 8), (5, 2), (6, 4), (7, 6), (8, 3));
   ((1, 2), (2, 4), (3, 6), (4, 8), (5, 3), (6, 1), (7, 7), (8, 5));
   ((1, 2), (2, 5), (3, 7), (4, 1), (5, 3), (6, 8), (7, 6), (8, 4));
   ((1, 2), (2, 5), (3, 7), (4, 4), (5, 1), (6, 8), (7, 6), (8, 3));
   ((1, 2), (2, 6), (3, 1), (4, 7), (5, 4), (6, 8), (7, 3), (8, 5));
   ((1, 2), (2, 6), (3, 8), (4, 3), (5, 1), (6, 4), (7, 7), (8, 5));
   ((1, 2), (2, 7), (3, 3), (4, 6), (5, 8), (6, 5), (7, 1), (8, 4));
   ((1, 2), (2, 7), (3, 5), (4, 8), (5, 1), (6, 4), (7, 6), (8, 3));
   ((1, 2), (2, 8), (3, 6), (4, 1), (5, 3), (6, 5), (7, 7), (8, ...)); ...]
# List.length find;;
- : int = 92

念のため N = 10 でチェック. Wikipedia によると 724 通りあります

10queen.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; 9; 10]

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 _ ->
  let numbers9 = remove numbers8 h in
  numbers9 >>= (fun i ->
  (guard (not_diagonal_all [(1, a); (2, b); (3, c); (4, d); (5, e); (6, f); (7, g); (8, h)] (9, i))) >>= (fun _ ->
  let numbers10 = remove numbers9 i in
  numbers10 >>= (fun j ->
  (guard (not_diagonal_all [(1, a); (2, b); (3, c); (4, d); (5, e); (6, f); (7, g); (8, h); (9, i)] (10, j))) >>= (fun _ ->
    return ((1, a), (2, b), (3, c), (4, d), (5, e), (6, f), (7, g), (8, h), (9, i), (10, j)))))))))))))))))))))

# #use "10queen.ml";;
type 'a m = 'a list
val ( >>= ) : 'a list -> ('a -> 'b list) -> 'b list = <fun>
val return : 'a -> 'a list = <fun>
val guard : bool -> unit list = <fun>
val numbers : int list = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]
val remove : 'a list -> 'a -> 'a list = <fun>
val not_diagonal : int * int -> int * int -> bool = <fun>
val not_diagonal_all : (int * int) list -> int * int -> bool = <fun>
val find :
  ((int * int) * (int * int) * (int * int) * (int * int) * (int * int) *
   (int * int) * (int * int) * (int * int) * (int * int) * (int * int))
  list =
  [((1, 1), (2, 3), (3, 6), (4, 8), (5, 10), (6, 5), (7, 9), (8, 2), 
    (9, 4), (10, 7));
   ((1, 1), (2, 3), (3, 6), (4, 9), (5, 7), (6, 10), (7, 4), (8, 2), 
    (9, 5), (10, 8));
   ((1, 1), (2, 3), (3, 6), (4, 9), (5, 7), (6, 10), (7, 4), (8, 2), 
    (9, 8), (10, 5));
   ((1, 1), (2, 3), (3, 9), (4, 7), (5, 10), (6, 4), (7, 2), (8, 5), 
    (9, 8), (10, 6));
   ((1, 1), (2, 4), (3, 6), (4, 9), (5, 3), (6, 10), (7, 8), (8, 2), 
    (9, 5), (10, 7));
   ((1, 1), (2, 4), (3, 7), (4, 10), (5, 2), (6, 9), (7, 5), (8, 3), 
    (9, 8), (10, 6));
   ((1, 1), (2, 4), (3, 7), (4, 10), (5, 3), (6, 9), (7, 2), (8, 5), 
    (9, 8), (10, 6));
   ((1, 1), (2, 4), (3, 7), (4, 10), (5, 6), (6, 9), (7, 2), (8, 5), 
    (9, 3), (10, 8));
   ((1, 1), (2, 4), (3, 7), (4, 10), (5, 8), (6, 2), (7, 5), (8, 3), 
    (9, 6), (10, 9));
   ((1, 1), (2, 4), (3, 7), (4, 10), (5, 8), (6, 3), (...), ...); ...]
# List.length find;;
- : int = 724

trifle

技術メモ（最近は hellorusk.net/blog の方が使うことが多いです）

OCaml で8クイーンを解く