Merge pull request #129 from diagrams/3D-util

3D scaling, alignment, coordinate lenses

diagrams-lib.cabal

@@ -75,6 +75,7 @@ Library
                        Diagrams.ThreeD.Transform,
                        Diagrams.ThreeD.Camera,
                        Diagrams.ThreeD.Light,
+                       Diagrams.ThreeD
                        Diagrams.Animation,
                        Diagrams.Animation.Active,
                        Diagrams.Util,

src/Diagrams/Coordinates.hs

@@ -18,9 +18,15 @@
 -----------------------------------------------------------------------------
 
 module Diagrams.Coordinates
-    ( (:&)(..), Coordinates(..) )
+    ( (:&)(..), Coordinates(..)
+
+    -- * Lenses for particular axes
+    , HasX(..), HasY(..), HasZ(..)
+    )
     where
 
+import           Control.Lens          (Lens')
+
 import           Diagrams.Core.Points
 
 -- | A pair of values, with a convenient infix (left-associative)
@@ -104,3 +110,15 @@ instance Coordinates v => Coordinates (Point v) where
 
   x & y        = P (x & y)
   coords (P v) = coords v
+
+-- | The class of types with at least one coordinate, called _x.
+class HasX t where
+    _x :: Lens' t Double
+
+-- | The class of types with at least two coordinates, the second called _y.
+class HasY t where
+    _y :: Lens' t Double
+
+-- | The class of types with at least three coordinates, the third called _z.
+class HasZ t where
+    _z :: Lens' t Double

src/Diagrams/ThreeD.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.ThreeD
+-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  diagrams-discuss@googlegroups.com
+--
+-- This module defines the three-dimensional vector space R^3,
+-- three-dimensional transformations, and various predefined
+-- three-dimensional shapes.  This module re-exports useful
+-- functionality from a group of more specific modules:
+--
+--   * "Diagrams.ThreeD.Types" defines basic types for two-dimensional
+--     diagrams, including types representing the 3D Euclidean vector
+--     space and various systems of representing directions.
+--
+--   * "Diagrams.ThreeD.Transform" defines R^3-specific transformations
+--     such as rotation by an angle, and scaling, translation, and
+--     reflection in the X, Y, and Z directions.
+--
+--   * "Diagrams.ThreeD.Shapes" defines three-dimensional solids,
+--     e.g. spheres and cubes.
+--
+--   * "Diagrams.ThreeD.Vector" defines some special 3D vectors and
+--     functions for converting between vectors and directions.
+--
+--   * "Diagrams.ThreeD.Light" and "Diagrams.ThreeD.Camera" define types needed
+--     for rendering 3D geometry to (2D) images.
+-----------------------------------------------------------------------------
+module Diagrams.ThreeD
+       ( module Diagrams.ThreeD.Types
+       , module Diagrams.ThreeD.Transform
+       , module Diagrams.ThreeD.Vector
+       , module Diagrams.ThreeD.Shapes
+       , module Diagrams.ThreeD.Light
+       , module Diagrams.ThreeD.Camera
+       ) where
+
+
+import Diagrams.ThreeD.Transform
+import Diagrams.ThreeD.Vector
+import Diagrams.ThreeD.Light
+import Diagrams.ThreeD.Types
+import Diagrams.ThreeD.Camera
+import Diagrams.ThreeD.Shapes

src/Diagrams/ThreeD/Align.hs

@@ -0,0 +1,209 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies     #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.ThreeD.Align
+-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  diagrams-discuss@googlegroups.com
+--
+-- Alignment combinators specialized for three dimensions.  See
+-- "Diagrams.Align" for more general alignment combinators.
+--
+-- The basic idea is that alignment is achieved by moving diagrams'
+-- local origins relative to their envelopes or traces (or some other
+-- sort of boundary).  For example, to align several diagrams along
+-- their tops, we first move their local origins to the upper edge of
+-- their boundary (using e.g. @map 'alignZMax'@), and then put them
+-- together with their local origins along a line (using e.g. 'cat'
+-- from "Diagrams.Combinators").
+--
+-----------------------------------------------------------------------------
+
+module Diagrams.TwoD.Align
+    ( -- * Absolute alignment
+      -- ** Align by envelope
+      alignXMin, alignXMax, alignYMin, alignYMax, alignZMin, alignZMax
+
+      -- ** Align by trace
+    , snugXMin, snugXMax, snugYMin, snugYMax, snugZMin, snugZMax
+
+      -- * Relative alignment
+    , alignX, snugX, alignY, snugY, alignZ, snugZ
+
+      -- * Centering
+    , centerX, centerY, centerZ
+    , centerXY, centerXZ, centerYZ
+    , snugCenterX, snugCenterY, snugCenterZ
+    , snugCenterXY, snugCenterXZ, snugCenterYZ
+
+    ) where
+
+import           Diagrams.Core
+
+import           Diagrams.Align
+import           Diagrams.ThreeD.Types
+import           Diagrams.ThreeD.Vector
+
+import           Data.VectorSpace
+
+-- | Translate the diagram along unitX so that all points have
+-- positive x-values.
+alignXMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+alignXMin = align (negateV unitX)
+
+snugXMin :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugXMin = snug (negateV unitX)
+
+-- | Translate the diagram along unitX so that all points have
+-- negative x-values.
+alignXMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+alignXMax = align unitX
+
+snugXMax :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugXMax = snug unitX
+
+
+-- | Translate the diagram along unitY so that all points have
+-- negative y-values.
+alignYMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+alignYMax = align unitY
+
+-- | Move the origin along unitY until it touches the edge of the
+-- diagram.
+snugYMax:: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugYMax = snug unitY
+
+-- | Translate the diagram along unitY so that all points have
+-- positive y-values.
+alignYMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+alignYMin = align (negateV unitY)
+
+snugYMin :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugYMin = snug (negateV unitY)
+
+-- | Translate the diagram along unitZ so that all points have
+-- negative z-values.
+alignZMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+alignZMax = align unitZ
+
+-- | Move the origin along unitZ until it touches the edge of the
+-- diagram.
+snugZMax:: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugZMax = snug unitZ
+
+-- | Translate the diagram along unitZ so that all points have
+-- positive z-values.
+alignZMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+alignZMin = align (negateV unitZ)
+
+-- | Move the origin along unit_Z until it touches the edge of the
+-- diagram.
+snugZMin :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugZMin = snug (negateV unitZ)
+
+-- | @alignX@ and @snugX@ move the local origin along unitX as follows:
+--
+--   * @alignX (-1)@ moves the local origin to the low-x of the boundary;
+--
+--   * @align 1@ moves the local origin to the high-x edge;
+--
+--   * any other argument interpolates linearly between these.  For
+--     example, @alignX 0@ centers, @alignX 2@ moves the origin one
+--     \"radius\" to the right of the right edge, and so on.
+--
+--   * @snugX@ works the same way.
+
+alignX :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a
+alignX = alignBy unitX
+
+-- | See the documentation for 'alignX'.
+snugX :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => Double -> a -> a
+snugX = snugBy unitX
+
+-- | Like 'alignX', but moving the local origin vertically, with an
+--   argument of @1@ corresponding to the top edge and @(-1)@ corresponding
+--   to the bottom edge.
+alignY :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a
+alignY = alignBy unitY
+
+snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => Double -> a -> a
+snugY = snugBy unitY
+
+
+-- | Like 'alignX', but moving the local origin in the Z direction, with an
+--   argument of @1@ corresponding to the top edge and @(-1)@ corresponding
+--   to the bottom edge.
+alignZ :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a
+alignZ = alignBy unitZ
+
+snugZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => Double -> a -> a
+snugZ = snugBy unitZ
+
+-- | Center the local origin along the X-axis.
+centerX  :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+centerX  = alignBy unitX 0
+
+snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugCenterX = snugBy unitX 0
+
+-- | Center the local origin along the Y-axis.
+centerY  :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+centerY  = alignBy unitY 0
+
+snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugCenterY = snugBy unitY 0
+
+-- | Center the local origin along the Z-axis.
+centerZ  :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+centerZ  = alignBy unitZ 0
+
+snugCenterZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugCenterZ = snugBy unitZ 0
+
+-- | Center along both the X- and Y-axes.
+centerXY :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+centerXY = centerX . centerY
+
+snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugCenterXY = snugCenterX . snugCenterY
+
+
+-- | Center along both the X- and Z-axes.
+centerXZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+centerXZ = centerX . centerZ
+
+snugCenterXZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugCenterXZ = snugCenterX . snugCenterZ
+
+
+-- | Center along both the Y- and Z-axes.
+centerYZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a
+centerYZ = centerZ . centerY
+
+snugCenterYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugCenterYZ = snugCenterZ . snugCenterY
+
+-- | Center an object in three dimensions.
+centerXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+centerXYZ = centerX . centerY . centerZ
+
+snugCenterXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,
+      HasOrigin a, V a ~ R3) => a -> a
+snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ

