module Wumpus.Drawing.Connectors.Arrowheads
(
tri90
, tri60
, tri45
, otri90
, otri60
, otri45
, revtri90
, revtri60
, revtri45
, orevtri90
, orevtri60
, orevtri45
, barb90
, barb60
, barb45
, revbarb90
, revbarb60
, revbarb45
, perp
, bracket
, diskTip
, odiskTip
, squareTip
, osquareTip
, diamondTip
, odiamondTip
, diamondWideTip
, odiamondWideTip
, curveTip
, revcurveTip
) where
import Wumpus.Drawing.Connectors.Base
import Wumpus.Drawing.Paths.Absolute
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
solid_stroke_tip :: DrawingContextF
solid_stroke_tip = reset_drawing_metrics
type PointGen = Radian -> [Vec2 En]
filledTipPath :: PointGen -> LocThetaGraphic En
filledTipPath fn =
localize fill_use_stroke_colour $ promoteR2 $ \pt theta ->
let vs = fn theta in vertexPP (map (pt .+^) vs) >>= filledPath
closedTipPath :: PointGen -> LocThetaGraphic En
closedTipPath fn =
localize solid_stroke_tip $ promoteR2 $ \pt theta ->
let vs = fn theta in vertexPP (map (pt .+^) vs) >>= closedStroke
openTipPath :: PointGen -> LocThetaGraphic En
openTipPath fn =
localize solid_stroke_tip $ promoteR2 $ \pt theta ->
let vs = fn theta in vertexPP (map (pt .+^) vs) >>= openStroke
tripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En))
tripointsFromTip baselen ang = \theta ->
(avec (theta + au) hyp, avec (theta + ad) hyp)
where
half_ang = 0.5 * ang
au = pi half_ang
ad = half_ang + pi
hyp = baselen / (fromRadian $ cos half_ang)
revTripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En, Vec2 En))
revTripointsFromTip baselen ang = \theta ->
(avec theta (baselen), oa theta, ob theta)
where
half_ang = 0.5 * ang
half_height = baselen * (fromRadian $ tan half_ang)
oa = \theta -> avec (theta + ang90) half_height
ob = \theta -> avec (theta ang90) half_height
zeroVec :: Vec2 En
zeroVec = V2 0 0
ang90 :: Radian
ang90 = pi / 2
ang60 :: Radian
ang60 = pi / 3
ang45 :: Radian
ang45 = pi / 4
len_one :: InterpretUnit u => Query u
len_one = uconvertCtx1 (1::En)
len_two :: InterpretUnit u => Query u
len_two = uconvertCtx1 (2::En)
len_half :: InterpretUnit u => Query u
len_half = uconvertCtx1 (0.5::En)
len_zero :: InterpretUnit u => Query u
len_zero = pure 0
retract_one :: InterpretUnit u => Query u
retract_one = uconvertCtx1 (1::En)
retract_two :: InterpretUnit u => Query u
retract_two = uconvertCtx1 (2::En)
retract_zero :: InterpretUnit u => Query u
retract_zero = pure 0
filledTri :: InterpretUnit u => Radian -> ArrowTip u
filledTri ang =
makeArrowTip retract_one len_one (filledTipPath spec)
where
spec theta = let (v1,v2) = tripointsFromTip 1 ang theta
in [zeroVec, v1, v2]
tri90 :: InterpretUnit u => ArrowTip u
tri90 = filledTri ang90
tri60 :: InterpretUnit u => ArrowTip u
tri60 = filledTri ang60
tri45 :: InterpretUnit u => ArrowTip u
tri45 = filledTri ang45
strokedClosedTri :: InterpretUnit u => Radian -> ArrowTip u
strokedClosedTri ang =
makeArrowTip retract_one len_one (closedTipPath spec)
where
spec theta = let (v1,v2) = tripointsFromTip 1 ang theta
in [zeroVec, v1, v2]
otri90 :: InterpretUnit u => ArrowTip u
otri90 = strokedClosedTri ang90
otri60 :: InterpretUnit u => ArrowTip u
otri60 = strokedClosedTri ang60
otri45 :: InterpretUnit u => ArrowTip u
otri45 = strokedClosedTri ang45
filledRevTri :: InterpretUnit u => Radian -> ArrowTip u
filledRevTri ang =
makeArrowTip retract_one len_one (filledTipPath spec)
where
spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta
in [v0, v1, v2]
revtri90 :: InterpretUnit u => ArrowTip u
revtri90 = filledRevTri ang90
revtri60 :: InterpretUnit u => ArrowTip u
revtri60 = filledRevTri ang60
revtri45 :: InterpretUnit u => ArrowTip u
revtri45 = filledRevTri ang45
strokedClosedRevTri :: InterpretUnit u => Radian -> ArrowTip u
strokedClosedRevTri ang =
makeArrowTip retract_one len_one (closedTipPath spec)
where
spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta
in [v0, v1, v2]
orevtri90 :: InterpretUnit u => ArrowTip u
orevtri90 = strokedClosedRevTri ang90
orevtri60 :: InterpretUnit u => ArrowTip u
orevtri60 = strokedClosedRevTri ang60
orevtri45 :: InterpretUnit u => ArrowTip u
orevtri45 = strokedClosedRevTri ang45
strokedBarb :: InterpretUnit u => Radian -> ArrowTip u
strokedBarb ang =
makeArrowTip retract_zero len_one (openTipPath spec)
where
spec theta = let (v1,v2) = tripointsFromTip 1 ang theta
in [v1,zeroVec,v2]
barb90 :: InterpretUnit u => ArrowTip u
barb90 = strokedBarb ang90
barb60 :: InterpretUnit u => ArrowTip u
barb60 = strokedBarb ang60
barb45 :: InterpretUnit u => ArrowTip u
barb45 = strokedBarb ang45
strokedRevBarb :: InterpretUnit u => Radian -> ArrowTip u
strokedRevBarb ang =
makeArrowTip retract_one len_one (openTipPath spec)
where
spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta
in [v1,v0,v2]
revbarb90 :: InterpretUnit u => ArrowTip u
revbarb90 = strokedRevBarb ang90
revbarb60 :: InterpretUnit u => ArrowTip u
revbarb60 = strokedRevBarb ang60
revbarb45 :: InterpretUnit u => ArrowTip u
revbarb45 = strokedRevBarb ang45
perp :: InterpretUnit u => ArrowTip u
perp =
makeArrowTip retract_zero len_zero (openTipPath spec)
where
spec theta = let oa = avec (theta + ang90) 0.5
ob = avec (theta ang90) 0.5
in [oa, ob]
bracket :: InterpretUnit u => ArrowTip u
bracket =
makeArrowTip retract_zero len_half (openTipPath spec)
where
spec theta = let oa = avec (theta + ang90) 0.5
ob = avec (theta ang90) 0.5
dv = avec theta (0.5)
in [ oa ^+^ dv, oa, ob, ob ^+^ dv ]
diskTip :: InterpretUnit u => ArrowTip u
diskTip =
makeArrowTip retract_one len_one
(promoteR2 $ \pt theta -> body theta `at` pt)
where
body :: Radian -> LocGraphic En
body theta = let v1 = avec theta (0.5)
in localize fill_use_stroke_colour $
moveStart (displaceVec v1) (filledDisk 0.5)
odiskTip :: InterpretUnit u => ArrowTip u
odiskTip =
makeArrowTip retract_one len_one
(promoteR2 $ \pt theta -> body theta `at` pt)
where
body :: Radian -> LocGraphic En
body theta = let v1 = avec theta (0.5)
in localize solid_stroke_tip $
moveStart (displaceVec v1) (strokedDisk 0.5)
squareSpec :: PointGen
squareSpec theta = [ oa ^+^ ov, oa, ob, ob ^+^ ov ]
where
oa = avec (theta + ang90) 0.5
ob = avec (theta ang90) 0.5
ov = avec theta (1)
squareTip :: InterpretUnit u => ArrowTip u
squareTip =
makeArrowTip retract_one len_one (filledTipPath squareSpec)
osquareTip :: InterpretUnit u => ArrowTip u
osquareTip =
makeArrowTip retract_one len_one (closedTipPath squareSpec)
diamondSpec :: En -> PointGen
diamondSpec width theta = [ ow, oa, zeroVec, ob ]
where
ow = avec theta (width)
ov = avec theta (negate $ 0.5 * width)
oa = ov ^+^ avec (theta + ang90) 0.5
ob = ov ^+^ avec (theta ang90) 0.5
diamondTip :: InterpretUnit u => ArrowTip u
diamondTip =
makeArrowTip retract_one len_one (filledTipPath $ diamondSpec 1)
odiamondTip :: InterpretUnit u => ArrowTip u
odiamondTip =
makeArrowTip retract_one len_one (closedTipPath $ diamondSpec 1)
diamondWideTip :: InterpretUnit u => ArrowTip u
diamondWideTip =
makeArrowTip retract_two len_two (filledTipPath $ diamondSpec 2)
odiamondWideTip :: InterpretUnit u => ArrowTip u
odiamondWideTip =
makeArrowTip retract_two len_two (closedTipPath $ diamondSpec 2)
curveTipPath :: Point2 En -> Radian -> AbsPath En
curveTipPath pt theta =
curve1 a b c pt `append` curve1 pt z y x
where
ow = avec theta (1)
a = pt .+^ ow ^+^ avec (theta + ang90) 0.5
x = pt .+^ ow ^+^ avec (theta ang90) 0.5
(c,b) = trapezoidFromBasePoints 0.125 0.5 pt a
(y,z) = trapezoidFromBasePoints 0.125 0.5 x pt
curveTip :: InterpretUnit u => ArrowTip u
curveTip =
makeArrowTip retract_zero len_one
(promoteR2 $ \pt theta ->
localize (join_bevel . solid_stroke_tip) $
toPrimPath (curveTipPath pt theta) >>= openStroke)
curveTipRevPath :: Point2 En -> Radian -> AbsPath En
curveTipRevPath pt theta =
curve1 a b c p2 `append` curve1 p2 z y x
where
p2 = pt .+^ avec theta (1)
a = pt .+^ avec (theta + ang90) 0.5
x = pt .+^ avec (theta ang90) 0.5
(b,c) = trapezoidFromBasePoints 0.125 0.5 a p2
(z,y) = trapezoidFromBasePoints 0.125 0.5 p2 x
revcurveTip :: InterpretUnit u => ArrowTip u
revcurveTip =
makeArrowTip retract_one len_one
(promoteR2 $ \pt theta ->
localize (join_bevel . solid_stroke_tip) $
toPrimPath (curveTipRevPath pt theta) >>= openStroke)
trapezoidFromBasePoints :: (Real u, Floating u)
=> u -> u -> Point2 u -> Point2 u
-> (Point2 u, Point2 u)
trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2)
where
base_vec = pvec p1 p2
base_len = vlength base_vec
theta = vdirection base_vec
half_ulen = 0.5 * ratio_to_base * base_len
base_mid = displaceParallel (0.5 * base_len) theta p1
ubase_mid = displacePerpendicular u theta base_mid
cp1 = displaceParallel (half_ulen) theta ubase_mid
cp2 = displaceParallel half_ulen theta ubase_mid