module Wumpus.Drawing.Shapes.Triangle
(
Triangle
, DTriangle
, triangle
) where
import Wumpus.Drawing.Paths.Absolute
import Wumpus.Drawing.Shapes.Base
import Wumpus.Basic.Geometry.Base
import Wumpus.Basic.Geometry.Quadrant
import Wumpus.Basic.Geometry.Paths
import Wumpus.Basic.Kernel
import Wumpus.Core
import Control.Applicative
data Triangle u = Triangle
{ tri_ctm :: ShapeCTM u
, tri_base_width :: !u
, tri_height :: !u
, tri_syn_props :: SyntheticProps u
}
type instance DUnit (Triangle u) = u
data SyntheticProps u = SyntheticProps
{ tri_hmajor :: u
, tri_hminor :: u
, tri_base_ang :: Radian
, tri_apex_ang :: Radian
}
type instance DUnit (SyntheticProps u) = u
type DTriangle = Triangle Double
instance Functor Triangle where
fmap f (Triangle ctm bw h props) =
Triangle (fmap f ctm) (f bw) (f h) (fmap f props)
instance Functor SyntheticProps where
fmap f (SyntheticProps hmin hmaj ang1 ang2) =
SyntheticProps (f hmin) (f hmaj) ang1 ang2
mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Triangle u -> Triangle u
mapCTM f = (\s i -> s { tri_ctm = f i }) <*> tri_ctm
instance (Real u, Floating u) => Rotate (Triangle u) where
rotate ang = mapCTM (rotate ang)
instance (Real u, Floating u) => RotateAbout (Triangle u) where
rotateAbout ang pt = mapCTM (rotateAbout ang pt)
instance Fractional u => Scale (Triangle u) where
scale sx sy = mapCTM (scale sx sy)
instance InterpretUnit u => Translate (Triangle u) where
translate dx dy = mapCTM (translate dx dy)
runDisplaceCenter :: (Real u, Floating u)
=> (u -> u -> u -> Radian -> Vec2 u) -> Triangle u -> Anchor u
runDisplaceCenter fn (Triangle { tri_ctm = ctm
, tri_base_width = bw
, tri_syn_props = syn }) =
projectFromCtr (fn (0.5*bw) hminor hmajor base_ang) ctm
where
hminor = tri_hminor syn
hmajor = tri_hmajor syn
base_ang = tri_base_ang syn
instance (Real u, Floating u) =>
CenterAnchor (Triangle u) where
center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0
instance (Real u, Floating u) =>
ApexAnchor (Triangle u) where
apex = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj
instance (Real u, Floating u) =>
BottomCornerAnchor (Triangle u) where
bottomLeftCorner = runDisplaceCenter $ \hbw hmin _ _ -> V2 (hbw) (hmin)
bottomRightCorner = runDisplaceCenter $ \hbw hmin _ _ -> V2 hbw (hmin)
instance (Real u, Floating u) =>
CardinalAnchor (Triangle u) where
north = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj
south = runDisplaceCenter $ \_ hmin _ _ -> V2 0 (hmin)
east = runDisplaceCenter $ \hbw hmin _ ang -> findEast hbw hmin ang
west = runDisplaceCenter $ \hbw hmin _ ang -> findWest hbw hmin ang
instance (Real u, Floating u) =>
SideMidpointAnchor (Triangle u) where
sideMidpoint n a = step (n `mod` 3)
where
step 1 = midpoint (apex a) (bottomLeftCorner a)
step 2 = midpoint (bottomLeftCorner a) (bottomRightCorner a)
step _ = midpoint (bottomRightCorner a) (apex a)
findEast :: Fractional u => u -> u -> Radian -> Vec2 u
findEast half_base_width hminor base_ang = V2 xdist 0
where
b1 = hminor / (fromRadian $ tan base_ang)
xdist = half_base_width b1
findWest :: Fractional u => u -> u -> Radian -> Vec2 u
findWest hbw hm ang = let (V2 xdist 0) = findEast hbw hm ang in V2 (xdist) 0
instance (Real u, Floating u) =>
CardinalAnchor2 (Triangle 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 (Triangle u) where
radialAnchor theta = runDisplaceCenter $ \hbw hmin hmaj _ ->
triangleRadialVector hbw hmin hmaj theta
triangle :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> Shape Triangle u
triangle bw h =
let props = synthesizeProps bw h
hminor = tri_hminor props
hmajor = tri_hmajor props
in makeShape (mkTriangle bw h props) (mkTrianglePath 0 bw hminor hmajor)
mkTriangle :: (Real u, Fractional u, InterpretUnit u)
=> u -> u -> SyntheticProps u -> LocThetaQuery u (Triangle u)
mkTriangle bw h props = promoteR2 $ \ctrd theta ->
pure $ Triangle { tri_ctm = makeShapeCTM ctrd theta
, tri_base_width = bw
, tri_height = h
, tri_syn_props = props
}
synthesizeProps :: (Real u, Fractional u) => u -> u -> SyntheticProps u
synthesizeProps bw h =
SyntheticProps { tri_hmajor = hmajor
, tri_hminor = hminor
, tri_base_ang = base_ang
, tri_apex_ang = apex_ang
}
where
half_base = 0.5 * bw
hminor = h / 3
hmajor = 2 * hminor
base_ang = atan $ toRadian (h / half_base)
apex_ang = 2 * ((pi/4) base_ang)
mkTrianglePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> u -> u -> LocThetaQuery u (AbsPath u)
mkTrianglePath rnd bw hminor hmajor = promoteR2 $ \ctr theta ->
let xs = trianglePath bw hminor hmajor ctr
in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs
trianglePath :: (Real u, Floating u)
=> u -> u -> u -> LocCoordPath u
trianglePath bw hminor hmajor (P2 x y) = [br, apx, bl]
where
half_base = 0.5 * bw
br = P2 (x + half_base ) (y hminor)
apx = P2 x (y + hmajor)
bl = P2 (x half_base ) (y hminor)