diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 98029f0a..99ba9d01 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -44,6 +44,7 @@ Library Diagrams.Solve, Diagrams.Tangent, Diagrams.Transform, + Diagrams.Deform Diagrams.BoundingBox, Diagrams.Names, Diagrams.Envelope, @@ -55,6 +56,7 @@ Library Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, Diagrams.TwoD.Combinators, + Diagrams.TwoD.Deform, Diagrams.TwoD.Transform, Diagrams.TwoD.Transform.ScaleInv, Diagrams.TwoD.Ellipse, @@ -73,12 +75,13 @@ Library Diagrams.TwoD.Adjust, Diagrams.ThreeD.Align, Diagrams.ThreeD.Camera, + Diagrams.ThreeD.Deform, Diagrams.ThreeD.Light, Diagrams.ThreeD.Shapes, Diagrams.ThreeD.Transform, Diagrams.ThreeD.Types, Diagrams.ThreeD.Vector, - Diagrams.ThreeD + Diagrams.ThreeD, Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Util, diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 914264c3..b2a9add5 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -160,10 +160,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 & _Wrapping Envelope %~ deform) d +deformEnvelope s v d = setEnvelope (getEnvelope d & _Wrapping 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 diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs new file mode 100644 index 00000000..364cc7b2 --- /dev/null +++ b/src/Diagrams/Deform.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +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 Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +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 +-- precision by a series of @Segment@s. @deformSegment@ does this, +-- which allows types built from lists of @Segment@s to themselves be +-- @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 (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) => + 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 = deform t + +goodEnough :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => + s -> Deformation v -> FixedSegment v -> Bool +goodEnough e t s = + 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) => + Deformable (Located (Trail v)) where + deform' eps p t + | isLine $ unLoc t = line `at` p0 + | otherwise = glueTrail line `at` p0 + where + 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 + 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 + dist pt = magnitude $ pt .-. loc t + +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 _Unwrapped $ map (deform' eps p) + deform p = under _Unwrapped $ map (deform p) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 31b280b8..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,6 +128,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 diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index aa82da6e..bfaea3f0 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 -------------------------------------- ------------------------------------------------------------ diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs new file mode 100644 index 00000000..3fb13d30 --- /dev/null +++ b/src/Diagrams/ThreeD/Deform.hs @@ -0,0 +1,51 @@ +module Diagrams.ThreeD.Deform where + +import Control.Lens + +import Diagrams.Deform + +import Diagrams.Coordinates +import Diagrams.ThreeD.Types + +-- | The parallel projection onto the plane x=0 +parallelX0 :: Deformation R3 +parallelX0 = Deformation (& _x .~ 0) + +-- | The perspective division onto the plane x=1 along lines going +-- through the origin. +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 :: Deformation R3 +parallelY0 = Deformation (& _y .~ 0) + +-- | The perspective division onto the plane y=1 along lines going +-- through the origin. +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 :: Deformation R3 +parallelZ0 = Deformation (& _z .~ 0) + +-- | The perspective division onto the plane z=1 along lines going +-- through the origin. +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. @asDeformation (translation unitX) <> +-- parallelX0 <> frustrumX = perspectiveX1@ +facingX :: Deformation R3 +facingX = Deformation (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) + +facingY :: Deformation R3 +facingY = Deformation (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) + +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 44cc9680..fa9c6989 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -189,6 +189,10 @@ module Diagrams.TwoD , shearingX, shearX , shearingY, shearY + -- * Deformations - 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.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..c324ce69 --- /dev/null +++ b/src/Diagrams/TwoD/Deform.hs @@ -0,0 +1,36 @@ +module Diagrams.TwoD.Deform where + +import Control.Lens + +import Diagrams.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/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