module Wumpus.Basic.Kernel.Objects.LocImage
(
LocGraphic
, LocImage
, DLocImage
, DLocGraphic
, intoLocImage
, locGraphic_
, emptyLocGraphic
, uconvLocImageF
, uconvLocImageZ
, distrib
, distribH
, distribV
, duplicate
, duplicateH
, duplicateV
)
where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Displacement
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
import Data.Monoid
type LocImage u a = LocQuery u (ImageAns u a)
type LocGraphic u = LocQuery u (GraphicAns u)
type DLocImage a = LocImage Double a
type DLocGraphic = LocGraphic Double
intoLocImage :: LocQuery u a -> LocGraphic u -> LocImage u a
intoLocImage ma gf = promoteR1 $ \pt ->
replaceAns <$> apply1R1 ma pt <*> apply1R1 gf pt
locGraphic_ :: LocImage u a -> LocGraphic u
locGraphic_ = (fmap . fmap) ignoreAns
emptyLocGraphic :: InterpretUnit u => LocGraphic u
emptyLocGraphic = promoteR1 $ \pt ->
uconvertCtxF pt >>= \dpt ->
return $ graphicAns $ prim1 $ zostroke $ emptyPrimPath dpt
uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t)
=> LocImage u (t u) -> LocImage u1 (t u1)
uconvLocImageF = uconvR1 szconvAnsF
uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1)
=> LocImage u a -> LocImage u1 a
uconvLocImageZ = uconvR1 szconvAnsZ
distrib :: (Monoid a, InterpretUnit u)
=> Vec2 u -> [LocImage u a] -> LocImage u a
distrib _ [] = pushR1 (replaceAns mempty) $ emptyLocGraphic
distrib v1 (x:xs) = promoteR1 $ \pt ->
go (x `at` pt) (pt .+^ v1) xs
where
go acc _ [] = acc
go acc pt (a:as) = go (acc `mappend` apply1R1 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 = pushR1 (replaceAns mempty) $ emptyLocGraphic
duplicate n v img = go img v (n1)
where
go acc _ i | i < 1 = acc
go acc va i = let img1 = moveStart (displaceVec va) img
in go (acc `mappend` img1) (va ^+^ 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)