module Wumpus.Basic.Graphic.Base
(
MonUnit
, TraceM(..)
, DrawingCtxM(..)
, asksDC
, PointSupplyM(..)
, HPrim
, hprimToList
, singleH
, Point2F
, DPoint2F
, DrawingR
, LocDrawingR
, DLocDrawingR
, runDrawingR
, Graphic
, DGraphic
, runGraphic
, xlinkGraphic
, LocGraphic
, DLocGraphic
, Image
, DImage
, LocImage
, DLocImage
, runImage
, intoImage
, intoLocImage
, xlinkImage
, ConnDrawingR
, DConnDrawingR
, ConnGraphic
, DConnGraphic
, ConnImage
, DConnImage
, intoConnImage
) where
import Wumpus.Basic.Graphic.DrawingContext
import Wumpus.Basic.Utils.HList
import Wumpus.Core
import Control.Applicative
import Data.Monoid
type family MonUnit m :: *
class Monad m => TraceM (m :: * -> *) where
trace :: HPrim (MonUnit m) -> m ()
class Monad m => DrawingCtxM (m :: * -> *) where
askDC :: m DrawingContext
localize :: (DrawingContext -> DrawingContext) -> m a -> m a
asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a
asksDC f = askDC >>= (return . f)
class Monad m => PointSupplyM (m :: * -> *) where
position :: u ~ MonUnit m => m (Point2 u)
newtype HPrim u = HPrim { getHPrim :: H (PrimElement u) }
instance Monoid (HPrim u) where
mempty = HPrim emptyH
ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb
hprimToList :: HPrim u -> [PrimElement u]
hprimToList = toListH . getHPrim
singleH :: PrimElement u -> HPrim u
singleH = HPrim . wrapH
type Point2F u = Point2 u -> Point2 u
type DPoint2F = Point2F Double
newtype DrawingR a = DrawingR { getDrawingR :: DrawingContext -> a }
instance Functor DrawingR where
fmap f ma = DrawingR $ \ctx -> f $ getDrawingR ma ctx
instance Monoid a => Monoid (DrawingR a) where
mempty = DrawingR $ \_ -> mempty
fa `mappend` fb = DrawingR $ \ctx ->
getDrawingR fa ctx `mappend` getDrawingR fb ctx
instance Applicative DrawingR where
pure a = DrawingR $ \_ -> a
mf <*> ma = DrawingR $ \ctx -> let f = getDrawingR mf ctx
a = getDrawingR ma ctx
in f a
instance Monad DrawingR where
return a = DrawingR $ \_ -> a
ma >>= k = DrawingR $ \ctx -> let a = getDrawingR ma ctx
in (getDrawingR . k) a ctx
instance DrawingCtxM DrawingR where
askDC = DrawingR $ \ctx -> ctx
localize upd df = DrawingR $ \ctx -> getDrawingR df (upd ctx)
runDrawingR :: DrawingContext -> DrawingR a -> a
runDrawingR ctx df = getDrawingR df ctx
type LocDrawingR u a = Point2 u -> DrawingR a
type DLocDrawingR a = LocDrawingR Double a
type Graphic u = DrawingR (HPrim u)
type DGraphic = Graphic Double
runGraphic :: DrawingContext -> Graphic u -> HPrim u
runGraphic ctx gf = (getDrawingR gf) ctx
xlinkGraphic :: XLink -> Graphic u -> Graphic u
xlinkGraphic xlink gf = DrawingR $ \ctx ->
let xs = hprimToList $ runGraphic ctx gf
in (singleH $ xlinkGroup xlink xs)
type LocGraphic u = Point2 u -> Graphic u
type DLocGraphic = LocGraphic Double
type Image u a = DrawingR (a, HPrim u)
type DImage a = Image Double a
type LocImage u a = Point2 u -> Image u a
type DLocImage a = LocImage Double a
runImage :: DrawingContext -> Image u a -> (a,HPrim u)
runImage ctx img = (getDrawingR img) ctx
intoImage :: DrawingR a -> Graphic u -> Image u a
intoImage f g = DrawingR $ \ctx ->
let a = getDrawingR f ctx; o = getDrawingR g ctx in (a,o)
intoLocImage :: LocDrawingR u a -> LocGraphic u -> LocImage u a
intoLocImage f g pt = DrawingR $ \ctx ->
let a = getDrawingR (f pt) ctx; o = getDrawingR (g pt) ctx in (a,o)
xlinkImage :: XLink -> Image u a -> Image u a
xlinkImage xlink img = DrawingR $ \ctx ->
let (a,hp) = runImage ctx img
in (a, singleH $ xlinkGroup xlink $ hprimToList hp)
type ConnDrawingR u a = Point2 u -> Point2 u -> DrawingR a
type DConnDrawingR a = ConnDrawingR Double a
type ConnGraphic u = Point2 u -> Point2 u -> Graphic u
type DConnGraphic = ConnGraphic Double
type ConnImage u a = Point2 u -> Point2 u -> Image u a
type DConnImage a = ConnImage Double a
intoConnImage :: ConnDrawingR u a -> ConnGraphic u -> ConnImage u a
intoConnImage f g p1 p2 = DrawingR $ \ctx ->
let a = getDrawingR (f p1 p2) ctx; o = getDrawingR (g p1 p2) ctx in (a,o)