wumpus-drawing-0.5.0: src/Wumpus/Drawing/Basis/LocTrace.hs
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Drawing.Basis.LocTrace
-- Copyright : (c) Stephen Tetley 2011
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : highly unstable
-- Portability : GHC
--
-- Writer monad with imperative /turtle/ style movement to build
-- LocGraphics.
--
--------------------------------------------------------------------------------
module Wumpus.Drawing.Basis.LocTrace
(
-- * LocTrace monads
LocTrace
, LocTraceT
, runLocTrace
, evalLocTrace
, execLocTrace
, runLocTraceT
, evalLocTraceT
, execLocTraceT
, liftLocTraceT
-- * LocTrace classes
, LocTraceM(..)
, LocForkTraceM(..)
-- * Derived operations
, hmoveBy
, vmoveBy
)
where
import Wumpus.Basic.Kernel -- package: wumpus-basic
import Wumpus.Core -- package: wumpus-core
import Data.VectorSpace -- package: vector-space
import Control.Applicative
import Control.Monad
import Data.Monoid
--
-- Note - there are no instances of DrawingCtxM for LocTrace or
-- LocTraceT.
--
-- The type is not directly compatible as we are collecting
-- LocGraphic in a triple, but also localize would change the
-- interpretation of the vector cursor if the font-size changes.
--
-- | LocTrace is a writer state monad.
--
-- The writer accumulates a LocGraphic the state is a cumulative
-- displacement vector (called a cursor below).
--
newtype LocTrace u a = LocTrace {
getLocTrace :: Vec2 u -> (a, Vec2 u, LocGraphic u )}
type instance DUnit (LocTrace u a) = u
-- Do we need a transformer version
-- | LocTrace is a writer state monad.
--
-- The writer accumulates a LocGraphic the state is a cumulative
-- displacement vector.
--
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
-- Functor
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)
-- Applicative
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)
-- Monad
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)
-- | Forget the generated LocImage, just return the /answer/.
--
evalLocTrace :: Num u => LocTrace u a -> a
evalLocTrace = post . runLocTrace
where
post (a,_,_) = a
-- | Forget the /answer/, just return the generated LocImage.
--
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)
-- | Forget the generated LocImage, just return the /answer/.
--
evalLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m a
evalLocTraceT = liftM post . runLocTraceT
where
post (a,_,_) = a
-- | Forget the /answer/, just return the generated LocImage.
--
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)
-- | 'insertl' analogue to Writer monad @tell@.
--
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
-- Note - @reset@ steals a too general name.
-- It needs changing...
-- | Add operations for branching (fork at the current point)
-- and resetting to the start point.
--
-- Not all drawings that support tracing support branching. For
-- instance Paths can be built by tracing but they always need
-- a cumulative progression of /next point/ they cannot resrt to
-- the start point and go in a differnt direction.
--
class LocTraceM m => LocForkTraceM (m :: * -> *) where
reset :: m ()
-- Branch is like @local@ in the Reader monad.
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)
--------------------------------------------------------------------------------
-- Derived operations
-- | Move the /cursor/ horizontally.
--
hmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m ()
hmoveBy dx = moveBy (hvec dx)
-- | Move the /cursor/ vertically.
--
vmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m ()
vmoveBy dx = moveBy (vvec dx)