diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index fa9c6989..2188edc7 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -150,6 +150,7 @@ module Diagrams.TwoD , arrowShaft , headSize , tailSize + , bothSize , headGap , tailGap , gap diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index ec6f853c..94d97d1e 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -78,6 +78,7 @@ module Diagrams.TwoD.Arrow , arrowShaft , headSize , tailSize + , bothSize , headGap , tailGap , gap @@ -149,7 +150,7 @@ straightShaft = trailFromOffsets [unitX] instance Default ArrowOpts where def = ArrowOpts { _arrowHead = dart - , _arrowTail = noTail + , _arrowTail = lineTail , _arrowShaft = trailFromOffsets [unitX] , _headSize = 0.3 , _tailSize = 0.3 @@ -179,6 +180,19 @@ headSize :: Lens' ArrowOpts Double -- | Radius of a circumcircle around the tail. tailSize :: Lens' ArrowOpts Double +bothSize :: Traversal' ArrowOpts Double +bothSize f opts = + (\h t -> opts & headSize .~ h & tailSize .~ toTailSize opts t) + <$> f (opts ^. headSize) <*> f (opts ^. tailSize) + +toTailSize :: ArrowOpts -> Double -> Double +toTailSize opts s = hw / tw + 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 diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 3c8caeae..09ed81ff 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -42,6 +42,7 @@ module Diagrams.TwoD.Arrowheads , spike' , thorn' , missile' + , lineTail , noTail , quill , block @@ -293,6 +294,9 @@ arrowtailQuill theta =aTail -- Standard tails --------------------------------------------------------- +lineTail :: ArrowHT +lineTail l w = (square 1 # scaleX l # scaleY w # alignR, mempty) + noTail :: ArrowHT noTail _ _ = (mempty, mempty)