module Wumpus.Basic.Kernel.Objects.PosObject
(
PosObject
, DPosObject
, runPosObject
, makePosObject
, emptyPosObject
, localPosObject
, decoPosObject
, extendPosObject
, mapOrientation
, illustratePosObject
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Base.UpdateDC
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Concat
import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Basic.Kernel.Objects.Orientation
import Wumpus.Core
import Wumpus.Core.Colour ( red, blue )
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
import Data.Monoid
type PosDraw u = Point2 u -> CatPrim
newtype PosObject u = PosObject
{ getPosObject :: Query u (Orientation u, PosDraw u) }
type instance DUnit (PosObject u) = u
type DPosObject = PosObject Double
instance (Fractional u, Ord u, InterpretUnit u) => Monoid (PosObject u) where
mempty = emptyPosObject
mappend = poconcat
poconcat :: (Fractional u, Ord u) => PosObject u -> PosObject u -> PosObject u
poconcat a b = PosObject body
where
body = askDC >>= \ctx ->
let ans1 = runQuery ctx (getPosObject a)
ans2 = runQuery ctx (getPosObject b)
in pure (appendW ans1 ans2)
appendW :: (Fractional u, Ord u)
=> (Orientation u, PosDraw u)
-> (Orientation u, PosDraw u)
-> (Orientation u, PosDraw u)
appendW (o0,pf0) (o1,pf1) = let pf = \pt -> pf0 pt `mappend` pf1 pt
in (o0 `mappend` o1, pf)
runPosObject :: Fractional u
=> RectAddress -> PosObject u -> LocImage u (BoundingBox u)
runPosObject addr (PosObject mf) = promoteLoc $ \pt ->
askDC >>= \ctx ->
let (o1,df) = runQuery ctx mf
v1 = orientationStart addr o1
p1 = pt .+^ v1
bb = orientationBounds o1 p1
in replaceAns bb $ primGraphic (df p1)
makePosObject :: Query u (Orientation u) -> LocGraphic u -> PosObject u
makePosObject qortt gf = PosObject body
where
body = askDC >>= \ctx ->
let v1 = runQuery ctx qortt
pf = \pt -> getCP $ runLocImage pt ctx gf
in return (v1,pf)
getCP (PrimW ca _) = ca
emptyPosObject :: InterpretUnit u => PosObject u
emptyPosObject = PosObject $ pure (Orientation 0 0 0 0, const mempty)
localPosObject :: DrawingContextF -> PosObject u -> PosObject u
localPosObject upd = PosObject . localize upd . getPosObject
decoPosObject :: (Orientation u -> LocGraphic u) -> ZDeco
-> PosObject u -> PosObject u
decoPosObject fn zdec po = PosObject body
where
body = askDC >>= \ctx ->
let (ortt,ptf) = runQuery ctx (getPosObject po)
deco = \pt -> getCP $ runLocImage pt ctx (fn ortt)
gf = case zdec of
ANTERIOR -> deco `mappend` ptf
SUPERIOR -> ptf `mappend` deco
in return (ortt, gf)
getCP (PrimW ca _) = ca
extendPosObject :: Num u
=> u -> u -> u -> u -> PosObject u -> PosObject u
extendPosObject x0 x1 y0 y1 po = PosObject body
where
body = askDC >>= \ctx ->
let (o0,pf0) = runQuery ctx (getPosObject po)
ortt = extendOrientation x0 x1 y0 y1 o0
in return (ortt,pf0)
mapOrientation :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u
mapOrientation fn po = PosObject body
where
body = askDC >>= \ctx ->
let (o0,pf0) = runQuery ctx (getPosObject po)
in return (fn o0,pf0)
illustratePosObject :: InterpretUnit u
=> PosObject u -> LocGraphic u
illustratePosObject (PosObject mf) = promoteLoc $ \pt ->
zapQuery mf >>= \(ortt,ptf) ->
decorate (primGraphic $ ptf pt) (illustrateOrientation ortt `at` pt)
illustrateOrientation :: InterpretUnit u
=> Orientation u -> LocGraphic u
illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt ->
dinterpCtx 3 >>= \radius ->
let upd = localize (fill_colour blue . dotted_line)
bl = pt .-^ V2 xmin ymin
dot = localize (fill_colour red) $ dcDisk FILL radius `at` pt
hln = upd $ locStraightLine (hvec $ xmin+xmaj) `at` pt .-^ hvec xmin
vln = upd $ locStraightLine (vvec $ ymin+ymaj) `at` pt .-^ vvec ymin
bdr = upd $ dcRectangle STROKE (xmin+xmaj) (ymin+ymaj) `at` bl
in mconcat [ bdr, hln, vln, dot ]
instance (Fractional u, Ord u, InterpretUnit u) => ZConcat (PosObject u) where
superior = mappend
anterior = flip mappend
instance (Num u, Ord u) => Concat (PosObject u) where
hconcat = genMoveAlign spinemoveH spineRight
vconcat = genMoveAlign spinemoveV spineBelow
instance (Num u, Ord u) => CatSpace (PosObject u) where
hspace = genMoveSepH spinemoveH spineRight
vspace = genMoveSepV spinemoveV spineBelow
instance (Fractional u, Ord u) => Align (PosObject u) where
halign HTop = genMoveAlign binmoveHTop halignTopO
halign HCenter = genMoveAlign binmoveHCenter halignCenterO
halign HBottom = genMoveAlign binmoveHBottom halignBottomO
valign VLeft = genMoveAlign binmoveVLeft valignLeftO
valign VCenter = genMoveAlign binmoveVCenter valignCenterO
valign VRight = genMoveAlign binmoveVRight valignRightO
genMoveAlign :: (Num u)
=> (Orientation u -> Orientation u -> Vec2 u)
-> (Orientation u -> Orientation u -> Orientation u)
-> PosObject u -> PosObject u -> PosObject u
genMoveAlign mkV mkO po0 po1 = PosObject body
where
body = askDC >>= \ctx ->
let (ortt0,pf0) = runQuery ctx (getPosObject po0)
(ortt1,pf1) = runQuery ctx (getPosObject po1)
v1 = mkV ortt0 ortt1
ortt = mkO ortt0 ortt1
pf = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)
in return (ortt,pf)
instance (Fractional u, Ord u) => AlignSpace (PosObject u) where
halignSpace HTop = genMoveSepH binmoveHTop halignTopO
halignSpace HCenter = genMoveSepH binmoveHCenter halignCenterO
halignSpace HBottom = genMoveSepH binmoveHBottom halignBottomO
valignSpace VLeft = genMoveSepV binmoveVLeft valignLeftO
valignSpace VCenter = genMoveSepV binmoveVCenter valignCenterO
valignSpace VRight = genMoveSepV binmoveVRight valignRightO
genMoveSepH :: (Num u)
=> (Orientation u -> Orientation u -> Vec2 u)
-> (Orientation u -> Orientation u -> Orientation u)
-> u
-> PosObject u -> PosObject u -> PosObject u
genMoveSepH mkV mkO sep po0 po1 = PosObject body
where
body = askDC >>= \ctx ->
let (ortt0,pf0) = runQuery ctx (getPosObject po0)
(ortt1,pf1) = runQuery ctx (getPosObject po1)
v1 = hvec sep ^+^ mkV ortt0 ortt1
ortt = extendORight sep $ mkO ortt0 ortt1
pf = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)
in return (ortt,pf)
genMoveSepV :: (Num u)
=> (Orientation u -> Orientation u -> Vec2 u)
-> (Orientation u -> Orientation u -> Orientation u)
-> u
-> PosObject u -> PosObject u -> PosObject u
genMoveSepV mkV mkO sep po0 po1 = PosObject body
where
body = askDC >>= \ctx ->
let (ortt0,pf0) = runQuery ctx (getPosObject po0)
(ortt1,pf1) = runQuery ctx (getPosObject po1)
v1 = vvec (sep) ^+^ mkV ortt0 ortt1
ortt = extendODown sep $ mkO ortt0 ortt1
pf = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)
in return (ortt,pf)