module Wumpus.Drawing.Shapes.Trapezium
(
Trapezium
, DTrapezium
, trapezium
, ztrapezium
) where
import Wumpus.Drawing.Paths.Absolute
import Wumpus.Drawing.Shapes.Base
import Wumpus.Basic.Geometry
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.VectorSpace
import Control.Applicative
data Trapezium u = Trapezium
{ tz_ctm :: ShapeCTM u
, tz_base_width :: !u
, tz_height :: !u
, tz_base_l_ang :: Radian
, tz_base_r_ang :: Radian
}
type instance DUnit (Trapezium u) = u
type DTrapezium = Trapezium Double
instance Functor Trapezium where
fmap f (Trapezium ctm bw h lang rang) =
Trapezium (fmap f ctm) (f bw) (f h) lang rang
mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Trapezium u -> Trapezium u
mapCTM f = (\s i -> s { tz_ctm = f i }) <*> tz_ctm
instance (Real u, Floating u) => Rotate (Trapezium u) where
rotate ang = mapCTM (rotate ang)
instance (Real u, Floating u) => RotateAbout (Trapezium u) where
rotateAbout ang pt = mapCTM (rotateAbout ang pt)
instance Fractional u => Scale (Trapezium u) where
scale sx sy = mapCTM (scale sx sy)
instance InterpretUnit u => Translate (Trapezium u) where
translate dx dy = mapCTM (translate dx dy)
runDisplaceCenter :: (Real u, Floating u)
=> (u -> u -> Radian -> Radian -> Vec2 u)
-> Trapezium u -> Anchor u
runDisplaceCenter fn (Trapezium { tz_ctm = ctm
, tz_base_width = bw
, tz_height = h
, tz_base_l_ang = lang
, tz_base_r_ang = rang }) =
projectFromCtr (fn (0.5 * bw) (0.5 * h) lang rang) ctm
instance (Real u, Floating u) =>
CenterAnchor (Trapezium u) where
center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0
instance (Real u, Floating u) =>
BottomCornerAnchor (Trapezium u) where
bottomLeftCorner = runDisplaceCenter $ \hbw hh _ _ -> V2 (hbw) (hh)
bottomRightCorner = runDisplaceCenter $ \hbw hh _ _ -> V2 hbw (hh)
instance (Real u, Floating u) =>
TopCornerAnchor (Trapezium u) where
topLeftCorner = runDisplaceCenter $ \hbw hh lang _ ->
let vbase = V2 (hbw) (hh)
vup = leftSideVec (2*hh) lang
in vbase ^+^ vup
topRightCorner = runDisplaceCenter $ \hbw hh _ rang ->
let vbase = V2 hbw (hh)
vup = rightSideVec (2*hh) rang
in vbase ^+^ vup
instance (Real u, Floating u, Tolerance u) =>
SideMidpointAnchor (Trapezium 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, Tolerance u) =>
CardinalAnchor (Trapezium u) where
north = runDisplaceCenter $ \_ hh _ _ -> V2 0 hh
south = runDisplaceCenter $ \_ hh _ _ -> V2 0 (hh)
east = tzRadialAnchor 0
west = tzRadialAnchor pi
instance (Real u, Floating u, Tolerance u) =>
CardinalAnchor2 (Trapezium u) where
northeast = tzRadialAnchor (0.25*pi)
southeast = tzRadialAnchor (1.75*pi)
southwest = tzRadialAnchor (1.25*pi)
northwest = tzRadialAnchor (0.75*pi)
instance (Real u, Floating u, Tolerance u) =>
RadialAnchor (Trapezium u) where
radialAnchor = tzRadialAnchor
tzRadialAnchor :: (Real u, Floating u, Tolerance u)
=> Radian -> Trapezium u -> Anchor u
tzRadialAnchor theta (Trapezium { tz_ctm = ctm
, tz_base_width = bw
, tz_height = h
, tz_base_l_ang = lang
, tz_base_r_ang = rang }) =
post $ findIntersect zeroPt theta $ polygonLineSegments ps
where
ps = tzPoints bw h lang rang
post = \ans -> case ans of
Nothing -> projectFromCtr (V2 0 0) ctm
Just (P2 x y) -> projectFromCtr (V2 x y) ctm
trapezium :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> Radian -> Radian -> Shape Trapezium u
trapezium bw h lang rang =
makeShape (mkTrapezium bw h lang rang) (mkTrapeziumPath 0 bw h lang rang)
ztrapezium :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> Shape Trapezium u
ztrapezium bw h = trapezium bw h ang ang
where
ang = d2r (60::Double)
mkTrapezium :: (Real u, Fractional u, InterpretUnit u)
=> u -> u -> Radian -> Radian -> LocThetaQuery u (Trapezium u)
mkTrapezium bw h lang rang = promoteR2 $ \ctr theta ->
pure $ Trapezium { tz_ctm = makeShapeCTM ctr theta
, tz_base_width = bw
, tz_height = h
, tz_base_l_ang = lang
, tz_base_r_ang = rang
}
mkTrapeziumPath :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> u -> u -> Radian -> Radian
-> LocThetaQuery u (AbsPath u)
mkTrapeziumPath rnd bw h lang rang = promoteR2 $ \ctr theta ->
let xs = tzPath bw h lang rang ctr
in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs
tzPath :: (Real u, Floating u)
=> u -> u -> Radian -> Radian -> LocCoordPath u
tzPath bw h lang rang (P2 x y) = [ bl, br, tr, tl ]
where
half_base = 0.5 * bw
hh = 0.5 * h
br = P2 (x + half_base ) (y hh)
bl = P2 (x half_base ) (y hh)
tr = displaceVec (rightSideVec h rang) br
tl = displaceVec (leftSideVec h lang) bl
tzPoints :: (Real u, Floating u)
=> u -> u -> Radian -> Radian -> [Point2 u]
tzPoints bw h lang rang = [ bl, br, tr, tl ]
where
half_base = 0.5 * bw
hh = 0.5 * h
bl = P2 (half_base) (hh)
br = P2 half_base (hh)
tr = displaceVec (rightSideVec h rang) br
tl = displaceVec (leftSideVec h lang) bl
leftSideVec :: Floating u => u -> Radian -> Vec2 u
leftSideVec h lang | lang < 0.5*pi = less_ninety
| lang == 0.5*pi = vvec h
| otherwise = grtr_ninety
where
less_ninety = let dist = h / (fromRadian $ sin lang) in avec lang dist
grtr_ninety = let theta = lang (0.5*pi)
dist = h / (fromRadian $ cos theta)
in avec lang dist
rightSideVec :: Floating u => u -> Radian -> Vec2 u
rightSideVec h rang | rang < 0.5*pi = less_ninety
| rang == 0.5*pi = vvec h
| otherwise = grtr_ninety
where
less_ninety = let dist = h / (fromRadian $ sin rang) in avec (pi rang) dist
grtr_ninety = let theta = rang (0.5*pi)
dist = h / (fromRadian $ cos theta)
in avec (pi rang) dist