Merge pull request #165 from diagrams/tail

Added bothSize function, lineHead and lineTail

src/Diagrams/TwoD.hs

@@ -146,6 +146,10 @@ module Diagrams.TwoD
        , arrowShaft
        , headSize
        , tailSize
+       , sizes
+       , headWidth
+       , tailWidth
+       , widths
        , headGap
        , tailGap
        , gap

src/Diagrams/TwoD/Arrow.hs

@@ -78,6 +78,10 @@ module Diagrams.TwoD.Arrow
        , arrowShaft
        , headSize
        , tailSize
+       , sizes
+       , headWidth
+       , tailWidth
+       , widths
        , headGap
        , tailGap
        , gap
@@ -97,7 +101,7 @@ module Diagrams.TwoD.Arrow
 import           Control.Applicative              ((<*>))
 import           Control.Arrow                    (first)
 import           Control.Lens                     (Lens', Setter', Traversal',
-                                                   generateSignatures,
+                                                   sets, generateSignatures,
                                                    lensRules, makeLensesWith,
                                                    (%~), (&), (.~), (^.))
 import           Data.AffineSpace
@@ -180,12 +184,57 @@ headSize :: Lens' ArrowOpts Double
 -- | Radius of a circumcircle around the tail.
 tailSize :: Lens' ArrowOpts Double
 
+-- | Width of the head.
+headWidth :: Setter' ArrowOpts Double
+headWidth f opts =
+  (\hd -> opts & headSize .~ g hd) <$> f (opts ^. headSize)
+  where
+    g w = w / (xWidth h + xWidth j)
+    (h, j) = (opts ^. arrowHead) 1 (widthOfJoint $ shaftSty opts)
+
+-- | Width of the tail.
+tailWidth :: Setter' ArrowOpts Double
+tailWidth f opts =
+  (\tl -> opts & tailSize .~ g tl) <$> f (opts ^. tailSize)
+  where
+    g w = w / (xWidth t + xWidth j)
+    (t, j) = (opts ^. arrowTail) 1 (widthOfJoint $ shaftSty opts)
+
+-- | Set both the @headWidth@ and @tailWidth@.
+widths :: Traversal' ArrowOpts Double
+widths f opts =
+  (\hd tl -> opts & headSize .~ gh hd & tailSize .~ gt tl)
+  <$> f (opts ^. headSize) <*> f (opts ^. tailSize)
+    where
+      gh w = w / (xWidth h + xWidth j)
+      (h, j) = (opts ^. arrowHead) 1 (widthOfJoint $ shaftSty opts)
+      gt w = w / (xWidth t + xWidth j')
+      (t, j') = (opts ^. arrowTail) 1 (widthOfJoint $ shaftSty opts)
+
+-- | Set the size of both the head and tail.
+sizes :: Traversal' ArrowOpts Double
+sizes f opts =
+  (\h t -> opts & headSize .~ h & tailSize .~ {-toTailSize opts-} t)
+    <$> f (opts ^. headSize) <*> f (opts ^. tailSize)
+
+-- Calculate the tailSize needed so that the head and tail are the same width.
+-- If either is zero, revert to the default size. This is needed for example
+-- in the noHead arrow head case.
+--toTailSize :: ArrowOpts -> Double -> Double
+--toTailSize opts s = if (hw > 0) && (tw > 0) then hw / tw else 0.3
+--  where
+--    (h, j) = (opts^.arrowHead) s (widthOfJoint $ shaftSty opts)
+--    (t, k) = (opts^.arrowTail) 1 (widthOfJoint $ shaftSty opts)
+--    hw = xWidth h + xWidth j
+--    tw = xWidth t + xWidth k
+
 -- | Distance to leave between the head and the target point.
 headGap :: Lens' ArrowOpts Double
 
 -- | Distance to leave between the starting point and the tail.
 tailGap :: Lens' ArrowOpts Double
 
+-- | Set both the @headGap@ and @tailGap@ simultaneously.
 gap :: Traversal' ArrowOpts Double
 gap f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap)
 

src/Diagrams/TwoD/Arrowheads.hs

@@ -23,6 +23,7 @@ module Diagrams.TwoD.Arrowheads
        , spike
        , thorn
        , missile
+       , lineHead
        , noHead
 
        -- ** Configurable arrowheads
@@ -42,6 +43,7 @@ module Diagrams.TwoD.Arrowheads
        , spike'
        , thorn'
        , missile'
+       , lineTail
        , noTail
        , quill
        , block
@@ -209,6 +211,10 @@ arrowheadMissile :: Angle -> ArrowHT
 arrowheadMissile theta = smoothArrowhead $ arrowheadDart theta
 
 -- Standard heads ---------------------------------------------------------
+-- | A line the same width as the shaft.
+lineHead :: ArrowHT
+lineHead l w = (square 1 # scaleX l # scaleY w # alignL, mempty)
+
 noHead :: ArrowHT
 noHead _ _ = (mempty, mempty)
 
@@ -293,6 +299,9 @@ arrowtailQuill theta =aTail
                 [ v0, n1, n2, v0, n3, n4, v0 ])
 
 -- Standard tails ---------------------------------------------------------
+-- | A line the same width as the shaft.
+lineTail :: ArrowHT
+lineTail l w = (square 1 # scaleX l # scaleY w # alignR, mempty)
 
 noTail :: ArrowHT
 noTail _ _ = (mempty, mempty)