M.Hiroi's Home Page

Functional Programming

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

[ PrevPage | Haskell | NextPage ]

順列と組み合わせ

今回は簡単な例題として、「順列 (permutation)」と「組み合わせ (combination)」を取り上げます。Haskell のモジュール Data.List には順列を生成する関数 permutations が用意されていますが、私たちでも簡単にプログラムすることができます。

●順列の生成

異なる n 個の順列の総数は、n の階乗 (n!) だけあります。たとえば、3 つの整数 1, 2, 3 の順列は次に示すように 6 通りあります。

1 2 3,  1 3 2,  2 1 3,  2 3 1,  3 1 2,  3 2 1

順列を生成するプログラムは再帰定義で簡単に作ることができます。[1, 2, 3] の順列を生成する場合、最初に 1 で始まる順列を生成します。これは 1 を取り除いた数字 [2, 3] の順列を生成することで実現できます。次は 2 で始まる順列を生成します。同様に、2 を取り除いた数字 [1, 3] の順列を生成すればいいわけです。[2, 3] や [1, 3] の順列を生成する場合も同じように考えることができます。

●要素の選択

それではプログラムを作りましょう。最初に、リストから要素を一つ選んで、選んだ要素と残りの要素を返す関数 select を作ります。次のリストを見てください。

リスト : 要素の選択

select :: [a] -> [(a, [a])]
select [x]    = [(x, [])]
select (x:xs) = (x, xs) : map (\(y, ys) -> (y, x:ys)) (select xs)

-- 別解
select' :: [a] -> [(a, [a])]
select' [x] = [(x, [])]
select' (x:xs) = (x,xs) : [(y, x:ys) | (y, ys) <- select' xs]

select は選んだ要素と残りの要素をタプルに格納し、それをリストに格納して返します。最初の節で、リストの要素が一つしかない場合は (x, []) をリストに格納して返します。これが再帰呼び出しの停止条件です。

次の節で、リストを x : xs で分解します。先頭要素 x を選ぶ場合は (x, xs) をリストに格納するだけです。それ以外の場合は、xs に対して select を再帰呼び出しし、返り値のタプルの第 2 要素 ys (残りの要素を格納したリスト) に x を追加します。この処理は map を使うと簡単ですね。あとは、map の返り値に (x, xs) を追加するだけです。別解はリスト内包表記でプログラムしたものです。

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

*Main> select [1,2,3]
[(1,[2,3]),(2,[1,3]),(3,[1,2])]
*Main> select [1,2,3,4]
[(1,[2,3,4]),(2,[1,3,4]),(3,[1,2,4]),(4,[1,2,3])]
*Main> select [1,2,3,4,5]
[(1,[2,3,4,5]),(2,[1,3,4,5]),(3,[1,2,4,5]),(4,[1,2,3,5]),(5,[1,2,3,4])]

●プログラムの作成

select を使うと順列を生成する関数 permutations は簡単にプログラムすることができます。

リスト : 順列の生成

permutations :: [a] -> [[a]]
permutations [] = [[]]
permutations xs =
  concatMap (\(y, ys) -> map (y:) (permutations ys)) $ select xs

