module Wumpus.Drawing.Shapes.Semicircle
(
Semicircle
, DSemicircle
, semicircle
) where
import Wumpus.Drawing.Paths
import Wumpus.Drawing.Shapes.Base
import Wumpus.Basic.Geometry.Base
import Wumpus.Basic.Geometry.Intersection
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
data Semicircle u = Semicircle
{ sc_ctm :: ShapeCTM u
, sc_radius :: !u
}
type instance DUnit (Semicircle u) = u
data SyntheticProps u = SP
{ sc_hminor :: u
, sc_hmajor :: u
}
type instance DUnit (SyntheticProps u) = u
type DSemicircle = Semicircle Double
instance Functor Semicircle where
fmap f (Semicircle ctm r) = Semicircle (fmap f ctm) (f r)
synthesizeProps :: Floating u => u -> SyntheticProps u
synthesizeProps radius =
SP { sc_hminor = hminor, sc_hmajor = hmajor }
where
hminor = (4 * radius) / (3 * pi)
hmajor = radius hminor
mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semicircle u -> Semicircle u
mapCTM f = (\s i -> s { sc_ctm = f i }) <*> sc_ctm
instance (Real u, Floating u) => Rotate (Semicircle u) where
rotate ang = mapCTM (rotate ang)
instance (Real u, Floating u) => RotateAbout (Semicircle u) where
rotateAbout ang pt = mapCTM (rotateAbout ang pt)
instance Fractional u => Scale (Semicircle u) where
scale sx sy = mapCTM (scale sx sy)
instance InterpretUnit u => Translate (Semicircle u) where
translate dx dy = mapCTM (translate dx dy)
runDisplaceCenter :: (Real u, Floating u)
=> (u -> u -> u -> Vec2 u) -> Semicircle u -> Anchor u
runDisplaceCenter fn (Semicircle { sc_ctm = ctm
, sc_radius = radius }) =
projectFromCtr (fn radius hminor hmajor) ctm
where
props = synthesizeProps radius
hminor = sc_hminor props
hmajor = sc_hmajor props
instance (Real u, Floating u) =>
CenterAnchor (Semicircle u) where
center = runDisplaceCenter $ \_ _ _ -> V2 0 0
instance (Real u, Floating u) =>
ApexAnchor (Semicircle u) where
apex = runDisplaceCenter $ \_ _ cmaj -> V2 0 cmaj
instance (Real u, Floating u) =>
BottomCornerAnchor (Semicircle u) where
bottomLeftCorner = runDisplaceCenter $ \r hminor _ -> V2 (r) (hminor)
bottomRightCorner = runDisplaceCenter $ \r hminor _ -> V2 r (hminor)
instance (Real u, Floating u) =>
CardinalAnchor (Semicircle u) where
north = apex
south = runDisplaceCenter $ \_ cmin _ -> V2 0 (cmin)
east = runDisplaceCenter $ \r cmin _ -> let x = pyth r cmin in V2 x 0
west = runDisplaceCenter $ \r cmin _ -> let x = pyth r cmin in V2 (x) 0
pyth :: Floating u => u -> u -> u
pyth hyp s1 = sqrt $ pow2 hyp pow2 s1
where
pow2 = (^ (2::Int))
instance (Real u, Floating u, Tolerance u) =>
CardinalAnchor2 (Semicircle 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, Tolerance u) =>
RadialAnchor (Semicircle u) where
radialAnchor theta = runDisplaceCenter (scRadialVec theta)
scRadialVec :: (Real u, Floating u, Ord u, Tolerance u)
=> Radian -> u -> u -> u -> Vec2 u
scRadialVec theta radius hminor _ = go (circularModulo theta)
where
(lang,rang) = baselineRange radius hminor
(bctr, br, _, bl) = constructionPoints radius hminor
plane = inclinedLine zeroPt theta
base_line = LineSegment bl br
left_curve = mkCurve radius half_pi bctr
right_curve = mkCurve radius 0 bctr
post = maybe (V2 0 0) (\(P2 x y) -> V2 x y)
go a
| lang <= a && a <= rang = post $ interLinesegLine base_line plane
| half_pi <= a && a < lang = post $ interCurveLine left_curve plane
| otherwise = post $ interCurveLine right_curve plane
mkCurve :: Floating u => u -> Radian -> Point2 u -> BezierCurve u
mkCurve radius theta ctr = BezierCurve p0 p1 p2 p3
where
(BezierCurve p0 p1 p2 p3) = bezierMinorArc half_pi radius theta ctr
constructionPoints :: Num u
=> u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)
constructionPoints radius hminor = (bctr, br, apx, bl)
where
bctr = P2 0 (hminor)
br = bctr .+^ hvec radius
apx = bctr .+^ vvec radius
bl = bctr .+^ hvec (radius)
baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)
baselineRange radius hminor = (lang, rang)
where
ang = toRadian $ atan (radius / hminor)
lang = (1.5*pi) ang
rang = (1.5*pi) + ang
semicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> Shape Semicircle u
semicircle radius =
let props = synthesizeProps radius
in makeShape (mkSemicircle radius)
(mkSemicirclePath radius (sc_hminor props))
mkSemicircle :: InterpretUnit u
=> u -> LocThetaQuery u (Semicircle u)
mkSemicircle radius = qpromoteLocTheta $ \ctr theta ->
pure $ Semicircle { sc_ctm = makeShapeCTM ctr theta
, sc_radius = radius
}
mkSemicirclePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> LocThetaQuery u (AbsPath u)
mkSemicirclePath radius cminor = qpromoteLocTheta $ \pt theta ->
let ctr = dispPerpendicular (cminor) theta pt
in pure $ curvePath $ bezierArcPoints pi radius theta ctr