M.Hiroi's Home Page

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

パズルの解法 (3)

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

はじめに

今回は基本的な探索手法である「幅優先探索」を使って簡単なパズルを解いてみましょう。

●水差し問題

[問題] 水差し問題

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

「水差し問題」はいろいろな呼び方があって、「水をはかる問題」とか「水を測り出す問題」と呼ばれることもあります。

●プログラムの作成

水差し問題の場合、次に示す 3 通りの操作があります。

  1. 容器いっぱいに水を満たす。
  2. 容器を空にする。
  3. 他の容器に水を移す。

3 の操作は、容器が空になるまで水を移す場合と、もう一方の容器が満杯になるまで水を移す場合があります。容器は 2 つあるので、全部で 6 通りの操作があります。最初に、これらの操作を行う関数を定義します。プログラムは次のようになります。 

リスト : 容器の操作

-- A を空にする
transfer1 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer1 _ (a, b) = (0, b)

-- A を満たす
transfer2 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer2 (ma, _) (_, b) = (ma, b)

-- A から B へ
transfer3 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer3 (_, mb) (a, b) =
  if c >= a then (0, a + b) else (a - c, b + c)
  where c = mb - b

-- B を空にする
transfer4 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer4 _ (a, b) = (a, 0)

-- B を満たす
transfer5 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer5 (_, mb) (a, b) = (a, mb)

-- B から A へ
transfer6 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer6 (ma, _) (a, b) =
  if c >= b then (a + b, 0) else (a + c, b - c)
  where c = ma - a

状態はタプル (a, b) で表します。A は 8 リットルの容器の水の量、B は 5 リットルの容器の水の量を表します。最初の引数は容器の大きさを表し、次の引数が容器に入っている水の量を表します。容器を水で満たす、または空にする操作は簡単ですね。他の容器へ移す場合、たとえば transfer3 では、B の空き容量と A の水の量を比較して、少ない方が移す水の量になります。

あとは幅優先探索で最短手順を求めるだけです。次のリストを見てください。 

リスト : 水差し問題の解法

import Queue

solver1 :: (Int, Int) -> Int -> [(Int, Int)]
solver1 size goal = iter (singleton [(0, 0)]) where
  isGoal ((a, b):_) = a == goal || b == goal
  transfer = [transfer1, transfer2, transfer3, transfer4, transfer5, transfer6]
  check move q f =
    if news `elem` move then q else enqueue q (news:move)
    where news = f size (head move)
  iter q
    | isEmptyQueue q = []
    | otherwise =
        let (move, q1) = dequeue q
        in if isGoal move then reverse move
           else iter $ foldl (check move) q1 transfer

関数 solver1 の引数 size は容器の大きさを格納したタプル、goal は求める水の量です。実際の処理は局所関数 iter で行います。手順はタプルを格納したリストで表します。最初に [(0, 0)] をキューに格納し、キューからデータを取り出して探索を行います。

A または B に水が goal リットルあれば解を見つけることができました。reverse で move を逆順にして返します。そうでなければ、foldl で操作関数を順番に適用して、新しい状態 news を生成します。news が今までの手順 move の中に出現していれば、堂々巡りになっているのでキューに追加しません。そうでなければ、news : move をキューに追加します。この処理を関数 check で行っています。

●実行結果

結果は次のようになりました。 

ghci> solver1 (8, 5) 4
[(0,0),(0,5),(5,0),(5,5),(8,2),(0,2),(2,0),(2,5),(7,0),(7,5),(8,4)]

このように、最短手順は 10 手になります。

●数字の並べ替え

[問題]数字の並べ替え 
 ┌─┬─┬─┬─┬─┐
 │１│２│３│４│  │スタート 
 └─┴─┴─┴─┴─┘
 ┌─┬─┬─┬─┬─┐
 │  │４│３│２│１│ゴール   
 └─┴─┴─┴─┴─┘

    図 : 数字の並べ替え

上図のスタートのように並んでいる数字を、ゴールのように逆順に並べ替える最短手順を求めてください。数字を動かす規則は次のとおりです。

スタートの状態では、4 は隣が空き場所なので移動することができます。また、3 は隣に 4 がありますが、それを跳び越して空き場所へ移動することができます。ほかの数字は空き場所へ移動できません。

このパズルは、高木茂男氏の著書「パズル遊びへの招待」(PHP研究所 1994) のオンライン版にある "おしどりの遊びと入れ替え問題" を参考にさせていただきました。数字を逆順に並べることは同じですが、空き場所の位置が異なっているので少しだけ難しくなっていると思います。

