From 4b1aca9075193dd0bb781b06a5a4224a2c298bde Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 22 Jan 2014 01:03:05 +0000 Subject: [PATCH 01/11] Handle 'project' name collision --- src/Diagrams/Prelude.hs | 2 +- src/Diagrams/ThreeD/Transform.hs | 2 +- src/Diagrams/ThreeD/Types.hs | 2 +- src/Diagrams/TwoD/Polygons.hs | 2 +- src/Diagrams/TwoD/Types.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 31b280b8..54cfce1b 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -147,5 +147,5 @@ import Data.AffineSpace import Data.Colour hiding (AffineSpace (..), atop, over) import Data.Colour.Names hiding (tan) import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) +import Data.VectorSpace hiding (Sum (..), project) import Control.Lens ((&), (.~), (%~)) diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index e90f388f..f6cb147b 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -18,7 +18,7 @@ module Diagrams.ThreeD.Transform where -import Diagrams.Core +import Diagrams.Core hiding (project) import qualified Diagrams.Core.Transform as T import Diagrams.ThreeD.Types diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 8cdc62ac..2c78e081 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -47,7 +47,7 @@ import Diagrams.Coordinates import Data.AffineSpace.Point import Data.Basis import Data.Cross -import Data.VectorSpace +import Data.VectorSpace hiding (project) ------------------------------------------------------------ -- 3D Euclidean space diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index d126acb2..fe72026e 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -61,7 +61,7 @@ import Data.Default.Class import Data.VectorSpace (magnitude, normalized, project, (<.>), (^*)) -import Diagrams.Core +import Diagrams.Core hiding (project) import Diagrams.Located import Diagrams.Path import Diagrams.Points (centroid) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 11655be0..e46c2171 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -42,7 +42,7 @@ import Data.AffineSpace.Point import Data.Basis import Data.MemoTrie (HasTrie (..)) import Data.NumInstances.Tuple () -import Data.VectorSpace +import Data.VectorSpace hiding (project) import Data.Typeable ------------------------------------------------------------ From 2c57803abe5f7a523d0a6556d433186558f655b8 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 22 Jan 2014 01:03:47 +0000 Subject: [PATCH 02/11] Add Sectionable instance for FixedSegment --- src/Diagrams/Segment.hs | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index 45aea5ed..1741a03a 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -375,6 +375,35 @@ instance VectorSpace v => Parametric (FixedSegment v) where p3 = alerp p21 p22 t +instance Num (Scalar v) => DomainBounds (FixedSegment v) + +instance (VectorSpace v, Num (Scalar v)) => EndValues (FixedSegment v) where + atStart (FLinear p0 _) = p0 + atStart (FCubic p0 _ _ _) = p0 + atEnd (FLinear _ p1) = p1 + atEnd (FCubic _ _ _ p1 ) = p1 + +instance (VectorSpace v, Fractional (Scalar v)) => Sectionable (FixedSegment v) where + splitAtParam (FLinear p0 p1) t = (left, right) + where left = FLinear p0 p + right = FLinear p p1 + p = alerp p0 p1 t + splitAtParam (FCubic p0 c1 c2 p1) t = (left, right) + where left = FCubic p0 a b cut + right = FCubic cut c d p1 + -- first round + a = alerp p0 c1 t + p = alerp c1 c2 t + d = alerp c2 p1 t + -- second round + b = alerp a p t + c = alerp p d t + -- final round + cut = alerp b c t + + reverseDomain (FLinear p0 p1) = FLinear p1 p0 + reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 + ------------------------------------------------------------ -- Segment measures -------------------------------------- ------------------------------------------------------------ From 4146ba526717373a8e57289d7036d28e89b552cf Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 22 Jan 2014 01:05:03 +0000 Subject: [PATCH 03/11] add Projectable instances for Path, Located Trail --- src/Diagrams/Project.hs | 72 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 72 insertions(+) create mode 100644 src/Diagrams/Project.hs diff --git a/src/Diagrams/Project.hs b/src/Diagrams/Project.hs new file mode 100644 index 00000000..73b53637 --- /dev/null +++ b/src/Diagrams/Project.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Diagrams.Project where + +import Data.AffineSpace +import Data.VectorSpace hiding (project) +import Control.Lens (under, wrapped) + +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail + +-- | Cubic curves are not closed under perspective projections. +-- Therefore @Segment@s are not an instance of Projectable. However, +-- the projection of a @Segment@ can be approximated to arbitrary +-- precision by a series of @Segment@s. @projectSegment@ does this, +-- which allows types built from lists of @Segment@s to themselves be +-- @Projectable@. +projectSegment :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => + s -> Projection v -> FixedSegment v -> [FixedSegment v] +projectSegment epsilon t s + | goodEnough epsilon t s = [approx t s] + | otherwise = concatMap (projectSegment epsilon t) [s1, s2] + where + (s1, s2) = splitAtParam s 0.5 + +approx :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => + Projection v -> FixedSegment v -> FixedSegment v +approx t (FLinear p0 p1) = FLinear (project t p0) (project t p1) +approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1) where + f = project t + +goodEnough :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => + s -> Projection v -> FixedSegment v -> Bool +goodEnough e t s = + all (< e) [magnitude $ project t (s `atParam` u) .-. approx t s `atParam` u + | u <- [0.25, 0.5, 0.75]] + +instance (VectorSpace v, InnerSpace v, + s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => + Projectable (Located (Trail v)) where + project' eps p t + | isLine $ unLoc t = line `at` p0 + | otherwise = glueTrail line `at` p0 + where + segs = concatMap (projectSegment eps p) $ fixTrail t + p0 = case segs of + (FLinear start _:_) -> start + (FCubic start _ _ _:_) -> start + _ -> loc t -- default in case of empty trail + line = trailFromSegments $ map (unLoc . fromFixedSeg) segs + project p t = project' (0.01 * extent) p t where + -- estimate the "size" of the Trail' as + -- the maximum distance to any vertex + extent = maximum . map dist . trailVertices $ t + dist pt = magnitude $ pt .-. loc t + +instance (VectorSpace v, InnerSpace v, + s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => + Projectable (Path v) where + project' eps p = under wrapped $ map (project' eps p) + project p = under wrapped $ map (project p) From f86495ee8770c684470763245ef7638bd744d098 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 22 Jan 2014 01:05:49 +0000 Subject: [PATCH 04/11] add 2D and 3D Projections --- src/Diagrams/ThreeD/Project.hs | 51 ++++++++++++++++++++++++++++++++++ src/Diagrams/TwoD/Project.hs | 36 ++++++++++++++++++++++++ 2 files changed, 87 insertions(+) create mode 100644 src/Diagrams/ThreeD/Project.hs create mode 100644 src/Diagrams/TwoD/Project.hs diff --git a/src/Diagrams/ThreeD/Project.hs b/src/Diagrams/ThreeD/Project.hs new file mode 100644 index 00000000..724edd91 --- /dev/null +++ b/src/Diagrams/ThreeD/Project.hs @@ -0,0 +1,51 @@ +module Diagrams.ThreeD.Project where + +import Control.Lens + +import Diagrams.Core.Project + +import Diagrams.Coordinates +import Diagrams.ThreeD.Types + +-- | The parallel projection onto the plane x=0 +parallelX0 :: Projection R3 +parallelX0 = Projection (& _x .~ 0) + +-- | The perspective division onto the plane x=1 along lines going +-- through the origin. +perspectiveX1 :: Projection R3 +perspectiveX1 = Projection (\p -> let x = p^._x in + p & _x .~ 1 & _y //~ x & _z //~ x ) + +-- | The parallel projection onto the plane y=0 +parallelY0 :: Projection R3 +parallelY0 = Projection (& _y .~ 0) + +-- | The perspective division onto the plane y=1 along lines going +-- through the origin. +perspectiveY1 :: Projection R3 +perspectiveY1 = Projection (\p -> let y = p^._y in + p & _x //~ y & _y .~ 1 & _z //~ y ) + +-- | The parallel projection onto the plane z=0 +parallelZ0 :: Projection R3 +parallelZ0 = Projection (& _z .~ 0) + +-- | The perspective division onto the plane z=1 along lines going +-- through the origin. +perspectiveZ1 :: Projection R3 +perspectiveZ1 = Projection (\p -> let z = p^._z in + p & _x //~ z & _y //~ z & _z .~ 1 ) + +-- | The viewing transform for a viewer facing along the positive X +-- axis. X coördinates stay fixed, while Y coördinates are compressed +-- with increasing distance. @asProjection (translation unitX) <> +-- parallelX0 <> frustrumX = perspectiveX1@ +facingX :: Projection R3 +facingX = Projection (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) + +facingY :: Projection R3 +facingY = Projection (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) + +facingZ :: Projection R3 +facingZ = Projection (\v -> v & _x //~ (v^._z) & _y //~ (v^._z)) diff --git a/src/Diagrams/TwoD/Project.hs b/src/Diagrams/TwoD/Project.hs new file mode 100644 index 00000000..23c10965 --- /dev/null +++ b/src/Diagrams/TwoD/Project.hs @@ -0,0 +1,36 @@ +module Diagrams.TwoD.Project where + +import Control.Lens + +import Diagrams.Core.Project + +import Diagrams.Coordinates +import Diagrams.TwoD.Types + +-- | The parallel projection onto the line x=0 +parallelX0 :: Projection R2 +parallelX0 = Projection (& _x .~ 0) + +-- | The perspective division onto the line x=1 along lines going +-- through the origin. +perspectiveX1 :: Projection R2 +perspectiveX1 = Projection (\p -> p & _y //~ (p^._x) & _x .~ 1) + +-- | The parallel projection onto the line y=0 +parallelY0 :: Projection R2 +parallelY0 = Projection (& _y .~ 0) + +-- | The perspective division onto the line y=1 along lines going +-- through the origin. +perspectiveY1 :: Projection R2 +perspectiveY1 = Projection (\p -> p & _x //~ (p^._y) & _y .~ 1) + +-- | The viewing transform for a viewer facing along the positive X +-- axis. X coördinates stay fixed, while Y coördinates are compressed +-- with increasing distance. @asProjection (translation unitX) <> +-- parallelX0 <> frustrumX = perspectiveX1@ +facingX :: Projection R2 +facingX = Projection (\v -> v & _y //~ (v^._x)) + +facingY :: Projection R2 +facingY = Projection (\v -> v & _x //~ (v^._y)) From 776ff47e2887b2d1ca05e78038b866e94fd84edf Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 22 Jan 2014 01:06:06 +0000 Subject: [PATCH 05/11] export Projections --- diagrams-lib.cabal | 3 +++ src/Diagrams/Prelude.hs | 1 + src/Diagrams/Project.hs | 3 ++- src/Diagrams/TwoD.hs | 5 +++++ 4 files changed, 11 insertions(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 3d15f6e4..95f5708e 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -43,6 +43,7 @@ Library Diagrams.Solve, Diagrams.Tangent, Diagrams.Transform, + Diagrams.Project Diagrams.BoundingBox, Diagrams.Names, Diagrams.Envelope, @@ -63,6 +64,7 @@ Library Diagrams.TwoD.Offset, Diagrams.TwoD.Path, Diagrams.TwoD.Polygons, + Diagrams.TwoD.Project, Diagrams.TwoD.Shapes, Diagrams.TwoD.Vector, Diagrams.TwoD.Size, @@ -70,6 +72,7 @@ Library Diagrams.TwoD.Text, Diagrams.TwoD.Image, Diagrams.TwoD.Adjust, + Diagrams.ThreeD.Project, Diagrams.ThreeD.Types, Diagrams.ThreeD.Shapes, Diagrams.ThreeD.Vector, diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 54cfce1b..3f496ce4 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -131,6 +131,7 @@ import Diagrams.Parametric import Diagrams.Parametric.Adjust import Diagrams.Path import Diagrams.Points +import Diagrams.Project () import Diagrams.Query import Diagrams.Segment import Diagrams.Tangent diff --git a/src/Diagrams/Project.hs b/src/Diagrams/Project.hs index 73b53637..bd39af66 100644 --- a/src/Diagrams/Project.hs +++ b/src/Diagrams/Project.hs @@ -7,7 +7,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -module Diagrams.Project where +module Diagrams.Project () -- export only instances + where import Data.AffineSpace import Data.VectorSpace hiding (project) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 44cc9680..7aa97e71 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -189,6 +189,10 @@ module Diagrams.TwoD , shearingX, shearX , shearingY, shearY + -- * Projections - non-affine transforms + , parallelX0, perspectiveX1, parallelY0, perspectiveY1 + , facingX, facingY + -- * Combinators -- ** Combining multiple diagrams , (===), (|||), atAngle @@ -247,6 +251,7 @@ import Diagrams.TwoD.Image import Diagrams.TwoD.Model import Diagrams.TwoD.Path import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Project import Diagrams.TwoD.Shapes import Diagrams.TwoD.Size import Diagrams.TwoD.Text From 0957765e8ced3ba4067e9f26c96f99b0a296d145 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sat, 8 Feb 2014 21:50:57 +0000 Subject: [PATCH 06/11] Deform no longer overlaps in name with VectorSpace.project Revert "Handle 'project' name collision" This reverts commit 4b1aca9075193dd0bb781b06a5a4224a2c298bde. --- src/Diagrams/Prelude.hs | 2 +- src/Diagrams/ThreeD/Transform.hs | 2 +- src/Diagrams/ThreeD/Types.hs | 2 +- src/Diagrams/TwoD/Polygons.hs | 2 +- src/Diagrams/TwoD/Types.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 3f496ce4..19e6dea5 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -148,5 +148,5 @@ import Data.AffineSpace import Data.Colour hiding (AffineSpace (..), atop, over) import Data.Colour.Names hiding (tan) import Data.Semigroup -import Data.VectorSpace hiding (Sum (..), project) +import Data.VectorSpace hiding (Sum (..)) import Control.Lens ((&), (.~), (%~)) diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index f6cb147b..e90f388f 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -18,7 +18,7 @@ module Diagrams.ThreeD.Transform where -import Diagrams.Core hiding (project) +import Diagrams.Core import qualified Diagrams.Core.Transform as T import Diagrams.ThreeD.Types diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 2c78e081..8cdc62ac 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -47,7 +47,7 @@ import Diagrams.Coordinates import Data.AffineSpace.Point import Data.Basis import Data.Cross -import Data.VectorSpace hiding (project) +import Data.VectorSpace ------------------------------------------------------------ -- 3D Euclidean space diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index fe72026e..d126acb2 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -61,7 +61,7 @@ import Data.Default.Class import Data.VectorSpace (magnitude, normalized, project, (<.>), (^*)) -import Diagrams.Core hiding (project) +import Diagrams.Core import Diagrams.Located import Diagrams.Path import Diagrams.Points (centroid) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index e46c2171..11655be0 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -42,7 +42,7 @@ import Data.AffineSpace.Point import Data.Basis import Data.MemoTrie (HasTrie (..)) import Data.NumInstances.Tuple () -import Data.VectorSpace hiding (project) +import Data.VectorSpace import Data.Typeable ------------------------------------------------------------ From 34c995dbc4cc235e0a716b106bae2e6179bdbd96 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sat, 8 Feb 2014 22:03:32 +0000 Subject: [PATCH 07/11] rename Projection to Deformation, &c. --- diagrams-lib.cabal | 6 +-- src/Diagrams/{Project.hs => Deform.hs} | 44 +++++++++---------- src/Diagrams/Prelude.hs | 2 +- src/Diagrams/ThreeD/{Project.hs => Deform.hs} | 42 +++++++++--------- src/Diagrams/TwoD.hs | 4 +- src/Diagrams/TwoD/Deform.hs | 36 +++++++++++++++ src/Diagrams/TwoD/Project.hs | 36 --------------- test/stretchtest.svg | 4 ++ 8 files changed, 89 insertions(+), 85 deletions(-) rename src/Diagrams/{Project.hs => Deform.hs} (60%) rename src/Diagrams/ThreeD/{Project.hs => Deform.hs} (50%) create mode 100644 src/Diagrams/TwoD/Deform.hs delete mode 100644 src/Diagrams/TwoD/Project.hs create mode 100644 test/stretchtest.svg diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 95f5708e..b4bf9538 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -43,7 +43,7 @@ Library Diagrams.Solve, Diagrams.Tangent, Diagrams.Transform, - Diagrams.Project + Diagrams.Deform Diagrams.BoundingBox, Diagrams.Names, Diagrams.Envelope, @@ -55,6 +55,7 @@ Library Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, Diagrams.TwoD.Combinators, + Diagrams.TwoD.Deform, Diagrams.TwoD.Transform, Diagrams.TwoD.Transform.ScaleInv, Diagrams.TwoD.Ellipse, @@ -64,7 +65,6 @@ Library Diagrams.TwoD.Offset, Diagrams.TwoD.Path, Diagrams.TwoD.Polygons, - Diagrams.TwoD.Project, Diagrams.TwoD.Shapes, Diagrams.TwoD.Vector, Diagrams.TwoD.Size, @@ -72,7 +72,7 @@ Library Diagrams.TwoD.Text, Diagrams.TwoD.Image, Diagrams.TwoD.Adjust, - Diagrams.ThreeD.Project, + Diagrams.ThreeD.Deform, Diagrams.ThreeD.Types, Diagrams.ThreeD.Shapes, Diagrams.ThreeD.Vector, diff --git a/src/Diagrams/Project.hs b/src/Diagrams/Deform.hs similarity index 60% rename from src/Diagrams/Project.hs rename to src/Diagrams/Deform.hs index bd39af66..2b13b338 100644 --- a/src/Diagrams/Project.hs +++ b/src/Diagrams/Deform.hs @@ -7,11 +7,11 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -module Diagrams.Project () -- export only instances +module Diagrams.Deform () -- export only instances where import Data.AffineSpace -import Data.VectorSpace hiding (project) +import Data.VectorSpace import Control.Lens (under, wrapped) import Diagrams.Core @@ -22,45 +22,45 @@ import Diagrams.Segment import Diagrams.Trail -- | Cubic curves are not closed under perspective projections. --- Therefore @Segment@s are not an instance of Projectable. However, --- the projection of a @Segment@ can be approximated to arbitrary --- precision by a series of @Segment@s. @projectSegment@ does this, +-- Therefore @Segment@s are not an instance of Deformable. However, +-- the deformation of a @Segment@ can be approximated to arbitrary +-- precision by a series of @Segment@s. @deformSegment@ does this, -- which allows types built from lists of @Segment@s to themselves be --- @Projectable@. -projectSegment :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => - s -> Projection v -> FixedSegment v -> [FixedSegment v] -projectSegment epsilon t s +-- @Deformable@. +deformSegment :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => + s -> Deformation v -> FixedSegment v -> [FixedSegment v] +deformSegment epsilon t s | goodEnough epsilon t s = [approx t s] - | otherwise = concatMap (projectSegment epsilon t) [s1, s2] + | otherwise = concatMap (deformSegment epsilon t) [s1, s2] where (s1, s2) = splitAtParam s 0.5 approx :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => - Projection v -> FixedSegment v -> FixedSegment v -approx t (FLinear p0 p1) = FLinear (project t p0) (project t p1) + Deformation v -> FixedSegment v -> FixedSegment v +approx t (FLinear p0 p1) = FLinear (deform t p0) (deform t p1) approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1) where - f = project t + f = deform t goodEnough :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => - s -> Projection v -> FixedSegment v -> Bool + s -> Deformation v -> FixedSegment v -> Bool goodEnough e t s = - all (< e) [magnitude $ project t (s `atParam` u) .-. approx t s `atParam` u + all (< e) [magnitude $ deform t (s `atParam` u) .-. approx t s `atParam` u | u <- [0.25, 0.5, 0.75]] instance (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => - Projectable (Located (Trail v)) where - project' eps p t + Deformable (Located (Trail v)) where + deform' eps p t | isLine $ unLoc t = line `at` p0 | otherwise = glueTrail line `at` p0 where - segs = concatMap (projectSegment eps p) $ fixTrail t + segs = concatMap (deformSegment eps p) $ fixTrail t p0 = case segs of (FLinear start _:_) -> start (FCubic start _ _ _:_) -> start _ -> loc t -- default in case of empty trail line = trailFromSegments $ map (unLoc . fromFixedSeg) segs - project p t = project' (0.01 * extent) p t where + deform p t = deform' (0.01 * extent) p t where -- estimate the "size" of the Trail' as -- the maximum distance to any vertex extent = maximum . map dist . trailVertices $ t @@ -68,6 +68,6 @@ instance (VectorSpace v, InnerSpace v, instance (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => - Projectable (Path v) where - project' eps p = under wrapped $ map (project' eps p) - project p = under wrapped $ map (project p) + Deformable (Path v) where + deform' eps p = under wrapped $ map (deform' eps p) + deform p = under wrapped $ map (deform p) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 19e6dea5..60386498 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -124,6 +124,7 @@ import Diagrams.Attributes import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.CubicSpline +import Diagrams.Deform () import Diagrams.Envelope import Diagrams.Located import Diagrams.Names @@ -131,7 +132,6 @@ import Diagrams.Parametric import Diagrams.Parametric.Adjust import Diagrams.Path import Diagrams.Points -import Diagrams.Project () import Diagrams.Query import Diagrams.Segment import Diagrams.Tangent diff --git a/src/Diagrams/ThreeD/Project.hs b/src/Diagrams/ThreeD/Deform.hs similarity index 50% rename from src/Diagrams/ThreeD/Project.hs rename to src/Diagrams/ThreeD/Deform.hs index 724edd91..c15af34a 100644 --- a/src/Diagrams/ThreeD/Project.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -1,51 +1,51 @@ -module Diagrams.ThreeD.Project where +module Diagrams.ThreeD.Deform where import Control.Lens -import Diagrams.Core.Project +import Diagrams.Core.Deform import Diagrams.Coordinates import Diagrams.ThreeD.Types -- | The parallel projection onto the plane x=0 -parallelX0 :: Projection R3 -parallelX0 = Projection (& _x .~ 0) +parallelX0 :: Deformation R3 +parallelX0 = Deformation (& _x .~ 0) -- | The perspective division onto the plane x=1 along lines going -- through the origin. -perspectiveX1 :: Projection R3 -perspectiveX1 = Projection (\p -> let x = p^._x in +perspectiveX1 :: Deformation R3 +perspectiveX1 = Deformation (\p -> let x = p^._x in p & _x .~ 1 & _y //~ x & _z //~ x ) -- | The parallel projection onto the plane y=0 -parallelY0 :: Projection R3 -parallelY0 = Projection (& _y .~ 0) +parallelY0 :: Deformation R3 +parallelY0 = Deformation (& _y .~ 0) -- | The perspective division onto the plane y=1 along lines going -- through the origin. -perspectiveY1 :: Projection R3 -perspectiveY1 = Projection (\p -> let y = p^._y in +perspectiveY1 :: Deformation R3 +perspectiveY1 = Deformation (\p -> let y = p^._y in p & _x //~ y & _y .~ 1 & _z //~ y ) -- | The parallel projection onto the plane z=0 -parallelZ0 :: Projection R3 -parallelZ0 = Projection (& _z .~ 0) +parallelZ0 :: Deformation R3 +parallelZ0 = Deformation (& _z .~ 0) -- | The perspective division onto the plane z=1 along lines going -- through the origin. -perspectiveZ1 :: Projection R3 -perspectiveZ1 = Projection (\p -> let z = p^._z in +perspectiveZ1 :: Deformation R3 +perspectiveZ1 = Deformation (\p -> let z = p^._z in p & _x //~ z & _y //~ z & _z .~ 1 ) -- | The viewing transform for a viewer facing along the positive X -- axis. X coördinates stay fixed, while Y coördinates are compressed --- with increasing distance. @asProjection (translation unitX) <> +-- with increasing distance. @asDeformation (translation unitX) <> -- parallelX0 <> frustrumX = perspectiveX1@ -facingX :: Projection R3 -facingX = Projection (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) +facingX :: Deformation R3 +facingX = Deformation (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) -facingY :: Projection R3 -facingY = Projection (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) +facingY :: Deformation R3 +facingY = Deformation (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) -facingZ :: Projection R3 -facingZ = Projection (\v -> v & _x //~ (v^._z) & _y //~ (v^._z)) +facingZ :: Deformation R3 +facingZ = Deformation (\v -> v & _x //~ (v^._z) & _y //~ (v^._z)) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 7aa97e71..fa9c6989 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -189,7 +189,7 @@ module Diagrams.TwoD , shearingX, shearX , shearingY, shearY - -- * Projections - non-affine transforms + -- * Deformations - non-affine transforms , parallelX0, perspectiveX1, parallelY0, perspectiveY1 , facingX, facingY @@ -251,7 +251,7 @@ import Diagrams.TwoD.Image import Diagrams.TwoD.Model import Diagrams.TwoD.Path import Diagrams.TwoD.Polygons -import Diagrams.TwoD.Project +import Diagrams.TwoD.Deform import Diagrams.TwoD.Shapes import Diagrams.TwoD.Size import Diagrams.TwoD.Text diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs new file mode 100644 index 00000000..d94badb8 --- /dev/null +++ b/src/Diagrams/TwoD/Deform.hs @@ -0,0 +1,36 @@ +module Diagrams.TwoD.Deform where + +import Control.Lens + +import Diagrams.Core.Deform + +import Diagrams.Coordinates +import Diagrams.TwoD.Types + +-- | The parallel projection onto the line x=0 +parallelX0 :: Deformation R2 +parallelX0 = Deformation (& _x .~ 0) + +-- | The perspective division onto the line x=1 along lines going +-- through the origin. +perspectiveX1 :: Deformation R2 +perspectiveX1 = Deformation (\p -> p & _y //~ (p^._x) & _x .~ 1) + +-- | The parallel projection onto the line y=0 +parallelY0 :: Deformation R2 +parallelY0 = Deformation (& _y .~ 0) + +-- | The perspective division onto the line y=1 along lines going +-- through the origin. +perspectiveY1 :: Deformation R2 +perspectiveY1 = Deformation (\p -> p & _x //~ (p^._y) & _y .~ 1) + +-- | The viewing transform for a viewer facing along the positive X +-- axis. X coördinates stay fixed, while Y coördinates are compressed +-- with increasing distance. @asDeformation (translation unitX) <> +-- parallelX0 <> frustrumX = perspectiveX1@ +facingX :: Deformation R2 +facingX = Deformation (\v -> v & _y //~ (v^._x)) + +facingY :: Deformation R2 +facingY = Deformation (\v -> v & _x //~ (v^._y)) diff --git a/src/Diagrams/TwoD/Project.hs b/src/Diagrams/TwoD/Project.hs deleted file mode 100644 index 23c10965..00000000 --- a/src/Diagrams/TwoD/Project.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Diagrams.TwoD.Project where - -import Control.Lens - -import Diagrams.Core.Project - -import Diagrams.Coordinates -import Diagrams.TwoD.Types - --- | The parallel projection onto the line x=0 -parallelX0 :: Projection R2 -parallelX0 = Projection (& _x .~ 0) - --- | The perspective division onto the line x=1 along lines going --- through the origin. -perspectiveX1 :: Projection R2 -perspectiveX1 = Projection (\p -> p & _y //~ (p^._x) & _x .~ 1) - --- | The parallel projection onto the line y=0 -parallelY0 :: Projection R2 -parallelY0 = Projection (& _y .~ 0) - --- | The perspective division onto the line y=1 along lines going --- through the origin. -perspectiveY1 :: Projection R2 -perspectiveY1 = Projection (\p -> p & _x //~ (p^._y) & _y .~ 1) - --- | The viewing transform for a viewer facing along the positive X --- axis. X coördinates stay fixed, while Y coördinates are compressed --- with increasing distance. @asProjection (translation unitX) <> --- parallelX0 <> frustrumX = perspectiveX1@ -facingX :: Projection R2 -facingX = Projection (\v -> v & _y //~ (v^._x)) - -facingY :: Projection R2 -facingY = Projection (\v -> v & _x //~ (v^._y)) diff --git a/test/stretchtest.svg b/test/stretchtest.svg new file mode 100644 index 00000000..1b670d83 --- /dev/null +++ b/test/stretchtest.svg @@ -0,0 +1,4 @@ + + + \ No newline at end of file From 4de7282fd822aa6166445bd1c794bc15cb48f4cc Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sat, 8 Feb 2014 23:26:44 +0000 Subject: [PATCH 08/11] -Wall: rename shadowing names --- src/Diagrams/Combinators.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 7156e895..d38d56ab 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -157,10 +157,10 @@ deformEnvelope :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) => (Scalar v) -> v -> QDiagram b v m -> QDiagram b v m -deformEnvelope s v d = setEnvelope (getEnvelope d & unwrapping Envelope %~ deform) d +deformEnvelope s v d = setEnvelope (getEnvelope d & unwrapping Envelope %~ deformE) d where - deform = Option . fmap deform' . getOption - deform' env v' + deformE = Option . fmap deformE' . getOption + deformE' env v' | dot > 0 = Max $ getMax (env v') + (dot * s) / magnitude v' | otherwise = env v' where From ebbb0b07361e433718ded8d9a1249110c531277b Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sun, 9 Feb 2014 16:10:18 +0000 Subject: [PATCH 09/11] Define Deformations in -lib, not -core --- src/Diagrams/Deform.hs | 57 ++++++++++++++++++++++++++++++++--- src/Diagrams/ThreeD/Deform.hs | 2 +- src/Diagrams/TwoD/Deform.hs | 2 +- 3 files changed, 54 insertions(+), 7 deletions(-) diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs index 2b13b338..d7899b38 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -7,12 +7,15 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -module Diagrams.Deform () -- export only instances - where +module Diagrams.Deform (Deformation(..), Deformable(..), asDeformation) where +import Control.Lens (under, _Unwrapped) import Data.AffineSpace +import Data.Basis +import Data.MemoTrie +import Data.Monoid hiding ((<>)) +import Data.Semigroup import Data.VectorSpace -import Control.Lens (under, wrapped) import Diagrams.Core import Diagrams.Located @@ -21,6 +24,50 @@ import Diagrams.Path import Diagrams.Segment import Diagrams.Trail +------------------------------------------------------------ +-- Deformations + +-- | @Deformations@ are a superset of the affine transformations +-- represented by the 'Transformation' type. In general they are not +-- invertable. @Deformation@s include projective transformations. +-- @Deformation@ can represent other functions from points to points +-- which are "well-behaved", in that they do not introduce small wiggles. +data Deformation v = Deformation (Point v -> Point v) + +instance Semigroup (Deformation v) where + (Deformation p1) <> (Deformation p2) = Deformation (p1 . p2) + +instance Monoid (Deformation v) where + mappend = (<>) + mempty = Deformation id + +class Deformable a where + -- | @deform' epsilon d a@ transforms @a@ by the deformation @d@. + -- If the type of @a@ is not closed under projection, approximate + -- to accuracy @epsilon@. + deform' :: Scalar (V a) -> Deformation (V a) -> a -> a + + -- | @deform d a@ transforms @a@ by the deformation @d@. + -- If the type of @a@ is not closed under projection, @deform@ + -- should call @deform'@ with some reasonable default value of + -- @epsilon@. + deform :: Deformation (V a) -> a -> a + +-- | @asDeformation@ converts a 'Transformation' to a 'Deformation' by +-- discarding the inverse transform. This allows reusing +-- @Transformation@s in the construction of @Deformation@s. +asDeformation + :: ( HasTrie (Basis v), HasBasis v) => Transformation v -> Deformation v +asDeformation t = Deformation f' where + f' = papply t + +------------------------------------------------------------ +-- Instances + +instance Deformable (Point v) where + deform' = const deform + deform (Deformation l) = l + -- | Cubic curves are not closed under perspective projections. -- Therefore @Segment@s are not an instance of Deformable. However, -- the deformation of a @Segment@ can be approximated to arbitrary @@ -69,5 +116,5 @@ instance (VectorSpace v, InnerSpace v, instance (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => Deformable (Path v) where - deform' eps p = under wrapped $ map (deform' eps p) - deform p = under wrapped $ map (deform p) + deform' eps p = under _Unwrapped $ map (deform' eps p) + deform p = under _Unwrapped $ map (deform p) diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs index c15af34a..3fb13d30 100644 --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -2,7 +2,7 @@ module Diagrams.ThreeD.Deform where import Control.Lens -import Diagrams.Core.Deform +import Diagrams.Deform import Diagrams.Coordinates import Diagrams.ThreeD.Types diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs index d94badb8..c324ce69 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -2,7 +2,7 @@ module Diagrams.TwoD.Deform where import Control.Lens -import Diagrams.Core.Deform +import Diagrams.Deform import Diagrams.Coordinates import Diagrams.TwoD.Types From 4224275b6a0815134e20efc105c1e4761a09d206 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sun, 9 Feb 2014 18:53:17 +0000 Subject: [PATCH 10/11] remove unused pragmas --- src/Diagrams/Deform.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs index d7899b38..364cc7b2 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -1,11 +1,8 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} module Diagrams.Deform (Deformation(..), Deformable(..), asDeformation) where From e1404abbaed41360795543dd1381492ba08b1f4d Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 11 Feb 2014 15:23:53 +0000 Subject: [PATCH 11/11] Export Diagrams.Deform from Diagrams.Prelude --- src/Diagrams/Prelude.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 60386498..2ca15805 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -61,6 +61,10 @@ module Diagrams.Prelude -- conjugation of transformations. , module Diagrams.Transform + -- | Projective transformations and other deformations + -- lacking an inverse. + , module Diagrams.Deform + -- | Giving names to subdiagrams and later retrieving -- subdiagrams by name. , module Diagrams.Names @@ -124,7 +128,7 @@ import Diagrams.Attributes import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.CubicSpline -import Diagrams.Deform () +import Diagrams.Deform import Diagrams.Envelope import Diagrams.Located import Diagrams.Names