module Wumpus.Basic.Graphic.BaseTypes
(
HPrim
, hprimToList
, singleH
, Point2F
, DPoint2F
, DrawingF
, LocDrawingF
, DLocDrawingF
, runDF
, pureDF
, askDF
, asksDF
, localDF
, Graphic
, DGraphic
, runGraphic
, xlinkGraphic
, LocGraphic
, DLocGraphic
, localLG
, lgappend
, Image
, DImage
, LocImage
, DLocImage
, runImage
, intoImage
, intoLocImage
, xlinkImage
, ConnDrawingF
, DConnDrawingF
, 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
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 DrawingF a = DrawingF { getDrawingF :: DrawingContext -> a }
instance Functor DrawingF where
fmap f ma = DrawingF $ \ctx -> f $ getDrawingF ma ctx
instance Monoid a => Monoid (DrawingF a) where
mempty = DrawingF $ \_ -> mempty
fa `mappend` fb = DrawingF $ \ctx ->
getDrawingF fa ctx `mappend` getDrawingF fb ctx
instance Applicative DrawingF where
pure a = DrawingF $ \_ -> a
mf <*> ma = DrawingF $ \ctx -> let f = getDrawingF mf ctx
a = getDrawingF ma ctx
in f a
instance Monad DrawingF where
return a = DrawingF $ \_ -> a
ma >>= k = DrawingF $ \ctx -> let a = getDrawingF ma ctx
in (getDrawingF . k) a ctx
runDF :: DrawingContext -> DrawingF a -> a
runDF ctx df = getDrawingF df ctx
pureDF :: a -> DrawingF a
pureDF a = DrawingF $ \ _ctx -> a
askDF :: DrawingF DrawingContext
askDF = DrawingF id
asksDF :: (DrawingContext -> a) -> DrawingF a
asksDF fn = DrawingF $ \ctx -> fn ctx
localDF :: (DrawingContext -> DrawingContext)
-> DrawingF a -> DrawingF a
localDF upd gf = DrawingF $ \ctx -> getDrawingF gf (upd ctx)
type LocDrawingF u a = Point2 u -> DrawingF a
type DLocDrawingF a = LocDrawingF Double a
type Graphic u = DrawingF (HPrim u)
type DGraphic = Graphic Double
runGraphic :: DrawingContext -> Graphic u -> HPrim u
runGraphic ctx gf = (getDrawingF gf) ctx
xlinkGraphic :: XLink -> Graphic u -> Graphic u
xlinkGraphic xlink gf = askDF >>= \ctx ->
let xs = hprimToList $ runGraphic ctx gf in pureDF (singleH $ xlinkGroup xlink xs)
type LocGraphic u = Point2 u -> Graphic u
type DLocGraphic = LocGraphic Double
localLG ::
(DrawingContext -> DrawingContext) -> LocGraphic u -> LocGraphic u
localLG upd img = \pt -> localDF upd (img pt)
lgappend :: LocGraphic u -> LocGraphic u -> LocGraphic u
lgappend f g = \pt -> f pt `mappend` g pt
type Image u a = DrawingF (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 = (getDrawingF img) ctx
intoImage :: DrawingF a -> Graphic u -> Image u a
intoImage f g = DrawingF $ \ctx ->
let a = getDrawingF f ctx; o = getDrawingF g ctx in (a,o)
intoLocImage :: LocDrawingF u a -> LocGraphic u -> LocImage u a
intoLocImage f g pt = DrawingF $ \ctx ->
let a = getDrawingF (f pt) ctx; o = getDrawingF (g pt) ctx in (a,o)
xlinkImage :: XLink -> Image u a -> Image u a
xlinkImage xlink img = askDF >>= \ctx ->
let (a,hp) = runImage ctx img
in pureDF (a, singleH $ xlinkGroup xlink $ hprimToList hp)
type ConnDrawingF u a = Point2 u -> Point2 u -> DrawingF a
type DConnDrawingF a = ConnDrawingF 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 :: ConnDrawingF u a -> ConnGraphic u -> ConnImage u a
intoConnImage f g p1 p2 = DrawingF $ \ctx ->
let a = getDrawingF (f p1 p2) ctx; o = getDrawingF (g p1 p2) ctx in (a,o)