module Wumpus.Basic.Graphic.Drawing
(
Drawing
, DrawingT
, runDrawing
, execDrawing
, runDrawingT
, execDrawingT
, runFdcDrawing
, execFdcDrawing
, runFdcDrawingT
, execFdcDrawingT
, liftToPictureU
, liftToPictureMb
, mbPictureU
, draw
, xdraw
, drawi
, xdrawi
, at
, ati
, conn
, node
, nodei
) where
import Wumpus.Basic.Graphic.BaseClasses
import Wumpus.Basic.Graphic.BaseTypes
import Wumpus.Basic.Graphic.DrawingContext
import Wumpus.Core
import Control.Applicative
import Control.Monad
import Data.Monoid
newtype Drawing u a = Drawing {
getDrawing :: DrawingContext -> HPrim u -> (a, HPrim u) }
newtype DrawingT u m a = DrawingT {
getDrawingT :: DrawingContext -> HPrim u -> 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 s ->
let (a,s1) = getDrawing ma ctx s in (f a,s1)
instance Monad m => Functor (DrawingT u m) where
fmap f ma = DrawingT $ \ctx s ->
getDrawingT ma ctx s >>= \(a,s1) -> return (f a,s1)
instance Applicative (Drawing u) where
pure a = Drawing $ \_ s -> (a, s)
mf <*> ma = Drawing $ \ctx s -> let (f,s1) = getDrawing mf ctx s
(a,s2) = getDrawing ma ctx s1
in (f a, s2)
instance Monad m => Applicative (DrawingT u m) where
pure a = DrawingT $ \_ s -> return (a, s)
mf <*> ma = DrawingT $ \ctx s -> getDrawingT mf ctx s >>= \(f,s1) ->
getDrawingT ma ctx s1 >>= \(a,s2) ->
return (f a, s2)
instance Monad (Drawing u) where
return a = Drawing $ \_ s -> (a, s)
ma >>= k = Drawing $ \ctx s -> let (a,s1) = getDrawing ma ctx s
in (getDrawing . k) a ctx s1
instance Monad m => Monad (DrawingT u m) where
return a = DrawingT $ \_ s -> return (a, s)
ma >>= k = DrawingT $ \ctx s -> getDrawingT ma ctx s >>= \(a,s1) ->
(getDrawingT . k) a ctx s1
instance TraceM (Drawing u) where
trace a = Drawing $ \_ s -> ((), s `mappend` a)
instance Monad m => TraceM (DrawingT u m) where
trace a = DrawingT $ \_ s -> return ((), s `mappend` a)
instance DrawingCtxM (Drawing u) where
askCtx = Drawing $ \ctx s -> (ctx, s)
localCtx cF ma = Drawing $ \ctx s -> getDrawing ma (cF ctx) s
instance Monad m => DrawingCtxM (DrawingT u m) where
askCtx = DrawingT $ \ctx s -> return (ctx,s)
localCtx cF ma = DrawingT $ \ctx s -> getDrawingT ma (cF ctx) s
runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u)
runDrawing ctx ma = getDrawing ma ctx mempty
execDrawing :: DrawingContext -> Drawing u a -> HPrim u
execDrawing ctx ma = snd $ runDrawing ctx ma
runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u)
runDrawingT ctx ma = getDrawingT ma ctx mempty
execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u)
execDrawingT ctx ma = liftM snd $ 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 = askCtx >>= \ctx -> trace (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 = askCtx >>= \ctx ->
let (a,o) = runImage ctx img in trace o >> return a
xdrawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m)
=> XLink -> Image u a -> m a
xdrawi xl img = drawi (xlinkImage xl img)
infixr 1 `at`, `ati`
at :: LocGraphic u -> Point2 u -> Graphic u
at = ($)
ati :: LocImage u a -> Point2 u -> Image u a
ati = ($)
infixl 1 `conn`
conn :: ConnImage u a -> Point2 u -> LocImage u a
conn = ($)
node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)
=> LocGraphic u -> m ()
node gfL = askCtx >>= \ctx ->
position >>= \pt -> trace (runGraphic ctx $ gfL pt)
nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)
=> LocImage u a -> m a
nodei imgL = askCtx >>= \ctx ->
position >>= \pt ->
let (a,o) = runImage ctx (imgL pt) in trace o >> return a