{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Connectors.ConnectorPaths -- Copyright : (c) Stephen Tetley 2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Primitive connectors -- -------------------------------------------------------------------------------- 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 -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Control.Applicative -- | Build as Path as a CatTrail between two points. -- 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 -- | Straight line connector. -- conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) => ConnectorPathSpec u conn_line = catConnector $ \_ p0 p1 -> pure $ catline $ pvec p0 p1 -- | Form an arc connector. -- -- If the conn_arc_angle in the Drawing context is positive the arc -- will be formed /above/ the straight line joining the points. -- If the angle is negative it will be drawn below. -- -- The notion of /above/ is respective to the line direction, of -- course. -- -- TODO - above and below versions... -- conna_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) => ConnectorPathSpec u conna_arc = connArcBody (vtriCurve CW) (vtriCurve CCW) -- | Below version of 'conna_arc'. -- 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 -- | Horizontal-diagonal-horizontal connector. -- -- > --@ -- > / -- > o-- -- -- Horizontal /arms/ are drawn from the start and end points, a -- diagonal segment joins the arms. -- 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 -- probably want trail_hdiagh as a library function -- | Vertical-diagonal-vertical connector. -- -- > @ -- > | -- > \ -- > | -- > o -- -- Vertical /arms/ are drawn from the start and end points, a -- diagonal segment joins the arms. -- 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 -- | Diagonal-horizontal connector. -- -- > --@ -- > / -- > o -- -- Restricted variant of 'hconndiag' - a diagonal segment is drawn -- from the start point joining a horizontal arm drawn from the -- end point -- 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 -- | Diagonal-vertical connector. -- -- > @ -- > | -- > / -- > o -- -- Restricted variant of 'vconndiag' - a diagonal segment is drawn -- from the start point joining a vertical arm drawn from the end -- point. -- 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 -- | Horizontal-diagonal connector. -- -- > @ -- > / -- > o-- -- -- Restricted variant of 'hconndiag' - a horizontal arm is drawn -- from the start point joining a diagonal segment drawn from the -- end point. -- 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 -- | Vertical-diagonal connector. -- -- > @ -- > / -- > | -- > o -- -- Restricted variant of 'vconndiag' - a horizontal arm is drawn -- from the start point joining a vertical segment drawn from the -- end point. -- 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 -- DESIGN NOTE - should the concept of /above/ and /below/ use -- ClockDirection instead? -- -- | Bar connector. -- -- > ,----, -- > | | -- > o @ -- -- The bar is drawn /above/ the points. -- conna_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) => ConnectorPathSpec u conna_bar = connBarBody (trail_perp_bar2 CW) (trail_perp_bar2 CCW) -- | Bar connector. -- -- > o @ -- > | | -- > '----' -- -- The bar is drawn /below/ the points. -- 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 -- | /Flam/ connector. -- -- > ,- ' -- > ,- | -- > | | -- > o @ -- -- The bar is drawn /above/ the points. -- conna_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) => ConnectorPathSpec u conna_flam = connFlamBody (trail_vflam CW) (trail_vflam CCW) -- | /Flam/ connector - bleow. -- 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 -- | Bar connector - always orthonormal . -- -- > -- > ,----, -- > | | -- > o @ -- -- The bar is drawn /above/ the points. -- conna_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) => ConnectorPathSpec u conna_orthohbar = connOrthobarBody (trail_ortho_hbar CW) (trail_ortho_hbar CCW) -- | Bar connector orthonormal - below. -- 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 -- | Bar connector - always orthonormal. -- -- > -- > ,--- o -- > | -- > '--- @ -- > -- -- The bar is drawn /left/ of the points. -- conna_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) => ConnectorPathSpec u conna_orthovbar = connOrthobarBody (trail_ortho_vbar CW) (trail_ortho_vbar CCW) -- | Bar connector orthonormal - right of the points. -- connb_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) => ConnectorPathSpec u connb_orthovbar = connOrthobarBody (trail_ortho_vbar CCW) (trail_ortho_vbar CW) -- | Right angle connector. -- -- > ,----@ -- > | -- > o -- -- The bar is drawn /above/ the points. -- conna_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) => ConnectorPathSpec u conna_right = catConnector $ \_ p0 p1 -> return $ trail_vright $ pvec p0 p1 -- | Right angle connector. -- -- > @ -- > | -- > o----' -- -- The bar is drawn /below/ the points. -- connb_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) => ConnectorPathSpec u connb_right = catConnector $ \_ p0 p1 -> return $ trail_hright $ pvec p0 p1 -- | Connector with two horizontal segments and a joining -- vertical segment. -- -- > ,--@ -- > | -- > o----' -- -- The length of the first horizontal segment is the source arm -- length. The length of the final segment is the remaining -- horizontal distance. -- 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 -- | Connector with two horizontal segements and a joining -- vertical segment. -- -- > ,----@ -- > | -- > o--' -- -- The length of the final horizontal segment is the destination -- arm length. The length of the initial segment is the remaining -- horizontal distance. -- 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 -- | Connector with two right angles... -- -- > @ -- > | -- > ,----' -- > | -- > o -- -- The length of the first vertical segment is the source arm -- length. The length of the final segment is the remaining -- vertical distance. -- 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 -- | Connector with two right angles... -- -- > @ -- > | -- > ,----' -- > | -- > o -- -- The length of the final vertical segment is the destination -- arm length. The length of the initial segment is the remaining -- vertical distance. -- 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 -- | Loop connector. -- -- > ,---------, -- > | | -- > '-o @--' -- -- The loop is drawn /above/ the points. -- conna_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) => ConnectorPathSpec u conna_loop = connLoopBody (trail_rect_loop CW) (trail_rect_loop CCW) -- | Loop connector. -- -- > ,-o @--, -- > | | -- > '---------' -- -- The loop is drawn /below/ the points. -- 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 -- | Bezier curve connector - the control points are positioned -- horizontally respective to the source and dest. -- -- > *--@ -- > . -- > . -- > o--* -- -- Note - the source and dest arm lengths are doubled, generally -- this produces nicer curves. -- 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 -- | Bezier curve connector - the control points are positioned -- vertically respective to the source and dest. -- -- > @ -- > .| -- > * . * -- > |. -- > o -- -- Note - the source and dest arm lengths are doubled, generally -- this produces nicer curves. -- 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