module Wumpus.Basic.Kernel.Objects.TraceDrawing
(
TraceDrawing
, DTraceDrawing
, TraceDrawingT
, DTraceDrawingT
, runTraceDrawing
, execTraceDrawing
, evalTraceDrawing
, runTraceDrawingT
, execTraceDrawingT
, evalTraceDrawingT
, liftToPictureU
, liftToPictureMb
, mbPictureU
, query
, draw
, xdraw
, drawi
, drawi_
, xdrawi
, xdrawi_
, node
, nodei
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Objects.BaseObjects
import Wumpus.Basic.Kernel.Objects.Graphic
import Wumpus.Core
import Control.Applicative
import Control.Monad
import Data.Monoid
newtype TraceDrawing u a = TraceDrawing {
getTraceDrawing :: DrawingContext -> (a, HPrim u) }
newtype TraceDrawingT u m a = TraceDrawingT {
getTraceDrawingT :: DrawingContext -> m (a, HPrim u) }
type DTraceDrawing a = TraceDrawing Double a
type DTraceDrawingT m a = TraceDrawingT Double m a
type instance MonUnit (TraceDrawing u) = u
type instance MonUnit (TraceDrawingT u m) = u
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)
instance Monad m => TraceM (TraceDrawingT u m) where
trace a = TraceDrawingT $ \_ -> return ((), a)
instance DrawingCtxM (TraceDrawing u) where
askDC = TraceDrawing $ \ctx -> (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)
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 :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u
liftToPictureU hf =
let prims = hprimToList hf in if null prims then errK else frame prims
where
errK = error "toPictureU - empty prims list."
liftToPictureMb :: (Real u, Floating u, FromPtSize u)
=> HPrim u -> Maybe (Picture u)
liftToPictureMb hf = let prims = hprimToList hf in
if null prims then Nothing else Just (frame prims)
mbPictureU :: (Real u, Floating u, FromPtSize u)
=> Maybe (Picture u) -> Picture u
mbPictureU Nothing = error "mbPictureU - empty picture."
mbPictureU (Just a) = a
query :: DrawingCtxM m => CF a -> m a
query df = askDC >>= \ctx -> return $ runCF ctx df
draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()
draw gf = askDC >>= \ctx -> trace (collectH $ snd $ runCF ctx gf)
xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> XLink -> Graphic u -> m ()
xdraw xl gf = draw (hyperlink xl gf)
drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a
drawi img = askDC >>= \ctx ->
let (a,o) = runCF ctx img in trace (collectH o) >> return a
drawi_ :: (TraceM m, DrawingCtxM m, MonUnit m ~ u) => Image u a -> m ()
drawi_ img = drawi img >> return ()
xdrawi :: (TraceM m, DrawingCtxM m, MonUnit m ~ u)
=> XLink -> Image u a -> m a
xdrawi xl img = drawi (hyperlink xl img)
xdrawi_ :: (TraceM m, DrawingCtxM m, MonUnit m ~ u)
=> XLink -> Image u a -> m ()
xdrawi_ xl img = xdrawi xl img >> return ()
node :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u)
=> LocGraphic u -> m ()
node gf = askDC >>= \ctx ->
position >>= \pt ->
let (_,prim) = runCF1 ctx pt gf in trace (collectH prim)
nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u)
=> LocImage u a -> m a
nodei imgL = askDC >>= \ctx ->
position >>= \pt ->
let (a,o) = runCF ctx (apply1R1 imgL pt)
in trace (collectH o) >> return a