From b9bd65abe862b7d504d907fd2a66015475599c28 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 4 Sep 2013 21:25:12 -0400 Subject: [PATCH 1/7] D.Points: get rid of Control.Newtype --- src/Diagrams/Points.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs index 7cada401..e87a6a03 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -25,15 +25,14 @@ module Diagrams.Points import Diagrams.Coordinates import Diagrams.Core.Points -import Control.Newtype - -import Control.Arrow ((&&&)) +import Control.Arrow ((&&&)) +import Data.AffineSpace.Point import Data.VectorSpace -- | The centroid of a set of /n/ points is their sum divided by /n/. centroid :: (VectorSpace v, Fractional (Scalar v)) => [Point v] -> Point v -centroid = pack . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unpack +centroid = P . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unPoint instance Coordinates v => Coordinates (Point v) where type FinalCoord (Point v) = FinalCoord v From ff82793a9da4ea6c13303bd9044e1058ffe9b9cc Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 4 Sep 2013 21:38:44 -0400 Subject: [PATCH 2/7] change Path projection function to a lens iso --- diagrams-lib.cabal | 3 ++- src/Diagrams/CubicSpline.hs | 4 ++-- src/Diagrams/Path.hs | 32 ++++++++++++++++---------------- src/Diagrams/TwoD/Path.hs | 11 ++++++----- src/Diagrams/TwoD/Shapes.hs | 3 ++- 5 files changed, 28 insertions(+), 25 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index b9d35048..f2c30de8 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -89,6 +89,7 @@ Library pretty >= 1.0.1.2 && < 1.2, newtype >= 0.2 && < 0.3, fingertree >= 0.1 && < 0.2, - intervals >= 0.2.2 && < 0.3 + intervals >= 0.2.2 && < 0.3, + lens >= 3.9 && < 3.10 Hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs index 0449e8f3..23040cb7 100644 --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -34,7 +34,7 @@ import Diagrams.TrailLike (TrailLike (..)) -- for e.g. the Fractional (Double, Double) instance import Data.NumInstances.Tuple () -import Control.Newtype +import Data.AffineSpace.Point import Data.VectorSpace -- | Construct a spline path-like thing of cubic segments from a list of @@ -53,7 +53,7 @@ import Data.VectorSpace -- For more information, see . cubicSpline :: (TrailLike t, Fractional (V t)) => Bool -> [Point (V t)] -> t cubicSpline c [] = trailLike . closeIf c $ emptyLine `at` origin -cubicSpline c ps = flattenBeziers . map f . solveCubicSplineCoefficients c . map unpack $ ps +cubicSpline c ps = flattenBeziers . map f . solveCubicSplineCoefficients c . map unPoint $ ps where f [a,b,c,d] = [a, (3*a+b)/3, (3*a+2*b+c)/3, a+b+c+d] flattenBeziers bs@((b:_):_) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 32c99faf..dc75e4c5 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -28,7 +29,7 @@ module Diagrams.Path -- * Paths - Path(..) + Path, pathTrails -- * Constructing paths -- $construct @@ -67,7 +68,8 @@ import Diagrams.TrailLike import Diagrams.Transform import Control.Arrow ((***)) -import Control.Newtype hiding (under) +import Control.Lens (from, makeLenses, mapped, over, view, + (%~)) import Data.AffineSpace import qualified Data.Foldable as F import Data.List (partition) @@ -82,21 +84,19 @@ import Data.VectorSpace -- Hence, unlike trails, paths are not translationally invariant, -- and they form a monoid under /superposition/ (placing one path on -- top of another) rather than concatenation. -newtype Path v = Path { pathTrails :: [Located (Trail v)] } +newtype Path v = Path { _pathTrails :: [Located (Trail v)] } deriving (Semigroup, Monoid) +makeLenses ''Path + deriving instance Show v => Show (Path v) deriving instance Eq v => Eq (Path v) deriving instance Ord v => Ord (Path v) type instance V (Path v) = v -instance Newtype (Path v) [Located (Trail v)] where - pack = Path - unpack = pathTrails - instance VectorSpace v => HasOrigin (Path v) where - moveOriginTo = over Path . map . moveOriginTo + moveOriginTo = over pathTrails . map . moveOriginTo -- | Paths are trail-like; a trail can be used to construct a -- singleton path. @@ -106,7 +106,7 @@ instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Path v) where -- See Note [Transforming paths] instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (Path v) where - transform = over Path . map . transform + transform = over pathTrails . map . transform {- ~~~~ Note [Transforming paths] @@ -121,7 +121,7 @@ of the v's are inside Points and hence ought to be translated. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => IsPrim (Path v) instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where - getEnvelope = F.foldMap trailEnvelope . pathTrails + getEnvelope = F.foldMap trailEnvelope . view pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 where trailEnvelope :: Located (Trail v) -> Envelope v trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) @@ -166,11 +166,11 @@ pathFromLocTrail = trailLike -- | Extract the vertices of a path, resulting in a separate list of -- vertices for each component trail (see 'trailVertices'). pathVertices :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[Point v]] -pathVertices = map trailVertices . pathTrails +pathVertices = map trailVertices . view pathTrails -- | Compute the total offset of each trail comprising a path (see 'trailOffset'). pathOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [v] -pathOffsets = map (trailOffset . unLoc) . pathTrails +pathOffsets = map (trailOffset . unLoc) . view pathTrails -- | Compute the /centroid/ of a path (/i.e./ the average location of -- its vertices). @@ -179,18 +179,18 @@ pathCentroid = centroid . concat . pathVertices -- | Convert a path into a list of lists of 'FixedSegment's. fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] -fixPath = map fixTrail . unpack +fixPath = map fixTrail . view pathTrails -- | \"Explode\" a path by exploding every component trail (see -- 'explodeTrail'). explodePath :: (VectorSpace (V t), TrailLike t) => Path (V t) -> [[t]] -explodePath = map explodeTrail . pathTrails +explodePath = map explodeTrail . view pathTrails -- | Partition a path into two paths based on a predicate on trails: -- the first containing all the trails for which the predicate returns -- @True@, and the second containing the remaining trails. partitionPath :: (Located (Trail v) -> Bool) -> Path v -> (Path v, Path v) -partitionPath p = (pack *** pack) . partition p . unpack +partitionPath p = (view (from pathTrails) *** view (from pathTrails)) . partition p . view pathTrails ------------------------------------------------------------ -- Modifying paths --------------------------------------- @@ -204,4 +204,4 @@ scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p -- | Reverse all the component trails of a path. reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v -reversePath = (over Path . map) reverseLocTrail +reversePath = pathTrails . mapped %~ reverseLocTrail diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 4302015c..16b12e0b 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -43,6 +43,7 @@ module Diagrams.TwoD.Path ) where import Control.Applicative (liftA2) +import Control.Lens (view, (^.)) import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable @@ -80,7 +81,7 @@ instance Traced (Trail R2) where . lineSegments instance Traced (Path R2) where - getTrace = F.foldMap getTrace . pathTrails + getTrace = F.foldMap getTrace . view pathTrails ------------------------------------------------------------ -- Constructing path-based diagrams ---------------------- @@ -112,9 +113,9 @@ instance Renderable (Path R2) b => TrailLike (QDiagram b R2 Any) where -- ... }@ syntax may be used. stroke' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 stroke' opts path - | null (pathTrails pLines) = mkP pLoops - | null (pathTrails pLoops) = mkP pLines - | otherwise = mkP pLines <> mkP pLoops + | null (pLines ^. pathTrails) = mkP pLoops + | null (pLoops ^. pathTrails) = mkP pLines + | otherwise = mkP pLines <> mkP pLoops where (pLines,pLoops) = partitionPath (isLine . unLoc) path mkP p @@ -282,7 +283,7 @@ isInsideEvenOdd p = odd . crossings p -- | Compute the sum of /signed/ crossings of a path as we travel in the -- positive x direction from a given point. crossings :: P2 -> Path R2 -> Int -crossings p = F.sum . map (trailCrossings p) . pathTrails +crossings p = F.sum . map (trailCrossings p) . view pathTrails -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index 0575cf51..e9414c94 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -59,6 +59,7 @@ import Diagrams.TwoD.Types import Diagrams.Util +import Control.Lens (view) import Data.Default.Class import Data.Semigroup @@ -105,7 +106,7 @@ square d = rect d d -- -- <> rect :: (TrailLike t, Transformable t, V t ~ R2) => Double -> Double -> t -rect w h = trailLike . head . pathTrails $ unitSquare # scaleX w # scaleY h +rect w h = trailLike . head . view pathTrails $ unitSquare # scaleX w # scaleY h -- > rectEx = rect 1 0.7 # pad 1.1 From 6f7724d2f32a30045e64e6babebdfd2a50d2bf58 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 2 Oct 2013 21:53:39 -0400 Subject: [PATCH 3/7] D.TwoD.Offset: update to use new pathTrails lens --- src/Diagrams/TwoD/Offset.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index ba5bae94..5df28e24 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -232,9 +232,9 @@ offsetTrail = offsetTrail' def -- | Offset a 'Path' by applying 'offsetTrail'' to each trail in the path. offsetPath' :: OffsetOpts -> Double -> Path R2 -> Path R2 -offsetPath' opts r = mconcat - . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin)) - . pathTrails +offsetPath' opts r = mconcat + . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin)) + . view pathTrails -- | Offset a 'Path' with the default options and given radius. See 'offsetPath''. offsetPath :: Double -> Path R2 -> Path R2 @@ -349,9 +349,9 @@ expandTrail = expandTrail' def -- | Expand a 'Path' using 'expandTrail'' on each trail in the path. expandPath' :: ExpandOpts -> Double -> Path R2 -> Path R2 -expandPath' opts r = mconcat - . map (bindLoc (expandTrail' opts r) . (`at` origin)) - . pathTrails +expandPath' opts r = mconcat + . map (bindLoc (expandTrail' opts r) . (`at` origin)) + . view pathTrails -- | Expand a 'Path' with the given radius and default options. See 'expandPath''. expandPath :: Double -> Path R2 -> Path R2 From 69094dd8090ca8359ed8f7ebc316fc26ac54fd2d Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 2 Oct 2013 21:53:58 -0400 Subject: [PATCH 4/7] hand-write pathTrails lens so we don't need TH --- src/Diagrams/Path.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index dc75e4c5..069b8f8b 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -5,7 +5,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -68,8 +67,7 @@ import Diagrams.TrailLike import Diagrams.Transform import Control.Arrow ((***)) -import Control.Lens (from, makeLenses, mapped, over, view, - (%~)) +import Control.Lens (Iso, from, iso, mapped, over, view, (%~)) import Data.AffineSpace import qualified Data.Foldable as F import Data.List (partition) @@ -87,7 +85,8 @@ import Data.VectorSpace newtype Path v = Path { _pathTrails :: [Located (Trail v)] } deriving (Semigroup, Monoid) -makeLenses ''Path +pathTrails :: Iso (Path v) (Path v') [Located (Trail v)] [Located (Trail v')] +pathTrails = iso _pathTrails Path deriving instance Show v => Show (Path v) deriving instance Eq v => Eq (Path v) From bc50877861b8bd38fabe9c7a98b30d6031bfa01e Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 2 Oct 2013 21:54:31 -0400 Subject: [PATCH 5/7] D.ThreeD.Types: update to use lens instead of newtype --- src/Diagrams/ThreeD/Types.hs | 45 ++++++++++++++++++------------------ 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 82ef02e4..3ab174a7 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -39,17 +39,17 @@ module Diagrams.ThreeD.Types , asSpherical ) where -import Control.Applicative +import Control.Applicative +import Control.Lens (Iso', iso, over) -import Diagrams.Coordinates -import Diagrams.TwoD.Types -import Diagrams.Core +import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.TwoD.Types -import Control.Newtype - -import Data.Basis -import Data.VectorSpace -import Data.Cross +import Data.AffineSpace.Point +import Data.Basis +import Data.Cross +import Data.VectorSpace ------------------------------------------------------------ -- 3D Euclidean space @@ -58,23 +58,22 @@ import Data.Cross newtype R3 = R3 { unR3 :: (Double, Double, Double) } deriving (AdditiveGroup, Eq, Ord, Show, Read) -instance Newtype R3 (Double, Double, Double) where - pack = R3 - unpack = unR3 +r3Iso :: Iso' R3 (Double, Double, Double) +r3Iso = iso unR3 R3 -- | Construct a 3D vector from a triple of components. r3 :: (Double, Double, Double) -> R3 -r3 = pack +r3 = R3 -- | Convert a 3D vector back into a triple of components. unr3 :: R3 -> (Double, Double, Double) -unr3 = unpack +unr3 = unR3 type instance V R3 = R3 instance VectorSpace R3 where type Scalar R3 = Double - (*^) = over R3 . (*^) + (*^) = over r3Iso . (*^) instance HasBasis R3 where type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) @@ -98,11 +97,11 @@ type P3 = Point R3 -- | Construct a 3D point from a triple of coordinates. p3 :: (Double, Double, Double) -> P3 -p3 = pack . pack +p3 = P . R3 -- | Convert a 2D point back into a triple of coordinates. unp3 :: P3 -> (Double, Double, Double) -unp3 = unpack . unpack +unp3 = unR3 . unPoint -- | Transformations in R^3. type T3 = Transformation R3 From f69c8e2c688b41cb4870c8b891f2c95c42004f82 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 2 Oct 2013 21:54:37 -0400 Subject: [PATCH 6/7] remove newtype dependency --- diagrams-lib.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 9aca6dc3..5991655a 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -92,7 +92,6 @@ Library colour >= 2.3.2 && < 2.4, data-default-class < 0.1, pretty >= 1.0.1.2 && < 1.2, - newtype >= 0.2 && < 0.3, fingertree >= 0.1 && < 0.2, intervals >= 0.2.2 && < 0.3, lens >= 3.9 && < 3.10 From ebc3e5e3eb62b33cdaba2349f6503accae5f6110 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Wed, 2 Oct 2013 21:55:49 -0400 Subject: [PATCH 7/7] D.TwoD.Offset: need to import Control.Lens --- src/Diagrams/TwoD/Offset.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index 5df28e24..4d7e1e6f 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -31,6 +31,7 @@ module Diagrams.TwoD.Offset ) where import Control.Applicative +import Control.Lens (view) import Data.AffineSpace import Data.Monoid