From 2b214459f0ebc58d47ea058a1ecc9b2437d45132 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Mon, 10 Feb 2014 14:44:42 -0500 Subject: [PATCH 01/77] start work on pushing fill attributes down to subtrees with only loops See diagrams/diagrams-svg#43. --- src/Diagrams/Attributes.hs | 79 +++++++++++++++++++++++++++++++++++++- 1 file changed, 78 insertions(+), 1 deletion(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index de470569..6e197c5a 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -57,18 +57,21 @@ module Diagrams.Attributes ( ) where +import Control.Arrow (second) import Control.Lens (Setter, sets) import Data.Colour -import Data.Colour.RGBSpace (RGB(..)) +import Data.Colour.RGBSpace (RGB (..)) import Data.Colour.SRGB (toSRGB) import Data.Default.Class import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup +import Data.Tree import Data.Typeable import Diagrams.Core import Diagrams.Core.Style (setAttr) +import Diagrams.Core.Types (RNode (..), RTree) ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -390,3 +393,77 @@ dashing :: HasStyle a => -- stroke should start. -> a -> a dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) + +------------------------------------------------------------ + +-- XXX todo: +-- * change type to take fill attribute explicitly, not style + +-- | Push fill attributes down until they are at the roots of trees +-- containing only loops. +splitFills :: RTree b v a -> RTree b v a +splitFills = fst . splitFills' Nothing + where + + -- splitFills' is where the most interesting logic happens. + -- Mutually recursive with splitFills'Forest. + -- + -- Input: fill attribute to apply to subtrees containing only loops. + -- + -- Output: tree with fill attributes pushed down appropriately, and + -- a Bool indicating whether the tree contains only loops (True) or + -- contains some lines (False). + splitFills' :: Maybe (Style v) -> RTree b v a -> (RTree b v a, Bool) + + -- RStyle node: Check for fill attribute and split it out of the + -- style, combining it with incoming fill attribute. Recurse and + -- rebuild. + splitFills' msty (Node (RStyle sty) cs) = undefined + + -- RPrim node: check whether it is a + -- * line: don't apply the fill; return False + -- * loop: do apply the fill; return True + -- * anything else: don't apply the fill; return True + splitFills' msty (Node (RPrim tr pr) cs) = undefined + + -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note + -- that transformations do not affect fill attributes. + splitFills' msty (Node nd cs) = (t', ok) + where + (cs', ok) = splitFills'Forest msty cs + t' = rebuildNode msty ok nd cs' + + -- Recursively call splitFills' on all subtrees, returning the + -- logical AND of the Bool results returned (the whole forest + -- contains only loops iff all the subtrees do). The tricky bit is + -- that we use some knot-tying to determine the right style to pass + -- down to the subtrees based on this computed Bool: if all subtrees + -- contain only loops, then we will apply the style at the root of + -- this forest, and pass Nothing to all the subtrees. Otherwise, we + -- pass the given style along. This works out because the style + -- does not need to be pattern-matched until actually applying it at + -- some root, so the recursion can proceed and the Bool values be + -- computed with the actual value of the style nodes filled in + -- lazily. + splitFills'Forest :: Maybe (Style v) -> [RTree b v a] -> ([RTree b v a], Bool) + splitFills'Forest msty cs = (cs', ok) + where + (cs', ok) = second and . unzip . map (splitFills' msty') $ cs + msty' | ok = Nothing + | otherwise = msty + + -- Given a style, a Bool indicating whether the given subforest + -- contains only loops, a node, and a subforest, rebuild a tree, + -- applying the style as appropriate (only if the Bool is true and + -- the style is not Nothing). + rebuildNode :: Maybe (Style v) -> Bool -> RNode b v a -> [RTree b v a] -> RTree b v a + rebuildNode msty ok nd cs + | ok = applyMSty msty (Node nd cs) + | otherwise = Node nd cs + + -- Prepend a new style node if Just; the identity function if + -- Nothing. + applyMSty :: Maybe (Style v) -> RTree b v a -> RTree b v a + applyMSty Nothing t = t + applyMSty (Just sty) t = Node (RStyle sty) [t] + From 6028236cf74caae6ffca565dad8864cc6744a564 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 11 Feb 2014 13:49:39 -0500 Subject: [PATCH 02/77] implement splitFills for case of style node --- src/Diagrams/Attributes.hs | 75 +++++++++++++++++++++----------------- 1 file changed, 42 insertions(+), 33 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 6e197c5a..b3e10a45 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -55,14 +55,18 @@ module Diagrams.Attributes ( -- ** Dashing , Dashing(..), DashingA, getDashing, dashing + -- * Compilation utilities + , splitFills + ) where import Control.Arrow (second) -import Control.Lens (Setter, sets) +import Control.Lens (Setter, sets, (%~), (&), _Wrapping') import Data.Colour import Data.Colour.RGBSpace (RGB (..)) import Data.Colour.SRGB (toSRGB) import Data.Default.Class +import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup @@ -70,7 +74,7 @@ import Data.Tree import Data.Typeable import Diagrams.Core -import Diagrams.Core.Style (setAttr) +import Diagrams.Core.Style (Style (..), attrToStyle, setAttr) import Diagrams.Core.Types (RNode (..), RTree) ------------------------------------------------------------ @@ -396,9 +400,6 @@ dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) ------------------------------------------------------------ --- XXX todo: --- * change type to take fill attribute explicitly, not style - -- | Push fill attributes down until they are at the roots of trees -- containing only loops. splitFills :: RTree b v a -> RTree b v a @@ -406,64 +407,72 @@ splitFills = fst . splitFills' Nothing where -- splitFills' is where the most interesting logic happens. - -- Mutually recursive with splitFills'Forest. + -- Mutually recursive with splitFills'Forest. rebuildNode and + -- applyMfc are helper functions. -- -- Input: fill attribute to apply to subtrees containing only loops. -- -- Output: tree with fill attributes pushed down appropriately, and -- a Bool indicating whether the tree contains only loops (True) or -- contains some lines (False). - splitFills' :: Maybe (Style v) -> RTree b v a -> (RTree b v a, Bool) + splitFills' :: Maybe FillColor -> RTree b v a -> (RTree b v a, Bool) -- RStyle node: Check for fill attribute and split it out of the -- style, combining it with incoming fill attribute. Recurse and -- rebuild. - splitFills' msty (Node (RStyle sty) cs) = undefined + splitFills' mfc (Node (RStyle sty) cs) = (t', ok) + where + mfc' = mfc <> getAttr sty + sty' = sty & _Wrapping' Style %~ M.delete ty + ty = show . typeOf $ (undefined :: FillColor) + (cs', ok) = splitFills'Forest mfc' cs + t' | ok = rebuildNode Nothing ok (RStyle sty) cs' + | otherwise = rebuildNode mfc ok (RStyle sty') cs' -- RPrim node: check whether it is a -- * line: don't apply the fill; return False -- * loop: do apply the fill; return True -- * anything else: don't apply the fill; return True - splitFills' msty (Node (RPrim tr pr) cs) = undefined + splitFills' mfc (Node (RPrim tr pr) cs) = undefined -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note -- that transformations do not affect fill attributes. - splitFills' msty (Node nd cs) = (t', ok) + splitFills' mfc (Node nd cs) = (t', ok) where - (cs', ok) = splitFills'Forest msty cs - t' = rebuildNode msty ok nd cs' + (cs', ok) = splitFills'Forest mfc cs + t' = rebuildNode mfc ok nd cs' -- Recursively call splitFills' on all subtrees, returning the -- logical AND of the Bool results returned (the whole forest -- contains only loops iff all the subtrees do). The tricky bit is - -- that we use some knot-tying to determine the right style to pass + -- that we use some knot-tying to determine the right attribute to pass -- down to the subtrees based on this computed Bool: if all subtrees - -- contain only loops, then we will apply the style at the root of + -- contain only loops, then we will apply the fill at the root of -- this forest, and pass Nothing to all the subtrees. Otherwise, we - -- pass the given style along. This works out because the style + -- pass the given fill along. This works out because the fill -- does not need to be pattern-matched until actually applying it at -- some root, so the recursion can proceed and the Bool values be - -- computed with the actual value of the style nodes filled in + -- computed with the actual value of the fill nodes filled in -- lazily. - splitFills'Forest :: Maybe (Style v) -> [RTree b v a] -> ([RTree b v a], Bool) - splitFills'Forest msty cs = (cs', ok) + splitFills'Forest :: Maybe FillColor -> [RTree b v a] -> ([RTree b v a], Bool) + splitFills'Forest mfc cs = (cs', ok) where - (cs', ok) = second and . unzip . map (splitFills' msty') $ cs - msty' | ok = Nothing - | otherwise = msty - - -- Given a style, a Bool indicating whether the given subforest - -- contains only loops, a node, and a subforest, rebuild a tree, - -- applying the style as appropriate (only if the Bool is true and - -- the style is not Nothing). - rebuildNode :: Maybe (Style v) -> Bool -> RNode b v a -> [RTree b v a] -> RTree b v a - rebuildNode msty ok nd cs - | ok = applyMSty msty (Node nd cs) + (cs', ok) = second and . unzip . map (splitFills' mfc') $ cs + mfc' | ok = Nothing + | otherwise = mfc + + -- Given a fill attribute, a Bool indicating whether the given + -- subforest contains only loops, a node, and a subforest, rebuild a + -- tree, applying the fill attribute as appropriate (only if the + -- Bool is true and the attribute is not Nothing). + rebuildNode :: Maybe FillColor -> Bool -> RNode b v a -> [RTree b v a] -> RTree b v a + rebuildNode mfc ok nd cs + | ok = applyMfc mfc (Node nd cs) | otherwise = Node nd cs - -- Prepend a new style node if Just; the identity function if + -- Prepend a new fill color node if Just; the identity function if -- Nothing. - applyMSty :: Maybe (Style v) -> RTree b v a -> RTree b v a - applyMSty Nothing t = t - applyMSty (Just sty) t = Node (RStyle sty) [t] + applyMfc :: Maybe FillColor -> RTree b v a -> RTree b v a + applyMfc Nothing t = t + applyMfc (Just fc) t = Node (RStyle $ attrToStyle fc) [t] From 7c95e39fe5b6ec05277a6731bc4f32c59251029f Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 11 Feb 2014 14:15:07 -0500 Subject: [PATCH 03/77] finish implementing splitFills: RPrim case --- src/Diagrams/Attributes.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index b3e10a45..1c0c6240 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes @@ -76,6 +78,9 @@ import Data.Typeable import Diagrams.Core import Diagrams.Core.Style (Style (..), attrToStyle, setAttr) import Diagrams.Core.Types (RNode (..), RTree) +import Diagrams.Located (unLoc) +import Diagrams.Path (Path, pathTrails) +import Diagrams.Trail (isLine) ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -402,9 +407,9 @@ dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) -- | Push fill attributes down until they are at the roots of trees -- containing only loops. -splitFills :: RTree b v a -> RTree b v a +splitFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a splitFills = fst . splitFills' Nothing - where + where -- splitFills' is where the most interesting logic happens. -- Mutually recursive with splitFills'Forest. rebuildNode and @@ -429,11 +434,17 @@ splitFills = fst . splitFills' Nothing t' | ok = rebuildNode Nothing ok (RStyle sty) cs' | otherwise = rebuildNode mfc ok (RStyle sty') cs' - -- RPrim node: check whether it is a - -- * line: don't apply the fill; return False - -- * loop: do apply the fill; return True - -- * anything else: don't apply the fill; return True - splitFills' mfc (Node (RPrim tr pr) cs) = undefined + -- RPrim node: check whether it + -- * is not a path : don't apply the fill; return True + -- * contains lines: don't apply the fill; return False + -- * contains loops: do apply the fill; return True + splitFills' mfc (Node rp@(RPrim tr (Prim p)) _) = + case cast p :: Maybe (Path v) of + Nothing -> (Node rp [], True) + Just pth -> + case any (isLine . unLoc) . pathTrails $ pth of + True -> (Node rp [], False) + False -> (rebuildNode mfc True rp [], True) -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note -- that transformations do not affect fill attributes. From 0412269b79170c75cb33e6e22a00868f45e7cbb6 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 11 Feb 2014 15:30:00 -0500 Subject: [PATCH 04/77] D.Attributes: fix warnings --- src/Diagrams/Attributes.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 1c0c6240..eb536f86 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -438,7 +438,7 @@ splitFills = fst . splitFills' Nothing -- * is not a path : don't apply the fill; return True -- * contains lines: don't apply the fill; return False -- * contains loops: do apply the fill; return True - splitFills' mfc (Node rp@(RPrim tr (Prim p)) _) = + splitFills' mfc (Node rp@(RPrim _ (Prim p)) _) = case cast p :: Maybe (Path v) of Nothing -> (Node rp [], True) Just pth -> @@ -484,6 +484,6 @@ splitFills = fst . splitFills' Nothing -- Prepend a new fill color node if Just; the identity function if -- Nothing. applyMfc :: Maybe FillColor -> RTree b v a -> RTree b v a - applyMfc Nothing t = t - applyMfc (Just fc) t = Node (RStyle $ attrToStyle fc) [t] + applyMfc Nothing t = t + applyMfc (Just f) t = Node (RStyle $ attrToStyle f) [t] From 79d1556a8cd1aa7271ffe5afd055f8653d3d8394 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 13 Feb 2014 12:12:33 -0500 Subject: [PATCH 05/77] D.Attributes: clarify comments on splitFills --- src/Diagrams/Attributes.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index eb536f86..5ee237a7 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -406,7 +406,11 @@ dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) ------------------------------------------------------------ -- | Push fill attributes down until they are at the roots of trees --- containing only loops. +-- containing only loops. This makes life much easier for backends, +-- which typically have a semantics where fill attributes are +-- applied to lines/non-closed paths as well as loops/closed paths, +-- whereas in the semantics of diagrams, fill attributes only apply +-- to loops. splitFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a splitFills = fst . splitFills' Nothing where @@ -422,9 +426,9 @@ splitFills = fst . splitFills' Nothing -- contains some lines (False). splitFills' :: Maybe FillColor -> RTree b v a -> (RTree b v a, Bool) - -- RStyle node: Check for fill attribute and split it out of the - -- style, combining it with incoming fill attribute. Recurse and - -- rebuild. + -- RStyle node: Check for a fill attribute, and split it out of the + -- style, combining it with the incoming fill attribute. Recurse + -- and rebuild. splitFills' mfc (Node (RStyle sty) cs) = (t', ok) where mfc' = mfc <> getAttr sty @@ -486,4 +490,3 @@ splitFills = fst . splitFills' Nothing applyMfc :: Maybe FillColor -> RTree b v a -> RTree b v a applyMfc Nothing t = t applyMfc (Just f) t = Node (RStyle $ attrToStyle f) [t] - From f5410a26d7990429edaf19180cd0c7d3f8fb1d01 Mon Sep 17 00:00:00 2001 From: Ryan Yates Date: Fri, 14 Feb 2014 23:20:05 -0500 Subject: [PATCH 06/77] Exclude joins in offsets on close segments (Fixes #160). --- src/Diagrams/TwoD/Offset.hs | 37 ++++++++++++++++++++++++------------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index d6bdeaab..ba5d817f 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -41,6 +41,7 @@ import Control.Applicative import Control.Lens hiding (at) import Data.AffineSpace +import Data.Maybe (catMaybes) import Data.Monoid import Data.Monoid.Inf import Data.VectorSpace @@ -263,9 +264,10 @@ offsetTrail' :: OffsetOpts -- loop. -> Located (Trail R2) -> Located (Trail R2) -offsetTrail' opts r t = joinSegments j isLoop (opts^.offsetMiterLimit) r ends . offset $ t +offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t where - offset = map (bindLoc (offsetSegment (opts^.offsetEpsilon) r)) . locatedTrailSegments + eps = opts^.offsetEpsilon + offset = map (bindLoc (offsetSegment eps r)) . locatedTrailSegments ends | isLoop = (\(a:as) -> as ++ [a]) . trailVertices $ t | otherwise = tail . trailVertices $ t j = fromLineJoin (opts^.offsetJoin) @@ -356,8 +358,10 @@ expandTrail' o r t expandLine :: ExpandOpts -> Double -> Located (Trail' Line R2) -> Located (Trail R2) expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) where - offset r' = map (bindLoc (offsetSegment (opts^.expandEpsilon) r')) . locatedTrailSegments - f r' = joinSegments (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends . offset r' $ t + eps = opts^.expandEpsilon + offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments + f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends + . offset r' $ t ends = tail . trailVertices $ t s = atStart t e = atEnd t @@ -366,8 +370,10 @@ expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) expandLoop :: ExpandOpts -> Double -> Located (Trail' Loop R2) -> Path R2 expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . reverseDomain . f $ -r) where - offset r' = map (bindLoc (offsetSegment (opts^.expandEpsilon) r')) . locatedTrailSegments - f r' = joinSegments (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends . offset r' $ t + eps = opts^.expandEpsilon + offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments + f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends + . offset r' $ t ends = (\(a:as) -> as ++ [a]) . trailVertices $ t -- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. @@ -470,20 +476,25 @@ arcVCW u v = arcCW (direction u) (direction v) -- Note: this is not a general purpose join and assumes that we are joining an -- offset trail. For instance, a fixed radius arc will not fit between arbitrary -- trails without trimming or extending. -joinSegments :: (Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2) +joinSegments :: Double + -> (Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2) -> Bool -> Double -> Double -> [Point R2] -> [Located (Trail R2)] -> Located (Trail R2) -joinSegments _ _ _ _ _ [] = mempty `at` origin -joinSegments _ _ _ _ [] _ = mempty `at` origin -joinSegments j isLoop ml r es ts@(t:_) = t' +joinSegments _ _ _ _ _ _ [] = mempty `at` origin +joinSegments _ _ _ _ _ [] _ = mempty `at` origin +joinSegments epsilon j isLoop ml r es ts@(t:_) = t' where - t' | isLoop = mapLoc (glueTrail . (<> mconcat (take (length ts * 2 - 1) $ ss es (ts ++ [t])))) t - | otherwise = mapLoc (<> mconcat (ss es ts)) t - ss es' ts' = concat [[j ml r e a b, unLoc b] | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts'] + t' | isLoop = mapLoc (glueTrail . (<> f (take (length ts * 2 - 1) $ ss es (ts ++ [t])))) t + | otherwise = mapLoc (<> f (ss es ts)) t + ss es' ts' = concat [[test a b $ j ml r e a b, Just $ unLoc b] | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts'] + test a b tj + | atStart b `distance` atEnd a > epsilon = Just tj + | otherwise = Nothing + f = mconcat . catMaybes -- | Take a join style and give the join function to be used by joinSegments. fromLineJoin From bf51700cf3af4b5c5ea8b4b219a4fc6b15c9339d Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 18 Feb 2014 22:55:27 -0500 Subject: [PATCH 07/77] finish implementing splitFills (with tests). --- diagrams-lib.cabal | 1 + src/Diagrams/Attributes.hs | 117 +++++--------------- src/Diagrams/Attributes/Compile.hs | 122 ++++++++++++++++++++ test/SplitAttr.hs | 172 +++++++++++++++++++++++++++++ 4 files changed, 320 insertions(+), 92 deletions(-) create mode 100644 src/Diagrams/Attributes/Compile.hs create mode 100644 test/SplitAttr.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 98029f0a..b0a940af 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -31,6 +31,7 @@ Library Diagrams.Combinators, Diagrams.Coordinates, Diagrams.Attributes, + Diagrams.Attributes.Compile, Diagrams.Points, Diagrams.Located, Diagrams.Parametric, diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 5ee237a7..b33f96d4 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes @@ -62,25 +62,27 @@ module Diagrams.Attributes ( ) where -import Control.Arrow (second) -import Control.Lens (Setter, sets, (%~), (&), _Wrapping') +import Control.Arrow (second) +import Control.Lens (Setter, sets, (%~), (&), + _Wrapping') import Data.Colour -import Data.Colour.RGBSpace (RGB (..)) -import Data.Colour.SRGB (toSRGB) +import Data.Colour.RGBSpace (RGB (..)) +import Data.Colour.SRGB (toSRGB) import Data.Default.Class -import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup import Data.Tree import Data.Typeable +import Diagrams.Attributes.Compile import Diagrams.Core -import Diagrams.Core.Style (Style (..), attrToStyle, setAttr) -import Diagrams.Core.Types (RNode (..), RTree) -import Diagrams.Located (unLoc) -import Diagrams.Path (Path, pathTrails) -import Diagrams.Trail (isLine) +import Diagrams.Core.Style (Style (..), attrToStyle, setAttr) +import Diagrams.Core.Types (RNode (..), RTree) +import Diagrams.Located (unLoc) +import Diagrams.Path (Path, pathTrails) +import Diagrams.Trail (isLoop) ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -405,88 +407,19 @@ dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) ------------------------------------------------------------ --- | Push fill attributes down until they are at the roots of trees --- containing only loops. This makes life much easier for backends, +data FillLoops v = FillLoops + +instance Typeable v => SplitAttribute (FillLoops v) where + type AttrType (FillLoops v) = FillColor + type PrimType (FillLoops v) = Path v + + primOK _ = all (isLoop . unLoc) . pathTrails + +-- | Push fill attributes down until they are at the root of subtrees +-- containing only loops. This makes life much easier for backends, -- which typically have a semantics where fill attributes are -- applied to lines/non-closed paths as well as loops/closed paths, -- whereas in the semantics of diagrams, fill attributes only apply -- to loops. splitFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a -splitFills = fst . splitFills' Nothing - where - - -- splitFills' is where the most interesting logic happens. - -- Mutually recursive with splitFills'Forest. rebuildNode and - -- applyMfc are helper functions. - -- - -- Input: fill attribute to apply to subtrees containing only loops. - -- - -- Output: tree with fill attributes pushed down appropriately, and - -- a Bool indicating whether the tree contains only loops (True) or - -- contains some lines (False). - splitFills' :: Maybe FillColor -> RTree b v a -> (RTree b v a, Bool) - - -- RStyle node: Check for a fill attribute, and split it out of the - -- style, combining it with the incoming fill attribute. Recurse - -- and rebuild. - splitFills' mfc (Node (RStyle sty) cs) = (t', ok) - where - mfc' = mfc <> getAttr sty - sty' = sty & _Wrapping' Style %~ M.delete ty - ty = show . typeOf $ (undefined :: FillColor) - (cs', ok) = splitFills'Forest mfc' cs - t' | ok = rebuildNode Nothing ok (RStyle sty) cs' - | otherwise = rebuildNode mfc ok (RStyle sty') cs' - - -- RPrim node: check whether it - -- * is not a path : don't apply the fill; return True - -- * contains lines: don't apply the fill; return False - -- * contains loops: do apply the fill; return True - splitFills' mfc (Node rp@(RPrim _ (Prim p)) _) = - case cast p :: Maybe (Path v) of - Nothing -> (Node rp [], True) - Just pth -> - case any (isLine . unLoc) . pathTrails $ pth of - True -> (Node rp [], False) - False -> (rebuildNode mfc True rp [], True) - - -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note - -- that transformations do not affect fill attributes. - splitFills' mfc (Node nd cs) = (t', ok) - where - (cs', ok) = splitFills'Forest mfc cs - t' = rebuildNode mfc ok nd cs' - - -- Recursively call splitFills' on all subtrees, returning the - -- logical AND of the Bool results returned (the whole forest - -- contains only loops iff all the subtrees do). The tricky bit is - -- that we use some knot-tying to determine the right attribute to pass - -- down to the subtrees based on this computed Bool: if all subtrees - -- contain only loops, then we will apply the fill at the root of - -- this forest, and pass Nothing to all the subtrees. Otherwise, we - -- pass the given fill along. This works out because the fill - -- does not need to be pattern-matched until actually applying it at - -- some root, so the recursion can proceed and the Bool values be - -- computed with the actual value of the fill nodes filled in - -- lazily. - splitFills'Forest :: Maybe FillColor -> [RTree b v a] -> ([RTree b v a], Bool) - splitFills'Forest mfc cs = (cs', ok) - where - (cs', ok) = second and . unzip . map (splitFills' mfc') $ cs - mfc' | ok = Nothing - | otherwise = mfc - - -- Given a fill attribute, a Bool indicating whether the given - -- subforest contains only loops, a node, and a subforest, rebuild a - -- tree, applying the fill attribute as appropriate (only if the - -- Bool is true and the attribute is not Nothing). - rebuildNode :: Maybe FillColor -> Bool -> RNode b v a -> [RTree b v a] -> RTree b v a - rebuildNode mfc ok nd cs - | ok = applyMfc mfc (Node nd cs) - | otherwise = Node nd cs - - -- Prepend a new fill color node if Just; the identity function if - -- Nothing. - applyMfc :: Maybe FillColor -> RTree b v a -> RTree b v a - applyMfc Nothing t = t - applyMfc (Just f) t = Node (RStyle $ attrToStyle f) [t] +splitFills = splitAttr (FillLoops :: FillLoops v) diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs new file mode 100644 index 00000000..820cbe8d --- /dev/null +++ b/src/Diagrams/Attributes/Compile.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Attributes.Compile +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- XXX +-- +----------------------------------------------------------------------------- + +module Diagrams.Attributes.Compile ( + SplitAttribute(..), splitAttr + ) where + +import Data.Typeable + +import Control.Arrow (second) +import Control.Lens ((%~), (&), _Wrapping') +import qualified Data.Map as M +import Data.Semigroup ((<>)) +import Data.Tree (Tree (..)) + +import Diagrams.Core +import Diagrams.Core.Style (Style (..), attrToStyle) +import Diagrams.Core.Types (RNode (..), RTree) + +------------------------------------------------------------ + +-- This is a sort of roundabout, overly-general way to define +-- splitFills; it's done this way to facilitate testing. + +class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where + type AttrType code :: * + type PrimType code :: * + + primOK :: code -> PrimType code -> Bool + +-- | Push certain attributes down until they are at the roots of trees +-- containing only "safe" nodes. In particular this is used to push +-- fill attributes down until they are over only loops; see +-- 'splitFills'. +splitAttr :: forall code b v a. SplitAttribute code => code -> RTree b v a -> RTree b v a +splitAttr code = fst . splitAttr' Nothing + where + + -- splitAttr' is where the most interesting logic happens. + -- Mutually recursive with splitAttr'Forest. rebuildNode and + -- applyMfc are helper functions. + -- + -- Input: attribute to apply to "safe" subtrees. + -- + -- Output: tree with attributes pushed down appropriately, and + -- a Bool indicating whether the tree contains only "safe" prims (True) or + -- contains some unsafe ones (False). + splitAttr' :: Maybe (AttrType code) -> RTree b v a -> (RTree b v a, Bool) + + -- RStyle node: Check for the special attribute, and split it out of + -- the style, combining it with the incoming attribute. Recurse and + -- rebuild. The tricky bit is that we use some knot-tying to + -- determine the right attribute to pass down to the subtrees based + -- on this computed Bool: if all subtrees are safe, then we will + -- apply the attribute at the root of this tree, and pass Nothing to + -- all the subtrees. Otherwise, we pass the given attribute along. + -- This works out because the attribute does not need to be + -- pattern-matched until actually applying it at some root, so the + -- recursion can proceed and the Bool values be computed with the + -- actual value of the attributes nodes filled in lazily. + splitAttr' mattr (Node (RStyle sty) cs) = (t', ok) + where + mattr' = mattr <> getAttr sty + sty' = sty & _Wrapping' Style %~ M.delete ty + ty = show . typeOf $ (undefined :: AttrType code) + (cs', ok) = splitAttr'Forest mattr' cs + t' | ok = rebuildNode Nothing ok (RStyle sty) cs' + | otherwise = rebuildNode mattr ok (RStyle sty') cs' + + -- RPrim node: check whether it + -- * is some sort of prim not under consideration: don't apply the attribute; return True + -- * is unsafe: don't apply the attribute; return False + -- * is safe : do apply the attribute; return True + splitAttr' mattr (Node rp@(RPrim _ (Prim prm)) _) = + case cast prm :: Maybe (PrimType code) of + Nothing -> (Node rp [], True) + Just p -> + case primOK code p of + True -> (rebuildNode mattr True rp [], True) + False -> (Node rp [], False) + + -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note + -- we assume that transformations do not affect the attributes. + splitAttr' mattr (Node nd cs) = (t', ok) + where + (cs', ok) = splitAttr'Forest mattr cs + t' = rebuildNode mattr ok nd cs' + + -- Recursively call splitAttr' on all subtrees, returning the + -- logical AND of the Bool results returned (the whole forest is + -- safe iff all subtrees are). + splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v a] -> ([RTree b v a], Bool) + splitAttr'Forest mattr cs = (cs', ok) + where + (cs', ok) = second and . unzip . map (splitAttr' mattr) $ cs + + -- Given a fill attribute, a Bool indicating whether the given + -- subforest contains only loops, a node, and a subforest, rebuild a + -- tree, applying the fill attribute as appropriate (only if the + -- Bool is true and the attribute is not Nothing). + rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v a -> [RTree b v a] -> RTree b v a + rebuildNode mattr ok nd cs + | ok = applyMattr mattr (Node nd cs) + | otherwise = Node nd cs + + -- Prepend a new fill color node if Just; the identity function if + -- Nothing. + applyMattr :: Maybe (AttrType code) -> RTree b v a -> RTree b v a + applyMattr Nothing t = t + applyMattr (Just a) t = Node (RStyle $ attrToStyle a) [t] diff --git a/test/SplitAttr.hs b/test/SplitAttr.hs new file mode 100644 index 00000000..6c7f3366 --- /dev/null +++ b/test/SplitAttr.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +import Control.Applicative +import Control.Lens ((%~), (&), _Wrapping') +import Control.Monad +import qualified Data.Map as M +import Data.Semigroup +import Data.Tree +import Data.Typeable +import Diagrams.Attributes.Compile +import Diagrams.Core +import Diagrams.Core.Style +import Diagrams.Core.Types +import Diagrams.Prelude (R2) +import Test.QuickCheck + +data FakePath = Ln | Lp + deriving (Show, Eq, Typeable) + +type instance V FakePath = R2 + +instance Transformable FakePath where + transform _ = id + +instance Renderable FakePath NullBackend where + render _ _ = undefined + +instance IsPrim FakePath where + +data A = A + deriving (Typeable, Show, Eq, Ord) +instance Semigroup A where + A <> A = A +instance AttributeClass A + +data B = B + deriving (Typeable, Show, Eq, Ord) +instance Semigroup B where + B <> B = B +instance AttributeClass B + +data FillLoopsTest = FillLoopsTest + +instance SplitAttribute FillLoopsTest where + type AttrType FillLoopsTest = A + type PrimType FillLoopsTest = FakePath + + primOK _ l = l == Lp + +showRTree :: RTree b v a -> String +showRTree = drawTree . fmap show + +instance Show (RNode b v a) where + show (RStyle s) = "<" ++ showAttr A s ++ showAttr B s ++ ">" + show (RPrim _ (Prim p)) = + case cast p of + Nothing -> "

