Transform.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.ThreeD.Transform
-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Transformations specific to three dimensions, with a few generic
-- transformations (uniform scaling, translation) also re-exported for
-- convenience.
--
-----------------------------------------------------------------------------

module Diagrams.ThreeD.Transform
       ( T3

         -- * Rotation
       , aboutX, aboutY, aboutZ
       , rotationAbout, rotateAbout
       , pointAt, pointAt'

       -- * Scaling
       , scalingX, scalingY, scalingZ
       , scaleX, scaleY, scaleZ
       , scaling, scale

       -- * Translation
       , translationX, translateX
       , translationY, translateY
       , translationZ, translateZ
       , translation, translate

         -- * Reflection
       , reflectionX, reflectX
       , reflectionY, reflectY
       , reflectionZ, reflectZ
       , reflectionAcross, reflectAcross

       ) where

import           Diagrams.Core
import           Diagrams.Core.Transform

import           Diagrams.Angle
import           Diagrams.Direction
import           Diagrams.ThreeD.Types
import           Diagrams.Transform
import           Diagrams.Points

import           Control.Lens            (view, (&), (*~), (.~), (//~))
import           Data.Semigroup
import           Diagrams.TwoD.Transform

import           Linear.Affine
import           Linear.Metric
import           Linear.V3               (cross)
import           Linear.Vector

-- | Create a transformation which rotates by the given angle about
--   a line parallel the Z axis passing through the local origin.
--   A positive angle brings positive x-values towards the positive-y axis.
--
--   The angle can be expressed using any type which is an
--   instance of 'Angle'.  For example, @aboutZ (1\/4 \@\@
--   'turn')@, @aboutZ (tau\/4 \@\@ 'rad')@, and @aboutZ (90 \@\@
--   'deg')@ all represent the same transformation, namely, a
--   counterclockwise rotation by a right angle.  For more general rotations,
--   see 'rotationAbout'.
--
--   Note that writing @aboutZ (1\/4)@, with no type annotation, will
--   yield an error since GHC cannot figure out which sort of angle
--   you want to use.
aboutZ :: Floating n => Angle n -> Transformation V3 n
aboutZ (view rad -> a) = fromOrthogonal r where
  r = rot a <-> rot (-a)
  rot θ (V3 x y z) = V3 (cos θ * x - sin θ * y)
                        (sin θ * x + cos θ * y)
                        z

-- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values
-- towards the positive z-axis.
aboutX :: Floating n => Angle n -> Transformation V3 n
aboutX (view rad -> a) = fromOrthogonal r where
  r = rot a <-> rot (-a)
  rot θ (V3 x y z) = V3 x
                        (cos θ * y - sin θ * z)
                        (sin θ * y + cos θ * z)

-- | Like 'aboutZ', but rotates about the Y axis, bringing postive
-- x-values towards the negative z-axis.
aboutY :: Floating n => Angle n -> Transformation V3 n
aboutY (view rad -> a) = fromOrthogonal r where
  r = rot a <-> rot (-a)
  rot θ (V3 x y z) = V3 (cos θ * x + sin θ * z)
                        y
                        (-sin θ * x + cos θ * z)

-- | @rotationAbout p d a@ is a rotation about a line parallel to @d@
--   passing through @p@.
rotationAbout
  :: Floating n
  => Point V3 n         -- ^ origin of rotation
  -> Direction V3 n     -- ^ direction of rotation axis
  -> Angle n            -- ^ angle of rotation
  -> Transformation V3 n
rotationAbout (P t) d (view rad -> a)
  = mconcat [translation (negated t),
             fromOrthogonal r,
             translation t] where
    r = rot a <-> rot (-a)
    w = fromDirection d

    rot θ v =          v ^* cos θ
           ^+^ cross w v ^* sin θ
           ^+^         w ^* ((w `dot` v) * (1 - cos θ))

-- | @rotationAbout p d a@ is a rotation about a line parallel to @d@
--   passing through @p@.
rotateAbout
  :: (InSpace V3 n t, Floating n, Transformable t)
  => Point V3 n         -- ^ origin of rotation
  -> Direction V3 n     -- ^ direction of rotation axis
  -> Angle n            -- ^ angle of rotation
  -> t -> t
rotateAbout p d theta = transform (rotationAbout p d theta)

-- | @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 @about@ 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 :: Floating n
        => Direction V3 n -> Direction V3 n -> Direction V3 n
        -> Transformation V3 n
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' :: Floating n => V3 n -> V3 n -> V3 n -> Transformation V3 n
pointAt' about initial final = pointAtUnit (signorm about) (signorm initial) (signorm final)

-- | pointAtUnit has the same behavior as @pointAt@, but takes unit vectors.
pointAtUnit :: Floating n => V3 n -> V3 n -> V3 n -> Transformation V3 n
pointAtUnit about initial final = tilt <> pan where
  -- rotating u by (signedAngle rel u v) about rel gives a vector in the direction of v
  signedAngle rel u v = signum (cross u v `dot` rel) *^ angleBetween u v
  inPanPlaneF = final ^-^ project about final
  inPanPlaneI = initial ^-^ project about initial
  panAngle    = signedAngle about inPanPlaneI inPanPlaneF
  pan         = rotationAbout origin (direction about) panAngle
  tiltAngle   = signedAngle tiltAxis (transform pan initial) final
  tiltAxis    = cross final about
  tilt        = rotationAbout origin (direction tiltAxis) tiltAngle

-- Scaling -------------------------------------------------

-- | Construct a transformation which scales by the given factor in
--   the z direction.
scalingZ :: (Additive v, R3 v, Fractional n) => n -> Transformation v n
scalingZ c = fromSymmetric $ (_z *~ c) <-> (_z //~ c)

-- | Scale a diagram by the given factor in the z direction.  To scale
-- uniformly, use 'scale'.
scaleZ :: (InSpace v n t, R3 v, Fractional n, Transformable t) => n -> t -> t
scaleZ = transform . scalingZ

-- Translation ----------------------------------------

-- | Construct a transformation which translates by the given distance
--   in the z direction.
translationZ :: (Additive v, R3 v, Num n) => n -> Transformation v n
translationZ z = translation (zero & _z .~ z)

-- | Translate a diagram by the given distance in the y
--   direction.
translateZ :: (InSpace v n t, R3 v, Transformable t) => n -> t -> t
translateZ = transform . translationZ

-- Reflection ----------------------------------------------

-- | Construct a transformation which flips a diagram across z=0,
-- i.e. sends the point (x,y,z) to (x,y,-z).
reflectionZ :: (Additive v, R3 v, Num n) => Transformation v n
reflectionZ = fromSymmetric $ (_z *~ (-1)) <-> (_z *~ (-1))

-- | Flip a diagram across z=0, i.e. send the point (x,y,z) to
-- (x,y,-z).
reflectZ :: (InSpace v n t, R3 v, Transformable t) => t -> t
reflectZ = transform reflectionZ

-- | @reflectionAcross p v@ is a reflection across the plane through
--   the point @p@ and normal to vector @v@. This also works as a 2D
--   transform where @v@ is the normal to the line passing through point
--   @p@.
reflectionAcross :: (Metric v, Fractional n)
  => Point v n -> v n -> Transformation v n
reflectionAcross p v =
  conjugate (translation (origin .-. p)) reflect
    where
      reflect = fromLinear t (linv t)
      t       = f v <-> f (negated v)
      f u w   = w ^-^ 2 *^ project u w

-- | @reflectAcross p v@ reflects a diagram across the plane though
--   the point @p@ and the vector @v@. This also works as a 2D transform
--   where @v@ is the normal to the line passing through point @p@.
reflectAcross :: (InSpace v n t, Metric v, Fractional n, Transformable t)
  => Point v n -> v n -> t -> t
reflectAcross p v = transform (reflectionAcross p v)