M.Hiroi's Home Page

Functional Programming

お気楽 Haskell プログラミング入門

[ PrevPage | Haskell | NextPage ]

パズルの解法 (2)

●小町算

パズルの世界では、1 から 9 までの数字を 1 個ずつすべて使った数字を「小町数」といいます。たとえば、123456789 とか 321654987 のような数字です。「小町算」というものもあり、たとえば 123 + 456 + 789 とか 321 * 654 + 987 のようなものです。

[問題] 小町算

1 から 9 までの数字を順番に並べ、間に + と - を補って三桁の値 (100 - 999) になる式を作ることにします。なお、1 の前に - 符号は付けないものとします。100 になる式の一例を示します。

例:1 + 2 + 3 - 4 + 5 + 6 + 78 + 9 = 100

100 になる式は全部で 11 通りあります。それでは問題です。

  1. 式の総数が最大になる値をすべて求めてください。
  2. 解のない値で最小のものを求めてください。
  3. 解のある値で最大のものを求めてください。

Haskell で解法プログラムを作ってください。

●プログラムの作成

今回のパズルは、演算子が + と - しかないので、数字の間に演算子を挿入して式を計算する処理は簡単にプログラムできます。ちょっと面倒なのが数字を連結する処理です。そこで、数字を連結する処理、数字の間に演算子を挿入する処理、式を計算する処理に分けてプログラムを作っていくことにします。

●数字の連結

最初に数字を連結する処理を作ります。次のリストを見てください。

リスト : 数字の連結

concat_number :: [Int] -> [[Int]]
concat_number [] = [[]]
concat_number [x] = [[x]]
concat_number (x:y:zs) =
  map (x:) (concat_number (y:zs)) ++ concat_number ((x * 10 + y):zs)

関数 concat_number は数字を格納したリストを受け取り、隣り合う数字を連結してできるパターンをすべて求めてリストに格納して返します。引数が空リストの場合は [[ ]] を返します。引数が [x] の場合は [[x]] を返します。これが再帰呼び出しの停止条件になります。

要素が 2 つ以上ある場合はリストを x : y : zs に分解して、x と y を連結しないパターンと、x と y を連結するパターンに分けて処理します。x と y を連結しない場合は x をそのまま使うことになります。リスト y : zs に concat_number を適用して、数字を連結したリストを求め、その先頭に x を追加します。この処理は map を使うと簡単ですね。x と y を連結する場合は、x * 10 + y を zs の先頭に追加し、そのリストに concat_number を適用します。あとは 2 つのリストを演算子 ++ で連結するだけです。

簡単な実行例を示します。

*Main> concat_number [1,2]
[[1,2],[12]]
*Main> concat_number [1,2,3]
[[1,2,3],[1,23],[12,3],[123]]
*Main> concat_number [1,2,3,4]
[[1,2,3,4],[1,2,34],[1,23,4],[1,234],[12,3,4],[12,34],[123,4],[1234]]
*Main> concat_number [1,2,3,4,5]
[[1,2,3,4,5],[1,2,3,45],[1,2,34,5],[1,2,345],[1,23,4,5],[1,23,45],[1,234,5],
[1,2345],[12,3,4,5],[12,3,45],[12,34,5],[12,345],[123,4,5],[123,45],[1234,5],
[12345]]

●演算子の挿入

次は演算子 +, - を挿入して式を生成する処理を作ります。次のリストを見てください。

リスト : 式の生成

-- 式の定義
data Expr = Val Int | Add | Sub deriving (Eq, Show)

-- 式の生成
make_expr :: [Int] -> [[Expr]]
make_expr [x] = [[Val x]]
make_expr (x:xs) = map (\zs -> (Val x):Add:zs) ys1 
                ++ map (\zs -> (Val x):Sub:zs) ys1
  where ys1 = make_expr xs

Expr で数値と演算子を定義します。Val が数値、Add が + で Sub が - です。関数 make_expr は数字を格納したリストを受け取り、数字の間に演算子を挿入するパターンをすべて求めてリストに格納して返します。

プログラムは簡単です。引数が [x] であれば、[[Val x]] を返します。そうでなければ、引数を x : xs で分解して、xs に make_expr を適用して数式を生成します。そして、その数式の先頭に map で (Val x):Add と (Val x):Sub を追加します。この処理は map を使うと簡単ですね。あとは 2 つのリストを連結するだけです。

それでは簡単な実行例を示します。

*Main> concatMap make_expr $ concat_number [1,2]
[[Val 1,Add,Val 2],[Val 1,Sub,Val 2],[Val 12]]
*Main> concatMap make_expr $ concat_number [1,2,3]
[[Val 1,Add,Val 2,Add,Val 3],
 [Val 1,Add,Val 2,Sub,Val 3],
 [Val 1,Sub,Val 2,Add,Val 3],
 [Val 1,Sub,Val 2,Sub,Val 3],
 [Val 1,Add,Val 23],
 [Val 1,Sub,Val 23],
 [Val 12,Add,Val 3],
 [Val 12,Sub,Val 3],
 [Val 123]]

