module Wumpus.Drawing.Paths.Connectors
(
ConnectorPath
, DConnectorPath
, sconnect
, connLine
, connRightVH
, connRightHV
, connRightVHV
, connRightHVH
, connIsosceles
, connIsosceles2
, connLightningBolt
, connIsoscelesCurve
, connSquareCurve
, connUSquareCurve
, connTrapezoidCurve
, connZSquareCurve
, connUZSquareCurve
) where
import Wumpus.Drawing.Paths.Base
import Wumpus.Drawing.Paths.ControlPoints
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
import Prelude hiding ( length )
type ConnectorPath u = ConnectorCF u (Path u)
type DConnectorPath = ConnectorPath Double
sconnect :: Num u
=> ConnectorPath u -> Point2 u -> Point2 u -> Image u (Path u)
sconnect mf p0 p1 =
connect mf p0 p1 >>= \cpath ->
intoImage (pure cpath) (openStroke $ toPrimPath cpath)
roundCornerPath :: (Real u, Floating u, FromPtSize u)
=> [Point2 u] -> CF (Path u)
roundCornerPath xs = getRoundCornerSize >>= \sz ->
if sz == 0 then return (traceLinePoints xs)
else return (roundInterior sz xs)
connLine :: Floating u => ConnectorPath u
connLine = promoteR2 $ \p0 p1 -> pure $ line p0 p1
connRightVH :: (Real u, Floating u, FromPtSize u) => ConnectorPath u
connRightVH = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->
let mid = P2 x0 y1 in roundCornerPath [p0, mid, p1]
connRightHV :: (Real u, Floating u, FromPtSize u)
=> ConnectorPath u
connRightHV = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 x1 _) ->
let mid = P2 x1 y0 in roundCornerPath [p0, mid, p1]
connRightVHV :: (Real u, Floating u, FromPtSize u)
=> u -> ConnectorPath u
connRightVHV v = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 x1 _) ->
let a0 = p0 .+^ vvec v
a1 = a0 .+^ hvec (x1 x0)
in roundCornerPath [p0, a0, a1, p1]
connRightHVH :: (Real u, Floating u, FromPtSize u)
=> u -> ConnectorPath u
connRightHVH h = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 _ y1) ->
let a0 = p0 .+^ hvec h
a1 = a0 .+^ vvec (y1 y0)
in roundCornerPath [p0,a0,a1,p1]
connIsosceles :: (Real u, Floating u, FromPtSize u)
=> u -> ConnectorPath u
connIsosceles dy = promoteR2 $ \ p0 p1 ->
let mid_pt = midpointIsosceles dy p0 p1
in roundCornerPath [p0, mid_pt, p1]
connIsosceles2 :: (Real u, Floating u, FromPtSize u)
=> u -> ConnectorPath u
connIsosceles2 u = promoteR2 $ \ p0 p1 ->
let (cp0,cp1) = dblpointIsosceles u p0 p1
in roundCornerPath [ p0, cp0, cp1, p1 ]
connLightningBolt :: (Real u, Floating u, FromPtSize u)
=> u -> ConnectorPath u
connLightningBolt u = promoteR2 $ \ p0 p1 ->
let cp0 = midpointIsosceles u p0 p1
cp1 = midpointIsosceles (u) p0 p1
in roundCornerPath [ p0, cp0, cp1, p1 ]
connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u
connIsoscelesCurve u = promoteR2 $ \ p0 p1 ->
let control_pt = midpointIsosceles u p0 p1
in pure $ traceCurvePoints [p0, control_pt, control_pt, p1]
connSquareCurve :: (Real u, Floating u) => ConnectorPath u
connSquareCurve = promoteR2 $ \ p0 p1 ->
let (cp0,cp1) = squareFromBasePoints p0 p1
in pure $ traceCurvePoints [p0, cp0, cp1, p1]
connUSquareCurve :: (Real u, Floating u) => ConnectorPath u
connUSquareCurve = promoteR2 $ \ p0 p1 ->
let (cp0,cp1) = usquareFromBasePoints p0 p1
in pure $ traceCurvePoints [p0, cp0, cp1, p1]
connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u
connTrapezoidCurve u ratio_to_base = promoteR2 $ \p0 p1 ->
let (cp0,cp1) = trapezoidFromBasePoints u ratio_to_base p0 p1
in pure $ traceCurvePoints [p0, cp0, cp1, p1]
connZSquareCurve :: (Real u, Floating u) => ConnectorPath u
connZSquareCurve = promoteR2 $ \p0 p1 ->
let (cp0,cp1) = squareFromCornerPoints p0 p1
in pure $ traceCurvePoints [p0,cp0,cp1,p1]
connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u
connUZSquareCurve = promoteR2 $ \ p0 p1 ->
let (cp0,cp1) = squareFromCornerPoints p0 p1
in pure $ traceCurvePoints [p0,cp1,cp0,p1]