module Wumpus.Basic.Kernel.Drawing.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.WrappedPrimitive
import Wumpus.Basic.Kernel.Drawing.Basis
import Wumpus.Basic.Kernel.Objects.Anchors
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 GenTraceDrawing st u a = GenTraceDrawing {
getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) }
type instance DUnit (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 :: DrawingContext -> TraceDrawing u a -> (a, HPrim u)
runTraceDrawing ctx ma = post $ getGenTraceDrawing ma ctx ()
where
post (a,_,w1) = (a,w1)
execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u
execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma
evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a
evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma
runGenTraceDrawing :: DrawingContext -> st -> GenTraceDrawing st u a
-> (a,st,HPrim u)
runGenTraceDrawing ctx st ma = getGenTraceDrawing ma ctx st
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 ctx textAttr
(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 ctx df
draw :: Image u a -> GenTraceDrawing st u ()
draw gf = askDC >>= \ctx ->
let (_,w) = runImage ctx gf
in trace (singleH w) >> return ()
drawi :: Image u a -> GenTraceDrawing st u a
drawi gf = askDC >>= \ctx ->
let (a,w) = runImage ctx gf
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 ctx pt gf
in trace (singleH w) >> return a
drawc :: InterpretUnit u
=> Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u ()
drawc an0 an1 gf = drawci an0 an1 gf >> return ()
drawci :: InterpretUnit u
=> Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a
drawci p0 p1 gf = drawi (connect gf p0 p1)
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 ctx pt gf
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 gf p0 p1)