module Wumpus.Drawing.Shapes.Semiellipse
(
Semiellipse
, DSemiellipse
, semiellipse
) where
import Wumpus.Drawing.Paths.Absolute
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 Semiellipse u = Semiellipse
{ se_ctm :: ShapeCTM u
, se_rx :: !u
, se_ry :: !u
}
type instance DUnit (Semiellipse u) = u
data SyntheticProps u = SP
{ se_hminor :: u
, se_hmajor :: u
}
type instance DUnit (SyntheticProps u) = u
type DSemiellipse = Semiellipse Double
instance Functor Semiellipse where
fmap f (Semiellipse ctm rx ry) = Semiellipse (fmap f ctm) (f rx) (f ry)
synthesizeProps :: Floating u => u -> SyntheticProps u
synthesizeProps ry =
SP { se_hminor = ry_minor, se_hmajor = ry_major }
where
ry_minor = (4 * ry) / (3 * pi)
ry_major = ry ry_minor
mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semiellipse u -> Semiellipse u
mapCTM f = (\s i -> s { se_ctm = f i }) <*> se_ctm
instance (Real u, Floating u) => Rotate (Semiellipse u) where
rotate ang = mapCTM (rotate ang)
instance (Real u, Floating u) => RotateAbout (Semiellipse u) where
rotateAbout ang pt = mapCTM (rotateAbout ang pt)
instance Fractional u => Scale (Semiellipse u) where
scale sx sy = mapCTM (scale sx sy)
instance InterpretUnit u => Translate (Semiellipse u) where
translate dx dy = mapCTM (translate dx dy)
runDisplaceCenter :: (Real u, Floating u)
=> (u -> u -> u -> u -> Vec2 u) -> Semiellipse u -> Anchor u
runDisplaceCenter fn (Semiellipse { se_ctm = ctm
, se_rx = rx
, se_ry = ry }) =
projectFromCtr (fn rx ry hminor hmajor) ctm
where
props = synthesizeProps ry
hminor = se_hminor props
hmajor = se_hmajor props
instance (Real u, Floating u) =>
CenterAnchor (Semiellipse u) where
center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0
instance (Real u, Floating u, Tolerance u) =>
ApexAnchor (Semiellipse u) where
apex = runDisplaceCenter $ \_ _ _ ry_major -> V2 0 ry_major
instance (Real u, Floating u) =>
BottomCornerAnchor (Semiellipse u) where
bottomLeftCorner = runDisplaceCenter $ \rx _ ry_minor _ -> V2 (rx) (ry_minor)
bottomRightCorner = runDisplaceCenter $ \rx _ ry_minor _ -> V2 rx (ry_minor)
instance (Real u, Floating u, Tolerance u) =>
CardinalAnchor (Semiellipse u) where
north = apex
south = runDisplaceCenter $ \_ _ ry_minor _ -> V2 0 (ry_minor)
east = radialAnchor 0
west = radialAnchor pi
instance (Real u, Floating u, Tolerance u) =>
CardinalAnchor2 (Semiellipse 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 (Semiellipse u) where
radialAnchor theta = runDisplaceCenter (seRadialVec theta)
seRadialVec :: (Real u, Floating u, Ord u, Tolerance u)
=> Radian -> u -> u -> u -> u -> Vec2 u
seRadialVec theta rx ry hminor _ = go theta
where
(lang,rang) = baselineRange rx hminor
(bctr, br, _, bl) = constructionPoints rx ry hminor
plane = inclinedLine zeroPt theta
base_line = LineSegment bl br
(right_curve,left_curve) = bezierSemiellipse rx ry 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
constructionPoints :: Num u
=> u -> u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)
constructionPoints rx ry hminor = (bctr, br, apx, bl)
where
bctr = P2 0 (hminor)
br = bctr .+^ hvec rx
apx = bctr .+^ vvec ry
bl = bctr .+^ hvec (rx)
baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)
baselineRange rx hminor = (lang, rang)
where
ang = toRadian $ atan (rx / hminor)
lang = (1.5*pi) ang
rang = (1.5*pi) + ang
semiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> Shape Semiellipse u
semiellipse rx ry =
let props = synthesizeProps ry
in makeShape (mkSemiellipse rx ry)
(mkSemiellipsePath rx ry (se_hminor props))
mkSemiellipse :: InterpretUnit u
=> u -> u -> LocThetaQuery u (Semiellipse u)
mkSemiellipse rx ry = qpromoteLocTheta $ \ctr theta ->
pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta
, se_rx = rx
, se_ry = ry
}
mkSemiellipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> u -> LocThetaQuery u (AbsPath u)
mkSemiellipsePath rx ry hminor = qpromoteLocTheta $ \pt theta ->
let ctr = dispPerpendicular (hminor) theta pt
xs = bezierSemiellipsePoints rx ry ctr
in return $ curvePath $ map (rotateAbout theta ctr) xs
bezierSemiellipsePoints :: Floating u
=> u -> u -> Point2 u -> [Point2 u]
bezierSemiellipsePoints rx ry pt = [ p0, c1,c2,p3, c4,c5,p6 ]
where
(BezierCurve p0 c1 c2 p3, BezierCurve _ c4 c5 p6) = bezierSemiellipse rx ry pt
bezierSemiellipse :: Floating u
=> u -> u -> Point2 u -> (BezierCurve u, BezierCurve u)
bezierSemiellipse rx ry (P2 x y) =
(BezierCurve p00 c01 c02 p03, BezierCurve p03 c04 c05 p06)
where
lrx = rx * kappa
lry = ry * kappa
p00 = P2 (x + rx) y
c01 = p00 .+^ vvec lry
c02 = p03 .+^ hvec lrx
p03 = P2 x (y + ry)
c04 = p03 .+^ hvec (lrx)
c05 = p06 .+^ vvec lry
p06 = P2 (x rx) y
kappa :: Floating u => u
kappa = 4 * ((sqrt 2 1) / 3)