module Wumpus.Drawing.Paths.Base
(
Path
, DPath
, length
, append
, pconcat
, line
, curve
, pivot
, traceLinePoints
, traceCurvePoints
, curveByAngles
, toPrimPath
, tipL
, tipR
, shortenPath
, shortenL
, shortenR
, directionL
, directionR
, midway
, midway_
, atstart
, atstart_
, atend
, atend_
, PathViewL(..)
, DPathViewL
, PathViewR(..)
, DPathViewR
, PathSegment(..)
, DPathSegment
, pathViewL
, pathViewR
, roundTrail
, roundInterior
) where
import Wumpus.Drawing.Geometry.Intersection ( langle )
import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl
, ViewR(..), viewr, cons, snoc, join )
import qualified Wumpus.Basic.Utils.JoinList as JL
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Data.List ( foldl' )
import Prelude hiding ( length )
data Path u = Path { _path_length :: u
, _path_start :: Point2 u
, _path_elements :: JoinList (PathSeg u)
, _path_end :: Point2 u
}
deriving (Eq,Show)
type DPath = Path Double
data PathSeg u = LineSeg { _line_length :: u
, _line_start :: Point2 u
, _line_end :: Point2 u
}
| CurveSeg { _curve_length :: u
, _curve_start :: Point2 u
, _ctrl_pt_one :: Point2 u
, _ctrl_pt_two :: Point2 u
, _curve_end :: Point2 u
}
deriving (Eq,Show)
type instance DUnit (Path u) = u
type instance DUnit (PathSeg u) = u
infixr 1 `append`
length :: Num u => Path u -> u
length (Path u _ _ _) = u
append :: Floating u => Path u -> Path u -> Path u
append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2)
| end1 == start2 = Path (len1+len2) start1 (se1 `join` se2) end2
| otherwise = let joint = lineSegment end1 start2
total_len = len1 + len2 + segmentLength joint
in Path total_len start1 (se1 `join` (cons joint se2)) end2
pconcat :: Floating u => Path u -> [Path u] -> Path u
pconcat p0 ps = foldl' append p0 ps
segmentLength :: PathSeg u -> u
segmentLength (LineSeg u _ _) = u
segmentLength (CurveSeg u _ _ _ _) = u
segmentStart :: PathSeg u -> Point2 u
segmentStart (LineSeg _ p0 _) = p0
segmentStart (CurveSeg _ p0 _ _ _) = p0
segmentEnd :: PathSeg u -> Point2 u
segmentEnd (LineSeg _ _ p1) = p1
segmentEnd (CurveSeg _ _ _ _ p3) = p3
lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u
lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1
pathZero :: Floating u => Point2 u -> Path u
pathZero p0 = Path 0 p0 JL.empty p0
line :: Floating u => Point2 u -> Point2 u -> Path u
line p0 p1 = let v = vlength $ pvec p0 p1
in Path v p0 (JL.one $ LineSeg v p0 p1) p1
curve :: (Floating u, Ord u)
=> Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u
curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3
in Path v p0 (JL.one $ CurveSeg v p0 p1 p2 p3) p3
pivot :: Floating u => Point2 u -> Path u
pivot p0 = Path 0 p0 (JL.one $ LineSeg 0 p0 p0) p0
traceLinePoints :: Floating u => [Point2 u] -> Path u
traceLinePoints [] = error "traceLinePoints - empty point list."
traceLinePoints [a] = line a a
traceLinePoints (a:b:xs) = step (line a b) b xs
where
step acc _ [] = acc
step acc e (y:ys) = step (acc `append` line e y) y ys
traceCurvePoints :: (Floating u, Ord u) => [Point2 u] -> Path u
traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs
where
step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs
step acc _ _ = acc
traceCurvePoints _ = error "tracePointsCurve - less than 4 elems."
curveByAngles :: (Floating u, Ord u)
=> Point2 u -> Radian -> Radian -> Point2 u -> Path u
curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end
where
sz = 0.375 * (vlength $ pvec start end)
v1 = avec cin sz
v2 = avec cout sz
toPrimPath :: Num u => Path u -> PrimPath u
toPrimPath (Path _ start segs _) = step1 $ viewl segs
where
step1 EmptyL = emptyPath start
step1 (e :< se) = let (p0,a) = seg1 e in
primPath p0 $ a : step2 (viewl se)
step2 EmptyL = []
step2 (e :< se) = seg2 e : step2 (viewl se)
seg1 (LineSeg _ p0 p1) = (p0, lineTo p1)
seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3)
seg2 (LineSeg _ _ p1) = lineTo p1
seg2 (CurveSeg _ _ p1 p2 p3) = curveTo p1 p2 p3
data StrictCurve u = Curve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)
curveLength :: (Floating u, Ord u)
=> Point2 u -> Point2 u -> Point2 u -> Point2 u -> u
curveLength p0 p1 p2 p3 = gravesenLength 0.1 $ Curve p0 p1 p2 p3
gravesenLength :: (Floating u, Ord u) => u -> StrictCurve u -> u
gravesenLength err_tol crv = step crv where
step c = let l1 = ctrlPolyLength c
l0 = cordLength c
in if l1l0 > err_tol
then let (a,b) = subdivide c in step a + step b
else 0.5*l0 + 0.5*l1
ctrlPolyLength :: Floating u => StrictCurve u -> u
ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3
where
len pa pb = vlength $ pvec pa pb
cordLength :: Floating u => StrictCurve u -> u
cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3
pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0
subdivide :: Fractional u
=> StrictCurve u -> (StrictCurve u, StrictCurve u)
subdivide (Curve p0 p1 p2 p3) =
(Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)
where
p01 = pointMidpoint p0 p1
p12 = pointMidpoint p1 p2
p23 = pointMidpoint p2 p3
p012 = pointMidpoint p01 p12
p123 = pointMidpoint p12 p23
p0123 = pointMidpoint p012 p123
subdividet :: Real u
=> u -> StrictCurve u -> (StrictCurve u, StrictCurve u)
subdividet t (Curve p0 p1 p2 p3) =
(Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)
where
p01 = affineCombination t p0 p1
p12 = affineCombination t p1 p2
p23 = affineCombination t p2 p3
p012 = affineCombination t p01 p12
p123 = affineCombination t p12 p23
p0123 = affineCombination t p012 p123
affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u
affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1)
tipL :: Path u -> Point2 u
tipL (Path _ sp _ _) = sp
tipR :: Path u -> Point2 u
tipR (Path _ _ _ ep) = ep
shortenPath :: (Real u , Floating u) => u -> u -> Path u -> Path u
shortenPath l r = shortenL l . shortenR r
shortenL :: (Real u, Floating u) => u -> Path u -> Path u
shortenL n (Path u _ segs ep)
| n >= u = line ep ep
| otherwise = step n (viewl segs)
where
step _ EmptyL = line ep ep
step d (e :< se) = let z = segmentLength e in
case compare d z of
GT -> step (dz) (viewl se)
EQ -> makeLeftPath (un) se ep
LT -> let e1 = shortenSegL d e
in Path (un) (segmentStart e1) (e1 `cons` se) ep
makeLeftPath :: Floating u => u -> JoinList (PathSeg u) -> Point2 u -> Path u
makeLeftPath u se ep =
case viewl se of
EmptyL -> line ep ep
(e :< _) -> Path u (segmentStart e) se ep
shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
shortenSegL n (LineSeg u p0 p1) =
LineSeg (un) (shortenLineL n p0 p1) p1
shortenSegL n (CurveSeg u p0 p1 p2 p3) =
let (Curve p0' p1' p2' p3') = snd $ subdividet (n/u) (Curve p0 p1 p2 p3)
in CurveSeg (un) p0' p1' p2' p3'
shortenLineL :: (Real u, Floating u)
=> u -> Point2 u -> Point2 u -> Point2 u
shortenLineL n p0 p1 = p0 .+^ v
where
v0 = p1 .-. p0
v = avec (vdirection v0) n
shortenR :: (Real u, Floating u) => u -> Path u -> Path u
shortenR n (Path u sp segs _)
| n >= u = line sp sp
| otherwise = step n (viewr segs)
where
step _ EmptyR = line sp sp
step d (se :> e) = let z = segmentLength e in
case compare d z of
GT -> step (dz) (viewr se)
EQ -> makeRightPath n sp se
LT -> let e1 = shortenSegR d e
in Path (un) sp (se `snoc` e1) (segmentEnd e1)
makeRightPath :: Floating u => u -> Point2 u -> JoinList (PathSeg u) -> Path u
makeRightPath u sp se =
case viewr se of
EmptyR -> line sp sp
(_ :> e) -> Path u sp se (segmentEnd e)
shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
shortenSegR n (LineSeg u p0 p1) =
LineSeg (un) p0 (shortenLineR n p0 p1)
shortenSegR n (CurveSeg u p0 p1 p2 p3) =
let (Curve p0' p1' p2' p3') = fst $ subdividet ((un)/u) (Curve p0 p1 p2 p3)
in CurveSeg (un) p0' p1' p2' p3'
shortenLineR :: (Real u, Floating u)
=> u -> Point2 u -> Point2 u -> Point2 u
shortenLineR n p0 p1 = p1 .+^ v
where
v0 = p0 .-. p1
v = avec (vdirection v0) n
directionL :: (Real u, Floating u) => Path u -> Radian
directionL (Path _ _ se _) = step $ viewl se
where
step (LineSeg _ p0 p1 :< _) = lineDirection p1 p0
step (CurveSeg _ p0 p1 _ _ :< _) = lineDirection p1 p0
step _ = 0
directionR :: (Real u, Floating u) => Path u -> Radian
directionR (Path _ _ se _) = step $ viewr se
where
step (_ :> LineSeg _ p0 p1) = lineDirection p0 p1
step (_ :> CurveSeg _ _ _ p2 p3) = lineDirection p2 p3
step _ = 0
midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian)
midway pa@(Path u sp _ _)
| u == 0 = (sp,0)
| otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1)
midway_ :: (Real u, Floating u) => Path u -> Point2 u
midway_ = fst . midway
atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian)
atstart pa@(Path _ sp _ _) = (sp, directionL pa)
atstart_ :: Path u -> Point2 u
atstart_ (Path _ sp _ _) = sp
atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian)
atend pa@(Path _ _ _ ep) = (ep, directionR pa)
atend_ :: Path u -> Point2 u
atend_ (Path _ _ _ ep) = ep
data PathViewL u = PathOneL (PathSegment u)
| PathSegment u :<< Path u
deriving (Eq,Show)
type DPathViewL = PathViewL Double
data PathViewR u = PathOneR (PathSegment u)
| Path u :>> PathSegment u
deriving (Eq,Show)
type DPathViewR = PathViewR Double
data PathSegment u = Line1 (Point2 u) (Point2 u)
| Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u)
deriving (Eq,Show)
type DPathSegment = PathSegment Double
type instance DUnit (PathViewL u) = u
type instance DUnit (PathViewR u) = u
type instance DUnit (PathSegment u) = u
pathViewL :: Num u => Path u -> PathViewL u
pathViewL (Path u _ segs ep) = go (viewl segs)
where
go EmptyL = error "pathViewL - (not) unreachable."
go (LineSeg v p0 p1 :< se)
| JL.null se = PathOneL (Line1 p0 p1)
| otherwise = Line1 p0 p1 :<< Path (uv) p1 se ep
go (CurveSeg v p0 p1 p2 p3 :< se)
| JL.null se = PathOneL (Curve1 p0 p1 p2 p3)
| otherwise = Curve1 p0 p1 p2 p3 :<< Path (uv) p3 se ep
pathViewR :: Num u => Path u -> PathViewR u
pathViewR (Path u _ segs ep) = go (viewr segs)
where
go EmptyR = error "pathViewR - (not) unreachable."
go (se :> LineSeg v p0 p1)
| JL.null se = PathOneR (Line1 p0 p1)
| otherwise = Path (uv) p1 se ep :>> Line1 p0 p1
go (se :> CurveSeg v p0 p1 p2 p3)
| JL.null se = PathOneR (Curve1 p0 p1 p2 p3)
| otherwise = Path (uv) p3 se ep :>> Curve1 p0 p1 p2 p3
cornerCurve :: (Real u, Floating u)
=> Point2 u -> Point2 u -> Point2 u -> Path u
cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3
where
len1 = 0.6 * (vlength $ pvec p1 p2)
len2 = 0.6 * (vlength $ pvec p3 p2)
cp1 = p1 .+^ (avec (langle p1 p2) len1)
cp2 = p3 .+^ (avec (langle p3 p2) len2)
roundTrail :: (Real u, Floating u)
=> u -> [Point2 u] -> Path u
roundTrail _ [] = error "roundTrail - empty list."
roundTrail _ [a] = pathZero a
roundTrail _ [a,b] = line a b
roundTrail u (start:b:c:xs) = step (lineCurveTrail u start b c) (b:c:xs)
where
step acc (m:n:o:ps) = step (acc `append` lineCurveTrail u m n o) (n:o:ps)
step acc [n,o] = acc `append` lineCurveTrail u n o start
`append` lineCurveTrail u o start b
step acc _ = acc
lineCurveTrail :: (Real u, Floating u)
=> u -> Point2 u -> Point2 u -> Point2 u -> Path u
lineCurveTrail u a b c = line p1 p2 `append` cornerCurve p2 b p3
where
p1 = a .+^ (avec (vdirection $ pvec a b) u)
p2 = b .+^ (avec (vdirection $ pvec b a) u)
p3 = b .+^ (avec (vdirection $ pvec b c) u)
roundInterior :: (Real u, Floating u)
=> u -> [Point2 u] -> Path u
roundInterior _ [] = error "roundEveryInterior - empty list."
roundInterior _ [a] = pathZero a
roundInterior _ [a,b] = line a b
roundInterior u (start:b:c:xs) = let (path1,p1) = lineCurveInter1 u start b c
in step path1 (p1:c:xs)
where
step acc (m:n:o:ps) = let (seg2,p1) = lineCurveInter1 u m n o
in step (acc `append` seg2) (p1:o:ps)
step acc [n,o] = acc `append` line n o
step acc _ = acc
lineCurveInter1 :: (Real u, Floating u)
=> u -> Point2 u -> Point2 u -> Point2 u -> (Path u, Point2 u)
lineCurveInter1 u a b c =
(line a p2 `append` cornerCurve p2 b p3, p3)
where
p2 = b .+^ (avec (vdirection $ pvec b a) u)
p3 = b .+^ (avec (vdirection $ pvec b c) u)