src/Diagrams/ThreeD/Transform.hs

@@ -25,6 +25,7 @@ import           Diagrams.Coordinates
 import           Diagrams.ThreeD.Types
 import           Diagrams.ThreeD.Vector
 
+import           Control.Lens                   ((*~), (//~))
 import           Data.Semigroup
 
 import           Data.AffineSpace
@@ -75,13 +76,13 @@ aboutY ang = fromLinear r (linv r) where
 
 -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@
 --   passing through @p@.
-rotatationAbout
+rotationAbout
   :: (Angle a, Direction d)
   => P3     -- ^ origin of rotation
   -> d      -- ^ direction of rotation axis
   -> a      -- ^ angle of rotation
   -> T3
-rotatationAbout p d a
+rotationAbout p d a
   = mconcat [translation (negateV t),
              fromLinear r (linv r),
              translation t] where
@@ -94,6 +95,62 @@ rotatationAbout p d a
                w ^* ((w <.> v) * (1 - cos th))
     t = p .-. origin
 
+-- | @pointAt about initial final@ produces a rotation which brings
+-- the direction @initial@ to point in the direction @final@ by first
+-- panning around @about@, then tilting about the axis perpendicular
+-- to initial and final.  In particular, if this can be accomplished
+-- 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 a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f)
+
+-- | pointAt' has the same behavior as 'pointAt', but takes vectors
+-- instead of directions.
+pointAt' :: R3 -> R3 -> R3 -> T3
+pointAt' about initial final = tilt <> pan where
+  inPanPlane    = final ^-^ project final initial
+  panAngle      = angleBetween initial inPanPlane :: Turn
+  pan           = rotationAbout origin (direction about :: Spherical Turn) panAngle
+  tiltAngle     = angleBetween initial inPanPlane :: Turn
+  tiltDir       = direction $ cross3 inPanPlane about :: Spherical Turn
+  tilt          = rotationAbout origin tiltDir tiltAngle
+
+-- Scaling -------------------------------------------------
+
+-- | Construct a transformation which scales by the given factor in
+--   the x direction.
+scalingX :: Double -> T3
+scalingX c = fromLinear s s
+  where s = (_x *~ c) <-> (_x //~ c)
+
+-- | Scale a diagram by the given factor in the x (horizontal)
+--   direction.  To scale uniformly, use 'scale'.
+scaleX :: (Transformable t, V t ~ R3) => Double -> t -> t
+scaleX = transform . scalingX
+
+-- | Construct a transformation which scales by the given factor in
+--   the y direction.
+scalingY :: Double -> T3
+scalingY c = fromLinear s s
+  where s = (_y *~ c) <-> (_y //~ c)
+
+-- | Scale a diagram by the given factor in the y (vertical)
+--   direction.  To scale uniformly, use 'scale'.
+scaleY :: (Transformable t, V t ~ R3) => Double -> t -> t
+scaleY = transform . scalingY
+
+-- | Construct a transformation which scales by the given factor in
+--   the z direction.
+scalingZ :: Double -> T3
+scalingZ c = fromLinear s s
+  where s = (_z *~ c) <-> (_z //~ c)
+
+-- | Scale a diagram by the given factor in the z direction.  To scale
+-- uniformly, use 'scale'.
+scaleZ :: (Transformable t, V t ~ R3) => Double -> t -> t
+scaleZ = transform . scalingZ
+
 -- | Get the matrix equivalent of an affine transform, as a triple of
 --   columns paired with the translation vector.  This is mostly
 --   useful for implementing backends.