module Wumpus.Basic.Kernel.Objects.TraceDrawing
(
TraceM(..)
, TraceDrawing
, DTraceDrawing
, TraceDrawingT
, DTraceDrawingT
, runTraceDrawing
, execTraceDrawing
, evalTraceDrawing
, runTraceDrawingT
, execTraceDrawingT
, evalTraceDrawingT
, liftToPictureU
, liftToPictureMb
, mbPictureU
, 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.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
class TraceM (m :: * -> *) where
trace :: MonUnit (m ()) ~ u => HPrim u -> m ()
fontDelta :: m a -> m a
newtype TraceDrawing u a = TraceDrawing {
getTraceDrawing :: DrawingContext -> (a, HPrim u) }
newtype TraceDrawingT u m a = TraceDrawingT {
getTraceDrawingT :: DrawingContext -> m (a, HPrim u) }
type instance MonUnit (TraceDrawing u a) = u
type instance MonUnit (TraceDrawingT u m a) = u
type DTraceDrawing a = TraceDrawing Double a
type DTraceDrawingT m a = TraceDrawingT Double m a
instance Functor (TraceDrawing u) where
fmap f ma = TraceDrawing $ \ctx ->
let (a,w) = getTraceDrawing ma ctx in (f a,w)
instance Monad m => Functor (TraceDrawingT u m) where
fmap f ma = TraceDrawingT $ \ctx ->
getTraceDrawingT ma ctx >>= \(a,w) -> return (f a,w)
instance Applicative (TraceDrawing u) where
pure a = TraceDrawing $ \_ -> (a, mempty)
mf <*> ma = TraceDrawing $ \ctx ->
let (f,w1) = getTraceDrawing mf ctx
(a,w2) = getTraceDrawing ma ctx
in (f a, w1 `mappend` w2)
instance Monad m => Applicative (TraceDrawingT u m) where
pure a = TraceDrawingT $ \_ -> return (a,mempty)
mf <*> ma = TraceDrawingT $ \ctx ->
getTraceDrawingT mf ctx >>= \(f,w1) ->
getTraceDrawingT ma ctx >>= \(a,w2) ->
return (f a, w1 `mappend` w2)
instance Monad (TraceDrawing u) where
return a = TraceDrawing $ \_ -> (a, mempty)
ma >>= k = TraceDrawing $ \ctx ->
let (a,w1) = getTraceDrawing ma ctx
(b,w2) = (getTraceDrawing . k) a ctx
in (b,w1 `mappend` w2)
instance Monad m => Monad (TraceDrawingT u m) where
return a = TraceDrawingT $ \_ -> return (a, mempty)
ma >>= k = TraceDrawingT $ \ctx ->
getTraceDrawingT ma ctx >>= \(a,w1) ->
(getTraceDrawingT . k) a ctx >>= \(b,w2) ->
return (b, w1 `mappend` w2)
instance TraceM (TraceDrawing u) where
trace a = TraceDrawing $ \_ -> ((), a)
fontDelta = fontDeltaMon
fontDeltaMon :: TraceDrawing u a -> TraceDrawing u a
fontDeltaMon mf = TraceDrawing $ \ctx ->
let (_,font_attrs) = primAnswer $ runImage ctx textAttr
(a,hf) = runTraceDrawing ctx mf
prim = fontDeltaContext font_attrs $ primGroup $ hprimToList hf
in (a, singleH $ prim1 $ prim)
instance Monad m => TraceM (TraceDrawingT u m) where
trace a = TraceDrawingT $ \_ -> return ((), a)
fontDelta = fontDeltaTrans
fontDeltaTrans :: Monad m => TraceDrawingT u m a -> TraceDrawingT u m a
fontDeltaTrans mf = TraceDrawingT $ \ctx ->
let (_,font_props) = primAnswer $ runImage ctx textAttr
in runTraceDrawingT ctx mf >>= \(a,hf) ->
let prim = fontDeltaContext font_props $ primGroup $ hprimToList hf
in return (a, singleH $ prim1 $ prim)
instance DrawingCtxM (TraceDrawing u) where
askDC = TraceDrawing $ \ctx -> (ctx, mempty)
asksDC f = TraceDrawing $ \ctx -> (f ctx, mempty)
localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx)
instance Monad m => DrawingCtxM (TraceDrawingT u m) where
askDC = TraceDrawingT $ \ctx -> return (ctx, mempty)
asksDC f = TraceDrawingT $ \ctx -> return (f ctx, mempty)
localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx)
runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u)
runTraceDrawing ctx ma = getTraceDrawing ma ctx
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
runTraceDrawingT :: Monad m
=> DrawingContext -> TraceDrawingT u m a -> m (a, HPrim u)
runTraceDrawingT ctx ma = getTraceDrawingT ma ctx
execTraceDrawingT :: Monad m
=> DrawingContext -> TraceDrawingT u m a -> m (HPrim u)
execTraceDrawingT ctx ma = liftM snd $ runTraceDrawingT ctx ma
evalTraceDrawingT :: Monad m
=> DrawingContext -> TraceDrawingT u m a -> m a
evalTraceDrawingT ctx ma = liftM fst $ runTraceDrawingT ctx ma
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
evalQuery :: DrawingCtxM m => Query u a -> m a
evalQuery df = askDC >>= \ctx -> return $ runQuery ctx df
draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> Image u a -> m ()
draw gf = askDC >>= \ctx ->
let (PrimW o _) = runImage ctx gf
in trace (singleH o) >> return ()
drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> Image u a -> m a
drawi gf = askDC >>= \ctx ->
let (PrimW o a) = runImage ctx gf
in trace (singleH o) >> return a
drawl :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> Anchor u -> LocImage u a -> m ()
drawl ancr img = drawli ancr img >> return ()
drawli :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> Anchor u -> LocImage u a -> m a
drawli pt gf = askDC >>= \ctx ->
let (PrimW o a) = runLocImage pt ctx gf
in trace (singleH o) >> return a
drawc :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> Anchor u -> Anchor u -> ConnectorImage u a -> m ()
drawc an0 an1 img = drawci an0 an1 img >> return ()
drawci :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> Anchor u -> Anchor u -> ConnectorImage u a -> m a
drawci p0 p1 img = drawi (connect p0 p1 img)
node :: (Fractional u, TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> (Int,Int) -> LocImage u a -> m ()
node coord gf = nodei coord gf >> return ()
nodei :: (Fractional u, TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> (Int,Int) -> LocImage u a -> m a
nodei coord gf = askDC >>= \ctx ->
position coord >>= \pt ->
let (PrimW o a) = runLocImage pt ctx gf
in trace (singleH o) >> return a
drawrc :: ( Real u, Floating u, DrawingCtxM m, TraceM m
, CenterAnchor a, RadialAnchor a
, CenterAnchor b, RadialAnchor b
, u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b
)
=> a -> b -> ConnectorImage u ans -> m ()
drawrc a b gf = drawrci a b gf >> return ()
drawrci :: ( Real u, Floating u, DrawingCtxM m, TraceM m
, CenterAnchor a, RadialAnchor a
, CenterAnchor b, RadialAnchor b
, u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b
)
=> a -> b -> ConnectorImage u ans -> m ans
drawrci a b gf =
let (p0,p1) = radialConnectorPoints a b in drawi (connect p0 p1 gf)