module Wumpus.Drawing.Paths.Base
(
AbsPath
, DAbsPath
, emptyPath
, line1
, curve1
, vertexPath
, curvePath
, controlCurve
, vectorPath
, vectorPathTheta
, anaTrailPath
, catTrailPath
, null
, length
, snocLine
, snocLineTo
, snocCurve
, snocCurveTo
, toPrimPath
, renderPath
, renderPath_
, shortenPath
, shortenL
, shortenR
, tipL
, tipR
, inclinationL
, inclinationR
, isBezierL
, isBezierR
, midway
, midway_
, atstart
, atstart_
, atend
, atend_
, PathViewL(..)
, DPathViewL
, PathViewR(..)
, DPathViewR
, PathSegment(..)
, DPathSegment
, pathViewL
, pathViewR
, optimizeLines
, roundExterior
, roundInterior
, deBezier
, pathMajorPoints
, pathAllPoints
, pathdiv
) where
import Wumpus.Drawing.Basis.BezierCurve
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
import Data.AffineSpace
import Data.VectorSpace
import Data.Monoid
import qualified Data.Traversable as T
import Prelude hiding ( null, length )
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
data AbsPathSeg u = AbsLineSeg u (Vec2 u)
| AbsCurveSeg u (Vec2 u) (Vec2 u) (Vec2 u)
deriving (Eq,Show)
type instance DUnit (AbsPathSeg u) = u
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)
instance Num u => Translate (AbsPathSeg u) where
translate _ _ s1 = s1
instance (Floating u, Ord u, Tolerance u) => Scale (AbsPathSeg u) where
scale sx sy (AbsLineSeg _ v1) = absLineSeg $ scale sx sy v1
scale sx sy (AbsCurveSeg _ v1 v2 v3) =
absCurveSeg (scale sx sy v1) (scale sx sy v2) (scale sx sy v3)
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)
instance (Floating u, Ord u, Tolerance u) => Scale (AbsPath u) where
scale sx sy = rebuildPath (scale sx sy) (scale sx sy)
(\v1 v2 v3 -> ( scale sx sy v1
, scale sx sy v2
, scale sx sy v3 ))
instance (Real u, Floating u, Ord u, Tolerance u) => Rotate (AbsPath u) where
rotate ang = rebuildPath (rotate ang) (rotate ang)
(\v1 v2 v3 -> ( rotate ang v1
, rotate ang v2
, rotate ang v3 ))
instance (Real u, Floating u, Ord u, Tolerance u) => RotateAbout (AbsPath u) where
rotateAbout ang pt =
rebuildPath (rotateAbout ang pt) (rotateAbout ang pt)
(\v1 v2 v3 -> ( rotateAbout ang pt v1
, rotateAbout ang pt v2
, rotateAbout ang pt v3 ))
rebuildPath :: (Floating u, Ord u, Tolerance u)
=> (Point2 u -> Point2 u)
-> (Vec2 u -> Vec2 u)
-> (Vec2 u -> Vec2 u -> Vec2 u -> (Vec2 u, Vec2 u, Vec2 u))
-> AbsPath u
-> AbsPath u
rebuildPath pointf linef curvef (AbsPath _ sp segs _) =
step (emptyPath $ pointf sp) (viewl segs)
where
step ac EmptyL = ac
step ac (AbsLineSeg _ v1 :< xs) =
step (snocLine ac $ linef v1) (viewl xs)
step ac (AbsCurveSeg _ v1 v2 v3 :< xs) =
step (snocCurve ac $ curvef v1 v2 v3) (viewl xs)
absLineSeg :: Floating u => Vec2 u -> AbsPathSeg u
absLineSeg v1 = AbsLineSeg (vlength v1) v1
absCurveSeg :: (Floating u, Ord u, Tolerance u)
=> Vec2 u -> Vec2 u -> Vec2 u -> AbsPathSeg u
absCurveSeg v1 v2 v3 =
AbsCurveSeg (bezierLength $ vbezierCurve v1 v2 v3 zeroPt) v1 v2 v3
emptyPath :: Floating u => Point2 u -> AbsPath u
emptyPath = zeroPath
line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u
line1 p0 p1 = AbsPath len p0 (JL.one s1) p1
where
s1@(AbsLineSeg len _) = absLineSeg $ pvec p0 p1
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 :: (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 :: (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."
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
anaTrailPath :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> AnaTrail u -> AbsPath u
anaTrailPath pt trl =
let (v1,ss) = destrAnaTrail 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
null :: AbsPath u -> Bool
null = JL.null . _abs_path_elements
length :: Num u => AbsPath u -> u
length (AbsPath u _ _ _) = u
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`
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`
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`
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
lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u
lineSegment p0 p1 = lineSegmentV $ pvec p0 p1
lineSegmentV :: Floating u => Vec2 u -> AbsPathSeg u
lineSegmentV v1 = AbsLineSeg (vlength v1) v1
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
zeroPath :: Floating u => Point2 u -> AbsPath u
zeroPath p0 = AbsPath 0 p0 JL.empty p0
renderPath :: InterpretUnit u
=> PathMode -> AbsPath u -> Image u (AbsPath u)
renderPath mode rp = replaceAns rp $
liftQuery (toPrimPath rp) >>= dcPath mode
renderPath_ :: InterpretUnit u
=> PathMode -> AbsPath u -> Graphic u
renderPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode
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)
shortenPath :: (Real u , Floating u)
=> u -> u -> AbsPath u -> AbsPath u
shortenPath l r = shortenL l . shortenR r
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 (dz) snext (viewl se)
EQ -> makeLeftPath (un) snext se ep
LT -> let (spart,e1) = shortenSegL d sp e
in AbsPath (un) 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 .+^ avec (vdirection v1) n
in (sp', AbsLineSeg (un) v2)
shortenSegL n sp (AbsCurveSeg u v1 v2 v3) =
(q0, AbsCurveSeg (un) (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
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 (dz) (viewr se) enext
EQ -> makeRightPath n sp se enext
LT -> let (e1,epart) = shortenSegR d e ep
in AbsPath (un) 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 .-^ avec (vdirection v1) n
in (AbsLineSeg (un) v2, ep')
shortenSegR n (AbsCurveSeg u v1 v2 v3) ep =
(AbsCurveSeg (un) (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 ((un)/u)
(BezierCurve p0 p1 p2 ep)
tipL :: AbsPath u -> Point2 u
tipL (AbsPath _ sp _ _) = sp
tipR :: AbsPath u -> Point2 u
tipR (AbsPath _ _ _ ep) = ep
inclinationL :: (Real u, Floating u) => AbsPath u -> Radian
inclinationL (AbsPath _ _ se _) = step $ viewl se
where
step (AbsLineSeg _ v1 :< _) = vdirection v1
step (AbsCurveSeg _ v1 _ _ :< _) = vdirection v1
step _ = 0
inclinationR :: (Real u, Floating u) => AbsPath u -> Radian
inclinationR (AbsPath _ _ se _) = step $ viewr se
where
step (_ :> AbsLineSeg _ v1) = vdirection v1
step (_ :> AbsCurveSeg _ _ _ v3) = vdirection v3
step _ = 0
isBezierL :: AbsPath u -> Bool
isBezierL (AbsPath _ _ se _) = step $ viewl se
where
step (AbsCurveSeg _ _ _ _ :< _) = True
step _ = False
isBezierR :: AbsPath u -> Bool
isBezierR (AbsPath _ _ se _) = step $ viewr se
where
step (_ :> AbsCurveSeg _ _ _ _) = True
step _ = False
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, inclinationR pa1)
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, inclinationL 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, inclinationR pa)
atend_ :: AbsPath u -> Point2 u
atend_ (AbsPath _ _ _ ep) = ep
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
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
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)
segToCatTrail :: AbsPathSeg u -> CatTrail u
segToCatTrail (AbsLineSeg _ v1) = catline v1
segToCatTrail (AbsCurveSeg _ v1 v2 v3) = catcurve v1 v2 v3
segmentListL :: AbsPath u -> (Point2 u, [AbsPathSeg u])
segmentListL (AbsPath _ sp se _) = (sp, JL.toList se)
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)
clockd = clockDirection v1 v2
tcurve = triCurve clockd bw (h) (vdirection base_vec)
pow2 :: Num a => a -> a
pow2 x = x ^ (2::Int)
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."
deBezier :: Floating u => AbsPath u -> AbsPath u
deBezier (AbsPath _ sp segs _) =
step (emptyPath sp) (viewl segs)
where
step ac EmptyL = ac
step ac (AbsLineSeg _ v1 :< xs) =
step (ac `snocLine` v1) (viewl xs)
step ac (AbsCurveSeg _ v1 v2 v3 :< xs) =
step (ac `snocLine` v1 `snocLine` v2 `snocLine` v3) (viewl xs)
pathMajorPoints :: Num u => AbsPath u -> [Point2 u]
pathMajorPoints (AbsPath _ sp segs _) = sp : step sp (viewl segs)
where
step _ EmptyL = []
step pt (AbsLineSeg _ v1 :< xs) =
let p1 = pt .+^ v1 in p1 : step p1 (viewl xs)
step pt (AbsCurveSeg _ v1 v2 v3 :< xs) =
let p1 = pt .+^ v1 in p1 : step (p1 .+^ (v2 ^+^ v3)) (viewl xs)
pathAllPoints :: Num u => AbsPath u -> [Point2 u]
pathAllPoints (AbsPath _ sp segs _) = sp : step sp (viewl segs)
where
step _ EmptyL = []
step pt (AbsLineSeg _ v1 :< xs) =
let p1 = pt .+^ v1 in p1 : step p1 (viewl xs)
step pt (AbsCurveSeg _ v1 v2 v3 :< xs) =
let p1 = pt .+^ v1
p2 = p1 .+^ v2
p3 = p2 .+^ v3
in p1 : p2 : p3 : step p3 (viewl xs)
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)