module Wumpus.Basic.Monads.TraceMonad
(
Trace
, TraceT
, runTrace
, runTraceT
) where
import Wumpus.Basic.Monads.DrawingCtxClass
import Wumpus.Basic.Monads.TraceClass
import Wumpus.Basic.Monads.TurtleClass
import Wumpus.Basic.Utils.HList
import MonadLib ( MonadT(..) )
import Control.Applicative
newtype Trace i a = Trace { getTrace :: H i -> (a, H i) }
newtype TraceT i m a = TraceT { getTraceT :: H i -> m (a, H i) }
instance Functor (Trace i) where
fmap f m = Trace $ \w -> let (a,w') = getTrace m w in (f a, w')
instance Monad m => Functor (TraceT i m) where
fmap f m = TraceT $ \w -> getTraceT m w >>= \(a,w') ->
return (f a, w')
instance Applicative (Trace i) where
pure a = Trace $ \w -> (a,w)
mf <*> ma = Trace $ \w -> let (f,w') = getTrace mf w
(a,w'') = getTrace ma w'
in (f a,w'')
instance Monad m => Applicative (TraceT i m) where
pure a = TraceT $ \w -> return (a,w)
mf <*> ma = TraceT $ \w -> getTraceT mf w >>= \(f,w') ->
getTraceT ma w' >>= \(a,w'') ->
return (f a,w'')
instance Monad (Trace i) where
return a = Trace $ \w -> (a,w)
m >>= k = Trace $ \w -> let (a,w') = getTrace m w
in (getTrace . k) a w'
instance Monad m => Monad (TraceT i m) where
return a = TraceT $ \w -> return (a,w)
m >>= k = TraceT $ \w -> getTraceT m w >>= \(a,w') ->
(getTraceT . k) a w' >>= \(b,w'') ->
return (b,w'')
instance MonadT (TraceT i) where
lift m = TraceT $ \w -> m >>= \ a -> return (a,w)
instance TraceM (Trace i) i where
trace h = Trace $ \w -> ((), h . w)
trace1 i = Trace $ \w -> ((), i `consH` w)
instance Monad m => TraceM (TraceT i m) i where
trace h = TraceT $ \w -> return ((), h . w)
trace1 i = TraceT $ \w -> return ((), i `consH` w)
runTrace :: Trace i a -> (a,H i)
runTrace mf = getTrace mf id
runTraceT :: Monad m => TraceT i m a -> m (a,H i)
runTraceT mf = getTraceT mf id >>= \(a,w) -> return (a,w)
instance DrawingCtxM m => DrawingCtxM (TraceT i m) where
askDrawingCtx = TraceT $ \w -> askDrawingCtx >>= \ ctx -> return (ctx,w)
localCtx ctx mf = TraceT $ \w -> localCtx ctx (getTraceT mf w)
instance TurtleM m => TurtleM (TraceT i m) where
getLoc = TraceT $ \w -> getLoc >>= \a -> return (a,w)
setLoc c = TraceT $ \w -> setLoc c >> return ((),w)
getOrigin = TraceT $ \w -> getOrigin >>= \a -> return (a,w)
setOrigin o = TraceT $ \w -> setOrigin o >> return ((),w)
instance TurtleScaleM m u => TurtleScaleM (TraceT i m) u where
xStep = TraceT $ \w -> xStep >>= \a -> return (a,w)
yStep = TraceT $ \w -> yStep >>= \a -> return (a,w)