{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.ThreeD.Projection
-- Copyright   :  (c) 2014 diagrams team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- 3D projections are a way of viewing a three-dimensional objects on a
-- two-dimensional plane.
--
-- This module can be used with the functions in "Linear.Projection".
--
-- Disclaimer: This module should be considered experimental and is
-- likely to change.
--
-----------------------------------------------------------------------------

module Diagrams.ThreeD.Projection
  ( -- * Orthographic projections

    -- $orthographic
    -- ** Parallel projections
    facingXY
  , facingXZ
  , facingYZ

    -- ** axonometric
    -- $axonometric

    -- *** Isometric projections
    -- $isometric
  , isometricApply
  , isometric

  , lookingAt

    -- ** Affine maps
  , m44AffineApply
  , m44AffineMap
  , m33AffineApply
  , m33AffineMap

    -- * Perspective projections
    -- $perspective
    -- ** Perspective deformations
  , m44Deformation
  , module Linear.Projection
  ) where

import           Control.Lens           hiding (transform)
import           Data.Functor.Rep

import           Diagrams.Core
import           Diagrams.Deform
import           Diagrams.Direction
import           Diagrams.LinearMap
import           Diagrams.ThreeD.Types  (P3)
import           Diagrams.ThreeD.Vector

import           Linear                 as L
import           Linear.Affine
import           Linear.Projection

------------------------------------------------------------------------
-- Orthographic projections
------------------------------------------------------------------------

-- $orthographic
-- Orthographic projections are a form of parallel projections where are
-- projection lines are orthogonal to the projection plane.

-- Parallel projections

-- | Look at the xy-plane with y as the up direction.
facingXY :: (Epsilon n, Floating n) => AffineMap V3 V2 n
facingXY :: AffineMap V3 V2 n
facingXY = P3 n -> P3 n -> Direction V3 n -> AffineMap V3 V2 n
forall n.
(Epsilon n, Floating n) =>
P3 n -> P3 n -> Direction V3 n -> AffineMap V3 V2 n
lookingAt P3 n
forall (v :: * -> *) n. (R3 v, Additive v, Num n) => v n
unitZ P3 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Direction V3 n
forall (v :: * -> *) n. (R2 v, Additive v, Num n) => Direction v n
yDir

-- | Look at the xz-plane with z as the up direction.
facingXZ :: (Epsilon n, Floating n) => AffineMap V3 V2 n
facingXZ :: AffineMap V3 V2 n
facingXZ = P3 n -> P3 n -> Direction V3 n -> AffineMap V3 V2 n
forall n.
(Epsilon n, Floating n) =>
P3 n -> P3 n -> Direction V3 n -> AffineMap V3 V2 n
lookingAt P3 n
forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY P3 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Direction V3 n
forall (v :: * -> *) n. (R3 v, Additive v, Num n) => Direction v n
zDir

-- | Look at the yz-plane with z as the up direction.
facingYZ :: (Epsilon n, Floating n) => AffineMap V3 V2 n
facingYZ :: AffineMap V3 V2 n
facingYZ = P3 n -> P3 n -> Direction V3 n -> AffineMap V3 V2 n
forall n.
(Epsilon n, Floating n) =>
P3 n -> P3 n -> Direction V3 n -> AffineMap V3 V2 n
lookingAt P3 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX P3 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Direction V3 n
forall (v :: * -> *) n. (R3 v, Additive v, Num n) => Direction v n
zDir

-- $axonometric
-- Axonometric projections are a type of orthographic projection where
-- the object is rotated along one or more of its axes relative to the
-- plane of projection.

-- $isometric
-- Isometric projections are when the scale along each axis of the
-- projection is the same and the angle between any axis is 120
-- degrees.

-- | Apply an isometric projection given the up direction
isometricApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b, Floating n, Epsilon n)
               => Direction V3 n -> a -> b
isometricApply :: Direction V3 n -> a -> b
isometricApply Direction V3 n
up = AffineMap (V a) (V b) (N b) -> a -> b
forall a b.
(AffineMappable a b, Additive (V a), Foldable (V a),
 Additive (V b), Num (N b)) =>
AffineMap (V a) (V b) (N b) -> a -> b
amap (Direction V3 n -> AffineMap V3 V2 n
forall n.
(Floating n, Epsilon n) =>
Direction V3 n -> AffineMap V3 V2 n
isometric Direction V3 n
up)

-- | Make an isometric affine map with the given up direction.
isometric :: (Floating n, Epsilon n) => Direction V3 n -> AffineMap V3 V2 n
isometric :: Direction V3 n -> AffineMap V3 V2 n
isometric Direction V3 n
up = M44 n -> AffineMap V3 V2 n
forall n. Num n => M44 n -> AffineMap V3 V2 n
m44AffineMap M44 n
m
  where
    m :: M44 n
