module Wumpus.Basic.Arrows.Connectors
(
Connector
, connector
, leftArrow
, rightArrow
, dblArrow
, leftrightArrow
, strokeConnector
) where
import Wumpus.Basic.Arrows.Tips
import Wumpus.Basic.Graphic
import Wumpus.Basic.Paths
import Wumpus.Core
import Data.Monoid
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) = \p0 p1 ->
let pathc = cpF p0 p1 in
(fn pathc opt_la p0 opt_ra p1) >>= \grafic ->
intoImage (return pathc) grafic
where
fn pathc ma p0 mb p1 = do
(path1,tipl) <- applyTipL ma p0 pathc
(path2,tipr) <- applyTipR mb p1 path1
return $ (openStroke $ toPrimPath path2) `mappend` tipl `mappend` tipr
applyTipL :: (Real u, Floating u)
=> Maybe (Arrowhead u) -> Point2 u -> Path u
-> DrawingR (Path u, Graphic u)
applyTipL Nothing _ pathc = return (pathc,mempty)
applyTipL (Just arw) ptL pathc =
retract_dist arw >>= \ dx ->
if dx > 0 then return (shortenL dx pathc, grafik)
else return (pathc, grafik)
where
grafik = (arrow_draw arw) (directionL pathc) ptL
applyTipR :: (Real u, Floating u)
=> Maybe (Arrowhead u) -> Point2 u -> Path u
-> DrawingR (Path u, Graphic u)
applyTipR Nothing _ pathc = return (pathc,mempty)
applyTipR (Just arw) ptR pathc =
retract_dist arw >>= \dx ->
if dx > 0 then return (shortenR dx pathc, grafik)
else return (pathc, grafik)
where
grafik = (arrow_draw arw) (directionR pathc) ptR