●式の計算

次は式を計算する処理を作ります。

リスト : 式の計算

calc_expr :: [Expr] -> Int
calc_expr ((Val x):xs) = iter xs x where
  iter [] a = a
  iter (Add:(Val x):xs) a = iter xs (a + x)
  iter (Sub:(Val x):xs) a = iter xs (a - x)

関数 calc_expr はリストの先頭 (左側) から順番に計算していくだけです。とくに難しいところはないと思います。

簡単な実行例を示します。

*Main> map calc_expr $ concatMap make_expr $ concat_number [1,2]
[3,-1,12]
*Main> map calc_expr $ concatMap make_expr $ concat_number [1,2,3]
[6,0,2,-4,24,-22,15,9,123]
*Main> map calc_expr $ concatMap make_expr $ concat_number [1,2,3,4]
[10,2,4,-4,6,-2,0,-8,37,-31,33,-35,28,20,-18,-26,235,-233,19,11,13,5,46,-22,127,119,1234]

●実行結果

あとは filter で指定した値になる式を取り出すだけです。プログラムは次のようになります。

リスト : 小町算の解法

komachi :: [Int] -> Int -> [[Expr]]
komachi xs n =
  filter (\expr -> calc_expr expr == n) $ concatMap make_expr $ concat_number xs

実行結果を示します。

*Main> komachi [1..9] 100
[[Val 1,Add,Val 2,Add,Val 3,Sub,Val 4,Add,Val 5,Add,Val 6,Add,Val 78,Add,Val 9],
 [Val 1,Add,Val 2,Add,Val 34,Sub,Val 5,Add,Val 67,Sub,Val 8,Add,Val 9],
 [Val 1,Add,Val 23,Sub,Val 4,Add,Val 5,Add,Val 6,Add,Val 78,Sub,Val 9],
 [Val 1,Add,Val 23,Sub,Val 4,Add,Val 56,Add,Val 7,Add,Val 8,Add,Val 9],
 [Val 12,Add,Val 3,Add,Val 4,Add,Val 5,Sub,Val 6,Sub,Val 7,Add,Val 89],
 [Val 12,Sub,Val 3,Sub,Val 4,Add,Val 5,Sub,Val 6,Add,Val 7,Add,Val 89],
 [Val 12,Add,Val 3,Sub,Val 4,Add,Val 5,Add,Val 67,Add,Val 8,Add,Val 9],
 [Val 123,Sub,Val 4,Sub,Val 5,Sub,Val 6,Sub,Val 7,Add,Val 8,Sub,Val 9],
 [Val 123,Add,Val 4,Sub,Val 5,Add,Val 67,Sub,Val 89],
 [Val 123,Add,Val 45,Sub,Val 67,Add,Val 8,Sub,Val 9],
 [Val 123,Sub,Val 45,Sub,Val 67,Add,Val 89]]

これではよくわからないので、式を文字列に変換する関数 toStr を作ります。

リスト :  式を文字列に変換

toStr :: Int -> [Expr] -> [Char]
toStr n []     = "=" ++ show n
toStr n (x:xs) =
  case x of
    Add   -> "+"
    Sub   -> "-"
    Val x -> show x
  ++ toStr n xs

プログラムは簡単なので説明は割愛します。実行結果を示します。

*Main> map (toStr 100) $ komachi [1..9] 100
["1+2+3-4+5+6+78+9=100",
 "1+2+34-5+67-8+9=100",
 "1+23-4+5+6+78-9=100",
 "1+23-4+56+7+8+9=100",
 "12+3+4+5-6-7+89=100",
 "12-3-4+5-6+7+89=100",
 "12+3-4+5+67+8+9=100",
 "123-4-5-6-7+8-9=100",
 "123+4-5+67-89=100",
 "123+45-67+8-9=100",
 "123-45-67+89=100"]

ここまでプログラムを作ると、問題を解くのは簡単です。最初の問題は次のようになります。

*Main> a = map (komachi [1..9]) [100..999]
*Main> b = map length a
*Main> maximum b
15
*Main> :m +Data.List
*Main Data.List> map (+100) $ elemIndices 15 b
[108,117,126]

3 桁の整数の中で、式の総数の最大値は 15 になり、その値は 108, 117, 126 の 3 通りになります。たとえば、108 になる式は次のようになります。

