module Wumpus.Drawing.Paths.Base.AbsPath
(
AbsPath
, DAbsPath
, empty
, line1
, curve1
, vertexPath
, curvePath
, controlCurve
, null
, length
, append
, consLineTo
, snocLineTo
, consCurveTo
, snocCurveTo
, pathconcat
, toPrimPath
, drawOpenPath
, drawOpenPath_
, drawClosedPath
, drawClosedPath_
, shortenPath
, shortenL
, shortenR
, tipL
, tipR
, directionL
, directionR
, midway
, midway_
, atstart
, atstart_
, atend
, atend_
, PathViewL(..)
, DPathViewL
, PathViewR(..)
, DPathViewR
, PathSegment(..)
, DPathSegment
, pathViewL
, pathViewR
, optimizeLines
, roundTrail
, roundInterior
) where
import Wumpus.Basic.Geometry.Base
import Wumpus.Basic.Kernel
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.List ( foldl' )
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
{ _abs_line_length :: u
, _abs_line_start :: Point2 u
, _abs_line_end :: Point2 u
}
| AbsCurveSeg
{ _abs_curve_length :: u
, _abs_curve_start :: Point2 u
, _abs_ctrl_pt_one :: Point2 u
, _abs_ctrl_pt_two :: Point2 u
, _abs_curve_end :: Point2 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 p0 p1) =
AbsLineSeg (f u) (fmap f p0) (fmap f p1)
fmap f (AbsCurveSeg u p0 p1 p2 p3) =
AbsCurveSeg (f u) (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3)
empty :: Floating u => Point2 u -> AbsPath u
empty = zeroPath
line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u
line1 p0 p1 = AbsPath v p0 (JL.one $ AbsLineSeg v p0 p1) p1
where
v = vlength $ 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 v p0 (JL.one $ AbsCurveSeg v p0 p1 p2 p3) p3
where
v = 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) b xs
where
step acc _ [] = acc
step acc e (y:ys) = step (acc `append` line1 e y) 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) d xs
where
step acc p0 (x:y:z:zs) = step (acc `append` curve1 p0 x y z) 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
null :: AbsPath u -> Bool
null = JL.null . _abs_path_elements
length :: Num u => AbsPath u -> u
length (AbsPath u _ _ _) = u
infixr 1 `append`
append :: (Floating u, Ord u, Tolerance u)
=> AbsPath u -> AbsPath u -> AbsPath u
append (AbsPath len1 start1 se1 end1) (AbsPath len2 start2 se2 end2)
| end1 == start2 = AbsPath (len1+len2) start1 (se1 `join` se2) end2
| otherwise = AbsPath total_len start1 segs end2
where
joint = lineSegment end1 start2
total_len = len1 + len2 + segmentLength joint
segs = se1 `join` (cons joint se2)
consLineTo :: Floating u => Point2 u -> AbsPath u -> AbsPath u
consLineTo p0 (AbsPath len1 sp se1 ep) = AbsPath (v+len1) p0 (cons s1 se1) ep
where
s1@(AbsLineSeg v _ _) = lineSegment p0 sp
snocLineTo :: Floating u => AbsPath u -> Point2 u -> AbsPath u
snocLineTo (AbsPath len1 sp se1 ep) p1 = AbsPath (len1+v) sp (snoc se1 s1) p1
where
s1@(AbsLineSeg v _ _) = lineSegment ep p1
consCurveTo :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> Point2 u -> Point2 u -> AbsPath u -> AbsPath u
consCurveTo p0 p1 p2 (AbsPath len1 sp se1 ep) =
AbsPath (v+len1) p0 (cons s1 se1) ep
where
s1@(AbsCurveSeg v _ _ _ _) = curveSegment p0 p1 p2 sp
snocCurveTo :: (Floating u, Ord u, Tolerance u)
=> AbsPath u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u
snocCurveTo (AbsPath len1 sp se1 ep) p1 p2 p3 =
AbsPath (v+len1) sp (snoc se1 s1) p3
where
s1@(AbsCurveSeg v _ _ _ _) = curveSegment ep p1 p2 p3
pathconcat :: (Floating u, Ord u, Tolerance u)
=> AbsPath u -> [AbsPath u] -> AbsPath u
pathconcat p0 ps = foldl' append p0 ps
segmentLength :: AbsPathSeg u -> u
segmentLength (AbsLineSeg u _ _) = u
segmentLength (AbsCurveSeg u _ _ _ _) = u
segmentStart :: AbsPathSeg u -> Point2 u
segmentStart (AbsLineSeg _ p0 _) = p0
segmentStart (AbsCurveSeg _ p0 _ _ _) = p0
segmentEnd :: AbsPathSeg u -> Point2 u
segmentEnd (AbsLineSeg _ _ p1) = p1
segmentEnd (AbsCurveSeg _ _ _ _ p3) = p3
lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u
lineSegment p0 p1 = AbsLineSeg v p0 p1
where
v = vlength $ pvec p0 p1
curveSegment :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPathSeg u
curveSegment p0 p1 p2 p3 = AbsCurveSeg v p0 p1 p2 p3
where
v = bezierLength (BezierCurve p0 p1 p2 p3)
zeroPath :: Floating u => Point2 u -> AbsPath u
zeroPath p0 = AbsPath 0 p0 JL.empty p0
drawOpenPath :: InterpretUnit u
=> AbsPath u -> Image u (AbsPath u)
drawOpenPath rp = replaceAns rp $
liftQuery (toPrimPath rp) >>= dcOpenPath
drawOpenPath_ :: InterpretUnit u
=> AbsPath u -> Graphic u
drawOpenPath_ rp = liftQuery (toPrimPath rp) >>= dcOpenPath
drawClosedPath :: InterpretUnit u
=> DrawStyle -> AbsPath u -> Image u (AbsPath u)
drawClosedPath sty rp = replaceAns rp $
liftQuery (toPrimPath rp) >>= dcClosedPath sty
drawClosedPath_ :: InterpretUnit u
=> DrawStyle -> AbsPath u -> Graphic u
drawClosedPath_ sty rp = liftQuery (toPrimPath rp) >>= dcClosedPath sty
toPrimPath :: InterpretUnit u => AbsPath u -> Query u PrimPath
toPrimPath (AbsPath _ start segs _) =
uconvertCtxF start >>= \dstart ->
T.mapM uconvertCtxF segs >>= \dsegs ->
return $ step1 dstart (viewl dsegs)
where
step1 p0 EmptyL = emptyPrimPath p0
step1 _ (e :< se) = let (p0,a) = seg1 e
rest = step2 (viewl se)
in absPrimPath p0 (a:rest)
step2 EmptyL = []
step2 (e :< se) = seg2 e : step2 (viewl se)
seg1 (AbsLineSeg _ p0 p1) = (p0, absLineTo p1)
seg1 (AbsCurveSeg _ p0 p1 p2 p3) = (p0, absCurveTo p1 p2 p3)
seg2 (AbsLineSeg _ _ p1) = absLineTo p1
seg2 (AbsCurveSeg _ _ p1 p2 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 (AbsPath u _ segs ep)
| n >= u = line1 ep ep
| otherwise = step n (viewl segs)
where
step _ EmptyL = line1 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
sp = segmentStart e1
in AbsPath (un) sp (e1 `cons` se) ep
makeLeftPath :: Floating u
=> u -> JoinList (AbsPathSeg u) -> Point2 u -> AbsPath u
makeLeftPath u se ep =
case viewl se of
EmptyL -> line1 ep ep
(e :< _) -> AbsPath u (segmentStart e) se ep
shortenSegL :: (Real u, Floating u)
=> u -> AbsPathSeg u -> AbsPathSeg u
shortenSegL n (AbsLineSeg u p0 p1) =
AbsLineSeg (un) (shortenLineL n p0 p1) p1
shortenSegL n (AbsCurveSeg u p0 p1 p2 p3) =
AbsCurveSeg (un) q0 q1 q2 q3
where
(BezierCurve q0 q1 q2 q3) = snd $ subdividet (n/u)
(BezierCurve 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 -> AbsPath u -> AbsPath u
shortenR n (AbsPath u sp segs _)
| n >= u = line1 sp sp
| otherwise = step n (viewr segs)
where
step _ EmptyR = line1 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
ep = segmentEnd e1
in AbsPath (un) sp (se `snoc` e1) ep
makeRightPath :: Floating u
=> u -> Point2 u -> JoinList (AbsPathSeg u) -> AbsPath u
makeRightPath u sp se =
case viewr se of
EmptyR -> line1 sp sp
(_ :> e) -> AbsPath u sp se (segmentEnd e)
shortenSegR :: (Real u, Floating u)
=> u -> AbsPathSeg u -> AbsPathSeg u
shortenSegR n (AbsLineSeg u p0 p1) =
AbsLineSeg (un) p0 (shortenLineR n p0 p1)
shortenSegR n (AbsCurveSeg u p0 p1 p2 p3) = AbsCurveSeg (un) q0 q1 q2 q3
where
(BezierCurve q0 q1 q2 q3) = fst $ subdividet ((un)/u)
(BezierCurve 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
tipL :: AbsPath u -> Point2 u
tipL (AbsPath _ sp _ _) = sp
tipR :: AbsPath u -> Point2 u
tipR (AbsPath _ _ _ ep) = ep
directionL :: (Real u, Floating u) => AbsPath u -> Radian
directionL (AbsPath _ _ se _) = step $ viewl se
where
step (AbsLineSeg _ p0 p1 :< _) = lineDirection p1 p0
step (AbsCurveSeg _ p0 p1 _ _ :< _) = lineDirection p1 p0
step _ = 0
directionR :: (Real u, Floating u) => AbsPath u -> Radian
directionR (AbsPath _ _ se _) = step $ viewr se
where
step (_ :> AbsLineSeg _ p0 p1) = lineDirection p0 p1
step (_ :> AbsCurveSeg _ _ _ p2 p3) = lineDirection p2 p3
step _ = 0
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)
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
infixr 5 :<<
infixl 5 :>>
data PathViewL u = PathOneL (PathSegment u)
| PathSegment u :<< AbsPath u
deriving (Eq,Show)
type DPathViewL = PathViewL Double
data PathViewR u = PathOneR (PathSegment u)
| AbsPath u :>> PathSegment u
deriving (Eq,Show)
type DPathViewR = PathViewR Double
data PathSegment u = LineSeg (Point2 u) (Point2 u)
| CurveSeg (Point2 u) (Point2 u) (Point2 u) (Point2 u)
deriving (Eq,Show)
type DPathSegment = PathSegment Double
instance Functor PathSegment where
fmap f (LineSeg p0 p1) = LineSeg (fmap f p0) (fmap f p1)
fmap f (CurveSeg p0 p1 p2 p3) =
CurveSeg (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3)
instance Functor PathViewL where
fmap f (PathOneL a) = PathOneL (fmap f a)
fmap f (a :<< as) = fmap f a :<< fmap f as
instance Functor PathViewR where
fmap f (PathOneR a) = PathOneR (fmap f a)
fmap f (as :>> a) = fmap f as :>> fmap f a
pathViewL :: Num u => AbsPath u -> PathViewL u
pathViewL (AbsPath u _ segs ep) = go (viewl segs)
where
go EmptyL = error "pathViewL - (not) unreachable."
go (AbsLineSeg v p0 p1 :< se)
| JL.null se = PathOneL (LineSeg p0 p1)
| otherwise = LineSeg p0 p1 :<< AbsPath (uv) p1 se ep
go (AbsCurveSeg v p0 p1 p2 p3 :< se)
| JL.null se = PathOneL (CurveSeg p0 p1 p2 p3)
| otherwise = CurveSeg p0 p1 p2 p3 :<< AbsPath (uv) p3 se ep
pathViewR :: Num u => AbsPath u -> PathViewR u
pathViewR (AbsPath u _ segs ep) = go (viewr segs)
where
go EmptyR = error "pathViewR - (not) unreachable."
go (se :> AbsLineSeg v p0 p1)
| JL.null se = PathOneR (LineSeg p0 p1)
| otherwise = AbsPath (uv) p1 se ep :>> LineSeg p0 p1
go (se :> AbsCurveSeg v p0 p1 p2 p3)
| JL.null se = PathOneR (CurveSeg p0 p1 p2 p3)
| otherwise = AbsPath (uv) p3 se ep :>> CurveSeg p0 p1 p2 p3
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 _ p0 p1 :< se) =
inner acc (vdirection $ pvec p0 p1) p0 p1 (viewl se)
outer acc (AbsCurveSeg _ _ p1 p2 p3 :< se) =
outer (snocCurveTo acc p1 p2 p3) (viewl se)
outer acc EmptyL = acc
inner acc d1 sp ep (AbsLineSeg _ p0 p1 :< se) =
let d2 = vdirection $ pvec p0 p1 in
if (d1 == d2)
then inner acc d1 sp p1 (viewl se)
else inner (acc `snocLineTo` ep) d2 ep p1 (viewl se)
inner acc _ _ ep (AbsCurveSeg _ _ p1 p2 p3 :< se) =
let acc1 = snocCurveTo (snocLineTo acc ep) p1 p2 p3
in outer acc1 (viewl se)
inner acc _ _ ep EmptyL = acc `snocLineTo` ep
cornerCurve :: (Real u, Floating u, Tolerance u)
=> Point2 u -> Point2 u -> Point2 u -> AbsPath u
cornerCurve p1 p2 p3 = curve1 p1 cp1 cp2 p3
where
len1 = 0.6 * (vlength $ pvec p1 p2)
len2 = 0.6 * (vlength $ pvec p3 p2)
cp1 = p1 .+^ (avec (lineAngle p1 p2) len1)
cp2 = p3 .+^ (avec (lineAngle p3 p2) len2)
roundTrail :: (Real u, Floating u, Tolerance u)
=> u -> [Point2 u] -> AbsPath u
roundTrail _ [] = error "roundTrail - empty list."
roundTrail _ [a] = zeroPath a
roundTrail _ [a,b] = line1 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, Tolerance u)
=> u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u
lineCurveTrail u a b c = line1 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, Tolerance u)
=> u -> [Point2 u] -> AbsPath u
roundInterior _ [] = error "roundEveryInterior - empty list."
roundInterior _ [a] = zeroPath a
roundInterior _ [a,b] = line1 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` line1 n o
step acc _ = acc
lineCurveInter1 :: (Real u, Floating u, Tolerance u)
=> u -> Point2 u -> Point2 u -> Point2 u
-> (AbsPath u, Point2 u)
lineCurveInter1 u a b c =
(line1 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)