module Wumpus.Basic.Kernel.Objects.Basis
(
PrimResult
, Image
, Graphic
, Query
, DImage
, DGraphic
, runImage
, runQuery
, zapQuery
, primGraphic
, clipImage
, UConvert(..)
, uconvImageF
, uconvImageZ
, emptyImage
, ignoreAns
, replaceAns
, Decorate(..)
, sdecorate
, adecorate
, selaborate
, aelaborate
) 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
type PrimResult u a = (a, CatPrim)
newtype Image u a = Image {
getImage :: DrawingContext -> (a, CatPrim) }
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 -> let (a,w1) = getImage ma ctx in (f a, w1)
instance Functor (Query u) where
fmap f ma = Query $ \ctx -> f $ getQuery ma ctx
instance Applicative (Image u) where
pure a = Image $ \_ -> (a,mempty)
mf <*> ma = Image $ \ctx -> let (f,w1) = getImage mf ctx
(a,w2) = getImage ma ctx
in (f a, w1 `mappend` w2)
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 $ \_ -> (a,mempty)
ma >>= k = Image $ \ctx -> let (a,w1) = getImage ma ctx
(b,w2) = getImage (k a) ctx
in (b,w1 `mappend` w2)
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 -> (ctx, mempty)
asksDC fn = Image $ \ctx -> (fn ctx, mempty)
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 :: Image u a -> DrawingContext -> PrimResult u a
runImage = getImage
runQuery :: Query u a -> DrawingContext -> a
runQuery = getQuery
zapQuery :: Query u a -> Image u a
zapQuery ma = askDC >>= \ctx -> let a = runQuery ma ctx in return a
primGraphic :: CatPrim -> Graphic u
primGraphic w = Image $ \_ -> (UNil, w)
clipImage :: PrimPath -> Image u a -> Image u a
clipImage pp ma = Image $ \ctx ->
let (a,w) = getImage ma ctx in (a, cpmap (clip pp) w)
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 (a,w) = getImage ma ctx
a' = uconvertF (dc_font_size ctx) a
in (a',w)
uconvImageZ :: (InterpretUnit u, InterpretUnit u1)
=> Image u a -> Image u1 a
uconvImageZ ma = Image $ \ctx -> getImage ma ctx
emptyImage :: Monoid a => Image u a
emptyImage = mempty
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 :: ZDeco -> f u a -> f u z -> f u a
elaborate :: ZDeco -> f u a -> (a -> f u z) -> f u a
obliterate :: f u a -> f u a
hyperlink :: XLink -> f u a -> f u a
sdecorate :: Decorate f => f u a -> f u z -> f u a
sdecorate = decorate SUPERIOR
adecorate :: Decorate f => f u a -> f u z -> f u a
adecorate = decorate ANTERIOR
selaborate :: Decorate f => f u a -> (a -> f u z) -> f u a
selaborate = elaborate SUPERIOR
aelaborate :: Decorate f => f u a -> (a -> f u z) -> f u a
aelaborate = elaborate ANTERIOR
decorateImage :: ZDeco -> Image u a -> Image u z -> Image u a
decorateImage zo ma mb = Image $ \ctx ->
step zo (getImage ma ctx) (getImage mb ctx)
where
step SUPERIOR (a,w1) (_,w2) = (a, w1 `mappend` w2)
step ANTERIOR (a,w1) (_,w2) = (a, w2 `mappend` w1)
elaborateImage :: ZDeco -> Image u a -> (a -> Image u z) -> Image u a
elaborateImage zo ma k = Image $ \ ctx ->
let (a,w1) = getImage ma ctx
(_,w2) = getImage (k a) ctx
in case zo of
SUPERIOR -> (a, w1 `mappend` w2)
ANTERIOR -> (a, w2 `mappend` w1)
obliterateImage :: Image u a -> Image u a
obliterateImage ma = Image $ \ctx ->
let (a,_) = getImage ma ctx in (a,mempty)
hyperlinkImage :: XLink -> Image u a -> Image u a
hyperlinkImage xl ma = Image $ \ctx -> step (getImage ma ctx)
where
step (a,w) = (a, cpmap (xlinkPrim xl) w)
instance Decorate Image where
decorate = decorateImage
elaborate = elaborateImage
obliterate = obliterateImage
hyperlink = hyperlinkImage
instance Rotate a => Rotate (Image u a) where
rotate ang ma = Image $ \ctx ->
let (a,w) = getImage ma ctx
in (rotate ang a, rotate ang w)
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
(a,w) = getImage ma ctx
in (rotateAbout ang pt a, rotateAbout ang ptu w)
instance Scale a => Scale (Image u a) where
scale sx sy ma = Image $ \ctx ->
let (a,w) = getImage ma ctx
in (scale sx sy a, scale sx sy w)
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
(a,w) = getImage ma ctx
in (translate dx dy a, translate ddx ddy w)