m = V3 n -> V3 n -> V3 n -> M44 n
forall a. (Epsilon a, Floating a) => V3 a -> V3 a -> V3 a -> M44 a
lookAt (n -> n -> n -> V3 n
forall a. a -> a -> a -> V3 a
V3 n
1 n
1 n
1) V3 n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero (Direction V3 n -> V3 n
forall (v :: * -> *) n.
(Metric v, Floating n) =>
Direction v n -> v n
fromDirection Direction V3 n
up)

lookingAt :: (Epsilon n, Floating n)
          => P3 n -- ^ Eye
          -> P3 n -- ^ Center
          -> Direction V3 n -- ^ Up
          -> AffineMap V3 V2 n
lookingAt :: P3 n -> P3 n -> Direction V3 n -> AffineMap V3 V2 n
lookingAt (P V3 n
cam) (P V3 n
center) Direction V3 n
d = M44 n -> AffineMap V3 V2 n
forall n. Num n => M44 n -> AffineMap V3 V2 n
m44AffineMap M44 n
m
  where
    m :: M44 n
m = V3 n -> V3 n -> V3 n -> M44 n
forall a. (Epsilon a, Floating a) => V3 a -> V3 a -> V3 a -> M44 a
lookAt V3 n
cam V3 n
center (Direction V3 n
dDirection V3 n -> Getting (V3 n) (Direction V3 n) (V3 n) -> V3 n
forall s a. s -> Getting a s a -> a
^.Getting (V3 n) (Direction V3 n) (V3 n)
forall (v :: * -> *) n. Iso' (Direction v n) (v n)
_Dir)

-- | Apply the affine part of a homogeneous matrix.
m44AffineApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b)
               => M44 n -> a -> b
m44AffineApply :: M44 n -> a -> b
m44AffineApply = AffineMap V3 V2 n -> a -> b
forall a b.
(AffineMappable a b, Additive (V a), Foldable (V a),
 Additive (V b), Num (N b)) =>
AffineMap (V a) (V b) (N b) -> a -> b
amap (AffineMap V3 V2 n -> a -> b)
-> (M44 n -> AffineMap V3 V2 n) -> M44 n -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M44 n -> AffineMap V3 V2 n
forall n. Num n => M44 n -> AffineMap V3 V2 n
m44AffineMap

-- | Create an 'AffineMap' from a 4x4 homogeneous matrix, ignoring any
--   perspective transforms.
m44AffineMap :: Num n => M44 n -> AffineMap V3 V2 n
m44AffineMap :: M44 n -> AffineMap V3 V2 n
m44AffineMap M44 n
m = LinearMap V3 V2 n -> V2 n -> AffineMap V3 V2 n
forall (v :: * -> *) (u :: * -> *) n.
LinearMap v u n -> u n -> AffineMap v u n
AffineMap ((V3 n -> V2 n) -> LinearMap V3 V2 n
forall (v :: * -> *) (u :: * -> *) n.
(v n -> u n) -> LinearMap v u n
LinearMap V3 n -> V2 n
f) (V3 n -> V2 n
f V3 n
v)
  where
    f :: V3 n -> V2 n
f  = Getting (V2 n) (V3 n) (V2 n) -> V3 n -> V2 n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V2 n) (V3 n) (V2 n)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy (V3 n -> V2 n) -> (V3 n -> V3 n) -> V3 n -> V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (M33 n
m' M33 n -> V3 n -> V3 n
forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
!*)
    m' :: M33 n
m' = M44 n
m M44 n -> Getting (M33 n) (M44 n) (M33 n) -> M33 n
forall s a. s -> Getting a s a -> a
^. Getting (M33 n) (M44 n) (M33 n)
forall (u :: * -> *) (v :: * -> *) n.
(Representable u, R3 v, R3 u) =>
Lens' (u (v n)) (M33 n)
linearTransform
    v :: V3 n
v  = M44 n
m M44 n -> Getting (V3 n) (M44 n) (V3 n) -> V3 n
forall s a. s -> Getting a s a -> a
^. Getting (V3 n) (M44 n) (V3 n)
forall (t :: * -> *) (v :: * -> *) a.
(Representable t, R3 t, R4 v) =>
Lens' (t (v a)) (V3 a)
L.translation

-- | Apply a transformation matrix and translation.
m33AffineApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b)
               => M33 n -> V2 n -> a -> b
m33AffineApply :: M33 n -> V2 n -> a -> b
m33AffineApply M33 n
m = AffineMap V3 V2 n -> a -> b
forall a b.
(AffineMappable a b, Additive (V a), Foldable (V a),
 Additive (V b), Num (N b)) =>