*Main Data.List> map (toStr 108) (a !! 8)
["1+2+3+4+5+6+78+9=108",
 "1+2-3+45-6+78-9=108",
 "1+2+34-5-6-7+89=108",
 "1+2+34+5+67+8-9=108",
 "1-2-34+56+78+9=108",
 "1+23+4+5+6+78-9=108",
 "1+23-4-5+6+78+9=108",
 "1+23+4+56+7+8+9=108",
 "12+3-4-5+6+7+89=108",
 "12-3+4+5-6+7+89=108",
 "12+3+4+5+67+8+9=108",
 "12+34+56+7+8-9=108",
 "123+4-5-6-7+8-9=108",
 "123-4+5-6+7-8-9=108",
 "123-45+6+7+8+9=108"]

解のない最小値は次のように求めることができます。

*Main Data.List> head $ map (+100) $ findIndices (==0) b
160
*Main Data.List> a !! 60
[]

解が存在する最大値は次のようになります。

*Main Data.List> last $ map (+100) $ findIndices (>0) b
972
*Main Data.List> map (toStr 972) $ a !! 872
["123+4+56+789=972"]

ちなみに、数字の並びを逆順 (9,8,7,6,5,4,3,2,1) にした場合も簡単に答えを求めることができます。

*Main Data.List> c = map (komachi [9,8..1]) [100..999]
*Main Data.List> d = map length c
*Main Data.List> maximum d
19
*Main Data.List> map (+100) $ elemIndices 19 d
[102]
*Main Data.List> map (toStr 102) (c !! 2)
["9+8+7+6+54-3+21=102",
 "9+8-7+65-4+32-1=102",
 "9-8+7+65-4+32+1=102",
 "9+8+76+5+4+3-2-1=102",
 "9+8+76+5+4-3+2+1=102",
 "9+8+76-5-4-3+21=102",
 "9-8+76+5-4+3+21=102",
 "98+7+6-5-4+3-2-1=102",
 "98+7+6-5-4-3+2+1=102",
 "98+7-6+5+4-3-2-1=102",
 "98+7-6+5-4+3-2+1=102",
 "98+7-6-5+4+3+2-1=102",
 "98-7+6+5+4-3-2+1=102",
 "98-7+6+5-4+3+2-1=102",
 "98-7+6-5+4+3+2+1=102",
 "98+7+6+5+4+3-21=102",
 "98-7-6-5+4-3+21=102",
 "98-7-6-5+43-21=102",
 "98+76-54+3-21=102"]
*Main Data.List> head $ map (+100) $ findIndices (==0) d
194
*Main Data.List> (c !! 94)
[]
*Main Data.List> last $ map (+100) $ findIndices (>0) d
999
*Main Data.List> map (toStr 999) (c !! 899)
["9+8+7+654+321=999"]

●大町算

パズルの世界では小町数に 0 を加えた数を「大町数」といいます。そして、0 から 9 までの 10 個の数字を 1 個ずつ使った計算を「大町算」といいます。ただし、0123456789 のように最上位の桁に 0 を入れることはできません。今回は大町数のパズルを生成検定法で解いてみましょう。それでは問題です。

[問題] 3数で大町どうさま

ある連続した3数 (n, n+1, n+2) を掛け合わせたら、大町数になったという。そのような3数をすべて見つけてほしい。もちろん、負の数は考えない。

出典:『Cマガ電脳クラブ』 Cマガジン 1998 年 2 月号(ソフトバンク)

C言語でプログラムを作る場合、大町数は整数 (32 bit) の範囲を超えるためちょっとした工夫が必要になりますが、Haskell だと簡単にプログラムを作ることができます。

●プログラムの作成

それではプログラムを作りましょう。最初に整数 n の範囲を絞り込みます。大町数の最大値は 9876543210 で最小値は 1023456789 ですから、n の値は次の範囲内になります。

(**) :: Floating a => a -> a -> a

1023456789 ** (1 / 3) => 1007.758578449832
1006 * 1007 * 1008    => 1021146336 < 1023456789

9876543210 ** (1 / 3) => 2145.5319657992272
2145 * 2146 * 2147    => 9883005990 > 9876543210

x ** y は x の y 乗を返します。これらの計算結果から n は 1007 以上 2144 以下であることがわかります。n の範囲がぐっと狭くなりましたね。これならば、あとは単純に計算して大町数になるかチェックすればいいでしょう。プログラムは次のようになります。

リスト : パズル「3数で大町どうさま」の解法

import Data.List

splitDigit :: Integer -> [Integer]
splitDigit 0 = []
splitDigit n = n `mod` 10 : splitDigit(n `div` 10)

check :: Integer -> Bool
check n = length (nub (splitDigit (n * (n + 1) * (n + 2)))) == 10

answer :: Integer -> String
answer n = show n ++ "*" ++ show n1 ++ "*" ++ show n2 ++ "=" ++ show n3
  where n1 = n + 1
        n2 = n + 2
        n3 = n * n1 * n2

oomachi_solver :: [String]
oomachi_solver = map answer $ filter check [1007 .. 2144]

関数 splitDigit は整数を 1 桁ずつ数字に分解します。実行例を示します。

