module Wumpus.Drawing.Basis.ShapeTrails
(
circle_trail
, rcircle_trail
, ellipse_trail
, rellipse_trail
, rectangle_trail
, rrectangle_trail
, diamond_trail
, rdiamond_trail
, isosceles_triangle_trail
, risosceles_triangle_trail
, semicircle_trail
, rsemicircle_trail
, semiellipse_trail
, rsemiellipse_trail
, parallelogram_trail
, rparallelogram_trail
, trapezium_trail
, rtrapezium_trail
)
where
import Wumpus.Drawing.Basis.InclineTrails
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.VectorSpace
import Data.Monoid
circle_trail :: (Real u, Floating u) => u -> AnaTrail u
circle_trail r = rcircle_trail r 0
rcircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u
rcircle_trail r ang =
modifyAna (\v -> v ^-^ avec ang r) $ incline_circle $ avec ang (2 * r)
ellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
ellipse_trail rx ry = rellipse_trail rx ry 0
rellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
rellipse_trail rx ry ang =
modifyAna (\v -> v ^-^ avec ang rx) $ incline_ellipse ry $ avec ang (2 * rx)
rectangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
rectangle_trail w h = rrectangle_trail w h 0
rrectangle_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
rrectangle_trail w h ang =
anaCatTrail (orthoVec (negate $ 0.5 * w) (negate $ 0.5 * h) ang) catt
where
catt = mconcat [ trail_theta_right w ang
, trail_theta_up h ang
, trail_theta_left w ang
, trail_theta_down h ang
]
diamond_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
diamond_trail w h = rdiamond_trail w h 0
rdiamond_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
rdiamond_trail w h ang =
anaCatTrail (theta_right hw ang) catt
where
hw = 0.5 * w
hh = 0.5 * h
catt = mconcat [ orthoCatTrail (hw) hh ang
, orthoCatTrail (hw) (hh) ang
, orthoCatTrail hw (hh) ang
, orthoCatTrail hw hh ang
]
isosceles_triangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
isosceles_triangle_trail bw h = risosceles_triangle_trail bw h 0
risosceles_triangle_trail :: (Real u, Floating u)
=> u -> u -> Radian -> AnaTrail u
risosceles_triangle_trail bw h ang =
anaCatTrail (orthoVec (negate hbw) (negate $ h / 3) ang) catt
where
hbw = 0.5 * bw
catt = mconcat [ trail_theta_right bw ang
, orthoCatTrail (hbw) h ang
, orthoCatTrail (hbw) (h) ang
]
semicircle_trail :: (Real u, Floating u) => u -> AnaTrail u
semicircle_trail r = rsemicircle_trail r 0
rsemicircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u
rsemicircle_trail r ang =
anaCatTrail (orthoVec (negate r) (negate hminor) ang) catt
where
hminor = (4 * r) / (3 * pi)
catt = trail_theta_right (2 * r) ang
<> semicircleTrail CCW (avec ang (negate $ 2 * r) )
semiellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
semiellipse_trail rx ry = rsemiellipse_trail rx ry 0
rsemiellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
rsemiellipse_trail rx ry ang =
anaCatTrail (orthoVec (negate rx) (negate hminor) ang) catt
where
hminor = (4 * ry) / (3 * pi)
catt = trail_theta_right (2 * rx) ang
<> semiellipseTrail CCW ry (avec ang (negate $ 2 * rx) )
parallelogram_trail :: Floating u => u -> u -> Radian -> AnaTrail u
parallelogram_trail w h bottom_left_ang =
rparallelogram_trail w h bottom_left_ang 0
rparallelogram_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u
rparallelogram_trail w h bl_ang ang
| bl_ang >= ang180 =
error "rparallelogram_trail - bottom left angle >= 180."
| otherwise = anaCatTrail ctr_to_bl catt
where
base_minor = h / (fromRadian $ tan bl_ang)
vbase = theta_right w ang
vrhs = orthoVec base_minor h ang
vtop = vreverse vbase
vlhs = vreverse vrhs
ctr_to_bl = vreverse $ 0.5 *^ (vbase ^+^ vrhs)
catt = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ]
trapezium_trail :: Floating u => u -> u -> Radian -> AnaTrail u
trapezium_trail w h bottom_left_ang =
rtrapezium_trail w h bottom_left_ang 0
rtrapezium_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u
rtrapezium_trail bw h bl_ang ang
| bl_ang >= ang180 = error "rtrapezium_trail - bottom left angle >= 180."
| otherwise = anaCatTrail ctr_to_bl catt
where
base_minor = h / (fromRadian $ tan bl_ang)
top_width = bw (2 * base_minor)
vbase = theta_right bw ang
vrhs = orthoVec (base_minor) h ang
vtop = theta_left top_width ang
vlhs = orthoVec (base_minor) (h) ang
ctr_to_bl = orthoVec (negate $ 0.5 * bw) (negate $ 0.5 * h) ang
catt = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ]