module Wumpus.Basic.Kernel.Drawing.LocDrawing
(
GenLocDrawing
, LocDrawing
, LocDrawM(..)
, runGenLocDrawing
, evalGenLocDrawing
, execGenLocDrawing
, stripGenLocDrawing
, runLocDrawing
, runLocDrawing_
)
where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Drawing.Basis
import Wumpus.Basic.Kernel.Objects.Anchors
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Connector
import Wumpus.Basic.Kernel.Objects.Image
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Core
import Control.Applicative
import Control.Monad
import Data.Monoid
newtype GenLocDrawing st u a = GenLocDrawing {
getGenLocDrawing :: DrawingContext -> st -> (a, st, CatPrim)}
type instance DUnit (GenLocDrawing st u a) = u
type instance UState (GenLocDrawing st u) = st
type LocDrawing u a = GenLocDrawing () u a
instance Functor (GenLocDrawing st u) where
fmap f ma = GenLocDrawing $ \ctx s ->
let (a,s1,o) = getGenLocDrawing ma ctx s in (f a, s1, o)
instance Applicative (GenLocDrawing st u) where
pure a = GenLocDrawing $ \_ s -> (a, s, mempty)
mf <*> ma = GenLocDrawing $ \ctx s ->
let (f,s1,o1) = getGenLocDrawing mf ctx s
(a,s2,o2) = getGenLocDrawing ma ctx s1
in (f a, s2, o1 `mappend` o2)
instance Monad (GenLocDrawing st u) where
return a = GenLocDrawing $ \_ s -> (a, s, mempty)
ma >>= k = GenLocDrawing $ \ctx s ->
let (a,s1,o1) = getGenLocDrawing ma ctx s
(b,s2,o2) = (getGenLocDrawing . k) a ctx s1
in (b, s2, o1 `mappend` o2)
instance DrawingCtxM (GenLocDrawing st u) where
askDC = GenLocDrawing $ \ctx s -> (ctx, s, mempty)
asksDC fn = GenLocDrawing $ \ctx s -> (fn ctx, s, mempty)
localize upd ma = GenLocDrawing $ \ctx s ->
getGenLocDrawing ma (upd ctx) s
instance UserStateM (GenLocDrawing st u) where
getState = GenLocDrawing $ \_ s -> (s, s, mempty)
setState s = GenLocDrawing $ \_ _ -> ((), s, mempty)
updateState upd = GenLocDrawing $ \_ s -> ((), upd s, mempty)
instance Monoid a => Monoid (GenLocDrawing st u a) where
mempty = GenLocDrawing $ \_ s -> (mempty, s, mempty)
ma `mappend` mb = GenLocDrawing $ \ctx s ->
let (a,s1,w1) = getGenLocDrawing ma ctx s
(b,s2,w2) = getGenLocDrawing mb ctx s1
in (a `mappend` b, s2, w1 `mappend` w2)
class Monad m => LocDrawM (m :: * -> *) where
inserti :: u ~ DUnit (m ()) => Image u a -> m a
inserti_ :: u ~ DUnit (m ()) => Image u a -> m ()
insertli :: u ~ DUnit (m ()) => Anchor u -> LocImage u a -> m a
insertli_ :: u ~ DUnit (m ()) => Anchor u -> LocImage u a -> m ()
insertci :: u ~ DUnit (m ()) =>
Anchor u -> Anchor u -> ConnectorImage u a -> m a
insertci_ :: u ~ DUnit (m ()) =>
Anchor u -> Anchor u -> ConnectorImage u a -> m ()
inserti_ gf = inserti gf >> return ()
insertli_ pt gf = insertli pt gf >> return ()
insertci_ p1 p2 gf = insertci p1 p2 gf >> return ()
instance InterpretUnit u => LocDrawM (GenLocDrawing st u) where
inserti = insertiImpl
insertli = insertliImpl
insertci = insertciImpl
runGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a)
=> st -> GenLocDrawing st u a -> LocImage u (a,st)
runGenLocDrawing st ma = promoteLoc $ \(P2 x y) ->
askDC >>= \ctx ->
let (a,s1,w1) = getGenLocDrawing ma ctx st
ans = translate x y a
dv1 = normalizeF (dc_font_size ctx) (V2 x y)
in replaceAns (ans,s1) $ primGraphic $ cpmove dv1 w1
evalGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a)
=> st -> GenLocDrawing st u a -> LocImage u a
evalGenLocDrawing st ma = fmap fst $ runGenLocDrawing st ma
execGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a)
=> st -> GenLocDrawing st u a -> LocImage u st
execGenLocDrawing st ma = fmap snd $ runGenLocDrawing st ma
stripGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a)
=> st -> GenLocDrawing st u a -> LocQuery u (a,st)
stripGenLocDrawing st ma = stripLocImage $ runGenLocDrawing st ma
runLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a)
=> LocDrawing u a -> LocImage u a
runLocDrawing ma = evalGenLocDrawing () ma
runLocDrawing_ :: (Translate a, InterpretUnit u, u ~ DUnit a)
=> LocDrawing u a -> LocGraphic u
runLocDrawing_ ma = ignoreAns $ runLocDrawing ma
insertiImpl :: InterpretUnit u
=> Image u a -> GenLocDrawing st u a
insertiImpl gf = GenLocDrawing $ \ctx s ->
let (a,w1) = runImage ctx gf in (a,s,w1)
insertliImpl :: InterpretUnit u
=> Anchor u -> LocImage u a -> GenLocDrawing st u a
insertliImpl p1 gf = GenLocDrawing $ \ctx s ->
let (a,w1) = runLocImage ctx p1 gf in (a,s,w1)
insertciImpl :: InterpretUnit u
=> Anchor u -> Anchor u -> ConnectorImage u a
-> GenLocDrawing st u a
insertciImpl p1 p2 gf = GenLocDrawing $ \ctx s ->
let (a,w1) = runConnectorImage ctx p1 p2 gf in (a,s,w1)