module Wumpus.Drawing.Shapes.Semiellipse
(
Semiellipse
, DSemiellipse
, semiellipse
) where
import Wumpus.Drawing.Basis.ShapeTrails
import Wumpus.Drawing.Paths
import Wumpus.Drawing.Paths.Intersection
import Wumpus.Drawing.Shapes.Base
import Wumpus.Basic.Kernel
import Wumpus.Core
import Control.Applicative
data Semiellipse u = Semiellipse
{ se_ctm :: ShapeCTM u
, se_rx :: !u
, se_ry :: !u
}
type instance DUnit (Semiellipse u) = u
type DSemiellipse = Semiellipse Double
instance Functor Semiellipse where
fmap f (Semiellipse ctm rx ry) = Semiellipse (fmap f ctm) (f rx) (f ry)
ryminor :: Floating u => u -> u
ryminor ry = (4 * ry) / (3 * pi)
rymajor :: Floating u => u -> u
rymajor ry = ry ryminor ry
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 -> Vec2 u) -> Semiellipse u -> Anchor u
runDisplaceCenter fn (Semiellipse { se_ctm = ctm
, se_rx = rx
, se_ry = ry }) =
projectFromCtr (fn rx ry) ctm
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 -> V2 0 (rymajor ry)
instance (Real u, Floating u) =>
BottomCornerAnchor (Semiellipse u) where
bottomLeftCorner = runDisplaceCenter $ \rx ry -> V2 (rx) (negate $ ryminor ry)
bottomRightCorner = runDisplaceCenter $ \rx ry -> V2 rx (negate $ ryminor ry)
instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>
CardinalAnchor (Semiellipse u) where
north = apex
south = runDisplaceCenter $ \_ ry -> V2 0 (negate $ ryminor ry)
east = radialAnchor 0
west = radialAnchor pi
instance (Real u, Floating u, InterpretUnit 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, InterpretUnit u, Tolerance u) =>
RadialAnchor (Semiellipse u) where
radialAnchor ang = runDisplaceCenter $ \rx ry ->
maybe zeroVec id $ semiellipseRadialAnchor rx ry ang
semiellipseRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> Radian -> Maybe (Vec2 u)
semiellipseRadialAnchor rx ry ang =
fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp
where
rp = anaTrailPath zeroPt $ semiellipse_trail rx ry
semiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> Shape Semiellipse u
semiellipse rx ry = makeShape (mkSemiellipse rx ry) (mkSemiellipsePath rx ry)
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 -> LocThetaQuery u (AbsPath u)
mkSemiellipsePath rx ry = qpromoteLocTheta $ \ctr theta ->
return $ anaTrailPath ctr $ rsemiellipse_trail rx ry theta