module Wumpus.Drawing.Basis.LocTrace
(
LocTrace
, LocTraceT
, runLocTrace
, evalLocTrace
, execLocTrace
, runLocTraceT
, evalLocTraceT
, execLocTraceT
, liftLocTraceT
, LocTraceM(..)
, LocForkTraceM(..)
, hmoveBy
, vmoveBy
)
where
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.VectorSpace
import Control.Applicative
import Control.Monad
import Data.Monoid
newtype LocTrace u a = LocTrace {
getLocTrace :: Vec2 u -> (a, Vec2 u, LocGraphic u )}
type instance DUnit (LocTrace u a) = u
newtype LocTraceT u m a = LocTraceT {
getLocTraceT :: Vec2 u -> m (a, Vec2 u, LocGraphic u )}
type instance DUnit (LocTraceT u m a) = u
type instance MonUnit (LocTrace u a) = u
type instance MonUnit (LocTraceT u m a) = u
instance Functor (LocTrace u) where
fmap f ma = LocTrace $ \v0 -> let (a,v1,o) = getLocTrace ma v0
in (f a, v1, o)
instance Monad m => Functor (LocTraceT u m) where
fmap f ma = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,v1,o) ->
return (f a, v1, o)
instance Applicative (LocTrace u) where
pure a = LocTrace $ \v0 -> (a, v0, mempty)
mf <*> ma = LocTrace $ \v0 ->
let (f,v1,o1) = getLocTrace mf v0
(a,v2,o2) = getLocTrace ma v1
in (f a, v2, o1 `mappend` o2)
instance Monad m => Applicative (LocTraceT u m) where
pure a = LocTraceT $ \v0 -> return (a, v0, mempty)
mf <*> ma = LocTraceT $ \v0 ->
getLocTraceT mf v0 >>= \(f,v1,o1) ->
getLocTraceT ma v1 >>= \(a,v2,o2) ->
return (f a, v2, o1 `mappend` o2)
instance Monad (LocTrace u) where
return a = LocTrace $ \v0 -> (a, v0, mempty)
ma >>= k = LocTrace $ \v0 ->
let (a,v1,o1) = getLocTrace ma v0
(b,v2,o2) = (getLocTrace . k) a v1
in (b, v2, o1 `mappend` o2)
instance Monad m => Monad (LocTraceT u m) where
return a = LocTraceT $ \v0 -> return (a, v0, mempty)
ma >>= k = LocTraceT $ \v0 ->
getLocTraceT ma v0 >>= \(a,v1,o1) ->
(getLocTraceT . k) a v1 >>= \(b,v2,o2) ->
return (b, v2, o1 `mappend` o2)
runLocTrace :: Num u => LocTrace u a -> (a, Vec2 u, LocGraphic u)
runLocTrace mf = getLocTrace mf (V2 0 0)
evalLocTrace :: Num u => LocTrace u a -> a
evalLocTrace = post . runLocTrace
where
post (a,_,_) = a
execLocTrace :: Num u => LocTrace u a -> LocGraphic u
execLocTrace = post . runLocTrace
where
post (_,_,o) = o
runLocTraceT :: (Monad m, Num u)
=> LocTraceT u m a -> m (a, Vec2 u, LocGraphic u)
runLocTraceT mf = getLocTraceT mf (V2 0 0)
evalLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m a
evalLocTraceT = liftM post . runLocTraceT
where
post (a,_,_) = a
execLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m (LocGraphic u)
execLocTraceT = liftM post . runLocTraceT
where
post (_,_,o) = o
liftLocTraceT :: Monad m => m a -> LocTraceT u m a
liftLocTraceT ma = LocTraceT $ \v0 ->
ma >>= \a -> return (a,v0,mempty)
class Monad m => LocTraceM (m :: * -> *) where
insertl :: MonUnit (m ()) ~ u => LocGraphic u -> m ()
insertl_ :: MonUnit (m ()) ~ u => LocImage u a -> m ()
moveBy :: MonUnit (m ()) ~ u => Vec2 u -> m ()
location :: MonUnit (m ()) ~ u => m (Vec2 u)
insertl_ = insertl . ignoreAns
class LocTraceM m => LocForkTraceM (m :: * -> *) where
reset :: m ()
branch :: m a -> m a
instance InterpretUnit u => LocTraceM (LocTrace u) where
insertl gf = LocTrace $ \v0 -> ((), v0, moveStart v0 gf)
moveBy v = LocTrace $ \v0 -> ((), v0 ^+^ v, mempty)
location = LocTrace $ \v0 -> (v0, v0, mempty)
instance InterpretUnit u => LocForkTraceM (LocTrace u) where
reset = LocTrace $ \_ -> ((), V2 0 0, mempty)
branch ma = LocTrace $ \v0 -> let (a,_,o) = getLocTrace ma v0 in (a,v0,o)
instance (Monad m, InterpretUnit u) => LocTraceM (LocTraceT u m) where
insertl gf = LocTraceT $ \v0 -> return ((), v0, moveStart v0 gf)
moveBy v = LocTraceT $ \v0 -> return ((), v0 ^+^ v, mempty)
location = LocTraceT $ \v0 -> return (v0, v0, mempty)
instance (LocTraceM m, InterpretUnit u) => LocForkTraceM (LocTraceT u m) where
reset = LocTraceT $ \_ -> return ((), V2 0 0, mempty)
branch ma = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,_,o) ->
return (a,v0,o)
hmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m ()
hmoveBy dx = moveBy (hvec dx)
vmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m ()
vmoveBy dx = moveBy (vvec dx)