" + Just (fp :: FakePath) -> "\"" ++ show fp ++ "\"" + show _ = "." + +showAttr :: forall a v. (Show a, AttributeClass a) => a -> Style v -> String +showAttr _ s = maybe "" show (getAttr s :: Maybe a) + +instance Eq (RNode b v a) where + r1 == r2 = show r1 == show r2 + +instance Arbitrary (RNode b v a) where + arbitrary = oneof [pure REmpty, s $ attrToStyle A, s $ attrToStyle B, s $ attrToStyle A <> attrToStyle B] + where + s = pure . RStyle + shrink REmpty = [] + shrink _ = [REmpty] + +arbPrim :: Gen (RNode NullBackend R2 ()) +arbPrim = (RPrim mempty . Prim) <$> elements [Ln, Lp] + +genTree :: Int -> Gen (Tree (RNode NullBackend R2 ())) +genTree n | n <= 0 = Node <$> arbitrary <*> pure [] +genTree n = do + len <- choose (0,3) + if len == 0 + then Node <$> arbPrim <*> pure [] + else Node <$> arbitrary <*> replicateM len (genTree (n - 1)) + +instance Arbitrary (Tree (RNode NullBackend R2 ())) where + arbitrary = sized genTree + shrink (Node r ts) + = [ t | t <- ts ] + ++ [ Node r ts' | ts' <- splices ts ] + ++ [ Node r' ts | r' <- shrink r ] + ++ [ Node r ts' | ts' <- shrink ts ] + where + splices :: [Tree a] -> [[Tree a]] + splices [] = [] + splices (t@(Node _ cs) : ts) = (cs ++ ts) : (map (t :) (splices ts)) + +splitA = splitAttr FillLoopsTest + +newtype PrettyTree = PT (RTree NullBackend R2 ()) + deriving (Arbitrary) + +instance Show PrettyTree where + show (PT t) = showRTree t + +------------------------------------------------------------ +-- Properties! + +-- should preserve semantics +-- should result in attributes in question only being over OK nodes +-- should not move other attributes + +{- + +-- Should preserve tree shape? +-- Actually, this isn't true (and shouldn't be)! New RStyle nodes have +-- to get introduced sometimes. + +class Matchable m where + matches :: m -> m -> Bool + matches _ _ = True + +instance Matchable m => Matchable [m] where + matches [] [] = True + matches (x:xs) (y:ys) = matches x y && matches xs ys + matches _ _ = False + +instance Matchable m => Matchable (Tree m) where + matches (Node x xs) (Node y ys) + = matches x y && matches xs ys + +instance Matchable (RNode b v a) + +prop_split_pres_shape :: PrettyTree -> Bool +prop_split_pres_shape (PT t) = matches t (splitA t) +-} + +-- Should preserve semantics + +type AB = (Maybe A, Maybe B) + +removeA :: AB -> AB +removeA (_,b) = (Nothing,b) + +flattenTree :: Style R2 -> RTree NullBackend R2 () -> [(Style R2, FakePath)] +flattenTree sty (Node REmpty ts) = flattenForest sty ts +flattenTree sty (Node (RStyle sty') ts) = flattenForest (sty <> sty') ts +flattenTree sty (Node (RPrim _ (Prim p)) _) = + case cast p of + Nothing -> [] + Just (l :: FakePath) -> [(sty, l)] +flattenTree sty _ = [] + +flattenForest :: Style R2 -> [RTree NullBackend R2 ()] -> [(Style R2, FakePath)] +flattenForest = concatMap . flattenTree + +semantics :: RTree NullBackend R2 () -> [(AB, FakePath)] +semantics = map postProcess . flattenTree mempty + where + styleToAB :: Style R2 -> AB + styleToAB = (,) <$> getAttr <*> getAttr + postProcess (sty, l) = ((if l == Ln then removeA else id) (styleToAB sty), l) + +prop_splitA_pres_semantics :: PrettyTree -> Bool +prop_splitA_pres_semantics (PT t) = semantics t == semantics (splitA t) + +-- Ha, this one caught a bug! Success! =D From ecc1a80b34bccacbecd4f5d1eed986f7badcf84e Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 19 Feb 2014 22:32:12 -0500 Subject: [PATCH 08/77] CHANGES for 1.1 --- CHANGES.markdown | 61 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) diff --git a/CHANGES.markdown b/CHANGES.markdown index fffbc013..047a3abf 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,64 @@ +1.1 (XXX) +--------- + +* **New features** + + - Support for `Deformation`s, arbitrary (non-affine) + transformations on objects such as points, paths, and located + trails (though not on diagrams). + + - New functions `clipTo`, which clips a diagram's envelope and + trace along with its visual representation, and `clipped`, which + clips the diagram's visual representation but replaces its + envelope and trace with those of the clipping path. + + - New `arrowV` function, for creating an arrow with the direction + and magnitude of a given vector. + + - `gap` traversal, for setting the head and tail gaps of an arrow + simultaneously. + + - Generalized types for `centerXY` and `snugXY`, based on new + `basis` function from `diagrams-core + + - New 3D `Transform`s, alignment, and 3D-specific `Prelude`. + +* **New instances** + + - `Typeable` instances for all data types that are used as diagram + primitives. + - `Sectionable` instance for `FixedSegment`. + +* **API changes** + + - `Angle` is now a type, rather than a class. It uses a single + internal representation for angles, and lenses `turn`, `rad,` + and `deg` are supplied for constructing (using `@@`) and viewing + (using `^.`) `Angle`s in various units. In addition, the `Num` + instance for `Angle` has been removed, eliminating a class of + errors where a bare number is interpreted in units other than + what you expect. + + - Removed `Num` instance for angles. + +* **Dependency/version changes** + + - Require `lens >= 4.0`. + - Allow `array-0.5`. + - Allow `hashable-1.1`. + - Remove `NumInstances` dependency. + +* **Bug fixes** + + - Exclude joins in offsets on close segments (#160). + - Exclude extra segment when joining loops in offset (#155). + +* **Performance improvements** + + - `colorToSRGBA` function now avoids expensive matrix operations, + offering dramatic speedups in rendering diagrams with many color + attributes. + 1.0.1 (26 January 2014) ----------------------- From a6feb309f1c2c1e6efeeee42fbd5c197fbedd537 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 19 Feb 2014 22:59:42 -0500 Subject: [PATCH 09/77] require diagrams-core-1.1 --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 99ba9d01..79ce3310 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -92,7 +92,7 @@ Library array >= 0.3 && < 0.6, semigroups >= 0.3.4 && < 0.13, monoid-extras >= 0.3 && < 0.4, - diagrams-core >= 1.0 && < 1.1, + diagrams-core >= 1.1 && < 1.2, active >= 0.1 && < 0.2, vector-space >= 0.7.7 && < 0.9, vector-space-points >= 0.1.2 && < 0.2, From eb0fcb5bf5da74d5ccbd26e087041f4a1a86601f Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Fri, 21 Feb 2014 14:48:45 -0500 Subject: [PATCH 10/77] Added `frame` section --- CHANGES.markdown | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGES.markdown b/CHANGES.markdown index 047a3abf..8b56cded 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -22,6 +22,10 @@ `basis` function from `diagrams-core - New 3D `Transform`s, alignment, and 3D-specific `Prelude`. + + - New `frame` function similar to `pad`, but increases the envelope + of a diagram by an amount specified in the local units. + Pre-centering is not necessary. * **New instances** From 38bc25dcfc1a7faa737b87834b544079e630289b Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Sat, 22 Feb 2014 10:55:02 -0500 Subject: [PATCH 11/77] edit `frame` description --- CHANGES.markdown | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGES.markdown b/CHANGES.markdown index 8b56cded..7ea0be94 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -24,8 +24,8 @@ - New 3D `Transform`s, alignment, and 3D-specific `Prelude`. - New `frame` function similar to `pad`, but increases the envelope - of a diagram by an amount specified in the local units. - Pre-centering is not necessary. + of a diagram by an amount specified in local units in every direction + irrespective of the local origin. * **New instances** From c9e63fc2ff7cb2b6366d650b8cc060c1d65333fd Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sat, 1 Mar 2014 17:01:15 -0500 Subject: [PATCH 12/77] update tested-with field --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 79ce3310..d8bfc153 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -19,7 +19,7 @@ Build-type: Simple Cabal-version: >=1.10 Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg Extra-doc-files: diagrams/*.svg -Tested-with: GHC == 7.4.2, GHC == 7.6.1 +Tested-with: GHC == 7.4.2, GHC == 7.6.3 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git From 1e0a1a089f944fe58eb83a9e022e6a66d1a10bd1 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sat, 1 Mar 2014 17:02:27 -0500 Subject: [PATCH 13/77] update copyright years --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index 1a60252f..b5f6258c 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2013 diagrams-lib team: +Copyright (c) 2011-2014 diagrams-lib team: Jan Bracker Daniel Bergey From e3a270c1230778bbfa9035f830ea965488483f6c Mon Sep 17 00:00:00 2001 From: Denys Duchier Date: Sun, 2 Mar 2014 14:30:58 +0100 Subject: [PATCH 14/77] fix doc for === and ||| --- src/Diagrams/TwoD/Combinators.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 5503c65d..6880b12c 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -76,7 +76,7 @@ infixl 6 ||| -- -- to place @c@ above @d@. The local origin of the resulting -- combined diagram is the same as the local origin of the first. --- @(|||)@ is associative and has 'mempty' as an identity. See the +-- @(===)@ is associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. (===) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (===) = beside (negateV unitY) @@ -84,7 +84,7 @@ infixl 6 ||| -- | Place two diagrams (or other juxtaposable objects) horizontally -- adjacent to one another, with the first diagram to the left of -- the second. The local origin of the resulting combined diagram --- is the same as the local origin of the first. @(===)@ is +-- is the same as the local origin of the first. @(|||)@ is -- associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. (|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a From 49b1705255af6e2cc4bc6241a84b40b0d28373c3 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 2 Mar 2014 16:45:52 -0500 Subject: [PATCH 15/77] add Denys to contributors list --- LICENSE | 1 + 1 file changed, 1 insertion(+) diff --git a/LICENSE b/LICENSE index b5f6258c..45b0b227 100644 --- a/LICENSE +++ b/LICENSE @@ -2,6 +2,7 @@ Copyright (c) 2011-2014 diagrams-lib team: Jan Bracker Daniel Bergey + Denys Duchier Daniil Frumin Niklas Haas Peter Hall From 02da78c4f431e65f0145a40dae103b58e72cc448 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 2 Mar 2014 16:51:46 -0500 Subject: [PATCH 16/77] add GHC 7.8.1 to tested-with field --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index d8bfc153..0be4864e 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -19,7 +19,7 @@ Build-type: Simple Cabal-version: >=1.10 Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg Extra-doc-files: diagrams/*.svg -Tested-with: GHC == 7.4.2, GHC == 7.6.3 +Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git From f78be72134a9ecc6bf869020b745a10226fb0ae1 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 3 Mar 2014 00:56:58 +0000 Subject: [PATCH 17/77] Wall: remove extra imports --- src/Diagrams/Attributes.hs | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index b33f96d4..5faa6807 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -62,24 +62,20 @@ module Diagrams.Attributes ( ) where -import Control.Arrow (second) -import Control.Lens (Setter, sets, (%~), (&), - _Wrapping') +import Control.Lens (Setter, sets) import Data.Colour import Data.Colour.RGBSpace (RGB (..)) import Data.Colour.SRGB (toSRGB) import Data.Default.Class -import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup -import Data.Tree import Data.Typeable import Diagrams.Attributes.Compile import Diagrams.Core -import Diagrams.Core.Style (Style (..), attrToStyle, setAttr) -import Diagrams.Core.Types (RNode (..), RTree) +import Diagrams.Core.Style (setAttr) +import Diagrams.Core.Types (RTree) import Diagrams.Located (unLoc) import Diagrams.Path (Path, pathTrails) import Diagrams.Trail (isLoop) From 0cf47263db69af996ed4826ddd9c06bd1167d1a1 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Mon, 3 Mar 2014 18:50:43 -0500 Subject: [PATCH 18/77] initial commit --- src/Diagrams/TwoD.hs | 1 + src/Diagrams/TwoD/Arrow.hs | 16 +++++++++++++++- src/Diagrams/TwoD/Arrowheads.hs | 4 ++++ 3 files changed, 20 insertions(+), 1 deletion(-) 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) From 8ce0b102dbf49a21edfe184c3260aba436ea36e1 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Mon, 3 Mar 2014 22:48:37 -0500 Subject: [PATCH 19/77] change defaults --- src/Diagrams/TwoD/Arrow.hs | 2 +- src/Diagrams/TwoD/Arrowheads.hs | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 94d97d1e..db2edadf 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -150,7 +150,7 @@ straightShaft = trailFromOffsets [unitX] instance Default ArrowOpts where def = ArrowOpts { _arrowHead = dart - , _arrowTail = lineTail + , _arrowTail = noTail , _arrowShaft = trailFromOffsets [unitX] , _headSize = 0.3 , _tailSize = 0.3 diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 09ed81ff..b03aef75 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -23,6 +23,7 @@ module Diagrams.TwoD.Arrowheads , spike , thorn , missile + , lineHead , noHead -- ** Configurable arrowheads @@ -209,6 +210,9 @@ arrowheadMissile :: Angle -> ArrowHT arrowheadMissile theta = smoothArrowhead $ arrowheadDart theta -- Standard heads --------------------------------------------------------- +lineHead :: ArrowHT +lineHead l w = (square 1 # scaleX l # scaleY w # alignL, mempty) + noHead :: ArrowHT noHead _ _ = (mempty, mempty) From 4007bddc0848f0f551d23a67b86838bae3939776 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Tue, 4 Mar 2014 07:39:18 -0500 Subject: [PATCH 20/77] handle zero case, add documentation --- src/Diagrams/TwoD/Arrow.hs | 10 +++++++++- src/Diagrams/TwoD/Arrowheads.hs | 3 ++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index db2edadf..7f4d4c61 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -180,13 +180,20 @@ headSize :: Lens' ArrowOpts Double -- | Radius of a circumcircle around the tail. tailSize :: Lens' ArrowOpts Double +-- | Set the size of both the head and tail. The @headSize@ is set to the +-- given value and the @tailSize@ is set so that it is the same width as +-- the head. Both @arrowHead@ and @arrowTail@ should be set before using +-- bothSize. bothSize :: Traversal' ArrowOpts Double bothSize 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 = hw / tw +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) @@ -199,6 +206,7 @@ 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) diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index b03aef75..2c81c9be 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -210,6 +210,7 @@ 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) @@ -297,7 +298,7 @@ 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) From 16813bea724692e914ad907ed4ac899b2c45cd63 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 5 Mar 2014 19:20:40 +0000 Subject: [PATCH 21/77] travis: build with 7.8.1 instead of GHC HEAD --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 2b9156e4..de4912d6 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ env: - HPVER=2013.2.0.0 - GHCVER=7.4.2 - GHCVER=7.6.3 - - GHCVER=head + - GHCVER=7.8.1 global: - CABALVER=1.18 - HEAD_DEPS="diagrams-core" @@ -14,6 +14,7 @@ env: matrix: allow_failures: - env: GHCVER=head + - env: GHCVER=7.8.1 before_install: - git clone http://github.com/diagrams/diagrams-travis travis From 63fe0ad4767f2a028f365472ddb52a24abe414d0 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 5 Mar 2014 17:28:54 -0500 Subject: [PATCH 22/77] CHANGES: note new splitFills function --- CHANGES.markdown | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/CHANGES.markdown b/CHANGES.markdown index 7ea0be94..21b4f59d 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -22,10 +22,14 @@ `basis` function from `diagrams-core - New 3D `Transform`s, alignment, and 3D-specific `Prelude`. - - - New `frame` function similar to `pad`, but increases the envelope + + - New `frame` function similar to `pad`, but increases the envelope of a diagram by an amount specified in local units in every direction - irrespective of the local origin. + irrespective of the local origin. + + - New `splitFills` function for pushing fill attributes down to + subtrees containing only loops (mostly of relevance only to + backend implementors). * **New instances** From b54f948e742da64686857846d0dbfa34b6ada33d Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 5 Mar 2014 23:44:48 +0000 Subject: [PATCH 23/77] travis: require ghc-7.8.1 to succeed, re-add HEAD [ci skip] --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index de4912d6..4eca1506 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,6 +7,7 @@ env: - GHCVER=7.4.2 - GHCVER=7.6.3 - GHCVER=7.8.1 + - GHCVER=HEAD global: - CABALVER=1.18 - HEAD_DEPS="diagrams-core" @@ -14,7 +15,6 @@ env: matrix: allow_failures: - env: GHCVER=head - - env: GHCVER=7.8.1 before_install: - git clone http://github.com/diagrams/diagrams-travis travis From 4b9d919a373e90a1c22f24747eb029d8c8e0c312 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Thu, 6 Mar 2014 00:35:24 +0000 Subject: [PATCH 24/77] travis: fix capitalization of GHC head [ci skip] --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 4eca1506..f2cc77c8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,7 +7,7 @@ env: - GHCVER=7.4.2 - GHCVER=7.6.3 - GHCVER=7.8.1 - - GHCVER=HEAD + - GHCVER=head global: - CABALVER=1.18 - HEAD_DEPS="diagrams-core" From ee18b88e7abfb8262496243c5f03c35b132afea0 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sat, 8 Mar 2014 20:27:07 -0500 Subject: [PATCH 25/77] CHANGES: 1.1 release date --- CHANGES.markdown | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGES.markdown b/CHANGES.markdown index 21b4f59d..0d2ea85d 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,5 +1,5 @@ -1.1 (XXX) ---------- +1.1 (8 March 2014) +------------------ * **New features** From 37e40335206aac443feec2ba16a01b9d055dd949 Mon Sep 17 00:00:00 2001 From: jeffreyrosenbluth Date: Sun, 9 Mar 2014 12:43:32 +0100 Subject: [PATCH 26/77] headWidth, tailWidth, widths --- src/Diagrams/TwoD.hs | 5 +++- src/Diagrams/TwoD/Arrow.hs | 59 +++++++++++++++++++++++++++----------- 2 files changed, 47 insertions(+), 17 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 2188edc7..6bd46984 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -150,7 +150,10 @@ module Diagrams.TwoD , arrowShaft , headSize , tailSize - , bothSize + , sizes + , headWidth + , tailWidth + , widths , headGap , tailGap , gap diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 7f4d4c61..6c35146f 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -78,7 +78,10 @@ module Diagrams.TwoD.Arrow , arrowShaft , headSize , tailSize - , bothSize + , sizes + , headWidth + , tailWidth + , widths , headGap , tailGap , gap @@ -98,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,25 +183,49 @@ headSize :: Lens' ArrowOpts Double -- | Radius of a circumcircle around the tail. tailSize :: Lens' ArrowOpts Double --- | Set the size of both the head and tail. The @headSize@ is set to the --- given value and the @tailSize@ is set so that it is the same width as --- the head. Both @arrowHead@ and @arrowTail@ should be set before using --- bothSize. -bothSize :: Traversal' ArrowOpts Double -bothSize f opts = - (\h t -> opts & headSize .~ h & tailSize .~ toTailSize opts t) +-- | 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 +--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 From 259419577434292a3dfafc39d6b7dfb8884900a7 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 14 Feb 2014 18:25:06 +0000 Subject: [PATCH 27/77] 3D colors, material reflectance closes #121 --- diagrams-lib.cabal | 1 + src/Diagrams/ThreeD.hs | 2 + src/Diagrams/ThreeD/Attributes.hs | 101 ++++++++++++++++++++++++++++++ 3 files changed, 104 insertions(+) create mode 100644 src/Diagrams/ThreeD/Attributes.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index acc0a5c6..7bc0f64f 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -75,6 +75,7 @@ Library Diagrams.TwoD.Image, Diagrams.TwoD.Adjust, Diagrams.ThreeD.Align, + Diagrams.ThreeD.Attributes, Diagrams.ThreeD.Camera, Diagrams.ThreeD.Deform, Diagrams.ThreeD.Light, diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index 3f973834..4687e408 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -32,6 +32,7 @@ ----------------------------------------------------------------------------- module Diagrams.ThreeD ( module Diagrams.ThreeD.Align + , module Diagrams.ThreeD.Attributes , module Diagrams.ThreeD.Camera , module Diagrams.ThreeD.Light , module Diagrams.ThreeD.Shapes @@ -41,6 +42,7 @@ module Diagrams.ThreeD ) where import Diagrams.ThreeD.Align +import Diagrams.ThreeD.Attributes import Diagrams.ThreeD.Camera import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs new file mode 100644 index 00000000..fbcd7758 --- /dev/null +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Attributes +-- Copyright : (c) 2014 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 some common attributes relevant in +-- 3D; particular backends may also define more backend-specific +-- attributes. +-- +-- Every attribute type must have a /semigroup/ structure, that is, an +-- associative binary operation for combining two attributes into one. +-- Unless otherwise noted, all the attributes defined here use the +-- 'Last' structure, that is, combining two attributes simply keeps +-- the second one and throws away the first. This means that child +-- attributes always override parent attributes. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Attributes where + +import Control.Lens +import Data.Semigroup +import Data.Typeable + +import Data.Colour + +import Diagrams.Attributes +import Diagrams.Core + +-- | @SurfaceColor@ is the inherent pigment of an object, assumed to +-- be opaque. +newtype SurfaceColor = SurfaceColor (Last (Colour Double)) + deriving (Typeable, Semigroup) +instance AttributeClass SurfaceColor + +surfaceColor :: Iso' SurfaceColor (Colour Double) +surfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) + +sc :: HasStyle d => Colour Double -> d -> d +sc = applyAttr . review surfaceColor + +-- | @Diffuse@ is the fraction of incident light reflected diffusely, +-- that is, in all directions. The actual light reflected is the +-- product of this value, the incident light, and the @SurfaceColor@ +-- Attribute. For physical reasonableness, @Diffuse@ should have a +-- value between 0 and 1; this is not checked. +newtype Diffuse = Diffuse (Last Double) + deriving (Typeable, Semigroup) +instance AttributeClass Diffuse + +_Diffuse :: Iso' Diffuse Double +_Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) + +diffuse :: HasStyle d => Double -> d -> d +diffuse = applyAttr . review _Diffuse + +-- | @Ambient@ is an ad-hoc representation of indirect lighting. The +-- product of @Ambient@ and @SurfaceColor@ is added to the light +-- leaving an object due to diffuse and specular terms. @Ambient@ can +-- be set per-object, and can be loosely thought of as the product of +-- indirect lighting incident on that object and the diffuse +-- reflectance. +newtype Ambient = Ambient (Last Double) + deriving (Typeable, Semigroup) +instance AttributeClass Ambient + +_Ambient :: Iso' Ambient Double +_Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last) + +ambient :: HasStyle d => Double -> d -> d +ambient = applyAttr . review _Ambient + +-- | A specular highlight has two terms, the intensity, between 0 and +-- 1, and the size. The highlight size is assumed to be the exponent +-- in a Phong shading model (though Backends are free to use a +-- different shading model). In this model, reasonable values are +-- between 1 and 50 or so, with higher values for shinier objects. +-- Physically, the intensity and the value of @Diffuse@ must add up to +-- less than 1; this is not enforced. +data Specular = Specular { _specularIntensity :: Double + , _specularSize :: Double + } + +makeLenses ''Specular + +newtype Highlight = Highlight (Last Specular) + deriving (Typeable, Semigroup) +instance AttributeClass Highlight + +_Highlight :: Iso' Highlight Specular +_Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) + +highlight :: HasStyle d => Specular -> d -> d +highlight = applyAttr . review _Highlight From d1806e413807d6259f1d13c0f0298a8f6794dcb7 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 24 Feb 2014 14:29:24 +0000 Subject: [PATCH 28/77] simpler angleBetween --- src/Diagrams/ThreeD/Vector.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 41dff9dd..6ab28669 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -76,7 +76,7 @@ fromDirection (toSpherical -> (Spherical θ' φ')) = r3 (x,y,z) where -- | compute the positive angle between the two vectors in their common plane angleBetween :: R3 -> R3 -> Angle -angleBetween v1 v2 = atan2 (magnitude $ cross3 v1 v2) (v1 <.> v2) @@ rad +angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad -- | compute the positive angle between the two vectors in their common plane angleBetweenDirs :: Direction d => d -> d -> Angle From 26807c2c2c0179750ca212c37dafaa2f80398273 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 14 Feb 2014 20:34:58 +0000 Subject: [PATCH 29/77] Add trig functions using Angle --- src/Diagrams/ThreeD/Types.hs | 1 + src/Diagrams/TwoD.hs | 1 + src/Diagrams/TwoD/Types.hs | 24 ++++++++++++++++++++++++ 3 files changed, 26 insertions(+) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index ae915382..c4340dc1 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -31,6 +31,7 @@ module Diagrams.ThreeD.Types -- reëxported here for convenience. , Angle, rad, turn, deg, (@@) , fullTurn, angleRatio + , sinA, cosA, tanA -- * Directions in 3D , Direction(..) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index fa9c6989..da641b67 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -72,6 +72,7 @@ module Diagrams.TwoD , Angle , rad, turn, deg , fullTurn, fullCircle, angleRatio + , sinA, cosA, tanA , (@@) -- * Paths diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index d1bf03cb..e45391dc 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -29,6 +29,7 @@ module Diagrams.TwoD.Types , Angle , rad, turn, deg , fullTurn, fullCircle, angleRatio + , sinA, cosA, tanA, asinA, acosA, atanA , (@@) ) where @@ -276,6 +277,29 @@ fullCircle = fullTurn angleRatio :: Angle -> Angle -> Double angleRatio a b = (a^.rad) / (b^.rad) +-- | The sine of the given @Angle@. +sinA :: Angle -> Double +sinA (Radians r) = sin r + +-- | The cosine of the given @Angle@. +cosA :: Angle -> Double +cosA (Radians r) = cos r + +-- | The tangent function of the given @Angle@. +tanA :: Angle -> Double +tanA (Radians r) = tan r + +-- | The @Angle@ with the given sine. +asinA :: Double -> Angle +asinA = Radians . asin + +-- | The @Angle@ with the given cosine. +acosA :: Double -> Angle +acosA = Radians . acos + +-- | The @Angle@ with the given tangent. +atanA :: Double -> Angle +atanA = Radians . atan -- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. -- From 44bdbad08da927e8290a6af46a5f877df71905c8 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 24 Feb 2014 17:16:37 +0000 Subject: [PATCH 30/77] lenses for polar coordinates 3D: spherical and cylindrical 2D: using the same type classes as cylindrical --- src/Diagrams/Coordinates.hs | 7 ++++- src/Diagrams/ThreeD/Types.hs | 54 ++++++++++++++++++++++++++++++++++++ src/Diagrams/TwoD/Types.hs | 35 ++++++++++++++++++++++- 3 files changed, 94 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 01e47fd6..bbb04278 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -16,7 +16,7 @@ module Diagrams.Coordinates ( (:&)(..), Coordinates(..) -- * Lenses for particular axes - , HasX(..), HasY(..), HasZ(..) + , HasX(..), HasY(..), HasZ(..), HasR(..) ) where @@ -121,3 +121,8 @@ class HasY t where -- | The class of types with at least three coordinates, the third called _z. class HasZ t where _z :: Lens' t Double + +-- | _r is the vector magnitude in 2D polar coordinates, or the +-- distance from the central axis in cylindrical coordinates. +class HasR t where + _r :: Lens' t Double diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index c4340dc1..ebf3bcc0 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -179,3 +179,57 @@ instance HasZ R3 where instance HasZ P3 where _z = p3Iso . _3 + +-- | Types which can be expressed in spherical 3D coordinates, as a +-- triple (r,θ,φ), where θ is rotation about the Z axis, and φ is the +-- angle from the Z axis. +class Spherical t where + spherical :: Iso' t (Double, Angle, Angle) + +-- | Types which can be expressed in cylindrical 3D coordinates. +class Cylindrical t where + cylindrical :: Iso' t (Double, Angle, Double) -- r, θ, z + +instance Cylindrical R3 where + cylindrical = iso (\(R3 x y z) -> (sqrt (x^2+y^2), atanA (y/x), z)) + (\(r,θ,z) -> R3 (r*cosA θ) (r*sinA θ) z) + +instance Spherical R3 where + spherical = iso + (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) + (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) + +instance Cylindrical t => HasR t where + _r = cylindrical . _1 + +instance Cylindrical t => HasTheta t where + _theta = cylindrical . _2 + +instance Spherical t => HasPhi t where + _phi = spherical . _3 + +-- not sure about exporting this +-- If we do want to export it, make it polymorphic, put it in Core.Points +_relative :: P3 -> Iso' P3 R3 +_relative p0 = iso (.-. p0) (p0 .+^) + +instance Cylindrical P3 where + cylindrical = _relative origin . cylindrical + +instance Spherical P3 where + spherical = _relative origin . spherical + +instance HasTheta Direction where + _theta = _Dir . _theta + +instance HasPhi Direction where + _phi = _Dir . _phi + +-- | @direction v@ is the direction in which @v@ points. Returns an +-- unspecified value when given the zero vector as input. +direction :: R3 -> Direction +direction = Direction + +-- | @fromDirection d@ is the unit vector in the direction @d@. +fromDirection :: Direction -> R3 +fromDirection (Direction v) = normalized v diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index e45391dc..6f1c7252 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -31,14 +31,17 @@ module Diagrams.TwoD.Types , fullTurn, fullCircle, angleRatio , sinA, cosA, tanA, asinA, acosA, atanA , (@@) + -- * Polar Coordinates + , HasTheta(..), HasPhi(..) ) where import Control.Lens (Iso', Wrapped(..), Rewrapped, iso - , review , (^.), _1, _2) + , review , (^.), _1, _2, Lens', lens) import Diagrams.Coordinates import Diagrams.Core +import Data.AffineSpace import Data.AffineSpace.Point import Data.Basis import Data.MemoTrie (HasTrie (..)) @@ -185,6 +188,13 @@ instance HasX R2 where instance HasY R2 where _y = r2Iso . _2 +instance HasTheta R2 where + _theta = lens (\v -> atanA (v^._y / v^._x)) + (\v θ -> let r = magnitude v in R2 (r * cosA θ) (r * sinA θ)) + +instance HasR R2 where + _r = lens magnitude (\v r -> let s = r/magnitude v in s *^ v) + -- | Points in R^2. This type is intentionally abstract. -- -- * To construct a point, use 'p2', or '^&' (see @@ -236,6 +246,18 @@ instance HasX P2 where instance HasY P2 where _y = p2Iso . _2 + +-- not sure about exporting this +-- If we do want to export it, make it polymorphic, put it in Core.Points +_relative :: P2 -> Iso' P2 R2 +_relative p0 = iso (.-. p0) (p0 .+^) + +instance HasR P2 where + _r = _relative origin . _r + +instance HasTheta P2 where + _theta = _relative origin . _theta + ------------------------------------------------------------ -- Angles @@ -311,3 +333,14 @@ atanA = Radians . atan a @@ i = review i a infixl 5 @@ + +------------------------------------------------------------ +-- Polar Coordinates + +-- | The class of types with at least one angle coordinate, called _theta. +class HasTheta t where + _theta :: Lens' t Angle + +-- | The class of types with at least two angle coordinates, the second called _phi. +class HasPhi t where + _phi :: Lens' t Angle From 1fea5fa3731a6987717f87091674865168599222 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 9 Mar 2014 15:47:39 -0400 Subject: [PATCH 31/77] allow vector-space-points-0.2 --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index acc0a5c6..4a3f2850 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -96,7 +96,7 @@ Library diagrams-core >= 1.1 && < 1.2, active >= 0.1 && < 0.2, vector-space >= 0.7.7 && < 0.9, - vector-space-points >= 0.1.2 && < 0.2, + vector-space-points >= 0.1.2 && < 0.3, MemoTrie >= 0.6 && < 0.7, colour >= 2.3.2 && < 2.4, data-default-class < 0.1, From 57b746ee7c4093adcb660e76c2b6c66c2bc3e4fc Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 9 Mar 2014 15:47:59 -0400 Subject: [PATCH 32/77] Bump version to 1.1.0.1 --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 4a3f2850..aa9b02d4 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 1.1 +Version: 1.1.0.1 Synopsis: Embedded domain-specific language for declarative graphics Description: Diagrams is a flexible, extensible EDSL for creating graphics of many types. Graphics can be created From 7614b82dcaf34b47abe39e61371ca24302fb5712 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 9 Mar 2014 15:48:13 -0400 Subject: [PATCH 33/77] Release notes for 1.1.0.1 --- CHANGES.markdown | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGES.markdown b/CHANGES.markdown index 0d2ea85d..4ea4a1d8 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,8 @@ +1.1.0.1 (9 March 2014) +---------------------- + + - Allow `vector-space-points-0.2` + 1.1 (8 March 2014) ------------------ From 7ff02639a2c5d8ec58d6ab56dd4e9a9524470bce Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 24 Feb 2014 18:45:45 +0000 Subject: [PATCH 34/77] make R3 strict data like R2 --- src/Diagrams/ThreeD/Types.hs | 39 +++++++++++++++++------------------- 1 file changed, 18 insertions(+), 21 deletions(-) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index ebf3bcc0..702044a1 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -21,7 +21,7 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space - R3, r3, unr3, mkR3 + R3(..), r3, unr3, mkR3 , P3, p3, unp3, mkP3 , T3 , r3Iso, p3Iso @@ -55,31 +55,28 @@ import Data.VectorSpace -- 3D Euclidean space -- | The three-dimensional Euclidean vector space R^3. -newtype R3 = R3 { unR3 :: (Double, Double, Double) } - deriving (AdditiveGroup, Eq, Ord, Show, Read) +data R3 = R3 !Double !Double !Double + deriving (Eq, Ord, Show, Read) r3Iso :: Iso' R3 (Double, Double, Double) -r3Iso = iso unR3 R3 +r3Iso = iso unr3 r3 -- | Construct a 3D vector from a triple of components. r3 :: (Double, Double, Double) -> R3 -r3 = R3 +r3 (x,y,z) = R3 x y z -- | Curried version of `r3`. mkR3 :: Double -> Double -> Double -> R3 -mkR3 x y z = r3 (x, y, z) +mkR3 = R3 -- | Convert a 3D vector back into a triple of components. unr3 :: R3 -> (Double, Double, Double) -unr3 = unR3 +unr3 (R3 x y z) = (x,y,z) --- | Lens wrapped isomorphisms for R3. -instance Wrapped R3 where - type Unwrapped R3 = (Double, Double, Double) - _Wrapped' = iso unr3 r3 - {-# INLINE _Wrapped' #-} - -instance Rewrapped R3 R3 +instance AdditiveGroup R3 where + zeroV = R3 0 0 0 + R3 x1 y1 z1 ^+^ R3 x2 y2 z2 = R3 (x1 + x2) (y1 + y2) (z1 + z2) + negateV (R3 x y z) = R3 (-x) (-y) (-z) type instance V R3 = R3 @@ -89,12 +86,12 @@ instance VectorSpace R3 where instance HasBasis R3 where type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) - basisValue = R3 . basisValue - decompose = decompose . unR3 - decompose' = decompose' . unR3 + basisValue = r3 . basisValue + decompose = decompose . unr3 + decompose' = decompose' . unr3 instance InnerSpace R3 where - (unR3 -> vec1) <.> (unR3 -> vec2) = vec1 <.> vec2 + (unr3 -> vec1) <.> (unr3 -> vec2) = vec1 <.> vec2 instance Coordinates R3 where type FinalCoord R3 = Double @@ -102,18 +99,18 @@ instance Coordinates R3 where type Decomposition R3 = Double :& Double :& Double (coords -> x :& y) ^& z = r3 (x,y,z) - coords (unR3 -> (x,y,z)) = x :& y :& z + coords (unr3 -> (x,y,z)) = x :& y :& z -- | Points in R^3. type P3 = Point R3 -- | Construct a 3D point from a triple of coordinates. p3 :: (Double, Double, Double) -> P3 -p3 = P . R3 +p3 = P . r3 -- | Convert a 3D point back into a triple of coordinates. unp3 :: P3 -> (Double, Double, Double) -unp3 = unR3 . unPoint +unp3 = unr3 . unPoint p3Iso :: Iso' P3 (Double, Double, Double) p3Iso = iso unp3 p3 From 216317fc87c2c4fee39ef7520c89b80d9c54f328 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 24 Feb 2014 18:46:05 +0000 Subject: [PATCH 35/77] Make Direction a type, not a type class --- src/Diagrams/ThreeD/Camera.hs | 6 ++-- src/Diagrams/ThreeD/Light.hs | 4 +-- src/Diagrams/ThreeD/Transform.hs | 15 +++++----- src/Diagrams/ThreeD/Types.hs | 49 ++++++++++---------------------- src/Diagrams/ThreeD/Vector.hs | 28 ++---------------- 5 files changed, 30 insertions(+), 72 deletions(-) diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index c6fb4318..d9d1ab10 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -119,13 +119,13 @@ mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- aspect ratio of 4:3, for VGA and similar computer resulotions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) -camForward :: Direction d => Camera l -> d +camForward :: Camera l -> Direction camForward = direction . forward -camUp :: Direction d => Camera l -> d +camUp :: Camera l -> Direction camUp = direction . up -camRight :: Direction d => Camera l -> d +camRight :: Camera l -> Direction camRight c = direction right where right = cross3 (forward c) (up c) diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index 25d12b6f..1340429c 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -51,8 +51,8 @@ pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty (Query . const . Any $ False) -- | Construct a Diagram with a single ParallelLight, which takes up no space. -parallelLight :: (Direction d, Backend b R3, Renderable ParallelLight b) - => d -- ^ The direction in which the light travels. +parallelLight :: (Backend b R3, Renderable ParallelLight b) + => Direction -- ^ The direction in which the light travels. -> Colour Double -- ^ The color of the light. -> Diagram b R3 parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 3c25c180..462a8517 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -102,11 +102,10 @@ aboutY ang = fromLinear r (linv r) where -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. -rotationAbout - :: Direction d - => P3 -- ^ origin of rotation - -> d -- ^ direction of rotation axis - -> Angle -- ^ angle of rotation +rotationAbout :: + P3 -- ^ origin of rotation + -> Direction -- ^ direction of rotation axis + -> Angle -- ^ angle of rotation -> T3 rotationAbout p d a = mconcat [translation (negateV t), @@ -128,7 +127,7 @@ rotationAbout p d a -- without tilting, it will be, otherwise if only tilting is -- necessary, no panning will occur. The tilt will always be between -- ± 1/4 turn. -pointAt :: Direction d => d -> d -> d -> T3 +pointAt :: Direction -> Direction -> Direction -> T3 pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors @@ -137,9 +136,9 @@ pointAt' :: R3 -> R3 -> R3 -> T3 pointAt' about initial final = tilt <> pan where inPanPlane = final ^-^ project final initial panAngle = angleBetween initial inPanPlane - pan = rotationAbout origin (direction about :: Spherical) panAngle + pan = rotationAbout origin (direction about) panAngle tiltAngle = angleBetween initial inPanPlane - tiltDir = direction $ cross3 inPanPlane about :: Spherical + tiltDir = direction $ cross3 inPanPlane about tilt = rotationAbout origin tiltDir tiltAngle -- Scaling ------------------------------------------------- diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 702044a1..0743b970 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,13 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Types @@ -31,21 +31,21 @@ module Diagrams.ThreeD.Types -- reëxported here for convenience. , Angle, rad, turn, deg, (@@) , fullTurn, angleRatio - , sinA, cosA, tanA + , sinA, cosA, tanA, asinA, acosA, atanA -- * Directions in 3D - , Direction(..) - , Spherical(..) - , asSpherical + , Direction, direction, fromDirection + , Spherical(..), Cylindrical(..) ) where import Control.Lens (Iso', iso, over, Wrapped(..), Rewrapped - , _1, _2, _3) + , _1, _2, _3, (^.)) import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.Coordinates +import Data.AffineSpace import Data.AffineSpace.Point import Data.Basis import Data.Cross @@ -131,33 +131,14 @@ instance HasCross3 R3 where -------------------------------------------------------------------------------- -- Direction --- | Direction is a type class representing directions in R3. The interface is --- based on that of the Angle class in 2D. - -class Direction d where - -- | Convert to spherical coördinates - toSpherical :: d -> Spherical - - -- | Convert from spherical coördinates - fromSpherical :: Spherical -> d - --- | A direction expressed as a pair of spherical coordinates. --- `Spherical 0 0` is the direction of `unitX`. The first coordinate --- represents rotation about the Z axis, the second rotation towards the Z axis. -data Spherical = Spherical Angle Angle - deriving (Show, Read, Eq) - -instance Direction Spherical where - toSpherical = id - fromSpherical = id - --- | The identity function with a restricted type, for conveniently --- restricting unwanted polymorphism. For example, @fromDirection --- . asSpherical . camForward@ gives a unit vector pointing in the --- direction of the camera view. Without @asSpherical@, the --- intermediate type would be ambiguous. -asSpherical :: Spherical -> Spherical -asSpherical = id +-- | A @Direction@ represents directions in R3. The constructor is +-- not exported; @Direction@s can be used with 'fromDirection' and the +-- lenses provided by its instances. +data Direction = Direction R3 + +-- | Not exported +_Dir :: Iso' Direction R3 +_Dir = iso (\(Direction v) -> v) Direction instance HasX R3 where _x = r3Iso . _1 diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 6ab28669..0d1c21f4 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -17,7 +17,7 @@ module Diagrams.ThreeD.Vector unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, -- * Converting between vectors and angles - direction, fromDirection, angleBetween, angleBetweenDirs + angleBetween, angleBetweenDirs ) where import Control.Lens ((^.)) @@ -52,32 +52,10 @@ unit_Y = 0 ^& (-1) ^& 0 unit_Z :: R3 unit_Z = 0 ^& 0 ^& (-1) - --- | @direction v@ is the direction in which @v@ points. Returns an --- unspecified value when given the zero vector as input. -direction :: Direction d => R3 -> d -direction v - | r == 0 = fromSpherical $ Spherical zero zero - | otherwise = fromSpherical $ Spherical θ φ where - r = magnitude v - (x,y,z) = unr3 v - φ = asin (z / r) @@ rad - θ = atan2 y x @@ rad - zero = 0 @@ rad - --- | @fromDirection d@ is the unit vector in the direction @d@. -fromDirection :: Direction d => d -> R3 -fromDirection (toSpherical -> (Spherical θ' φ')) = r3 (x,y,z) where - θ = θ'^.rad - φ = φ'^.rad - x = cos θ * cos φ - y = sin θ * cos φ - z = sin φ - -- | compute the positive angle between the two vectors in their common plane angleBetween :: R3 -> R3 -> Angle angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad --- | compute the positive angle between the two vectors in their common plane -angleBetweenDirs :: Direction d => d -> d -> Angle +-- | compute the positive angle between the two directions in their common plane +angleBetweenDirs :: Direction -> Direction -> Angle angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) From 03833af4409e299b138501b38cee65a6c97ab732 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 24 Feb 2014 14:32:37 +0000 Subject: [PATCH 36/77] Add Box --- src/Diagrams/ThreeD/Shapes.hs | 49 +++++++++++++++++++++++++++++++++-- 1 file changed, 47 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 80e6dae3..cfcca8b9 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -15,18 +15,24 @@ module Diagrams.ThreeD.Shapes ( - Ellipsoid(..) - , sphere + Ellipsoid(..), sphere + , Box(..), cube ) where import Data.Typeable +import Control.Applicative +import Control.Lens ((^.), review) +import Data.Semigroup import Data.AffineSpace import Data.Semigroup import Data.VectorSpace +import Diagrams.Coordinates import Diagrams.Core import Diagrams.Solve import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector +import Diagrams.TwoD.Types data Ellipsoid = Ellipsoid T3 deriving Typeable @@ -41,6 +47,7 @@ instance IsPrim Ellipsoid instance Renderable Ellipsoid NullBackend where render _ _ = mempty +-- | A sphere of radius 1 with its center at the origin. sphere :: (Backend b R3, Renderable Ellipsoid b) => Diagram b R3 sphere = mkQD (Prim $ Ellipsoid mempty) (mkEnvelope sphereEnv) @@ -54,3 +61,41 @@ sphere = mkQD (Prim $ Ellipsoid mempty) c = p' <.> p' - 1 p' = p .-. origin sphereQuery v = Any $ magnitudeSq (v .-. origin) <= 1 + +data Box = Box T3 + deriving (Typeable) + +type instance V Box = R3 + +instance Transformable Box where + transform t1 (Box t2) = Box (t1 <> t2) + +instance IsPrim Box + +instance Renderable Box NullBackend where + render _ _ = mempty + +-- | A cube with side length 1, in the positive octant, with one +-- vertex at the origin. +cube :: (Backend b R3, Renderable Box b) => Diagram b R3 +cube = mkQD (Prim $ Box mempty) + (mkEnvelope boxEnv) + (mkTrace boxTrace) + mempty + (Query boxQuery) + where + corners = mkR3 <$> [0,1] <*> [0,1] <*> [0,1] + boxEnv v = maximum (map (v <.>) corners) / magnitudeSq v + -- ts gives all intersections with the planes forming the box + -- filter keeps only those actually on the box surface + boxTrace p v = mkSortedList . filter (range . atT) $ ts where + (x0, y0, z0) = unp3 p + (vx, vy, vz) = unr3 v + intersections f d = case d of + 0 -> [] + _ -> [-f/d, (1-f)/d] + ts = concat $ zipWith intersections [x0,y0,z0] [vx,vy,vz] + atT t = p .+^ (t*^v) + range u = and [x >= 0, x <= 1, y >= 0, y <= 1, z >= 0, z <= 1] where + (x, y, z) = unp3 u + boxQuery = Any . range From 2e03decac42ac86ff9bebd7692599a2b833bee0f Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 24 Feb 2014 14:32:43 +0000 Subject: [PATCH 37/77] Add Frustum --- src/Diagrams/ThreeD/Shapes.hs | 68 ++++++++++++++++++++++++++++++++ src/Diagrams/ThreeD/Transform.hs | 2 +- 2 files changed, 69 insertions(+), 1 deletion(-) diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index cfcca8b9..a75d6a16 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -17,6 +17,7 @@ module Diagrams.ThreeD.Shapes ( Ellipsoid(..), sphere , Box(..), cube + , Frustum(..) , frustum, cone, cylinder ) where import Data.Typeable @@ -99,3 +100,70 @@ cube = mkQD (Prim $ Box mempty) range u = and [x >= 0, x <= 1, y >= 0, y <= 1, z >= 0, z <= 1] where (x, y, z) = unp3 u boxQuery = Any . range + +data Frustum = Frustum Double Double T3 + deriving (Typeable) + +type instance V Frustum = R3 + +instance Transformable Frustum where + transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) + +instance IsPrim Frustum + +instance Renderable Frustum NullBackend where + render _ _ = mempty + +-- | A frustum of a right circular cone. It has height 1 oriented +-- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. +-- 'cone' and 'cylinder' are special cases. +frustum :: (Backend b R3, Renderable Frustum b) => Double -> Double -> Diagram b R3 +frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) + (mkEnvelope frEnv) + (mkTrace frTrace) + mempty + (Query frQuery) + where + projectXY u = u ^-^ project unitZ u + frQuery p = Any $ x >= 0 && x <= 1 && a <= r where + (x, _, z) = unp3 p + r = r0 + (r1-r0)*z + v = p .-. origin + a = magnitude $ projectXY v + -- The plane containing v and the z axis intersects the frustum in a trapezoid + -- Test the four corners of this trapezoid; one must determine the Envelope + frEnv v = maximum . map (magnitude . project v . review cylindrical) $ corners + where + θ = v^._theta + corners = [(r1,θ,1), (-r1,θ,1), (r0,θ,0), (-r0,θ,0)] + -- The trace can intersect the sides of the cone or one of the end + -- caps The sides are described by a quadric equation; substitute + -- in the parametric form of the ray but disregard any + -- intersections outside z = [0,1] Similarly, find intersections + -- with the planes z=0, z=1, but disregard any r>r0, r>r1 + frTrace p v = mkSortedList $ filter zbounds (quadForm a b c) ++ ends + where + (px, py, pz) = unp3 p + (vx, vy, vz) = unr3 v + ray t = p .+^ t*^v + dr = r1-r0 + a = vx**2 + vy**2 - vz**2 * dr**2 + b = 2 * (px * vx + py * vy - (r0+pz*dr) * dr * vz) + c = px**2 + py**2 - (r0 + dr*pz)**2 + zbounds t = (ray t)^._z >= 0 && (ray t)^._z <= 1 + ends = concatMap cap [0,1] + cap z = if (ray t)^._r < r0 + z*dr + then [t] + else [] + where + t = (z - pz) / vz + +-- | A cone with its base centered on the origin, with radius 1 at the +-- base, height 1, and it's apex on the positive Z axis. +cone :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +cone = frustum 1 0 + +-- | A circular cylinder of radius 1 with one end cap centered on the +-- origin, and extending to Z=1. +cylinder :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +cylinder = frustum 1 1 diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 462a8517..a0b3fc82 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -260,4 +260,4 @@ reflectAbout p v = transform (reflectionAbout p v) -- useful for implementing backends. onBasis :: T3 -> ((R3, R3, R3), R3) onBasis t = ((x, y, z), v) - where ((x:y:z:[]), v) = T.onBasis t + where (x:y:z:[], v) = T.onBasis t From 1229c5532e29db0b16972a29cec739f508858393 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sun, 9 Mar 2014 21:26:21 +0000 Subject: [PATCH 38/77] Wall: remove extra imports --- src/Diagrams/ThreeD/Attributes.hs | 1 - src/Diagrams/ThreeD/Light.hs | 1 - src/Diagrams/ThreeD/Shapes.hs | 1 - src/Diagrams/ThreeD/Types.hs | 2 +- src/Diagrams/ThreeD/Vector.hs | 2 -- 5 files changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs index fbcd7758..6fbdb587 100644 --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -31,7 +31,6 @@ import Data.Typeable import Data.Colour -import Diagrams.Attributes import Diagrams.Core -- | @SurfaceColor@ is the inherent pigment of an object, assumed to diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index 1340429c..532612bd 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -22,7 +22,6 @@ import Data.Typeable import Diagrams.Core import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector data PointLight = PointLight P3 (Colour Double) deriving Typeable diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index a75d6a16..d4b030a5 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -23,7 +23,6 @@ module Diagrams.ThreeD.Shapes import Data.Typeable import Control.Applicative import Control.Lens ((^.), review) -import Data.Semigroup import Data.AffineSpace import Data.Semigroup diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 0743b970..88c45521 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -38,7 +38,7 @@ module Diagrams.ThreeD.Types , Spherical(..), Cylindrical(..) ) where -import Control.Lens (Iso', iso, over, Wrapped(..), Rewrapped +import Control.Lens (Iso', iso, over , _1, _2, _3, (^.)) import Diagrams.Core diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 0d1c21f4..aac540c4 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -20,9 +20,7 @@ module Diagrams.ThreeD.Vector angleBetween, angleBetweenDirs ) where -import Control.Lens ((^.)) import Data.VectorSpace -import Data.Cross import Diagrams.ThreeD.Types import Diagrams.Coordinates From ec8f0a9bdaac4c092d4713648b2d07c43924c380 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sun, 9 Mar 2014 21:31:18 +0000 Subject: [PATCH 39/77] explicit instances for HasPhi, HasR, HasTheta to avoid overlap --- src/Diagrams/ThreeD/Types.hs | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 88c45521..f683b085 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -169,7 +169,7 @@ class Cylindrical t where cylindrical :: Iso' t (Double, Angle, Double) -- r, θ, z instance Cylindrical R3 where - cylindrical = iso (\(R3 x y z) -> (sqrt (x^2+y^2), atanA (y/x), z)) + cylindrical = iso (\(R3 x y z) -> (sqrt (x^(2::Int)+y^(2::Int)), atanA (y/x), z)) (\(r,θ,z) -> R3 (r*cosA θ) (r*sinA θ) z) instance Spherical R3 where @@ -177,13 +177,25 @@ instance Spherical R3 where (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) -instance Cylindrical t => HasR t where +-- We'd like to write: instance Cylindrical t => HasR t +-- But GHC can't work out that the instance won't overlap. Just write them explicitly: + +instance HasR R3 where + _r = cylindrical . _1 + +instance HasR P3 where _r = cylindrical . _1 -instance Cylindrical t => HasTheta t where +instance HasTheta R3 where _theta = cylindrical . _2 -instance Spherical t => HasPhi t where +instance HasTheta P3 where + _theta = cylindrical . _2 + +instance HasPhi R3 where + _phi = spherical . _3 + +instance HasPhi P3 where _phi = spherical . _3 -- not sure about exporting this From 9148c6af32cfc95fbf0c20f3f299cd543b808112 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sun, 9 Mar 2014 21:37:45 +0000 Subject: [PATCH 40/77] make HasR _r lens be the vector magnitude This definition works in all vector spaces, and is probably more often useful. The cylindrical r is easy to refer to as cylindrical._1; it just happens that it was the case that motivated me to write these lenses. --- src/Diagrams/Coordinates.hs | 3 +-- src/Diagrams/ThreeD/Shapes.hs | 4 ++-- src/Diagrams/ThreeD/Types.hs | 6 +++--- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index bbb04278..b248d580 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -122,7 +122,6 @@ class HasY t where class HasZ t where _z :: Lens' t Double --- | _r is the vector magnitude in 2D polar coordinates, or the --- distance from the central axis in cylindrical coordinates. +-- | _r is the vector magnitude class HasR t where _r :: Lens' t Double diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index d4b030a5..21561481 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -22,7 +22,7 @@ module Diagrams.ThreeD.Shapes import Data.Typeable import Control.Applicative -import Control.Lens ((^.), review) +import Control.Lens ((^.), review, _1) import Data.AffineSpace import Data.Semigroup @@ -151,7 +151,7 @@ frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) c = px**2 + py**2 - (r0 + dr*pz)**2 zbounds t = (ray t)^._z >= 0 && (ray t)^._z <= 1 ends = concatMap cap [0,1] - cap z = if (ray t)^._r < r0 + z*dr + cap z = if (ray t)^.cylindrical._1 < r0 + z*dr then [t] else [] where diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index f683b085..91761d7f 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -177,14 +177,14 @@ instance Spherical R3 where (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) --- We'd like to write: instance Cylindrical t => HasR t +-- We'd like to write: instance Spherical t => HasR t -- But GHC can't work out that the instance won't overlap. Just write them explicitly: instance HasR R3 where - _r = cylindrical . _1 + _r = spherical . _1 instance HasR P3 where - _r = cylindrical . _1 + _r = spherical . _1 instance HasTheta R3 where _theta = cylindrical . _2 From c76595e453d39109b763f597716276a17cd1491d Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Mon, 10 Mar 2014 17:43:55 -0400 Subject: [PATCH 41/77] move avgScale to core --- src/Diagrams/TwoD/Transform.hs | 41 +--------------------------------- 1 file changed, 1 insertion(+), 40 deletions(-) diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 49e7fe39..9f71c4e4 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -47,7 +47,6 @@ module Diagrams.TwoD.Transform -- * Utilities , onBasis - , avgScale ) where import Diagrams.Core @@ -248,42 +247,4 @@ shearY = transform . shearingY -- is mostly useful for implementing backends. onBasis :: Transformation R2 -> ((R2, R2), R2) onBasis t = ((x, y), v) - where ((x:y:[]), v) = T.onBasis t - --- | Compute the \"average\" amount of scaling performed by a --- transformation. Satisfies the properties --- --- @ --- avgScale (scaling k) == k --- avgScale (t1 <> t2) == avgScale t1 * avgScale t2 --- @ --- --- Backends which do not support stroking in the context of an --- arbitrary transformation may instead call 'avgScale' on --- \"frozen\" transformations and multiply the line width by the --- resulting value. -avgScale :: T2 -> Double -avgScale t = sqrt (abs (x1*y2 - y1*x2)) - where ((unr2 -> (x1,y1), unr2 -> (x2,y2)), _) = onBasis t - -{- - -avgScale is computed as the square root of the positive -determinant. Proofs for the specified properties: - -1. sqrt (|det (scaling k)|) = sqrt (k^2) = k -2. sqrt (|det t1|) * sqrt (|det t2|) - = sqrt (|det t1| * |det t2|) - = sqrt (|det t1 * det t2|) - = sqrt (|det (t1 * t2)|) - -From wikipedia: - - A geometric interpretation can be given to the value of the - determinant of a square matrix with real entries: the absolute - value of the determinant gives the scale factor by which area or - volume (or a higher dimensional analogue) is multiplied under the - associated linear transformation, while its sign indicates whether - the transformation preserves orientation. - --} + where ((x:y:[]), v) = T.onBasis t \ No newline at end of file From debf974df0a8b55735a71458b2350607cd65030d Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 13:18:26 +0000 Subject: [PATCH 42/77] clean up R3 instances --- src/Diagrams/ThreeD/Types.hs | 15 ++++++++++----- src/Diagrams/TwoD/Types.hs | 6 +----- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 91761d7f..ff58e9fd 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -35,10 +35,10 @@ module Diagrams.ThreeD.Types -- * Directions in 3D , Direction, direction, fromDirection - , Spherical(..), Cylindrical(..) + , Spherical(..), Cylindrical(..), HasPhi(..) ) where -import Control.Lens (Iso', iso, over +import Control.Lens (Iso', Lens', iso, over , _1, _2, _3, (^.)) import Diagrams.Core @@ -91,15 +91,15 @@ instance HasBasis R3 where decompose' = decompose' . unr3 instance InnerSpace R3 where - (unr3 -> vec1) <.> (unr3 -> vec2) = vec1 <.> vec2 + (R3 x1 y1 z1) <.> (R3 x2 y2 z2) = x1*x2 + y1*y2 + z1*z2 instance Coordinates R3 where type FinalCoord R3 = Double type PrevDim R3 = R2 type Decomposition R3 = Double :& Double :& Double - (coords -> x :& y) ^& z = r3 (x,y,z) - coords (unr3 -> (x,y,z)) = x :& y :& z + (coords -> x :& y) ^& z = R3 x y z + coords (R3 x y z) = x :& y :& z -- | Points in R^3. type P3 = Point R3 @@ -192,6 +192,11 @@ instance HasTheta R3 where instance HasTheta P3 where _theta = cylindrical . _2 +-- | The class of types with at least two angle coordinates, the +-- second called _phi. +class HasPhi t where + _phi :: Lens' t Angle + instance HasPhi R3 where _phi = spherical . _3 diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 6f1c7252..c0579514 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -32,7 +32,7 @@ module Diagrams.TwoD.Types , sinA, cosA, tanA, asinA, acosA, atanA , (@@) -- * Polar Coordinates - , HasTheta(..), HasPhi(..) + , HasTheta(..) ) where import Control.Lens (Iso', Wrapped(..), Rewrapped, iso @@ -340,7 +340,3 @@ infixl 5 @@ -- | The class of types with at least one angle coordinate, called _theta. class HasTheta t where _theta :: Lens' t Angle - --- | The class of types with at least two angle coordinates, the second called _phi. -class HasPhi t where - _phi :: Lens' t Angle From 78c05225066e4ddac5ab121703795a1c8dcbae8a Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 13:19:06 +0000 Subject: [PATCH 43/77] Wall: remove unneeded import --- src/Diagrams/Combinators.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index f5939bf9..5f02316f 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -45,7 +45,6 @@ import Control.Lens (Lens', generateSignatures, lensField, import Data.AdditiveGroup import Data.AffineSpace ((.+^)) import Data.Default.Class -import Data.Proxy import Data.Semigroup import Data.VectorSpace From a52e8e51b5dc0b6f0675e171faa9ea1510c15a5e Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 13:18:50 +0000 Subject: [PATCH 44/77] generalize angleBetween for arbitrary InnerSpace --- src/Diagrams/ThreeD/Vector.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index aac540c4..349560b0 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -51,7 +51,7 @@ unit_Z :: R3 unit_Z = 0 ^& 0 ^& (-1) -- | compute the positive angle between the two vectors in their common plane -angleBetween :: R3 -> R3 -> Angle +angleBetween :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Angle angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad -- | compute the positive angle between the two directions in their common plane From e4312f0c8b50091736cb763b91028ea2ec67730c Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 13:37:07 +0000 Subject: [PATCH 45/77] move Angle definition to separate module Angle's aren't specific to R2, and this way 3D modules don't need to import from 2D. --- src/Diagrams/Angle.hs | 108 +++++++++++++++++++++++++++++++ src/Diagrams/ThreeD.hs | 5 +- src/Diagrams/ThreeD/Camera.hs | 1 + src/Diagrams/ThreeD/Shapes.hs | 2 +- src/Diagrams/ThreeD/Transform.hs | 1 + src/Diagrams/ThreeD/Types.hs | 10 +-- src/Diagrams/ThreeD/Vector.hs | 3 +- src/Diagrams/TwoD.hs | 1 + src/Diagrams/TwoD/Arc.hs | 1 + src/Diagrams/TwoD/Arrow.hs | 1 + src/Diagrams/TwoD/Arrowheads.hs | 1 + src/Diagrams/TwoD/Combinators.hs | 1 + src/Diagrams/TwoD/Ellipse.hs | 1 + src/Diagrams/TwoD/Polygons.hs | 1 + src/Diagrams/TwoD/Shapes.hs | 1 + src/Diagrams/TwoD/Transform.hs | 1 + src/Diagrams/TwoD/Types.hs | 94 +-------------------------- src/Diagrams/TwoD/Vector.hs | 2 + 18 files changed, 132 insertions(+), 103 deletions(-) create mode 100644 src/Diagrams/Angle.hs diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs new file mode 100644 index 00000000..592ab79f --- /dev/null +++ b/src/Diagrams/Angle.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Angle +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Type for representing angles, independent of vector-space +-- +----------------------------------------------------------------------------- + +module Diagrams.Angle + ( + Angle + , rad, turn, deg + , fullTurn, fullCircle, angleRatio + , sinA, cosA, tanA, asinA, acosA, atanA + , (@@) + , HasTheta(..) + ) where + +import Control.Lens (Iso', Lens', iso, review, (^.)) + -- , review , (^.), _1, _2, Lens', lens) + +import Data.VectorSpace + +-- | Angles can be expressed in a variety of units. Internally, +-- they are represented in radians. +newtype Angle = Radians Double + deriving (Read, Show, Eq, Ord, Enum, AdditiveGroup) + +instance VectorSpace Angle where + type Scalar Angle = Double + s *^ Radians t = Radians (s*t) + +-- | The radian measure of an @Angle@ @a@ can be accessed as @a +-- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. +rad :: Iso' Angle Double +rad = iso (\(Radians r) -> r) Radians + +-- | The measure of an @Angle@ @a@ in full circles can be accessed as +-- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as +-- @1/2 \@\@ turn@. +turn :: Iso' Angle Double +turn = iso (\(Radians r) -> r/2/pi) (Radians . (*(2*pi))) + +-- | The degree measure of an @Angle@ @a@ can be accessed as @a +-- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ +-- deg@. +deg :: Iso' Angle Double +deg = iso (\(Radians r) -> r/2/pi*360) (Radians . (*(2*pi/360))) + +-- | An angle representing one full turn. +fullTurn :: Angle +fullTurn = 1 @@ turn + +-- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. +fullCircle :: Angle +fullCircle = fullTurn + +-- | Calculate ratio between two angles. +angleRatio :: Angle -> Angle -> Double +angleRatio a b = (a^.rad) / (b^.rad) + +-- | The sine of the given @Angle@. +sinA :: Angle -> Double +sinA (Radians r) = sin r + +-- | The cosine of the given @Angle@. +cosA :: Angle -> Double +cosA (Radians r) = cos r + +-- | The tangent function of the given @Angle@. +tanA :: Angle -> Double +tanA (Radians r) = tan r + +-- | The @Angle@ with the given sine. +asinA :: Double -> Angle +asinA = Radians . asin + +-- | The @Angle@ with the given cosine. +acosA :: Double -> Angle +acosA = Radians . acos + +-- | The @Angle@ with the given tangent. +atanA :: Double -> Angle +atanA = Radians . atan + +-- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. +-- +-- More generally, @\@\@@ reverses the @Iso\'@ on its right, and +-- applies the @Iso\'@ to the value on the left. @Angle@s are the +-- motivating example where this order improves readability. +(@@) :: b -> Iso' a b -> a +-- The signature above is slightly specialized, in favor of readability +a @@ i = review i a + +infixl 5 @@ + +------------------------------------------------------------ +-- Polar Coordinates + +-- | The class of types with at least one angle coordinate, called _theta. +class HasTheta t where + _theta :: Lens' t Angle diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index 4687e408..8981c45d 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -31,7 +31,8 @@ -- for rendering 3D geometry to (2D) images. ----------------------------------------------------------------------------- module Diagrams.ThreeD - ( module Diagrams.ThreeD.Align + ( module Diagrams.Angle + , module Diagrams.ThreeD.Align , module Diagrams.ThreeD.Attributes , module Diagrams.ThreeD.Camera , module Diagrams.ThreeD.Light @@ -41,6 +42,8 @@ module Diagrams.ThreeD , module Diagrams.ThreeD.Vector ) where +import Diagrams.Angle + import Diagrams.ThreeD.Align import Diagrams.ThreeD.Attributes import Diagrams.ThreeD.Camera diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index d9d1ab10..e2eb2865 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -34,6 +34,7 @@ import Data.Cross import Data.Monoid import Data.Typeable +import Diagrams.Angle import Diagrams.Core import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 21561481..2c5f406e 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -32,7 +32,7 @@ import Diagrams.Core import Diagrams.Solve import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector -import Diagrams.TwoD.Types +import Diagrams.Angle data Ellipsoid = Ellipsoid T3 deriving Typeable diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index a0b3fc82..cbf87029 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -46,6 +46,7 @@ module Diagrams.ThreeD.Transform import Diagrams.Core import qualified Diagrams.Core.Transform as T +import Diagrams.Angle import Diagrams.Transform import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index ff58e9fd..907c839c 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -26,13 +26,6 @@ module Diagrams.ThreeD.Types , T3 , r3Iso, p3Iso - -- * Two-dimensional angles - -- | These are defined in "Diagrams.TwoD.Types" but - -- reëxported here for convenience. - , Angle, rad, turn, deg, (@@) - , fullTurn, angleRatio - , sinA, cosA, tanA, asinA, acosA, atanA - -- * Directions in 3D , Direction, direction, fromDirection , Spherical(..), Cylindrical(..), HasPhi(..) @@ -42,7 +35,8 @@ import Control.Lens (Iso', Lens', iso, over , _1, _2, _3, (^.)) import Diagrams.Core -import Diagrams.TwoD.Types +import Diagrams.Angle +import Diagrams.TwoD.Types (R2) import Diagrams.Coordinates import Data.AffineSpace diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 349560b0..d7369ea5 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -22,8 +22,9 @@ module Diagrams.ThreeD.Vector import Data.VectorSpace -import Diagrams.ThreeD.Types +import Diagrams.Angle import Diagrams.Coordinates +import Diagrams.ThreeD.Types -- | The unit vector in the positive X direction. diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index da641b67..ac9313dc 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -260,4 +260,5 @@ import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector +import Diagrams.Angle import Diagrams.Util (tau) diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index d22556a3..84aac3a5 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -23,6 +23,7 @@ module Diagrams.TwoD.Arc , annularWedge ) where +import Diagrams.Angle import Diagrams.Core import Diagrams.Located (at) import Diagrams.Segment diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index ec6f853c..549da7e6 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -115,6 +115,7 @@ import Diagrams.Attributes import Diagrams.Core import Diagrams.Core.Types (QDiaLeaf (..), mkQD') +import Diagrams.Angle import Diagrams.Parametric import Diagrams.Path import Diagrams.Solve (quadForm) diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 3c8caeae..ff27f4f3 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -63,6 +63,7 @@ import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) import Data.VectorSpace +import Diagrams.Angle import Diagrams.Core import Diagrams.CubicSpline (cubicSpline) import Diagrams.Path diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 6880b12c..ec34168f 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -45,6 +45,7 @@ import Data.VectorSpace import Diagrams.Core +import Diagrams.Angle import Diagrams.Attributes (fc, lw) import Diagrams.BoundingBox import Diagrams.Combinators diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index abdd7ff7..e0287875 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -26,6 +26,7 @@ import Data.AdditiveGroup import Diagrams.Core +import Diagrams.Angle import Diagrams.Located (at) import Diagrams.TrailLike import Diagrams.TwoD.Arc diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 3fa1a1ed..7879e7bc 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -60,6 +60,7 @@ import Data.AffineSpace ((.+^), (.-.)) import Data.Default.Class import Data.VectorSpace +import Diagrams.Angle import Diagrams.Core import Diagrams.Located import Diagrams.Path diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index 5eabf866..d49d4b87 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -47,6 +47,7 @@ module Diagrams.TwoD.Shapes import Diagrams.Core +import Diagrams.Angle import Diagrams.Located (at) import Diagrams.Path import Diagrams.Segment diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 49e7fe39..859ffea7 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -53,6 +53,7 @@ module Diagrams.TwoD.Transform import Diagrams.Core import qualified Diagrams.Core.Transform as T +import Diagrams.Angle import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index c0579514..23f52b3c 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -25,19 +25,12 @@ module Diagrams.TwoD.Types , P2, p2, mkP2, unp2, p2Iso , T2 - -- * Angles - , Angle - , rad, turn, deg - , fullTurn, fullCircle, angleRatio - , sinA, cosA, tanA, asinA, acosA, atanA - , (@@) - -- * Polar Coordinates - , HasTheta(..) ) where import Control.Lens (Iso', Wrapped(..), Rewrapped, iso - , review , (^.), _1, _2, Lens', lens) + , (^.), _1, _2, lens) +import Diagrams.Angle import Diagrams.Coordinates import Diagrams.Core @@ -257,86 +250,3 @@ instance HasR P2 where instance HasTheta P2 where _theta = _relative origin . _theta - ------------------------------------------------------------- --- Angles - --- | Angles can be expressed in a variety of units. Internally, --- they are represented in radians. -newtype Angle = Radians Double - deriving (Read, Show, Eq, Ord, Enum, AdditiveGroup) - -instance VectorSpace Angle where - type Scalar Angle = Double - s *^ Radians t = Radians (s*t) - --- | The radian measure of an @Angle@ @a@ can be accessed as @a --- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. -rad :: Iso' Angle Double -rad = iso (\(Radians r) -> r) Radians - --- | The measure of an @Angle@ @a@ in full circles can be accessed as --- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as --- @1/2 \@\@ turn@. -turn :: Iso' Angle Double -turn = iso (\(Radians r) -> r/2/pi) (Radians . (*(2*pi))) - --- | The degree measure of an @Angle@ @a@ can be accessed as @a --- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ --- deg@. -deg :: Iso' Angle Double -deg = iso (\(Radians r) -> r/2/pi*360) (Radians . (*(2*pi/360))) - --- | An angle representing one full turn. -fullTurn :: Angle -fullTurn = 1 @@ turn - --- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. -fullCircle :: Angle -fullCircle = fullTurn - --- | Calculate ratio between two angles. -angleRatio :: Angle -> Angle -> Double -angleRatio a b = (a^.rad) / (b^.rad) - --- | The sine of the given @Angle@. -sinA :: Angle -> Double -sinA (Radians r) = sin r - --- | The cosine of the given @Angle@. -cosA :: Angle -> Double -cosA (Radians r) = cos r - --- | The tangent function of the given @Angle@. -tanA :: Angle -> Double -tanA (Radians r) = tan r - --- | The @Angle@ with the given sine. -asinA :: Double -> Angle -asinA = Radians . asin - --- | The @Angle@ with the given cosine. -acosA :: Double -> Angle -acosA = Radians . acos - --- | The @Angle@ with the given tangent. -atanA :: Double -> Angle -atanA = Radians . atan - --- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. --- --- More generally, @\@\@@ reverses the @Iso\'@ on its right, and --- applies the @Iso\'@ to the value on the left. @Angle@s are the --- motivating example where this order improves readability. -(@@) :: b -> Iso' a b -> a --- The signature above is slightly specialized, in favor of readability -a @@ i = review i a - -infixl 5 @@ - ------------------------------------------------------------- --- Polar Coordinates - --- | The class of types with at least one angle coordinate, called _theta. -class HasTheta t where - _theta :: Lens' t Angle diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 9d4a7ee1..c0bb7960 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -25,6 +25,8 @@ module Diagrams.TwoD.Vector import Control.Lens ((^.)) import Data.AdditiveGroup import Data.VectorSpace ((<.>)) + +import Diagrams.Angle import Diagrams.TwoD.Types import Diagrams.Coordinates From 3ebb80dff23e75dac46e2f19a1570e53677a0458 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 13:43:46 +0000 Subject: [PATCH 46/77] move angleBetween to Diagrams.Angle and move 3D angleBetweenDir next to the definition of Direction type --- src/Diagrams/Angle.hs | 5 +++++ src/Diagrams/ThreeD/Transform.hs | 1 - src/Diagrams/ThreeD/Types.hs | 7 ++++++- src/Diagrams/ThreeD/Vector.hs | 14 -------------- src/Diagrams/TwoD/Vector.hs | 10 ---------- 5 files changed, 11 insertions(+), 26 deletions(-) diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 592ab79f..add94628 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -19,6 +19,7 @@ module Diagrams.Angle , fullTurn, fullCircle, angleRatio , sinA, cosA, tanA, asinA, acosA, atanA , (@@) + , angleBetween , HasTheta(..) ) where @@ -100,6 +101,10 @@ a @@ i = review i a infixl 5 @@ +-- | compute the positive angle between the two vectors in their common plane +angleBetween :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Angle +angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad + ------------------------------------------------------------ -- Polar Coordinates diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index cbf87029..7fff6a8f 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -49,7 +49,6 @@ import qualified Diagrams.Core.Transform as T import Diagrams.Angle import Diagrams.Transform import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector import Diagrams.Coordinates import Control.Lens (view, (*~), (//~)) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 907c839c..fa3fc38a 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -27,7 +27,8 @@ module Diagrams.ThreeD.Types , r3Iso, p3Iso -- * Directions in 3D - , Direction, direction, fromDirection + , Direction, direction, fromDirection, angleBetweenDirs + -- * other coördinate systems , Spherical(..), Cylindrical(..), HasPhi(..) ) where @@ -222,3 +223,7 @@ direction = Direction -- | @fromDirection d@ is the unit vector in the direction @d@. fromDirection :: Direction -> R3 fromDirection (Direction v) = normalized v + +-- | compute the positive angle between the two directions in their common plane +angleBetweenDirs :: Direction -> Direction -> Angle +angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index d7369ea5..975188b5 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -15,14 +15,8 @@ module Diagrams.ThreeD.Vector ( -- * Special 2D vectors unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, - - -- * Converting between vectors and angles - angleBetween, angleBetweenDirs ) where -import Data.VectorSpace - -import Diagrams.Angle import Diagrams.Coordinates import Diagrams.ThreeD.Types @@ -50,11 +44,3 @@ unit_Y = 0 ^& (-1) ^& 0 -- | The unit vector in the negative Z direction. unit_Z :: R3 unit_Z = 0 ^& 0 ^& (-1) - --- | compute the positive angle between the two vectors in their common plane -angleBetween :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Angle -angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad - --- | compute the positive angle between the two directions in their common plane -angleBetweenDirs :: Direction -> Direction -> Angle -angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index c0bb7960..4c3ecc85 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -23,7 +23,6 @@ module Diagrams.TwoD.Vector ) where import Control.Lens ((^.)) -import Data.AdditiveGroup import Data.VectorSpace ((<.>)) import Diagrams.Angle @@ -52,15 +51,6 @@ unit_Y = 0 ^& (-1) direction :: R2 -> Angle direction (coords -> x :& y) = atan2 y x @@ rad --- | Compute the counterclockwise angle from the first vector to the second. -angleBetween :: R2 -> R2 -> Angle -angleBetween v1 v2 - | d2 > d1 = d2 ^-^ d1 - | otherwise = fullTurn ^+^ d2 ^-^ d1 - where - d1 = direction v1 - d2 = direction v2 - -- | Convert an angle into a unit vector pointing in that direction. fromDirection :: Angle -> R2 fromDirection a = cos a' ^& sin a' From daca572a028702167eb558c58760eae29fdb73c7 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 16:48:54 +0000 Subject: [PATCH 47/77] export more Angle functions from TwoD.hs --- src/Diagrams/TwoD.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index ac9313dc..fdf3232c 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -65,15 +65,17 @@ module Diagrams.TwoD , P2, p2, unp2, mkP2 , T2 , unitX, unitY, unit_X, unit_Y - , direction, angleBetween, fromDirection + , direction, fromDirection -- * Angles , tau , Angle , rad, turn, deg , fullTurn, fullCircle, angleRatio - , sinA, cosA, tanA + , sinA, cosA, tanA, asinA, acosA, atanA , (@@) + , angleBetween + , HasTheta(..) -- * Paths -- ** Stroking From d7a09ea6e7c44fd936a26cca8c1025ed28dcfb38 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 16:49:36 +0000 Subject: [PATCH 48/77] import Data.Proxy iff GHC < 7.7 --- src/Diagrams/Combinators.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 5f02316f..96224ab8 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} @@ -45,6 +46,9 @@ import Control.Lens (Lens', generateSignatures, lensField, import Data.AdditiveGroup import Data.AffineSpace ((.+^)) import Data.Default.Class +#if __GLASGOW_HASKELL__ < 707 +import Data.Proxy +#endif import Data.Semigroup import Data.VectorSpace From 7b356a7127e0a13fde9d7960f7a797cc6c300647 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 17:05:52 +0000 Subject: [PATCH 49/77] Better Haddock comments for 3D attributes, _r Lens --- diagrams-lib.cabal | 1 + src/Diagrams/Coordinates.hs | 3 ++- src/Diagrams/ThreeD/Attributes.hs | 4 ++++ 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 7bc0f64f..a3a2dee7 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -28,6 +28,7 @@ Library Exposed-modules: Diagrams.Prelude, Diagrams.Prelude.ThreeD, Diagrams.Align, + Diagrams.Angle, Diagrams.Combinators, Diagrams.Coordinates, Diagrams.Attributes, diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index b248d580..11065a61 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -122,6 +122,7 @@ class HasY t where class HasZ t where _z :: Lens' t Double --- | _r is the vector magnitude +-- | The class of types with a single length coordinate _r. _r is +-- magnitude of a vector, or the distance from the origin of a point. class HasR t where _r :: Lens' t Double diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs index 6fbdb587..52c013ef 100644 --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -42,6 +42,7 @@ instance AttributeClass SurfaceColor surfaceColor :: Iso' SurfaceColor (Colour Double) surfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) +-- | Set the surface color. sc :: HasStyle d => Colour Double -> d -> d sc = applyAttr . review surfaceColor @@ -57,6 +58,7 @@ instance AttributeClass Diffuse _Diffuse :: Iso' Diffuse Double _Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) +-- | Set the diffuse reflectance. diffuse :: HasStyle d => Double -> d -> d diffuse = applyAttr . review _Diffuse @@ -73,6 +75,7 @@ instance AttributeClass Ambient _Ambient :: Iso' Ambient Double _Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last) +-- | Set the emittance due to ambient light. ambient :: HasStyle d => Double -> d -> d ambient = applyAttr . review _Ambient @@ -96,5 +99,6 @@ instance AttributeClass Highlight _Highlight :: Iso' Highlight Specular _Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) +-- | Set the specular highlight. highlight :: HasStyle d => Specular -> d -> d highlight = applyAttr . review _Highlight From e1897ca10fccae1bb728bcb1e44e067522229382 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 18:17:28 +0000 Subject: [PATCH 50/77] Use _relative from Diagrams.Core --- src/Diagrams/ThreeD/Types.hs | 5 ----- src/Diagrams/TwoD/Types.hs | 5 ----- 2 files changed, 10 deletions(-) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index fa3fc38a..0083f6c3 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -198,11 +198,6 @@ instance HasPhi R3 where instance HasPhi P3 where _phi = spherical . _3 --- not sure about exporting this --- If we do want to export it, make it polymorphic, put it in Core.Points -_relative :: P3 -> Iso' P3 R3 -_relative p0 = iso (.-. p0) (p0 .+^) - instance Cylindrical P3 where cylindrical = _relative origin . cylindrical diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 23f52b3c..555ecc14 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -240,11 +240,6 @@ instance HasX P2 where instance HasY P2 where _y = p2Iso . _2 --- not sure about exporting this --- If we do want to export it, make it polymorphic, put it in Core.Points -_relative :: P2 -> Iso' P2 R2 -_relative p0 = iso (.-. p0) (p0 .+^) - instance HasR P2 where _r = _relative origin . _r From 49d298f9e7f62a72133274890673b3b3f3c5964b Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Mar 2014 19:15:06 +0000 Subject: [PATCH 51/77] Wall: remove AffineSpace import --- src/Diagrams/ThreeD/Types.hs | 1 - src/Diagrams/TwoD/Types.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 0083f6c3..07855025 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -40,7 +40,6 @@ import Diagrams.Angle import Diagrams.TwoD.Types (R2) import Diagrams.Coordinates -import Data.AffineSpace import Data.AffineSpace.Point import Data.Basis import Data.Cross diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 555ecc14..66943a83 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -34,7 +34,6 @@ import Diagrams.Angle import Diagrams.Coordinates import Diagrams.Core -import Data.AffineSpace import Data.AffineSpace.Point import Data.Basis import Data.MemoTrie (HasTrie (..)) From f86249c312fdb401853d5e90449d34d60893b307 Mon Sep 17 00:00:00 2001 From: John Lato Date: Wed, 12 Mar 2014 08:21:30 +0900 Subject: [PATCH 52/77] Segment: clean up ghc-7.8 warnings --- src/Diagrams/Segment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index bfaea3f0..c77469a2 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -493,7 +493,7 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) = let !negOff = negateV . op TotalOffset $ o1 e2Off = moveOriginBy negOff e2 - !() = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off + !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off in OffsetEnvelope (o1 <> o2) (e1 <> e2Off) From 77480c05366b045b02f8b2c29d2185496ae3a308 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 12 Mar 2014 01:18:11 +0000 Subject: [PATCH 53/77] Export Angle module from Prelude instead of TwoD --- src/Diagrams/Prelude.hs | 5 ++++- src/Diagrams/Prelude/ThreeD.hs | 6 +++++- src/Diagrams/ThreeD.hs | 6 ++---- src/Diagrams/TwoD.hs | 8 -------- 4 files changed, 11 insertions(+), 14 deletions(-) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 2ca15805..ad0ccd53 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -84,8 +84,10 @@ module Diagrams.Prelude -- | Utilities for working with points. , module Diagrams.Points + -- | Angles + , module Diagrams.Angle -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates + , module Diagrams.Coordinates -- | A wide range of things (shapes, transformations, -- combinators) specific to creating two-dimensional @@ -123,6 +125,7 @@ module Diagrams.Prelude import Diagrams.Core import Diagrams.Align +import Diagrams.Angle import Diagrams.Animation import Diagrams.Attributes import Diagrams.Combinators diff --git a/src/Diagrams/Prelude/ThreeD.hs b/src/Diagrams/Prelude/ThreeD.hs index 082150b6..0f1f91d2 100644 --- a/src/Diagrams/Prelude/ThreeD.hs +++ b/src/Diagrams/Prelude/ThreeD.hs @@ -80,8 +80,11 @@ module Diagrams.Prelude.ThreeD -- | Utilities for working with points. , module Diagrams.Points + -- | Angles + , module Diagrams.Angle + -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates + , module Diagrams.Coordinates -- | things (shapes, transformations, combinators) specific -- to creating three-dimensional diagrams. @@ -118,6 +121,7 @@ module Diagrams.Prelude.ThreeD import Diagrams.Core import Diagrams.Align +import Diagrams.Angle import Diagrams.Animation import Diagrams.Attributes import Diagrams.Combinators diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index 8981c45d..2f342a51 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -31,8 +31,8 @@ -- for rendering 3D geometry to (2D) images. ----------------------------------------------------------------------------- module Diagrams.ThreeD - ( module Diagrams.Angle - , module Diagrams.ThreeD.Align + ( + module Diagrams.ThreeD.Align , module Diagrams.ThreeD.Attributes , module Diagrams.ThreeD.Camera , module Diagrams.ThreeD.Light @@ -42,8 +42,6 @@ module Diagrams.ThreeD , module Diagrams.ThreeD.Vector ) where -import Diagrams.Angle - import Diagrams.ThreeD.Align import Diagrams.ThreeD.Attributes import Diagrams.ThreeD.Camera diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index fdf3232c..c304e37e 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -69,13 +69,6 @@ module Diagrams.TwoD -- * Angles , tau - , Angle - , rad, turn, deg - , fullTurn, fullCircle, angleRatio - , sinA, cosA, tanA, asinA, acosA, atanA - , (@@) - , angleBetween - , HasTheta(..) -- * Paths -- ** Stroking @@ -262,5 +255,4 @@ import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Diagrams.Angle import Diagrams.Util (tau) From b65dccb1b6e0c5e2e35b3dab11476613dd961fa4 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 12 Mar 2014 07:05:31 -0400 Subject: [PATCH 54/77] Wall: remove redundant import --- src/Diagrams/TwoD/Arrow.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 238d9092..783a85a1 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -101,7 +101,7 @@ module Diagrams.TwoD.Arrow import Control.Applicative ((<*>)) import Control.Arrow (first) import Control.Lens (Lens', Setter', Traversal', - sets, generateSignatures, + generateSignatures, lensRules, makeLensesWith, (%~), (&), (.~), (^.)) import Data.AffineSpace From a325a06524bb72aa6765bf3255a972e66076e8cb Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 12 Mar 2014 15:55:53 -0400 Subject: [PATCH 55/77] Revert "Manually written Transformable instance for SegTree" This reverts commit 34b8929083da850f6060370853e89d1ca7c5eeb3. In the end 7.8.1 actually supports this derived instance, without the need for a manual instance due to role restrictions. Conflicts: src/Diagrams/Trail.hs --- src/Diagrams/Trail.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index b28a05da..71aec3c6 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -163,10 +163,8 @@ deriving instance (OrderedField (Scalar v), InnerSpace v) => Monoid (SegTree v) deriving instance (OrderedField (Scalar v), InnerSpace v) => FT.Measured (SegMeasure v) (SegTree v) - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (SegTree v) where - transform t = SegTree . transform t . op SegTree +deriving instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Transformable (SegTree v) type instance Codomain (SegTree v) = v From 792bb5efade362bf9aa03384561abfddb398bc26 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Thu, 13 Mar 2014 15:18:31 -0400 Subject: [PATCH 56/77] Remove extraneous comments --- src/Diagrams/TwoD/Arrow.hs | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 783a85a1..1b370ddd 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -214,20 +214,9 @@ widths f 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) + (\h t -> opts & headSize .~ h & tailSize .~ 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 From 2b1e1b862b70586915c21f7c76196b3a53ec27de Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Thu, 13 Mar 2014 17:02:39 -0400 Subject: [PATCH 57/77] Add `gaps` as synonym for `gap` --- src/Diagrams/TwoD/Arrow.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 1b370ddd..a47d4b31 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -84,7 +84,7 @@ module Diagrams.TwoD.Arrow , widths , headGap , tailGap - , gap + , gaps, gap , headColor , headStyle , tailColor @@ -224,8 +224,12 @@ headGap :: Lens' ArrowOpts Double tailGap :: Lens' ArrowOpts Double -- | Set both the @headGap@ and @tailGap@ simultaneously. +gaps :: Traversal' ArrowOpts Double +gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) + +-- | Same as gaps, provided for backward compatiiblity. gap :: Traversal' ArrowOpts Double -gap f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) +gap = gaps -- | Style to apply to the head. @headStyle@ is modified by using the lens -- combinator @%~@ to change the current style. For example, to change From aafd919b3506314ffa6789ac9570d1a4db761989 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Thu, 13 Mar 2014 17:03:45 -0400 Subject: [PATCH 58/77] Added gaps --- src/Diagrams/TwoD.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 988caa7d..2124c4f6 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -152,7 +152,7 @@ module Diagrams.TwoD , widths , headGap , tailGap - , gap + , gaps, gap , headColor , headStyle , tailColor From bf635ff1c698265680abad7af5168ae9145cd25a Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 18 Mar 2014 20:32:44 -0400 Subject: [PATCH 59/77] allow optparse-applicative-0.8 --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 77ff01f7..8f856f94 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -107,7 +107,7 @@ Library intervals >= 0.3 && < 0.5, lens >= 4.0 && < 4.1, tagged >= 0.7, - optparse-applicative >= 0.7 && < 0.8, + optparse-applicative >= 0.7 && < 0.9, filepath, safe >= 0.2 && < 0.4, hashable >= 1.1 && < 1.3 From a5d2c62031596a1d407cfed6fc0497793af81d0a Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 18 Mar 2014 21:03:59 -0400 Subject: [PATCH 60/77] Release notes for 1.1.0.2 --- CHANGES.markdown | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGES.markdown b/CHANGES.markdown index 4ea4a1d8..49053225 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,8 @@ +1.1.0.2 (18 March 2014) +----------------------- + + - Allow `optparse-applicative-0.8` + 1.1.0.1 (9 March 2014) ---------------------- From 91aa8096d6229b911c6a536b0fa968fe8cc2c908 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 19 Mar 2014 17:44:03 +0000 Subject: [PATCH 61/77] allow lens-4.1 --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 8f856f94..146d135d 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -105,7 +105,7 @@ Library pretty >= 1.0.1.2 && < 1.2, fingertree >= 0.1 && < 0.2, intervals >= 0.3 && < 0.5, - lens >= 4.0 && < 4.1, + lens >= 4.0 && < 4.2, tagged >= 0.7, optparse-applicative >= 0.7 && < 0.9, filepath, From 4e6d1258b5b8a96678632770720720d5474cc201 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 19 Mar 2014 14:55:00 -0400 Subject: [PATCH 62/77] give connectOutside a reasonable behavior even when one or both endpoints has no trace It used to simply draw no arrow if either trace returned Nothing. A better default is to simply use the location of the endpoint instead. This way an arrow is *always* drawn. It also allows things like drawing an arrow between a named point (which has no trace) and the boundary of some object. --- src/Diagrams/TwoD/Arrow.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index a47d4b31..d7272f4c 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -573,9 +573,7 @@ connectOutside' opts n1 n2 = withName n2 $ \b2 -> let v = location b2 .-. location b1 midpoint = location b1 .+^ (v/2) - s' = traceP midpoint (-v) b1 - e' = traceP midpoint v b2 + s' = fromMaybe (location b1) $ traceP midpoint (-v) b1 + e' = fromMaybe (location b2) $ traceP midpoint v b2 in - case (s', e') of - (Just s, Just e) -> atop (arrowBetween' opts s e) - (_, _) -> id + atop (arrowBetween' opts s' e') From 0297bb34f5566e67f5b78089f98c87d565ac6c16 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 19 Mar 2014 18:25:34 +0000 Subject: [PATCH 63/77] CHANGES for 1.1.0.3 [ci-skip] --- CHANGES.markdown | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGES.markdown b/CHANGES.markdown index 49053225..6d020ad9 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,8 @@ +1.1.0.3 (19 March 2014) +---------------------- + + - Allow `lens-4.1` + 1.1.0.2 (18 March 2014) ----------------------- From 0acad55532d04529b423eb708202d78d9497b30e Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Thu, 20 Mar 2014 03:23:17 -0400 Subject: [PATCH 64/77] trailLocSegments, pathLocSegments --- src/Diagrams/Path.hs | 5 +++++ src/Diagrams/Trail.hs | 10 +++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 5bd0f07d..0ac6e8f9 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -189,6 +189,11 @@ pathOffsets = map (trailOffset . unLoc) . op Path pathCentroid :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Point v pathCentroid = centroid . concat . pathVertices +-- | Convert a path into a list of lists of located segments. +pathLocSegments :: (InnerSpace v, OrderedField (Scalar v)) + => Path v -> [[Located (Segment Closed v)]] +pathLocSegments = map trailLocSegments . op Path + -- | Convert a path into a list of lists of 'FixedSegment's. fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] fixPath = map fixTrail . op Path diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 71aec3c6..e7b14a41 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -77,7 +77,7 @@ module Diagrams.Trail , trailOffsets, trailOffset , lineOffsets, lineOffset, loopOffsets , trailVertices, lineVertices, loopVertices - , fixTrail + , trailLocSegments, fixTrail -- * Modifying trails @@ -991,8 +991,12 @@ segmentVertices p = scanl (.+^) p . map segOffset -- | Convert a concretely located trail into a list of fixed segments. fixTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [FixedSegment v] -fixTrail t = zipWith ((mkFixedSeg .) . at) - (trailSegments (unLoc t)) (trailVertices t) +fixTrail t = map mkFixedSeg (trailLocSegments t) + +-- | Convert a concretely located trail into a list of fixed segments. +trailLocSegments :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail v) -> [Located (Segment Closed v)] +trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailVertices t) ------------------------------------------------------------ -- Modifying trails -------------------------------------- From efdfe0cb739028cac66fbdf09c834e0169e6c08d Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Thu, 20 Mar 2014 03:25:12 -0400 Subject: [PATCH 65/77] fixed comment --- src/Diagrams/Trail.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index e7b14a41..a7c2e837 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -993,7 +993,7 @@ fixTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [FixedSegment v] fixTrail t = map mkFixedSeg (trailLocSegments t) --- | Convert a concretely located trail into a list of fixed segments. +-- | Convert a concretely located trail into a list of located segments. trailLocSegments :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [Located (Segment Closed v)] trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailVertices t) From 0cae89a7255b6a5ff391369a24e2ba8372ac9578 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Thu, 20 Mar 2014 03:42:37 -0400 Subject: [PATCH 66/77] export pathLocSegments --- src/Diagrams/Path.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 0ac6e8f9..4b1b27bb 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -44,7 +44,7 @@ module Diagrams.Path , pathVertices , pathOffsets , pathCentroid - , fixPath + , pathLocSegments, fixPath -- * Modifying paths From 7bcf0a5c57afb1072674037b60eaea403d922b24 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 21 Mar 2014 02:32:38 +0000 Subject: [PATCH 67/77] Arrowtest: update to use Angle type --- test/Arrowtest.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/Arrowtest.hs b/test/Arrowtest.hs index c738561d..04c33a08 100644 --- a/test/Arrowtest.hs +++ b/test/Arrowtest.hs @@ -43,8 +43,8 @@ example = d # connect' (with & arrowHead .~ dart & arrowTail .~ noTail & shaftStyle %~ dashing [0.1,0.2,0.3,0.1] 0) "8" "9" where c = circle 1 # showOrigin # lw 0.02 - a = arc (5/12 :: Turn) (11/12 :: Turn) - a1 = arc (1/2 :: Turn) (3/4 :: Turn) + a = arc (5/12 @@ turn) (11/12 @@ turn) + a1 = arc (1/2 @@ turn) (3/4 @@ turn) t = bezier3 (r2 (1,1)) (r2 (1,1)) (r2 (0,2)) t' = reflectX t l = straight unitX @@ -66,4 +66,4 @@ example = d # connect' (with & arrowHead .~ dart & arrowTail .~ noTail === row3 -main = defaultMain $ ( example # centerXY) # pad 1.1 \ No newline at end of file +main = defaultMain $ ( example # centerXY) # pad 1.1 From bd4b3a30eb9fe399951c4e05b89d84c5c90ad101 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 25 Mar 2014 08:12:28 -0400 Subject: [PATCH 68/77] progress on units * move toOutput to generic version in -core * add some Data instances * make lineWidth a "generic" attribute * misc fixes required after merging master --- diagrams-lib.cabal | 1 - src/Diagrams/Attributes/Compile.hs | 2 +- src/Diagrams/Backend/Show.hs | 3 +- src/Diagrams/ThreeD/Shapes.hs | 10 ++---- src/Diagrams/TwoD.hs | 3 -- src/Diagrams/TwoD/Arrow.hs | 2 +- src/Diagrams/TwoD/Attributes.hs | 13 ++++--- src/Diagrams/TwoD/Combinators.hs | 4 +-- src/Diagrams/TwoD/Compile.hs | 58 ------------------------------ src/Diagrams/TwoD/Path.hs | 6 ++-- src/Diagrams/TwoD/Types.hs | 10 +++--- 11 files changed, 22 insertions(+), 90 deletions(-) delete mode 100644 src/Diagrams/TwoD/Compile.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 84497044..5faca040 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -65,7 +65,6 @@ Library Diagrams.TwoD.Ellipse, Diagrams.TwoD.Arc, Diagrams.TwoD.Segment, - Diagrams.TwoD.Compile, Diagrams.TwoD.Curvature, Diagrams.TwoD.Offset, Diagrams.TwoD.Path, diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs index 820cbe8d..8daa8028 100644 --- a/src/Diagrams/Attributes/Compile.hs +++ b/src/Diagrams/Attributes/Compile.hs @@ -83,7 +83,7 @@ splitAttr code = fst . splitAttr' Nothing -- * is some sort of prim not under consideration: don't apply the attribute; return True -- * is unsafe: don't apply the attribute; return False -- * is safe : do apply the attribute; return True - splitAttr' mattr (Node rp@(RPrim _ (Prim prm)) _) = + splitAttr' mattr (Node rp@(RPrim (Prim prm)) _) = case cast prm :: Maybe (PrimType code) of Nothing -> (Node rp [], True) Just p -> diff --git a/src/Diagrams/Backend/Show.hs b/src/Diagrams/Backend/Show.hs index e45dcb82..1aef14b9 100644 --- a/src/Diagrams/Backend/Show.hs +++ b/src/Diagrams/Backend/Show.hs @@ -36,8 +36,7 @@ instance HasLinearMap v => Backend ShowBackend v where data Options ShowBackend v = SBOpt doRender _ _ (SR r) = PP.render r - renderRTree _ = SR empty - renderData _ _ _ _ = SR empty + renderData _ _ _ = SR empty instance Monoid (Render ShowBackend v) where mempty = SR empty diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index d474750f..e524068c 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -20,19 +20,19 @@ module Diagrams.ThreeD.Shapes , Frustum(..) , frustum, cone, cylinder ) where -import Data.Typeable import Control.Applicative -import Control.Lens ((^.), review, _1) +import Control.Lens (review, (^.), _1) +import Data.Typeable import Data.AffineSpace import Data.Semigroup import Data.VectorSpace +import Diagrams.Angle import Diagrams.Coordinates import Diagrams.Core import Diagrams.Solve import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector -import Diagrams.Angle data Ellipsoid = Ellipsoid T3 deriving Typeable @@ -68,8 +68,6 @@ type instance V Box = R3 instance Transformable Box where transform t1 (Box t2) = Box (t1 <> t2) -instance IsPrim Box - instance Renderable Box NullBackend where render _ _ = mempty @@ -106,8 +104,6 @@ type instance V Frustum = R3 instance Transformable Frustum where transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) -instance IsPrim Frustum - instance Renderable Frustum NullBackend where render _ _ = mempty diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index f97964cf..e9383e00 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -232,8 +232,6 @@ module Diagrams.TwoD -- ** Width , LineWidth, getLineWidth, lineWidth, lineWidthA, lw, lwN, lwO, lwL , ultraThin, veryThin, thin, medium, thick, veryThick - -- * Measure conversion - , toOutput -- * Visual aids for understanding the internal model , showOrigin @@ -249,7 +247,6 @@ import Diagrams.TwoD.Arrow import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Attributes import Diagrams.TwoD.Combinators -import Diagrams.TwoD.Compile import Diagrams.TwoD.Deform import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Image diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index dad488ad..acde5974 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -126,7 +126,7 @@ import Diagrams.Trail import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Attributes import Diagrams.TwoD.Path (stroke, strokeT) -import Diagrams.TwoD.Transform (avgScale, rotate, translateX) +import Diagrams.TwoD.Transform (rotate, translateX) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (direction, unitX, unit_X) import Diagrams.Util (( # )) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index eeea782b..45478705 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -27,14 +27,13 @@ module Diagrams.TwoD.Attributes ( ) where +import Data.Data import Data.Default.Class import Data.Semigroup -import Data.Typeable import Diagrams.Core -import Diagrams.Core.Style (setAttr) -import Diagrams.TwoD.Transform (avgScale) -import Diagrams.TwoD.Types (R2) +import Diagrams.Core.Style (setAttr) +import Diagrams.TwoD.Types (R2) ------------------------------------------------------------ -- Line Width ------------------------------------------------- @@ -43,7 +42,7 @@ import Diagrams.TwoD.Types (R2) -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth = LineWidth (Last (Measure Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Data, Semigroup) instance AttributeClass LineWidth type instance V LineWidth = R2 @@ -64,11 +63,11 @@ setLineWidth = setAttr . LineWidth . Last -- | Set the line (stroke) width. lineWidth :: (HasStyle a, V a ~ R2) => (Measure Double) -> a -> a -lineWidth = applyTAttr . LineWidth . Last +lineWidth = applyGTAttr . LineWidth . Last -- | Apply a 'LineWidth' attribute. lineWidthA :: (HasStyle a, V a ~ R2) => LineWidth -> a -> a -lineWidthA = applyTAttr +lineWidthA = applyGTAttr -- | A convenient synonym for 'lineWidth (Global w)'. lw :: (HasStyle a, V a ~ R2) => Double -> a -> a diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 3938b097..d79b48fe 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -46,7 +46,7 @@ import Data.VectorSpace import Diagrams.Core import Diagrams.Angle -import Diagrams.Attributes (fc, lw) +import Diagrams.Attributes (fc) import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates @@ -54,7 +54,7 @@ import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align -import Diagrams.TwoD.Attributes (lineWidth) +import Diagrams.TwoD.Attributes (lineWidth, lw) import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) diff --git a/src/Diagrams/TwoD/Compile.hs b/src/Diagrams/TwoD/Compile.hs deleted file mode 100644 index 7c586ce8..00000000 --- a/src/Diagrams/TwoD/Compile.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Diagrams.TwoD.Compile --- Copyright : (c) 2014 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Functions to rewrite the RTree form of diagrams during backend rendering. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Compile - ( toOutput - - ) where - -import Diagrams.Core -import Diagrams.Core.Types (RTree) -import Diagrams.TwoD.Arrow -import Diagrams.TwoD.Attributes -import Diagrams.TwoD.Size (SizeSpec2D, sizePair) -import Diagrams.TwoD.Text -import Diagrams.TwoD.Types (R2) - --- | Take a getter, a setter, and two scaling terms, return a function --- that rewrites the given Measure-containing Attribute into Output --- units. The scaling terms are from Normalized to Output and from --- Global to Output. -modifyStyle :: AttributeClass a => - (a -> Measure Double) -> - (Measure Double -> Style R2 -> Style R2) -> - SizeSpec2D -> Double -> - Style R2 -> Style R2 -modifyStyle get set outputSize gs sty = case getAttr sty of - Nothing -> sty - Just a -> case get a of - Output _ -> sty - Normalized t -> set (Output $ sqrt (w*h) * t) sty where - (w,h) = sizePair outputSize - - -- Note: we assume here that this function is being called on - -- values in an RTree; conversion to RTree involves pushing - -- transformations down to the leaves, and transforming any - -- styles encountered along the way. In particular this will - -- scale any 'Local' values; hence any 'Local' value - -- encountered here must already be in Output units. - Local t -> set (Output t) sty - - Global t -> set (Output $ gs * t) sty - --- | 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 :: SizeSpec2D -> Double -> Style R2 -> Style R2 -toOutput ns gs = modifyStyle getLineWidth setLineWidth ns gs . - modifyStyle getHeadSize setHeadSize ns gs . - modifyStyle getTailSize setTailSize ns gs . - modifyStyle getFontSize setFontSize ns gs diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 07ee02c2..f75403b7 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -45,9 +45,9 @@ module Diagrams.TwoD.Path ) where import Control.Applicative (liftA2) -import Control.Lens ( makeWrapped, makeLensesWith, (.~), (^.) - , generateSignatures, lensRules, op - , Lens, Lens', _Wrapped') +import Control.Lens (Lens, Lens', generateSignatures, + lensRules, makeLensesWith, makeWrapped, + op, (.~), (^.), _Wrapped') import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 66943a83..f184b888 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -27,8 +27,8 @@ module Diagrams.TwoD.Types ) where -import Control.Lens (Iso', Wrapped(..), Rewrapped, iso - , (^.), _1, _2, lens) +import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, + lens, (^.), _1, _2) import Diagrams.Angle import Diagrams.Coordinates @@ -36,10 +36,10 @@ import Diagrams.Core import Data.AffineSpace.Point import Data.Basis -import Data.MemoTrie (HasTrie (..)) +import Data.MemoTrie (HasTrie (..)) import Data.VectorSpace -import Data.Typeable +import Data.Data ------------------------------------------------------------ -- 2D Euclidean space @@ -73,7 +73,7 @@ import Data.Typeable data R2 = R2 {-# UNPACK #-} !Double {-# UNPACK #-} !Double - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable, Data) instance AdditiveGroup R2 where zeroV = R2 0 0 From 9ea002f2654bff715a393ed79469fb9a2337b363 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 25 Mar 2014 08:47:18 -0400 Subject: [PATCH 69/77] -Wall: remove redundant import --- src/Diagrams/TwoD/Combinators.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index d79b48fe..aa321cbf 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -54,7 +54,7 @@ import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align -import Diagrams.TwoD.Attributes (lineWidth, lw) +import Diagrams.TwoD.Attributes (lineWidth) import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) From 1e2e468efe25c5aa92303087b874cad581900515 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 25 Mar 2014 10:01:46 -0400 Subject: [PATCH 70/77] -Wall: remove another redundant import --- src/Diagrams/TwoD/Adjust.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index c38b604c..f28c823c 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | @@ -25,8 +25,7 @@ import Diagrams.Core import Diagrams.TwoD.Arrow (headSizeA, tailSizeA) import Diagrams.TwoD.Attributes (lineWidthA) import Diagrams.TwoD.Size (SizeSpec2D (..), center2D, - requiredScale, requiredScaleT, - size2D) + requiredScale, size2D) import Diagrams.TwoD.Text (fontSizeA) import Diagrams.TwoD.Types (R2, T2, p2) import Diagrams.Util (( # )) From c9407f867b5c32ac6065e99303cc6f58e7be1246 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 25 Mar 2014 11:13:54 -0400 Subject: [PATCH 71/77] get rid of setLineWidth, which is no longer used and seems dodgy anyway In particular it used 'setAttr' which created a normal Attribute instead of a GTAttribute! --- src/Diagrams/TwoD/Attributes.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 45478705..8f4f9f22 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -21,7 +21,7 @@ module Diagrams.TwoD.Attributes ( -- ** Width - LineWidth, getLineWidth, lineWidth, lineWidthA, setLineWidth + LineWidth, getLineWidth, lineWidth, lineWidthA , lw, lwN, lwO, lwL , ultraThin, veryThin, thin, medium, thick, veryThick @@ -32,7 +32,6 @@ import Data.Default.Class import Data.Semigroup import Diagrams.Core -import Diagrams.Core.Style (setAttr) import Diagrams.TwoD.Types (R2) ------------------------------------------------------------ @@ -55,12 +54,9 @@ instance Transformable LineWidth where instance Default LineWidth where def = LineWidth (Last (Output 1)) -getLineWidth :: LineWidth -> (Measure Double) +getLineWidth :: LineWidth -> Measure Double getLineWidth (LineWidth (Last w)) = w -setLineWidth :: (Measure Double) -> Style R2 -> Style R2 -setLineWidth = setAttr . LineWidth . Last - -- | Set the line (stroke) width. lineWidth :: (HasStyle a, V a ~ R2) => (Measure Double) -> a -> a lineWidth = applyGTAttr . LineWidth . Last From 3092b715ff21f71f7e82349d82c16bedbcfddbdc Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Tue, 25 Mar 2014 13:11:17 -0400 Subject: [PATCH 72/77] headSize and tailSize use applyGTAttr --- src/Diagrams/TwoD.hs | 6 +++--- src/Diagrams/TwoD/Arrow.hs | 23 +++++++++-------------- src/Diagrams/TwoD/Text.hs | 8 +------- 3 files changed, 13 insertions(+), 24 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index e9383e00..dcaa4ac9 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -153,12 +153,12 @@ module Diagrams.TwoD , tailStyle , shaftColor , shaftStyle - , HeadSize, headSize, headSizeA, getHeadSize, setHeadSize - , TailSize, tailSize, tailSizeA, getTailSize, setTailSize + , HeadSize, headSize, headSizeA, getHeadSize + , TailSize, tailSize, tailSizeA, getTailSize -- * Text , text, topLeftText, alignedText, baselineText - , font, fontSize, italic, oblique, bold, setFontSize + , font, fontSize, italic, oblique, bold -- * Images , Image, image diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index acde5974..826f2a71 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -72,8 +72,8 @@ module Diagrams.TwoD.Arrow , arrow' -- * Attributes - , HeadSize, headSize, headSizeA, getHeadSize, setHeadSize - , TailSize, tailSize, tailSizeA, getTailSize, setTailSize + , HeadSize, headSize, headSizeA, getHeadSize + , TailSize, tailSize, tailSizeA, getTailSize -- * Options , ArrowOpts(..) @@ -103,6 +103,7 @@ import Control.Lens (Lens', Setter', Traversal', makeLensesWith, (%~), (&), (.~), (^.)) import Data.AffineSpace +import Data.Data import Data.Default.Class import Data.Functor ((<$>)) import Data.Maybe (fromMaybe) @@ -286,7 +287,7 @@ tailSty opts = fc black (opts^.tailStyle) -- | Radius of a circumcircle around the head. newtype HeadSize = HeadSize (Last (Measure Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Data, Semigroup) instance AttributeClass HeadSize type instance V HeadSize = R2 @@ -301,19 +302,16 @@ instance Default HeadSize where -- | Set the radius of the circumcircle around the head. headSize :: (HasStyle a, V a ~ R2) => Measure Double -> a -> a -headSize = applyTAttr . HeadSize . Last - -setHeadSize :: (Measure Double) -> Style R2 -> Style R2 -setHeadSize = setAttr . HeadSize . Last +headSize = applyGTAttr . HeadSize . Last headSizeA :: (HasStyle a, V a ~ R2) => HeadSize -> a -> a -headSizeA = applyTAttr +headSizeA = applyGTAttr getHeadSize :: HeadSize -> Measure Double getHeadSize (HeadSize (Last s)) = s newtype TailSize = TailSize (Last (Measure Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Data, Semigroup) instance AttributeClass TailSize type instance V TailSize = R2 @@ -328,13 +326,10 @@ instance Default TailSize where -- | Set the radius of a circumcircle around the arrow tail. tailSize :: (HasStyle a, V a ~ R2) => Measure Double -> a -> a -tailSize = applyTAttr . TailSize . Last - -setTailSize :: (Measure Double) -> Style R2 -> Style R2 -setTailSize = setAttr . TailSize . Last +tailSize = applyGTAttr . TailSize . Last tailSizeA :: (HasStyle a, V a ~ R2) => TailSize -> a -> a -tailSizeA = applyTAttr +tailSizeA = applyGTAttr getTailSize :: TailSize -> Measure Double getTailSize (TailSize (Last s)) = s diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 5a29c041..c0fe02a9 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -23,7 +23,7 @@ module Diagrams.TwoD.Text ( -- ** Font family , Font(..), getFont, font -- ** Font size - , FontSize(..), getFontSize, fontSize, fontSizeA, setFontSize + , FontSize(..), getFontSize, fontSize, fontSizeA -- ** Font slant , FontSlant(..), FontSlantA, getFontSlant, fontSlant, italic, oblique -- ** Font weight @@ -37,13 +37,9 @@ import Diagrams.Core.Style (setAttr) import Diagrams.TwoD.Types import Data.AffineSpace ((.-.)) - import Data.Semigroup - import Data.Colour - import Data.Default.Class - import Data.Typeable ------------------------------------------------------------ @@ -177,8 +173,6 @@ instance Default FontSize where getFontSize :: FontSize -> Measure Double getFontSize (FontSize (Last s)) = s -setFontSize :: (Measure Double) -> Style R2 -> Style R2 -setFontSize = setAttr . FontSize . Last -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size -- is @1@. From e625a487215602bf5fa1713bc461d0c419860299 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Tue, 25 Mar 2014 14:07:50 -0400 Subject: [PATCH 73/77] convert dashing to Measure, Local not scaling --- src/Diagrams/Attributes.hs | 25 ----------------------- src/Diagrams/TwoD.hs | 3 +++ src/Diagrams/TwoD/Attributes.hs | 36 +++++++++++++++++++++++++++++++++ 3 files changed, 39 insertions(+), 25 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 99dff242..eac42d4d 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -51,9 +51,6 @@ module Diagrams.Attributes ( -- ** Miter limit , LineMiterLimit(..), getLineMiterLimit, lineMiterLimit, lineMiterLimitA - -- ** Dashing - , Dashing(..), DashingA, getDashing, dashing - -- * Compilation utilities , splitFills @@ -342,28 +339,6 @@ lineMiterLimit = applyAttr . LineMiterLimit . Last -- | Apply a 'LineMiterLimit' attribute. lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr - --- | Create lines that are dashing... er, dashed. -data Dashing = Dashing [Double] Double - deriving (Typeable, Eq) - -newtype DashingA = DashingA (Last Dashing) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass DashingA - -getDashing :: DashingA -> Dashing -getDashing (DashingA (Last d)) = d - --- | Set the line dashing style. -dashing :: HasStyle a => - [Double] -- ^ A list specifying alternate lengths of on - -- and off portions of the stroke. The empty - -- list indicates no dashing. - -> Double -- ^ An offset into the dash pattern at which the - -- stroke should start. - -> a -> a -dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) - ------------------------------------------------------------ data FillLoops v = FillLoops diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index dcaa4ac9..4621ce09 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -233,6 +233,9 @@ module Diagrams.TwoD , LineWidth, getLineWidth, lineWidth, lineWidthA, lw, lwN, lwO, lwL , ultraThin, veryThin, thin, medium, thick, veryThick + -- ** Dashing + , Dashing(..), DashingA, getDashing, dashing + -- * Visual aids for understanding the internal model , showOrigin , showOrigin' diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 8f4f9f22..35748b1f 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -25,6 +25,9 @@ module Diagrams.TwoD.Attributes ( , lw, lwN, lwO, lwL , ultraThin, veryThin, thin, medium, thick, veryThick + -- ** Dashing + , Dashing(..), DashingA, getDashing, dashing + ) where import Data.Data @@ -90,3 +93,36 @@ thin = lwO 1 medium = lwO 2 thick = lwO 4 veryThick = lwO 5 + +------------------------------------------------------------ + +-- | Create lines that are dashing... er, dashed. +data Dashing = Dashing [Measure Double] (Measure Double) + deriving (Typeable, Data, Eq) + +newtype DashingA = DashingA (Last Dashing) + deriving (Typeable, Data, Semigroup, Eq) +instance AttributeClass DashingA + +type instance V DashingA = R2 + +instance Transformable DashingA where + transform t (DashingA (Last (Dashing [Local w] (Local v)))) = + DashingA (Last (Dashing [Local r] (Local s))) + where + r = avgScale t * w + s = avgScale t * v + transform _ l = l + +getDashing :: DashingA -> Dashing +getDashing (DashingA (Last d)) = d + +-- | Set the line dashing style. +dashing :: (HasStyle a, V a ~ R2) => + [Measure Double] -- ^ A list specifying alternate lengths of on + -- and off portions of the stroke. The empty + -- list indicates no dashing. + -> Measure Double -- ^ An offset into the dash pattern at which the + -- stroke should start. + -> a -> a +dashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) From 2578d598cbfbf5f7eb60d8cab030be49acd5dcc9 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Tue, 25 Mar 2014 16:16:10 -0400 Subject: [PATCH 74/77] fix Dashing transform --- src/Diagrams/TwoD/Attributes.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 35748b1f..b22af9b8 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -107,12 +107,18 @@ instance AttributeClass DashingA type instance V DashingA = R2 instance Transformable DashingA where - transform t (DashingA (Last (Dashing [Local w] (Local v)))) = - DashingA (Last (Dashing [Local r] (Local s))) + transform t (DashingA (Last (Dashing w v))) = + DashingA (Last (Dashing (trLocals w) (trLocal v))) where - r = avgScale t * w - s = avgScale t * v - transform _ l = l + s = avgScale t + + trLocals [] = [] + trLocals ((Local h) : tl) = Local (h * s) : trLocals tl + trLocals (x : tl) = x : trLocals tl + + trLocal (Local y) = Local (y * s) + trLocal z = z + getDashing :: DashingA -> Dashing getDashing (DashingA (Last d)) = d From abe0b9784ee593925e56990638c6e69a8cde361e Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Tue, 25 Mar 2014 16:24:24 -0400 Subject: [PATCH 75/77] better --- src/Diagrams/TwoD/Attributes.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index b22af9b8..7cff6d22 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -108,18 +108,12 @@ type instance V DashingA = R2 instance Transformable DashingA where transform t (DashingA (Last (Dashing w v))) = - DashingA (Last (Dashing (trLocals w) (trLocal v))) + DashingA (Last (Dashing (map trLocal w) (trLocal v))) where s = avgScale t - - trLocals [] = [] - trLocals ((Local h) : tl) = Local (h * s) : trLocals tl - trLocals (x : tl) = x : trLocals tl - trLocal (Local y) = Local (y * s) trLocal z = z - getDashing :: DashingA -> Dashing getDashing (DashingA (Last d)) = d From 40a02f43a10783421450f8592e94d33ee0074086 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Tue, 25 Mar 2014 16:26:32 -0400 Subject: [PATCH 76/77] remove redundant imports from arrows --- src/Diagrams/TwoD/Arrow.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 826f2a71..7d6b46bc 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -109,13 +109,11 @@ import Data.Functor ((<$>)) import Data.Maybe (fromMaybe) import Data.Monoid.Coproduct (untangle) import Data.Semigroup -import Data.Typeable import Data.VectorSpace import Data.Colour hiding (atop) import Diagrams.Attributes import Diagrams.Core -import Diagrams.Core.Style (setAttr) import Diagrams.Core.Types (QDiaLeaf (..), mkQD') import Diagrams.Angle From d00b132f36e6204fe53b0016769510ffef627284 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Tue, 25 Mar 2014 17:32:40 -0400 Subject: [PATCH 77/77] Transformable instance for (Measure Double), convenience functions for Dashing --- src/Diagrams/TwoD.hs | 3 +- src/Diagrams/TwoD/Attributes.hs | 52 ++++++++++++++++++++++++--------- 2 files changed, 41 insertions(+), 14 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 4621ce09..9aa09869 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -234,7 +234,8 @@ module Diagrams.TwoD , ultraThin, veryThin, thin, medium, thick, veryThick -- ** Dashing - , Dashing(..), DashingA, getDashing, dashing + , Dashing(..), DashingA, getDashing + , dashing, dashingO, dashingL, dashingN -- * Visual aids for understanding the internal model , showOrigin diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 7cff6d22..53f8155b 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -26,7 +27,8 @@ module Diagrams.TwoD.Attributes ( , ultraThin, veryThin, thin, medium, thick, veryThick -- ** Dashing - , Dashing(..), DashingA, getDashing, dashing + , Dashing(..), DashingA, getDashing, setDashing + , dashing, dashingN, dashingO, dashingL ) where @@ -37,9 +39,17 @@ import Data.Semigroup import Diagrams.Core import Diagrams.TwoD.Types (R2) ------------------------------------------------------------- +----------------------------------------------------------------- + +type instance V (Measure Double) = R2 + +instance Transformable (Measure Double) where + transform tr (Local x) = Local (avgScale tr * x) + transform _ y = y + +----------------------------------------------------------------- -- Line Width ------------------------------------------------- ------------------------------------------------------------- +----------------------------------------------------------------- -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. @@ -50,9 +60,8 @@ instance AttributeClass LineWidth type instance V LineWidth = R2 instance Transformable LineWidth where - transform t (LineWidth (Last (Local w))) = - LineWidth (Last (Local (avgScale t * w))) - transform _ l = l + transform t (LineWidth (Last w)) = + LineWidth (Last (transform t w)) instance Default LineWidth where def = LineWidth (Last (Output 1)) @@ -94,7 +103,9 @@ medium = lwO 2 thick = lwO 4 veryThick = lwO 5 ------------------------------------------------------------- +----------------------------------------------------------------- +-- Dashing ---------------------------------------------------- +----------------------------------------------------------------- -- | Create lines that are dashing... er, dashed. data Dashing = Dashing [Measure Double] (Measure Double) @@ -108,21 +119,36 @@ type instance V DashingA = R2 instance Transformable DashingA where transform t (DashingA (Last (Dashing w v))) = - DashingA (Last (Dashing (map trLocal w) (trLocal v))) + DashingA (Last (Dashing r s)) where - s = avgScale t - trLocal (Local y) = Local (y * s) - trLocal z = z + r = map (transform t) w + s = transform t v getDashing :: DashingA -> Dashing getDashing (DashingA (Last d)) = d -- | Set the line dashing style. -dashing :: (HasStyle a, V a ~ R2) => +setDashing :: (HasStyle a, V a ~ R2) => [Measure Double] -- ^ A list specifying alternate lengths of on -- and off portions of the stroke. The empty -- list indicates no dashing. -> Measure Double -- ^ An offset into the dash pattern at which the -- stroke should start. -> a -> a -dashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) +setDashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) + +-- | A convenient synonym for 'setDashing (Global w)'. +dashing :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashing w v = setDashing (map Global w) (Global v) + +-- | A convenient synonym for 'setDashing (Normalized w)'. +dashingN :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingN w v = setDashing (map Normalized w) (Normalized v) + +-- | A convenient synonym for 'setDashing (Output w)'. +dashingO :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingO w v = setDashing (map Output w) (Output v) + +-- | A convenient sysnonym for 'setDashing (Local w)'. +dashingL :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingL w v = setDashing (map Local w) (Local v)