module Wumpus.Drawing.Connectors.Base
(
ConnectorPathQuery
, SpacingProjection
, ArrowTip(..)
, ArrowConnector
, ConnectorConfig(..)
, ConnectorPathSpec(..)
, renderConnectorConfig
, arrowDecoratePath
, leftArrowConnector
, rightArrowConnector
, uniformArrowConnector
) where
import Wumpus.Drawing.Connectors.ConnectorProps
import Wumpus.Drawing.Paths
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.Monoid
type SpacingProjection u =
ConnectorProps -> Point2 u -> Point2 u -> Query u (Point2 u)
type ConnectorPathQuery u = ConnectorQuery u (AbsPath u)
data ArrowTip = ArrowTip
{ retract_distance :: En
, tip_half_len :: En
, tip_deco :: LocThetaGraphic En
}
newtype ConnectorPathSpec u = ConnectorPathSpec {
getConnectorPathSpec :: ConnectorProps -> ConnectorPathQuery u }
data ConnectorConfig u = ConnectorConfig
{ conn_arrowl :: Maybe ArrowTip
, conn_arrowr :: Maybe ArrowTip
, conn_path_spec :: ConnectorPathSpec u
}
type ArrowConnector u = ConnectorImage u (AbsPath u)
renderConnectorConfig :: (Real u, Floating u, InterpretUnit u)
=> ConnectorProps
-> ConnectorConfig u
-> ConnectorImage u (AbsPath u)
renderConnectorConfig props (ConnectorConfig mbl mbr pspec) =
promoteConn $ \src dst ->
liftQuery (qapplyConn path_spec src dst) >>= \tot_path ->
connectorSrcSpace props >>= \sepl ->
connectorDstSpace props >>= \sepr ->
arrowDecoratePath mbl mbr $ shortenL sepl $ shortenR sepr tot_path
where
path_spec = getConnectorPathSpec pspec props
arrowDecoratePath :: (Real u, Floating u, InterpretUnit u)
=> Maybe ArrowTip -> Maybe ArrowTip -> (AbsPath u)
-> Image u (AbsPath u)
arrowDecoratePath mbl mbr initial_path =
uconvertCtx1 (maybe 0 retract_distance mbl) >>= \retl ->
uconvertCtx1 (maybe 0 retract_distance mbr) >>= \retr ->
let (p1,theta1) = atstart initial_path
(p2,theta2) = atend initial_path
new_path = shortenL retl $ shortenR retr initial_path
arrl = mbTip p1 (pi + theta1) mbl
arrr = mbTip p2 theta2 mbr
in replaceAns initial_path $
decorate ZABOVE (renderPath OSTROKE new_path) (arrl `mappend` arrr)
where
mbTip pt ang = maybe emptyImage (supplyLocTheta pt ang . uconvF . tip_deco)
leftArrowConnector :: (Real u, Floating u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathSpec u -> ArrowTip
-> ConnectorImage u (AbsPath u)
leftArrowConnector props cpath tip = renderConnectorConfig props cfg
where
cfg = ConnectorConfig { conn_arrowl = Just tip
, conn_arrowr = Nothing
, conn_path_spec = cpath }
rightArrowConnector :: (Real u, Floating u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathSpec u -> ArrowTip
-> ConnectorImage u (AbsPath u)
rightArrowConnector props cpath tip = renderConnectorConfig props cfg
where
cfg = ConnectorConfig { conn_arrowl = Nothing
, conn_arrowr = Just tip
, conn_path_spec = cpath }
uniformArrowConnector :: (Real u, Floating u, InterpretUnit u)
=> ConnectorProps -> ConnectorPathSpec u -> ArrowTip
-> ConnectorImage u (AbsPath u)
uniformArrowConnector props cpath tip = renderConnectorConfig props cfg
where
cfg = ConnectorConfig { conn_arrowl = Just tip
, conn_arrowr = Just tip
, conn_path_spec = cpath }