Stateモナド

Haskell

大域変数を使ったLispの練習問題をHaskellで挑戦していて、状態を全部、引数にして戻り値にするしかないなー、大変やと思ったら、それをしてくるモナドがありました。
「人工知能のためのLISP入門」p.126

--
-- 「人工知能のためのLISP入門」 by Peter Coxhead
-- 6.1 探索技術
{-
次のようなパズルを考えてみよう。ある細長い板がいくつかの「マス目(SQUARE)」に
区切られているとしよう。マス目の数は正確には決っていないが、丁度、チェス盤の
１列のようなものである。いくつかの「駒」が左端に並んでいて、それぞれ異なった
文字が記されている。下記の規則に従ってこれらの駒を動かし、指定された文字の並びを
細長い板の右端に作ることがこのパズルのゴールである。
(1) 一度に１つの駒しか動かせない。
(2) 動かし方、押し移動と飛び越し移動である。
(3) 押し移動とは、すぐ右隣の空いているマス目に駒を動かすことである。
(4) 飛び越し移動は、１つ飛び越しを可能な限り多く行う。１つ飛び越しとは、１つの駒を
飛び越してその右側の空いているマス目に、駒を動かすことである。
-}

-- 設計仕様
-- 文字列を使って駒の状態を表す。アルファベットは駒、ハイフンは空いているマス目を示す。
-- 縦型探索
-- 同じ状態は２度探索しない。

import Control.Monad.State.Strict
import qualified Data.Set as Set
import List

newtype PuzzleState = PS String deriving (Eq, Ord, Show)

main = print $ solve (PS "ART---") (PS "---TAR")

class (Ord a) => Situation a where
    children :: a -> [a]
    -- 可能な次の状態すべてを返す。
    distance :: a -> a -> Int
    -- ２つの状態の「距離」を返す。

type Path a = [a]

solve :: Situation a => a -> a -> ([a], Set.Set a)
-- startからgoalへ至る遷移パスがあれば、それと、探索の際に通過した状態を出力する。
-- searchで組み立てた演算戦略を実行する。
solve start goal = runState (search [[start]] goal) Set.empty

search :: Situation a => [[a]] -> a -> State (Set.Set a) [a]
-- sortqの優先順位で縦型探索する。
-- 探索した状態を持って探索するので、Stateモナド（を使った演算戦略）を返す。
search [] _ = return []
search (path@(s:_):paths) goal
    | s == goal = return (reverse path)
    | otherwise = do
  x <- expand path
  search (sortq (x ++ paths) goal) goal

expand :: Situation a => [a] -> State (Set.Set a) [[a]]
-- pathの先頭に可能な次の状態をそれぞれconsした配列を返す。
expand [] = return []
expand path@(s:_) = do
  x <- new (children s)
  return (map (\s -> s:path) x)

new :: Situation a => [a] -> State (Set.Set a) [a]
-- 引数の状態のうち、新たなものを返す。
new [] = return []
new (s:ss) = do
  b <- isGenerated s
  rest <- new ss
  return (if b then rest else s:rest)
    where
      isGenerated :: Situation a => a -> State (Set.Set a) Bool
      isGenerated state = do
               generated <- get
               put (Set.insert state generated)
               return (Set.member state generated)

sortq :: Situation a => [Path a] -> a -> [Path a]
-- 評価関数に従って探索パス候補を並び替える。
sortq paths goal = sortBy ordering paths
    where
      -- 型宣言がうまくいかないのでとりあえず省略
      ordering path1 path2 = compare (efv path1 goal) (efv path2 goal)
      efv path@(p:_) goal = length path + distance p goal
      -- efvは評価関数

instance Situation PuzzleState where
    children (PS s) = map PS (children1 [] s)
        where
          children1 :: String -> String -> [String]
          children1 _ [] = []
          children1 squaresPassed squaresLeft@(c:cs) =
              let move = moveFirstSquare squaresLeft
              in
                if move /= []
                then (reverse squaresPassed ++ move):children1 (c:squaresPassed) cs
                else children1 (c:squaresPassed) cs
          moveFirstSquare :: String -> String
          moveFirstSquare [] = []
          moveFirstSquare ('-':_) = []
          moveFirstSquare (c:'-':cs) = '-':c:cs
          moveFirstSquare state@(_:_:'-':_) = jumpFirstSquare state
          moveFirstSquare _ = []
          jumpFirstSquare :: String -> String
          jumpFirstSquare [] = []
          jumpFirstSquare state@('-':_) = state
          jumpFirstSquare state@(_:'-':_) = state
          jumpFirstSquare (c0:c1:'-':cs) = '-':c1:(jumpFirstSquare (c0:cs))
          jumpFirstSquare state = state

    distance (PS s1) (PS s2) = distance_ s1 s2
        where
          distance_ [] _ = 0
          distance_ (c:cs) goal@(_:gs)
              | c == '-' = distance_ cs gs
              | otherwise = countMoves c goal + distance_ cs gs
              where
                countMoves :: Char -> String -> Int
                countMoves _ [] = maxBound :: Int
                countMoves piece (g:gs)
                    | piece == g = 0
                    | otherwise = 1 + countMoves piece gs

状態の代わりを変数の代わりに引数にして関数を数珠繋ぎにして状態の初期値の関数にした後（いわゆる「戦略」）、評価する。こりゃデバッグや検証が大変なんじゃなかろうか。
いやでも状態に依存する部分とそうでない部分が分かれていくところが面白いけど、末端でステートを入れたくなったとき、状態依存を持つようになる上位の関数すべて書き直さないといけない…なるほどこれが純粋関数型か。はたしてこれだけのコストを払う価値があるのか。
でも、なんでもないことをするのに知恵を絞らないといけない、というのがいいですね。凡人は湯水のようにアイデアが沸くわけじゃないから、何か思いつくまで、頭を刺激する別の何かが必要。