F# Programming

幅優先探索

今回は幅優先探索の例題として、簡単なパズルを解いてみましょう。

●水差し問題

大きな容器に水が入っています。目盛の付いていない 8 リットルと 5 リットルの容器を使って、大きな容器から 4 リットルの水を汲み出してください。4 リットルの水は、どちらの容器に入れてもかまいません。水をはかる最短手順を求めてください。なお、水の総量に制限はありません。

●プログラムリスト

リスト : 水差し問題 (puzzle02.fsx")

# load "queue.fs"
open Queue

// 容器のサイズ
let max_a = 8
let max_b = 5

// 容器の操作関数
let move1 (_, b) = (0, b)
let move2 (_, b) = (max_a, b)
let move3 (a, b) =
  let d = max_b - b
  if a > d then (a - d, max_b)
  else (0, a + b)

let move4 (a, _) = (a, 0)
let move5 (a, _) = (a, max_b)
let move6 (a, b) =
  let d = max_a - a
  if b > d then (max_a, b - d)
  else (a + b, 0)

let water_jug goal =
  let rec iter qs =
    if is_empty qs then printfn "not found"
    else
      let move = top qs
      let (a, b) = List.head move
      if a = goal || b = goal then printfn "%A" (List.rev move)
      else
        List.fold (fun q m -> let st = m (a, b)
                              if List.contains st move then q
                              else enqueue (st::move) q)
                  (dequeue qs)
                  [move1; move2; move3; move4; move5; move6] |> iter
  create |> enqueue [(0 ,0)] |> iter

●実行例

> open Puzzle02;;
> water_jug 4;;
[(0, 0); (0, 5); (5, 0); (5, 5); (8, 2); (0, 2); (2, 0); (2, 5); (7, 0); (7, 5);
 (8, 4)]
val it: unit = ()

●5 パズル

次は、15 パズルで有名なスライドパズルを取り上げます。

       図 : 15 パズル

15 パズルは上図に示すように、1 から 15 までの駒を並べるパズルです。駒の動かし方は、1 回に 1 個の駒を空いている隣の場所に滑らせる、というものです。駒を跳び越したり持ち上げたりすることはできません。

15 パズルの場合、駒の配置は空き場所がどこでもいいことにすると、16! (約 2e13) 通りもあります。実際には、15 パズルの性質からその半分になるのですが、それでもパソコンで扱うにはあまりにも大きすぎる数です。そこで、盤面をぐっと小さくした、1 から 5 までの数字を並べる「5 パズル」を考えることにします。

  4 5 0    1 2 3
  1 2 3    4 5 0
  Start    Goal

  図 : 5 パズル

上図の Start から Goal までの最短手順を求めてください。

●プログラムリスト

リスト : 5 パズル (puzzle02.fsx)

// 隣接リスト
// 0 1 2
// 3 4 5
let adjacent = [|
  [1; 3]
  [0; 2; 4]
  [1; 5]
  [0; 4]
  [1; 3; 5]
  [2; 4]  |]

// 局面
// Cons (空き場所の位置, 手数, 盤面, 1 手前の局面)
type state = Nil | Cons of int * int * int array * state

// 同一局面のチェック
let rec isSameState board = function
  [] -> false
| Nil :: _ -> failwith "state is empty"
| Cons (_, _, b, _) :: xs -> if board = b then true else isSameState board xs

// 手順の表示
let rec printMove = function
  Nil -> ()
| Cons (_, n, board, prev) -> printMove prev; printfn "%d: %A" n board

// 5 パズルの解法
let fivePuzzle start goal =
  let rec iter (cs, qs) =
    if is_empty qs then printfn "not found"
    else
      match top qs with
        Nil -> failwith "state is empty"
      | Cons (s, n, b, _) as state ->
        if b = goal then printMove state
        else
          List.fold (fun (c, q) x ->
                      let nb = b.[0..5]
                      nb.[s] <- nb.[x]
                      nb.[x] <- 0
                      if isSameState nb c then (c, q)
                      else
                        let newst = Cons (x, n + 1, nb, state)
                        (newst::c, enqueue newst q))
                    (cs, (dequeue qs))
                    adjacent.[s] |> iter
  let s = Array.findIndex (fun x -> x = 0) start
  let st = Cons (s, 0, start, Nil)
  ([st], create |> enqueue st) |> iter

●実行結果

> open Puzzle02;;
> fivePuzzle [|4;5;0;1;2;3|] [|1;2;3;4;5;0|];;
0: [|4; 5; 0; 1; 2; 3|]
1: [|4; 0; 5; 1; 2; 3|]
2: [|0; 4; 5; 1; 2; 3|]
3: [|1; 4; 5; 0; 2; 3|]
4: [|1; 4; 5; 2; 0; 3|]
5: [|1; 0; 5; 2; 4; 3|]
6: [|1; 5; 0; 2; 4; 3|]
7: [|1; 5; 3; 2; 4; 0|]
8: [|1; 5; 3; 2; 0; 4|]
9: [|1; 5; 3; 0; 2; 4|]
10: [|0; 5; 3; 1; 2; 4|]
11: [|5; 0; 3; 1; 2; 4|]
12: [|5; 2; 3; 1; 0; 4|]
13: [|5; 2; 3; 1; 4; 0|]
14: [|5; 2; 0; 1; 4; 3|]
15: [|5; 0; 2; 1; 4; 3|]
16: [|0; 5; 2; 1; 4; 3|]
17: [|1; 5; 2; 0; 4; 3|]
18: [|1; 5; 2; 4; 0; 3|]
19: [|1; 0; 2; 4; 5; 3|]
20: [|1; 2; 0; 4; 5; 3|]
21: [|1; 2; 3; 4; 5; 0|]
val it: unit = ()

最短手数は 21 手になります。

●最長手数の局面

実は Start の局面が最長手数の局面です。最長手数の局面は、幅優先探索で簡単に求めることができます。

リスト : 最長手数の局面を求める (puzzle02.fsx)

// 最長手数を求める
let getMax cs =
  match List.head cs with
    Nil -> failwith "state is empty"
  | Cons (_, n, _, _) -> n

// 最長手数の局面を表示
let rec printMax m = function
  [] -> ()
| Nil::_ -> failwith "state is empty"
| Cons (_, n, board, _)::xs when m = n -> printfn "%d: %A" n board; printMax m xs
| _ -> ()

// 最長手数の局面を求める
let fivePuzzleMax () =
  let rec iter (cs, qs) =
    if is_empty qs then printMax (getMax cs) cs
    else
      match top qs with
        Nil -> failwith "state is empty"
      | Cons (s, n, b, _) as state ->
        List.fold (fun (c, q) x ->
                    let nb = b.[0..5]
                    nb.[s] <- nb.[x]
                    nb.[x] <- 0
                    if isSameState nb c then (c, q)
                    else
                      let newst = Cons (x, n + 1, nb, state)
                      (newst::c, enqueue newst q))
                  (cs, (dequeue qs))
                  adjacent.[s] |> iter
  let start = [|1;2;3;4;5;0|]
  let s = Array.findIndex (fun x -> x = 0) start
  let st = Cons (s, 0, start, Nil)
  ([st], create |> enqueue st) |> iter

> open Puzzle02;;
> fivePuzzleMax ();;
21: [|4; 5; 0; 1; 2; 3|]
val it: unit = ()

●嫉妬深い夫の問題

三組の夫婦が川を渡ることになりました。ボートには二人しか乗ることができません。どの夫も嫉妬深く、彼自身が一緒にいない限り、ボートでも岸でも妻が他の男といることを許しません。なお、六人ともボートをこぐことができます。この条件で、三組の夫婦が川を渡る最短手順を考えてください。

●プログラムリスト

リスト : 嫉妬深い夫の問題 (puzzle02.fsx)

type item = Bo | Ha | Wa | Hb | Wb | Hc | Wc

// 局面
type state2 = Nil2 | Cons2 of item list * item list * state2

// ボートに乗る組み合わせ
let riders = [
  [Bo; Ha]
  [Bo; Hb]
  [Bo; Hc]
  [Bo; Wa]
  [Bo; Wb]
  [Bo; Wc]
  [Bo; Ha; Hb]
  [Bo; Ha; Hc]
  [Bo; Hb; Hc]
  [Bo; Wa; Wb]
  [Bo; Wa; Wc]
  [Bo; Wb; Wc]
  [Bo; Ha; Wa]
  [Bo; Hb; Wb]
  [Bo; Hc; Wc] ]

// 安全確認
let isSafe xs =
  let checkMale xs = List.exists (fun x -> x = Ha || x = Hb || x = Hc) xs
  let rec iter = function
    [] -> true
  | Wa::_ when checkMale xs && not (List.contains Ha xs) -> false
  | Wb::_ when checkMale xs && not (List.contains Hb xs) -> false
  | Wc::_ when checkMale xs && not (List.contains Hc xs) -> false
  | _::ys -> iter ys
  iter xs

// 乗船
let rec boarding xs = function
  [] -> Some xs
| y::ys when List.contains y xs -> boarding (List.filter (fun x -> x <> y) xs) ys
| _ -> None

// 同一局面があるか
let isSameState2 xs ys =
  let sameState xs ys =
    if List.length xs <> List.length ys then false
    else List.forall (fun x -> List.contains x ys) xs
  List.exists (fun zs -> sameState xs zs) ys

// 移動
let moveBoat ls rs bs =
  if List.head ls = Bo then
    match boarding ls bs with
      None -> None
    | Some xs -> let ys = bs @ rs
                 if isSafe xs && isSafe ys then Some (xs, ys) else None
  else
    match boarding rs bs with
      None -> None
    | Some ys -> let xs = bs @ ls
                 if isSafe xs && isSafe ys then Some (xs, ys) else None

// 手順の表示
let rec printMove2 = function
  Nil2 -> ()
| Cons2(ls, rs, prev) -> printMove2 prev; printfn "%A %A" ls rs

// 解法 (左岸から右岸へ)
let husband () =
  let rec iter (cs, qs) =
    if is_empty qs then printfn "not found"
    else
      match top qs with
        Nil2 -> failwith "state is empty"
      | Cons2(ls, rs, _) as state ->
        if List.isEmpty ls then printMove2 state
        else
          List.fold (fun (c, q) bs ->
                      match moveBoat ls rs bs with
                        None -> (c, q)
                      | Some (xs, ys) when not (isSameState2 xs cs) ->
                        let newst = Cons2(xs, ys, state)
                        (xs::c, enqueue newst q)
                      | _ -> (c, q))
                    (cs, dequeue qs)
                    riders |> iter
  let ls = [Bo; Ha; Wa; Hb; Wb; Hc; Wc]
  ([ls], create |> enqueue (Cons2(ls, [], Nil2))) |> iter

●実行結果

> husband();;
[Bo; Ha; Wa; Hb; Wb; Hc; Wc] []
[Ha; Hb; Hc; Wc] [Bo; Wa; Wb]
[Bo; Wa; Ha; Hb; Hc; Wc] [Wb]
[Ha; Hb; Hc] [Bo; Wa; Wc; Wb]
[Bo; Wa; Ha; Hb; Hc] [Wc; Wb]
[Wa; Ha] [Bo; Hb; Hc; Wc; Wb]
[Bo; Hb; Wb; Wa; Ha] [Hc; Wc]
[Wb; Wa] [Bo; Ha; Hb; Hc; Wc]
[Bo; Wc; Wb; Wa] [Ha; Hb; Hc]
[Wc] [Bo; Wa; Wb; Ha; Hb; Hc]
[Bo; Hc; Wc] [Wa; Wb; Ha; Hb]
[] [Bo; Hc; Wc; Wa; Wb; Ha; Hb]
val it: unit = ()

反復深化

今回は反復深化の例題として、簡単なパズルを解いてみましょう。反復深化は最短手数を求めることができるアルゴリズムです。幅優先探索と違って局面を保存する必要が無いため、必要となるメモリは深さ優先探索と同程度で済みます。また、プログラムも深さ優先探索と同じくらい簡単に作成することができます。

ただし、同じ探索を何度も繰り返すため実行時間が増大する、という欠点があります。ようするに、使用するメモリは少ないが実行時間が長くなるアルゴリズムなのです。実行時間が長くなるといっても、枝刈りを工夫することでパズルを高速に解くことができます。メモリ不足になる場合には、積極的に使ってみたいアルゴリズムといえるでしょう。

●ペグ・ソリティア

ペグ・ソリテアは、盤上に配置されたペグ (駒) を最後には一つ残るように取り除いていく、古典的なパズルです。ルールの説明は拙作のページ Puzzle DE Programming ペグ・ソリティア をお読みください。Hoppers は芦ヶ原伸之氏が考案されたペグ・ソリテアです。次の図を見てください。

     図 : Hoppers

Hoppers は穴を 13 個に減らしていて、遊ぶのに手頃な大きさになっています。上図に示したように、最初に中央のペグを取り除きます。この状態から始めて、最後のペグが中央の位置に残る跳び方の最小手数を求めてください。

●プログラムの作成

今回はペグの有無を bool (true, false) で表します。盤面の型は bool array になります。盤面と配列の対応は下図を見てください。

            図 : Hoppers の盤面

ペグの移動は跳び先表 (配列 jump_table) を用意すると簡単です。配列の要素はリストであることに注意してください。リストの要素は、跳び越されるペグの位置と跳び先の位置を格納したタプルです。たとえば、0 番の位置にあるペグは、1 番を跳び越して 2 番へ移動する場合と、3 番を跳び越して 6 番へ移動する場合と、5 番を飛び越して 10 番へ移動する場合の 3 通りがあります。これをリスト [(1, 2); (3, 6); (5, 10)] で表しています。

あとは単純な反復深化で最短手順を求めるだけです。詳細はプログラムリストをお読みくださいませ。

●プログラムリスト

リスト : Hoppers の解法 (puzzle03.fsx)

// 跳び先表
let jump_table = [|
  [(1, 2); (3, 6); (5, 10)]
  [(3, 5); (6, 11); (4, 7)]
  [(1, 0); (4, 6); (7, 12)]
  [(6, 9)]
  [(6, 8)]
  [(3, 1); (6, 7); (8, 11)]
  [(3, 0); (4, 2); (8, 10); (9, 12)]
  [(4, 1); (6, 5); (9, 11)]
  [(6, 4)]
  [(6, 3)]
  [(5, 0); (8, 6); (11, 12)]
  [(8, 5); (6, 1); (9, 7)]
  [(11, 10); (9, 6); (7, 2)] |]

let size = 13      // 盤面の大きさ
let max_jump = 11  // ペグがジャンプする回数
let hole = 6       // 中央の穴の位置

// 手順の表示
// 連続跳びは [i,j,k,...] で表す
let print_move move =
  let rec iter prev = function
    [] -> printfn "]"
  | (from, to_)::xs -> if prev = from then printf ",%d" to_
                       else printf "][%d,%d" from to_;
                       iter to_ xs

  match move with
    [] -> ()
  | (from, to_)::xs -> printf "[%d,%d" from to_; iter to_ xs

// 反復深化
let hoppers () =
  let mutable count = 0
  let board = Array.create size true
  let rec dfs jc limit move =
    if jc <= limit then
      if List.length move = max_jump then
        if board.[hole] then (
           count <- count + 1
           print_move (List.rev move)
        ) else ()
      else
        for from = 0 to size - 1 do
          if not board.[from] then ()
          else
            List.iter
              (fun (del, to_) ->
                if board.[del] && not board.[to_] then (
                  board.[from] <- false
                  board.[del]  <- false
                  board.[to_]  <- true
                  dfs
                    (if snd (List.head move) = from then jc else jc + 1)
                    limit
                    ((from, to_)::move)
                  board.[to_]  <- false
                  board.[del]  <- true
                  board.[from] <- true
                ) else ())
              jump_table.[from]

  // 初手を 0 -> (3) -> 6: hole に限定
  board.[0] <- false
  board.[3] <- false
  board.[hole] <- true
  let mutable i = 2
  while i <= max_jump && count = 0 do
    printfn "----- %d -----" i
    dfs 1 i [(0, hole)]
    i <- i + 1

●実行結果

> open Puzzle03;;
> hoppers ();;
----- 2 -----
----- 3 -----
----- 4 -----
----- 5 -----
----- 6 -----
----- 7 -----
[0,6][9,3][2,0,6][11,1][10,0,2,6][8,4][12,2,6]
[0,6][9,3][2,0,6][11,1][10,6][4,8][12,2,0,10,6]
[0,6][9,3][2,0,6][11,1][12,2,6][8,4][10,0,2,6]
[0,6][9,3][2,6][8,4][10,0,2,6][7,5][12,10,0,6]
[0,6][9,3][2,6][8,4][10,0,2,6][11,1][12,2,0,6]
[0,6][9,3][2,6][8,4][10,0,6][7,5][12,10,0,2,6]
[0,6][9,3][2,6][8,4][12,2,0,6][5,7][10,12,2,6]
[0,6][9,3][2,6][8,4][12,2,0,6][11,1][10,0,2,6]
[0,6][9,3][2,6][8,4][12,2,6][5,7][10,12,2,0,6]
[0,6][9,3][10,0,6][7,5][2,0,10,6][4,8][12,10,6]
[0,6][9,3][10,0,6][7,5][2,6][8,4][12,10,0,2,6]
[0,6][9,3][10,0,6][7,5][12,10,6][4,8][2,0,10,6]
[0,6][9,3][10,6][4,8][2,0,6][11,1][12,2,0,10,6]
[0,6][9,3][10,6][4,8][2,0,10,6][7,5][12,10,0,6]
[0,6][9,3][10,6][4,8][2,0,10,6][11,1][12,2,0,6]
[0,6][9,3][10,6][4,8][12,10,0,6][1,11][2,12,10,6]
[0,6][9,3][10,6][4,8][12,10,0,6][7,5][2,0,10,6]
[0,6][9,3][10,6][4,8][12,10,6][1,11][2,12,10,0,6]
val it: unit = ()

7 手で解くことができました。解は全部で 18 通りになりました。最近のパソコンは高性能なので、穴の数が少ない盤面であれば、単純な反復深化でも高速に解くことができるようです。

●５パズル

次は 5 パズルを反復深化で解いてみましょう。

●プログラムの作成

幅優先探索では全ての局面を保存しましたが、反復深化ではその必要はありません。盤面は配列 board で表します。駒の移動は board を書き換えて、バックトラックする時は元に戻すことにします。動かした駒はリスト move に格納します。動かした駒がわかれば局面を再現できるので、それで移動手順を表すことにします。

リスト : 5 パズル (puzzle03.fsx)

// 隣接行列
// 0 1 2
// 3 4 5
let adjacent = [|
  [1; 3]
  [0; 2; 4]
  [1; 5]
  [0; 4]
  [1; 3; 5]
  [2; 4]  |]

let fivePuzzle (board: int array) goal =
  let mutable count = 0
  let rec dfs n limit space move =
    if n = limit then
      if board = goal then (
        count <- count + 1
        printfn "%A" (List.tail (List.rev move))
      ) else ()
    else
      List.iter
        (fun x ->
          let p = board.[x]
          if p <> List.head move then (
            // 駒を動かす
            board.[space] <- p;
            board.[x] <- 0;
            // 再帰呼び出し
            dfs (n+1) limit x (p::move);
            // 元に戻す
            board.[space] <- 0;
            board.[x] <- p
          ) else ())
        adjacent.[space]
  // 上限値を増やす
  let mutable i = 1
  while (i <= 21 && count = 0) do
    printfn "----- %d -----" i
    dfs 0 i (Array.findIndex (fun x -> x = 0) board) [-1];
    i <- i + 1

探索処理は局所関数 dfs で行います。dfs の引数 n が手数、limit が反復深化の上限値、space が空き場所の位置、move が移動手順を表します。n が limit に達したら、パズルが解けたかチェックします。関数 fivePuzzle の引数 goal が完成形を表す配列です。完成形に到達したら、変数 count の値を +1 してから関数 printfn で手順を表示します。上限値に達していない場合は、駒を移動して新しい局面を作ります。

5 パズルのように、元の局面に戻すことが可能 (可逆的) なパズルの場合、単純な深さ優先探索では同じ移動手順を何度も繰り返すことがあります。そうなると、とんでもない解を出力するだけではなく、再帰呼び出しが深くなるとスタックがオーバーフローしてプログラムの実行が停止してしまいます。

このような場合、局面の履歴を保存しておいて同じ局面がないかチェックすることで、解を求めることができるようになります。ただし、同一局面をチェックする分だけ時間が余分にかかりますし、最初に見つかる解が最短手数とは限りません。

反復深化では深さが制限されているため、同一局面のチェックを行わなくてもスタックオーバーフローが発生することはありません。そのかわり、無駄な探索はどうしても避けることができません。5 パズルの場合、1 手前に動かした駒を再度動かすと 2 手前の局面に戻ってしまいます。完全ではありませんが、このチェックを入れるだけでもかなりの無駄を省くことができます。

プログラムでは、リスト move に移動した駒を格納しているので、1 手前と同じ駒は動かさないようにチェックしています。なお、move の初期値はダミーデータを入れて [-1] としています。

最後に、関数 dfs を呼び出します。変数 i が上限値を表します。i を 1 手ずつ増やして関数 dfs を呼び出します。変数 count が 0 より大きい場合、解が見つかったので while ループを終了します。プログラムはこれで完成です。

●実行結果

> open Puzzle03;;
> fivePuzzle [|4;5;0;1;2;3|] [|1;2;3;4;5;0|];;
----- 1 -----
----- 2 -----
----- 3 -----
----- 4 -----
----- 5 -----
----- 6 -----
----- 7 -----
----- 8 -----
----- 9 -----
----- 10 -----
----- 11 -----
----- 12 -----
----- 13 -----
----- 14 -----
----- 15 -----
----- 16 -----
----- 17 -----
----- 18 -----
----- 19 -----
----- 20 -----
----- 21 -----
[5; 4; 1; 2; 4; 5; 3; 4; 2; 1; 5; 2; 4; 3; 2; 5; 1; 4; 5; 2; 3]
[5; 2; 1; 4; 2; 5; 3; 1; 5; 2; 4; 5; 1; 3; 2; 1; 5; 4; 1; 2; 3]
[3; 2; 5; 4; 1; 5; 2; 3; 4; 2; 5; 1; 2; 4; 3; 5; 4; 2; 1; 4; 5]
[3; 2; 1; 4; 5; 1; 2; 3; 1; 5; 4; 2; 5; 1; 3; 5; 2; 4; 1; 2; 5]
val it: unit = ()

当然ですが最短手数は 21 手で 4 通りの手順が表示されました。

●フリップ・イット

次はパズル「フリップ・イット (Flip It)」の解法プログラムを F# で作ってみましょう。フリップ・イットは芦ヶ原伸之氏が考案されたパズルで、すべての駒を裏返しにするのが目的です。今回はリバーシの駒を使うことにしましょう。次の図を見てください。

フリップ・イットのルールは簡単です。ある駒は他の駒を跳び越して空き場所へ移動することができます。空き場所の隣にある駒は、跳び越す駒がないので移動できません。このとき、跳び越された駒は裏返しにされますが、跳んだ駒はそのままです。

図では 5 の位置にある駒が 0 へ跳び、それから 2 の駒が 5 へ跳んだ場合を示しています。このあと 0 -> 2, 5 -> 0 と跳ぶと、すべての駒を白にすることができます。それでは問題です。

参考文献 [1] の問題は 4 つの駒を使っているので、ここでは駒の個数を増やしてみました。すべての駒を白にする最短手順を求めてください。

●プログラムの作成

それではプログラムを作りましょう。アルゴリズムは単純な反復深化を使います。盤面は配列で表しましょう。駒は type で定義します。

リスト : 駒の定義

type piece = S | B | W

S が空き場所、B が黒石、W が白石を表します。盤面の型は piece array になります。

次は、駒を動かして新しい盤面を生成する関数 movePiece を作ります。

リスト : 駒の移動

let movePiece (b: piece array) s e =
  let newb = b.[0..(Array.length b - 1)]
  for i = (min s e) + 1 to (max s e) - 1 do
    newb.[i] <- if newb.[i] = B then W else B
  let p = newb.[s]
  newb.[s] <- newb.[e]
  newb.[e] <- p
  newb

引数 b が盤面、s と e が移動する駒の位置と空き場所の位置です。最初に盤面 b をコピーして変数 newb にセットします。次の for ループで s と e に挟まれた駒を反転します。最後に、s と e の駒を交換して newb を返します。

次は、反復深化で最短手順を探索する関数 flipIt を作ります。

リスト : 反復深化による探索

let flipIt board =
  let mutable count = 0
  let rec dfs n limit board space history =
    if n = limit then
      if Array.contains B board then ()
      else (
        count <- count + 1
        printfn "%A" (List.rev history)
      )
    else
      for i = 0 to Array.length board - 1 do
        if i < space - 1 || i > space + 1 then
          let newb = movePiece board i space
          if List.contains newb history then ()
          else dfs (n + 1) limit newb i (newb::history)

  let mutable i = 1
  while (i < 16 && count = 0) do
    printfn "----- %d -----" i
    dfs 0 i board (Array.findIndex (fun x -> x = S) board) [board]
    i <- i + 1

実際の処理は局所関数 dfs で行います。引数 n が手数、limit が反復深化の上限値、board が盤面、space が空き場所の位置、history が移動手順を表すリストです。history には盤面をそのまま格納することにします。

手数 n が上限値 limit になったならば、駒がすべて白になったかチェックします。関数 Array.contains で B を探索します。見つからなければ黒の駒はありません。printfn で手順を表示します。そうでなければ、駒を動かして新しい盤面を生成します。for ループで board の先頭から順番に駒を動かすことができるかチェックします。

フリップ・イットのルールでは、空き場所の隣の駒は動かすことができません。この条件を i < space - 1 || i > space + 1 でチェックしています。そして、List.contains で history に同一局面がないっことを確認して dfs を再帰呼び出しします。あとは上限値を一つずつ増やしながら dfs を呼び出すだけです。

●実行結果

それでは実際に試してみましょう。

> open Puzzle03;;
> flipIt [|B;B;S;B;B;B|];;
----- 1 -----
----- 2 -----
----- 3 -----
----- 4 -----
----- 5 -----
----- 6 -----
----- 7 -----
----- 8 -----
[[|B; B; S; B; B; B|]; [|S; W; B; B; B; B|]; [|B; B; W; S; B; B|];
 [|B; B; W; B; W; S|]; [|B; B; S; W; B; W|]; [|S; W; B; W; B; W|];
 [|W; B; W; S; B; W|]; [|W; S; B; B; B; W|]; [|W; W; W; W; W; S|]]

・・・省略・・・

> flipIt [|B;S;W;B;B;B;B|];;
----- 1 -----
----- 2 -----
----- 3 -----
----- 4 -----
----- 5 -----
----- 6 -----
----- 7 -----
----- 8 -----
[[|B; S; W; B; B; B; B|]; [|B; B; B; S; B; B; B|]; [|S; W; W; B; B; B; B|];
 [|W; B; S; B; B; B; B|]; [|W; B; B; W; S; B; B|]; [|W; B; B; W; B; W; S|];
 [|W; B; B; S; W; B; W|]; [|W; B; B; B; B; S; W|]; [|S; W; W; W; W; W; W|]]

・・・省略・・・

> flipIt [|B;S;W;W;W;B;B;B|];;
----- 1 -----
----- 2 -----
----- 3 -----
----- 4 -----
----- 5 -----
----- 6 -----
----- 7 -----
----- 8 -----
[[|B; S; W; W; W; B; B; B|]; [|B; W; B; S; W; B; B; B|];
 [|S; B; W; B; W; B; B; B|]; [|W; W; S; B; W; B; B; B|];
 [|W; W; W; W; S; B; B; B|]; [|W; W; W; W; B; W; W; S|];
 [|S; B; B; B; W; B; B; W|]; [|W; W; W; W; S; B; B; W|];
 [|W; W; W; W; W; W; W; S|]]

・・・省略・・・

最短手順の一例を図で示すと次のようになります。図では空き場所を ＿ で表しています。

(A), (B), (C) ともに最短手数は 8 手になりました。実は、これが最長手数の局面となります。ちなみに、駒の個数が 4 つの場合だと、最長手数は 10 手と長くなります。また、最後の白石の位置を限定すると、手数が長くなる場合もあります。たとえば、(A) の問題でゴールを "＿ ○ ○ ○ ○ ○" とすると、最短手数は 9 手になります。興味のある方は、いろいろと試してみてください。