module Wumpus.Basic.Kernel.Objects.PosObject
(
PosObject
, DPosObject
, LocRectQuery
, BoundedLocRectGraphic
, makePosObject
, makeBindPosObject
, emptyPosObject
, runPosObjectR0
, runPosObjectR1
, runPosObjectR2
, localizePO
, elaboratePO
, aelaboratePO
, startAddr
, atStartAddr
, extendPosObject
, padHorizontalPO
, padLeftPO
, padRightPO
, padVerticalPO
, padUpPO
, padDownPO
, illustratePosObject
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Base.UpdateDC
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Bounded
import Wumpus.Basic.Kernel.Objects.Concat
import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
import Wumpus.Basic.Kernel.Objects.Displacement
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 -> GraphicAns u
newtype PosObject u = PosObject
{ getPosObject :: CF (Orientation u, PosDraw u) }
type instance DUnit (PosObject u) = u
type DPosObject = PosObject Double
type LocRectQuery u a = CF (Point2 u -> RectAddress -> a)
type BoundedLocRectGraphic u = LocRectQuery u (ImageAns u (BoundingBox u))
instance (Fractional u, Ord u) => OPlus (PosObject u) where
oplus = poconcat
instance (Fractional u, Ord u, InterpretUnit u) => Monoid (PosObject u) where
mempty = pozero
mappend = poconcat
pozero :: InterpretUnit u => PosObject u
pozero = PosObject body
where
body = drawingCtx >>= \ctx ->
let pf = \pt -> runCF ctx (apply1R1 emptyLocGraphic pt)
in return (Orientation 0 0 0 0, pf)
poconcat :: (Fractional u, Ord u) => PosObject u -> PosObject u -> PosObject u
poconcat a b = PosObject body
where
body = drawingCtx >>= \ctx ->
let (o0,pf0) = runCF ctx (getPosObject a)
(o1,pf1) = runCF ctx (getPosObject b)
pf = \pt -> pf0 pt `oplus` pf1 pt
in return (o0 `oplus` o1, pf)
makePosObject :: Query (Orientation u) -> LocGraphic u -> PosObject u
makePosObject qortt gf = PosObject body
where
body = drawingCtx >>= \ctx ->
let ortt = runCF ctx qortt
pf = runCF ctx gf
in return (ortt,pf)
makeBindPosObject :: Query a
-> (a -> Query (Orientation u)) -> (a -> LocGraphic u)
-> PosObject u
makeBindPosObject qy mkO mkG = PosObject body
where
body = drawingCtx >>= \ctx ->
let a = runCF ctx qy
ortt = runCF ctx (mkO a)
pf = runCF ctx (mkG a)
in return (ortt,pf)
emptyPosObject :: InterpretUnit u => PosObject u
emptyPosObject =
makePosObject (pure $ Orientation 0 0 0 0) emptyLocGraphic
runPosObjectR0 :: Fractional u
=> Point2 u -> RectAddress -> PosObject u -> BoundedGraphic u
runPosObjectR0 pt addr (PosObject mf) =
mf >>= \(ortt,ptf) -> let sv = orientationStart addr ortt
bb = orientationBounds ortt (displaceVec sv pt)
in pure $ replaceAns bb $ ptf $ displaceVec sv pt
runPosObjectR1 :: Fractional u
=> RectAddress -> PosObject u -> BoundedLocGraphic u
runPosObjectR1 addr obj = promoteR1 $ \start -> runPosObjectR0 start addr obj
runPosObjectR2 :: Fractional u
=> PosObject u -> BoundedLocRectGraphic u
runPosObjectR2 obj = promoteR2 $ \start addr -> runPosObjectR0 start addr obj
localizePO :: DrawingContextF -> PosObject u -> PosObject u
localizePO upd = PosObject . localize upd . getPosObject
elaboratePO :: (Orientation u -> LocGraphic u) -> PosObject u -> PosObject u
elaboratePO fn po = PosObject body
where
body = drawingCtx >>= \ctx ->
let (ortt,ptf) = runCF ctx (getPosObject po)
deco = runCF ctx (fn ortt)
in return (ortt, ptf `oplus` deco)
aelaboratePO :: (Orientation u -> LocGraphic u) -> PosObject u -> PosObject u
aelaboratePO fn po = PosObject body
where
body = drawingCtx >>= \ctx ->
let (ortt,ptf) = runCF ctx (getPosObject po)
deco = runCF ctx (fn ortt)
in return (ortt, deco `oplus` ptf)
infixr 1 `startAddr`
startAddr :: Floating u
=> BoundedLocRectGraphic u -> RectAddress -> BoundedLocGraphic u
startAddr = apply1R2
atStartAddr :: Floating u
=> BoundedLocRectGraphic u -> Point2 u -> RectAddress
-> BoundedGraphic u
atStartAddr = apply2R2
extendPosObject :: Num u
=> u -> u -> u -> u -> PosObject u -> PosObject u
extendPosObject x0 x1 y0 y1 po = PosObject body
where
body = drawingCtx >>= \ctx ->
let (o0,pf0) = runCF ctx (getPosObject po)
ortt = extendOrientation x0 x1 y0 y1 o0
in return (ortt,pf0)
padHorizontalPO :: (Fractional u, Ord u) => u -> PosObject u -> PosObject u
padHorizontalPO w = genPad (padHEven w)
padLeftPO :: (Num u, Ord u) => u -> PosObject u -> PosObject u
padLeftPO w = genPad (padXMinor w)
padRightPO :: (Num u, Ord u) => u -> PosObject u -> PosObject u
padRightPO w = genPad (padXMajor w)
padVerticalPO :: (Fractional u, Ord u) => u -> PosObject u -> PosObject u
padVerticalPO w = genPad (padVEven w)
padUpPO :: (Num u, Ord u) => u -> PosObject u -> PosObject u
padUpPO h = genPad (padYMajor h)
padDownPO :: (Num u, Ord u) => u -> PosObject u -> PosObject u
padDownPO h = genPad (padYMinor h)
genPad :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u
genPad fn po = PosObject body
where
body = drawingCtx >>= \ctx ->
let (o0,pf0) = runCF ctx (getPosObject po)
ortt = fn o0
in return (ortt,pf0)
illustratePosObject :: InterpretUnit u
=> PosObject u -> LocGraphic u
illustratePosObject (PosObject mf) = promoteR1 $ \pt ->
mf >>= \(ortt,ptf) ->
decorateR0 (pure $ ptf pt) (illustrateOrientation ortt `at` pt)
illustrateOrientation :: InterpretUnit u
=> Orientation u -> LocGraphic u
illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteR1 $ \pt ->
dinterpCtx 3 >>= \radius ->
let upd = localize (fill_colour blue . dotted_line)
bl = pt .-^ V2 xmin ymin
dot = localize (fill_colour red) $ filledDisk 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 $ strokedRectangle (xmin+xmaj) (ymin+ymaj) `at` bl
in bdr `oplus` hln `oplus` vln `oplus` dot
instance (Fractional u, Ord u) => ZConcat (PosObject u) where
superior = oplus
anterior = flip oplus
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 = drawingCtx >>= \ctx ->
let (ortt0,pf0) = runCF ctx (getPosObject po0)
(ortt1,pf1) = runCF 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 = drawingCtx >>= \ctx ->
let (ortt0,pf0) = runCF ctx (getPosObject po0)
(ortt1,pf1) = runCF 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 = drawingCtx >>= \ctx ->
let (ortt0,pf0) = runCF ctx (getPosObject po0)
(ortt1,pf1) = runCF 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)