module Wumpus.Basic.Kernel.Objects.TraceDrawing
(
GenTraceDrawing
, TraceDrawing
, DTraceDrawing
, runTraceDrawing
, execTraceDrawing
, evalTraceDrawing
, runGenTraceDrawing
, liftToPictureU
, liftToPictureMb
, mbPictureU
, trace
, fontDelta
, evalQuery
, draw
, drawi
, drawl
, drawli
, drawc
, drawci
, node
, nodei
, drawrc
, drawrci
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Base.UserState
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Objects.Anchors
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Connector
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Core
import Control.Applicative
import Control.Monad
import Data.Monoid
newtype GenTraceDrawing st u a = GenTraceDrawing {
getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) }
type instance MonUnit (GenTraceDrawing st u a) = u
type instance UState (GenTraceDrawing st u) = st
type TraceDrawing u a = GenTraceDrawing () u a
type DTraceDrawing a = TraceDrawing Double a
instance Functor (GenTraceDrawing st u) where
fmap f ma = GenTraceDrawing $ \ctx s ->
let (a,s1,w1) = getGenTraceDrawing ma ctx s in (f a,s1,w1)
instance Applicative (GenTraceDrawing st u) where
pure a = GenTraceDrawing $ \_ s -> (a, s, mempty)
mf <*> ma = GenTraceDrawing $ \ctx s ->
let (f,s1,w1) = getGenTraceDrawing mf ctx s
(a,s2,w2) = getGenTraceDrawing ma ctx s1
in (f a, s2, w1 `mappend` w2)
instance Monad (GenTraceDrawing st u) where
return a = GenTraceDrawing $ \_ s -> (a, s, mempty)
ma >>= k = GenTraceDrawing $ \ctx s ->
let (a,s1,w1) = getGenTraceDrawing ma ctx s
(b,s2,w2) = (getGenTraceDrawing . k) a ctx s1
in (b,s2,w1 `mappend` w2)
instance DrawingCtxM (GenTraceDrawing st u) where
askDC = GenTraceDrawing $ \ctx s -> (ctx, s, mempty)
asksDC f = GenTraceDrawing $ \ctx s -> (f ctx, s, mempty)
localize upd ma = GenTraceDrawing $ \ctx s ->
getGenTraceDrawing ma (upd ctx) s
instance UserStateM (GenTraceDrawing st u) where
getState = GenTraceDrawing $ \_ s -> (s, s, mempty)
setState s = GenTraceDrawing $ \_ _ -> ((), s, mempty)
updateState upd = GenTraceDrawing $ \_ s -> ((), upd s, mempty)
runTraceDrawing :: TraceDrawing u a -> DrawingContext -> (a, HPrim u)
runTraceDrawing ma ctx = post $ getGenTraceDrawing ma ctx ()
where
post (a,_,w1) = (a,w1)
execTraceDrawing :: TraceDrawing u a -> DrawingContext -> HPrim u
execTraceDrawing ma ctx = snd $ runTraceDrawing ma ctx
evalTraceDrawing :: TraceDrawing u a -> DrawingContext -> a
evalTraceDrawing ma ctx = fst $ runTraceDrawing ma ctx
runGenTraceDrawing :: GenTraceDrawing st u a -> DrawingContext -> st
-> (a,st,HPrim u)
runGenTraceDrawing = getGenTraceDrawing
liftToPictureU :: HPrim u -> Picture
liftToPictureU hf =
let prims = hprimToList hf in if null prims then errK else frame prims
where
errK = error "toPictureU - empty prims list."
liftToPictureMb :: HPrim u -> Maybe Picture
liftToPictureMb hf = let prims = hprimToList hf in
if null prims then Nothing else Just (frame prims)
mbPictureU :: Maybe Picture -> Picture
mbPictureU Nothing = error "mbPictureU - empty picture."
mbPictureU (Just a) = a
trace :: HPrim u -> GenTraceDrawing st u ()
trace a = GenTraceDrawing $ \_ s -> ((), s, a)
fontDelta :: GenTraceDrawing st u a -> GenTraceDrawing st u a
fontDelta mf = GenTraceDrawing $ \ctx s ->
let (_,font_attrs) = runQuery textAttr ctx
(a,s1,w1) = getGenTraceDrawing mf ctx s
prim = fontDeltaContext font_attrs $ primGroup $ hprimToList w1
in (a, s1, singleH $ prim1 $ prim)
evalQuery :: DrawingCtxM m => Query u a -> m a
evalQuery df = askDC >>= \ctx -> return $ runQuery df ctx
draw :: Image u a -> GenTraceDrawing st u ()
draw gf = askDC >>= \ctx ->
let (_,w) = runImage gf ctx
in trace (singleH w) >> return ()
drawi :: Image u a -> GenTraceDrawing st u a
drawi gf = askDC >>= \ctx ->
let (a,w) = runImage gf ctx
in trace (singleH w) >> return a
drawl :: InterpretUnit u
=> Anchor u -> LocImage u a -> GenTraceDrawing st u ()
drawl ancr img = drawli ancr img >> return ()
drawli :: InterpretUnit u
=> Anchor u -> LocImage u a -> GenTraceDrawing st u a
drawli pt gf = askDC >>= \ctx ->
let (a,w) = runLocImage gf ctx pt
in trace (singleH w) >> return a
drawc :: InterpretUnit u
=> Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u ()
drawc an0 an1 img = drawci an0 an1 img >> return ()
drawci :: InterpretUnit u
=> Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a
drawci p0 p1 img = drawi (connect p0 p1 img)
node :: ( Fractional u, InterpretUnit u)
=> (Int,Int) -> LocImage u a -> GenTraceDrawing st u ()
node coord gf = nodei coord gf >> return ()
nodei :: (Fractional u, InterpretUnit u)
=> (Int,Int) -> LocImage u a -> GenTraceDrawing st u a
nodei coord gf = askDC >>= \ctx ->
position coord >>= \pt ->
let (a,w) = runLocImage gf ctx pt
in trace (singleH w) >> return a
drawrc :: ( Real u, Floating u, InterpretUnit u
, CenterAnchor a1, RadialAnchor a1
, CenterAnchor a2, RadialAnchor a2
, u ~ DUnit a1, u ~ DUnit a2
)
=> a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u ()
drawrc a b gf = drawrci a b gf >> return ()
drawrci :: ( Real u, Floating u, InterpretUnit u
, CenterAnchor a1, RadialAnchor a1
, CenterAnchor a2, RadialAnchor a2
, u ~ DUnit a1, u ~ DUnit a2
)
=> a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u a
drawrci a b gf =
let (p0,p1) = radialConnectorPoints a b in drawi (connect p0 p1 gf)