変換子スタックの管理

-- 問題を記述している型
data NQueensProblem = NQP {board::Board,
                           ranks::[Rank],   files::[File],
                           asc::[Diagonal], desc::[Diagonal]}

-- 初期状態は空の盤。すべての横筋、縦筋、斜め筋が空
initialState = let fileA = map (\r->Pos A r) [1..8]
                   rank8 = map (\f->Pos f 8) [A .. H]
                   rank1 = map (\f->Pos f 1) [A .. H]
                   asc   = map Ascending (nub (fileA ++ rank1))
                   desc  = map Descending (nub (fileA ++ rank8))
               in NQP (Board []) [1..8] [A .. H] asc desc

-- この問題用の合成モナドの型
type NDS a = WriterT [String] (StateT NQueensProblem []) a

-- 最初の解を得る。初期問題状態でソルバ計算を評価して、
-- 結果のリストから最初の解、あるいは、解がなければ Nothing を返す
getSolution :: NDS a -> NQueensProblem -> Maybe (a,[String])
getSolution c i = listToMaybe (evalStateT (runWriterT c) i)

-- 盤の指定された位置にクィーンを置く
addQueen :: Position -> NDS ()
addQueen p = do (Board b) <- gets board
                rs <- gets ranks
                fs <- gets files
                as <- gets asc
                ds <- gets desc
                let b'  = (Piece Black Queen, p):b
                    rs' = delete (rank p) rs
                    fs' = delete (file p) fs
                    (a,d) = getDiags p
                    as' = delete a as
                    ds' = delete d ds
                tell ["Added Queen at " ++ (show p)]
                put (NQP (Board b') rs' fs' as' ds')

-- ある位置が許された筋にあるかどうかをテスト
inDiags :: Position -> NDS Bool
inDiags p = do let (a,d) = getDiags p
               as <- gets asc
               ds <- gets desc
               return $ (elem a as) && (elem d ds)
	       
-- 許された全ての位置にクィーンを置く
addQueens :: NDS ()
addQueens = do rs <- gets ranks
               fs <- gets files
               allowed <- filterM inDiags [Pos f r | f <- fs, r <- rs]
               tell [show (length allowed) ++ " possible choices"]
               msum (map addQueen allowed)

-- 空のチェス盤からはじめて、要求された数のクィーンを置く
-- その後、盤を取得し、ログに従って解を印字する
main :: IO ()
main = do args <- getArgs
          let n    = read (args!!0)
              cmds = replicate n addQueens
              sol  = (`getSolution` initialState) $ do sequence_ cmds
                                                       gets board
          case sol of
            Just (b,l) -> do putStr $ show b    -- show the solution
                             putStr $ unlines l -- show the log
            Nothing    -> putStrLn "No solution"

logString :: String -> StateT MyState (WriterT [String] []) Int
logString s = ...

logString :: (MonadWriter [String] m) => String -> m Int
logString s = ...

liftListToState = lift . lift . lift

-- この問題用の合成モナドの型
type NDS a = StateT Int (WriterT [String] []) a

{- リスト上の計算 -}

-- 数の各桁をリストとして返す
getDigits :: Int -> [Int]
getDigits n = let s = (show n)
              in map digitToInt s

{- MonadWriter の計算 -}

-- 値をログに書き込み、その値を返す
logVal :: (MonadWriter [String] m) => Int -> m Int
logVal n = do tell ["logVal: " ++ (show n)]
              return n

-- ログを記録する計算を実行し、記録したログの長さを返す
getLogLength :: (MonadWriter [[a]] m) => m b -> m Int
getLogLength c = do (_,l) <- listen $ c
                    return (length (concat l))

-- 文字列値を記録し、0 を返す
logString :: (MonadWriter [String] m) => String -> m Int
logString s = do tell ["logString: " ++ s]
                 return 0

{- WriterT [String] [] を必要とする計算 -}

-- "Fork" the computation and log each list item in a different branch.
logEach :: (Show a) => [a] -> WriterT [String] [] a
logEach xs = do x <- lift xs
                tell ["logEach: " ++ (show x)]
                return x
		
{- MonadState の計算 -}

-- 状態を指定した値だけ増加する
addVal :: (MonadState Int m) => Int -> m ()
addVal n = do x <- get
              put (x+n)

{- 合成モナドの計算 -}

-- 状態を与えられた値に設定し、その値を記録する
setVal :: Int -> NDS ()
setVal n = do x <- lift $ logVal n
              put x

-- 計算を「フォーク」する。各ブランチの状態に異る数字を付加する
-- setVal が使われているので、新しい値は同じように記録される
addDigits :: Int -> NDS ()
addDigits n = do x  <- get
                 y <- lift . lift $ getDigits n
                 setVal (x+y)

{- 同等の構成は以下のとおり
addDigits :: Int -> NDS ()
addDigits n = do x <- get
                 msum (map (\i->setVal (x+i)) (getDigits n))
-}

{- これは、すべてのもちあげロジックを一箇所にまとめ、わかりやすい名前を
   持たせるのに使える補助関数の例です。これには、変換子スタックが将来
   変化(たとえば、ErrorTを追加)しても既存のもちあげロジックへの変更は
   少数の関数の範囲にとどまるという利点があります。
-}
liftListToNDS :: [a] -> NDS a
liftListToNDS = lift . lift

-- 合成モナドの一連の計算を実行する。計算を必要に応じて他のモナドから
-- もちあげる
main :: IO ()
main = do mapM_ print $ runWriterT $ (`evalStateT` 0) $ do x <- lift $ getLogLength $ logString "hello"
                                                           addDigits x
                                                           x <- lift $ logEach [1,3,5]
                                                           lift $ logVal x
                                                           liftListToNDS $ getDigits 287