module Wumpus.Basic.Kernel.Objects.Basis
(
PrimW(..)
, primAnswer
, Image
, Graphic
, Query
, DImage
, DGraphic
, runImage
, runQuery
, zapQuery
, primGraphic
, clipImage
, UConvert(..)
, uconvImageF
, uconvImageZ
, emptyImage
, both
, ignoreAns
, replaceAns
, Decorate(..)
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Core
import Control.Applicative
import Data.Monoid
data PrimW u a = PrimW CatPrim a
type instance DUnit (PrimW u a) = u
instance Monoid a => Monoid (PrimW u a) where
mempty = PrimW mempty mempty
PrimW ca a `mappend` PrimW cb b = PrimW (ca `mappend` cb) (a `mappend` b)
instance Functor (PrimW u) where
fmap f (PrimW w a) = PrimW w (f a)
instance Applicative (PrimW u) where
pure a = PrimW mempty a
(PrimW c1 f) <*> (PrimW c2 a) = PrimW (c1 `mappend` c2) (f a)
instance Monad (PrimW u) where
return a = PrimW mempty a
(PrimW c1 a) >>= mf = let (PrimW c2 b) = mf a
in PrimW (c1 `mappend` c2) b
primAnswer :: PrimW u a -> a
primAnswer (PrimW _ a) = a
bimapPrimW :: (CatPrim -> CatPrim) -> (a -> a) -> PrimW u a -> PrimW u a
bimapPrimW f g (PrimW ca a) = PrimW (f ca) (g a)
szconvPrimF :: (Functor t, InterpretUnit u, InterpretUnit u1)
=> FontSize -> PrimW u (t u) -> PrimW u1 (t u1)
szconvPrimF sz (PrimW c a) = PrimW c (uconvertF sz a)
szconvPrimZ :: (InterpretUnit u, InterpretUnit u1)
=> FontSize -> PrimW u a -> PrimW u1 a
szconvPrimZ _ (PrimW c a) = PrimW c a
newtype Image u a = Image {
getImage :: DrawingContext -> PrimW u a }
type instance DUnit (Image u a) = u
type Graphic u = Image u (UNil u)
type DImage a = Image Double a
type DGraphic = Graphic Double
newtype Query u a = Query {
getQuery :: DrawingContext -> a }
type instance DUnit (Query u a) = u
instance Functor (Image u) where
fmap f ma = Image $ \ctx -> fmap f $ getImage ma ctx
instance Functor (Query u) where
fmap f ma = Query $ \ctx -> f $ getQuery ma ctx
instance Applicative (Image u) where
pure a = Image $ \_ -> pure a
mf <*> ma = Image $ \ctx ->
getImage mf ctx <*> getImage ma ctx
instance Applicative (Query u) where
pure a = Query $ \_ -> a
mf <*> ma = Query $ \ctx -> let f = getQuery mf ctx
a = getQuery ma ctx
in f a
instance Monad (Image u) where
return a = Image $ \_ -> return a
ma >>= k = Image $ \ctx -> getImage ma ctx >>= \ans -> getImage (k ans) ctx
instance Monad (Query u) where
return a = Query $ \_ -> a
ma >>= k = Query $ \ctx -> let a = getQuery ma ctx in getQuery (k a) ctx
instance Monoid a => Monoid (Image u a) where
mempty = pure mempty
ma `mappend` mb = Image $ \ctx ->
getImage ma ctx `mappend` getImage mb ctx
instance Monoid a => Monoid (Query u a) where
mempty = pure mempty
ma `mappend` mb = Query $ \ctx ->
getQuery ma ctx `mappend` getQuery mb ctx
instance DrawingCtxM (Image u) where
askDC = Image $ \ctx -> return ctx
asksDC fn = Image $ \ctx -> return (fn ctx)
localize upd ma = Image $ \ctx -> getImage ma (upd ctx)
instance DrawingCtxM (Query u) where
askDC = Query $ \ctx -> ctx
asksDC fn = Query $ \ctx -> (fn ctx)
localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)
runImage :: DrawingContext -> Image u a -> PrimW u a
runImage ctx mf = getImage mf ctx
runQuery :: DrawingContext -> Query u a -> a
runQuery ctx mf = getQuery mf ctx
zapQuery :: Query u a -> Image u a
zapQuery mq = askDC >>= \ctx -> let a = runQuery ctx mq in return a
primGraphic :: CatPrim -> Graphic u
primGraphic ca = Image $ \_ -> PrimW ca UNil
clipImage :: PrimPath -> Image u a -> Image u a
clipImage pp ma = Image $ \ctx -> step (getImage ma ctx)
where
step (PrimW ca a) = PrimW (cpmap (clip pp) ca) a
class UConvert (f :: * -> * -> *) where
uconvF :: (Functor t, InterpretUnit u, InterpretUnit u1)
=> f u (t u) -> f u1 (t u1)
uconvZ :: (InterpretUnit u, InterpretUnit u1)
=> f u a -> f u1 a
instance UConvert Image where
uconvZ = uconvImageZ
uconvF = uconvImageF
uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1)
=> Image u (t u) -> Image u1 (t u1)
uconvImageF ma = Image $ \ctx ->
let sz = dc_font_size ctx
ans = getImage ma ctx
in szconvPrimF sz ans
uconvImageZ :: (InterpretUnit u, InterpretUnit u1)
=> Image u a -> Image u1 a
uconvImageZ ma = Image $ \ctx ->
let sz = dc_font_size ctx
ans = getImage ma ctx
in szconvPrimZ sz ans
emptyImage :: Monoid a => Image u a
emptyImage = mempty
both :: Applicative f => f a -> f b -> f (a,b)
both fa fb = (,) <$> fa <*> fb
ignoreAns :: Functor (f u) => f u a -> f u (UNil u)
ignoreAns = fmap (const UNil)
replaceAns :: Functor (f u) => a -> f u z -> f u a
replaceAns a = fmap (const a)
class Decorate (f :: * -> * -> *) where
decorate :: f u a -> f u z -> f u a
elaborate :: f u a -> (a -> f u z) -> f u a
obliterate :: f u a -> f u z -> f u a
hyperlink :: XLink -> f u a -> f u a
getCatPrim :: PrimW u a -> CatPrim
getCatPrim (PrimW ca _) = ca
decorateImage :: Image u a -> Image u z -> Image u a
decorateImage ma mb = Image $ \ctx ->
step (getImage ma ctx) (getImage mb ctx)
where
step (PrimW ca a) (PrimW cb _) = PrimW (ca `mappend` cb) a
elaborateImage :: Image u a -> (a -> Image u z) -> Image u a
elaborateImage ma k = Image $ \ ctx -> case getImage ma ctx of
PrimW ca a -> let cb = getCatPrim $ getImage (k a) ctx
in PrimW (ca `mappend` cb) a
obliterateImage :: Image u a -> Image u z -> Image u a
obliterateImage ma mb = Image $ \ctx ->
let a = primAnswer $ getImage ma ctx
ca = getCatPrim $ getImage mb ctx
in PrimW ca a
hyperlinkImage :: XLink -> Image u a -> Image u a
hyperlinkImage xl ma = Image $ \ctx -> step (getImage ma ctx)
where
step (PrimW ca a) = PrimW (cpmap (xlinkPrim xl) ca) a
instance Decorate Image where
decorate = decorateImage
elaborate = elaborateImage
obliterate = obliterateImage
hyperlink = hyperlinkImage
instance Rotate a => Rotate (PrimW u a) where
rotate ang (PrimW ca a) = PrimW (rotate ang ca) (rotate ang a)
instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) =>
RotateAbout (PrimW u a) where
rotateAbout ang pt@(P2 x y) (PrimW ca a) =
PrimW (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) ca)
(rotateAbout ang pt a)
instance Scale a => Scale (PrimW u a) where
scale sx sy (PrimW ca a) = PrimW (scale sx sy ca) (scale sx sy a)
instance (Translate a, ScalarUnit u, u ~ DUnit a) =>
Translate (PrimW u a) where
translate dx dy (PrimW cp a) =
PrimW (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy a)
instance Rotate a => Rotate (Image u a) where
rotate ang ma = Image $ \ctx ->
bimapPrimW (rotate ang) (rotate ang) $ getImage ma ctx
instance (RotateAbout a, InterpretUnit u, u ~ DUnit a) =>
RotateAbout (Image u a) where
rotateAbout ang pt ma = Image $ \ctx ->
let ptu = uconvertF (dc_font_size ctx) pt
in bimapPrimW (rotateAbout ang ptu) (rotateAbout ang pt) $ getImage ma ctx
instance Scale a => Scale (Image u a) where
scale sx sy ma = Image $ \ctx ->
bimapPrimW (scale sx sy) (scale sx sy) $ getImage ma ctx
instance (Translate a, InterpretUnit u, u ~ DUnit a) =>
Translate (Image u a) where
translate dx dy ma = Image $ \ctx ->
let sz = dc_font_size ctx
ddx = uconvert1 sz dx
ddy = uconvert1 sz dy
in bimapPrimW (translate ddx ddy) (translate dx dy) $ getImage ma ctx