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.ContextFun
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.Image
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) = runCF 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) = runCF 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 a -> m a
evalQuery df = askDC >>= \ctx -> return $ runCF ctx df
draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> Image u a -> m ()
draw gf = askDC >>= \ctx ->
let Ans o _ = runCF ctx gf
in trace (singleH o) >> return ()
drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )
=> Image u a -> m a
drawi img = askDC >>= \ctx ->
let Ans o a = runCF ctx img
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 img = askDC >>= \ctx ->
let Ans o a = runCF ctx img pt
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 img p0 p1)
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 Ans o a = runCF ctx gf pt
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 img =
let (p0,p1) = radialConnectorPoints a b in drawi (connect img p0 p1)