Projections - non-affine transformations

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,

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 & _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

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)

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

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  --------------------------------------
 ------------------------------------------------------------

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))

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

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))