AffineMap (V a) (V b) (N b) -> a -> b
amap (AffineMap V3 V2 n -> a -> b)
-> (V2 n -> AffineMap V3 V2 n) -> V2 n -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M33 n -> V2 n -> AffineMap V3 V2 n
forall n. Num n => M33 n -> V2 n -> AffineMap V3 V2 n
m33AffineMap M33 n
m

-- | Create an 'AffineMap' from a 3x3 transformation matrix and a
--   translation vector.
m33AffineMap :: Num n => M33 n -> V2 n -> AffineMap V3 V2 n
m33AffineMap :: M33 n -> V2 n -> AffineMap V3 V2 n
m33AffineMap M33 n
m = LinearMap V3 V2 n -> V2 n -> AffineMap V3 V2 n
forall (v :: * -> *) (u :: * -> *) n.
LinearMap v u n -> u n -> AffineMap v u n
AffineMap ((V3 n -> V2 n) -> LinearMap V3 V2 n
forall (v :: * -> *) (u :: * -> *) n.
(v n -> u n) -> LinearMap v u n
LinearMap V3 n -> V2 n
f)
  where
    f :: V3 n -> V2 n
f = Getting (V2 n) (V3 n) (V2 n) -> V3 n -> V2 n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V2 n) (V3 n) (V2 n)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy (V3 n -> V2 n) -> (V3 n -> V3 n) -> V3 n -> V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (M33 n
m M33 n -> V3 n -> V3 n
forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
!*)

-- | Extract the linear transform part of a homogeneous matrix.
linearTransform :: (Representable u, R3 v, R3 u) => Lens' (u (v n)) (M33 n)
linearTransform :: Lens' (u (v n)) (M33 n)
linearTransform = LensLike (Context (V3 n) (V3 n)) (v n) (v n) (V3 n) (V3 n)
-> Lens (u (v n)) (u (v n)) (u (V3 n)) (u (V3 n))
forall (f :: * -> *) a b s t.
Representable f =>
LensLike (Context a b) s t a b -> Lens (f s) (f t) (f a) (f b)
column LensLike (Context (V3 n) (V3 n)) (v n) (v n) (V3 n) (V3 n)
forall (t :: * -> *) a. R3 t => Lens' (t a) (V3 a)
_xyz ((u (V3 n) -> f (u (V3 n))) -> u (v n) -> f (u (v n)))
-> ((M33 n -> f (M33 n)) -> u (V3 n) -> f (u (V3 n)))
-> (M33 n -> f (M33 n))
-> u (v n)
-> f (u (v n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (M33 n -> f (M33 n)) -> u (V3 n) -> f (u (V3 n))
forall (t :: * -> *) a. R3 t => Lens' (t a) (V3 a)
_xyz

------------------------------------------------------------------------
-- Perspective transforms
------------------------------------------------------------------------

-- For the time being projective transforms use the deformable class.
-- Eventually we would like to replace this with a more specialised
-- method.

-- $perspective
-- Perspective projections are when closer objects appear bigger.

-- | Make a deformation from a 4x4 homogeneous matrix.
m44Deformation :: Fractional n => M44 n -> Deformation V3 V2 n
m44Deformation :: M44 n -> Deformation V3 V2 n
m44Deformation M44 n
m =
  (Point V3 n -> Point V2 n) -> Deformation V3 V2 n
forall (v :: * -> *) (u :: * -> *) n.
(Point v n -> Point u n) -> Deformation v u n
Deformation (V2 n -> Point V2 n
forall (f :: * -> *) a. f a -> Point f a
P (V2 n -> Point V2 n)
-> (Point V3 n -> V2 n) -> Point V3 n -> Point V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (V2 n) (V3 n) (V2 n) -> V3 n -> V2 n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V2 n) (V3 n) (V2 n)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy (V3 n -> V2 n) -> (Point V3 n -> V3 n) -> Point V3 n -> V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V4 n -> V3 n
forall a. Fractional a => V4 a -> V3 a
normalizePoint (V4 n -> V3 n) -> (Point V3 n -> V4 n) -> Point V3 n -> V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (M44 n
m M44 n -> V4 n -> V4 n
forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
!*) (V4 n -> V4 n) -> (Point V3 n -> V4 n) -> Point V3 n -> V4 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 n -> V4 n
forall a. Num a => V3 a -> V4 a
point (V3 n -> V4 n) -> (Point V3 n -> V3 n) -> Point V3 n -> V4 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (V3 n) (Point V3 n) (V3 n) -> Point V3 n -> V3 n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V3 n) (Point V3 n) (V3 n)
forall (f :: * -> *) a. Iso' (Point f a) (f a)
_Point)