module Wumpus.Drawing.Connectors.ConnectorPaths
(
connline
, connarc
, connhdiagh
, connvdiagv
, conndiagh
, conndiagv
, connhdiag
, connvdiag
, connabar
, connbbar
, connaright
, connbright
, connhrr
, connrrh
, connvrr
, connrrv
, connaloop
, connbloop
, connhbezier
, connvbezier
) where
import Wumpus.Drawing.Connectors.Base
import Wumpus.Drawing.Paths.Absolute
import Wumpus.Basic.Geometry.Quadrant
import Wumpus.Basic.Kernel hiding ( promoteConn )
import Wumpus.Core
import Data.AffineSpace
connline :: (Real u, Floating u, InterpretUnit u) => Connector u
connline = qpromoteConn $ \p0 p1 -> return $ line1 p0 p1
connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u)
=> Connector u
connarc = qpromoteConn $ \p0 p1 ->
connectorArcAngle >>= \arc_ang ->
let v1 = pvec p0 p1
hlen = 0.5 * vlength v1
ang = vdirection v1
cp0 = p0 .+^ avec (ang + arc_ang) hlen
cp1 = p1 .+^ avec (pi + ang arc_ang) hlen
in return $ curve1 p0 cp0 cp1 p1
connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connhdiagh = qpromoteConn $ \p0 p1 ->
connectorSrcArm >>= \src_arm ->
connectorDstArm >>= \dst_arm ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> right p0 p1 src_arm dst_arm
QUAD_SE -> right p0 p1 src_arm dst_arm
_ -> left p0 p1 src_arm dst_arm
where
right p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .+^ hvec h0
, p1 .-^ hvec h1, p1 ]
left p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .-^ hvec h0
, p1 .+^ hvec h1, p1 ]
connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connvdiagv = qpromoteConn $ \p0 p1 ->
connectorSrcArm >>= \src_arm ->
connectorDstArm >>= \dst_arm ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> up p0 p1 src_arm dst_arm
QUAD_NW -> up p0 p1 src_arm dst_arm
_ -> down p0 p1 src_arm dst_arm
where
up p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .+^ vvec v0
, p1 .-^ vvec v1, p1 ]
down p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .-^ vvec v0
, p1 .+^ vvec v1, p1 ]
conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
conndiagh = qpromoteConn $ \p0 p1 ->
connectorDstArm >>= \dst_arm ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> right p0 p1 dst_arm
QUAD_SE -> right p0 p1 dst_arm
_ -> left p0 p1 dst_arm
where
right p0 p1 h1 = return $ vertexPath [ p0, p1 .-^ hvec h1, p1 ]
left p0 p1 h1 = return $ vertexPath [ p0, p1 .+^ hvec h1, p1 ]
conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
conndiagv = qpromoteConn $ \p0 p1 ->
connectorDstArm >>= \dst_arm ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> up p0 p1 dst_arm
QUAD_NW -> up p0 p1 dst_arm
_ -> down p0 p1 dst_arm
where
up p0 p1 v1 = return $ vertexPath [ p0, p1 .-^ vvec v1, p1 ]
down p0 p1 v1 = return $ vertexPath [ p0, p1 .+^ vvec v1, p1 ]
connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connhdiag = qpromoteConn $ \p0 p1 ->
connectorSrcArm >>= \src_arm ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> right p0 p1 src_arm
QUAD_SE -> right p0 p1 src_arm
_ -> left p0 p1 src_arm
where
right p0 p1 h1 = return $ vertexPath [ p0, p0 .+^ hvec h1, p1 ]
left p0 p1 h1 = return $ vertexPath [ p0, p0 .-^ hvec h1, p1 ]
connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connvdiag = qpromoteConn $ \p0 p1 ->
connectorSrcArm >>= \src_arm ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> up p0 p1 src_arm
QUAD_NW -> up p0 p1 src_arm
_ -> down p0 p1 src_arm
where
up p0 p1 v1 = return $ vertexPath [ p0, p0 .+^ vvec v1, p1 ]
down p0 p1 v1 = return $ vertexPath [ p0, p0 .-^ vvec v1, p1 ]
connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connabar = qpromoteConn $ \p0 p1 ->
connectorSrcArm >>= \src_arm ->
connectorDstArm >>= \dst_arm ->
let ang = vdirection $ pvec p0 p1
in return $ vertexPath [ p0, dispDirectionTheta UP src_arm ang p0
, dispDirectionTheta UP dst_arm ang p1, p1 ]
connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connbbar = qpromoteConn $ \p0 p1 ->
connectorSrcArm >>= \src_arm ->
connectorDstArm >>= \dst_arm ->
let ang = vdirection $ pvec p0 p1
in return $ vertexPath [ p0, dispDirectionTheta DOWN src_arm ang p0
, dispDirectionTheta DOWN dst_arm ang p1, p1 ]
connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connaright = qpromoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->
let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1]
connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connbright = qpromoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) ->
let mid = P2 x1 y0 in return $ vertexPath [p0, mid, p1]
directional :: (Num u, Ord u) => u -> u -> u -> u
directional src dst arm = if src < dst then arm else negate arm
connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connhrr = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->
fmap (directional x0 x1) connectorSrcArm >>= \ src_arm ->
let a0 = p0 .+^ hvec src_arm
a1 = a0 .+^ vvec (y1 y0)
in return $ vertexPath [p0, a0, a1, p1]
connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connrrh = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->
fmap (directional x0 x1) connectorDstArm >>= \ dst_arm ->
let a1 = p1 .-^ hvec dst_arm
a0 = a1 .-^ vvec (y1 y0)
in return $ vertexPath [p0, a0, a1, p1]
connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connvrr = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->
fmap (directional y0 y1) connectorSrcArm >>= \ src_arm ->
let a0 = p0 .+^ vvec src_arm
a1 = a0 .+^ hvec (x1 x0)
in return $ vertexPath [p0, a0, a1, p1]
connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connrrv = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->
fmap (directional y0 y1) connectorDstArm >>= \ dst_arm ->
let a1 = p1 .-^ vvec dst_arm
a0 = a1 .-^ hvec (x1 x0)
in return $ vertexPath [p0, a0, a1, p1]
connaloop :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connaloop = loopbody id
connbloop :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> Connector u
connbloop = loopbody negate
loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> (u -> u) -> Connector u
loopbody fn = qpromoteConn $ \p0 p1 ->
connectorSrcArm >>= \src_arm ->
connectorDstArm >>= \dst_arm ->
connectorLoopSize >>= \loop_len ->
let ang = vdirection $ pvec p0 p1
a0 = dispParallel (negate src_arm) ang p0
a1 = dispPerpendicular (fn loop_len) ang a0
z0 = dispParallel dst_arm ang p1
z1 = dispPerpendicular (fn loop_len) ang z0
in return $ vertexPath [ p0, a0, a1, z1, z0, p1 ]
connhbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> Connector u
connhbezier = qpromoteConn $ \p0 p1 ->
fmap (2*) connectorSrcArm >>= \src_arm ->
fmap (2*) connectorDstArm >>= \dst_arm ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> right p0 p1 src_arm dst_arm
QUAD_SE -> right p0 p1 src_arm dst_arm
_ -> left p0 p1 src_arm dst_arm
where
right p0 p1 h0 h1 = return $ curve1 p0 (p0 .+^ hvec h0) (p1 .-^ hvec h1) p1
left p0 p1 h0 h1 = return $ curve1 p0 (p0 .-^ hvec h0) (p1 .+^ hvec h1) p1
connvbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> Connector u
connvbezier = qpromoteConn $ \p0 p1 ->
fmap (2*) connectorSrcArm >>= \src_arm ->
fmap (2*) connectorDstArm >>= \dst_arm ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> up p0 p1 src_arm dst_arm
QUAD_NW -> up p0 p1 src_arm dst_arm
_ -> down p0 p1 src_arm dst_arm
where
up p0 p1 v0 v1 = return $ curve1 p0 (p0 .+^ vvec v0) (p1 .-^ vvec v1) p1
down p0 p1 v0 v1 = return $ curve1 p0 (p0 .-^ vvec v0) (p1 .+^ vvec v1) p1