module Wumpus.Drawing.Shapes.Rectangle
(
Rectangle
, DRectangle
, rectangle
) where
import Wumpus.Drawing.Paths
import Wumpus.Drawing.Shapes.Base
import Wumpus.Basic.Geometry
import Wumpus.Basic.Kernel
import Wumpus.Core
import Control.Applicative
data Rectangle u = Rectangle
{ rect_ctm :: ShapeCTM u
, rect_hw :: !u
, rect_hh :: !u
}
deriving (Eq,Ord,Show)
type instance DUnit (Rectangle u) = u
type DRectangle = Rectangle Double
instance Functor Rectangle where
fmap f (Rectangle ctm hw hh) = Rectangle (fmap f ctm) (f hw) (f hh)
mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u
mapCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm
instance (Real u, Floating u) => Rotate (Rectangle u) where
rotate ang = mapCTM (rotate ang)
instance (Real u, Floating u) => RotateAbout (Rectangle u) where
rotateAbout ang pt = mapCTM (rotateAbout ang pt)
instance Fractional u => Scale (Rectangle u) where
scale sx sy = mapCTM (scale sx sy)
instance InterpretUnit u => Translate (Rectangle u) where
translate dx dy = mapCTM (translate dx dy)
runDisplaceCenter :: (Real u, Floating u)
=> (u -> u -> Vec2 u) -> Rectangle u -> Anchor u
runDisplaceCenter fn (Rectangle { rect_ctm = ctm
, rect_hw = hw
, rect_hh = hh }) =
projectFromCtr (fn hw hh) ctm
instance (Real u, Floating u) =>
CenterAnchor (Rectangle u) where
center = runDisplaceCenter $ \_ _ -> V2 0 0
instance (Real u, Floating u) =>
TopCornerAnchor (Rectangle u) where
topLeftCorner = runDisplaceCenter $ \hw hh -> V2 (hw) hh
topRightCorner = runDisplaceCenter $ \hw hh -> V2 hw hh
instance (Real u, Floating u) =>
BottomCornerAnchor (Rectangle u) where
bottomLeftCorner = runDisplaceCenter $ \hw hh -> V2 (hw) (hh)
bottomRightCorner = runDisplaceCenter $ \hw hh -> V2 hw (hh)
instance (Real u, Floating u) =>
SideMidpointAnchor (Rectangle u) where
sideMidpoint n a = step (n `mod` 4)
where
step 1 = north a
step 2 = west a
step 3 = south a
step _ = east a
instance (Real u, Floating u) =>
CardinalAnchor (Rectangle u) where
north = runDisplaceCenter $ \_ hh -> V2 0 hh
south = runDisplaceCenter $ \_ hh -> V2 0 (hh)
east = runDisplaceCenter $ \hw _ -> V2 hw 0
west = runDisplaceCenter $ \hw _ -> V2 (hw) 0
instance (Real u, Floating u) =>
CardinalAnchor2 (Rectangle u) where
northeast = radialAnchor (0.25*pi)
southeast = radialAnchor (1.75*pi)
southwest = radialAnchor (1.25*pi)
northwest = radialAnchor (0.75*pi)
instance (Real u, Floating u) =>
RadialAnchor (Rectangle u) where
radialAnchor theta = runDisplaceCenter $ \hw hh ->
rectRadialVector hw hh theta
rectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> Shape Rectangle u
rectangle w h =
makeShape (mkRectangle (0.5*w) (0.5*h)) (mkRectPath 0 (0.5*w) (0.5*h))
mkRectangle :: InterpretUnit u => u -> u -> LocThetaQuery u (Rectangle u)
mkRectangle hw hh = qpromoteLocTheta $ \ctr theta ->
pure $ Rectangle { rect_ctm = makeShapeCTM ctr theta
, rect_hw = hw
, rect_hh = hh
}
mkRectPath :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> u -> LocThetaQuery u (AbsPath u)
mkRectPath rnd hw hh = qpromoteLocTheta $ \ctr theta ->
let xs = runVertices4 ctr $ rectangleVertices hw hh
in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs