wumpus-drawing-0.7.0: src/Wumpus/Drawing/Paths/Base.hs
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Drawing.Paths.Base
-- Copyright : (c) Stephen Tetley 2010-2011
-- License : BSD3
--
-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>
-- Stability : highly unstable
-- Portability : GHC
--
-- Absolute path type - this should be more amenable for building
-- complex drawings than the PrimPath type in Wumpus-Core.
--
--------------------------------------------------------------------------------
module Wumpus.Drawing.Paths.Base
(
-- * Absolute path type
AbsPath
, DAbsPath
-- * Construction
, emptyPath
, line1
, curve1
, vertexPath
, curvePath
, controlCurve
, vectorPath
, vectorPathTheta
, placedTrailPath
, catTrailPath
-- * Queries
, null
, length
-- * Concat and extension
, snocLine
, snocLineTo
, snocCurve
, snocCurveTo
-- * Conversion
, toPrimPath
, drawPath
, drawPath_
-- * Shortening
, shortenPath
, shortenL
, shortenR
-- * Tips and direction
, tipL
, tipR
, directionL
, directionR
, isBezierL
, isBezierR
-- * Path anchors
, midway
, midway_
, atstart
, atstart_
, atend
, atend_
-- * Views
, PathViewL(..)
, DPathViewL
, PathViewR(..)
, DPathViewR
, PathSegment(..)
, DPathSegment
, pathViewL
, pathViewR
, optimizeLines
, roundExterior
, roundInterior
-- * Path division
, pathdiv
) where
import Wumpus.Basic.Geometry.Base -- package: wumpus-basic
import Wumpus.Basic.Kernel
import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl
, ViewR(..), viewr, cons, snoc )
import qualified Wumpus.Basic.Utils.JoinList as JL
import Wumpus.Core -- package: wumpus-core
import Data.AffineSpace -- package: vector-space
import Data.VectorSpace
import Data.Monoid
import qualified Data.Traversable as T
import Prelude hiding ( null, length )
--
-- Design Note
--
-- Wumpus has no relative path type. An AbsPath is expected to be
-- an /answer/ from some function like an anchor point or a
-- bounding box.
--
-- Wumpus didn\'t always work on this premise, some of the code
-- below may contradict this...
--
-- | Absolute path data type.
--
data AbsPath u = AbsPath
{ _abs_path_length :: u
, _abs_path_start :: Point2 u
, _abs_path_elements :: JoinList (AbsPathSeg u)
, _abs_path_end :: Point2 u
}
deriving (Eq,Show)
type instance DUnit (AbsPath u) = u
type DAbsPath = AbsPath Double
-- Annotating each segment with length is \*\* good \*\*.
-- Makes it much more efficient to find the midway point.
--
-- But what do we do about the start point:
--
-- a) put it in the segment - too much info in the type, allows
-- consistency problems vis-a-vis gaps in the path.
--
-- b) leave it out - too little info in the type, allows
-- consistency problems with length.
--
-- Option (a) is probably most convenient espcially as the
-- constructors won\'t be exported.
-- Annotation is length...
--
data AbsPathSeg u = AbsLineSeg u (Vec2 u)
| AbsCurveSeg u (Vec2 u) (Vec2 u) (Vec2 u)
deriving (Eq,Show)
type instance DUnit (AbsPathSeg u) = u
--
-- DESIGN NOTE
--
-- No monoid instance. AbsPaths dont support empty or even concat
-- naturally.
--
-- Concat is troublesome because AbsPaths are always located
-- within a frame.
--
-- They can support:
--
-- a. Concat with a join between the end of the first path and the
-- start of the second.
--
-- b. Shape preserving concat - the second path is moved so it
-- continues from the end point of the first path.
--
-- It is conceptually simpler to think about extension (adding to
-- the path tip) rather than concatenation.
--
--------------------------------------------------------------------------------
instance Functor AbsPath where
fmap f (AbsPath u sp ls ep) =
AbsPath (f u) (fmap f sp) (fmap (fmap f) ls) (fmap f ep)
instance Functor AbsPathSeg where
fmap f (AbsLineSeg u v1) =
AbsLineSeg (f u) (fmap f v1)
fmap f (AbsCurveSeg u v1 v2 v3) =
AbsCurveSeg (f u) (fmap f v1) (fmap f v2) (fmap f v3)
--------------------------------------------------------------------------------
-- Translate
-- Translate is cheap on AbsPath
instance Num u => Translate (AbsPath u) where
translate x y (AbsPath len sp se ep) =
AbsPath len (translate x y sp) se (translate x y ep)
--------------------------------------------------------------------------------
-- Construction
-- | Create the empty path.
--
-- Note - an absolute path needs /locating/ and cannot be built
-- without a start point. Figuratively, the empty path is a path
-- from the start point to the end point.
--
-- Thus AbsPath operates as a semigroup but not a monoid.
--
emptyPath :: Floating u => Point2 u -> AbsPath u
emptyPath = zeroPath
-- | Create an absolute path as a straight line between the
-- supplied points.
--
line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u
line1 p0 p1 = AbsPath len p0 (JL.one $ AbsLineSeg len v1) p1
where
v1 = pvec p0 p1
len = vlength v1
-- | Create an absolute path from a single cubic Bezier curve.
--
curve1 :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u
curve1 p0 p1 p2 p3 =
AbsPath len p0 (JL.one $ AbsCurveSeg len v1 v2 v3) p3
where
v1 = pvec p0 p1
v2 = pvec p1 p2
v3 = pvec p2 p3
len = bezierLength (BezierCurve p0 p1 p2 p3)
-- | 'vertexPath' throws a runtime error if the supplied list
-- is empty.
--
vertexPath :: (Floating u, Ord u, Tolerance u)
=> [Point2 u] -> AbsPath u
vertexPath [] = error "traceLinePoints - empty point list."
vertexPath [a] = line1 a a
vertexPath (a:b:xs) = step (line1 a b) xs
where
step acc [] = acc
step acc (y:ys) = step (snocLineTo acc y) ys
-- | 'curvePath' consumes 4 points from the list on the
-- intial step (start, control1, control2, end) then steps
-- through the list taking 3 points at a time thereafter
-- (control1,control2, end). Leftover points are discarded.
--
-- 'curvePath' throws a runtime error if the supplied list
-- is has less than 4 elements (start, control1, control2, end).
--
curvePath :: (Floating u, Ord u, Tolerance u)
=> [Point2 u] -> AbsPath u
curvePath (a:b:c:d:xs) = step (curve1 a b c d) xs
where
step acc (x:y:z:zs) = step (snocCurveTo acc (x,y,z)) zs
step acc _ = acc
curvePath _ = error "curvePath - less than 4 elems."
-- NOTE - need a proper arc path builder.
-- | This is not an arc...
--
controlCurve :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> Radian -> Radian -> Point2 u -> AbsPath u
controlCurve start cin cout end =
curve1 start (start .+^ v1) (end .+^ v2) end
where
sz = 0.375 * (vlength $ pvec start end)
v1 = avec cin sz
v2 = avec cout sz
vectorPath :: (Floating u, Ord u, Tolerance u)
=> [Vec2 u] -> Point2 u -> AbsPath u
vectorPath vecs p0 = vertexPath $ p0 : step p0 vecs
where
step _ [] = []
step pt (v1:vs) = let p1 = pt .+^ v1 in p1 : step p1 vs
vectorPathTheta :: (Real u, Floating u, Tolerance u)
=> [Vec2 u] -> Radian -> Point2 u -> AbsPath u
vectorPathTheta vs ang = vectorPath $ map (rotate ang) vs
placedTrailPath :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> PlacedTrail u -> AbsPath u
placedTrailPath pt trl =
let (v1,ss) = destrPlacedTrail trl in step (emptyPath $ pt .+^ v1) ss
where
step ac [] = ac
step ac (TLine v1:xs) = step (ac `snocLine` v1) xs
step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs
catTrailPath :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> CatTrail u -> AbsPath u
catTrailPath pt trl = step (emptyPath pt) $ destrCatTrail trl
where
step ac [] = ac
step ac (TLine v1:xs) = step (ac `snocLine` v1) xs
step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs
--------------------------------------------------------------------------------
-- Queries
-- | Is the path empty?
--
null :: AbsPath u -> Bool
null = JL.null . _abs_path_elements
-- | Length of the Path.
--
-- Length is the length of the path as it is drawn, it is not a
-- count of the number or path segments.
--
-- Length is cached so this operation is cheap - though this puts
-- a tax on the build operations.
--
length :: Num u => AbsPath u -> u
length (AbsPath u _ _ _) = u
--------------------------------------------------------------------------------
-- Extension
infixl 5 `snocLine`
-- | Extend the path with a straight line segment from the
-- end-point defined by the supplied vector.
--
-- > infixl 5 `snocLine`
--
snocLine :: Floating u => AbsPath u -> Vec2 u -> AbsPath u
snocLine (AbsPath u sp se ep) v1 =
let u1 = vlength v1
tail_line = AbsLineSeg u1 v1
in AbsPath (u + u1) sp (JL.snoc se tail_line) (ep .+^ v1)
infixl 5 `snocLineTo`
-- | Extend the path with a straight line segment from the
-- end-point to the supplied point.
--
-- > infixl 5 `snocLineTo`
--
snocLineTo :: Floating u => AbsPath u -> Point2 u -> AbsPath u
snocLineTo (AbsPath u sp se1 ep) p1 = AbsPath (u + len) sp (snoc se1 s1) p1
where
s1@(AbsLineSeg len _) = lineSegment ep p1
infixl 5 `snocCurve`
-- | Extend the path from the end-point with a Bezier curve
-- segment formed by the supplied points.
--
-- > infixl 5 `snocCurve`
--
snocCurve :: (Floating u, Ord u, Tolerance u)
=> AbsPath u -> (Vec2 u, Vec2 u, Vec2 u) -> AbsPath u
snocCurve absp@(AbsPath _ _ _ ep) (v1,v2,v3) = snocCurveTo absp (p1,p2,p3)
where
p1 = ep .+^ v1
p2 = p1 .+^ v2
p3 = p2 .+^ v3
infixl 5 `snocCurveTo`
-- | Extend the path from the end-point with a Bezier curve
-- segment formed by the supplied points.
--
-- > infixl 5 `snocCurveTo`
--
snocCurveTo :: (Floating u, Ord u, Tolerance u)
=> AbsPath u -> (Point2 u, Point2 u, Point2 u) -> AbsPath u
snocCurveTo (AbsPath u sp se1 ep) (p1,p2,p3) =
AbsPath (u + len) sp (snoc se1 s1) p3
where
s1@(AbsCurveSeg len _ _ _) = curveSegment ep p1 p2 p3
--------------------------------------------------------------------------------
segmentLength :: AbsPathSeg u -> u
segmentLength (AbsLineSeg u _) = u
segmentLength (AbsCurveSeg u _ _ _) = u
segmentVector :: Num u => AbsPathSeg u -> Vec2 u
segmentVector (AbsLineSeg _ v1) = v1
segmentVector (AbsCurveSeg _ v1 v2 v3) = v1 ^+^ v2 ^+^ v3
-- | Helper - construct a line segment.
--
lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u
lineSegment p0 p1 = lineSegmentV $ pvec p0 p1
-- | Helper - construct a line segment.
--
lineSegmentV :: Floating u => Vec2 u -> AbsPathSeg u
lineSegmentV v1 = AbsLineSeg (vlength v1) v1
-- | Helper - construct a curve segment.
--
curveSegment :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPathSeg u
curveSegment p0 p1 p2 p3 = AbsCurveSeg len v1 v2 v3
where
len = bezierLength (BezierCurve p0 p1 p2 p3)
v1 = pvec p0 p1
v2 = pvec p1 p2
v3 = pvec p2 p3
-- | Helper - construct the /empty/ but located path.
--
zeroPath :: Floating u => Point2 u -> AbsPath u
zeroPath p0 = AbsPath 0 p0 JL.empty p0
drawPath :: InterpretUnit u
=> PathMode -> AbsPath u -> Image u (AbsPath u)
drawPath mode rp = replaceAns rp $
liftQuery (toPrimPath rp) >>= dcPath mode
drawPath_ :: InterpretUnit u
=> PathMode -> AbsPath u -> Graphic u
drawPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode
-- | Turn a Path into an ordinary PrimPath.
--
-- Assumes path is properly formed - i.e. end point of one
-- segment is the same point as the start point of the next
-- segment.
--
toPrimPath :: InterpretUnit u => AbsPath u -> Query u PrimPath
toPrimPath (AbsPath _ start segs _) =
uconvertCtxF start >>= \dstart ->
T.mapM uconvertCtxF segs >>= \dsegs ->
return $ step1 dstart dsegs
where
step1 p0 se | JL.null se = emptyPrimPath p0
| otherwise = absPrimPath p0 $ step2 p0 (viewl se)
step2 _ EmptyL = []
step2 pt (e :< se) = let (p1,s) = mkSeg pt e
in s : step2 p1 (viewl se)
mkSeg p0 (AbsLineSeg _ v1) = let p1 = p0 .+^ v1
in (p1, absLineTo p1)
mkSeg p0 (AbsCurveSeg _ v1 v2 v3) = let p1 = p0 .+^ v1
p2 = p1 .+^ v2
p3 = p2 .+^ v3
in (p3, absCurveTo p1 p2 p3)
-- | 'sortenPath' : @ left_dist * right_dist * path -> Path @
--
shortenPath :: (Real u , Floating u)
=> u -> u -> AbsPath u -> AbsPath u
shortenPath l r = shortenL l . shortenR r
--------------------------------------------------------------------------------
-- shorten from the left...
-- | Note - shortening a line from the left by
-- greater-than-or-equal its length is operationally equivalent
-- to making a zero-length line at the end point.
--
shortenL :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u
shortenL n path1@(AbsPath u startp segs ep)
| n < 0 = path1
| n >= u = AbsPath 0 ep mempty ep
| otherwise = step n startp (viewl segs)
where
step _ _ EmptyL = AbsPath 0 ep mempty ep
step d sp (e :< se) = let z = segmentLength e
snext = sp .+^ segmentVector e
in case compare d z of
GT -> step (d-z) snext (viewl se)
EQ -> makeLeftPath (u-n) snext se ep
LT -> let (spart,e1) = shortenSegL d sp e
in AbsPath (u-n) spart (e1 `cons` se) ep
makeLeftPath :: Floating u
=> u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u
-> AbsPath u
makeLeftPath u sp se ep | JL.null se = line1 sp ep
| otherwise = AbsPath u sp se ep
shortenSegL :: (Real u, Floating u)
=> u -> Point2 u -> AbsPathSeg u -> (Point2 u, AbsPathSeg u)
shortenSegL n sp (AbsLineSeg u v1) =
let v2 = shortenVec n v1
sp' = sp .+^ (v1 ^-^ v2)
in (sp', AbsLineSeg (u-n) v2)
shortenSegL n sp (AbsCurveSeg u v1 v2 v3) =
(q0, AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3))
where
(BezierCurve q0 q1 q2 q3) = let p1 = sp .+^ v1
p2 = p1 .+^ v2
p3 = p2 .+^ v3
in snd $ subdividet (n/u)
(BezierCurve sp p1 p2 p3)
shortenVec :: (Real u, Floating u) => u -> Vec2 u -> Vec2 u
shortenVec n v0 = v0 ^-^ v
where
v = avec (vdirection v0) n
--------------------------------------------------------------------------------
-- shorten from the right ...
-- | Note - shortening a line from the right by
-- greater-than-or-equal its length is operationally equivalent
-- to making a zero-length line at the start point.
--
shortenR :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u
shortenR n path1@(AbsPath u sp segs endpt)
| n < 0 = path1
| n >= u = AbsPath 0 sp mempty sp
| otherwise = step n (viewr segs) endpt
where
step _ EmptyR _ = AbsPath 0 sp mempty sp
step d (se :> e) ep = let z = segmentLength e
enext = ep .-^ segmentVector e
in case compare d z of
GT -> step (d-z) (viewr se) enext
EQ -> makeRightPath n sp se enext
LT -> let (e1,epart) = shortenSegR d e ep
in AbsPath (u-n) sp (se `snoc` e1) epart
makeRightPath :: Floating u
=> u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u
-> AbsPath u
makeRightPath u sp se ep | JL.null se = line1 sp ep
| otherwise = AbsPath u sp se ep
shortenSegR :: (Real u, Floating u)
=> u -> AbsPathSeg u -> Point2 u -> (AbsPathSeg u, Point2 u)
shortenSegR n (AbsLineSeg u v1) ep =
let v2 = shortenVec n v1
ep' = ep .-^ (v1 ^+^ v2)
in (AbsLineSeg (u-n) v2, ep')
shortenSegR n (AbsCurveSeg u v1 v2 v3) ep =
(AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3), q3)
where
(BezierCurve q0 q1 q2 q3) = let p2 = ep .-^ v3
p1 = p2 .-^ v2
p0 = p1 .-^ v1
in fst $ subdividet ((u-n)/u)
(BezierCurve p0 p1 p2 ep)
--------------------------------------------------------------------------------
-- tips
tipL :: AbsPath u -> Point2 u
tipL (AbsPath _ sp _ _) = sp
tipR :: AbsPath u -> Point2 u
tipR (AbsPath _ _ _ ep) = ep
--------------------------------------------------------------------------------
-- line direction
-- | Direction of empty path is considered to be 0.
--
directionL :: (Real u, Floating u) => AbsPath u -> Radian
directionL (AbsPath _ _ se _) = step $ viewl se
where
step (AbsLineSeg _ v1 :< _) = vdirection $ negateV v1
step (AbsCurveSeg _ v1 _ _ :< _) = vdirection $ negateV v1
step _ = 0
-- | Direction of empty path is considered to be 0.
--
directionR :: (Real u, Floating u) => AbsPath u -> Radian
directionR (AbsPath _ _ se _) = step $ viewr se
where
step (_ :> AbsLineSeg _ v1) = vdirection v1
step (_ :> AbsCurveSeg _ _ _ v3) = vdirection v3
step _ = 0
-- | Is the left tip a Bezier curve?
--
isBezierL :: AbsPath u -> Bool
isBezierL (AbsPath _ _ se _) = step $ viewl se
where
step (AbsCurveSeg _ _ _ _ :< _) = True
step _ = False
-- | Is the right tip a Bezier curve?
--
isBezierR :: AbsPath u -> Bool
isBezierR (AbsPath _ _ se _) = step $ viewr se
where
step (_ :> AbsCurveSeg _ _ _ _) = True
step _ = False
--------------------------------------------------------------------------------
-- Return direction as well because the calculation is expensive...
--
midway :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)
midway pa@(AbsPath u sp _ _)
| u == 0 = (sp,0)
| otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1)
-- Just the midway point.
--
midway_ :: (Real u, Floating u) => AbsPath u -> Point2 u
midway_ = fst . midway
atstart :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)
atstart pa@(AbsPath _ sp _ _) = (sp, directionL pa)
atstart_ :: AbsPath u -> Point2 u
atstart_ (AbsPath _ sp _ _) = sp
atend :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)
atend pa@(AbsPath _ _ _ ep) = (ep, directionR pa)
atend_ :: AbsPath u -> Point2 u
atend_ (AbsPath _ _ _ ep) = ep
-- nearstart, nearend, verynear ...
--------------------------------------------------------------------------------
-- Path Views cf. Data.Sequence
infixr 5 :<<
infixl 5 :>>
data PathViewL u = EmptyPathL
| PathSegment u :<< AbsPath u
deriving (Eq,Show)
type instance DUnit (PathViewL u) = u
type DPathViewL = PathViewL Double
data PathViewR u = EmptyPathR
| AbsPath u :>> PathSegment u
deriving (Eq,Show)
type instance DUnit (PathViewR u) = u
type DPathViewR = PathViewR Double
-- | PathSegments are annotated with length.
--
--
data PathSegment u = LineSeg u (Point2 u) (Point2 u)
| CurveSeg u (Point2 u) (Point2 u) (Point2 u) (Point2 u)
deriving (Eq,Show)
type instance DUnit (PathSegment u) = u
type DPathSegment = PathSegment Double
--------------------------------------------------------------------------------
instance Functor PathSegment where
fmap f (LineSeg d p0 p1) = LineSeg (f d) (fmap f p0) (fmap f p1)
fmap f (CurveSeg d p0 p1 p2 p3) =
CurveSeg (f d) (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3)
instance Functor PathViewL where
fmap _ EmptyPathL = EmptyPathL
fmap f (a :<< as) = fmap f a :<< fmap f as
instance Functor PathViewR where
fmap _ EmptyPathR = EmptyPathR
fmap f (as :>> a) = fmap f as :>> fmap f a
--------------------------------------------------------------------------------
pathViewL :: Num u => AbsPath u -> PathViewL u
pathViewL (AbsPath len sp segs ep) = go (viewl segs)
where
go EmptyL = EmptyPathL
go (AbsLineSeg d v1 :< se) =
let p1 = sp .+^ v1 in LineSeg d sp p1 :<< AbsPath (len - d) p1 se ep
go (AbsCurveSeg d v1 v2 v3 :< se) =
let p1 = sp .+^ v1
p2 = p1 .+^ v2
p3 = p2 .+^ v3
in CurveSeg d sp p1 p2 p3 :<< AbsPath (len - d) p3 se ep
pathViewR :: Num u => AbsPath u -> PathViewR u
pathViewR (AbsPath len sp segs ep) = go (viewr segs)
where
go EmptyR = EmptyPathR
go (se :> AbsLineSeg d v1) =
let p0 = ep .-^ v1 in AbsPath (len - d) sp se p0 :>> LineSeg d p0 ep
go (se :> AbsCurveSeg d v1 v2 v3) =
let p2 = ep .-^ v3
p1 = p2 .-^ v2
p0 = p1 .-^ v1
in AbsPath (len - d) sp se p0 :>> CurveSeg d p0 p1 p2 ep
--------------------------------------------------------------------------------
-- Path should be same length afterwards.
optimizeLines :: (Real u, Floating u, Ord u, Tolerance u)
=> AbsPath u -> AbsPath u
optimizeLines (AbsPath _ sp0 segs _) =
outer (zeroPath sp0) (viewl segs)
where
outer acc (AbsLineSeg _ v1 :< se) =
inner acc (vdirection v1) v1 (viewl se)
outer acc (AbsCurveSeg u v1 v2 v3 :< se) =
outer (snocC acc u v1 v2 v3) (viewl se)
outer acc EmptyL = acc
inner acc d0 v0 (AbsLineSeg _ v1 :< se) =
let d1 = vdirection v1
in if (d0 == vdirection v1)
then inner acc d1 (v0 ^+^ v1) (viewl se)
else inner (snocV acc v0) d1 v1 (viewl se)
inner acc _ v0 (AbsCurveSeg u v1 v2 v3 :< se) =
let acc1 = snocC (snocV acc v0) u v1 v2 v3
in outer acc1 (viewl se)
inner acc _ v0 EmptyL = snocV acc v0
snocC (AbsPath u sp se ep) u1 v1 v2 v3 =
let tail_curve = AbsCurveSeg u1 v1 v2 v3
vtotal = v1 ^+^ v2 ^+^ v3
in AbsPath (u+u1) sp (JL.snoc se tail_curve) (ep .+^ vtotal)
snocV (AbsPath u sp se ep) v1 =
let u1 = vlength v1
tail_line = AbsLineSeg u1 v1
in AbsPath (u+u1) sp (JL.snoc se tail_line) (ep .+^ v1)
--------------------------------------------------------------------------------
-- Round corners
segToCatTrail :: AbsPathSeg u -> CatTrail u
segToCatTrail (AbsLineSeg _ v1) = catline v1
segToCatTrail (AbsCurveSeg _ v1 v2 v3) = catcurve v1 v2 v3
-- | Because lookahead of 2 makes the rounding algos easier we
-- decons to a list...
--
segmentListL :: AbsPath u -> (Point2 u, [AbsPathSeg u])
segmentListL (AbsPath _ sp se _) = (sp, JL.toList se)
-- | Round interior corners of a Path.
--
-- The path is treated as open - the start of the initial and end
-- of the final segments are not rounded. Only straight line to
-- straight line joins are rounded, joins to or from Beczier
-- curves are not rounded.
--
-- Caution - all path segments are expected to be longer than
-- 2x the round corner length, though this is not checked..
--
roundInterior :: (Real u, Floating u,Tolerance u)
=> u -> AbsPath u -> AbsPath u
roundInterior du pth0 = catTrailPath pt ctrail
where
(pt,ss) = segmentListL pth0
ctrail = roundInteriorCat du ss
roundInteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u
roundInteriorCat _ [] = mempty
roundInteriorCat du (z:zs) = step mempty z zs
where
step ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) =
let (x,k) = roundAB du v1 v2 in step (ac `mappend` x) k xs
step ac prev (x:xs) =
let tprev = segToCatTrail prev in step (ac `mappend` tprev) x xs
step ac prev [] = ac `mappend` segToCatTrail prev
roundAB :: (Real u, Floating u)
=> u -> Vec2 u -> Vec2 u -> (CatTrail u, AbsPathSeg u)
roundAB du v1 v2 =
(catline v1' `mappend` tcurve, lineSegmentV v2')
where
v1' = shortenVec du v1
v2' = shortenVec du v2
tv1 = avec (vdirection v1) du
tv2 = avec (vdirection v2) du
base_vec = tv1 ^+^ tv2
bw = vlength base_vec
h = sqrt $ pow2 du - (pow2 $ 0.5 * bw)
tcurve = tricurve bw (-h) (vdirection base_vec)
-- note the (-h) in tricurve is wrong, we need to account
-- for CCW or CW properly...
pow2 :: Num a => a -> a
pow2 x = x ^ (2::Int)
-- Form corners inside a /triangle/ Bezier.
-- | Round a \"closed\" path.
--
-- Caution - all path sgements are expected to be longer than
-- 2x the round corner length, though this is not checked..
--
roundExterior :: (Real u, Floating u, Tolerance u)
=> u -> AbsPath u -> AbsPath u
roundExterior du pth0
| isBezierR pth0 || isBezierL pth0 = roundInterior du pth0
| otherwise = catTrailPath pt ctrail
where
(pt,ss) = segmentListL pth0
ctrail = roundExteriorCat du ss
roundExteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u
roundExteriorCat _ [] = mempty
roundExteriorCat _ (AbsCurveSeg _ _ _ _ : _) =
error "runExteriorCat - unreachable."
roundExteriorCat du (z@(AbsLineSeg _ v0):zs) = step0 z zs
where
step0 (AbsLineSeg _ v1) xs =
let seg0 = lineSegmentV $ shortenVec du v1 in step1 mempty seg0 xs
step0 _ _ = error "roundExteriorCat - unreachable 1."
step1 ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) =
let (x,k) = roundAB du v1 v2 in step1 (ac `mappend` x) k xs
step1 ac prev (x:xs) =
let tprev = segToCatTrail prev in step1 (ac `mappend` tprev) x xs
step1 ac (AbsLineSeg _ v1) [] =
let (t,_) = roundAB du v1 v0 in ac `mappend` t
step1 _ _ [] =
error "roundExteriorCat - unreachable 2."
--------------------------------------------------------------------------------
-- Path division
-- | Divide a path returning intermediate points and direction
--
-- Args are initial-prefix, division size, trailing size.
--
-- Generation is stopped if the remainder of the path is shorter
-- than the trailing size.
--
pathdiv :: (Real u, Floating u)
=> u -> u -> u -> AbsPath u -> [(Point2 u, Radian)]
pathdiv ana sz end = step . shortenL ana
where
step pth | length pth < end = []
| otherwise = atstart pth : step (shortenL sz pth)