{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Connectors.Arrowheads -- Copyright : (c) Stephen Tetley 2011-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- 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