module Wumpus.Basic.Kernel.Objects.AdvObject
(
AdvObject
, DAdvObject
, AdvGraphic
, DAdvGraphic
, makeAdvObject
, emptyAdvObject
, runAdvObjectR0
, runAdvObjectR1
, advance
, advances
, advspace
, evenspace
, advrepeat
, punctuate
, advfill
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Displacement
import Wumpus.Basic.Kernel.Objects.Image
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
import Data.Monoid
type AdvDraw u = Point2 u -> GraphicAns u
newtype AdvObject u = AdvObject { getAdvObject :: CF (Vec2 u, AdvDraw u) }
type instance DUnit (AdvObject u) = u
type DAdvObject = AdvObject Double
type AdvGraphic u = LocImage u (Vec2 u)
type DAdvGraphic = AdvGraphic Double
instance (InterpretUnit u) => Monoid (AdvObject u) where
mempty = emptyAdvObject
mappend = advplus
makeAdvObject :: Query (Vec2 u) -> LocGraphic u -> AdvObject u
makeAdvObject qvec gf = AdvObject body
where
body = drawingCtx >>= \ctx ->
let v1 = runCF ctx qvec
pf = runCF ctx gf
in return (v1,pf)
emptyAdvObject :: InterpretUnit u => AdvObject u
emptyAdvObject = makeAdvObject (pure $ V2 0 0) emptyLocGraphic
runAdvObjectR0 :: Point2 u -> AdvObject u -> Image u (Vec2 u)
runAdvObjectR0 pt (AdvObject mf) =
(\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf
runAdvObjectR1 :: AdvObject u -> AdvGraphic u
runAdvObjectR1 (AdvObject mf) = promoteR1 $ \pt ->
(\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf
advplus :: Num u => AdvObject u -> AdvObject u -> AdvObject u
advplus a b = AdvObject body
where
body = drawingCtx >>= \ctx ->
let (v0,pf0) = runCF ctx (getAdvObject a)
(v1,pf1) = runCF ctx (getAdvObject b)
pf = \pt -> pf0 pt `oplus` pf1 (pt .+^ v0)
in return (v0 ^+^ v1, pf)
listcat :: InterpretUnit u
=> (AdvObject u -> AdvObject u -> AdvObject u)
-> [AdvObject u] -> AdvObject u
listcat _ [] = emptyAdvObject
listcat op (x:xs) = go x xs
where
go acc [] = acc
go acc (b:bs) = go (acc `op` b) bs
infixr 6 `advance`
advance :: Num u => AdvObject u -> AdvObject u -> AdvObject u
advance = advplus
advances :: InterpretUnit u => [AdvObject u] -> AdvObject u
advances = listcat advance
advspace :: Num u => Vec2 u -> AdvObject u -> AdvObject u -> AdvObject u
advspace sep a b = AdvObject body
where
body = drawingCtx >>= \ctx ->
let (v0,pf0) = runCF ctx (getAdvObject a)
(v1,pf1) = runCF ctx (getAdvObject b)
pf = \pt -> pf0 pt `oplus` pf1 (displaceVec (sep ^+^ v0) pt)
in return (v0 ^+^ sep ^+^ v1, pf)
evenspace :: InterpretUnit u => Vec2 u -> [AdvObject u] -> AdvObject u
evenspace v = listcat (advspace v)
advrepeat :: InterpretUnit u => Int -> AdvObject u -> AdvObject u
advrepeat n = advances . replicate n
punctuate :: InterpretUnit u => AdvObject u -> [AdvObject u] -> AdvObject u
punctuate sep = listcat (\a b -> a `advance` sep `advance` b)
advfill :: Num u => Vec2 u -> AdvObject u -> AdvObject u
advfill sv a = AdvObject body
where
body = drawingCtx >>= \ctx ->
let (_,pf) = runCF ctx (getAdvObject a) in return (sv, pf)