module Wumpus.Drawing.Connectors.ConnectorPaths
(
conn_line
, conna_arc
, connb_arc
, conn_hdiagh
, conn_vdiagv
, conn_diagh
, conn_diagv
, conn_hdiag
, conn_vdiag
, conna_bar
, connb_bar
, conna_flam
, connb_flam
, conna_orthohbar
, connb_orthohbar
, conna_orthovbar
, connb_orthovbar
, conna_right
, connb_right
, conn_hrr
, conn_rrh
, conn_vrr
, conn_rrv
, conna_loop
, connb_loop
, conn_hbezier
, conn_vbezier
) where
import Wumpus.Drawing.Basis.InclineTrails
import Wumpus.Drawing.Connectors.Base
import Wumpus.Drawing.Connectors.ConnectorProps
import Wumpus.Drawing.Paths
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
catConnector :: (Floating u, Ord u, InterpretUnit u, Tolerance u)
=> (ConnectorProps -> Point2 u -> Point2 u -> Query u (CatTrail u))
-> ConnectorPathSpec u
catConnector mf = ConnectorPathSpec $ \props ->
qpromoteConn $ \p0 p1 -> catTrailPath p0 <$> mf props p0 p1
horizontally :: (Real u, Floating u)
=> (Vec2 u -> a) -> (Vec2 u -> a) -> Vec2 u -> a
horizontally rightf leftf v1 =
case horizontalDirection $ vdirection v1 of
RIGHTWARDS -> rightf v1
LEFTWARDS -> leftf v1
conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> ConnectorPathSpec u
conn_line = catConnector $ \_ p0 p1 -> pure $ catline $ pvec p0 p1
conna_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u)
=> ConnectorPathSpec u
conna_arc = connArcBody (vtriCurve CW) (vtriCurve CCW)
connb_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u)
=> ConnectorPathSpec u
connb_arc = connArcBody (vtriCurve CCW) (vtriCurve CW)
connArcBody :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u)
=> (u -> Vec2 u -> CatTrail u)
-> (u -> Vec2 u -> CatTrail u)
-> ConnectorPathSpec u
connArcBody rightf leftf = catConnector $ \props p0 p1 ->
let arc_ang = conn_arc_ang props
v1 = pvec p0 p1
h = (0.5 * vlength v1) * (fromRadian $ tan arc_ang)
in return $ horizontally (rightf h) (leftf h) v1
conn_hdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_hdiagh = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src_leg, dst_leg) ->
return $ trail_hdiagh src_leg dst_leg $ pvec p0 p1
conn_vdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_vdiagv = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src_leg, dst_leg) ->
return $ trail_vdiagv src_leg dst_leg $ pvec p0 p1
conn_diagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_diagh = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(_, dst_leg) ->
return $ trail_diagh dst_leg $ pvec p0 p1
conn_diagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_diagv = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(_, dst_leg) ->
return $ trail_diagv dst_leg $ pvec p0 p1
conn_hdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_hdiag = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src_leg, _) ->
return $ trail_hdiag src_leg $ pvec p0 p1
conn_vdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_vdiag = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src_leg, _) ->
return $ trail_vdiag src_leg $ pvec p0 p1
conna_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conna_bar = connBarBody (trail_perp_bar2 CW) (trail_perp_bar2 CCW)
connb_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
connb_bar = connBarBody (trail_perp_bar2 CCW) (trail_perp_bar2 CW)
connBarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> (u -> u -> Vec2 u -> CatTrail u)
-> (u -> u -> Vec2 u -> CatTrail u)
-> ConnectorPathSpec u
connBarBody rightf leftf = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src, dst) ->
return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1
conna_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conna_flam = connFlamBody (trail_vflam CW) (trail_vflam CCW)
connb_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
connb_flam = connFlamBody (trail_vflam CCW) (trail_vflam CW)
connFlamBody :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> (u -> u -> Vec2 u -> CatTrail u)
-> (u -> u -> Vec2 u -> CatTrail u)
-> ConnectorPathSpec u
connFlamBody rightf leftf = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src,dst) ->
return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1
conna_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conna_orthohbar = connOrthobarBody (trail_ortho_hbar CW) (trail_ortho_hbar CCW)
connb_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
connb_orthohbar = connOrthobarBody (trail_ortho_hbar CCW) (trail_ortho_hbar CW)
connOrthobarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> (u -> Vec2 u -> CatTrail u)
-> (u -> Vec2 u -> CatTrail u)
-> ConnectorPathSpec u
connOrthobarBody rightf leftf = catConnector $ \props p0 p1 ->
connectorLoopSize props >>= \looph ->
return $ horizontally (rightf looph) (leftf looph) $ pvec p0 p1
conna_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conna_orthovbar = connOrthobarBody (trail_ortho_vbar CW) (trail_ortho_vbar CCW)
connb_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
connb_orthovbar = connOrthobarBody (trail_ortho_vbar CCW) (trail_ortho_vbar CW)
conna_right :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conna_right = catConnector $ \_ p0 p1 ->
return $ trail_vright $ pvec p0 p1
connb_right :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
connb_right = catConnector $ \_ p0 p1 ->
return $ trail_hright $ pvec p0 p1
conn_hrr :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_hrr = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src_leg,_) ->
return $ trail_hrr src_leg $ pvec p0 p1
conn_rrh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_rrh = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(_,dst_leg) ->
return $ trail_rrh dst_leg $ pvec p0 p1
conn_vrr :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_vrr = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src_leg,_) ->
return $ trail_vrr src_leg $ pvec p0 p1
conn_rrv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conn_rrv = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(_,dst_leg) ->
return $ trail_rrv dst_leg $ pvec p0 p1
conna_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
conna_loop = connLoopBody (trail_rect_loop CW) (trail_rect_loop CCW)
connb_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorPathSpec u
connb_loop = connLoopBody (trail_rect_loop CCW) (trail_rect_loop CW)
connLoopBody :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> (u -> u -> u -> Vec2 u -> CatTrail u)
-> (u -> u -> u -> Vec2 u -> CatTrail u)
-> ConnectorPathSpec u
connLoopBody rightf leftf = catConnector $ \props p0 p1 ->
connectorLegs props >>= \(src,dst) ->
connectorLoopSize props >>= \looph ->
return $ horizontally (rightf src dst looph) (leftf src dst looph)
$ pvec p0 p1
conn_hbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> ConnectorPathSpec u
conn_hbezier = ConnectorPathSpec $ \props ->
qpromoteConn $ \p0 p1 ->
fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,dst_arm) ->
case horizontalDirection $ vdirection $ pvec p0 p1 of
RIGHTWARDS -> 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
conn_vbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> ConnectorPathSpec u
conn_vbezier = ConnectorPathSpec $ \props ->
qpromoteConn $ \p0 p1 ->
fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,dst_arm) ->
case verticalDirection $ vdirection $ pvec p0 p1 of
UPWARDS -> 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