module Wumpus.Basic.Graphic.Base
(
OPlus(..)
, oconcat
, anterior
, superior
, HAlign(..)
, VAlign(..)
, MonUnit
, TraceM(..)
, DrawingCtxM(..)
, asksDC
, PointSupplyM(..)
, HPrim
, hprimToList
, singleH
, PrimGraphic
, getPrimGraphic
, primGraphic
, collectH
) where
import Wumpus.Basic.Graphic.DrawingContext
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 Ord u => OPlus (BoundingBox u) where
oplus = boundaryUnion
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
data HAlign = HTop | HCenter | HBottom
deriving (Enum,Eq,Ord,Show)
data VAlign = VLeft | VCenter | VRight
deriving (Enum,Eq,Ord,Show)
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
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
primGraphic :: Primitive u -> PrimGraphic u
primGraphic = PrimGraphic
collectH :: PrimGraphic u -> HPrim u
collectH = singleH . getPrimGraphic