wumpus-drawing-0.9.0: src/Wumpus/Drawing/Connectors/Arrowheads.hs
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Drawing.Connectors.Arrowheads
-- Copyright : (c) Stephen Tetley 2011-2012
-- License : BSD3
--
-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>
-- Stability : highly unstable
-- Portability : GHC
--
-- Arrowheads.
--
-- \*\* WARNING \*\* - naming scheme due to change.
--
--------------------------------------------------------------------------------
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.Basis.InclineTrails
import Wumpus.Drawing.Connectors.Base
import Wumpus.Basic.Kernel -- package: wumpus-basic
import Wumpus.Core -- package: wumpus-core
-- import Data.AffineSpace -- package: vector-space
import Data.VectorSpace
import Data.Monoid
-- | Arrow tips are drawn with a solid line even if the connector
-- line is dashed (tips also override round corners)
solid_stroke_tip :: DrawingContextF
solid_stroke_tip = solid_line -- reset_drawing_metrics
type TrailGen = Radian -> AnaTrail En
fillTrailTip :: TrailGen -> LocThetaGraphic En
fillTrailTip gen_pt =
localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta ->
supplyLoc pt $ renderAnaTrail CFILL $ gen_pt theta
closedTrailTip :: TrailGen -> LocThetaGraphic En
closedTrailTip gen_pt =
localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->
supplyLoc pt $ renderAnaTrail CSTROKE $ gen_pt theta
openTrailTip :: TrailGen -> LocThetaGraphic En
openTrailTip gen_pt =
localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->
supplyLoc pt $ renderAnaTrail OSTROKE $ gen_pt theta
-- | All three lines are stated.
--
closedTriTrail :: Radian -> TrailGen
closedTriTrail ang = \theta ->
modifyAna (\v1 -> v1 ^+^ theta_left 1 theta) $
incline_triangle ang (avec theta 1)
filledTri :: Radian -> ArrowTip
filledTri ang =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = fillTrailTip $ closedTriTrail ang
}
--
-- DESIGN NOTE
--
-- Naming scheme should change.
--
-- The \"wumpus way\" of naming seems to be coalescing to favour
-- underscore separated names rather than camelCase for /data/
-- objects.
--
-- These data objects can still be functions but they are
-- distinguished by drawing differently - roughly speaking
-- the difference between a barb tip and a triangle tip is
-- \"what they draw not what they mean\".
--
-- | Filled triangle - apex is 90 deg.
--
tri90 :: ArrowTip
tri90 = filledTri ang90
-- | Filled triangle - apex is 60 deg.
--
tri60 :: ArrowTip
tri60 = filledTri ang60
-- | Filled triangle - apex is 45 deg.
--
tri45 :: ArrowTip
tri45 = filledTri ang45
strokedClosedTri :: Radian -> ArrowTip
strokedClosedTri ang =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = closedTrailTip $ closedTriTrail ang
}
otri90 :: ArrowTip
otri90 = strokedClosedTri ang90
otri60 :: ArrowTip
otri60 = strokedClosedTri ang60
otri45 :: ArrowTip
otri45 = strokedClosedTri ang45
-- | All three lines are stated.
--
revClosedTriSpec :: Radian -> TrailGen
revClosedTriSpec ang = \theta -> incline_triangle ang (avec theta (-1))
filledRevTri :: Radian -> ArrowTip
filledRevTri ang =
ArrowTip
{ retract_distance = 0.5
, tip_half_len = 0.5
, tip_deco = fillTrailTip $ revClosedTriSpec ang
}
revtri90 :: ArrowTip
revtri90 = filledRevTri ang90
revtri60 :: ArrowTip
revtri60 = filledRevTri ang60
revtri45 :: ArrowTip
revtri45 = filledRevTri ang45
strokedClosedRevTri :: Radian -> ArrowTip
strokedClosedRevTri ang =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = closedTrailTip $ revClosedTriSpec ang
}
orevtri90 :: ArrowTip
orevtri90 = strokedClosedRevTri ang90
orevtri60 :: ArrowTip
orevtri60 = strokedClosedRevTri ang60
orevtri45 :: ArrowTip
orevtri45 = strokedClosedRevTri ang45
barbSpec :: Radian -> TrailGen
barbSpec ang = \theta ->
modifyAna (\v1 -> v1 ^+^ avec theta (-1)) $ incline_barb ang (avec theta 1)
strokedBarb :: Radian -> ArrowTip
strokedBarb ang =
ArrowTip
{ retract_distance = 0
, tip_half_len = 0.5
, tip_deco = openTrailTip $ barbSpec ang
}
barb90 :: ArrowTip
barb90 = strokedBarb ang90
barb60 :: ArrowTip
barb60 = strokedBarb ang60
barb45 :: ArrowTip
barb45 = strokedBarb ang45
revBarbSpec :: Radian -> TrailGen
revBarbSpec ang = \theta -> incline_barb ang (avec theta (-1))
strokedRevBarb :: Radian -> ArrowTip
strokedRevBarb ang =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = openTrailTip $ revBarbSpec ang
}
revbarb90 :: ArrowTip
revbarb90 = strokedRevBarb ang90
revbarb60 :: ArrowTip
revbarb60 = strokedRevBarb ang60
revbarb45 :: ArrowTip
revbarb45 = strokedRevBarb ang45
perpSpec :: TrailGen
perpSpec ang =
anaCatTrail (theta_up 0.5 ang) $ trail_theta_down 1 ang
perp :: ArrowTip
perp =
ArrowTip
{ retract_distance = 0
, tip_half_len = 0
, tip_deco = openTrailTip perpSpec
}
bracketSpec :: TrailGen
bracketSpec ang = anaCatTrail (orthoVec (-0.5) 0.5 ang) catt
where
catt = mconcat [ trail_theta_right 0.5 ang
, trail_theta_down 1.0 ang
, trail_theta_left 0.5 ang
]
bracket :: ArrowTip
bracket =
ArrowTip
{ retract_distance = 0.0
, tip_half_len = 0.5
, tip_deco = openTrailTip bracketSpec
}
diskBody :: DrawMode -> Radian -> LocGraphic En
diskBody mode theta =
localize fill_use_stroke_colour $ moveStart vback $ dcDisk mode 0.5
where
vback = theta_left 0.5 theta
diskTip :: ArrowTip
diskTip =
ArrowTip
{ retract_distance = 0.5
, tip_half_len = 0.5
, tip_deco = promoteLocTheta $ \pt theta ->
diskBody DRAW_FILL theta `at` pt
}
odiskTip :: ArrowTip
odiskTip =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = promoteLocTheta $ \pt theta ->
diskBody DRAW_STROKE theta `at` pt
}
-- | Note - need to draw square East-West rather than West-East
-- hence the base_width is negative.
--
squareSpec :: TrailGen
squareSpec theta = incline_square $ avec theta (-1)
squareTip :: ArrowTip
squareTip =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = fillTrailTip squareSpec
}
osquareTip :: ArrowTip
osquareTip =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = closedTrailTip squareSpec
}
-- | squareSpec:
--
-- >
-- > a
-- > / \
-- > ...w..v..o
-- > \ /
-- > b
--
diamondSpec :: En -> TrailGen
diamondSpec w theta = incline_diamond 1 $ avec theta (-w)
diamondTip :: ArrowTip
diamondTip =
ArrowTip
{ retract_distance = 0.5
, tip_half_len = 0.5
, tip_deco = fillTrailTip $ diamondSpec 1
}
odiamondTip :: ArrowTip
odiamondTip =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = closedTrailTip $ diamondSpec 1
}
diamondWideTip :: ArrowTip
diamondWideTip =
ArrowTip
{ retract_distance = 1.0
, tip_half_len = 1.0
, tip_deco = fillTrailTip $ diamondSpec 2
}
odiamondWideTip :: ArrowTip
odiamondWideTip =
ArrowTip
{ retract_distance = 2.0
, tip_half_len = 1.0
, tip_deco = closedTrailTip $ diamondSpec 2
}
curveTipSpec :: TrailGen
curveTipSpec theta =
anaCatTrail dv $ vectrapCCW v1 <> vectrapCCW v2
where
dv = orthoVec (-1.0) 0.75 theta -- back and up
v1 = orthoVec 1.0 (-0.75) theta -- fwd and down
v2 = orthoVec (-1.0) (-0.75) theta -- back and down
vectrapCW :: (Real u, Floating u) => Vec2 u -> CatTrail u
vectrapCW v1 = trapCurve CW w h quarter_pi ang
where
w = vlength v1
h = w / 4
ang = vdirection v1
vectrapCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u
vectrapCCW v1 = trapCurve CCW w h quarter_pi ang
where
w = vlength v1
h = w / 4
ang = vdirection v1
curveTip :: ArrowTip
curveTip =
ArrowTip
{ retract_distance = 0
, tip_half_len = 0.5
, tip_deco = body
}
where
body = localize (cap_round . join_round . solid_stroke_tip) $
openTrailTip curveTipSpec
curveTipRevSpec :: TrailGen
curveTipRevSpec theta =
anaCatTrail dv $ vectrapCW v1 <> vectrapCW v2
where
dv = orthoVec 0.0 0.75 theta -- just up
v1 = orthoVec (-1.0) (-0.75) theta -- back and down
v2 = orthoVec 1.0 (-0.75) theta -- fwd and down
revcurveTip :: ArrowTip
revcurveTip =
ArrowTip
{ retract_distance = 1
, tip_half_len = 0.5
, tip_deco = body
}
where
body = localize (cap_round . join_round . solid_stroke_tip) $
openTrailTip curveTipRevSpec