[Haskell] Writerモナドの問題を解いてみた

スタートHaskell2　最終回 14章 演習問題1
http://wiki.haskell.jp/Workshop/StartHaskell2/exercise14
Writerモナドの問題を解いてみた
収集つかなくなっちゃったけど、いろいろ試行錯誤したので、そのまま掲載しちゃう。

{-# OPTIONS -Wall -Werror #-}
-- スタートHaskell2　最終回 14章 演習問題1
-- http://wiki.haskell.jp/Workshop/StartHaskell2/exercise14

module Exercise141 where
-- import Control.Applicative
import Control.Monad.Writer
------------------------------------------------------
-- | すごいHaskellたのしく学ぼう本の Writerモナドの例の改変版
logNumber :: Double -> Writer [String] Double
logNumber x = writer (x, ["Got Nubmer: " ++ show x])

multWithLog :: Double->Double->Writer [String] Double
multWithLog x y = do
  a <- logNumber x
  b <- logNumber y
  return (a*b)
-- | モナドの中にいれたものを、もう一度ひっぱがして
-- | 計算結果をモナドにいれて次に引き渡す。
------------------------------------------------------
-- | すごいHaskellたのしく学ぼう本の　非モナド版
solveRPN1 :: String -> Double
-- | 関数合成してできている。
--solveRPN1 formula = (head . foldl foldingFunction [] . words) formula
-- | 右から、まず String->[String]にして、
-- | 次に[String]->[Double]にして、最後に[Double]->Doubleして解を得る。
-- | ポイントフリースタイルだとこうなる。
--solveRPN1 = head . foldl foldingFunction [] . words
-- | 補助関数 rpn1 を使って、いったん置き換える
-- | solveRPN1 = head . rpn1
-- | 左から右に書きたい p.290
(-:) :: t1 -> (t1 -> t) -> t
x -: f = f x
-- | 左から右につなげて書けると美しい。
-- | 結局これは、String->[String]->[Double]->Double
solveRPN1 formula = formula -: words -: foldl foldingFunction [] -: head
  where
    -- | 以下のあちこちにある型宣言は、実はいらないけど、書いてもOK
    --rpn1 :: String -> [Double]
    --rpn1 = foldl foldingFunction [] . words
    foldingFunction :: [Double] -> String -> [Double]
    foldingFunction (x:y:ys) "*" = (y * x) : ys
    foldingFunction (x:y:ys) "+" = (y + x) : ys
    foldingFunction (x:y:ys) "-" = (y - x) : ys
    foldingFunction xs       str = (read str::Double) : xs
------------------------------------------------------
-- | 演習問題　Exercise14-1
-- | Writerモナドを使ってみよう
-- | 逆ポーランド記法で書かれた式を計算する関数 solveRPN (p.214) に、
-- | Writerモナドを使って計算経過ログをとる機能を追加してみよう。
-- solveRPN2 :: String -> Writerモナド型 Double
solveRPN2 :: String -> Writer[String] Double
--solveRPN2 formula = (liftM head <$> foldM foldingFunctionM [] <$> words) formula
--solveRPN2 = liftM head <$> foldM foldingFunctionM [] <$> words
--solveRPN2 = liftM head <$> (foldM foldingFunctionM [] . words)
--solveRPN2 formula = liftM head ((foldM foldingFunctionM [] . words) formula)
-- | 右から、まず String->[String]にして、
-- | 次に[String]->Writer[String]の[Double]にして、
-- | 最後に[Double]->Writer[String]のDoubleして解を得る。
-- | 補助関数 rpn2 を使って、いったん置き換える
--solveRPN2 = fmap (liftM head) rpn2
--solveRPN2 = liftM head <$> rpn2
--solveRPN2 = (<$>) head <$> rpn2
--solveRPN2 formula = liftM head (rpn2 formula)
--solveRPN2 formula = (<$>) head (rpn2 formula)
-- | どう書いても美しくない
{--
-- | do記法で書いたほうが少し美しい
solveRPN2 formula = do
     ds <- rpn2 formula
     return $ head ds
solveRPN2 formula = do
     ds <- rpn2 formula
     let d = head ds
     return d
--}
-- | バインドで書くと最も美しい
-- | m aをとって(a->m b)な関数をバインドしてつなげて、最終的にm bを得る
-- solveRPN2 formula = rpn2 formula >>= (\x -> return (head x))
-- | 結局これは、String->m String->Writer[String] [Double]->Writer[String] Double
solveRPN2 formula = return (formula) 
                    >>= (\x -> return (words x))
                    >>= (foldM foldingFunctionM []) 
                    >>= (\x -> return (head x))
  where
 -- rpn2 :: String -> Writerモナド型 [Double]
 -- rpn2 :: String -> Writer[String] [Double]
 -- rpn2 = foldM foldingFunctionM [] <$> words
 -- rpn2 = fmap (foldM foldingFunctionM []) words 
    -- | 以下の型宣言はいらないけど、書いてもOK
 -- foldingFunctionM :: [Double] -> String -> Writer[String]モナド [Double]
    foldingFunctionM :: [Double] -> String -> Writer[String] [Double]
    -- | writerやtellをいろいろな形で使ってみる
    foldingFunctionM (x:y:ys) "*" = do
                    (y1,x1) <- writer ((y,x), [show y ++ "*" ++ show x])
                    return ((y1*x1):ys)
    -- | これが一番シンプル。
    -- | 計算結果とログに追加する文字列をセットしたWriterモナドを返す
    foldingFunctionM (x:y:ys) "+" = 
                    writer (((y+x):ys), [show y ++ "+" ++ show x])
    -- | ログだけ追加するtellというのも使える
    foldingFunctionM (x:y:ys) "-" = do
                    tell [show y ++ "-" ++ show x]
                    return ((y-x):ys)
    foldingFunctionM xs str = do
                    tell [str]
                    return ((read str::Double):xs)

-- | どちらで計算しても結果は同じ
-- | solveRPN2は内部でWriterモナドを使っているけど純粋関数
solveRPNcomp::String->Bool
solveRPNcomp formula = (solveRPN1 formula) == (fst . runWriter $ solveRPN2 formula)

-- | main
main :: IO ()
main = do
    putStrLn "hoo"
    let formula1 = "10 2 3 * +"
    print $ solveRPN1 formula1
{--
> :t runWriter
runWriter :: Writer w a -> (a, w)
モナドからタプルを取り出す関数は、純粋な関数からは呼べないが、mainからは呼べる
取り出したあとは、モナドではないが、取り出した値をそれ以降使う部分は、
純粋な部分にはいれられない。
> :t runWriter . solveRPN2
runWriter . solveRPN2 :: String -> (Double, [String])
> :t solveRPN2
solveRPN2 :: String -> Writer [String] Double
--}
-- | (演算結果,ログ)を出力する
    print . runWriter $ multWithLog 4.5 6.5
-- | (演算結果,ログ)を出力する
    print . runWriter $ solveRPN2 formula1
    let (result,logs) = runWriter $ solveRPN2 formula1
    print (result,logs)
-- | 演算結果を出力する
    print . fst . runWriter $ solveRPN2 formula1
-- | ログだけ出力する
    print . execWriter $ solveRPN2 formula1
-- | テスト
    print $ solveRPNcomp formula1
    return ()

実行結果

hoo
16.0
(29.25,["Got Nubmer: 4.5","Got Nubmer: 6.5"])
(16.0,["10","2","3","2.0*3.0","10.0+6.0"])
(16.0,["10","2","3","2.0*3.0","10.0+6.0"])
16.0
["10","2","3","2.0*3.0","10.0+6.0"]
True