●プログラムの作成

それではプログラムを作りましょう。盤面はリスト [Int] で、空き場所は 0 で表すことにします。数字を動かして新しい盤面を作る関数は次のようになります。 

リスト :  数字を動かす

movePiece :: Int -> [Int] -> [Int]
movePiece _ [] = []
movePiece n (x:xs) 
  | x == n    = 0 : movePiece n xs
  | x == 0    = n : movePiece n xs
  | otherwise = x : movePiece n xs

関数 movePiece は数字 n を空き場所の位置へ移動します。リストの要素 x が n ならば 0 に、0 ならば n に置き換えるだけです。

次は移動可能な数字を動かして新しい状態を生成する関数 makeState を作ります。 

リスト : 新しい状態を作る

-- 状態を表すデータ型
data State = State {board :: [Int], space :: Int} deriving (Eq, Show)

makeState :: State -> [State]
makeState s =
  foldr (\x a -> let b = board s
                     n = x + space s
                     p = b !! n
                 in if n < 0 || n >= length b
                    then a
                    else State (movePiece p b) n : a)
        []
        [-2, -1, 1, 2]

データ型 State は盤面 board と空き場所の位置 space を格納します。空き場所の位置を x とすると、そこに移動できる数字の位置は x - 2, x - 1, x + 1, x + 2 の 4 通りあります。あとは、その位置が盤面の範囲内にあるかチェックして、そうであれば movePiece で新しい盤面を作ります。この処理を畳み込み foldr で行っています。

最後に幅優先探索で最短手順を求めます。 

リスト : 幅優先探索

solver2 :: State -> State -> [State]
solver2 start goal = iter (singleton [start]) where
  check xs q s =
    if s `elem` xs then q else enqueue q (s:xs)
  iter q
    | isEmptyQueue q = []
    | otherwise =
        let (xs, q1) = dequeue q
            s1 = head xs
        in if s1 == goal then reverse xs
           else iter $ foldl (check xs) q1 (makeState s1)

関数 solver2 の引数 start がスタートの状態、goal がゴールの状態を表します。実際の処理は局所関数 iter で行います。手順は State を格納したリストで表します。最初に [start] をキューに格納し、キューからデータを取り出して探索を行います。

手順 xs の先頭要素 s1 が goal と等しければ、解を求めることができました。xs を反転してから返します。そうでなければ、makeState で新しい状態を生成し、それを foldl でキューに追加します。このとき、関数 check で堂々巡りしていないことをチェックします。

●実行結果

結果は次のようになりました。 

ghci> mapM_ print $ solver2 (State [1,2,3,4,0] 4) (State [0,4,3,2,1] 0)
State {board = [1,2,3,4,0], space = 4}
State {board = [1,2,0,4,3], space = 2}
State {board = [0,2,1,4,3], space = 0}
State {board = [2,0,1,4,3], space = 1}
State {board = [2,1,0,4,3], space = 2}
State {board = [2,1,4,0,3], space = 3}
State {board = [2,0,4,1,3], space = 1}
State {board = [0,2,4,1,3], space = 0}
State {board = [4,2,0,1,3], space = 2}
State {board = [4,2,3,1,0], space = 4}
State {board = [4,2,3,0,1], space = 3}
State {board = [4,0,3,2,1], space = 1}
State {board = [0,4,3,2,1], space = 0}

12 手で解くことができました。実は、これが最長手数の局面になります。

●嫉妬深い夫の問題

[問題] 嫉妬深い夫の問題

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

「嫉妬深い夫の問題」は「川渡りの問題」と呼ばれる古典的なパズルの一種です。このパズルにはたくさんのバリエーションがありますが、その中で「農夫と山羊と狼とキャベツの問題」や「宣教師と先住民」という名前のパズルが有名です。

●プログラムの作成

それではプログラムを作ります。今回は左岸から右岸へ渡ることにしましょう。まず最初に、夫婦と岸の状態を表すデータ構造を決めます。次のリストを見てください。 

リスト : データ型の定義

-- ボートの位置
data Boat = LEFT | RIGHT deriving (Show, Eq)

-- 夫婦
data Person = Ha | Wa | Hb | Wb | Hc | Wc deriving (Show, Eq)

-- 状態を表す
data State3 = State3 {boat :: Boat, left :: [Person], right :: [Person]}
  deriving Show

