module Wumpus.Basic.Kernel.Objects.Bounded
(
BoundedGraphic
, BoundedLocGraphic
, BoundedLocThetaGraphic
, centerOrthoBBox
, emptyBoundedLocGraphic
, emptyBoundedLocThetaGraphic
, illustrateBoundedGraphic
, illustrateBoundedLocGraphic
, illustrateBoundedLocThetaGraphic
, bbrectangle
, boundedRect
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.UpdateDC
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
import Wumpus.Basic.Kernel.Objects.Image
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Basic.Kernel.Objects.LocThetaImage
import Wumpus.Core
import Data.Monoid
type BoundedGraphic u = Image u (BoundingBox u)
type BoundedLocGraphic u = LocImage u (BoundingBox u)
type BoundedLocThetaGraphic u = LocThetaImage u (BoundingBox u)
centerOrthoBBox :: (Real u, Floating u, Ord u)
=> Radian -> BoundingBox u -> BoundingBox u
centerOrthoBBox theta bb = traceBoundary $ map (rotateAbout theta ctr) ps
where
ctr = boundaryCenter bb
ps = boundaryCornerList bb
emptyBoundedLocGraphic :: InterpretUnit u => BoundedLocGraphic u
emptyBoundedLocGraphic = promoteLoc $ \pt ->
replaceAns (BBox pt pt) $ primGraphic mempty
emptyBoundedLocThetaGraphic :: InterpretUnit u
=> BoundedLocThetaGraphic u
emptyBoundedLocThetaGraphic = promoteLocTheta $ \pt _ ->
replaceAns (BBox pt pt) $ primGraphic mempty
illustrateBoundedGraphic :: InterpretUnit u
=> Image u (BoundingBox u) -> Image u (BoundingBox u)
illustrateBoundedGraphic gf = aelaborate gf bbrectangle
illustrateBoundedLocGraphic :: InterpretUnit u
=> LocImage u (BoundingBox u)
-> LocImage u (BoundingBox u)
illustrateBoundedLocGraphic gf = aelaborate gf fn
where
fn bb = promoteLoc $ \_ -> bbrectangle bb
illustrateBoundedLocThetaGraphic :: InterpretUnit u
=> LocThetaImage u (BoundingBox u)
-> LocThetaImage u (BoundingBox u)
illustrateBoundedLocThetaGraphic gf = aelaborate gf fn
where
fn bb = promoteLocTheta $ \_ _ -> bbrectangle bb
bbrectangle :: InterpretUnit u => BoundingBox u -> Graphic u
bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))
| llx == urx && lly == ury = mempty `at` p1
| otherwise =
localize drawing_props $ rect1 `mappend` cross
where
drawing_props = cap_round . dotted_line
rect1 = dcRectangle DRAW_STROKE (urxllx) (urylly) `at` p1
cross = straightLine p1 p2
`mappend` straightLine (P2 llx ury) (P2 urx lly)
boundedRect :: InterpretUnit u
=> DrawMode -> u -> u -> BoundedLocGraphic u
boundedRect style w h = promoteLoc $ \pt@(P2 x y) ->
let bb = BBox pt (P2 (x + w) (y + h))
in replaceAns bb $ applyLoc (dcRectangle style w h) pt