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 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) p0 p1 =
tipEval opt_la (directionL pathc) p0 >>= \(dl,gfL) ->
tipEval opt_ra (directionR pathc) p1 >>= \(dr,gfR) ->
intoImage (pure pathc) (gfR $ gfL $ drawP $ shortenPath dl dr pathc)
where
pathc = cpF p0 p1
drawP = openStroke . toPrimPath
shortenPath :: (Real u , Floating u) => u -> u -> Path u -> Path u
shortenPath l r = shortenL l . shortenR r
tipEval :: Num u
=> Maybe (Arrowhead u) -> Radian -> Point2 u
-> DrawingR (u, GraphicTrafoF u)
tipEval Nothing _ _ = return (0,unmarked)
tipEval (Just arw) theta pt = getArrowhead arw theta pt >>= \(dx,prim) ->
return (dx, superior $ pure prim)
unmarked :: GraphicTrafoF u
unmarked = id