arrow envelopes

src/Diagrams/TwoD.hs

@@ -148,10 +148,13 @@ module Diagrams.TwoD
        , tailGap
        , gaps, gap
        , headColor
+       , headTexture
        , headStyle
        , tailColor
+       , tailTexture
        , tailStyle
        , shaftColor
+       , shaftTexture
        , shaftStyle
        , headSize
        , tailSize

src/Diagrams/TwoD/Arrow.hs

@@ -81,12 +81,15 @@ module Diagrams.TwoD.Arrow
        , tailGap
        , gaps, gap
        , headColor
+       , headTexture
        , headStyle
        , headSize
        , tailColor
+       , tailTexture
        , tailStyle
        , tailSize
        , shaftColor
+       , shaftTexture
        , shaftStyle
        , straightShaft
 
@@ -235,6 +238,21 @@ tailColor = tailStyle . styleFillColor
 shaftColor :: Color c => Setter' ArrowOpts c
 shaftColor = shaftStyle . styleLineColor
 
+-- | A lens for setting or modifying the texture of an arrow
+--   head.
+headTexture :: Setter' ArrowOpts Texture
+headTexture = headStyle . styleFillTexture
+
+-- | A lens for setting or modifying the texture of an arrow
+--   tail.
+tailTexture :: Setter' ArrowOpts Texture
+tailTexture = tailStyle . styleFillTexture
+
+-- | A lens for setting or modifying the texture of an arrow
+--   shaft.
+shaftTexture :: Setter' ArrowOpts Texture
+shaftTexture = shaftStyle . styleLineTexture
+
 -- Set the default shaft style of an `ArrowOpts` record by applying the
 -- default style after all other styles have been applied.
 -- The semigroup stucture of the lw attribute will insure that the default
@@ -348,6 +366,16 @@ scaleFactor tr tw hw t
     hv = hw *^ (tangentAtEnd   tr # normalized)
     v  = trailOffset tr
 
+-- Calculate the approximate envelope of a horizontal arrow
+-- as if the arrow were made only of a shaft.
+arrowEnv :: ArrowOpts -> Double -> Envelope R2
+arrowEnv opts len = getEnvelope horizShaft
+  where
+    horizShaft = shaft # rotate (negateV direction v) # scale (len / m)
+    m = magnitude v
+    v = trailOffset shaft
+    shaft = opts ^. arrowShaft
+
 -- | @arrow len@ creates an arrow of length @len@ with default
 --   parameters, starting at the origin and ending at the point
 --   @(len,0)@.
@@ -362,7 +390,7 @@ arrow' :: Renderable (Path R2) b => ArrowOpts -> Double -> Diagram b R2
 arrow' opts len = mkQD' (DelayedLeaf delayedArrow)
 
       -- Currently arrows have an empty envelope and trace.
-      mempty mempty mempty mempty
+      (arrowEnv opts len) mempty mempty mempty
 
   where
 
@@ -466,7 +494,8 @@ arrowAt s v = arrowAt' def s v
 arrowAt'
   :: Renderable (Path R2) b =>
      ArrowOpts -> P2 -> R2 -> Diagram b R2
-arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s
+arrowAt' opts s v = arrow' opts len
+                  # rotate dir # moveTo s
   where
     len = magnitude v
     dir = direction v

src/Diagrams/TwoD/Attributes.hs

@@ -50,13 +50,15 @@ module Diagrams.TwoD.Attributes (
 
   -- ** Line texture
   ,  LineTexture(..), getLineTexture, lineTexture, lineTextureA
+  ,  mkLineTexture, styleLineTexture
 
   -- ** Line color
   , LineColor, lineColor, getLineColor, lc, lcA, lineColorA
   , mkLineColor, styleLineColor
 
   -- ** Fill texture
   , FillTexture(..), getFillTexture, fillTexture
+  , mkFillTexture, styleFillTexture
 
   -- ** Fill color
   , FillColor, fillColor, getFillColor, fc, fcA, recommendFillColor
@@ -381,6 +383,20 @@ lineTexture = applyTAttr . LineTexture . Last
 lineTextureA :: (HasStyle a, V a ~ R2) => LineTexture -> a -> a
 lineTextureA = applyTAttr
 
+mkLineTexture :: Texture  -> LineTexture
+mkLineTexture = LineTexture . Last
+
+styleLineTexture :: Setter (Style v) (Style v) Texture Texture
+styleLineTexture = sets modifyLineTexture
+  where
+    modifyLineTexture f s
+      = flip setAttr s
+      . mkLineTexture
+      . f
+      . getLineTexture
+      . fromMaybe def . getAttr
+      $ s
+
 -- | The color with which lines (strokes) are drawn.  Note that child
 --   colors always override parent colors; that is, @'lineColor' c1
 --   . 'lineColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@.
@@ -473,12 +489,30 @@ instance Transformable FillTexture where
       rgt = _RG . rGradTrans %~ f
       f = transform t
 
+instance Default FillTexture where
+    def = FillTexture (Recommend (Last (SC
+                      (SomeColor (transparent :: AlphaColour Double)))))
+
 getFillTexture :: FillTexture -> Texture
 getFillTexture (FillTexture tx) = getLast . getRecommend $ tx
 
 fillTexture :: (HasStyle a, V a ~ R2) => Texture -> a -> a
 fillTexture = applyTAttr . FillTexture . Commit . Last
 
+mkFillTexture :: Texture  -> FillTexture
+mkFillTexture = FillTexture . Commit . Last
+
+styleFillTexture :: Setter (Style v) (Style v) Texture Texture
+styleFillTexture = sets modifyFillTexture
+  where
+    modifyFillTexture f s
+      = flip setAttr s
+      . mkFillTexture
+      . f
+      . getFillTexture
+      . fromMaybe def . getAttr
+      $ s
+
 -- | The color with which shapes are filled. Note that child
 --   colors always override parent colors; that is, @'fillColor' c1
 --   . 'fillColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@.