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@.