module Wumpus.Basic.Graphic.Base
(
OPlus(..)
, oconcat
, anterior
, superior
, MonUnit
, TraceM(..)
, DrawingCtxM(..)
, asksDC
, PointSupplyM(..)
, HPrim
, hprimToList
, singleH
, Point2F
, DPoint2F
, DrawingR
, LocDrawingR
, DLocDrawingR
, DrawingTrafoF
, runDrawingR
, PrimGraphic
, getPrimGraphic
, wrapPrim
, collectH
, Graphic
, DGraphic
, GraphicTrafoF
, superiorGraphic
, anteriorGraphic
, runGraphic
, xlinkGraphic
, LocGraphic
, DLocGraphic
, Image
, DImage
, ImageTrafoF
, intoImageTrafo
, imageTrafoDrawing
, imageTrafoGraphic
, LocImage
, DLocImage
, runImage
, intoImage
, intoLocImage
, xlinkImage
, ConnectorDrawingR
, DConnectorDrawingR
, ConnectorGraphic
, DConnectorGraphic
, ConnectorImage
, DConnectorImage
, intoConnectorImage
, ThetaLocDrawingR
, DThetaLocDrawingR
, ThetaLocGraphic
, DThetaLocGraphic
, ThetaLocImage
, DThetaLocImage
, intoThetaLocImage
) where
import Wumpus.Basic.Graphic.DrawingContext
import Wumpus.Basic.Utils.Combinators
import Wumpus.Basic.Utils.HList
import Wumpus.Core
import Control.Applicative
import Data.Monoid
infixr 6 `oplus`
class OPlus t where
oplus :: t -> t -> t
oconcat :: OPlus t => t -> [t] -> t
oconcat t = step t
where
step ac [] = ac
step ac (x:xs) = step (ac `oplus` x) xs
anterior :: OPlus t => t -> (t -> t)
anterior a = (a `oplus`)
superior :: OPlus t => t -> (t -> t)
superior a = (`oplus` a)
instance OPlus (Primitive u) where
a `oplus` b = primGroup [a,b]
instance (OPlus a, OPlus b) => OPlus (a,b) where
(a,b) `oplus` (a',b') = (a `oplus` a', b `oplus` b')
instance OPlus a => OPlus (r -> a) where
f `oplus` g = \x -> f x `oplus` g x
type family MonUnit m :: *
class Monad m => TraceM (m :: * -> *) where
trace :: HPrim (MonUnit m) -> m ()
class (Applicative m, 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 (Primitive u) }
instance Monoid (HPrim u) where
mempty = HPrim emptyH
ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb
hprimToList :: HPrim u -> [Primitive u]
hprimToList = toListH . getHPrim
singleH :: Primitive 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 OPlus a => OPlus (DrawingR a) where
fa `oplus` fb = DrawingR $ \ctx ->
getDrawingR fa ctx `oplus` getDrawingR fb 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 DrawingTrafoF a = DrawingR a -> DrawingR a
newtype PrimGraphic u = PrimGraphic { getPrimGraphic :: Primitive u }
deriving (Eq,Show)
type instance DUnit (PrimGraphic u) = u
instance OPlus (PrimGraphic u) where
oplus a b = PrimGraphic $ getPrimGraphic a `oplus` getPrimGraphic b
instance (Real u, Floating u) => Rotate (PrimGraphic u) where
rotate ang = PrimGraphic . rotate ang . getPrimGraphic
instance (Real u, Floating u) => RotateAbout (PrimGraphic u) where
rotateAbout ang pt = PrimGraphic . rotateAbout ang pt . getPrimGraphic
instance Num u => Scale (PrimGraphic u) where
scale sx sy = PrimGraphic . scale sx sy . getPrimGraphic
instance Num u => Translate (PrimGraphic u) where
translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic
wrapPrim :: Primitive u -> PrimGraphic u
wrapPrim = PrimGraphic
collectH :: PrimGraphic u -> HPrim u
collectH = singleH . getPrimGraphic
type Graphic u = DrawingR (PrimGraphic u)
type DGraphic = Graphic Double
type instance DUnit (Graphic u) = u
runGraphic :: DrawingContext -> Graphic u -> PrimGraphic u
runGraphic ctx gf = (getDrawingR gf) ctx
xlinkGraphic :: XLink -> Graphic u -> Graphic u
xlinkGraphic xlink gf = DrawingR $ \ctx ->
let a = runGraphic ctx gf
in PrimGraphic $ xlinkGroup xlink [getPrimGraphic a]
instance (Real u, Floating u) => Rotate (Graphic u) where
rotate ang = liftA (rotate ang)
instance (Real u, Floating u) => RotateAbout (Graphic u) where
rotateAbout ang pt = liftA (rotateAbout ang pt)
instance Num u => Scale (Graphic u) where
scale sx sy = liftA (scale sx sy)
instance Num u => Translate (Graphic u) where
translate dx dy = liftA (translate dx dy)
type GraphicTrafoF u = Graphic u -> Graphic u
anteriorGraphic :: Graphic u -> GraphicTrafoF u
anteriorGraphic = anterior
superiorGraphic :: Graphic u -> GraphicTrafoF u
superiorGraphic = superior
type LocGraphic u = Point2 u -> Graphic u
type DLocGraphic = LocGraphic Double
type Image u a = DrawingR (a, PrimGraphic u)
type DImage a = Image Double a
type instance DUnit (Image u a) = u
runImage :: DrawingContext -> Image u a -> (a, PrimGraphic u)
runImage ctx img = (getDrawingR img) ctx
intoImage :: DrawingR a -> Graphic u -> Image u a
intoImage f g = forkA f g
instance (Real u, Floating u, Rotate a, DUnit a ~ u) =>
Rotate (Image u a) where
rotate ang = liftA (prod (rotate ang) (rotate ang))
instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) =>
RotateAbout (Image u a) where
rotateAbout ang pt = liftA (prod (rotateAbout ang pt) (rotateAbout ang pt))
instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where
scale sx sy = liftA (prod (scale sx sy) (scale sx sy))
instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where
translate dx dy = liftA (prod (translate dx dy) (translate dx dy))
type ImageTrafoF u a = Image u a -> Image u a
intoImageTrafo :: DrawingTrafoF a -> GraphicTrafoF u -> ImageTrafoF u a
intoImageTrafo df gf img = img >>= \(a,prim) ->
intoImage (df $ pure a) (gf $ pure prim)
imageTrafoDrawing :: DrawingTrafoF a -> ImageTrafoF u a
imageTrafoDrawing df = intoImageTrafo df id
imageTrafoGraphic :: GraphicTrafoF u -> ImageTrafoF u a
imageTrafoGraphic gf = intoImageTrafo id gf
type LocImage u a = Point2 u -> Image u a
type DLocImage a = LocImage Double a
intoLocImage :: LocDrawingR u a -> LocGraphic u -> LocImage u a
intoLocImage f g pt = forkA (f pt) (g pt)
xlinkImage :: XLink -> Image u a -> Image u a
xlinkImage xlink img = DrawingR $ \ctx ->
let (a,pg) = runImage ctx img
in (a, PrimGraphic $ xlinkGroup xlink [getPrimGraphic pg])
type ConnectorDrawingR u a = Point2 u -> Point2 u -> DrawingR a
type DConnectorDrawingR a = ConnectorDrawingR Double a
type ConnectorGraphic u = Point2 u -> Point2 u -> Graphic u
type DConnectorGraphic = ConnectorGraphic Double
type ConnectorImage u a = Point2 u -> Point2 u -> Image u a
type DConnectorImage a = ConnectorImage Double a
intoConnectorImage :: ConnectorDrawingR u a
-> ConnectorGraphic u
-> ConnectorImage u a
intoConnectorImage f g p1 p2 = forkA (f p1 p2) (g p1 p2)
type ThetaLocDrawingR u a = Radian -> LocDrawingR u a
type DThetaLocDrawingR a = ThetaLocDrawingR Double a
type ThetaLocGraphic u = Radian -> LocGraphic u
type DThetaLocGraphic = ThetaLocGraphic Double
type ThetaLocImage u a = Radian -> LocImage u a
type DThetaLocImage a = ThetaLocImage Double a
intoThetaLocImage :: ThetaLocDrawingR u a
-> ThetaLocGraphic u
-> ThetaLocImage u a
intoThetaLocImage f g theta pt = forkA (f theta pt) (g theta pt)