module Wumpus.Basic.Paths
(
connectS
, pathGraphic
, shorten
, shortenL
, shortenR
, midpoint
, directionL
, directionR
) where
import Wumpus.Basic.Graphic
import Wumpus.Basic.Graphic.DrawingAttr
import Wumpus.Basic.Paths.Base
import Wumpus.Basic.Paths.Construction
import Wumpus.Core
import Data.AffineSpace
import Data.Sequence
connectS :: Floating u => BPathF u
connectS = \p0 p1 -> execPath p0 $ lineto p1
pathGraphic :: Num u => BPath u -> DrawingAttr -> Graphic u
pathGraphic bpath attr = wrapG $ ostroke (strokeAttr attr) $ toPathU bpath
shorten :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u
shorten u p = shortenL u $ shortenR u p
shortenL :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u
shortenL n (BPath u bp) | n >= u = emptyPath
| otherwise = step n (viewl bp)
where
step _ EmptyL = emptyPath
step d (e :< se) = let z = segmentLength e in
case compare d z of
GT -> step (dz) (viewl se)
EQ -> BPath (un) se
_ -> BPath (un) (shortenSegL d e <| se)
shortenSegL :: (Real u, Floating u) => u -> BPathSeg u -> BPathSeg u
shortenSegL n (BLineSeg u l) = BLineSeg (un) (shortenLineL n l)
shortenSegL n (BCurveSeg u c) = BCurveSeg (un) (snd $ subdividet (n/u) c)
shortenLineL :: (Real u, Floating u) => u -> Line u -> Line u
shortenLineL n (Line p1 p2) = Line (p1 .+^ v) p2
where
v0 = p2 .-. p1
v = avec (direction v0) n
shortenR :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u
shortenR n (BPath u bp) | n >= u = emptyPath
| otherwise = step n (viewr bp)
where
step _ EmptyR = emptyPath
step d (se :> e) = let z = segmentLength e in
case compare d z of
GT -> step (dz) (viewr se)
EQ -> BPath (un) se
_ -> BPath (un) (se |> shortenSegR d e)
shortenSegR :: (Real u, Floating u) => u -> BPathSeg u -> BPathSeg u
shortenSegR n (BLineSeg u l) = BLineSeg (un) (shortenLineR n l)
shortenSegR n (BCurveSeg u c) = BCurveSeg (un) (fst $ subdividet ((un)/u) c)
shortenLineR :: (Real u, Floating u) => u -> Line u -> Line u
shortenLineR n (Line p1 p2) = Line p1 (p2 .+^ v)
where
v0 = p1 .-. p2
v = avec (direction v0) n
midpoint :: (Real u, Floating u) => BPath u -> Point2 u
midpoint (BPath u bp) = step (u/2) (viewl bp)
where
step _ EmptyL = zeroPt
step d (e :< se) = let z = segmentLength e in
case compare d z of
GT -> step (dz) (viewl se)
EQ -> segmentEnd e
_ -> segmentEnd $ shortenSegL d e
directionL :: (Real u, Floating u) => BPath u -> Radian
directionL (BPath _ se) = step $ viewl se
where
step (BLineSeg _ l :< _) = lineDirectionL l
step (BCurveSeg _ c :< _) = curveDirectionL c
step _ = 0
directionR :: (Real u, Floating u) => BPath u -> Radian
directionR (BPath _ se) = step $ viewr se
where
step (_ :> BLineSeg _ l) = lineDirectionR l
step (_ :> BCurveSeg _ c) = curveDirectionR c
step _ = 0
lineDirectionL :: (Real u, Floating u) => Line u -> Radian
lineDirectionL (Line p0 p1) = direction (pvec p1 p0)
lineDirectionR :: (Real u, Floating u) => Line u -> Radian
lineDirectionR (Line p0 p1) = direction (pvec p0 p1)
curveDirectionL :: (Real u, Floating u) => Curve u -> Radian
curveDirectionL (Curve p0 p1 _ _) = direction $ pvec p1 p0
curveDirectionR :: (Real u, Floating u) => Curve u -> Radian
curveDirectionR (Curve _ _ p2 p3) = direction $ pvec p2 p3