From 7937ad17b75266de94873e9530088ce311d94f8c Mon Sep 17 00:00:00 2001
From: Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>
Date: Mon, 28 Apr 2014 13:09:08 -0400
Subject: [PATCH 1/3] arrow envelopes

---
 src/Diagrams/TwoD/Arrow.hs | 16 ++++++++++++++--
 1 file changed, 14 insertions(+), 2 deletions(-)

diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs
index 0de78f74..3775af56 100644
--- a/src/Diagrams/TwoD/Arrow.hs
+++ b/src/Diagrams/TwoD/Arrow.hs
@@ -113,6 +113,7 @@ import           Diagrams.Core
 import           Diagrams.Core.Types      (QDiaLeaf (..), mkQD')
 
 import           Diagrams.Angle
+import           Diagrams.Combinators     (withEnvelope)
 import           Diagrams.Parametric
 import           Diagrams.Path
 import           Diagrams.Solve           (quadForm)
@@ -348,6 +349,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 +373,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 +477,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

From 0924cc0b0a40f700f56c879afd6b5972c62d55a7 Mon Sep 17 00:00:00 2001
From: Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>
Date: Mon, 28 Apr 2014 14:10:38 -0400
Subject: [PATCH 2/3] remove extra import in arrow module

---
 src/Diagrams/TwoD/Arrow.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs
index 3775af56..915df32c 100644
--- a/src/Diagrams/TwoD/Arrow.hs
+++ b/src/Diagrams/TwoD/Arrow.hs
@@ -113,7 +113,6 @@ import           Diagrams.Core
 import           Diagrams.Core.Types      (QDiaLeaf (..), mkQD')
 
 import           Diagrams.Angle
-import           Diagrams.Combinators     (withEnvelope)
 import           Diagrams.Parametric
 import           Diagrams.Path
 import           Diagrams.Solve           (quadForm)

From e2c157e575e52de88c546366e8ff7b2936e260d5 Mon Sep 17 00:00:00 2001
From: Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>
Date: Mon, 28 Apr 2014 20:27:45 -0400
Subject: [PATCH 3/3] add styleFillTexture, styleLineTexture

---
 src/Diagrams/TwoD.hs            |  3 +++
 src/Diagrams/TwoD/Arrow.hs      | 18 +++++++++++++++++
 src/Diagrams/TwoD/Attributes.hs | 34 +++++++++++++++++++++++++++++++++
 3 files changed, 55 insertions(+)

diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs
index eaee53f2..2dd61430 100644
--- a/src/Diagrams/TwoD.hs
+++ b/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
diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs
index 915df32c..5242c6a6 100644
--- a/src/Diagrams/TwoD/Arrow.hs
+++ b/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
diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs
index 54ceca00..482eedad 100644
--- a/src/Diagrams/TwoD/Attributes.hs
+++ b/src/Diagrams/TwoD/Attributes.hs
@@ -50,6 +50,7 @@ module Diagrams.TwoD.Attributes (
 
   -- ** Line texture
   ,  LineTexture(..), getLineTexture, lineTexture, lineTextureA
+  ,  mkLineTexture, styleLineTexture
 
   -- ** Line color
   , LineColor, lineColor, getLineColor, lc, lcA, lineColorA
@@ -57,6 +58,7 @@ module Diagrams.TwoD.Attributes (
 
   -- ** 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@.