*Main> splitDigit 1234567890
[0,9,8,7,6,5,4,3,2,1]

数字の並びは逆になりますが、これでも今回の問題を解くことができます。興味のある方は数字の並び方が逆にならないようにプログラムを修正してみてください。

関数 check は引数 n が大町数になっているかチェックします。n * (n + 1) * (n + 2) を計算して、その値を splitDigit で分割します。nub は重複要素を取り除く関数で、モジュール Data.List に定義されています。簡単な使用例を示します。

*Main> :t nub
nub :: Eq a => [a] -> [a]
*Main> nub [1,2,3,4,2,3,4,5,3,4,5,6]
[1,2,3,4,5,6]

生成される値は 10 桁なので、重複要素を取り除いたリストの長さが 10 であれば、その値は「大町数」であることがわかります。あとは filter で大町数になる値だけ取り出して、関数 answer で文字列に変換します。

●実行結果

これでプログラムは完成です。さっそく実行してみましょう。

*Main> oomachi_solver
["1267*1268*1269=2038719564","1332*1333*1334=2368591704"]

2 通りの解を見つけることができました。


初版 2013 年 2 月 11 日
改訂 2021 年 1 月 24 日

経路の探索

今回は、地図上の A 地点から B 地点までの道順を求める、といった「経路の探索」と呼ばれる問題を取り上げます。「探索」にはいろいろな種類があります。「8 クイーン」 のようなパズルの解法も、あらゆる可能性の中から正解に行き着く手順を探すことですから、探索の一つと考えることができます。そして、探索でよく用いられる最も基本的な方法が「バックトラック」なのです。もちろん、経路の探索もバックトラックで解くことができます。

このほかに、もう一つ基本的な方法として「幅優先探索」があります。バックトラックの場合、失敗したら後戻りして別の道を選び直しますが、幅優先探索の場合は、全ての経路について並行に探索を進めていきます。今回は、この 2 つの方法で問題を解いてみましょう。

●グラフの表現方法

簡単な例題として、次に示す経路を考えてみます。


        図 : 経路図

点とそれを接続する線からなる図形を「グラフ (graph)」といいます。点のことを「頂点 (vertex)」とか「節 (node)」と呼び、線のことを「辺 (edge)」とか「弧 (arc)」と呼びます。グラフには 2 種類あって、辺に向きがないものを「無向グラフ」といい、向きがあるものを「有向グラフ」といいます。有向グラフは一方通行の道と考えるとわかりやすいでしょう。上図ではアルファベットで頂点を表しています。今回は経路をグラフで表していますが、このほかにもいろいろな問題をグラフで表現することができます。

グラフをプログラムする場合、よく使われる方法が「隣接行列」と「隣接リスト」です。隣接行列は 2 次元配列で頂点の連結を表す方法です。頂点が N 個ある場合、隣接行列は N 行 N 列の行列で表すことができます。上図を隣接行列で表すと、次のようになります。

   | A B C D E F G
  -+--------------  
  A| 0 1 1 0 0 0 0
  B| 1 0 1 1 0 0 0
  C| 1 1 0 0 1 0 0
  D| 0 1 0 0 1 1 0
  E| 0 0 1 1 0 0 1
  F| 0 0 0 1 0 0 0
  G| 0 0 0 0 1 0 0


    図 : 隣接行列

A に接続している頂点は B と C なので、A 行の B と C に 1 をセットし、接続していない頂点には 0 をセットします。経路が一方通行ではない無向グラフの場合は、A 列の B と C にも 1 がセットされます。

隣接行列の欠点は、辺の数が少ない場合でも N 行 N 列の行列が必要になることです。つまり、ほとんどの要素が 0 になってしまい、メモリを浪費してしまうのです。この欠点を補う方法に隣接リストがあります。これは、つながっている頂点を格納する方法です。次の図を見てください。

  A => [B, C]
  B => [A, C, D]  
  C => [A, B, E]
  D => [B, E, F]
  E => [C, D, G]
  F => [D]
  G => [E]


  図 : 隣接リスト

上図は、頂点とそこに接続されている頂点を => と [ ] で表しています。これを Haskell で表すと、次のようになります。

リスト : 隣接リスト

adjacent :: [[Int]]
adjacent =
  [[1, 2],     -- A
   [0, 2, 3],  -- B
   [0, 1, 4],  -- C
   [1, 4, 5],  -- D
   [2, 3, 6],  -- E
   [3],        -- F
   [4]]        -- G

頂点 A から G を数値 0 から 6 に対応させるところがポイントです。すると、隣接リスト adjacent のデータ型は [[Int]] で表すことができます。

ところで、隣接リストにも欠点があります。たとえば、E と G が接続しているか調べるには、データを順番に調べていくしか方法がありません。このため、接続の判定に時間がかかることがあるのです。まあ、頂点に接続されている辺の数が少なければ、処理速度が極端に遅くなることはないでしょう。

