module Wumpus.Drawing.Shapes.Rectangle
(
Rectangle
, DRectangle
, rectangle
) where
import Wumpus.Drawing.Paths
import Wumpus.Drawing.Shapes.Base
import Wumpus.Basic.Geometry.Paths
import Wumpus.Basic.Geometry.Quadrant
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 DRectangle = Rectangle Double
type instance DUnit (Rectangle u) = u
mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u
mapCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm
instance Num u => Scale (Rectangle u) where
scale sx sy = mapCTM (scale sx sy)
instance 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 Num u => Translate (Rectangle u) where
translate dx dy = mapCTM (translate dx dy)
runDisplaceCenter :: (Real u, Floating u)
=> (u -> u -> Vec2 u) -> Rectangle u -> Point2 u
runDisplaceCenter fn (Rectangle { rect_ctm = ctm
, rect_hw = hw
, rect_hh = hh }) =
displaceCenter (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, FromPtSize u)
=> u -> u -> Shape u (Rectangle u)
rectangle w h =
makeShape (mkRectangle (0.5*w) (0.5*h))
(mkRectPath (0.5*w) (0.5*h))
mkRectangle :: Num u => u -> u -> LocThetaCF u (Rectangle u)
mkRectangle hw hh = promoteR2 $ \ctr theta ->
pure $ Rectangle { rect_ctm = makeShapeCTM ctr theta
, rect_hw = hw
, rect_hh = hh
}
mkRectPath :: (Real u, Floating u, FromPtSize u)
=> u -> u -> LocThetaCF u (Path u)
mkRectPath hw hh = promoteR2 $ \ctr theta ->
let btm_left = displace (hw) (hh) ctr
in roundCornerShapePath $ map (rotateAbout theta ctr)
$ rectangleCoordPath (2*hw) (2*hh) btm_left