module Wumpus.Drawing.Arrows.Connectors
(
Connector
, connector
, leftArrow
, rightArrow
, dblArrow
, leftrightArrow
, strokeConnector
) where
import Wumpus.Basic.Kernel
import Wumpus.Drawing.Arrows.Tips
import Wumpus.Drawing.Paths
import Wumpus.Core
import Control.Applicative
data Connector u = Connector
{ connector_path :: ConnectorPath u
, opt_left_arrow :: Maybe (Arrowhead u)
, opt_right_arrow :: Maybe (Arrowhead u)
}
connector :: ConnectorPath u -> Connector u
connector cp =
Connector { connector_path = cp
, opt_left_arrow = Nothing
, opt_right_arrow = Nothing
}
leftArrow :: ConnectorPath u -> Arrowhead u -> Connector u
leftArrow cp la =
Connector { connector_path = cp
, opt_left_arrow = Just la
, opt_right_arrow = Nothing
}
rightArrow :: ConnectorPath u -> Arrowhead u -> Connector u
rightArrow cp ra =
Connector { connector_path = cp
, opt_left_arrow = Nothing
, opt_right_arrow = Just ra
}
dblArrow :: ConnectorPath u -> Arrowhead u -> Connector u
dblArrow cp arw = leftrightArrow cp arw arw
leftrightArrow :: ConnectorPath u -> Arrowhead u -> Arrowhead u -> Connector u
leftrightArrow cp la ra =
Connector { connector_path = cp
, opt_left_arrow = Just la
, opt_right_arrow = Just ra
}
strokeConnector :: (Real u, Floating u)
=> Connector u -> ConnectorImage u (Path u)
strokeConnector (Connector cpF opt_la opt_ra) =
promoteR2 $ \p0 p1 -> let pathc = cpF p0 p1 in
tipEval opt_la p0 (directionL pathc) >>= \(dl,gfL) ->
tipEval opt_ra p1 (directionR pathc) >>= \(dr,gfR) ->
intoImage (pure pathc)
(fmap (bimapR (gfR . gfL)) $ drawP $ shortenPath dl dr pathc)
where
drawP = openStroke . toPrimPath
shortenPath :: (Real u , Floating u) => u -> u -> Path u -> Path u
shortenPath l r = shortenL l . shortenR r
type ArrowMark u = PrimGraphic u -> PrimGraphic u
tipEval :: Num u
=> Maybe (Arrowhead u) -> Point2 u -> Radian
-> CF (u, ArrowMark u)
tipEval Nothing _ _ = return (0,unmarked)
tipEval (Just arw) pt theta = makeMark $ apply2R2 (getArrowhead arw) pt theta
unmarked :: ArrowMark u
unmarked = id
makeMark :: Image u a -> CF (a, ArrowMark u)
makeMark = fmap (\(a,prim) -> (a, (`oplus` prim)))