mainbak05.hs

module Mainbak05 where
import Stack

-- スタック操作型
newtype StackOp a b = StackOp {run :: Stack a -> (b, Stack a)}

-- Monad を真似したクラス
class MyMonad m where
--    comb :: m a -> (a -> m a) -> m a   -- これ間違い
    comb :: m a -> (a -> m b) -> m b
    ret :: a -> m a
    comb_ :: m a -> m b -> m b -- クラスにおいて型を定義していると見間違えにくい。

instance MyMonad (StackOp a) where
    ret x = StackOp $ \stack -> (x, stack)
    m `comb` n = StackOp $ \stack0 ->
                 let (x1, stack1) = run m stack0
                     (x2, stack2) = run (n x1) stack1
                 in  (x2, stack2)
    m `comb_` n = m `comb` (\_ -> n)

-- 連続して pop
poppop = StackOp pop `comb` \x1 ->
         StackOp pop `comb` \x2 -> 
         ret $ x1 + x2

-- pop して push
poppush = StackOp pop `comb` (\x -> StackOp (push' x))
poppush' = StackOp pop `comb` (StackOp . push')

-- インスタンス宣言で書き直す
-- comb_ :: StackOp a b -> StackOp a b -> StackOp a b -- これ間違い
-- comb_ :: StackOp a b -> StackOp a c -> StackOp a c
-- comb_ m n = m `comb` (\_ -> n)

-- 連続して push
pushpush = StackOp (push' 10) `comb_` (StackOp (push' 9))

-- pop した要素が述語を満しているか？
topis :: (a -> Bool) -> Stack a -> (Bool, Stack a)
topis p s = let (a, s') = pop s
            in  (p a, s')

-- push して pop
pushpop = StackOp (push' 10) `comb_` StackOp pop

main = do
  print $ run poppop s
  print $ run poppush s
  print $ run poppush s  
  print $ run poppush' s
  print $ run pushpush s
  print $ run (StackOp $ topis (> 4)) s
  print $ run (StackOp (topis (> 4)) `comb` (\x1 ->
               StackOp (topis (> 3)) `comb`  \x2 ->
               StackOp (topis (> 2)) `comb`  \x3 ->
               ret $ and [x1, x2, x3]))$ s