module Wumpus.Basic.Kernel.Objects.LocImage
(
LocImage
, LocGraphic
, DLocImage
, DLocGraphic
, LocQuery
, runLocImage
, runLocQuery
, promoteLoc
, applyLoc
, qpromoteLoc
, qapplyLoc
, zapLocQuery
, 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 :: Point2 u -> 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 ma mz = LocImage $ \pt ->
getLocImage ma pt `decorate` getLocImage mz pt
elaborate ma f = LocImage $ \pt ->
getLocImage ma pt `elaborate` (\a -> getLocImage (f a) pt)
obliterate ma mz = LocImage $ \pt ->
getLocImage ma pt `obliterate` getLocImage mz pt
hyperlink xl ma = LocImage $ \pt ->
hyperlink xl $ getLocImage ma pt
runLocImage :: Point2 u -> DrawingContext -> LocImage u a -> PrimW u a
runLocImage pt ctx mf = runImage ctx (getLocImage mf pt)
runLocQuery :: Point2 u -> DrawingContext -> LocQuery u a -> a
runLocQuery pt ctx mf = runQuery ctx (getLocQuery mf pt)
promoteLoc :: (Point2 u -> Image u a) -> LocImage u a
promoteLoc k = LocImage $ \pt -> k pt
applyLoc :: LocImage u a -> Point2 u -> Image u a
applyLoc mq pt = getLocImage mq pt
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
zapLocQuery :: LocQuery u a -> Point2 u -> Image u a
zapLocQuery mq pt = askDC >>= \ctx -> let a = runLocQuery pt ctx mq in return a
instance (Real u, Floating u, Rotate a) => Rotate (LocImage u a) where
rotate ang ma = promoteLoc $ \pt ->
fmap (rotate ang) $ getLocImage ma (rotate ang pt)
instance (Real u, Floating u, RotateAbout a, ScalarUnit u, u ~ DUnit a) =>
RotateAbout (LocImage u a) where
rotateAbout ang pt ma = promoteLoc $ \p0 ->
fmap (rotateAbout ang pt) $
getLocImage ma (rotateAbout ang pt p0)
instance (Fractional u, Scale a) => Scale (LocImage u a) where
scale sx sy ma = promoteLoc $ \pt ->
fmap (scale sx sy) $ getLocImage ma (scale sx sy pt)
instance (Num u, Translate a, ScalarUnit u, u ~ DUnit a) =>
Translate (LocImage u a) where
translate dx dy ma = promoteLoc $ \pt ->
fmap (translate dx dy) $
getLocImage ma (translate dx dy pt)
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 ->
getFontSize >>= \sz ->
let ptu = uconvertF sz pt
in uconvF $ getLocImage ma ptu
uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1)
=> LocImage u a -> LocImage u1 a
uconvLocImageZ ma = LocImage $ \pt ->
getFontSize >>= \sz ->
let ptu = uconvertF sz pt
in uconvZ $ getLocImage ma ptu
emptyLocImage :: Monoid a => LocImage u a
emptyLocImage = mempty
moveStart :: Num u => Vec2 u -> LocImage u a -> LocImage u a
moveStart v1 ma = LocImage $ \pt -> getLocImage ma (pt .+^ v1)
infixr 1 `at`
at :: LocImage u a -> Point2 u -> Image u a
at mf pt = getLocImage mf pt
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)