●深さ優先探索の動作

それでは、隣接リストを使って A から G までの経路をバックトラックで求めてみましょう。バックトラックの実装にはスタックを使うと簡単です。また、明示的にスタックを使わなくても再帰呼び出しで簡単に実装することもできます。

経路は頂点を並べたリストで表すことにします。バックトラックによる経路の探索は下図のような動作になります。

最初、スタックに出発点を格納した経路 [A] を入れます。次に、スタックから経路を一つ取り出します (1)。そして、経路 [A] を一つ進めた経路 [A,B], [A,C] を作成し、それをスタックに追加します (2)。ここでスタックには経路 [A,B], [A,C] が格納されます。同様にスタックからデータを取り出して経路を一つ進めます、取り出した経路が [A,C] とすると、一つ進めた経路は [A,C,B], [A,C,E] で、これをスタックに追加します (3)。あとは同様に、スタックからデータを取り出して経路を一つ進めます (4)。これをゴールに到達するか、スタックが空になるまで繰り返します。

ここで、スタックから取り出した経路を順番に並べてみましょう。

[A] => [A, C] => [A, C, E] => ...

ひとつの経路を延ばして探索をすすめていることがわかります。このように、スタックを使って探索を行うと、経路を先へ先へ進めるので、「縦形探索」とか「深さ優先探索」と呼ばれています。

バックトラックも簡単です。次の図を見てください。

行き止まりになったら、その経路を捨ててスタックから新しい経路を取り出します。たとえば、[A,C,E,G] は行き止まりなので、スタックから [A,C,E,D] を取り出します。この動作は [A,C,E,G] から [A,C,E] に戻って [A,C,E,D] に進む動作に対応します。スタックは後入れ先出し (LIFO) のデータ構造です。スタックの中には通ってきた経路が格納されているので、スタックから経路を取り出せばバックトラック (後戻り) することができるわけです。

●プログラムの作成

それではプログラムを作ります。最初に経路を表すデータ構造を決めておきましょう。次の図を見てください。

  A - B - D      ─→  [0, 1. 3]    ==> [3, 1, 0]

  A - B - C - E  ─→  [0, 1, 2, 4] ==> [4, 2, 1, 0]  

                               逆順で管理する


                図 : 経路の表し方

経路はリストに頂点を格納して表すことにします。リストの最後尾にデータを追加するのは面倒なので、経路は上図のように逆順で管理することにします。

求めた経路を画面に出力する場合、プログラムは次のようになります。

リスト : 深さ優先探索 (1)

import Stack

-- 次の頂点へ進む
nextPath :: [Int] -> [[Int]]
nextPath path@(x:xs) = [y:path | y <- adjacent !! x, y `notElem` xs]

-- 深さ優先探索
dfs :: Int -> Int -> IO ()
dfs start goal = iter (singleton [start]) where
  iter s
    | isEmptyStack s = return ()
    | otherwise =
        let (path, s1) = pop s
        in if head path == goal then do
             print (reverse path)
             iter s1
           else iter $ foldl push s1 $ nextPath path

モジュール Stack は拙作のページ モジュール で作成した Stack.hs です。関数 nextPath は隣接リスト adjacent から x の隣にある頂点 y を選んで新しい経路を生成します。このとき、経路に含まれている頂点を選んではいけません。そうしないと、同じ道をぐるぐると回る巡回経路が発生し、ゴールまでたどり着くことができなくなります。これをリスト内包表記の条件式 y `notElem` xs でチェックしています。

関数 dfs は深さ優先探索で start から goal までの経路を求めます。実際の処理は局所関数 iter で行います。iter には経路を格納したスタックを渡します。最初は出発点だけを格納した経路 [start] をスタックに積みます。そして、スタックにデータがある間、スタックから経路を取り出して探索を行います。

スタックにデータがある場合、pop でデータを取り出して、path と s1 に経路とスタックをセットします。path の先頭要素が goal と等しい場合、経路をひとつ見つけたので print で表示します。経路は逆順になっているので reverse で反転します。ここで探索を終了することもできますが、iter s1 を呼び出してバックトラックすることで全ての経路を見つけることができます。パズルの解法で解の総数を求める場合、全ての解をもれなく探索する必要があります。バックトラックを使えば、このような要求も満たすことができます。

goal に到達していない場合は新しい経路を nextPath で生成して、それをスタックに積んで iter を再帰呼び出しします。新しい経路をスタックに積む操作は畳み込み foldl を使えば簡単です。最後に、スタックが空になったら return で IO () を生成して返します。

それでは実行してみましょう。

*Main> dfs 0 6
[0,2,4,6]
[0,2,1,3,4,6]
[0,1,3,4,6]
[0,1,2,4,6]
*Main> dfs 6 0
[6,4,3,1,2,0]
[6,4,3,1,0]
[6,4,2,1,0]
[6,4,2,0]

