wumpus-basic-0.24.0: src/Wumpus/Basic/Kernel/Objects/Trail.hs
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Basic.Kernel.Objects.Trial
-- Copyright : (c) Stephen Tetley 2011
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : highly unstable
-- Portability : GHC
--
-- /Trails/ - prototype paths. Less resource heavy than the Path
-- object in Wumpus-Drawing.
--
-- @CatTrail@ supports concatenation. @AnaTrail@ supports
-- /initial displacement/ - this can account for drawing
-- rectangles from their center, for example.
--
--------------------------------------------------------------------------------
module Wumpus.Basic.Kernel.Objects.Trail
(
-- * Trail types
TrailSegment(..)
, CatTrail
, AnaTrail
-- * Trail operations
, renderAnaTrail
, renderCatTrail
, destrAnaTrail
, destrCatTrail
, anaCatTrail
, modifyAna
, trailIterateLocus
, anaTrailPoints
, catline
, catcurve
, orthoCatTrail
, diffCurve
, diffLines
-- * Shape trails
, rectangleTrail
, diamondTrail
, polygonTrail
, wedgeTrail
-- * Named Trail constructors
, trail_up
, trail_down
, trail_left
, trail_right
, trail_north
, trail_south
, trail_east
, trail_west
, trail_north_east
, trail_north_west
, trail_south_east
, trail_south_west
, trail_up_left
, trail_up_right
, trail_down_left
, trail_down_right
, trail_para
, trail_perp
, trail_theta_up
, trail_theta_down
, trail_theta_left
, trail_theta_right
, trail_theta_north
, trail_theta_south
, trail_theta_east
, trail_theta_west
, trail_theta_north_east
, trail_theta_north_west
, trail_theta_south_east
, trail_theta_south_west
, trail_theta_up_left
, trail_theta_up_right
, trail_theta_down_left
, trail_theta_down_right
, trail_theta_adj_grazing
, trail_theta_bkwd_adj_grazing
, semicircleTrail
, semiellipseTrail
, minorCircleSweep
, circleSweep
, circularArc
, sineWave
, sineWave1
, squareWave
, sawtoothWave
, squiggleWave
, semicircleWave
, triCurve
, rectCurve
, trapCurve
, bowCurve
, wedgeCurve
, loopCurve
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Objects.Displacement
import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
import Wumpus.Basic.Kernel.Objects.Image
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Basic.Utils.HList
import Wumpus.Core -- package: wumpus-core
import Data.AffineSpace -- package: vector-space
import Data.VectorSpace
import Data.List ( unfoldr )
import Data.Monoid
--------------------------------------------------------------------------------
-- Trail types
-- | Trail with an initial (undrawn) displacement - an anacrusis.
--
-- This allows trails to represent centered objects.
--
data AnaTrail u = AnaTrail
{ pt_init_vec :: Vec2 u
, pt_segments :: [TrailSegment u]
}
deriving (Eq,Ord,Show)
type instance DUnit (AnaTrail u) = u
-- | Trail supporting concatenation.
--
newtype CatTrail u = CatTrail { getCatTrail :: H (TrailSegment u) }
type instance DUnit (CatTrail u) = u
-- | Trail segment - trails are /prototype/ paths, so the are
-- built from the usual straight lines and Bezier curves.
--
data TrailSegment u = TLine (Vec2 u)
| TCurve (Vec2 u) (Vec2 u) (Vec2 u)
deriving (Eq,Ord,Show)
type instance DUnit (TrailSegment u) = u
instance Functor TrailSegment where
fmap f (TLine v1) = TLine $ fmap f v1
fmap f (TCurve v1 v2 v3) = TCurve (fmap f v1) (fmap f v2) (fmap f v3)
instance Monoid (CatTrail u) where
mempty = CatTrail emptyH
a `mappend` b = CatTrail $ getCatTrail a `appendH` getCatTrail b
--------------------------------------------------------------------------------
-- Trail operations
-- | Render a 'CatTrail' to make a drawable 'LocGraphic'.
--
renderCatTrail :: InterpretUnit u => PathMode -> CatTrail u -> LocGraphic u
renderCatTrail mode (CatTrail ct) = promoteLoc $ \pt ->
drawTrailBody mode (toListH ct) pt
-- | Render an 'AnaTrail' to make a drawable 'LocGraphic'.
--
renderAnaTrail :: InterpretUnit u => PathMode -> AnaTrail u -> LocGraphic u
renderAnaTrail mode (AnaTrail v0 xs) = promoteLoc $ \pt ->
drawTrailBody mode xs (pt .+^ v0)
-- | Note - this optimizes contiguous lines that share the same
-- direction.
--
drawTrailBody :: InterpretUnit u
=> PathMode -> [TrailSegment u] -> Point2 u -> Graphic u
drawTrailBody mode ts pt =
normalizeCtxF pt >>= \dpt ->
mapM normalizeCtxF ts >>= \dxs ->
dcPath mode $ relPrimPath dpt $ stepA id dxs
where
stepA f [] = toListH f
stepA f (TLine v1:ys) = stepB f (vdirection v1) v1 ys
stepA f (TCurve v1 v2 v3:ys) = stepA (f `snocH` relCurveTo v1 v2 v3) ys
stepB f dir v0 (TLine v1:ys)
| vdirection v1 == dir = stepB f dir (v0 ^+^ v1) ys
stepB f _ v0 ys = stepA (f `snocH` relLineTo v0) ys
-- | /Destructor/ for the opaque 'AnaTrail' type.
--
destrAnaTrail :: AnaTrail u -> (Vec2 u, [TrailSegment u])
destrAnaTrail (AnaTrail v0 ss) = (v0,ss)
-- | /Destructor/ for the opaque 'CatTrail' type.
--
destrCatTrail :: CatTrail u -> [TrailSegment u]
destrCatTrail = toListH . getCatTrail
-- | Turn a 'CatTrail' into a 'AnaTrail'.
--
anaCatTrail :: Vec2 u -> CatTrail u -> AnaTrail u
anaCatTrail vinit cat = AnaTrail { pt_init_vec = vinit
, pt_segments = getCatTrail cat []
}
modifyAna :: (Vec2 u -> Vec2 u) -> AnaTrail u -> AnaTrail u
modifyAna upd (AnaTrail v1 body) = AnaTrail (upd v1) body
-- | Create a AnaTrail from the vector list - each vector in the
-- input list iterates to the start point rather then the
-- cumulative tip.
--
-- When the AnaTrail is run, the supplied point is the /locus/ of
-- the path and it does not form part of the path proper.
--
-- Like 'trailStartIsLocus', this constructor is typically used to
-- make /shape paths/. Some shapes are easier to express as
-- iterated displacements of the center rather than
-- /turtle drawing/.
--
trailIterateLocus :: Num u => [Vec2 u] -> AnaTrail u
trailIterateLocus [] = AnaTrail zeroVec []
trailIterateLocus (v0:xs) = AnaTrail v0 (step v0 xs)
where
step v1 [] = [ TLine (v0 ^-^ v1) ]
step v1 (v2:vs) = TLine (v2 ^-^ v1) : step v2 vs
anaTrailPoints :: InterpretUnit u => AnaTrail u -> LocQuery u [Point2 u]
anaTrailPoints (AnaTrail v0 ts) = qpromoteLoc $ \pt ->
return $ step (pt .+^ v0) ts
where
step p1 [] = [p1]
step p1 (TLine v1:xs) = p1 : step (p1 .+^ v1) xs
step p1 (TCurve v1 v2 v3 :xs) = let p2 = p1 .+^ v1
p3 = p2 .+^ v2
p4 = p3 .+^ v3
in p1 : p2 : p3 : step p4 xs
catline :: Vec2 u -> CatTrail u
catline = CatTrail . wrapH . TLine
-- | Alternative to @catline@, specifying the vector components
-- rather the vector itself.
--
-- (cf. orthoVec from Wumpus-Core)
--
orthoCatTrail :: Floating u => u -> u -> Radian -> CatTrail u
orthoCatTrail x y ang = catline (orthoVec x y ang)
catcurve :: Vec2 u -> Vec2 u -> Vec2 u -> CatTrail u
catcurve v1 v2 v3 = CatTrail $ wrapH $ TCurve v1 v2 v3
-- | Form a Bezier CatTrail from the vectors between four control
-- points.
--
diffCurve :: Num u
=> Point2 u -> Point2 u -> Point2 u -> Point2 u -> CatTrail u
diffCurve p0 p1 p2 p3 =
catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)
-- | Form a CatTrail from the linear segment joining the list of
-- points.
--
-- Some configurations of vectors seem easier to specify using
-- located points then making them coordinate free by taking
-- the joining vectors.
--
diffLines :: Num u => [Point2 u] -> CatTrail u
diffLines [] = mempty
diffLines (x:xs) = step mempty x xs
where
step ac a (b:bs) = step (ac `mappend` catline (pvec a b)) b bs
step ac _ [] = ac
--------------------------------------------------------------------------------
-- Shape Trails
-- | 'rectangleTrail' : @ width * height -> AnaTrail @
--
rectangleTrail :: Fractional u => u -> u -> AnaTrail u
rectangleTrail w h =
AnaTrail { pt_init_vec = ctr_to_bl
, pt_segments = map TLine spec
}
where
ctr_to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)
spec = [ go_right w, go_up h, go_left w, go_down h ]
-- | 'diamondTrail' : @ half_width * half_height -> AnaTrail @
--
diamondTrail :: Num u => u -> u -> AnaTrail u
diamondTrail hw hh = trailIterateLocus [ vs,ve,vn,vw ]
where
vs = vvec (-hh)
ve = hvec hw
vn = vvec hh
vw = hvec (-hw)
-- | 'polygonTrail' : @ num_points * radius -> AnaTrail @
--
polygonTrail :: Floating u => Int -> u -> AnaTrail u
polygonTrail n radius = trailIterateLocus $ unfoldr phi (0,top)
where
top = 0.5*pi
theta = (2*pi) / fromIntegral n
phi (i,ang) | i < n = Just (avec ang radius, (i+1,ang+theta))
| otherwise = Nothing
-- | wedgeTrail : radius * apex_angle
--
-- Wedge is drawn at the apex.
--
wedgeTrail :: (Real u, Floating u)
=> u -> Radian -> Radian -> AnaTrail u
wedgeTrail radius ang theta =
anaCatTrail zeroVec $ line_in `mappend` w_arc `mappend` line_out
where
half_ang = 0.5 * ang
line_in = catline $ avec (theta + half_ang) radius
line_out = catline $ avec (theta - half_ang) (-radius)
w_arc = circularArcCW ang radius (theta - half_pi)
--------------------------------------------------------------------------------
-- Named Trail constructors
trail_up :: Num u => u -> CatTrail u
trail_up = catline . go_up
trail_down :: Num u => u -> CatTrail u
trail_down = catline . go_down
trail_left :: Num u => u -> CatTrail u
trail_left = catline . go_left
trail_right :: Num u => u -> CatTrail u
trail_right = catline . go_right
trail_north :: Num u => u -> CatTrail u
trail_north = trail_up
trail_south :: Num u => u -> CatTrail u
trail_south = catline . go_down
trail_east :: Num u => u -> CatTrail u
trail_east = catline . go_right
trail_west :: Num u => u -> CatTrail u
trail_west = catline . go_left
trail_north_east :: Floating u => u -> CatTrail u
trail_north_east = catline . go_north_east
trail_north_west :: Floating u => u -> CatTrail u
trail_north_west = catline . go_north_west
trail_south_east :: Floating u => u -> CatTrail u
trail_south_east = catline . go_south_east
trail_south_west :: Floating u => u -> CatTrail u
trail_south_west = catline . go_south_west
trail_up_left :: Num u => u -> CatTrail u
trail_up_left = catline . go_up_left
trail_up_right :: Num u => u -> CatTrail u
trail_up_right = catline . go_up_right
trail_down_left :: Num u => u -> CatTrail u
trail_down_left = catline . go_down_left
trail_down_right :: Num u => u -> CatTrail u
trail_down_right = catline . go_down_right
trail_perp :: Floating u => u -> Radian -> CatTrail u
trail_perp = trail_theta_up
trail_para :: Floating u => u -> Radian -> CatTrail u
trail_para = trail_theta_right
trail_theta_up :: Floating u => u -> Radian -> CatTrail u
trail_theta_up u = catline . theta_up u
trail_theta_down :: Floating u => u -> Radian -> CatTrail u
trail_theta_down u = catline . theta_down u
trail_theta_left :: Floating u => u -> Radian -> CatTrail u
trail_theta_left u = catline . theta_left u
trail_theta_right :: Floating u => u -> Radian -> CatTrail u
trail_theta_right u = catline . theta_right u
trail_theta_north :: Floating u => u -> Radian -> CatTrail u
trail_theta_north = trail_theta_up
trail_theta_south :: Floating u => u -> Radian -> CatTrail u
trail_theta_south = trail_theta_down
trail_theta_east :: Floating u => u -> Radian -> CatTrail u
trail_theta_east = trail_theta_right
trail_theta_west :: Floating u => u -> Radian -> CatTrail u
trail_theta_west = trail_theta_left
trail_theta_north_east :: Floating u => u -> Radian -> CatTrail u
trail_theta_north_east u = catline . theta_north_east u
trail_theta_north_west :: Floating u => u -> Radian -> CatTrail u
trail_theta_north_west u = catline . theta_north_west u
trail_theta_south_east :: Floating u => u -> Radian -> CatTrail u
trail_theta_south_east u = catline . theta_south_east u
trail_theta_south_west :: Floating u => u -> Radian -> CatTrail u
trail_theta_south_west u = catline . theta_south_west u
trail_theta_up_left :: Floating u => u -> Radian -> CatTrail u
trail_theta_up_left u = catline . theta_up_left u
trail_theta_up_right :: Floating u => u -> Radian -> CatTrail u
trail_theta_up_right u = catline . theta_up_right u
trail_theta_down_left :: Floating u => u -> Radian -> CatTrail u
trail_theta_down_left u = catline . theta_down_left u
trail_theta_down_right :: Floating u => u -> Radian -> CatTrail u
trail_theta_down_right u = catline . theta_down_right u
-- | Return the line @a-o@ when supplied length of @b-o@ and the
-- grazing angle @boa@:
--
-- > a
-- > .\
-- > . \
-- > ..b..o
--
-- This is useful for building arrowhead vectors.
--
trail_theta_adj_grazing :: Floating u => u -> Radian -> Radian -> CatTrail u
trail_theta_adj_grazing adj_len ang =
catline . theta_adj_grazing adj_len ang
-- | Return the line @o-c@ when supplied length of @b-o@ and the
-- grazing angle @boc@:
--
--
-- > ..b..o
-- > . /
-- > ./
-- > c
--
-- This is useful for building arrowhead vectors.
--
trail_theta_bkwd_adj_grazing :: Floating u => u -> Radian -> Radian -> CatTrail u
trail_theta_bkwd_adj_grazing adj_len ang =
catline . theta_bkwd_adj_grazing adj_len ang
--------------------------------------------------------------------------------
--
-- DESIGN NOTE
--
-- Angle, unit width and number of repetitions (plus height etc.)
-- seems the best API, although this make fitting an issue.
--
sineWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u
sineWave i unit ang =
mconcat $ replicate i $ sineWave1 (0.25 * unit) unit ang
-- | One-phase sine wave. Height is parametric.
--
sineWave1 :: (Real u, Floating u)
=> u -> u -> Radian -> CatTrail u
sineWave1 h unit ang =
catcurve v1 (vdiff v1 v2) (vdiff v2 v3)
`mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)
`mappend` catcurve (vdiff v6 v7) (vdiff v7 v8) (vdiff v8 v9)
`mappend` catcurve (vdiff v9 v10) (vdiff v10 v11) (vdiff v11 v12)
where
base1 = unit / 12
h2 = h * (pi / 6)
v1 = orthoVec base1 h2 ang
v2 = orthoVec (2*base1) h ang
v3 = orthoVec (3*base1) h ang
v4 = orthoVec (4*base1) h ang
v5 = orthoVec (5*base1) h2 ang
v6 = orthoVec (6*base1) 0 ang
v7 = orthoVec (7*base1) (-h2) ang
v8 = orthoVec (8*base1) (-h) ang
v9 = orthoVec (9*base1) (-h) ang
v10 = orthoVec (10*base1) (-h) ang
v11 = orthoVec (11*base1) (-h2) ang
v12 = orthoVec (12*base1) 0 ang
kappa :: Floating u => u
kappa = 4 * ((sqrt 2 - 1) / 3)
--
-- DESIGN NOTE
--
-- The API seems better exposing ClockDirection as an argument
-- rather than providing two different functions for CW and CCW
-- (even though some functions are defined by independent CW and
-- CCW versions).
--
-- | 'semicircleCW' : @ base_vector -> CatTrail @
--
-- Make an open semicircle from two Bezier curves.
--
-- Although this function produces an approximation of a
-- semicircle, the approximation seems fine in practice.
--
semicircleTrail :: (Real u, Floating u)
=> ClockDirection -> Vec2 u -> CatTrail u
semicircleTrail CW = semicircleCW
semicircleTrail _ = semicircleCCW
-- | 'semicircleCW' : @ base_vector -> CatTrail @
--
-- Make a clockwise semicircle from two Bezier curves. Although
-- this function produces an approximation of a semicircle, the
-- approximation seems fine in practice.
--
semicircleCW :: (Real u, Floating u) => Vec2 u -> CatTrail u
semicircleCW base_vec =
catcurve v1 (vdiff v1 v2) (vdiff v2 v3)
`mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)
where
circum = vlength base_vec
radius = 0.5 * circum
ang = vdirection base_vec
rl = radius * kappa
v1 = orthoVec 0 rl ang
v2 = orthoVec (radius - rl) radius ang
v3 = orthoVec radius radius ang
v4 = orthoVec (radius + rl) radius ang
v5 = orthoVec circum rl ang
v6 = orthoVec circum 0 ang
-- | 'semicircleCCW' : @ base_vector_vector -> CatTrail @
--
-- Make a counter-clockwise semicircle from two Bezier curves.
-- Although this function produces an approximation of a
-- semicircle, the approximation seems fine in practice.
--
semicircleCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u
semicircleCCW base_vec =
catcurve v1 (vdiff v1 v2) (vdiff v2 v3)
`mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)
where
circum = vlength base_vec
radius = 0.5 * circum
ang = vdirection base_vec
rl = radius * kappa
v1 = orthoVec 0 (-rl) ang
v2 = orthoVec (radius - rl) (-radius) ang
v3 = orthoVec radius (-radius) ang
v4 = orthoVec (radius + rl) (-radius) ang
v5 = orthoVec circum (-rl) ang
v6 = orthoVec circum 0 ang
-- | 'semicircleTrail' : @ clock_direction * ry * base_vector -> CatTrail @
--
-- Make an open semiellipse from two Bezier curves.
--
-- Although this function produces an approximation of a
-- semiellipse, the approximation seems fine in practice.
--
semiellipseTrail :: (Real u, Floating u)
=> ClockDirection -> u -> Vec2 u -> CatTrail u
semiellipseTrail CW = semiellipseBasis theta_up
semiellipseTrail _ = semiellipseBasis theta_down
-- | theta_up for CW, theta_down for CCW...
--
semiellipseBasis :: (Real u, Floating u)
=> (u -> Radian -> Vec2 u) -> u -> Vec2 u -> CatTrail u
semiellipseBasis perpfun ry base_vec =
catcurve (pvec p00 c01) (pvec c01 c02) (pvec c02 p03)
`mappend` catcurve (pvec p03 c04) (pvec c04 c05) (pvec c05 p06)
where
rx = 0.5 * vlength base_vec
ang = vdirection base_vec
lrx = rx * kappa
lry = ry * kappa
para = theta_right `flip` ang
perp = perpfun `flip` ang
p00 = zeroPt .+^ theta_left rx ang
c01 = p00 .+^ perp lry
c02 = p03 .+^ para (-lrx)
p03 = zeroPt .+^ perpfun ry ang
c04 = p03 .+^ para lrx
c05 = p06 .+^ perp lry
p06 = zeroPt .+^ theta_right rx ang
-- | 'minorCircleSweep' : @ clock_direction * angle * radius
-- * inclination -> CatTrail @
--
-- > ang should be in the range 0 < ang <= 90deg.
--
minorCircleSweep :: (Real u, Floating u)
=> ClockDirection -> Radian -> u -> Radian -> CatTrail u
minorCircleSweep CW = minorCircleSweepCW
minorCircleSweep _ = minorCircleSweepCCW
-- | 'minorCircleSweepCW' : @ angle * radius * inclination -> CatTrail @
--
-- > ang should be in the range 0 < ang <= 90deg.
--
minorCircleSweepCW :: (Real u, Floating u)
=> Radian -> u -> Radian -> CatTrail u
minorCircleSweepCW ang radius theta =
catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)
where
kfactor = fromRadian $ ang / (0.5*pi)
rl = kfactor * radius * kappa
totang = circularModulo $ theta + (half_pi - ang)
p0 = displace (theta_up radius theta) zeroPt
p1 = displace (theta_right rl theta) p0
p2 = displace (theta_up rl totang) p3
p3 = displace (avec totang radius) zeroPt
-- | 'minorCircleSweepCCW' : @ angle * radius * inclination -> CatTrail @
--
-- > ang should be in the range 0 < ang <= 90deg.
--
minorCircleSweepCCW :: (Real u, Floating u)
=> Radian -> u -> Radian -> CatTrail u
minorCircleSweepCCW ang radius theta =
catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)
where
kfactor = fromRadian $ ang / (0.5*pi)
rl = kfactor * radius * kappa
totang = circularModulo $ theta - half_pi + ang
p0 = displace (theta_down radius theta) zeroPt
p1 = displace (theta_right rl theta) p0
p2 = displace (theta_down rl totang) p3
p3 = displace (avec totang radius) zeroPt
-- | 'circleSweep' : @ clock_direction * apex_angle * radius
-- * inclination -> CatTrail @
--
-- > ang should be in the range 0 < ang < 360deg.
--
-- > if 0 < ang <= 90 returns 1 segment
-- > if 90 < ang <= 180 returns 2 segments
-- > if 180 < ang <= 270 returns 3 segments
-- > if 270 < ang < 360 returns 4 segmenets
--
circleSweep :: (Real u, Floating u)
=> ClockDirection -> Radian -> u -> Radian -> CatTrail u
circleSweep CW = circleSweepCW
circleSweep _ = circleSweepCCW
-- | 'circleSweepCW' : @ apex_angle * radius * inclination -> CatTrail @
--
-- > ang should be in the range 0 < ang < 360deg.
--
-- > if 0 < ang <= 90 returns 1 segment
-- > if 90 < ang <= 180 returns 2 segments
-- > if 180 < ang <= 270 returns 3 segments
-- > if 270 < ang < 360 returns 4 segmenets
--
circleSweepCW :: (Real u, Floating u)
=> Radian -> u -> Radian -> CatTrail u
circleSweepCW ang radius theta = go (circularModulo ang)
where
go a | a <= half_pi = wedge1 a
| a <= pi = wedge2 (a/2)
| a <= 1.5*pi = wedge3 (a/3)
| otherwise = wedge4 (a/4)
wedge1 a = minorCircleSweepCW a radius theta
wedge2 a = minorCircleSweepCW a radius theta
`mappend` minorCircleSweepCW a radius (theta-a)
wedge3 a = minorCircleSweepCW a radius theta
`mappend` minorCircleSweepCW a radius (theta - a)
`mappend` minorCircleSweepCW a radius (theta - 2*a)
wedge4 a = minorCircleSweepCW a radius theta
`mappend` minorCircleSweepCW a radius (theta - a)
`mappend` minorCircleSweepCW a radius (theta - 2*a)
`mappend` minorCircleSweepCW a radius (theta - 3*a)
-- | 'circleSweepCCW' : @ apex_angle * radius * inclination -> CatTrail @
--
-- > ang should be in the range 0 < ang < 360deg.
--
-- > if 0 < ang <= 90 returns 1 segment
-- > if 90 < ang <= 180 returns 2 segments
-- > if 180 < ang <= 270 returns 3 segments
-- > if 270 < ang < 360 returns 4 segmenets
--
circleSweepCCW :: (Real u, Floating u)
=> Radian -> u -> Radian -> CatTrail u
circleSweepCCW ang radius theta = go (circularModulo ang)
where
go a | a <= half_pi = wedge1 a
| a <= pi = wedge2 (a/2)
| a <= 1.5*pi = wedge3 (a/3)
| otherwise = wedge4 (a/4)
wedge1 a = minorCircleSweepCCW a radius theta
wedge2 a = minorCircleSweepCCW a radius theta
`mappend` minorCircleSweepCCW a radius (theta+a)
wedge3 a = minorCircleSweepCCW a radius theta
`mappend` minorCircleSweepCCW a radius (theta+a)
`mappend` minorCircleSweepCCW a radius (theta+a+a)
wedge4 a = minorCircleSweepCCW a radius theta
`mappend` minorCircleSweepCCW a radius (theta+a)
`mappend` minorCircleSweepCCW a radius (theta+a+a)
`mappend` minorCircleSweepCCW a radius (theta+a+a+a)
circularArc :: (Real u, Floating u)
=> ClockDirection -> Radian -> u -> Radian -> CatTrail u
circularArc CW = circularArcCW
circularArc _ = circularArcCCW
-- | inclination is the inclination of the chord.
--
circularArcCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u
circularArcCW apex_ang radius inclin =
circleSweepCW apex_ang radius (inclin + 0.5 * apex_ang)
-- | inclination is the inclination of the chord.
--
circularArcCCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u
circularArcCCW apex_ang radius inclin =
circleSweepCCW apex_ang radius (inclin - 0.5 * apex_ang)
-- | Proper semicircles do not make a good squiggle (it needs a
-- bit of pinch).
--
squiggleWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u
squiggleWave i unit ang = mconcat $ replicate i $ squiggle1 unit ang
squiggle1 :: (Real u, Floating u) => u -> Radian -> CatTrail u
squiggle1 unit ang =
catcurve v1 (vdiff v1 v2) (vdiff v2 v3)
`mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)
`mappend` catcurve (vdiff v6 v7) (vdiff v7 v8) (vdiff v8 v9)
`mappend` catcurve (vdiff v9 v10) (vdiff v10 v11) (vdiff v11 v12)
where
four_radius = unit
radius = 0.25 * four_radius
two_radius = 0.5 * four_radius
three_radius = 0.75 * four_radius
rl = radius * kappa
micro = 0.33 * rl -- seems good
v1 = orthoVec micro rl ang
v2 = orthoVec (radius - rl) radius ang
v3 = orthoVec radius radius ang
v4 = orthoVec (radius + rl) radius ang
v5 = orthoVec (two_radius - micro) rl ang
v6 = orthoVec two_radius 0 ang
v7 = orthoVec (two_radius + micro) (-rl) ang
v8 = orthoVec (three_radius - rl) (-radius) ang
v9 = orthoVec three_radius (-radius) ang
v10 = orthoVec (three_radius + rl) (-radius) ang
v11 = orthoVec (four_radius - micro) (-rl) ang
v12 = orthoVec four_radius 0 ang
squareWave :: Floating u => Int -> u -> Radian -> CatTrail u
squareWave n unit ang
| n > 0 = monPreRepeatPost up_half (n - 1,kont) fin
| otherwise = mempty
where
up_half = catline $ theta_up (0.25 * unit) ang
up_one = catline $ theta_up (0.5 * unit) ang
down_one = catline $ theta_down (0.5 * unit) ang
right_half = catline $ theta_right (0.5 * unit) ang
kont = right_half `mappend` down_one `mappend` right_half
`mappend` up_one
fin = right_half `mappend` down_one `mappend` right_half
`mappend` up_half
-- |
--
sawtoothWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u
sawtoothWave n unit ang
| n > 0 = monPreRepeatPost up_half (n - 1,kont) fin
| otherwise = mempty
where
up_half = catline $ theta_up_right (0.25 * unit) ang
up_one = catline $ theta_up_right (0.5 * unit) ang
down_one = catline $ theta_down_right (0.5 * unit) ang
kont = down_one `mappend` up_one
fin = down_one `mappend` up_half
semicircleWave :: (Real u, Floating u)
=> ClockDirection -> Int -> u -> Radian -> CatTrail u
semicircleWave cdir i unit ang =
mconcat $ replicate i $ fn cdir (avec ang unit)
where
fn CCW = semicircleCCW
fn _ = semicircleCW
--------------------------------------------------------------------------------
-- | 'triCurve' : @ clock_direction * base_width * height *
-- base_inclination -> CatTrail @
--
-- Curve in a triangle - base_width and height are expected to
-- be positive.
--
triCurve :: Floating u => ClockDirection -> u -> u -> Radian -> CatTrail u
triCurve CW bw h ang = ctriCW bw h ang
triCurve CCW bw h ang = ctriCW bw (-h) ang
-- | Curve in a triangle.
--
ctriCW :: Floating u => u -> u -> Radian -> CatTrail u
ctriCW bw h ang = catcurve v1 zeroVec v2
where
v1 = orthoVec (0.5 * bw) h ang
v2 = orthoVec (0.5 * bw) (-h) ang
-- | 'rectCurve' : @ clock_direction * base_width * height *
-- base_inclination -> CatTrail @
--
-- Curve in a rectangle.
--
rectCurve :: Floating u => ClockDirection -> u -> u -> Radian -> CatTrail u
rectCurve CW bw h ang = crectCW bw h ang
rectCurve CCW bw h ang = crectCW bw (-h) ang
-- | Curve in a rectangle.
--
crectCW :: Floating u => u -> u -> Radian -> CatTrail u
crectCW bw h ang = catcurve v1 v2 v3
where
v1 = orthoVec 0 h ang
v2 = orthoVec bw 0 ang
v3 = orthoVec 0 (-h) ang
-- | Curve in a trapezium.
--
trapCurve :: Floating u
=> ClockDirection -> u -> u -> Radian -> Radian -> CatTrail u
trapCurve CW = ctrapCW
trapCurve CCW = ctrapCCW
-- | Curve in a trapezium (CW).
--
-- h must be positive.
--
ctrapCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u
ctrapCW bw h interior_ang ang = catcurve v1 v2 v3
where
minor_bw = h / (fromRadian $ tan interior_ang)
v1 = orthoVec minor_bw h ang
v2 = orthoVec (bw - (2 * minor_bw)) 0 ang
v3 = orthoVec minor_bw (-h) ang
-- | Curve in a trapezium (CCW).
--
-- h must be positive.
--
ctrapCCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u
ctrapCCW bw h interior_ang ang = catcurve v1 v2 v3
where
minor_bw = h / (fromRadian $ tan interior_ang)
v1 = orthoVec minor_bw (-h) ang
v2 = orthoVec (bw - (2 * minor_bw)) 0 ang
v3 = orthoVec minor_bw h ang
-- | Curve in half a /bowtie/.
--
bowCurve :: Floating u
=> ClockDirection -> u -> u -> Radian -> CatTrail u
bowCurve CW bw h ang = cbowCW bw h ang
bowCurve CCW bw h ang = cbowCW bw (-h) ang
-- | Curve in half a /bowtie/.
--
cbowCW :: Floating u => u -> u -> Radian -> CatTrail u
cbowCW bw h ang = catcurve v1 v2 v3
where
v1 = orthoVec 0 h ang
v2 = orthoVec bw (-h) ang
v3 = orthoVec 0 h ang
-- | Wedge curve formed inside a bowtie rotated by 90deg.
--
wedgeCurve :: Floating u
=> ClockDirection -> u -> u -> Radian -> CatTrail u
wedgeCurve CW bw h ang = cwedgeCW bw h ang
wedgeCurve CCW bw h ang = cwedgeCW bw (-h) ang
-- | Wedge curve clockwise.
--
cwedgeCW :: Floating u => u -> u -> Radian -> CatTrail u
cwedgeCW bw h ang = catcurve v1 v2 v3
where
v1 = orthoVec bw h ang
v2 = orthoVec (-bw) 0 ang
v3 = orthoVec bw (-h) ang
-- | Variation of wedge curve that draws a loop.
--
loopCurve :: Floating u
=> ClockDirection -> u -> u -> Radian -> CatTrail u
loopCurve CW bw h ang = cloopCW bw h ang
loopCurve CCW bw h ang = cloopCW bw (-h) ang
-- | loop curve clockwise.
--
cloopCW :: Floating u => u -> u -> Radian -> CatTrail u
cloopCW bw h ang = catcurve v1 v2 v3
where
ww = 2.0 * bw
v1 = orthoVec (1.5 * bw) h ang
v2 = orthoVec (-ww) 0 ang
v3 = orthoVec (1.5 * bw) (-h) ang