今回は 15 パズルで有名なスライドパズルを Haskell で解いてみましょう。
参考文献『世界のパズル百科イラストパズルワンダーランド』によると、15 パズルはアメリカのサム・ロイドが 1870 年代に考案したパズルで、彼はパズルの神様と呼ばれるほど有名なパズル作家だそうです。
┌─┬─┬─┬─┐
│１│２│３│４│
├─┼─┼─┼─┤
│５│６│７│８│
├─┼─┼─┼─┤
│９│10│11│12│
├─┼─┼─┼─┤
│13│14│15│ │
└─┴─┴─┴─┘
図 : 15 パズル
15 パズルは上図に示すように、1 から 15 までの駒を並べるパズルです。駒の動かし方は、1 回に 1 個の駒を空いている隣の場所に滑らせる、というものです。駒を跳び越したり持ち上げたりすることはできません。
15 パズルの場合、駒の配置は空き場所がどこでもいいことにすると、16! (約 2e13) 通りもあります。実際には、15 パズルの性質からその半分になるのですが、それでもパソコンで扱うにはあまりにも大きすぎる数です。そこで、盤面を一回り小さくした、1 から 8 までの数字を並べる「8 パズル」を考えることにします。
┌─┬─┬─┐ ┌─┬─┬─┐
│１│２│３│ │１│２│３│
├─┼─┼─┤ ├─┼─┼─┤
│４│５│６│ │４│５│６│
├─┼─┼─┤ ├─┼─┼─┤
│７│８│ │ │８│７│ │
└─┴─┴─┘ └─┴─┴─┘
(1) 完成形 (2) 不可能な局面
図 : 8 パズル
15 パズルは 4 行 4 列の盤ですが、8 パズルは 3 行 3 列と盤を小さくしたパズルです。8 パズルの場合、駒の配置は空き場所がどこでもいいことにすると、9! = 362880 通りあります。
15 パズルや 8 パズルの場合、参考文献『特集コンピュータパズルへの招待 スライディングブロック編』によると 『適当な 2 つの駒をつまみ上げて交換する動作を偶数回行った局面にしか移行できない』 とのことです。
上図 (2) は 7 と 8 を入れ替えただけの配置です。この場合、交換の回数が奇数回のため完成形に到達することができない、つまり解くことができないのです。
このような性質を「偶奇性（パリティ）」といいます。詳しい説明は拙作のページ Puzzle DE Programming 「偶奇性（パリティ）のお話」をお読みください。8 パズルの場合、完成形に到達する局面の総数は 9! / 2 = 181440 個となります。
それでは、プログラムを作りましょう。下図に示すスタートから完成形 (ゴール) に到達するまでの最短手数を幅優先探索で求めます。
┌─┬─┬─┐ ┌─┬─┬─┐
│８│６│７│ │１│２│３│
├─┼─┼─┤ ├─┼─┼─┤
│２│５│４│ │４│５│６│
├─┼─┼─┤ ├─┼─┼─┤
│３│ │１│ │７│８│ │
└─┴─┴─┘ └─┴─┴─┘
スタート ゴール
図 : 8 パズル
8 パズルの盤面はリストを使って表します。盤面の位置とリストの添字の対応は下図を見てください。
┌─┬─┬─┐ ┌─┬─┬─┐
│１│２│３│ │０│１│２│
├─┼─┼─┤ ├─┼─┼─┤
│４│５│６│ │３│４│５│
├─┼─┼─┤ ├─┼─┼─┤
│７│８│ │ │６│７│８│
└─┴─┴─┘ └─┴─┴─┘
盤面:[1, 2, 3, 盤面とリストの対応
4, 5, 6,
7, 8, 0]
図 : 8 パズルの盤面
空き場所は 0 で表します。隣接リストの定義は次のようになります。
リスト : 隣接リスト adjacent :: [[Int]] adjacent = [[1, 3], [0, 2, 4], [1, 5], [0, 4, 6], [1, 3, 5, 7], [2, 4, 8], [3, 7], [4, 6, 8], [5, 7]]
次は局面を表すデータ型を定義します。
リスト : 局面の定義
data State = Null | State {board :: [Int], space :: Int, piece :: Int, prev :: State}
deriving Show
型名は State としました。最初の board は盤面を表すリスト、space は空き場所の位置、piece は動かした駒の種類、prev は 1 手前の局面を格納します。
幅優先探索の場合、手数 を 1 つずつ増やしながら探索を行います。このため、n 手目の移動で作られた局面が n 手以前の局面で出現している場合、n 手より短い手数で到達する移動手順が必ず存在します。最短手順を求めるのであれば、この n 手の手順を探索する必要はありません。同一局面があるかチェックして新しい局面だけをキューに追加します。ゴールに到達したら、prev をたどって手順を表示します。終端は Null で表します。
キューは自作したモジュール Queue.hs を使うことにします。それから、同一局面をチェックするとき、単純な線形探索では時間がかかりすぎるので、今回は自作したモジュール TreeMap.hs を使うことにしましょう。盤面 (リスト) をキーにマップを作成すると、リストの比較に時間がかかるので動作が遅くなってしまいます。そのため、盤面を整数値に変換し、それをキーとして使うことにします。盤面を整数値に変換する関数は次のようになります。
リスト : 盤面を数値に変換する makeKey :: [Int] -> Int makeKey xs = foldl (\a x -> a * 10 + x) 0 xs
関数 makeKey は盤面 xs を 10 進数と考えて、それを整数値に変換します。
次は駒を動かす関数 movePiece を作ります。
リスト : 駒を動かす movePiece :: [Int] -> Int -> [Int] movePiece [] _ = [] movePiece (x:xs) p | x == 0 = p : movePiece xs p | x == p = 0 : movePiece xs p | otherwise = x : movePiece xs p
2 番目の引数 p が動かす駒の種類です。x が 0 (空き場所) ならば p に置き換えます。x が p ならば 0 に置き換えます。あとの駒はそのままにします。
次は駒を動かして新しい局面を生成する関数 makeState を作ります。
リスト : 新しい局面を作る
makeState :: State -> [State]
makeState s =
foldr (\x a -> let p = board s !! x
in if piece s == p then a
else let b = movePiece (board s) p
in State b x p s : a)
[]
(adjacent !! space s)
makeState は新しい局面を格納したリストを返します。空き場所の隣の位置を隣接リストから求め、それを foldr に渡します。ラムダ式の中で、動かす駒の種類を変数 p にセットし、それが局面 s で動かした駒と一致するならば、元の局面に戻ってしまいます。この場合は累積変数 a をそのまま返します。そうでなければ、movePiece で新しい盤面を生成し、それを State に格納して返します。
最後に幅優先探索で最短手順を求めるプログラムを作ります。
リスト : 解法
-- 手順をリストに格納する
make_answer :: State -> [[Int]]
make_answer state = iter state [] where
iter Null xs = xs
iter s xs = iter (prev s) (board s : xs)
-- 幅優先探索
solver :: [Int] -> [Int] -> [[Int]]
solver start goal = iter (que, tree) where
ss = State start (fromJust (elemIndex 0 start)) 0 Null
que = Queue.singleton ss
tree = insert (makeKey start) ss emptyTree
check (q, t) s =
let k = makeKey (board s)
in case search k t of
Nothing -> (enqueue q s, insert k s t)
Just _ -> (q, t)
iter (q, t)
| isEmptyQueue q = []
| otherwise =
let (s, q1) = dequeue q
in if goal == board s then make_answer s
else iter $ foldl check (q1, t) (makeState s)
main :: IO ()
main = do
print $ solver [8,6,7,2,5,4,3,0,1] [1,2,3,4,5,6,7,8,0]
関数 solver は幅優先探索で 8 パズルの最短手順を求めます。引数 start がスタートの盤面、goal がゴールの盤面です。実際の処理は局所関数 iter で行います。最初に start の盤面から State 型のデータを作成し、キューとマップにセットします。このキューとマップをタプルに格納して iter に渡します。
なお、今回のプログラムは TreeMap を同一局面のチェックだけに使っているので、局面を格納する必要はありません。ユニット ( ) を格納してもいいですし、TreeMap ではなく Tree.hs を使ってもかまいません。今後の改良 (高速化) に備えて TreeMap を使っています。
空き場所 (0) の位置を求めるため関数 elemIndex を使います。elemIndex はモジュール Data.List に定義されている関数で、データを探索してその位置を返します。簡単な例を示しましょう。
ghci> :t elemIndex elemIndex :: Eq a => a -> [a] -> Maybe Int ghci> elemIndex 15 [11..20] Just 4 ghci> elemIndex 11 [11..20] Just 0 ghci> elemIndex 20 [11..20] Just 9 ghci> elemIndex 0 [11..20] Nothing
関数 fromJust はモジュール Data.Maybe に定義されている関数で、Just に格納されているデータを取り出して返します。Nothing の場合はエラーを送出します。簡単な例を示しましょう。
ghci> :t fromJust fromJust :: Maybe a -> a ghci> fromJust (Just 10) 10 ghci> fromJust Nothing *** Exception: Maybe.fromJust: Nothing
iter はキューにデータがある間、キューからデータを取り出して探索を行います。キューが空になった場合、解が見つからなかったので空リスト [ ] を返します。そうでなければ、キューからデータを取り出して、goal に到達したかチェックします。解が見つかれば、関数 make_answer で最短手順を返します。
ゴールに到達していない場合は、makeState で新しい局面を生成し、foldl に渡してキューとマップに追加します。このとき、関数 check で同一局面のチェックを行います。関数 search でマップを探索し、返り値が Nothing であれば新しい局面です。新しいキューとマップを作って返します。Just であれば s と同じ局面が見つかったので、(q, t) をそのまま返します。
これでプログラムは完成です。インタプリタ ghci では動作が遅いので GHC でコンパイルします。ファイル名は eight.hs とします。eight.hs と同じディレクトリにモジュール Queue.hs と TreeMap.hs を置いてください。GHC の場合、プログラムのコンパイルは簡単です。
$ stack ghc -- -O eight.hs [1 of 4] Compiling Queue ( Queue.hs, Queue.o ) [2 of 4] Compiling TreeMap ( TreeMap.hs, TreeMap.o ) [3 of 4] Compiling Main ( eight.hs, eight.o ) [4 of 4] Linking eight $
それでは実行してみましょう。
$ ./eight [[8,6,7,2,5,4,3,0,1],[8,6,7,2,0,4,3,5,1],[8,0,7,2,6,4,3,5,1],[0,8,7,2,6,4,3,5,1], [2,8,7,0,6,4,3,5,1],[2,8,7,3,6,4,0,5,1],[2,8,7,3,6,4,5,0,1],[2,8,7,3,6,4,5,1,0], [2,8,7,3,6,0,5,1,4],[2,8,0,3,6,7,5,1,4],[2,0,8,3,6,7,5,1,4],[2,6,8,3,0,7,5,1,4], [2,6,8,0,3,7,5,1,4],[2,6,8,5,3,7,0,1,4],[2,6,8,5,3,7,1,0,4],[2,6,8,5,3,7,1,4,0], [2,6,8,5,3,0,1,4,7],[2,6,0,5,3,8,1,4,7],[2,0,6,5,3,8,1,4,7],[2,3,6,5,0,8,1,4,7], [2,3,6,0,5,8,1,4,7],[2,3,6,1,5,8,0,4,7],[2,3,6,1,5,8,4,0,7],[2,3,6,1,5,8,4,7,0], [2,3,6,1,5,0,4,7,8],[2,3,0,1,5,6,4,7,8],[2,0,3,1,5,6,4,7,8],[0,2,3,1,5,6,4,7,8], [1,2,3,0,5,6,4,7,8],[1,2,3,4,5,6,0,7,8],[1,2,3,4,5,6,7,0,8],[1,2,3,4,5,6,7,8,0]]
31 手で解くことができました。実行時間は 1.64 秒 (Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz) かかりました。実行速度はそれほど速くありません。TreeMap.hs のかわりに Data.Map または Data.IntMap を使うともっと速くなります。
8 パズルの場合、最長手数は 31 手で、下図に示す 2 通りの局面があります。スタートの局面はその一つです。
┌─┬─┬─┐ ┌─┬─┬─┐
│８│６│７│ │６│４│７│
├─┼─┼─┤ ├─┼─┼─┤
│２│５│４│ │８│５│ │
├─┼─┼─┤ ├─┼─┼─┤
│３│ │１│ │３│２│１│
└─┴─┴─┘ └─┴─┴─┘
図 : 31 手で解ける局面
最長手数の局面は、幅優先探索を使って求めることができます。これはあとで試してみましょう。
それでは、TreeMap.hs のかわりに Data.IntMap を使ってみましょう。Data.IntMap はキーのデータ型を Int に限定したマップです。使い方は Data.Map とほぼ同じです。
なお、Haskell のマニュアルによると Data.IntMap のアルゴリズムは平衡木ではなく、「パトリシア木 (patricia tree)」をベースに実装されているそうです。パトリシア木の基本的なことは、拙作のページ Algorithms with Python 「トライとパトリシア」をお読みくださいませ。
プログラムは次のようになります。
リスト : 8 パズルの解法 (Data.IntMap を使う場合)
solver' :: [Int] -> [Int] -> [[Int]]
solver' start goal = iter (que, tree) where
ss = State start (fromJust (elemIndex 0 start)) 0 Null
que = Queue.singleton ss
tree = Map.singleton (makeKey start) ss
check (q, t) s =
let k = makeKey (board s)
in if Map.member k t
then (q, t)
else (enqueue q s, Map.insert k s t)
iter (q, t)
| isEmptyQueue q = []
| otherwise =
let (s, q1) = dequeue q
in if goal == board s then make_answer s
else iter $ foldl check (q1, t) (makeState s)
main :: IO ()
main = do
-- print $ solver [8,6,7,2,5,4,3,0,1] [1,2,3,4,5,6,7,8,0]
print $ solver' [8,6,7,2,5,4,3,0,1] [1,2,3,4,5,6,7,8,0]
Data.IntMap は qualified 付きでインポートし、Map という別名を付けます。Map.singleton でマップを生成し、Map.member で同一局面があるかチェックします。True を返す場合は同一局面が見つかったので (q, t) をそのまま返します。そうでなければ、キューとマップにデータを追加して返します。
実行時間は次のようになりました。
TreeMap.hs : 1.64 秒 Data.IntMap : 0.76 秒
Data.IntMap は約二倍速くなりました。Haskell のモジュール Data.IntMap で使用されているパトリシア木の性能はとても優秀なようです。
次は、最長手数の局面を求めてみましょう。最長手数の求め方ですが、181440 通りの配置の最短手数がすべてわかれば、最長の手数となる配置を求めることができます。しかし、この方法では時間がとてもかかりそうです。そこで、完成形から始めていちばん長い手数の局面を生成することにします。
まず、完成形から駒を動かして 1 手で到達する局面をすべて作ります。次に、これらの局面から駒を動かして新しい局面を作れば、完成形から 2 手で到達する局面となります。このように、手数を 1 手ずつ伸ばしていき、新しい局面が生成できなくなった時点での手数が求める最長手数となります。この処理は幅優先探索を使えばぴったりです。
それではプログラムを作ります。次のリストを見てください。
リスト : 8 パズルの最長手数を求める
max_solver start = iter [ss] tree where
ss = State start (fromJust (elemIndex 0 start)) 0 Null
tree = Map.singleton (makeKey start) ss
check (a, t) s =
let k = makeKey (board s)
in if Map.member k t
then (a, t)
else (s:a, Map.insert k s t)
iter xs t =
if null ys then map make_answer xs else iter ys t'
where (ys, t') = foldl check ([], t) $ concatMap makeState xs
main :: IO ()
main = do
-- print $ solver [8,6,7,2,5,4,3,0,1] [1,2,3,4,5,6,7,8,0]
-- print $ solver' [8,6,7,2,5,4,3,0,1] [1,2,3,4,5,6,7,8,0]
print $ max_solver [1,2,3,4,5,6,7,8,0]
局所関数 iter は n 手の局面を格納したリストを第 1 引数 xs に受け取ります。そして、そこから n + 1 手の局面を生成してリストに格納し、変数 ys にセットします。もしも、ys が空リストであれば、xs の局面が最長手数の局面となります。そうでなければ、iter を再帰呼び出しして探索処理を続行します。
新しい局面は concatMap makeState xs で生成して、それを foldl に渡します。そして、関数 check で同一局面のチェックを行い、新しい局面であれば、それを累積変数 a のリストとマップに追加します。
さっそく実行してみましょう。
[[[1,2,3,4,5,6,7,8,0],[1,2,3,4,5,0,7,8,6],[1,2,3,4,0,5,7,8,6],[1,2,3,4,8,5,7,0,6], [1,2,3,4,8,5,0,7,6],[1,2,3,0,8,5,4,7,6],[1,2,3,8,0,5,4,7,6],[1,0,3,8,2,5,4,7,6], [1,3,0,8,2,5,4,7,6],[1,3,5,8,2,0,4,7,6],[1,3,5,8,2,6,4,7,0],[1,3,5,8,2,6,4,0,7], [1,3,5,8,0,6,4,2,7],[1,0,5,8,3,6,4,2,7],[0,1,5,8,3,6,4,2,7],[8,1,5,0,3,6,4,2,7], [8,1,5,3,0,6,4,2,7],[8,1,5,3,2,6,4,0,7],[8,1,5,3,2,6,0,4,7],[8,1,5,0,2,6,3,4,7], [8,1,5,2,0,6,3,4,7],[8,0,5,2,1,6,3,4,7],[8,5,0,2,1,6,3,4,7],[8,5,6,2,1,0,3,4,7], [8,5,6,2,1,7,3,4,0],[8,5,6,2,1,7,3,0,4],[8,5,6,2,0,7,3,1,4],[8,0,6,2,5,7,3,1,4], [8,6,0,2,5,7,3,1,4],[8,6,7,2,5,0,3,1,4],[8,6,7,2,5,4,3,1,0],[8,6,7,2,5,4,3,0,1]], [[1,2,3,4,5,6,7,8,0],[1,2,3,4,5,0,7,8,6],[1,2,3,4,0,5,7,8,6],[1,2,3,4,8,5,7,0,6], [1,2,3,4,8,5,7,6,0],[1,2,3,4,8,0,7,6,5],[1,2,0,4,8,3,7,6,5],[1,0,2,4,8,3,7,6,5], [0,1,2,4,8,3,7,6,5],[4,1,2,0,8,3,7,6,5],[4,1,2,7,8,3,0,6,5],[4,1,2,7,8,3,6,0,5], [4,1,2,7,0,3,6,8,5],[4,1,2,0,7,3,6,8,5],[4,1,2,6,7,3,0,8,5],[4,1,2,6,7,3,8,0,5], [4,1,2,6,7,3,8,5,0],[4,1,2,6,7,0,8,5,3],[4,1,0,6,7,2,8,5,3],[4,0,1,6,7,2,8,5,3], [4,7,1,6,0,2,8,5,3],[4,7,1,6,5,2,8,0,3],[4,7,1,6,5,2,8,3,0],[4,7,1,6,5,0,8,3,2], [4,7,0,6,5,1,8,3,2],[4,0,7,6,5,1,8,3,2],[0,4,7,6,5,1,8,3,2],[6,4,7,0,5,1,8,3,2], [6,4,7,8,5,1,0,3,2],[6,4,7,8,5,1,3,0,2],[6,4,7,8,5,1,3,2,0],[6,4,7,8,5,0,3,2,1]]]
最長手数は 31 手で、その配置は全部で 2 通りになります。実行時間は 0.59 秒になりました。
ところで、今回の 8 パズルようにゴールの状態が明確な場合、スタートから探索するだけではなくゴールからも探索を行うことで、幅優先探索を高速化することができます。これを「双方向探索 (bi-directional search)」といいます。
その理由を説明するために、簡単なシミュレーションをしてみましょう。たとえば、1 手進むたびに 3 つの局面が生成され、5 手で解けると仮定します。すると、n 手目で生成される局面は 3 の n 乗個になるので、初期状態から単純に探索すると、生成される局面の総数は、3 + 9 + 27 + 81 + 243 = 363 個となります。
これに対し、初期状態と終了状態から同時に探索を始めた場合、お互い 3 手まで探索した時点で同じ局面に到達する、つまり、解を見つけることができます。この場合、生成される局面の総数は 3 手目までの局面数を 2 倍した 78 個となります。
生成される局面数はぐっと少なくなりますね。局面数が減少すると同一局面の探索処理に有利なだけではなく、「キューからデータを取り出して新しい局面を作る」という根本的な処理のループ回数を減らすことになるので、処理速度は大幅に向上するのです。
それではプログラムを作りましょう。単純に考えると、2 つの探索処理を交互に行うことになりますが、そうするとプログラムの大幅な修正が必要になります。ここは、探索方向を示すフラグを用意することで、一つのキューだけで処理することにしましょう。局面を表す State 型に方向を格納するデータ型 Dir を追加します。
リスト : 局面の定義 (双方向からの探索)
-- 方向を表すデータ型
data Dir = F | B deriving (Show, Eq)
-- 局面を表すデータ型
data State = Null | State {board :: [Int], space :: Int, piece :: Int, dir :: Dir, prev :: State}
deriving Show
スタートからの探索を F で、ゴールからの探索を B で表ます。双方向探索のプログラムは次のようになります。
リスト : 双方向探索
solver :: [Int] -> [Int] -> [[Int]]
solver start goal = iter que Map.empty where
gs = State goal (fromJust (elemIndex 0 goal)) 0 B Null
ss = State start (fromJust (elemIndex 0 start)) 0 F Null
que = enqueue (singleton ss) gs
iter q t
| isEmptyQueue q = []
| otherwise =
let (s, q1) = dequeue q
k = makeKey (board s)
in case Map.lookup k t of
Nothing -> iter (foldl enqueue q1 (makeState s)) (Map.insert k s t)
Just s1 -> if dir s1 /= dir s then make_answer s s1
else iter q1 t
スタートとゴールの局面を生成してキューにセットします。スタートの局面は F をセットし、ゴールの局面は B をセットします。最初に、スタートの状態から 1 手目の局面が生成され、次にゴールの状態から 1 手目の局面が生成されます。あとは、交互に探索が行われます。
駒の移動と局面の生成処理は幅優先探索と同じです。キューから局面 s を取り出し、それがマップに登録されているか関数 Map.lookup でチェックします。返り値が Nothing であれば、同じ局面はないので s をマップに追加し、新しい局面を生成してキューに追加します。
返り値が Just の場合は s と同じ盤面の局面があります。方向を比較して異なる場合、解が見つかったので関数 make_answer で最短手順を返します。そうでなければ、キューとマップをそのまま iter に渡して再帰呼び出しします。
あとのプログラムは簡単なので説明は割愛いたします。詳細はプログラムリスト２をお読みください。
さっそく実行してみると実行時間は 0.043 秒、約 17 倍速くなりました。双方向探索の効果はとても大きいと思います。
--
-- eight.hs : 8 パズル
--
-- Copyright (C) 2013-2021 Makoto Hiroi
--
import Data.List (elemIndex)
import Data.Maybe
import Queue
import TreeMap
import qualified Data.IntMap as Map
{- 盤面
0 1 2
3 4 5
6 7 8 -}
-- 隣接リスト
adjacent :: [[Int]]
adjacent =
[[1, 3],
[0, 2, 4],
[1, 5],
[0, 4, 6],
[1, 3, 5, 7],
[2, 4, 8],
[3, 7],
[4, 6, 8],
[5, 7]]
-- 局面を表すデータ型
data State = Null | State {board :: [Int], space :: Int, piece :: Int, prev :: State}
deriving Show
-- 盤面を数値に変換する
makeKey :: [Int] -> Int
makeKey xs = foldl (\a x -> a * 10 + x) 0 xs
-- ピースを動かす
movePiece :: [Int] -> Int -> [Int]
movePiece [] _ = []
movePiece (x:xs) p
| x == 0 = p : movePiece xs p
| x == p = 0 : movePiece xs p
| otherwise = x : movePiece xs p
-- 新しい局面を作る
makeState :: State -> [State]
makeState s =
foldr (\x a -> let p = board s !! x
in if piece s == p then a
else let b = movePiece (board s) p
in State b x p s : a)
[]
(adjacent !! space s)
-- 手順をリストに格納する
make_answer :: State -> [[Int]]
make_answer state = iter state [] where
iter Null xs = xs
iter s xs = iter (prev s) (board s : xs)
-- 解法
solver :: [Int] -> [Int] -> [[Int]]
solver start goal = iter (que, tree) where
ss = State start (fromJust (elemIndex 0 start)) 0 Null
que = Queue.singleton ss
tree = insert (makeKey start) ss emptyTree
check (q, t) s =
let k = makeKey (board s)
in case search k t of
Nothing -> (enqueue q s, insert k s t)
Just _ -> (q, t)
iter (q, t)
| isEmptyQueue q = []
| otherwise =
let (s, q1) = dequeue q
in if goal == board s then make_answer s
else iter $ foldl check (q1, t) (makeState s)
-- Data.IntMap を使う
solver' :: [Int] -> [Int] -> [[Int]]
solver' start goal = iter (que, tree) where
ss = State start (fromJust (elemIndex 0 start)) 0 Null
que = Queue.singleton ss
tree = Map.singleton (makeKey start) ss
check (q, t) s =
let k = makeKey (board s)
in if Map.member k t
then (q, t)
else (enqueue q s, Map.insert k s t)
iter (q, t)
| isEmptyQueue q = []
| otherwise =
let (s, q1) = dequeue q
in if goal == board s then make_answer s
else iter $ foldl check (q1, t) (makeState s)
-- 最長手数を求める
max_solver :: [Int] -> [[[Int]]]
max_solver start = iter [ss] tree where
ss = State start (fromJust (elemIndex 0 start)) 0 Null
tree = Map.singleton (makeKey start) ss
check (a, t) s =
let k = makeKey (board s)
in if Map.member k t
then (a, t)
else (s:a, Map.insert k s t)
iter xs t =
if null ys then map make_answer xs else iter ys t'
where (ys, t') = foldl check ([], t) $ concatMap makeState xs
main :: IO ()
main = do
print $ solver [8,6,7,2,5,4,3,0,1] [1,2,3,4,5,6,7,8,0]
-- print $ solver' [8,6,7,2,5,4,3,0,1] [1,2,3,4,5,6,7,8,0]
-- print $ max_solver [1,2,3,4,5,6,7,8,0]
--
-- eight1.hs : 8 パズル (双方向探索)
--
-- Copyright (C) 2013-2021 Makoto Hiroi
--
import Data.List (elemIndex)
import Data.Maybe
import Queue
import qualified Data.IntMap as Map
{- 盤面
0 1 2
3 4 5
6 7 8 -}
-- 隣接リスト
adjacent :: [[Int]]
adjacent =
[[1, 3],
[0, 2, 4],
[1, 5],
[0, 4, 6],
[1, 3, 5, 7],
[2, 4, 8],
[3, 7],
[4, 6, 8],
[5, 7]]
-- 方向を表すデータ型
data Dir = F | B deriving (Show, Eq)
-- 局面を表すデータ型
data State = Null | State {board :: [Int], space :: Int, piece :: Int, dir :: Dir,
prev :: State} deriving Show
-- 盤面を数値に変換する
makeKey :: [Int] -> Int
makeKey xs = foldl (\a x -> a * 10 + x) 0 xs
-- ピースを動かす
movePiece :: [Int] -> Int -> [Int]
movePiece [] _ = []
movePiece (x:xs) p
| x == 0 = p : movePiece xs p
| x == p = 0 : movePiece xs p
| otherwise = x : movePiece xs p
-- 新しい局面を作る
makeState :: State -> [State]
makeState s =
foldr (\x a -> let p = board s !! x
in if piece s == p then a
else let b = movePiece (board s) p
in State b x p (dir s) s : a)
[]
(adjacent !! space s)
-- 手順をリストに格納する
make_answer :: State -> State -> [[Int]]
make_answer s1 s2 =
if dir s1 == F then iterF s1 [] ++ iterB (prev s2)
else iterF s2 [] ++ iterB (prev s1)
where
iterF Null xs = xs
iterF s xs = iterF (prev s) (board s : xs)
iterB Null = []
iterB s = board s : iterB (prev s)
-- 双方向探索
solver :: [Int] -> [Int] -> [[Int]]
solver start goal = iter que Map.empty where
gs = State goal (fromJust (elemIndex 0 goal)) 0 B Null
ss = State start (fromJust (elemIndex 0 start)) 0 F Null
que = enqueue (singleton ss) gs
iter q t
| isEmptyQueue q = []
| otherwise =
let (s, q1) = dequeue q
k = makeKey (board s)
in case Map.lookup k t of
Nothing -> iter (foldl enqueue q1 (makeState s)) (Map.insert k s t)
Just s1 -> if dir s1 /= dir s then make_answer s s1
else iter q1 t
main :: IO ()
main = do
print $ solver [8,6,7,2,5,4,3,0,1] [1,2,3,4,5,6,7,8,0]