diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index a6029d00..5540768c 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -55,6 +55,7 @@ Library Diagrams.TwoD.Align, -- Diagrams.TwoD.Arrow, -- Diagrams.TwoD.Arrowheads, + Diagrams.TwoD.Attributes, Diagrams.TwoD.Combinators, Diagrams.TwoD.Deform, Diagrams.TwoD.Transform, diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 39951ee7..a2760187 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -39,10 +39,7 @@ module Diagrams.Attributes ( -- ** Converting colors , colorToSRGBA, colorToRGBA - -- * Lines - -- ** Width - , LineWidth, getLineWidth, lineWidth, lineWidthA, lw - + -- * Line stuff -- ** Cap style , LineCap(..), LineCapA, getLineCap, lineCap @@ -55,8 +52,6 @@ module Diagrams.Attributes ( -- ** Dashing , Dashing(..), DashingA, getDashing, dashing - -- * Measure conversion - , toOutput ) where @@ -69,12 +64,9 @@ import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup import Data.Typeable -import Data.VectorSpace (magnitude) import Diagrams.Core -import Diagrams.Core.Compile (mapRTreeStyle) import Diagrams.Core.Style (setAttr) -import Diagrams.Core.Types (RTree) ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -273,58 +265,9 @@ opacity :: HasStyle a => Double -> a -> a opacity = applyAttr . Opacity . Product ------------------------------------------------------------ --- Lines and stuff ------------------------------------- +-- Line stuff ------------------------------------- ------------------------------------------------------------ --- | Line widths specified on child nodes always override line widths --- specified at parent nodes. -newtype LineWidth = LineWidth (Last (Measure Double)) - deriving (Typeable, Semigroup) -instance AttributeClass LineWidth - -geometricScale :: Transformation t -> Double -geometricScale t = sqrt (w * h) - where - w = magnitude $ transform t unitX - h = magnitude $ transform t unitY - ---instance Transformable LineWidth where --- transform t l@(LineWidth (Last (Output w))) = l --- transform t LineWidth (Last (Normalized w)) = - -instance Default LineWidth where - def = LineWidth (Last (Output 1)) - -getLineWidth :: LineWidth -> (Measure Double) -getLineWidth (LineWidth (Last w)) = w - --- | Set the line (stroke) width. -lineWidth :: HasStyle a => (Measure Double) -> a -> a -lineWidth = applyAttr . LineWidth . Last - --- | Apply a 'LineWidth' attribute. -lineWidthA :: HasStyle a => LineWidth -> a -> a -lineWidthA = applyAttr - --- | A convenient synonym for 'lineWidth'. -lw :: HasStyle a => (Measure Double) -> a -> a -lw = lineWidth - --- | Convert all of the @LineWidth@ attributes in an @RTree@ to output --- units. `w` and `h` are the width and height of the final diagram. --- The scaling factor is the geometric mean of `h` and `w`. -toOutput :: Double -> Double -> RTree b v () -> RTree b v () -toOutput w h tr = mapRTreeStyle f tr - where - f sty = case getAttr sty of - Just (LineWidth (Last (Output t))) -> out t sty - Just (LineWidth (Last (Normalized t))) -> out (s*t) sty - Just (LineWidth (Last (Local t))) -> out (s*t) sty - Just (LineWidth (Last (Global t))) -> out t sty - Nothing -> sty - out z st = setAttr (LineWidth (Last (Output z))) st - s = sqrt (w * h) - -- | What sort of shape should be placed at the endpoints of lines? data LineCap = LineCapButt -- ^ Lines end precisely at their endpoints. | LineCapRound -- ^ Lines are capped with semicircles diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index a856a3f7..6a2c3548 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -233,6 +233,12 @@ module Diagrams.TwoD -- ** Adjusting size , sized, sizedAs + -- ** Width + , LineWidth, getLineWidth, lineWidth, lineWidthA, lw + + -- * Measure conversion + , toOutput + -- * Visual aids for understanding the internal model , showOrigin , showOrigin' @@ -243,6 +249,7 @@ module Diagrams.TwoD import Diagrams.TwoD.Align import Diagrams.TwoD.Arc +import Diagrams.TwoD.Attributes --import Diagrams.TwoD.Arrow --import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Combinators diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index 2e7d1ed4..5709755b 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -24,18 +24,19 @@ module Diagrams.TwoD.Adjust import Diagrams.Core -import Diagrams.Attributes (lineWidthA, lineColorA, lineCap - , lineJoin, lineMiterLimitA - ) -import Diagrams.Util ((#)) +import Diagrams.Attributes (lineColorA, lineCap + , lineJoin, lineMiterLimitA + ) +import Diagrams.Util ((#)) -import Diagrams.TwoD.Types (R2, p2) -import Diagrams.TwoD.Size ( size2D, center2D, SizeSpec2D(..) - , requiredScaleT, requiredScale - ) -import Diagrams.TwoD.Text (fontSizeA) +import Diagrams.TwoD.Attributes (lineWidthA) +import Diagrams.TwoD.Types (R2, p2) +import Diagrams.TwoD.Size ( size2D, center2D, SizeSpec2D(..) + , requiredScaleT, requiredScale + ) +import Diagrams.TwoD.Text (fontSizeA) -import Data.AffineSpace ((.-.)) +import Data.AffineSpace ((.-.)) import Data.Semigroup import Data.Default.Class diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs new file mode 100644 index 00000000..2a32ef0e --- /dev/null +++ b/src/Diagrams/TwoD/Attributes.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Attributes +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Diagrams may have /attributes/ which affect the way they are +-- rendered. This module defines /Textures/ (Gradients and Colors) in two +-- dimensions. Like the attriubtes defined in the Diagrams.Attributes module, +-- all attributes defined here use the 'Last' or 'Recommend' /semigroup/ structure. +-- 'FillColor' and 'LineColor' attributes are provided so that backends that +-- don't support gradients need not be concerned with using textures. Backends +-- should only implement color attributes or textures attributes, not both. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Attributes ( + -- ** Width + LineWidth, getLineWidth, lineWidth, lineWidthA, lw + + -- * Measure conversion + , toOutput + + ) where + +import Data.Default.Class +import Data.Semigroup +import Data.Typeable +import Data.VectorSpace (magnitude) + +import Diagrams.Core +import Diagrams.Core.Compile (mapRTreeStyle) +import Diagrams.Core.Style (setAttr) +import Diagrams.Core.Types (RTree) +import Diagrams.TwoD.Types (R2) +import Diagrams.TwoD.Vector (unitX, unitY) + +------------------------------------------------------------ +-- Line Width ------------------------------------------------- +------------------------------------------------------------ + +-- | Line widths specified on child nodes always override line widths +-- specified at parent nodes. +newtype LineWidth = LineWidth (Last (Measure Double)) + deriving (Typeable, Semigroup) +instance AttributeClass LineWidth + +type instance V LineWidth = R2 + +-- Estimate the line width scaling based on the geometric mean of the x and y +-- scaling of the transformation +geometricScale :: Transformation R2 -> Double -> Double +geometricScale t w = w * sqrt (x*y) + where + x = magnitude $ transform t unitX + y = magnitude $ transform t unitY + +instance Transformable LineWidth where + transform t (LineWidth (Last (Local w))) = + LineWidth (Last (Local (geometricScale t w))) + transform _ l = l + +instance Default LineWidth where + def = LineWidth (Last (Output 1)) + +getLineWidth :: LineWidth -> (Measure Double) +getLineWidth (LineWidth (Last w)) = w + +-- | Set the line (stroke) width. +lineWidth :: (HasStyle a, V a ~ R2) => (Measure Double) -> a -> a +lineWidth = applyTAttr . LineWidth . Last + +-- | Apply a 'LineWidth' attribute. +lineWidthA :: (HasStyle a, V a ~ R2) => LineWidth -> a -> a +lineWidthA = applyTAttr + +-- | A convenient synonym for 'lineWidth'. +lw :: (HasStyle a, V a ~ R2) => (Measure Double) -> a -> a +lw = lineWidth + +-- | Convert all of the @LineWidth@ attributes in an @RTree@ to output +-- units. `w` and `h` are the width and height of the final diagram. +-- The scaling factor is the geometric mean of `h` and `w`. +toOutput :: Double -> Double -> RTree b v () -> RTree b v () +toOutput w h tr = mapRTreeStyle f tr + where + f sty = case getAttr sty of + Just (LineWidth (Last (Output t))) -> out t sty + Just (LineWidth (Last (Normalized t))) -> out (s*t) sty + Just (LineWidth (Last (Local t))) -> out t sty + Nothing -> sty + out z st = setAttr (LineWidth (Last (Output z))) st + s = sqrt (w * h) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 839a759d..3ca9ce12 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -45,7 +45,7 @@ import Data.VectorSpace import Diagrams.Core -import Diagrams.Attributes (fc, lw) +import Diagrams.Attributes (fc) import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates @@ -53,12 +53,13 @@ import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align -import Diagrams.TwoD.Path () +import Diagrams.TwoD.Attributes (lw) +import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Transform (scaleX, scaleY) +import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (fromDirection, unitX, unitY) -import Diagrams.Util (( # )) +import Diagrams.TwoD.Vector (fromDirection, unitX, unitY) +import Diagrams.Util (( # )) infixl 6 === diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index 48404181..3e2667ac 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -25,6 +25,7 @@ import Control.Lens (makeLenses, (^.)) import Diagrams.Core import Diagrams.Attributes import Diagrams.Path +import Diagrams.TwoD.Attributes import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Path import Diagrams.TwoD.Size (size2D)