4 通りの経路を見つけることができました。結果を見てもわかるように、最初に見つかる経路が最短経路とは限りません。最短経路を求めるのに適したアルゴリズムが「幅優先探索」です。

ところで、見つけた経路をリストに格納して返すことも簡単です。プログラムは次のようになります。

リスト : 深さ優先探索 (2)

-- リストに格納する
dfs' :: Int -> Int -> [[Int]]
dfs' start goal = iter (singleton [start]) where
  iter s
    | isEmptyStack s = []
    | otherwise =
        let (path, s1) = pop s
        in if head path == goal then reverse path : iter s1
           else iter $ foldl push s1 $ nextPath path

スタックが空になったら空リスト [ ] を返します。そして、経路を一つ見つけたら、reverse で反転してから、iter の返り値のリストに追加します。

それでは実行してみましょう。

*Main> dfs' 0 6
[[0,2,4,6],[0,2,1,3,4,6],[0,1,3,4,6],[0,1,2,4,6]]
*Main> dfs' 6 0
[[6,4,3,1,2,0],[6,4,3,1,0],[6,4,2,1,0],[6,4,2,0]]

なお、スタックを使わなくても演算子 ++ で深さ優先探索を実装することもできます。プログラムは次のようになります。

リスト : 深さ優先探索 (3)

dfs'' :: Int -> Int -> [[Int]]
dfs'' start goal = iter [[start]] where
  iter [] = []
  iter (path:xs)
    | head path == goal = reverse path : iter xs
    | otherwise         = iter (nextPath path ++ xs)

局所関数 iter の引数がスタックのかわりになるリストです。引数が空リストの場合は空リストを返します。そうでなければ、先頭から経路 path を取り出して、ゴールに到達したかチェックします。ゴールに到達していない場合は、nextPath で新しい経路を生成し、それを演算子 ++ で xs の前に追加します。これで深さ優先探索として動作します。

●再帰呼び出しによる実装

次はスタックを使わずに再帰呼び出しでバックトラックを実装してみましょう。バックトラックを再帰呼び出しで実装する場合、経路を「進む」ことを再帰呼び出しに対応させるのがポイントです。たとえば、経路を探索する関数を search としましょう。search は引数として現在地点の頂点を受け取ることにします。最初は search(A) と呼び出します。そして、A から B へ進むには search(B) と呼び出します。これで B へ進むことができます。

それでは、A に戻るにはどうしたらいいのでしょう。search(B) は search(A) から呼び出されたので、search(B) の実行を終了すれば、呼び出し元である search(A) に戻ることができます。つまり、関数の実行を終了すれば、一つ手前の地点にバックトラックできるのです。このように再帰呼び出しを使うと、進むことと戻ることを関数呼び出しで簡単に実現することができます。

たとえば、経路の探索を行う関数 search を次のように定義します。

search :: Int -> [Int] -> IO ()

search の第 1 引数がゴール、第 2 引数が経路を表すリストです。リストの先頭要素が現在地点の頂点になります。search は現在地点に隣接している頂点を一つ選び、経路を進めていきます。A から Gまでの経路を求めるには、次のように呼び出します。

-- A から G までの経路を求める
search 6 [0]

search は出発点 A をリストにセットし、A に接続されている頂点を選びます。隣接リストから順番に選ぶことにすると、次の頂点は B となります。B へ進むためには、次のように search を再帰呼び出しします。

-- B へ進む時の再帰呼び出し
search 6 [1, 0]

この関数の実行を終了すると、呼び出し元の関数である頂点 A の処理に戻ります。これをプログラムすると次のようになります。

リスト : 深さ優先探索 (4)

dfs1 :: Int -> Int -> IO ()
dfs1 start goal = search [start] where
  search path@(x:xs)
    | x == goal = print (reverse path)
    | otherwise = mapM_ search $ nextPath path

局所関数 search を見てください。最初に、現在地点 x がゴール goal かチェックします。これが再帰呼び出しの停止条件になります。ゴールしたら print で経路を表示します。

ゴールしていない場合は、nexPath で次の頂点を選択して新しい経路を生成します。あとは、それを search に渡して再帰呼び出しします。search は I/O アクションの関数になるので、search を実行するため関数 mapM_ を使っています。たとえば、nextPath が生成したリストが [path1, path2] とすると、最初に path1 に対して探索が行われ、バックトラックする (再帰呼び出しから戻ってくる) と次の経路 path2 に対して探索が行われます。

求めた経路をリストに格納するプログラムは次のようになります。

リスト : 深さ優先探索 (5)

-- 結果をリストに格納する
dfs1' :: Int -> Int -> [[Int]]
dfs1' start goal = search [] [start] where
  search ys path@(x:xs)
    | x == goal = reverse path : ys
    | otherwise = foldl search ys $ nextPath path

