Functional Programming

経路の探索 (2)

経路の探索 の続きです。今回は「反復深化」というアルゴリズムを説明します。

●反復深化

幅優先探索は最短手数を求めるのに適したアルゴリズムですが、生成する局面数が多くなると大量のメモリを必要とします。このため、メモリが不足するときは、幅優先探索を使うことができません。深さ優先探索の場合、メモリの消費量は少ないのですが、最初に見つかる解が最短手数とは限らないという問題点があります。

それでは、大量のメモリを使わずに最短手数を求める方法はないのでしょうか。実は、とても簡単な方法があるのです。それは、深さ優先探索の「深さ」に上限値を設定し、解が見つかるまで上限値を段階的に増やしていく、という方法です。

たとえば、1 手で解が見つからない場合は、2 手までを探索し、それでも見つからない場合は 3 手までを探索する、というように制限値を 1 手ずつ増やしていくわけです。このアルゴリズムを「反復深化 (iterative deeping)」といいます。

反復深化は最短手数を求めることができるアルゴリズムですが、幅優先探索と違って局面を保存する必要が無いため、必要となるメモリは深さ優先探索と同程度で済みます。また、プログラムも深さ優先探索と同じくらい簡単に作成することができます。ただし、同じ探索を何度も繰り返すため実行時間が増大するという欠点があります。ようするに、使用するメモリは少ないが実行時間が長くなるアルゴリズムなのです。

●反復深化のプログラム

それでは、同じ経路図を使って反復深化を具体的に説明しましょう。

        図 : 経路図

反復深化のプログラムはとても簡単です。設定した上限値まで深さ優先探索を行う関数を作り、上限値を１手ずつ増やしてその関数を呼び出せばいいのです。プログラムは次のようになります。

リスト : 反復深化

-- 隣接リスト
adjacent :: [[Int]]
adjacent =
  [[1,2],
   [0,2,3],
   [0,1,4],
   [1,4,5],
   [2,3,6],
   [3],
   [4]]

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

-- 反復深化
ids :: Int -> Int -> IO ()
ids start goal = iter 1 where
  dfs n m path@(x:xs)
    | n == m    = if x == goal then print (reverse path) else return ()
    | otherwise = mapM_ (dfs (n + 1) m) $ nextPath path
  iter 7 = return ()
  iter m = do
    dfs 0 m [start]
    iter (m + 1)

-- リストに格納する
ids' :: Int -> Int -> [[Int]]
ids' start goal = iter 1 where
  dfs n m ys path@(x:xs)
    | n == m    = if x == goal then reverse path : ys else ys
    | otherwise = foldl (dfs (n + 1) m) ys $ nextPath path
  iter 7 = []
  iter m = dfs 0 m [] [start] ++ iter (m + 1)

局所関数 iter で上限値を増やしていき、局所関数 dfs で深さ優先探索を行います。引数 n が経路長、引数 m が上限値を表します。n が m に達したら探索を打ち切ります。このとき、ゴールに到達したかチェックします。あとは、m の値を増やしながら dfs を呼び出せばいいわけです。関数 ids' は見つけた解をリストに格納して返します。

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

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

結果を見ればおわかりのように、最初に見つかる解が最短手数になります。このプログラムでは全ての経路を求めましたが、最短手数を求めるだけでよい場合は、解が見つかった時点で探索を終了すればいいでしょう。

●探索の一般化

ところで、深さ優先探索と幅優先探索は高階関数を使うと一般化することができます。次のリストを見てください。

リスト : 探索の一般化

-- 解をリストに格納して返す
search :: (a -> Bool) -> (a -> b) -> (b -> [a] -> [a]) -> [a] -> [a]
search _ _ _ [] = []
search isGoal nextState combine (x:xs) =
  if isGoal x then x : search isGoal nextState combine xs
  else search isGoal nextState combine (combine (nextState x) xs)

-- 解を一つだけ求める
search' :: (a -> Bool) -> (a -> b) -> (b -> [a] -> [a]) -> [a] -> Maybe a
search' _ _ _ [] = Nothing
search' isGoal nextState combine (x:xs) =
  if isGoal x then Just x 
  else search' isGoal nextState combine (combine (nextState x) xs)

関数 search はまだ調べていない局面 (state) を格納したリスト (stateList) を受け取り、その先頭から局面を取り出して新しい局面を生成することで探索を進めます。isGoal はゴールに到達したか調べる述語、nextState は現在の局面から新しい局面を生成してリストに格納して返す関数、combine は新しく生成した局面を stateList に連結する関数、最後の引数が stateList です。

