MealyLike

MealyLike.hs

{-# LANGUAGE PatternSynonyms, DeriveFunctor, FlexibleContexts, TemplateHaskell, RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses #-}
import Data.Bifunctor (first)
import Control.Monad (forever)
import Control.Monad.Coroutine
import Control.Monad.Coroutine.SuspensionFunctors
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Control.Monad.State.Class
import Control.Monad.State.Lazy
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Except
import Control.Monad.Trans.Maybe
import Control.Applicative
import Control.Lens
import System.IO
import Data.IntMap

--------------------------------------------------------------
-- Lib: ミーリマシンっぽいなにかでオブジェクトのメッセージ通信
-- メモ：
-- コルーチンにするとawait/yieldが出来る
-- 遷移関数を1関数で記述すると相関の強い一連の遷移シーケンスが扱い辛い(状態の特定に名前つけたり、判定したり)
-- 遷移関数の合成を何種類か用意出来ないか考えた
-- 遷移出来ない場合、エラーメッセージ出して状態変化しないという遷移の方が自然あが、合成の都合でNothingを返すようにした
--------------------------------------------------------------

--resume :: Coroutine s m r -> m (Either (s (Coroutine s m r)) r)
data Transition out ev x = Transition out (ev -> Maybe x)

instance Functor (Transition x f) where
   fmap f (Transition x g) = Transition x (fmap f . g)

type MealyM ev out m  =              Coroutine (Transition out ev) m

type Mealy ev out m a = ev -> Maybe (MealyM ev out m a)

recv :: (ev -> Maybe b) -> (b -> MealyM ev out m a) -> Mealy ev out m a
recv p f = \x -> case p x of
    Just a -> Just $ f a
    Nothing -> Nothing

(|=>) :: (Monad m) => out -> Mealy ev out m a -> MealyM ev out m a
out |=> k = suspend $ Transition out k
infixr 0 |=>

-- sequence ;
(==>) :: (Monad m) => Mealy ev res m res -> Mealy ev res m a -> Mealy ev res m a
f ==> g = \x ->
      case (f x) of
        (Just k) -> Just $ do
                res <- k
                res |=> g
        Nothing -> Nothing

-- echoise []
(|=|) :: (Monad m) => Mealy ev res m a -> Mealy ev res m a -> Mealy ev res m a
f |=| g = \x -> f x <|> g x
infixr 0 |=|

-- optional & retry
-- P |?| Q = (P ; (P |?| Q)) [] Q
(|?|) :: (Monad m) => Mealy ev res m res -> Mealy ev res m a -> Mealy ev res m a
(|?|) f g = (f ==> ((|?|) f g)) |=| g

infixr 0 |?|


--------------------------------------------------------------
-- App: 自動販売機
--------------------------------------------------------------

data Message = Coin | Juice | Fill Int | Query deriving Show
data Result  = None | ResultQuery String  deriving Show
type Object  = Mealy Message Result M Result
data World   = World { _objmap :: IntMap Object, _fresh :: Key}
type M = StateT World IO -- 本当はMonadState と MonadIO で済ませたかった

makeLenses ''World
makePrisms ''Message

new :: Object -> M Key
new obj = do
    key <- use fresh
    objmap %= insert key obj
    fresh %= succ
    return key

runM :: World -> M a -> IO a
runM = flip evalStateT

getRandom :: M Int
getRandom = undefined

sendMessage :: Message -> Key -> M (Maybe Result)
sendMessage msg key = do
    objs <- use objmap
    case (objs ! key) msg of -- unsafe
        Nothing -> return Nothing -- 実際副作用ないのに M で包むのもどうなんだろう
        (Just oc) -> do
            k <- resume oc
            case k of
                Left (Transition out autm') -> do { objmap %= insert key autm'; return $ Just out }
                Right out -> do {objmap %= delete key; return $ Just out }

vmbDef :: Int -> Object
vmbDef n Query = Just $ return $ ResultQuery (show n)
vmbDef _ _ = Nothing

-- T.B.D vmbDef を毎回指定するのは面倒。Readerに入れておいてrecvする時にコンテキストから持ってこれた方が良いかも?
vmb :: Int -> Object
vmb  n Juice = Nothing
vmb  n (Fill m)
    | n + m > 10 || n < 0 || m < 1 = Nothing
    | otherwise  = Just $ None |=> vmb (n + m)
vmb  n Coin 
    | n <= 0    = Nothing
    | n == 1    = Just $ None |=>
        vmbDef n |?| recv (^? _Juice) $ \_ -> None |=>
        vmb (n-1)
    | otherwise = Just $ None |=>
        vmbDef n     |?| recv (^? _Juice) $ \_ -> None |=>
        vmbDef (n-1) |?| vmb (n-1) |=| recv (^? _Juice) $ \_ -> None |=>
                vmb (n-2)
vmb n msg = Just $ ResultQuery (show n) |=> vmb n

main = do
    runM (World Data.IntMap.empty 0) $ do
        vmbId <- new $ vmb 5
        sendMessage Query vmbId >>= \x -> liftIO $ print x
        sendMessage Coin vmbId >>= \x -> liftIO $ print x
        sendMessage Query vmbId >>= \x -> liftIO $ print x
        sendMessage Coin vmbId >>= \x -> liftIO $ print x
        sendMessage Juice vmbId >>= \x -> liftIO $ print x
        sendMessage Query vmbId >>= \x -> liftIO $ print x
        sendMessage Juice vmbId >>= \x -> liftIO $ print x
        sendMessage Juice vmbId >>= \x -> liftIO $ print x
        sendMessage Query vmbId >>= \x -> liftIO $ print x
        sendMessage (Fill 3) vmbId >>= \x -> liftIO $ print x
        sendMessage Query vmbId >>= \x -> liftIO $ print x
        sendMessage Coin vmbId >>= \x -> liftIO $ print x
        sendMessage Juice vmbId >>= \x -> liftIO $ print x
        sendMessage Coin vmbId >>= \x -> liftIO $ print x
        sendMessage Query vmbId >>= \x -> liftIO $ print x