{-# 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