最初に、stateList が空リストであれば、空リストを返して探索を終了します。次に、先頭の局面 x を取り出して、ゴールに到達しているか isGoal でチェックします。isGoal が True であれば x を search の返り値 (リスト) に追加します。そうでなければ、search を再帰呼び出しします。このとき、x に nextState を適用して新しい局面を生成し、combine で xs に追加します。チェックした局面 x は stateList から取り除くことに注意してください。

解を一つ求めるだけでよければ、関数 search' のように isGoal の返り値が True であれば Just x を返して、ここで探索を打ち切ります。解が見つからない場合は Nothing を返します。

深さ優先探索は経路を先へ先へと進めていく探索なので、stateList の先頭に新しい局面を追加することで実現できます。combine にはリストを連結する関数を渡します。演算子 ++ をカッコで囲めばカリー化関数として渡すことができます。幅優先探索はすべての経路を並行に探索していくので、stateList の末尾に新しい局面を追加することで実現できます。combine には flip (++) を渡します。ただし、演算子 ++ を使う場合、たくさんの局面が生成されると効率は悪くなります。

それでは、実際に経路の探索を行ってみましょう。

*Main> map reverse $ search (\x -> head x == 6) nextPath (++) [[0]]
[[0,1,2,4,6],[0,1,3,4,6],[0,2,1,3,4,6],[0,2,4,6]]
*Main> map reverse $ search (\x -> head x == 6) nextPath (flip (++)) [[0]]
[[0,2,4,6],[0,1,2,4,6],[0,1,3,4,6],[0,2,1,3,4,6]]
*Main> fmap reverse $ search' (\x -> head x == 6) nextPath (++) [[0]]
Just [0,1,2,4,6]
*Main> fmap reverse $ search' (\x -> head x == 6) nextPath (flip (++)) [[0]]
Just [0,2,4,6]

経路が逆順になるので reverse で反転しています。深さ優先探索と幅優先探索どちらも正常に動作していますね。

●プログラムリスト

--
-- keiro2.hs : 経路の探索 (2)
--
--             Copyright (C) 2013-2018 Makoto Hiroi
--

-- 隣接リスト
adjacent :: [[Int]]
adjacent =
  [[1,2],
   [0,2,3],
   [0,1,4],
   [1,4,5],
   [2,3,6],
   [3],
   [4]]

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

-- 反復深化
ids :: Int -> Int -> IO ()
ids start goal = iter 1 where
  dfs n m path@(x:xs)
    | n == m    = if x == goal then print (reverse path) else return ()
    | otherwise = mapM_ (dfs (n + 1) m) $ nextPath path
  iter 7 = return ()
  iter m = do
    dfs 0 m [start]
    iter (m + 1)

-- リストに格納する
ids' :: Int -> Int -> [[Int]]
ids' start goal = iter 1 where
  dfs n m ys path@(x:xs)
    | n == m    = if x == goal then reverse path : ys else ys
    | otherwise = foldl (dfs (n + 1) m) ys $ nextPath path
  iter 7 = []
  iter m = dfs 0 m [] [start] ++ iter (m + 1)

--
-- 探索の一般化
--

-- 解をリストに格納して返す
search :: (a -> Bool) -> (a -> b) -> (b -> [a] -> [a]) -> [a] -> [a]
search _ _ _ [] = []
search isGoal nextState combine (x:xs) =
  if isGoal x then x : search isGoal nextState combine xs
  else search isGoal nextState combine (combine (nextState x) xs)

-- 解を一つだけ求める
search' :: (a -> Bool) -> (a -> b) -> (b -> [a] -> [a]) -> [a] -> Maybe a
search' _ _ _ [] = Nothing
search' isGoal nextState combine (x:xs) =
  if isGoal x then Just x
  else search' isGoal nextState combine (combine (nextState x) xs)

パズルの解法 (3)

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

●水差し問題

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

●プログラムの作成

水差し問題の場合、次に示す 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 で行っています。

●実行結果

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

*Main> 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 で堂々巡りしていないことをチェックします。

●実行結果

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

*Main> 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 に用意されているリストの集合演算を下表に示します。

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

Prelude Data.List> nub [1,2,3,1,2,3,4,1,2,3,4,5]
[1,2,3,4,5]
Prelude Data.List> union [1,2,3,4] [3,4,5,6]
[1,2,3,4,5,6]
Prelude Data.List> intersect [1,2,3,4] [3,4,5,6]
[3,4]
Prelude Data.List> [1,2,3,4] \\ [3,4,5,6]
[1,2]
Prelude Data.List> [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 は単純な幅優先探索なので、とくに難しいところはないと思います。

●実行結果

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

*Main> 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
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