局所関数 search の第 1 引数を累積変数として使います。経路をひとつ見つけたら累積変数 ys に追加して返します。そうでなければ、nextPath で新しい経路を作って、それを search に渡して再帰呼び出しします。累積変数 ys には新しい経路が追加されることがあるので、更新された累積変数を search が受け取れるように畳み込み foldl を使っています。

「リストモナド」を使うと上記プログラムはもっとわかりやすくなります。リストモナドについては、拙作のページ モナド (1) をお読みくださいませ。ご参考までにプログラムを示します。

リスト : 深さ優先探索 (6)

import Control.Monad

-- リストモナド
dfs1'' :: Int -> Int -> [[Int]]
dfs1'' start goal = search [start] where
  search path@(x:xs)
    | x == goal = return (reverse path)
    | otherwise = do
        y <- (adjacent !! x)
        guard(y `notElem` xs)
        search (y:path)

●幅優先探索

バックトラックによる探索は「深さ優先探索」や「縦形探索」とも呼ばれるように、一つの経路を先へ先へと進めていきます。このため最初に見つかる経路が最短経路であるとは限りません。幅優先探索は全ての経路について平行に探索を進めていくため、最初に見つかる経路が最短経路となります。

それでは、同じ経路図を使って幅優先探索を具体的に説明しましょう。幅優先探索の様子を下図に示します。


                        図 : 幅優先探索

まず、出発点 A から一つ進んだ経路 (2 節点) を全て求めます。この場合は、[A, B] と [A, C] の 2 つあり、これを全て記憶しておきます。次に、これらの経路から一つ進めた経路 (3 節点) を全て求めます。経路 [A, B] は [A, B, C] と [A, B, D] へ進めることができますね。ほかの経路 [A, C] も同様に進めて、全ての経路を記憶します。あとはこの作業をゴールに達するまで繰り返せばいいのです。

上図では、4 節点の経路 [A, C, E, G] でゴールに達していることがわかります。このように幅優先探索では、最初に見つかった経路が最短距離 (または最小手数) となるのです。この性質は、全ての経路を平行に進めていく探索順序から考えれば当然のことといえるでしょう。このことからバックトラックの縦形探索に対して、幅優先探索は「横形探索」と呼ばれます。このあとも探索を繰り返せば全ての経路を求めることができます。

完成までの最小手数を求めるパズルを解く場合、幅優先探索を使ってみるといいでしょう。ただし、探索を進めるにしたがって、記憶しておかなければならないデータの総数が爆発的に増加する、つまりメモリを大量消費することに注意してください。

上図の場合ではメモリを大量消費することはありませんが、問題によってはマシンに搭載されているメモリが不足するため、幅優先探索を実行できない場合もあるでしょう。したがって、幅優先探索を使う場合は、メモリの消費量を抑える工夫も必要になります。

●経路の管理

経路の管理はキューを使うと簡単です。幅優先探索でのキューの動作を下図に示します。


          図 : 幅優先探索とキューの動作

最初は、(1) のように出発点をキューにセットしておきます。次に、キューから経路を取り出し、(2) のように経路 [A] を一つ進めて、経路 [A, B] [A, C] を作り、それをキューに追加します。(3) では、経路 [A, B] を取り出して、一つ進めた経路 [A, B, C] と [A, B, D] をキューに追加します。あとはキューに経路がある間、処理を繰り返せばいいわけです。

キューは先入れ先出し (FIFO) の性質を持つデータ構造です。距離の短い経路から順番に処理されるため、幅優先探索として機能するわけです。

●プログラムの作成

プログラムは次のようになります。

リスト : 幅優先探索

import qualified Queue as Q

bfs start goal = iter (Q.singleton [start]) where
  iter q
    | Q.isEmptyQueue q = return ()
    | otherwise =
        let (path, q1) = Q.dequeue q
        in if head path == goal then do
             print (reverse path)
             iter q1
           else iter $ foldl Q.enqueue q1 $ nextPath path

-- リストに格納する
bfs' :: Int -> Int -> [[Int]]
bfs' start goal = iter (Q.singleton [start]) where
  iter q
    | Q.isEmptyQueue q = []
    | otherwise =
        let (path, q1) = Q.dequeue q
        in if head path == goal then reverse path : iter q1
           else iter $ foldl Q.enqueue q1 $ nextPath path

モジュール Queue は拙作のページ モジュール で作成した Queue.hs です。プログラムは深さ優先探索を行う関数 dfs のスタックをキューに変更しただけで、あとの処理はほとんど同じです。これで幅優先で経路の探索が行われます。見つけた経路をリストに格納して返す関数 bfs' も同様です。

それでは実行してみましょう。

