wumpus-drawing-0.7.0: src/Wumpus/Drawing/Connectors/ConnectorPaths.hs
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Drawing.Connectors.ConnectorPaths
-- Copyright : (c) Stephen Tetley 2011
-- License : BSD3
--
-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>
-- Stability : highly unstable
-- Portability : GHC
--
-- Primitive connectors
--
--------------------------------------------------------------------------------
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.Connectors.ConnectorProps
import Wumpus.Drawing.Paths
import Wumpus.Basic.Geometry.Quadrant -- package: wumpus-basic
import Wumpus.Basic.Kernel hiding ( promoteConn )
import Wumpus.Core -- package: wumpus-core
import Data.AffineSpace -- package: vector-space
type ProjectionQuery u =
ConnectorProps -> Point2 u -> Point2 u -> Query u (Point2 u)
inlineSrc :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
inlineSrc props p0 p1 =
connectorSrcSpace props >>= \sep ->
let ang = vdirection $ pvec p0 p1
in return $ p0 .+^ avec ang sep
inlineDst :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
inlineDst props p0 p1 =
connectorDstSpace props >>= \sep ->
let ang = vdirection $ pvec p0 p1
in return $ p1 .-^ avec ang sep
-- | Like 'inlineSrc' but /expands/ rather than /contracts/.
--
-- Use for loops.
--
extlineSrc :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
extlineSrc props p0 p1 =
connectorSrcSpace props >>= \sep ->
let ang = vdirection $ pvec p0 p1
in return $ p0 .-^ avec ang sep
-- | Like 'inlineDst' but /expands/ rather than /contracts/.
--
-- Use for loops.
--
extlineDst :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
extlineDst props p0 p1 =
connectorDstSpace props >>= \sep ->
let ang = vdirection $ pvec p0 p1
in return $ p1 .+^ avec ang sep
-- | Horizontal \"orthonormal\" version of 'inlineSrc'.
--
horizontalSrc :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
horizontalSrc props p0 p1 =
connectorSrcSpace props >>= \sep ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> return $ p0 .+^ go_right sep
QUAD_SE -> return $ p0 .+^ go_right sep
_ -> return $ p0 .+^ go_left sep
-- | Horizontal \"orthonormal\" version of 'inlineDst'.
--
horizontalDst :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
horizontalDst props p0 p1 =
connectorDstSpace props >>= \sep ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> return $ p1 .+^ go_left sep
QUAD_SE -> return $ p1 .+^ go_left sep
_ -> return $ p1 .+^ go_right sep
-- | Vertical \"orthonormal\" version of 'inlineSrc'.
--
verticalSrc :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
verticalSrc props p0 p1 =
connectorSrcSpace props >>= \sep ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> return $ p0 .+^ go_up sep
QUAD_NW -> return $ p0 .+^ go_up sep
_ -> return $ p0 .+^ go_down sep
-- | Vertical \"orthonormal\" version of 'inlineDst'.
--
verticalDst :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
verticalDst props p0 p1 =
connectorDstSpace props >>= \sep ->
case quadrant $ vdirection $ pvec p0 p1 of
QUAD_NE -> return $ p1 .+^ go_down sep
QUAD_NW -> return $ p1 .+^ go_down sep
_ -> return $ p1 .+^ go_up sep
abovePerpSrc :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
abovePerpSrc props p0 p1 =
connectorSrcSpace props >>= \sep ->
let ang = vdirection $ pvec p0 p1
in return $ p0 .+^ avec (ang + half_pi) sep
abovePerpDst :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
abovePerpDst props p0 p1 =
connectorDstSpace props >>= \sep ->
let ang = vdirection $ pvec p0 p1
in return $ p1 .+^ avec (ang + half_pi) sep
belowPerpSrc :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
belowPerpSrc props p0 p1 =
connectorSrcSpace props >>= \sep ->
let ang = vdirection $ pvec p0 p1
in return $ p0 .+^ avec (ang - half_pi) sep
belowPerpDst :: (Real u, Floating u, InterpretUnit u)
=> ProjectionQuery u
belowPerpDst props p0 p1 =
connectorDstSpace props >>= \sep ->
let ang = vdirection $ pvec p0 p1
in return $ p1 .+^ avec (ang - half_pi) sep
-- | Promote a function from source and dest points to a connector
-- function accounting for the separator values in the
-- DrawingContext.
--
buildConn :: (Real u, Floating u, InterpretUnit u)
=> ConnectorProps
-> ProjectionQuery u -> ProjectionQuery u
-> (Point2 u -> Point2 u -> Query u (AbsPath u))
-> ConnectorPathQuery u
buildConn props qsrc qdst fn = qpromoteConn $ \p0 p1 ->
qsrc props p0 p1 >>= \q0 -> qdst props p0 p1 >>= \q1 -> fn q0 q1
-- | Straight line connector.
--
connline :: (Real u, Floating u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connline props = buildConn props inlineSrc inlineDst $ \p0 p1 ->
return $ line1 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.
--
--
connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u)
=> ConnectorProps -> ConnectorPathQuery u
connarc props = buildConn props inlineSrc inlineDst $ \p0 p1 ->
let arc_ang = conn_arc_ang props
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
-- | Horizontal-diagonal-horizontal connector.
--
-- > --@
-- > /
-- > o--
--
-- Horizontal /arms/ are drawn from the start and end points, a
-- diagonal segment joins the arms.
--
connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connhdiagh props = buildConn props horizontalSrc horizontalDst $ \p0 p1 ->
connectorArms props >>= \(src_arm, 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 ]
-- | Vertical-diagonal-vertical connector.
--
-- > @
-- > |
-- > \
-- > |
-- > o
--
-- Vertical /arms/ are drawn from the start and end points, a
-- diagonal segment joins the arms.
--
connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connvdiagv props = buildConn props verticalSrc verticalDst $ \p0 p1 ->
connectorArms props >>= \(src_arm, 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 ]
-- | 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
--
conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
conndiagh props = buildConn props inlineSrc horizontalDst $ \p0 p1 ->
connectorArms props >>= \(_,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 ]
-- | 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.
--
conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
conndiagv props = buildConn props inlineSrc verticalDst $ \p0 p1 ->
connectorArms props >>= \(_,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 ]
-- | 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.
--
connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connhdiag props = buildConn props horizontalSrc inlineDst $ \p0 p1 ->
connectorArms props >>= \(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 ]
-- | 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.
--
connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connvdiag props = buildConn props verticalSrc inlineDst $ \p0 p1 ->
connectorArms props >>= \(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 ]
-- DESIGN NOTE - should the concept of /above/ and /below/ use
-- quadrants?
--
-- | Bar connector.
--
-- > ,----,
-- > | |
-- > o @
--
-- The bar is drawn /above/ the points.
--
connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connabar props = buildConn props abovePerpSrc abovePerpDst $ \p0 p1 ->
connectorArms props >>= \(src_arm,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 ]
-- | Bar connector.
--
-- > o @
-- > | |
-- > '----'
--
-- The bar is drawn /below/ the points.
--
connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connbbar props = buildConn props belowPerpSrc belowPerpDst $ \p0 p1 ->
connectorArms props >>= \(src_arm, 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 ]
-- | Right angle connector.
--
-- > ,----@
-- > |
-- > o
--
-- The bar is drawn /above/ the points.
--
connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connaright props =
buildConn props verticalSrc horizontalDst $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->
let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1]
-- | Right angle connector.
--
-- > @
-- > |
-- > o----'
--
-- The bar is drawn /below/ the points.
--
connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connbright props =
buildConn props horizontalSrc verticalDst $ \ p0@(P2 _ y0) p1@(P2 x1 _) ->
let mid = P2 x1 y0 in return $ vertexPath [p0, mid, p1]
-- Helper
-- | Derive the direction aka. sign of an arm.
--
directional :: (Num u, Ord u) => u -> u -> u -> u
directional src dst arm = if src < dst then arm else negate arm
-- | Connector with two horizontal segements 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 remaing
-- horizontal distance.
--
connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connhrr props =
buildConn props horizontalSrc horizontalDst $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->
connectorArms props >>= \(src_arm,_) ->
let a0 = p0 .+^ hvec (directional x0 x1 src_arm)
a1 = a0 .+^ vvec (y1 - y0)
in return $ vertexPath [p0, a0, a1, p1]
-- | Connector with two horizontal segements and a joining
-- vertical segment.
--
-- > ,----@
-- > |
-- > o--'
--
-- The length of the final horizontal segment is the distination
-- arm length. The length of the initial segment is the remaining
-- horizontal distance.
--
connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connrrh props =
buildConn props horizontalSrc horizontalDst $ \p0@(P2 x0 y0) p1@(P2 x1 y1) ->
connectorArms props >>= \(_,dst_arm) ->
let a1 = p1 .-^ hvec (directional x0 x1 dst_arm)
a0 = a1 .-^ vvec (y1 - y0)
in return $ vertexPath [p0, a0, a1, p1]
-- | Connector with two right angles...
--
-- > @
-- > |
-- > ,----'
-- > |
-- > o
--
connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connvrr props =
buildConn props verticalSrc verticalDst $ \p0@(P2 x0 y0) p1@(P2 x1 y1) ->
connectorArms props >>= \(src_arm,_) ->
let a0 = p0 .+^ vvec (directional y0 y1 src_arm)
a1 = a0 .+^ hvec (x1 - x0)
in return $ vertexPath [p0, a0, a1, p1]
-- | Connector with two right angles...
--
-- > @
-- > |
-- > ,----'
-- > |
-- > o
--
connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connrrv props =
buildConn props verticalSrc verticalDst $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->
connectorArms props >>= \(_,dst_arm) ->
let a1 = p1 .-^ vvec (directional y0 y1 dst_arm)
a0 = a1 .-^ hvec (x1 - x0)
in return $ vertexPath [p0, a0, a1, p1]
-- | Loop connector.
--
-- > ,---------,
-- > | |
-- > '-o @--'
--
-- The loop is drawn /above/ the points.
--
connaloop :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connaloop = loopbody id
-- | Loop connector.
--
-- > ,-o @--,
-- > | |
-- > '---------'
--
-- The loop is drawn /above/ the points.
--
connbloop :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathQuery u
connbloop = loopbody negate
-- | Looping just differs on a negate...
--
loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u)
=> (u -> u) -> ConnectorProps -> ConnectorPathQuery u
loopbody fn props = buildConn props extlineSrc extlineDst $ \p0 p1 ->
connectorArms props >>= \(src_arm, dst_arm) ->
connectorLoopSize props >>= \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 ]
-- | 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.
--
-- Warning - currently bezier connectors do not draw properly
-- with source or destination spacers.
--
connhbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> ConnectorProps -> ConnectorPathQuery u
connhbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 ->
fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,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
-- | 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.
--
-- Warning - currently bezier connectors do not draw properly
-- with source or destination spacers.
--
connvbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> ConnectorProps -> ConnectorPathQuery u
connvbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 ->
fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,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