From c218cf27a63f83e4c50140e9c93fd9a95467ef39 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 18 Feb 2015 21:52:16 -0500 Subject: [PATCH 1/6] bug fix: get line width for arrow shaft The line width was still Measured in the style, so simply applying 'getAttr' was always returning Nothing and a default line width was being used, so setting the line width had no effect on arrow shafts. The fix is to use unmeasureAttrs to first resolve Measured attributes before calling getAttr. --- src/Diagrams/TwoD/Arrow.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index b4a2718b..ba19b27f 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -114,6 +114,7 @@ import Data.Typeable import Data.Colour hiding (atop) import Diagrams.Core +import Diagrams.Core.Style (unmeasureAttrs) import Diagrams.Core.Types (QDiaLeaf (..), mkQD') import Diagrams.Angle @@ -280,9 +281,9 @@ colorJoint sStyle = -- | Get line width from a style. widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n widthOfJoint sStyle gToO nToO = - maybe (fromMeasured gToO nToO medium) -- should be same as default line width - (fromMeasured gToO nToO) - (fmap getLineWidth . getAttr $ sStyle :: Maybe (Measure n)) + fromMaybe + (fromMeasured gToO nToO medium) -- should be same as default line width + (fmap getLineWidth . getAttr . unmeasureAttrs gToO nToO $ sStyle) -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram From 9a2a63e1c97932ff0b27be336ec029e040b8823e Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 18 Feb 2015 22:16:55 -0500 Subject: [PATCH 2/6] arrows: use global line width for shaft style Previously it was only taking the line color from the global style. Now we simply apply the entire global style to the shaft style. Anything explicitly set in the shaft style will take precedence, but this means the shaft and joint now pick up not only the ambient line color but also the line width, so you can do things like arrow ... # lw thick # lc red and it will "just work". --- src/Diagrams/TwoD/Arrow.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index ba19b27f..874b1c97 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -409,12 +409,13 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Use the existing line color for head, tail, and shaft by -- default (can be overridden by explicitly setting headStyle, - -- tailStyle, or shaftStyle). + -- tailStyle, or shaftStyle). Also use existing global line width + -- for shaft if not explicitly set in shaftStyle. globalLC = getLineTexture <$> getAttr sty opts' = opts & headStyle %~ maybe id fillTexture globalLC & tailStyle %~ maybe id fillTexture globalLC - & shaftStyle %~ maybe id lineTexture globalLC + & shaftStyle %~ applyStyle sty -- The head size, tail size, head gap, and tail gap are obtained -- from the style and converted to output units. @@ -451,7 +452,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- shaft into a Diagram with using its style. sf = scaleFactor shaftTrail tWidth hWidth (norm (q .-. p)) shaftTrail' = shaftTrail # scale sf - shaft = strokeT shaftTrail' # applyStyle (shaftSty opts) + shaft = strokeT shaftTrail' # applyStyle (shaftSty opts') -- Adjust the head and tail to point in the directions of the shaft ends. h' = h # rotate hAngle From bd26844cd6704c4a63f9097f581ff35d674bbfef Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 18 Feb 2015 23:13:33 -0500 Subject: [PATCH 3/6] arrows: pick up reflection from ambient transform Previously arrowheads were unaffected by reflections, which no one ever noticed because we never had any asymmetric arrowheads. --- src/Diagrams/TwoD/Arrow.hs | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 874b1c97..4621d6b3 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -129,7 +129,7 @@ import Diagrams.Trail import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Attributes import Diagrams.TwoD.Path (stroke, strokeT) -import Diagrams.TwoD.Transform (rotate, translateX) +import Diagrams.TwoD.Transform (rotate, translateX, reflectY) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X) import Diagrams.Util (( # )) @@ -289,9 +289,13 @@ widthOfJoint sStyle gToO nToO = -- and move the origin to the attachment point. Return the diagram -- and its width. mkHead :: (TypeableFloat n, Renderable (Path V2 n) b) => - n -> ArrowOpts n -> n -> n -> (QDiagram b V2 n Any, n) -mkHead sz opts gToO nToO = ( (j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 - , hWidth + jWidth) + n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) +mkHead sz opts gToO nToO reflect + = ( (j <> h) + # (if reflect then reflectY else id) + # moveOriginBy (jWidth *^ unit_X) # lwO 0 + , hWidth + jWidth + ) where (h', j') = (opts^.arrowHead) sz (widthOfJoint (shaftSty opts) gToO nToO) @@ -300,11 +304,15 @@ mkHead sz opts gToO nToO = ( (j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 h = stroke h' # applyStyle (headSty opts) j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) --- | Just like mkHead only the attachment point is on the right. +-- | Just like 'mkHead' only the attachment point is on the right. mkTail :: (TypeableFloat n, Renderable (Path V2 n) b) => - n -> ArrowOpts n -> n -> n -> (QDiagram b V2 n Any, n) -mkTail sz opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 - , tWidth + jWidth) + n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) +mkTail sz opts gToO nToO reflect + = ( (t <> j) + # (if reflect then reflectY else id) + # moveOriginBy (jWidth *^ unitX) # lwO 0 + , tWidth + jWidth + ) where (t', j') = (opts^.arrowTail) sz (widthOfJoint (shaftSty opts) gToO nToO) @@ -426,8 +434,8 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) tGap = scaleFromMeasure $ opts ^. tailGap -- Make the head and tail and save their widths. - (h, hWidth') = mkHead hSize opts' gToO nToO - (t, tWidth') = mkTail tSize opts' gToO nToO + (h, hWidth') = mkHead hSize opts' gToO nToO (isReflection tr) + (t, tWidth') = mkTail tSize opts' gToO nToO (isReflection tr) rawShaftTrail = opts^.arrowShaft shaftTrail From 56794be18ccdf05cfbf81f86d672f6a77a643561 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 18 Feb 2015 23:20:48 -0500 Subject: [PATCH 4/6] D.TwoD.Arrow: factor out common code mkHead and mkTail were almost identical. Please don't make me write down the type of mkHT. --- src/Diagrams/TwoD/Arrow.hs | 39 ++++++++++++++------------------------ 1 file changed, 14 insertions(+), 25 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 4621d6b3..097c61c0 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -290,36 +290,25 @@ widthOfJoint sStyle gToO nToO = -- and its width. mkHead :: (TypeableFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) -mkHead sz opts gToO nToO reflect - = ( (j <> h) - # (if reflect then reflectY else id) - # moveOriginBy (jWidth *^ unit_X) # lwO 0 - , hWidth + jWidth - ) - where - (h', j') = (opts^.arrowHead) sz - (widthOfJoint (shaftSty opts) gToO nToO) - hWidth = xWidth h' - jWidth = xWidth j' - h = stroke h' # applyStyle (headSty opts) - j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) - --- | Just like 'mkHead' only the attachment point is on the right. +mkHead = mkHT unit_X arrowHead headSty + mkTail :: (TypeableFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) -mkTail sz opts gToO nToO reflect - = ( (t <> j) +mkTail = mkHT unitX arrowTail tailSty + +mkHT xDir htProj styProj sz opts gToO nToO reflect + = ( (j <> ht) # (if reflect then reflectY else id) - # moveOriginBy (jWidth *^ unitX) # lwO 0 - , tWidth + jWidth + # moveOriginBy (jWidth *^ xDir) # lwO 0 + , htWidth + jWidth ) where - (t', j') = (opts^.arrowTail) sz - (widthOfJoint (shaftSty opts) gToO nToO) - tWidth = xWidth t' - jWidth = xWidth j' - t = stroke t' # applyStyle (tailSty opts) - j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) + (ht', j') = (opts^.htProj) sz + (widthOfJoint (shaftSty opts) gToO nToO) + htWidth = xWidth ht' + jWidth = xWidth j' + ht = stroke ht' # applyStyle (styProj opts) + j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) -- | Make a trail with the same angles and offset as an arrow with tail width -- tw, head width hw and shaft of tr, such that the magnituted of the shaft From ef7d42fd705ef1d24df76a8792026b3572698ab2 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 18 Feb 2015 23:25:52 -0500 Subject: [PATCH 5/6] half dart arrowhead --- src/Diagrams/TwoD/Arrowheads.hs | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index be12c0a2..0eaea861 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -22,6 +22,7 @@ module Diagrams.TwoD.Arrowheads -- ** Standard arrowheads tri , dart + , halfDart , spike , thorn , lineHead @@ -33,6 +34,7 @@ module Diagrams.TwoD.Arrowheads -- left point of the arrowhead. , arrowheadTriangle , arrowheadDart + , arrowheadHalfDart , arrowheadSpike , arrowheadThorn @@ -40,6 +42,7 @@ module Diagrams.TwoD.Arrowheads -- ** Standard arrow tails , tri' , dart' + , halfDart' , spike' , thorn' , lineTail @@ -127,6 +130,24 @@ arrowheadDart theta len shaftWidth = (hd # scale sz, jt) -- If the shaft if too wide, set the size to a default value of 1. sz = max 1 ((len - jLength) / 1.5) +-- | Top half of an 'arrowheadDart'. +arrowheadHalfDart :: RealFloat n => Angle n -> ArrowHT n +arrowheadHalfDart theta len shaftWidth = (hd, jt) + where + hd = fromOffsets [t1, t2] + # closeTrail # pathFromTrail + # translateX 1.5 # scale sz + # translateY (-shaftWidth/2) + # snugL + jt = snugR . translateY (-shaftWidth/2) . pathFromTrail . closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 shaftWidth] + v = rotate theta unitX + (t1, t2) = (unit_X ^+^ v, (0.5 *^ unit_X) ^-^ v) + psi = pi - negated t2 ^. _theta . rad + jLength = shaftWidth / tan psi + + -- If the shaft if too wide, set the size to a default value of 1. + sz = max 1 ((len - jLength) / 1.5) + -- | Isoceles triangle with curved concave base. Inkscape type 2. arrowheadSpike :: RealFloat n => Angle n -> ArrowHT n arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) @@ -215,6 +236,12 @@ thorn = arrowheadThorn (3/8 @@ turn) dart :: RealFloat n => ArrowHT n dart = arrowheadDart (2/5 @@ turn) +-- | <<#diagram=halfDartEx&width=100>> + +-- > halfDartEx = drawHead halfDart +halfDart :: RealFloat n => ArrowHT n +halfDart = arrowheadHalfDart (2/5 @@ turn) + -- Tails ------------------------------------------------------------------ -- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw none & arrowHead .~ noHead) -- > origin (r2 (0.001, 0)) @@ -296,6 +323,12 @@ thorn' = headToTail thorn dart' :: RealFloat n => ArrowHT n dart' = headToTail dart +-- | <<#diagram=halfDart'Ex&width=100>> + +-- > halfDart'Ex = drawTail halfDart' +halfDart' :: RealFloat n => ArrowHT n +halfDart' = headToTail halfDart + -- | <> -- > quillEx = drawTail quill From 4d273fa7707d5bf1e4db20d2db586b4255f53796 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 19 Feb 2015 09:26:45 -0500 Subject: [PATCH 6/6] D.TwoD.Arrow: add type signature for mkHT --- src/Diagrams/TwoD/Arrow.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 097c61c0..c3862d1f 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -296,6 +297,10 @@ mkTail :: (TypeableFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) mkTail = mkHT unitX arrowTail tailSty +mkHT + :: (TypeableFloat n, Renderable (Path V2 n) b) + => V2 n -> Lens' (ArrowOpts n) (ArrowHT n) -> (ArrowOpts n -> Style V2 n) + -> n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) mkHT xDir htProj styProj sz opts gToO nToO reflect = ( (j <> ht) # (if reflect then reflectY else id)