-- 別解
permutations' :: [a] -> [[a]]
permutations' [] = [[]]
permutations' xs =
  [y:zs | (y, ys) <- select xs, zs <- permutations' ys]

関数 permutations は引数のリスト xs から順列を生成し、それをリストに格納して返します。引数が空リストになるときが再帰の停止条件で、空リストを格納したリストを返します。このリストに対して要素を追加していきます。この処理は map を二重に使うと簡単に実現できそうです。次の例を見てください。

*Main> map (5:) [[1],[2],[3],[4],[5]]
[[5,1],[5,2],[5,3],[5,4],[5,5]]
*Main> map (\y -> map (y:) [[1],[2],[3],[4],[5]]) [5,6]
[[[5,1],[5,2],[5,3],[5,4],[5,5]],[[6,1],[6,2],[6,3],[6,4],[6,5]]]

リストの各要素に 5 を追加したい場合、map を使うと簡単ですね。次は、リスト [5, 6] の各要素を追加したリストを求めることを考えます。map を二重にして、[5, 6] の要素をラムダ式の引数 y に渡します。次の map で y をリストに追加します。すると、返り値のリストには 5 を追加したリストと 6 を追加したリストが格納されます。map を二重にしているので、リストの階層が一段深くなるわけです。

そこで、リストを一段階だけ平坦化することにします。Haskell には concat という関数が用意されています。簡単な例を示しましょう。

*Main> :t concat
concat :: [[a]] -> [a]
*Main> concat [[1,2,3],[4,5,6],[7,8,9]]
[1,2,3,4,5,6,7,8,9]

実際のプログラムでは平坦化と map を組み合わせた関数を定義しておくと便利です。Haskell には関数 concatMap が用意されています。簡単な使用例を示しましょう。

*Main> :t concatMap
concatMap :: (a -> [b]) -> [a] -> [b]
*Main> concatMap (\y -> map (y:) [[1],[2],[3],[4],[5]]) [5,6]
[[5,1],[5,2],[5,3],[5,4],[5,5],[6,1],[6,2],[6,3],[6,4],[6,5]]

ご参考までに、concatMap のプログラムを示します。

リスト : concatMap

concatMap :: (a -> [b]) -> [a] -> [b]
concatMap _ [] = []
concatMap f (x:xs) = f x ++ concatMap f xs

関数 permutations の説明に戻ります。ラムダ式の中で permutations を再帰呼び出しをして、リスト ys の順列を生成します。そして、その返り値に選択した要素 y を追加すれば順列を生成することができます。別解はリスト内包表記でプログラムしたものです。

簡単な実行例を示しましょう。

*Main> permutations [1,2,3]
[[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
*Main> permutations [1,2,3,4]
[[1,2,3,4],[1,2,4,3],[1,3,2,4],[1,3,4,2],[1,4,2,3],[1,4,3,2],[2,1,3,4],[2,1,4,3],
 [2,3,1,4],[2,3,4,1],[2,4,1,3],[2,4,3,1],[3,1,2,4],[3,1,4,2],[3,2,1,4],[3,2,4,1],
 [3,4,1,2],[3,4,2,1],[4,1,2,3],[4,1,3,2],[4,2,1,3],[4,2,3,1],[4,3,1,2],[4,3,2,1]]

なお、permutations で生成されるリストは「遅延ストリーム」として利用することもできます。たとえば、[1,2,3,4] の順列の総数は 24 通りありますが、take 1 $ permutations [1,2,3,4] とすると、[1,2,3,4] が取り出されますが、残りの順列はまだ生成されていません。必要になった時点で順列が生成されます。

もうひとつ別解を示しましょう。

リスト : 別解 (2)

permutations'' :: [a] -> [[a]]
permutations'' xs = perm xs [] [] where
  perm [] ys zs = reverse ys : zs
  perm xs ys zs = foldr (\(x, xs) a -> perm xs (x:ys) a) zs $ select xs

局所関数 perm は、第 2 引数のリストに要素を追加していき、完成した順列を第 3 引数のリストに格納します。最初の節で、第 1 引数が空リストになったら順列が一つ完成しました。reverse で ys を反転してから zs に追加して返します。perm を呼び出す場合、この返り値を第 3 引数に渡すことで、生成した順列を格納していくことができます。

次の節で、foldr の初期値を第 3 引数の zs にすることで、ラムダ式の引数 a に順列を格納するリストを渡します。あとは perm を再帰呼び出しすると、その返り値は次にラムダ式を呼び出すときの引数 a に渡されるので、順列を格納したリストを perm に渡していくことができます。

それでは実行結果を示します。

*Main> permutations'' [1..4]
[[1,2,3,4],[1,2,4,3],[1,3,2,4],[1,3,4,2],[1,4,2,3],[1,4,3,2],[2,1,3,4],[2,1,4,3],
 [2,3,1,4],[2,3,4,1],[2,4,1,3],[2,4,3,1],[3,1,2,4],[3,1,4,2],[3,2,1,4],[3,2,4,1],
 [3,4,1,2],[3,4,2,1],[4,1,2,3],[4,1,3,2],[4,2,1,3],[4,2,3,1],[4,3,1,2],[4,3,2,1]]

●select を使わない方法

リストの要素に型クラス制約 Eq を付けると、select を使わないでプログラムを作ることができます。次のリストを見てください。

リスト : 順列の生成 (2)

permutations :: Eq a => [a] -> [[a]]
permutations [] = [[]]
permutations xs =
  concatMap (\x -> map (x:) (permutations (filter (/=x) xs))) xs

-- 別解
permutations' :: Eq a => [a] -> [[a]]
permutations' [] = [[]]
permutations' xs =
  [x:ys | x <- xs, ys <- permutations' (filter (/=x) xs)]

要素の選択は concatMap で行います。この場合、先頭の要素から順番に選択することになります。そして、permutations を再帰呼び出しするとき、リスト xs から選んだ要素 x を filter で削除します。これで x を取り除いたリストの順列を生成することができます。あとは、返り値の要素 (リスト) の先頭に x を追加していくだけです。別解はリスト内包表記でプログラムしたものです。

●リストから n 個の要素を選ぶ場合

リストから n 個の要素を選んで順列を生成することも簡単にできます。次のリストを見てください。

リスト : n 個の要素を選んで順列を生成する

permutation :: Int -> [a] -> [[a]]
permutation 0 _  = [[]]
permutation n xs =
  concatMap (\(y, ys) -> map (y:) (permutation (n - 1) ys)) $ select xs

-- 別解
permutation' :: Int -> [a] -> [[a]]
permutation' 0 _  = [[]]
permutation' n xs =
  [y:zs | (y, ys) <- select xs, zs <- permutation' (n - 1) ys]

関数名は permutation としました。最初の引数が選ぶ要素の個数を表します。0 ならば [[ ]] を返します。これが再帰呼び出しの停止条件です。あとは、perumtation を再帰呼び出しするとき個数を -1 するだけです。別解はリスト内包表記でプログラムしたものです。

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

*Main> permutation 3 [1,2,3,4]
[[1,2,3],[1,2,4],[1,3,2],[1,3,4],[1,4,2],[1,4,3],[2,1,3],[2,1,4],[2,3,1],[2,3,4]
,[2,4,1],[2,4,3],[3,1,2],[3,1,4],[3,2,1],[3,2,4],[3,4,1],[3,4,2],[4,1,2],[4,1,3]
,[4,2,1],[4,2,3],[4,3,1],[4,3,2]]

型クラス制約 Eq を付ける場合も同様にプログラムすることができます。

●組み合わせの生成

次は「組み合わせ (combination)」を生成するプログラムを作ってみましょう。たとえば、リスト [1, 2, 3, 4, 5] の中から 3 個を選ぶ組み合わせは次のようになります。

1 2 3, 1 2 4, 1 2 5, 1 3 4, 1 3 5, 1 4 5
2 3 4, 2 3 5, 2 4 5, 3 4 5

最初に 1 を選択した場合、次は [2, 3, 4, 5] の中から 2 個を選べばいいですね。2 番目に 2 を選択したら、次は [3, 4, 5] の中から 1 個を選べばいいわけです。これで、[1, 2, 3], [1, 2, 4], [1, 2, 5] が生成されます。[2, 3, 4, 5] の中から 2 個選ぶとき、2 を選ばない場合があります。この場合は [3, 4, 5] の中から 2 個を選べばいいわけです。ここで 3 を選ぶと [1, 3, 4], [1, 3, 5] が生成できます。同様に、3 を除いた [4, 5] の中から 2 個をえらぶと [1, 4, 5] を生成することができます。

これで 1 を含む組み合わせを生成したので、次は 1 を含まない組み合わせ、つまり [2, 3, 4, 5] から 3 個を選ぶ組み合わせを生成すればいいわけです。けっきょく、この処理の考え方は次に示す組み合わせの公式と同じです。

nC0 = nCn = 1
nCr = n-1Cr-1 + n-1Cr

これをプログラムすると次のようになります。

リスト : 組み合わせの生成

combinations :: Int -> [a] -> [[a]]
combinations n xs = comb n (length xs) xs where
  comb 0 _ _ = [[]]
  comb r n a@(x:xs)
    | n == r    = [a]
    | otherwise = map (x:) (comb (r - 1) (n - 1) xs) ++ comb r (n - 1) xs

実際の処理は局所関数 comb で行います。第 1 引数が選ぶ個数 r、第 2 要素が要素の個数 n、第 3 引数が要素を格納したリストです。最初の節は r が 0 の場合です。選択する要素がないので空リストを格納したリストを返します。最後の節で、n と r が等しい場合は、その要素を全て選択するのでリスト [a] を返します。

そうでなければ、先頭要素 x を選びます。残りのリスト xs から r - 1 個を選ぶ組み合わせを生成して、その先頭に x を追加します。あとは、xs から r 個を選ぶ組み合わせを comb で求めて、演算子 ++ で連結するだけです。

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

*Main> combinations 2 [1,2,3,4,5]
[[1,2],[1,3],[1,4],[1,5],[2,3],[2,4],[2,5],[3,4],[3,5],[4,5]]
*Main> combinations 3 [1,2,3,4,5]
[[1,2,3],[1,2,4],[1,2,5],[1,3,4],[1,3,5],[1,4,5],[2,3,4],[2,3,5],[2,4,5],[3,4,5]]
*Main> combinations 4 [1,2,3,4,5]
[[1,2,3,4],[1,2,3,5],[1,2,4,5],[1,3,4,5],[2,3,4,5]]

正常に動作していますね。

ところで、参考 URL には、もっと簡潔なプログラムが掲載されています。参考 URL よりプログラムを引用します。

リスト : 組み合わせの生成 (引用)

comb :: [a] -> Int -> [[a]]
comb _ 0     = [[]]
comb [] _     = []
comb (x:xs) n = map (x:) (comb xs (n-1)) ++ comb xs n

引数のリストが空リストになったら、組み合わせを生成できないので空リストを返すところがポイントです。xs ++ [ ] や [ ] ++ xs は xs になるので、空リストを返しても正常に動作するわけです。とても参考になりました。山下伸夫さんに感謝いたします。

演算子 ++ を使わない場合は次のようになります。

リスト : 別解

combinations' :: Int -> [a] -> [[a]]
combinations' n xs = comb n xs [] [] where
  comb 0 _      ys zs = reverse ys : zs
  comb _ []     _  zs = zs
  comb n (x:xs) ys zs = comb (n - 1) xs (x:ys) (comb n xs ys zs)

局所関数 comb は、第 3 引数のリストに要素を追加していき、生成した組み合わせを第 4 引数のリストに格納します。最初の節で、第 1 引数が 0 になったら組み合わせが一つ完成しました。reverse で ys を反転してから zs に追加して返します。comb を呼び出す場合、この返り値を第 3 引数に渡すことで、生成した順列を格納していくことができます。

次の節で、リストが空リストになったら組み合わせを生成できないので、今まで生成した組み合わせを格納したリスト zs をそのまま返します。最後の節で、x を選ばない組み合わせを comb n xs ys zs で生成し、その返り値を x を選ぶ組み合わせを求める comb の第 4 引数に渡します。これで生成した組み合わせをリストに格納することができます。

実行例を示します。

*Main> combinations' 2 [1..5]
[[1,2],[1,3],[1,4],[1,5],[2,3],[2,4],[2,5],[3,4],[3,5],[4,5]]
*Main> combinations' 3 [1..5]
[[1,2,3],[1,2,4],[1,2,5],[1,3,4],[1,3,5],[1,4,5],[2,3,4],[2,3,5],[2,4,5],[3,4,5]]

●参考 URL

  1. Haskell-jp wiki Old/sampou.org/Programming_玉手箱_組合せ

●問題

次の関数を定義してください。

  1. リスト xs から重複を許して n 個の要素を選ぶ順列を生成する関数 repeatPerm n xs
  2. リスト xs から重複を許して r 個の要素を選ぶ組み合わせを生成する関数 repeatComb xs r
  3. 0 から m - 1 までの整数値で完全順列を生成する関数 derangement m












●解答

リスト : 解答例 (perm.hs)

repeatPerm :: Int -> [a] -> [[a]]
repeatPerm 0 _ = [[]]
repeatPerm n xs = [x:ys | x <- xs, ys <- repeatPerm (n - 1) xs]

repeatComb :: Int -> [a] -> [[a]]
repeatComb 0 _  = [[]]
repeatComb _ [] = []
repeatComb n ys@(x:xs) = map (x:) (repeatComb (n-1) ys) ++ repeatComb n xs

select :: [a] -> [(a, [a])]
select []     = []
select [x]    = [(x, [])]
select (x:xs) = (x, xs) : map (\(y, ys) -> (y, x:ys)) (select xs)

derangement :: Int -> [[Int]]
derangement m = perm_sub 1 [1 .. m]
  where
    perm_sub _ [] = [[]]
    perm_sub n xs = [y:zs | (y, ys) <- select xs, y /= n, zs <- perm_sub (n + 1) ys]
Prelude> :l perm.hs
[1 of 1] Compiling Main             ( perm.hs, interpreted )
Ok, one module loaded.

*Main> repeatPerm 2 [1,2,3]
[[1,1],[1,2],[1,3],[2,1],[2,2],[2,3],[3,1],[3,2],[3,3]]
*Main> repeatPerm 2 [1,2,3,4]
[[1,1],[1,2],[1,3],[1,4],[2,1],[2,2],[2,3],[2,4],[3,1],[3,2],[3,3],[3,4],[4,1],[4,2],[4,3],[4,4]]
*Main> repeatPerm 3 [1,2,3]
[[1,1,1],[1,1,2],[1,1,3],[1,2,1],[1,2,2],[1,2,3],[1,3,1],[1,3,2],[1,3,3],[2,1,1],[2,1,2],[2,1,3],
 [2,2,1],[2,2,2],[2,2,3],[2,3,1],[2,3,2],[2,3,3],[3,1,1],[3,1,2],[3,1,3],[3,2,1],[3,2,2],[3,2,3],
 [3,3,1],[3,3,2],[3,3,3]]

*Main> repeatComb 2 [1,2,3]
[[1,1],[1,2],[1,3],[2,2],[2,3],[3,3]]
*Main> repeatComb 2 [1,2,3,4]
[[1,1],[1,2],[1,3],[1,4],[2,2],[2,3],[2,4],[3,3],[3,4],[4,4]]
*Main> repeatComb 3 [1,2,3]
[[1,1,1],[1,1,2],[1,1,3],[1,2,2],[1,2,3],[1,3,3],[2,2,2],[2,2,3],[2,3,3],[3,3,3]]

*Main> derangement 3
[[2,3,1],[3,1,2]]
*Main> derangement 4
[[2,1,4,3],[2,3,4,1],[2,4,1,3],[3,1,4,2],[3,4,1,2],[3,4,2,1],[4,1,2,3],[4,3,1,2],[4,3,2,1]]

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

パズルの解法 (1)

今回は「パズル」を題材にプログラムを作ってみましょう。どのプログラミング言語でもそうですが、上達の秘訣は実際にプログラムを作って動作を確認してみることです。ところが、いざとなると「さて何を作ろうか」と困ってしまう方もいるのではないでしょうか。

このようなときにぴったりな題材が「パズルの解法」です。なんといっても、実際にパズルが解けたときの喜びはとても大きく、プログラムを作る意欲をかきたててくれます。そこで、今回は順列を生成するプログラムを使って簡単なパズルを解いてみましょう。

●覆面算

計算式の数字を文字や記号に置き換えて、それを元の数字に戻すパズルを「覆面算」といいます。異なる文字は異なる数字を表し、同じ文字は同じ数字を表します。使用する数字は 0 から 9 までで、最上位の桁に 0 を入れることはできません。

問題はデュードニーが 1924 年に発表したもので、覆面算の古典といわれる有名なパズルです。

     S E N D
 +   M O R E
-------------
   M O N E Y


  図 : 覆面算

それではプログラムを作りましょう。式 SEND + MORE = MONEY は足し算なので、M が 1 であることはすぐにわかります。ここでは、それ以外の数字を求めるプログラムを作りましょう。次のリストを見てください。

リスト : 覆面算

check_hukumen :: [Int] -> [String] -> [String]
check_hukumen (s:e:n:d:o:r:y:[]) a =
  if send + more == money then expr:a else a
  where send  = s * 1000 + e * 100 + n * 10 + d
        more  = 1000 + o * 100 + r * 10 + e
        money = 10000 + o * 1000 + n * 100 + e * 10 + y
        expr  = show send ++ "+" ++ show more ++ "=" ++ show money

hukumen_solver :: [String]
hukumen_solver = 
  foldr check_hukumen [] (permutation 7 [0,2,3,4,5,6,7,8,9])

1 を除いた 9 個の数字の中から 7 個の数字を選んで順列を生成します。あとは関数 check_hukumen で数値 send, more, money を計算して、send + more = money を満たしているかチェックします。とても簡単なプログラムですね。さっそく実行してみましょう。

*Main> hukumen_solver
["9567+1085=10652"]

答えは 9567 + 1085 = 10652 の 1 通りしかありません。興味のある方は、もっとクールな方法でプログラムを作ってみてください。

●8 クイーン

「8 クイーン」はコンピュータに解かせるパズルの中でも特に有名な問題です。8 クイーンは 8 行 8 列のチェスの升目に、8 個のクイーンを互いの利き筋が重ならないように配置する問題です。クイーンは将棋の飛車と角をあわせた駒で、縦横斜めに任意に動くことができます。解答の一例を次に示します。


      図 : 8 クイーンの解答例

8 クイーンを解くには、すべての置き方を試してみるしか方法はありません。最初のクイーンは、盤上の好きなところへ置くことができるので、64 通りの置き方があります。次のクイーンは 63 通り、その次は 62 通りあります。したがって、置き方の総数は 64 から 57 までの整数を掛け算した 178462987637760 通りもあります。

ところが、解答例を見ればわかるように、同じ行と列に 2 つ以上のクイーンを置くことはできません。上図の解答例をリストを使って表すと、 次のようになります。

  1  2  3  4  5  6  7  8    <--- 列の位置
---------------------------
 [1, 7, 5, 8, 2, 4, 6, 3]   <--- 要素が行の位置を表す  


        図 : リストでの行と列の表現方法

列をリストの位置に、行番号を要素に対応させれば、各要素には 1 から 8 までの数字が重複しないで入ることになります。すなわち、1 から 8 までの順列の総数である 8! = 40320 通りの置き方を調べるだけでよいのです。パズルを解く場合は、そのパズル固有の性質をうまく使って、調べなければならない場合の数を減らすように工夫することが大切です。

あとは、その順列が 8 クイーンの条件を満たしているかチェックすればいいわけです。このように、正解の可能性があるデータを作りそれをチェックするという方法を「生成検定法 (generate and test)」といいます。覆面算の解法プログラムも単純な生成検定法です。

可能性のあるデータをもれなく作る場合、「バックトラック (backtrack)」という方法が適しています。たとえば、簡単な例として迷路を考えてみましょう。ある地点 A で道が左右に分かれているとします。ここで、左の道を選んで先へ進むと、行き止まりになってしまいました。この場合は A 地点まで戻って右の道へ進まないといけません。つまり、失敗したら後戻りして別の道を選ぶ、という試行錯誤をゴールに行き着くまで繰り返すわけです。これが「バックトラック」です。

バックトラックは再帰定義で簡単にプログラムを作ることができます。順列を生成するプログラムもバックトラックを使っています。バックトラックはパズルの解法だけではなく、いろいろな分野の問題に応用できる方法です。ただし、「生成するデータ数が多くなると時間がとてもかかる」という弱点があるので注意してください。

●プログラムの作成

それでは、プログラムを作りましょう。次のリストを見てください。

リスト : 8 クイーンの解法

safe :: [Int] -> Bool
safe [] = True
safe (x:xs) = if attack 1 x xs then False else safe xs

queen :: [Int] -> [[Int]]
queen xs = filter safe $ permutations xs

述語 safe は 8 クイーンの条件を満たしているかチェックします。関数 queen は permutations で順列を生成し、filter で safe を満たす順列だけを取り出します。関数 safe はリストの先頭の要素からチェックしていきます。衝突のチェックは斜めの利き筋を調るだけです。端にあるクイーンから順番に調べるとすると、斜めの利き筋は次のように表せます。

    1 2 3    --> 調べる方向
  *-------------
  | . . . . . .
  | . . . -3. .  5 - 3 = 2
  | . . -2. . .  5 - 2 = 3
  | . -1. . . .  5 - 1 = 4
  | Q . . . . .  Q の位置は 5  
  | . +1. . . .  5 + 1 = 6
  | . . +2. . .  5 + 2 = 7
  | . . . +3. .  5 + 2 = 8
  *-------------


    図 : 衝突の検出

図を見てもらえばおわかりのように、Q が行 5 にある場合、ひとつ隣の列は 4 と 6 が利き筋に当たります。2 つ隣の列の場合は 3 と 7 が利き筋に当たります。このように単純な足し算と引き算で、利き筋を計算することができます。これをプログラムすると次のようになります。

リスト : 衝突の検出

attack :: Int -> Int -> [Int] -> Bool
attack _ _ []     = False
attack n x (y:ys) =
  if x == y + n || x == y - n
  then True
  else attack (n + 1) x ys

attack はリストの先頭から斜めの利き筋に当たるか調べます。第 1 引数が位置の差分、第 2 引数がクイーンの位置、第 3 引数がリストになります。最初の節がクイーンを全て調べた場合です。クイーンは衝突していないので False を返します。次の節で、リストから先頭の要素 y を取りだし、利き筋に当たるか調べます。これは、y + n または y - n が x と等しいかチェックするだけです。衝突している場合は True を返します。そうでなければ、attack を再帰呼び出しして次のクイーンを調べます。このとき、差分 n の値を +1 することをお忘れなく。

●実行結果

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

*Main> queen [1..5]
[[1,3,5,2,4],
 [1,4,2,5,3],
 [2,4,1,3,5],
 [2,5,3,1,4],
 [3,1,4,2,5],
 [3,5,2,4,1],
 [4,1,3,5,2],
 [4,2,5,3,1],
 [5,2,4,1,3],
 [5,3,1,4,2]]
*Main> queen [1..6]
[[2,4,6,1,3,5],
 [3,6,2,5,1,4],
 [4,1,5,2,6,3],
 [5,3,1,6,4,2]]
*Main> :set +s
*Main> length $ queen [1..8]
92
(0.34 secs, 133,790,632 bytes)
*Main> length $ queen [1..9]
352
(3.42 secs, 1,351,557,456 bytes)
*Main> length $ queen [1..10]
724
(37.45 secs, 14,994,424,824 bytes)

実行環境 : Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz

8 クイーンの場合、解は全部で 92 通りあります。ところで、クイーンの個数を増やすと、プログラムの実行時間は極端に遅くなります。実はこのプログラム、とても非効率なことをやっているのです。

●8 クイーンの高速化

実行速度が遅い理由は、失敗することがわかっている順列も生成してしまうからです。たとえば、最初 (1, 1) の位置にクイーンを置くと、次のクイーンは (2, 2) の位置に置くことはできませんね。したがって、[1, 2, X, X, X, X, X, X,] という配置はすべて失敗するのですが、順列を発生させてからチェックする方法では、このような無駄を省くことができません。

そこで、クイーンの配置を決めるたびに衝突のチェックを行うことにします。これをプログラムすると次のようになります。

リスト : 8 クイーン (改良版)

-- 要素の選択
select :: [a] -> [(a, [a])]
select [x]    = [(x, [])]
select (x:xs) = (x, xs) : map (\(y, ys) -> (y, x:ys)) (select xs)

-- クイーンの選択
select_queen :: ([Int], [Int]) -> [([Int], [Int])]
select_queen (xs, ys) =
  foldr (\(z, zs) a -> if attack 1 z ys then a else (zs, z:ys):a) [] $ select xs

-- 8 クイーンの解法
queen_fast :: [Int] -> [[Int]]
queen_fast xs = iter (length xs) [(xs, [])] where
  iter 0 xs = map snd xs
  iter n xs = iter (n - 1) $ concatMap select_queen xs

select は順列の生成で作成した関数です。関数 select_queen は、クイーンを配置したリストと残りのリストをタプルで受け取ります。第 1 要素 xs が残りのリスト、第 2 要素 ys がクイーンを配置したリストです。foldr でクイーンを配置できたタプルだけを集めます。select xs で xs から要素をひとつ選びます。ラムダ式の引数 z が選んだ要素、zs が残りの要素のリストです。attack で z を ys に追加できるかチェックし、大丈夫であれば (zs, z:ys) を累積変数 a のリストに追加します。そうでなければ a をそのまま返します。

select_queen の実行例を示します。

*Main> select_queen ([1,2,3,4], [])
[([2,3,4],[1]),([1,3,4],[2]),([1,2,4],[3]),([1,2,3],[4])]
*Main> select_queen ([2,3,4], [1])
[([2,4],[3,1]),([2,3],[4,1])]
*Main> select_queen ([2,4], [3,1])
[]

select_queen を使うと、8 クイーンの解法プログラム queen_fast は簡単です。実際の処理は局所関数 iter で行います。iter の引数 xs はタプル (残りのリスト, クイーンのリスト) を格納したリストです。concatMap で xs に select_queen を適用して、その結果を平坦化します。1 回実行すると、1 つのクイーンを配置したリストが得られ、2 回実行すると、2 つのクイーンを配置したリストが得られます。あとは、クイーンの個数だけ繰り返して、タプルの第 2 要素を map snd で取り出すだけです。

このように、できるだけ早い段階でチェックを入れることで、無駄なデータをカットすることを「枝刈り」と呼びます。バックトラックを使って問題を解く場合、この枝刈りのよしあしによって実行時間が大きく左右されます。ところが、枝刈りの方法はパズルによって違います。パズル固有の性質をよく調べて、適切な枝刈りを考えることが重要なのです。パズル自体はコンピュータに解かせるのですが、枝刈りの条件は私達が考えるのです。これも「パズルの解法」の面白いところでしょう。解を求めるだけでなく、いかに効率の良い条件を見つけて実行時間を短縮するか、ということでも楽しむことができます。

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

*Main> length $ queen_fast [1..8]
92
(0.05 secs, 12,215,888 bytes)
*Main> length $ queen_fast [1..9]
352
(0.20 secs, 57,988,728 bytes)
*Main> length $ queen_fast [1..10]
724
(0.79 secs, 286,276,160 bytes)

インタプリタ ghci での実行ですが、とても速くなりましたね。枝刈りの効果は十分に出ていると思います。

ところで、「リストモナド」を使うと、もっと簡単にプログラムを作ることができます。ご参考までに、順列の生成と 8 クイーンの解法プログラムを示します。

リスト : 順列の生成と 8 クイーンの解法

import Control.Monad

-- 順列の生成
permutation' :: Eq a => [a] -> [[a]]
permutation' xs = iter xs [] where
  iter [] ys = return (reverse ys)
  iter xs ys = do
    x <- xs
    iter (filter (/=x) xs) (x:ys)

-- 8 クイーンの解法
queen_m :: [Int] -> [[Int]]
queen_m xs = queen' xs [] where
  queen' [] ys = return (reverse ys)
  queen' xs ys = do
    x <- xs
    guard(not (attack 1 x ys))
    queen' (filter (/=x) xs) (x:ys)

リストモナドは「非決定性」をシミュレートすることができます。拙作のページ お気楽 Scheme プログラミング入門 非決定性 をお読みの方であれば、リストモナドは bag_of と同じ働きをしていて、x <- xs が amb で、guard が assert で、return は解をリスト (bag) に格納すると考えると、やっていることはなんとなくわかると思います。詳しい説明は モナド (1) をお読みください。

このほかにも、Haskell らしいクールな解き方があると思います。興味のある方は挑戦してみてください。

●マスターマインド

パズルではありませんが、簡単な例題として「マスターマインド」を解くプログラムを作りましょう。マスターマインドは拙作のページ お気楽 Scheme プログラミング入門 数当てゲーム [2] で作成した、0 から 9 までの重複しない 4 つの数字からなる隠しコードを当てるゲームです。数字は合っているが位置が間違っている個数を cows で表し、数字も位置も合っている個数を bulls で表します。bulls が 4 になると正解です。

     [6, 2, 8, 1] : 正解
-------------------------------------
1.   [0, 1, 2, 3] : cows 2 : bulls 0
2.   [1, 0, 4, 5] : cows 1 : bulls 0
3.   [2, 3, 5, 6] : cows 2 : bulls 0
4.   [3, 2, 7, 4] : cows 0 : bulls 1
5.   [3, 6, 0, 8] : cows 2 : bulls 0
6.   [6, 2, 8, 1] : cows 0 : bulls 4


   図 : マスターマインドの動作例

今回は、私達が出した問題をコンピュータに答えてもらうことにします。それはちょっと難しいのではないか、と思った人もいるかもしれませんね。ところが、とても簡単な方法があるのです。このゲームでは、10 個の数字の中から 4 個選ぶわけですから、全体では 10 * 9 * 8 * 7 = 5040 通りのコードしかありません。コードを生成する処理は順列と同じですから、簡単にプログラムできます。

●推測アルゴリズム

次に、この中から正解を見つける方法ですが、質問したコードとその結果を覚えておいて、それと矛盾しないコードを作るようにします。具体的には、4 つの数字の順列を生成し、それが今まで質問したコードと矛盾しないことを確かめます。これは生成検定法と同じですね。

矛盾しているかチェックする方法も簡単で、以前に質問したコードと比較して、bulls と cows が等しいときは矛盾していません。たとえば、次の例を考えてみてください。

[6, 2, 8, 1] が正解の場合

[0, 1, 2, 3] =>, bulls = 0, cows = 2

           [0, 1, 2, 3]  と比較する
     --------------------------------------------------------
           [0, X, X, X]  0 から始まるコードは bulls = 1
                         になるので矛盾する。
           ・・・・

           [1, 0, 3, 4]  cows = 3, bulls = 0 になるので矛盾する

           ・・・・

           [1, 0, 4, 5]  cows = 2, bulls = 0 で矛盾しない。
     --------------------------------------------------------

[1, 0, 4, 5] =>, bulls = 0, cows = 1

次は、[0, 1, 2, 3] と [1, 0, 4, 5] に矛盾しない数字を選ぶ


         図 : マスターマインドの推測アルゴリズム

[0, 1, 2, 3] で bulls が 0 ですから、その位置にその数字は当てはまりません。したがって、[0, X, X, X] というコードは [0, 1, 2, 3] と比較すると bulls が 1 となるので、矛盾していることがわかります。

次に [1, 0, 3, 4] というコードを考えてみます。[0, 1, 2, 3] の結果は cows が 2 ですから、その中で合っている数字は 2 つしかないわけです。ところが、[1, 0, 3, 4] と [0, 1, 2, 3] と比較すると cows が 3 になります。当たっている数字が 2 つしかないのに、同じ数字を 3 つ使うのでは矛盾していることになりますね。

次に [1, 0, 4, 5] というコードと比較すると、bulls が 0 で cows が 2 となります。これは矛盾していないので、このコードを質問することにします。その結果が bulls = 0, cows = 1 となり、今度は [0, 1, 2, 3] と [1, 0, 4, 5] に矛盾しないコードを選択するのです。

●プログラムの作成

それでは、プログラムを作りましょう。最初に bulls と cows を求める関数を作ります。

リスト : bulls と cows を求める

-- x と等しい要素の個数をカウントする
count :: Eq a => a -> [a] -> Int
count x xs = foldl (\a y -> if x == y then a + 1 else a) 0 xs

-- bulls を数える
count_bulls :: [Int] -> [Int] -> Int
count_bulls xs ys = count True $ zipWith (==) xs ys

-- 同じ数字を数える
count_same_number :: [Int] -> [Int] -> Int
count_same_number xs ys = length $ intersect xs ys

-- bulls と cows を求める
check_code :: [Int] -> [Int] -> (Int, Int)
check_code code1 code2 = (bulls, cows)
  where bulls = count_bulls code1 code2
        cows  = count_same_number code1 code2 - bulls

関数 count x xs は x と等しい要素の個数を返します。関数 count_bulls は count と zipWith を使うと簡単です。zipWith は 2 つのリストを受け取るマップ関数です。簡単な実行例を示しましょう。

*Main> :t zipWith
zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
*Main> zipWith (==) [1,2,3,4] [1,2,3,4]
[True,True,True,True]
*Main> zipWith (==) [1,2,3,4] [4,3,2,1]
[False,False,False,False]
*Main> zipWith (+) [1,2,3,4] [4,3,2,1]
[5,5,5,5]
*Main> zipWith (*) [1,2,3,4] [4,3,2,1]
[4,6,6,4]

zipWith で 2 つの要素の等値を判定し、count で True の個数を数えれば bulls を求めることができます。

次は、cows を数える処理を作ります。いきなり cows を数えようとすると難しいのですが、2 つのリストに共通の数字を数えることは簡単にできます。この方法では、bulls の個数を含んだ数を求めることになりますが、そこから bulls を引けば cows を求めることができます。

関数名は count_same_number としました。この処理は Data.List の関数 intersect を使うと簡単です。intersect xs ys は引数のリストを集合とみなして、xs と ys の積集合を求める関数です。これで xs と ys の共通の要素を取り出すことができます。あとは length で個数を数えるだけです。

関数 check_code は 2 つのコードを受け取り、bulls と cows を求めてタプルに格納して返します。

次は生成したコードが今までの結果と矛盾していないか調べる処理を作ります。次のリストを見てください。

リスト : 今までの質問と矛盾しているか

check_query :: [Int] -> ([Int], Int, Int) -> Bool
check_query code (old_code, old_bulls, old_cows) =
  bulls == old_bulls && cows == old_cows
  where (bulls, cows) = check_code code old_code

select_code :: [Int] -> [([Int], Int, Int)] -> [Int] -> [([Int], Int, Int)]
select_code collect query code =
  if all (check_query code) query
  then (code, bulls, cows) : query
  else query
  where (bulls, cows) = check_code collect code

質問したコードとその結果はタプル (code, bulls, cows) にまとめてリストに格納します。最初が質問したコード、次が bulls の個数、最後が cows の個数です。

関数 check_query はデータをパターンマッチングで取り出して、局所変数 old_bulls, old_cows, old_code にセットします。そして、code と old_colde から bulls と cows を check_code で求めます。bulls と old_bulls が等しくて、cows と old_cows が等しい場合、code は矛盾していないので、true を返します。そうでなれば false を返します。

関数 select_code は質問するコードを選択します。引数 collect が正解のコード、query が今まで質問したコードと結果を格納したリスト、code が生成したコードです。最初に関数 all と check_query で code が今までの質問と矛盾していないかチェックします。

all pred xs は述語 pred をリスト xs の要素に適用し、返り値がすべて真であれば all は真を返します。簡単な実行例を示します。

*Main> :t all
all :: (a -> Bool) -> [a] -> Bool
*Main> all even [2,4,6,8,10]
True
*Main> all even [2,4,6,8,1]
False

select_code は code に矛盾がなければ、check_code で collect と code の bulls と cows を求め、タプルに格納して qyery に追加して返します。そうでなければ、query をそのまま返します。

マスターマインドを解くプログラムは次のようになります。

リスト : マスターマインドの解法

mastermind :: [Int] -> [([Int], Int, Int)]
mastermind collect =
  reverse $ foldl (select_code collect) [] (permutation 4 [0 .. 9])

前回作成した関数 permutation でリスト [0 .. 9] から 4 個の数字を選ぶ順列を生成します。あとは foldl でコードを順番に取り出して、select_code collect を呼び出すだけです。質問したコードは逆順に格納されるので、最後に reverse で反転します。

●何回で当たるか

これでプログラムは完成です。それでは実行例を示しましょう。

*Main> mastermind [9,8,7,6]
[([0,1,2,3],0,0),
 ([4,5,6,7],0,2),
 ([5,4,8,9],0,2),
 ([6,7,9,8],0,4),
 ([8,9,7,6],2,2),
 ([9,8,7,6],4,0)]
*Main> mastermind [9,4,3,1]
[([0,1,2,3],0,2),
 ([1,0,4,5],0,2),
 ([2,3,5,4],0,2),
 ([3,4,0,6],1,1),
 ([3,5,6,1],1,1),
 ([6,5,0,2],0,0),
 ([7,4,3,1],3,0),
 ([8,4,3,1],3,0),
 ([9,4,3,1],4,0)]

肝心の質問回数ですが、5, 6 回で当たる場合が多いようです。実際に、5040 個のコードをすべて試してみたところ、平均は 5.56 回になりました。これは 参考文献 1 の結果と同じです。質問回数の最大値は 9 回で、そのときのコードは [9, 4, 3, 1], [9, 2, 4, 1], [5, 2, 9, 3], [9, 2, 0, 4], [9, 2, 1, 4] でした。

なお、参考文献 1 には平均質問回数がこれよりも少なくなる方法が紹介されています。単純な数当てゲームと思っていましたが、その奥はけっこう深いようです。興味のある方はいろいろ試してみてください。

●参考文献

  1. 田中哲郎, 「数当てゲーム (MOO, マスターマインド)」, 松原仁、竹内郁雄 編 『bit 別冊 ゲームプログラミング』 pp150 - 157, 共立出版, 1997

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

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

[ PrevPage | Haskell | NextPage ]