*Main> bfs 0 6
[0,2,4,6]
[0,1,2,4,6]
[0,1,3,4,6]
[0,2,1,3,4,6]
*Main> bfs 6 0
[6,4,2,0]
[6,4,2,1,0]
[6,4,3,1,0]
[6,4,3,1,2,0]
*Main> bfs' 0 6
[[0,2,4,6],[0,1,2,4,6],[0,1,3,4,6],[0,2,1,3,4,6]]
*Main> bfs' 6 0
[[6,4,2,0],[6,4,2,1,0],[6,4,3,1,0],[6,4,3,1,2,0]]

結果を見ればおわかりのように、最初に見つかる経路が最短で、最後に見つかる経路が最長となります。当然ですが、経路の総数は 4 通りとなります。

この程度の問題であれば、わざわざキューを使わなくても演算子 ++ で幅優先探索を実装することができます。プログラムは次のようになります。

リスト : 幅優先探索 (2)

bfs'' :: Int -> Int -> [[Int]]
bfs'' start goal = iter [[start]] where
  iter [] = []
  iter (path:q)
    | head path == goal = reverse path : iter q
    | otherwise         = iter (q ++ nextPath path)

局所関数 iter の引数がキューのかわりになるリストです。引数が空リストの場合は空リストを返します。そうでなければ、先頭から経路 path を取り出して、ゴールに到達したかチェックします。ゴールに到達していない場合は、nextPath で新しい経路を生成し、それを演算子 ++ で q の後ろに連結します。これで幅優先探索として動作します。


●プログラムリスト

--
-- keiro.hs : 経路の探索
--
--            Copyright (C) 2013-2021 Makoto Hiroi
--
import Control.Monad
import Stack
import qualified Queue as Q

-- 隣接リスト
adjacent :: [[Int]]
adjacent =
  [[1, 2],     -- A
   [0, 2, 3],  -- B
   [0, 1, 4],  -- C
   [1, 4, 5],  -- D
   [2, 3, 6],  -- E
   [3],        -- F
   [4]]        -- G

-- 次の頂点へ進む
nextPath :: [Int] -> [[Int]]
nextPath path@(x:xs) = [y:path | y <- adjacent !! x, y `notElem` xs]

-- 深さ優先探索
dfs :: Int -> Int -> IO ()
dfs start goal = iter (singleton [start]) where
  iter s
    | isEmptyStack s = return ()
    | otherwise =
        let (path, s1) = pop s
        in if head path == goal then do
             print (reverse path)
             iter s1
           else iter $ foldl push s1 $ nextPath path

-- リストに格納する
dfs' :: Int -> Int -> [[Int]]
dfs' start goal = iter (singleton [start]) where
  iter s
    | isEmptyStack s = []
    | otherwise =
        let (path, s1) = pop s
        in if head path == goal then reverse path : iter s1
           else iter $ foldl push s1 $ nextPath path

dfs'' :: Int -> Int -> [[Int]]
dfs'' start goal = iter [[start]] where
  iter [] = []
  iter (path:xs)
    | head path == goal = reverse path : iter xs
    | otherwise         = iter (nextPath path ++ xs)

dfs1 :: Int -> Int -> IO ()
dfs1 start goal = search [start] where
  search path@(x:xs)
    | x == goal = print (reverse path)
    | otherwise = mapM_ search $ nextPath path

 -- 結果をリストに格納する
dfs1' :: Int -> Int -> [[Int]]
dfs1' start goal = search [] [start] where
  search ys path@(x:xs)
    | x == goal = reverse path : ys
    | otherwise = foldl search ys $ nextPath path

-- リストモナド
dfs1'' :: Int -> Int -> [[Int]]
dfs1'' start goal = search [start] where
  search path@(x:xs)
    | x == goal = return (reverse path)
    | otherwise = do
        y <- (adjacent !! x)
        guard(y `notElem` xs)
        search (y:path)

--
-- 幅優先探索
--
bfs start goal = iter (Q.singleton [start]) where
  iter q
    | Q.isEmptyQueue q = return ()
    | otherwise =
        let (path, q1) = Q.dequeue q
        in if head path == goal then do
             print (reverse path)
             iter q1
           else iter $ foldl Q.enqueue q1 $ nextPath path

-- リストに格納する
bfs' :: Int -> Int -> [[Int]]
bfs' start goal = iter (Q.singleton [start]) where
  iter q
    | Q.isEmptyQueue q = []
    | otherwise =
        let (path, q1) = Q.dequeue q
        in if head path == goal then reverse path : iter q1
           else iter $ foldl Q.enqueue q1 $ nextPath path

bfs'' :: Int -> Int -> [[Int]]
bfs'' start goal = iter [[start]] where
  iter [] = []
  iter (path:q)
    | head path == goal = reverse path : iter q
    | otherwise         = iter (q ++ nextPath path)

初版 2013 年 2 月 17 日
改訂 2021 年 1 月 24 日

Copyright (C) 2013-2021 Makoto Hiroi
All rights reserved.

[ PrevPage | Haskell | NextPage ]