いろいろな方法が考えられますが、今回は 3 組の夫婦をデータ型 Person のデータ構築子 Ha, Wa, Hb, Wb, Hc, Wc で、岸の状態をリスト [Person] で表すことにします。H で始まるデータ構築子が夫、W で始まるデータ構築子が妻を表します。そして、ボートの位置を表すデータ型 Boat (LEFT or RIGHT)、左岸 left の状態 [Person]、右岸 right の状態 [Person] をデータ型 State3 に格納します。

したがって、最初の局面は State3 LEFT [Ha, Hb, Hc, Wa, Wb, Wc] [ ]、ゴールの局面は State3 RIGHT [ ] [Ha, Hb, Hc, Wa, Wb, Wc] と表すことができます。

●リストの集合演算

岸の状態はデータ構築子の集まりなので、リストを「集合 (set)」として扱うと操作が簡単になります。Haskell のモジュール Data.List に用意されているリストの集合演算を下表に示します。

表 : リストの集合演算
関数名型機能
union xs ysEq a => [a] -> [a] -> [a]xs と ys の和を求める
intersect xs ysEq a => [a] -> [a] -> [a]xs と ys の積を求める
xs \\ ysEq a => [a] -> [a] -> [a]ys に現れない xs の要素をリストにして返す (集合の差を求める)
nub xsEq a => [a] -> [a]xs の重複要素を削除する

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

ghci> nub [1,2,3,1,2,3,4,1,2,3,4,5]
[1,2,3,4,5]
ghci> union [1,2,3,4] [3,4,5,6]
[1,2,3,4,5,6]
ghci> intersect [1,2,3,4] [3,4,5,6]
[3,4]
ghci> [1,2,3,4] \\ [3,4,5,6]
[1,2]
ghci> [3,4,5,6] \\ [1,2,3,4]
[5,6]

このほかに集合 xs, ys が等しいか判定する述語が必要になります。 

リスト : 集合の等値判定

isEqSet :: Eq a => [a] -> [a] -> Bool
isEqSet xs ys = null(xs \\ ys) && null(ys \\ xs)

関数名は isEqSet としました。集合 xs と ys の差を求め、それが空リストであれば、xs は ys の部分集合 (xs ⊆ ys) であることがわかります。次に、ys と xs の差を求めます。それが空リストであれば、ys は xs の部分集合 (xs ⊇ ys) となり、 xs ⊆ ys かつ xs ⊇ ys が成り立つので、xs と ys は等しい集合であることがわかります

次に、State3 型の等値を判定する処理を作ります。 

リスト : State3 型の等値判定

instance Eq State3 where
  State3 b1 l1 r1 == State3 b2 l2 r2 =
    b1 == b2 && isEqSet l1 l2 && isEqSet r1 r2

instance 宣言で State3 型を型クラス Eq のインスタンスに設定します。Boat 型は演算子 == で比較し、左右の岸の状態は関数 isEqSet で比較します。

●安全確認

次はボートや岸の状態が安全か確認する処理を作ります。 

リスト : 安全確認

safe :: [Person] -> Bool
safe xs = null(intersect xs [Ha, Hb, Hc]) || iter xs where
  iter [] = True
  iter (Wa:ys) = if Ha `elem` xs then iter ys else False
  iter (Wb:ys) = if Hb `elem` xs then iter ys else False
  iter (Wc:ys) = if Hc `elem` xs then iter ys else False
  iter (_:ys)  = iter ys

関数 safe の引数 xs はボートまたは岸の状態を表すリストです。xs に男性がいない場合は安全です。intersect で xs と [Ha, Hb, Hc] の積を求め、それが空リストであれば男性がいないことがわかります。そうでなければ、局所関数 iter で安全を確認します。要素が女性の場合、リスト xs に夫がいることを確認します。夫がいない場合、夫以外の男性と一緒にいることになるので False を返します。

●ボートに乗る組み合わせ

次はボートに乗る組み合わせを求める処理を作ります。 

リスト : ボートに乗る組み合わせを作る

-- 組み合わせの生成
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)

selectPerson :: [Person] -> [[Person]]
selectPerson xs = filter safe $ combinations 1 xs ++ combinations 2 xs

関数 combinations はリスト xs から n 個を取り出す組み合わせを求めます。これは拙作のページ「順列と組み合わせ」で作成したプログラムと同じです。

関数 selectPerson は引数 xs からボートに乗り込む組み合わせを作ります。xs から 1 人選ぶ組み合わせと 2 人選ぶ組み合わせを求めて演算子 ++ で連結します。そして、filter で安全な状態のみを取り出して返します。

●新しい局面の生成

