module Wumpus.Basic.Graphic.Drawing
(
Drawing
, DrawingT
, runDrawing
, execDrawing
, evalDrawing
, runDrawingT
, execDrawingT
, evalDrawingT
, runFdcDrawing
, execFdcDrawing
, runFdcDrawingT
, execFdcDrawingT
, liftToPictureU
, liftToPictureMb
, mbPictureU
, draw
, xdraw
, drawi
, drawi_
, xdrawi
, xdrawi_
, at
, node
, nodei
) where
import Wumpus.Basic.Graphic.Base
import Wumpus.Basic.Graphic.DrawingContext
import Wumpus.Core
import Control.Applicative
import Control.Monad
import Data.Monoid
newtype Drawing u a = Drawing {
getDrawing :: DrawingContext -> (a, HPrim u) }
newtype DrawingT u m a = DrawingT {
getDrawingT :: DrawingContext -> m (a, HPrim u) }
type instance MonUnit (Drawing u) = u
type instance MonUnit (DrawingT u m) = u
instance Functor (Drawing u) where
fmap f ma = Drawing $ \ctx ->
let (a,w) = getDrawing ma ctx in (f a,w)
instance Monad m => Functor (DrawingT u m) where
fmap f ma = DrawingT $ \ctx ->
getDrawingT ma ctx >>= \(a,w) -> return (f a,w)
instance Applicative (Drawing u) where
pure a = Drawing $ \_ -> (a, mempty)
mf <*> ma = Drawing $ \ctx -> let (f,w1) = getDrawing mf ctx
(a,w2) = getDrawing ma ctx
in (f a, w1 `mappend` w2)
instance Monad m => Applicative (DrawingT u m) where
pure a = DrawingT $ \_ -> return (a,mempty)
mf <*> ma = DrawingT $ \ctx -> getDrawingT mf ctx >>= \(f,w1) ->
getDrawingT ma ctx >>= \(a,w2) ->
return (f a, w1 `mappend` w2)
instance Monad (Drawing u) where
return a = Drawing $ \_ -> (a, mempty)
ma >>= k = Drawing $ \ctx -> let (a,w1) = getDrawing ma ctx
(b,w2) = (getDrawing . k) a ctx
in (b,w1 `mappend` w2)
instance Monad m => Monad (DrawingT u m) where
return a = DrawingT $ \_ -> return (a, mempty)
ma >>= k = DrawingT $ \ctx -> getDrawingT ma ctx >>= \(a,w1) ->
(getDrawingT . k) a ctx >>= \(b,w2) ->
return (b, w1 `mappend` w2)
instance TraceM (Drawing u) where
trace a = Drawing $ \_ -> ((), a)
instance Monad m => TraceM (DrawingT u m) where
trace a = DrawingT $ \_ -> return ((), a)
instance DrawingCtxM (Drawing u) where
askDC = Drawing $ \ctx -> (ctx, mempty)
localize upd ma = Drawing $ \ctx -> getDrawing ma (upd ctx)
instance Monad m => DrawingCtxM (DrawingT u m) where
askDC = DrawingT $ \ctx -> return (ctx,mempty)
localize upd ma = DrawingT $ \ctx -> getDrawingT ma (upd ctx)
runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u)
runDrawing ctx ma = getDrawing ma ctx
execDrawing :: DrawingContext -> Drawing u a -> HPrim u
execDrawing ctx ma = snd $ runDrawing ctx ma
evalDrawing :: DrawingContext -> Drawing u a -> a
evalDrawing ctx ma = fst $ runDrawing ctx ma
runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u)
runDrawingT ctx ma = getDrawingT ma ctx
execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u)
execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma
evalDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m a
evalDrawingT ctx ma = liftM fst $ runDrawingT ctx ma
runFdcDrawing :: (Real u, Floating u, FromPtSize u)
=> DrawingContext -> Drawing u a -> (a, Maybe (Picture u))
runFdcDrawing ctx ma =
let (a,hp) = runDrawing ctx ma
ps = hprimToList hp
fdc = font_props ctx
in if null ps then (a, Nothing)
else (a, Just $ fontDeltaContext fdc $ frame ps)
execFdcDrawing :: (Real u, Floating u, FromPtSize u)
=> DrawingContext -> Drawing u a -> Maybe (Picture u)
execFdcDrawing ctx ma = snd $ runFdcDrawing ctx ma
runFdcDrawingT :: (Real u, Floating u, FromPtSize u, Monad m)
=> DrawingContext -> DrawingT u m a -> m (a, Maybe (Picture u))
runFdcDrawingT ctx ma =
runDrawingT ctx ma >>= \(a,hp) ->
let ps = hprimToList hp
fdc = font_props ctx
in if null ps then return (a, Nothing)
else return (a, Just $ fontDeltaContext fdc $ frame ps)
execFdcDrawingT :: (Real u, Floating u, FromPtSize u, Monad m)
=> DrawingContext -> DrawingT u m a -> m (Maybe (Picture u))
execFdcDrawingT ctx ma = liftM snd $ runFdcDrawingT 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
draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()
draw gf = askDC >>= \ctx -> trace (collectH $ runGraphic ctx gf)
xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> XLink -> Graphic u -> m ()
xdraw xl gf = draw (xlinkGraphic xl gf)
drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a
drawi img = askDC >>= \ctx ->
let (a,o) = runImage ctx img in trace (collectH o) >> return a
drawi_ :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m ()
drawi_ img = drawi img >> return ()
xdrawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> XLink -> Image u a -> m a
xdrawi xl img = drawi (xlinkImage xl img)
xdrawi_ :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> XLink -> Image u a -> m ()
xdrawi_ xl img = xdrawi xl img >> return ()
infixr 1 `at`
at :: (Point2 u -> a) -> Point2 u -> a
at = ($)
node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)
=> LocGraphic u -> m ()
node gfL = askDC >>= \ctx ->
position >>= \pt ->
trace (collectH $ runGraphic ctx $ gfL pt)
nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)
=> LocImage u a -> m a
nodei imgL = askDC >>= \ctx ->
position >>= \pt ->
let (a,o) = runImage ctx (imgL pt)
in trace (collectH o) >> return a