module Wumpus.Drawing.Arrows.Connectors
(
ArrowConnector
, leftArrow
, rightArrow
, leftRightArrow
, uniformArrow
) where
import Wumpus.Basic.Kernel
import Wumpus.Drawing.Arrows.Tips
import Wumpus.Drawing.Paths
type ArrowConnector u = ConnectorImage u (Path u)
leftArrow :: (Real u, Floating u)
=> Arrowhead u -> ConnectorPath u -> ArrowConnector u
leftArrow arrh conn = promoteR2 $ \p0 p1 ->
connect conn p0 p1 >>= \cpath ->
arrowhead_retract_dist arrh >>= \dl ->
let path1 = shortenL dl cpath
ang = directionL path1
g1 = openStroke $ toPrimPath path1
g2 = atRot (arrowhead_draw arrh) p0 ang
in fmap (replaceL cpath) $ g1 `oplus` g2
rightArrow :: (Real u, Floating u)
=> Arrowhead u -> ConnectorPath u -> ArrowConnector u
rightArrow arrh conn = promoteR2 $ \p0 p1 ->
connect conn p0 p1 >>= \cpath ->
arrowhead_retract_dist arrh >>= \dr ->
let path1 = shortenR dr cpath
ang = directionR path1
g1 = openStroke $ toPrimPath path1
g2 = atRot (arrowhead_draw arrh) p1 ang
in fmap (replaceL cpath) $ g1 `oplus` g2
leftRightArrow :: (Real u, Floating u)
=> Arrowhead u -> Arrowhead u -> ConnectorPath u
-> ArrowConnector u
leftRightArrow arrL arrR conn = promoteR2 $ \p0 p1 ->
connect conn p0 p1 >>= \cpath ->
arrowhead_retract_dist arrL >>= \dL ->
arrowhead_retract_dist arrR >>= \dR ->
let path1 = shortenPath dL dR cpath
angL = directionL path1
angR = directionR path1
g1 = openStroke $ toPrimPath path1
gL = atRot (arrowhead_draw arrL) p0 angL
gR = atRot (arrowhead_draw arrR) p1 angR
in fmap (replaceL cpath) $ g1 `oplus` gL `oplus` gR
uniformArrow :: (Real u, Floating u)
=> Arrowhead u -> ConnectorPath u -> ArrowConnector u
uniformArrow arrh cp = leftRightArrow arrh arrh cp