次はボートを動かして新しい局面を生成する処理を作ります 

リスト : ボートを動かして新しい局面を生成する

isLeft s = boat s == LEFT

toLeft :: State3 -> [Person] -> State3
toLeft s xs = State3 LEFT (union (left s) xs) ((right s) \\ xs)

toRight :: State3 -> [Person] -> State3
toRight s xs = State3 RIGHT ((left s) \\ xs) (union (right s) xs)

check :: State3 -> [State3] -> Bool
check s xs = safe (left s) && safe (right s) && s `notElem` xs

moveBoat q xs@(s:_) =
  foldl (\a x -> let s1 = if isLeft s then toRight s x else toLeft s x
                 in if check s1 xs then enqueue a (s1:xs) else a)
        q
        (selectPerson (if isLeft s then left s else right s))

関数 isLeft はボートが左岸にあるとき真を返します。関数 toLeft は xs の人達を右岸から左岸へ移動します。新しい状態は boat を LEFT に設定します。左岸は left に xs の人達を追加します。これは集合の和を求める関数 union を使うと簡単です。右岸の状態は、集合の差を求める演算子 \\ を使って、right から xs の人達を取り除きます。関数 toRight は xs の人達を左岸から右岸へ移動します。toRight は toLeft の処理と左右が反転するだけです。

関数 moveBoat は局面 s から新しい局面を生成し、それを引数のキュー q に追加します。ボートに乗る組み合わせを selectPerson で作成し、それを foldl で一つずつ取り出して新しい局面 s1 を生成します。s1 が安全な状態でかつ xs に含まれていないことを関数 check で確認します。そうであれば、s1 : xs をキューに追加します。

●幅優先探索による解法

あとは幅優先探索で最短手順を求めるだけです。 

リスト : 解法

solver3 :: [State3]
solver3 = iter (singleton [State3 LEFT person []])
  where
    person = [Ha, Wa, Hb, Wb, Hc, Wc]
    isGoal s = s == State3 RIGHT [] person
    iter q
      | isEmptyQueue q = []
      | otherwise =
          let (xs@(s:_), q1) = dequeue q
          in if isGoal s then reverse xs
             else iter $ moveBoat q1 xs

solver3 は単純な幅優先探索なので、とくに難しいところはないと思います。

●実行結果

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

