module Wumpus.Basic.Graphic.Chain
(
ChainT
, runChainT
, horizontal
) where
import Wumpus.Basic.Graphic.BaseClasses
import Wumpus.Basic.Graphic.BaseTypes
import Wumpus.Core
import Control.Applicative
import Control.Monad
newtype ChainT u m a = ChainT {
getChainT :: Point2T u -> Point2 u -> m (a, Point2 u) }
type instance MonUnit (ChainT u m) = u
instance Monad m => Functor (ChainT u m) where
fmap f ma = ChainT $ \rf s ->
getChainT ma rf s >>= \(a,s1) -> return (f a, s1)
instance Monad m => Applicative (ChainT u m) where
pure a = ChainT $ \_ s -> return (a,s)
mf <*> ma = ChainT $ \rf s -> getChainT mf rf s >>= \(f,s1) ->
getChainT ma rf s1 >>= \(a,s2) ->
return (f a, s2)
instance Monad m => Monad (ChainT u m) where
return a = ChainT $ \_ s -> return (a,s)
m >>= k = ChainT $ \rf s -> getChainT m rf s >>= \(a,s1) ->
(getChainT . k) a rf s1
instance Monad m => PointSupplyM (ChainT u m) where
position = ChainT $ \rf s -> return (s, rf s)
runChainT :: Monad m
=> Point2T u -> Point2 u -> ChainT u m a -> m a
runChainT f pt0 ma = liftM fst $ getChainT ma f pt0
horizontal :: (Num u, Monad m)
=> Point2 u -> u -> ChainT u m a -> m a
horizontal pt0 dx ma = runChainT f pt0 ma
where
f (P2 x y) = P2 (x+dx) y
instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ChainT u m) where
trace a = ChainT $ \_ s -> trace a >> return ((), s)
instance (Monad m, DrawingCtxM m) => DrawingCtxM (ChainT u m) where
askCtx = ChainT $ \_ s -> askCtx >>= \ctx -> return (ctx, s)
localCtx cF ma = ChainT $ \r s -> localCtx cF (getChainT ma r s)