module Wumpus.Basic.Kernel.Objects.LocImage
(
LocImage
, LocGraphic
, DLocImage
, DLocGraphic
, LocQuery
, runLocImage
, runLocQuery
, promoteLoc
, applyLoc
, qpromoteLoc
, qapplyLoc
, zapLocQuery
, extrLoc
, emptyLocImage
, moveStart
, at
, distrib
, distribH
, distribV
, duplicate
, duplicateH
, duplicateV
)
where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
import Data.Monoid
newtype LocImage u a = LocImage {
getLocImage :: DPoint2 -> Image u a }
type instance DUnit (LocImage u a) = u
type LocGraphic u = LocImage u (UNil u)
type DLocImage a = LocImage Double a
type DLocGraphic = LocGraphic Double
newtype LocQuery u a = LocQuery {
getLocQuery :: Point2 u -> Query u a }
instance Functor (LocImage u) where
fmap f ma = LocImage $ \pt -> fmap f $ getLocImage ma pt
instance Functor (LocQuery u) where
fmap f ma = LocQuery $ \pt -> fmap f $ getLocQuery ma pt
instance Applicative (LocImage u) where
pure a = LocImage $ \_ -> pure a
mf <*> ma = LocImage $ \pt -> getLocImage mf pt <*> getLocImage ma pt
instance Applicative (LocQuery u) where
pure a = LocQuery $ \_ -> pure a
mf <*> ma = LocQuery $ \pt -> getLocQuery mf pt <*> getLocQuery ma pt
instance Monad (LocImage u) where
return a = LocImage $ \_ -> return a
ma >>= k = LocImage $ \pt -> getLocImage ma pt >>= \ans ->
getLocImage (k ans) pt
instance Monad (LocQuery u) where
return a = LocQuery $ \_ -> return a
ma >>= k = LocQuery $ \pt -> getLocQuery ma pt >>= \ans ->
getLocQuery (k ans) pt
instance Monoid a => Monoid (LocImage u a) where
mempty = pure mempty
ma `mappend` mb = LocImage $ \pt ->
getLocImage ma pt `mappend` getLocImage mb pt
instance Monoid a => Monoid (LocQuery u a) where
mempty = pure mempty
ma `mappend` mb = LocQuery $ \pt ->
getLocQuery ma pt `mappend` getLocQuery mb pt
instance DrawingCtxM (LocImage u) where
askDC = LocImage $ \_ -> askDC
asksDC fn = LocImage $ \_ -> asksDC fn
localize upd ma = LocImage $ \pt -> localize upd (getLocImage ma pt)
instance DrawingCtxM (LocQuery u) where
askDC = LocQuery $ \_ -> askDC
asksDC fn = LocQuery $ \_ -> asksDC fn
localize upd ma = LocQuery $ \pt -> localize upd (getLocQuery ma pt)
instance Decorate LocImage where
decorate zo ma mz = LocImage $ \pt ->
decorate zo (getLocImage ma pt) (getLocImage mz pt)
elaborate zo ma f = LocImage $ \pt ->
elaborate zo (getLocImage ma pt) (\a -> getLocImage (f a) pt)
obliterate ma = LocImage $ \pt -> obliterate $ getLocImage ma pt
hyperlink xl ma = LocImage $ \pt -> hyperlink xl $ getLocImage ma pt
runLocImage :: InterpretUnit u
=> LocImage u a -> DrawingContext -> Point2 u -> PrimResult u a
runLocImage ma ctx pt =
let dpt = normalizeF (dc_font_size ctx) pt
in runImage (getLocImage ma dpt) ctx
runLocQuery :: LocQuery u a -> DrawingContext -> Point2 u -> a
runLocQuery ma ctx pt = runQuery (getLocQuery ma pt) ctx
promoteLoc :: InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a
promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= \upt -> k upt
applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
applyLoc mq pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mq dpt
qpromoteLoc :: (Point2 u -> Query u a) -> LocQuery u a
qpromoteLoc k = LocQuery $ \pt -> k pt
qapplyLoc :: LocQuery u a -> Point2 u -> Query u a
qapplyLoc mq pt = getLocQuery mq pt
extrLoc :: InterpretUnit u => LocImage u a -> LocQuery u a
extrLoc ma = LocQuery $ \pt ->
askDC >>= \ctx ->
let (a,_) = runLocImage ma ctx pt
in return a
zapLocQuery :: LocQuery u a -> Point2 u -> Image u a
zapLocQuery ma pt = askDC >>= \ctx ->
let a = runLocQuery ma ctx pt in return a
instance (Real u, Floating u, InterpretUnit u, Rotate a) =>
Rotate (LocImage u a) where
rotate ang ma = promoteLoc $ \pt ->
zapQuery (normalizeCtxF pt) >>= \dpt ->
fmap (rotate ang) $ getLocImage ma (rotate ang dpt)
instance (Real u, Floating u, InterpretUnit u, RotateAbout a, u ~ DUnit a) =>
RotateAbout (LocImage u a) where
rotateAbout ang pt ma = promoteLoc $ \p0 ->
zapQuery (normalizeCtxF p0) >>= \dp0 ->
zapQuery (normalizeCtxF pt) >>= \dpt ->
fmap (rotateAbout ang pt) $
getLocImage ma (rotateAbout ang dpt dp0)
instance (Fractional u, InterpretUnit u, Scale a) => Scale (LocImage u a) where
scale sx sy ma = promoteLoc $ \pt ->
zapQuery (normalizeCtxF pt) >>= \dpt ->
fmap (scale sx sy) $ getLocImage ma (scale sx sy dpt)
instance (InterpretUnit u, Translate a, ScalarUnit u, u ~ DUnit a) =>
Translate (LocImage u a) where
translate dx dy ma = promoteLoc $ \pt ->
zapQuery (normalizeCtxF pt) >>= \dpt ->
zapQuery (normalizeCtx dx) >>= \ddx ->
zapQuery (normalizeCtx dy) >>= \ddy ->
fmap (translate dx dy) $
getLocImage ma (translate ddx ddy dpt)
instance UConvert LocImage where
uconvF = uconvLocImageF
uconvZ = uconvLocImageZ
uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t)
=> LocImage u (t u) -> LocImage u1 (t u1)
uconvLocImageF ma = LocImage $ \pt -> uconvF $ getLocImage ma pt
uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1)
=> LocImage u a -> LocImage u1 a
uconvLocImageZ ma = LocImage $ \pt -> uconvZ $ getLocImage ma pt
emptyLocImage :: Monoid a => LocImage u a
emptyLocImage = mempty
moveStart :: InterpretUnit u => Vec2 u -> LocImage u a -> LocImage u a
moveStart v1 ma = LocImage $ \pt ->
zapQuery (normalizeCtxF v1) >>= \dv -> getLocImage ma (pt .+^ dv)
infixr 1 `at`
at :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
at mf pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mf dpt
distrib :: (Monoid a, InterpretUnit u)
=> Vec2 u -> [LocImage u a] -> LocImage u a
distrib _ [] = mempty
distrib v1 (x:xs) = promoteLoc $ \pt ->
go (applyLoc x pt) (pt .+^ v1) xs
where
go acc _ [] = acc
go acc pt (a:as) = go (acc `mappend` applyLoc a pt) (pt .+^ v1) as
distribH :: (Monoid a, InterpretUnit u)
=> u -> [LocImage u a] -> LocImage u a
distribH dx = distrib (hvec dx)
distribV :: (Monoid a, InterpretUnit u)
=> u -> [LocImage u a] -> LocImage u a
distribV dy = distrib (hvec dy)
duplicate :: (Monoid a, InterpretUnit u)
=> Int -> Vec2 u -> LocImage u a -> LocImage u a
duplicate n _ _ | n < 1 = mempty
duplicate n v img = go img v (n1)
where
go acc _ i | i < 1 = acc
go acc v1 i = let img1 = moveStart v1 img
in go (acc `mappend` img1) (v1 ^+^ v) (i1)
duplicateH :: (Monoid a, InterpretUnit u)
=> Int -> u -> LocImage u a -> LocImage u a
duplicateH n dx = duplicate n (hvec dx)
duplicateV :: (Monoid a, InterpretUnit u)
=> Int -> u -> LocImage u a -> LocImage u a
duplicateV n dy = duplicate n (vvec dy)