module Wumpus.Basic.Monads.DrawingMonad
(
Drawing
, DrawingT
, runDrawing
, execDrawing
, runDrawingT
, execDrawingT
, module Wumpus.Basic.Graphic.DrawingAttr
, module Wumpus.Basic.Monads.DrawingCtxClass
, module Wumpus.Basic.Monads.TraceClass
) where
import Wumpus.Basic.Graphic
import Wumpus.Basic.Graphic.DrawingAttr
import Wumpus.Basic.Monads.DrawingCtxClass
import Wumpus.Basic.Monads.TraceClass
import Control.Applicative
import Control.Monad
newtype Drawing u a = Drawing {
getDrawing :: DrawingAttr -> (a, Graphic u) }
newtype DrawingT u m a = DrawingT {
getDrawingT :: DrawingAttr -> m (a, Graphic u) }
instance Functor (Drawing u) where
fmap f ma = Drawing $ \attr ->
let (a,w) = getDrawing ma attr in (f a,w)
instance Monad m => Functor (DrawingT u m) where
fmap f ma = DrawingT $ \attr ->
getDrawingT ma attr >>= \(a,w) -> return (f a,w)
instance Applicative (Drawing u) where
pure a = Drawing $ \_ -> (a, emptyG)
mf <*> ma = Drawing $ \attr -> let (f,w1) = getDrawing mf attr
(a,w2) = getDrawing ma attr
in (f a, w2 . w1)
instance Monad m => Applicative (DrawingT u m) where
pure a = DrawingT $ \_ -> return (a, emptyG)
mf <*> ma = DrawingT $ \attr -> getDrawingT mf attr >>= \(f,w1) ->
getDrawingT ma attr >>= \(a,w2) ->
return (f a, w2 . w1)
instance Monad (Drawing u) where
return a = Drawing $ \_ -> (a, emptyG)
ma >>= k = Drawing $ \attr -> let (a,w1) = getDrawing ma attr
(b,w2) = (getDrawing . k) a attr
in (b, w2 . w1)
instance Monad m => Monad (DrawingT u m) where
return a = DrawingT $ \_ -> return (a, emptyG)
ma >>= k = DrawingT $ \attr -> getDrawingT ma attr >>= \(a,w1) ->
(getDrawingT . k) a attr >>= \(b,w2) ->
return (b, w2 . w1)
instance TraceM (Drawing u) u where
trace a = Drawing $ \_ -> ((),a)
instance Monad m => TraceM (DrawingT u m) u where
trace a = DrawingT $ \_ -> return ((),a)
instance DrawingCtxM (Drawing u) where
askDrawingCtx = Drawing $ \attr -> (attr,emptyG)
localCtx ctx ma = Drawing $ \_ -> getDrawing ma ctx
instance Monad m => DrawingCtxM (DrawingT u m) where
askDrawingCtx = DrawingT $ \attr -> return (attr,emptyG)
localCtx ctx ma = DrawingT $ \_ -> getDrawingT ma ctx
runDrawing :: DrawingAttr -> Drawing u a -> (a, Graphic u)
runDrawing attr ma = getDrawing ma attr
execDrawing :: DrawingAttr -> Drawing u a -> Graphic u
execDrawing attr ma = snd $ runDrawing attr ma
runDrawingT :: Monad m => DrawingAttr -> DrawingT u m a -> m (a, Graphic u)
runDrawingT attr ma = getDrawingT ma attr
execDrawingT :: Monad m => DrawingAttr -> DrawingT u m a -> m (Graphic u)
execDrawingT attr ma = liftM snd $ runDrawingT attr ma