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 => PathF u
connectS = \p0 p1 -> execPath p0 $ lineto p1
pathGraphic :: Num u => Path u -> DrawingAttr -> Graphic u
pathGraphic bpath attr =
wrapG $ ostroke (stroke_colour attr) (stroke_props attr) $ toPrimPathU bpath
shorten :: (Real u, Floating u, Ord u) => u -> Path u -> Path u
shorten u p = shortenL u $ shortenR u p
shortenL :: (Real u, Floating u, Ord u) => u -> Path u -> Path u
shortenL n (Path 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 -> Path (un) se
_ -> Path (un) (shortenSegL d e <| se)
shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
shortenSegL n (LineSeg u l) = LineSeg (un) (shortenLineL n l)
shortenSegL n (CurveSeg u c) = CurveSeg (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 -> Path u -> Path u
shortenR n (Path 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 -> Path (un) se
_ -> Path (un) (se |> shortenSegR d e)
shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
shortenSegR n (LineSeg u l) = LineSeg (un) (shortenLineR n l)
shortenSegR n (CurveSeg u c) = CurveSeg (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) => Path u -> Point2 u
midpoint (Path 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) => Path u -> Radian
directionL (Path _ se) = step $ viewl se
where
step (LineSeg _ l :< _) = lineDirectionL l
step (CurveSeg _ c :< _) = curveDirectionL c
step _ = 0
directionR :: (Real u, Floating u) => Path u -> Radian
directionR (Path _ se) = step $ viewr se
where
step (_ :> LineSeg _ l) = lineDirectionR l
step (_ :> CurveSeg _ 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