ghci> mapM_ print solver3
State3 {boat = LEFT, left = [Ha,Wa,Hb,Wb,Hc,Wc], right = []}
State3 {boat = RIGHT, left = [Hb,Wb,Hc,Wc], right = [Ha,Wa]}
State3 {boat = LEFT, left = [Hb,Wb,Hc,Wc,Ha], right = [Wa]}
State3 {boat = RIGHT, left = [Hb,Hc,Ha], right = [Wa,Wb,Wc]}
State3 {boat = LEFT, left = [Hb,Hc,Ha,Wa], right = [Wb,Wc]}
State3 {boat = RIGHT, left = [Ha,Wa], right = [Wb,Wc,Hb,Hc]}
State3 {boat = LEFT, left = [Ha,Wa,Wb,Hb], right = [Wc,Hc]}
State3 {boat = RIGHT, left = [Wa,Wb], right = [Wc,Hc,Ha,Hb]}
State3 {boat = LEFT, left = [Wa,Wb,Wc], right = [Hc,Ha,Hb]}
State3 {boat = RIGHT, left = [Wc], right = [Hc,Ha,Hb,Wa,Wb]}
State3 {boat = LEFT, left = [Wc,Hc], right = [Ha,Hb,Wa,Wb]}
State3 {boat = RIGHT, left = [], right = [Ha,Hb,Wa,Wb,Wc,Hc]

11 手で解くことができました。

●プログラムリスト

--
-- puzzle03.hs : パズルの解法 (3)
--
--               Copyright (C) 2013-2021 Makoto Hiroi
--
import Data.List hiding (singleton)
import Queue

--
-- 水差し問題
--

-- A を空にする
transfer1 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer1 _ (a, b) = (0, b)

-- A を満たす
transfer2 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer2 (ma, _) (_, b) = (ma, b)

-- A から B へ
transfer3 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer3 (_, mb) (a, b) =
  if c >= a then (0, a + b) else (a - c, b + c)
  where c = mb - b

-- B を空にする
transfer4 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer4 _ (a, b) = (a, 0)

-- B を満たす
transfer5 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer5 (_, mb) (a, b) = (a, mb)

-- B から A へ
transfer6 :: (Int, Int) -> (Int, Int) -> (Int, Int)
transfer6 (ma, _) (a, b) =
  if c >= b then (a + b, 0) else (a + c, b - c)
  where c = ma - a

solver1 :: (Int, Int) -> Int -> [(Int, Int)]
solver1 size goal = iter (singleton [(0, 0)]) where
  isGoal ((a, b):_) = a == goal || b == goal
  transfer = [transfer1, transfer2, transfer3, transfer4, transfer5, transfer6]
  check move q f =
    if news `elem` move then q else enqueue q (news:move)
    where news = f size (head move)
  iter q
    | isEmptyQueue q = []
    | otherwise =
        let (move, q1) = dequeue q
        in if isGoal move then reverse move
           else iter $ foldl (check move) q1 transfer

--
-- 数字の並べ替え
--

-- 状態を表すデータ型
data State = State {board :: [Int], space :: Int} deriving (Eq, Show)

-- 数字を動かす
movePiece :: Int -> [Int] -> [Int]
movePiece _ [] = []
movePiece n (x:xs)
  | x == n    = 0 : movePiece n xs
  | x == 0    = n : movePiece n xs
  | otherwise = x : movePiece n xs

-- 状態の生成
makeState :: State -> [State]
makeState s =
  foldr (\x a -> let b = board s
                     n = x + space s
                     p = b !! n
                 in if n < 0 || n >= length b
                    then a
                    else State (movePiece p b) n : a)
        []
        [-2, -1, 1, 2]

solver2 :: State -> State -> [State]
solver2 start goal = iter (singleton [start]) where
  check xs q s =
    if s `elem` xs then q else enqueue q (s:xs)
  iter q
    | isEmptyQueue q = []
    | otherwise =
        let (xs, q1) = dequeue q
            s1 = head xs
        in if s1 == goal then reverse xs
           else iter $ foldl (check xs) q1 (makeState s1)

--
-- 嫉妬深い夫の問題
--

-- ボートの位置
data Boat = LEFT | RIGHT deriving (Show, Eq)

-- 夫婦
data Person = Ha | Wa | Hb | Wb | Hc | Wc deriving (Show, Eq)

-- 状態を表す
data State3 = State3 {boat :: Boat, left :: [Person], right :: [Person]}
  deriving Show

-- 集合の等値判定
isEqSet :: Eq a => [a] -> [a] -> Bool
isEqSet xs ys = null(xs \\ ys) && null(ys \\ xs)

-- State3 型の等値判定
instance Eq State3 where
  State3 b1 l1 r1 == State3 b2 l2 r2 =
    b1 == b2 && isEqSet l1 l2 && isEqSet r1 r2

-- 安全確認
safe :: [Person] -> Bool
safe xs = null(intersect xs [Ha, Hb, Hc]) || iter xs where
  iter [] = True
  iter (Wa:ys) = if Ha `elem` xs then iter ys else False
  iter (Wb:ys) = if Hb `elem` xs then iter ys else False
  iter (Wc:ys) = if Hc `elem` xs then iter ys else False
  iter (_:ys)  = iter ys

-- 組み合わせの生成
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)

-- ボートに乗る組み合わせを作る
selectPerson :: [Person] -> [[Person]]
selectPerson xs = filter safe $ combinations 1 xs ++ combinations 2 xs

--
-- ボートを動かして新しい局面を生成する
--

isLeft s = boat s == LEFT

toLeft :: State3 -> [Person] -> State3
toLeft s xs = State3 LEFT (union (left s) xs) ((right s) \\ xs)

toRight :: State3 -> [Person] -> State3
toRight s xs = State3 RIGHT ((left s) \\ xs) (union (right s) xs)

check :: State3 -> [State3] -> Bool
check s xs = safe (left s) && safe (right s) && s `notElem` xs

moveBoat q xs@(s:_) =
  foldl (\a x -> let s1 = if isLeft s then toRight s x else toLeft s x
                 in if check s1 xs then enqueue a (s1:xs) else a)
        q
        (selectPerson (if isLeft s then left s else right s))

solver3 :: [State3]
solver3 = iter (singleton [State3 LEFT person []])
  where
    person = [Ha, Wa, Hb, Wb, Hc, Wc]
    isGoal s = s == State3 RIGHT [] person
    iter q
      | isEmptyQueue q = []
      | otherwise =
          let (xs@(s:_), q1) = dequeue q
          in if isGoal s then reverse xs
             else iter $ moveBoat q1 xs
初版 2013 年 3 月 2 日
改訂 2021 年 1 月 24 日