module Wumpus.Basic.Paths.Connectors
(
ConnPath
, connectS
, vhconn
, hvconn
, arbv
, arbh
, curveconn
, joint
, pathGraphic
, fillPath
, shorten
, shortenL
, shortenR
, midpoint
, directionL
, directionR
) where
import Wumpus.Basic.Graphic
import Wumpus.Basic.Paths.Base
import Wumpus.Basic.Paths.Construction
import Wumpus.Core
import Data.AffineSpace
import Data.Sequence
type ConnPath u = Point2 u -> Point2 u -> Path u
connectS :: Floating u => ConnPath u
connectS = \p1 p2 -> execPath p1 $ lineto p2
vhconn :: Floating u => ConnPath u
vhconn p1 p2 = execPath p1 $ verticalHorizontal p2
hvconn :: Floating u => ConnPath u
hvconn p1 p2 = execPath p1 $ horizontalVertical p2
arbv :: Floating u => u -> ConnPath u
arbv v p1@(P2 x1 y1) (P2 x2 y2) = execPath p1 $ vline v >> hline dx >> vline dy
where
dx = x2 x1
dy = y2 (y1+v)
arbh :: Floating u => u -> ConnPath u
arbh h p1@(P2 x1 y1) (P2 x2 y2) = execPath p1 $ hline h >> vline dy >> hline dx
where
dx = x2 (x1+h)
dy = y2 y1
curveconn :: (Floating u, Ord u) => Radian -> Radian -> ConnPath u
curveconn r1 r2 p1 p2 = execPath p1 $ curveto r1 r2 p2
joint :: (Real u, Floating u) => u -> ConnPath u
joint u p1@(P2 x1 y1) p2@(P2 x2 y2) =
execPath p1 $ lineto (mid_pt .+^ avec perp_ang u) >> lineto p2
where
mid_pt = P2 (x1 + 0.5*(x2x1)) (y1 + 0.5*(y2y1))
perp_ang = (pi*0.5) + direction (pvec p2 p1)
pathGraphic :: Num u => ConnPath u -> ConnGraphic u
pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2
fillPath :: Num u => Path u -> Graphic u
fillPath = filledPath . toPrimPathU
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 $ shortenSegR 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