{-# 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 :: forall n. (Epsilon n, Floating n) => 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 :: forall n. (Epsilon n, Floating n) => 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 :: forall n. (Epsilon n, Floating n) => 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 :: forall n a b.
(InSpace V3 n a, InSpace V2 n b, AffineMappable a b, Floating n,
 Epsilon n) =>
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 :: forall n.
(Floating n, Epsilon n) =>
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 a. Num a => V3 a
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 :: forall n.
(Epsilon n, Floating n) =>
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 (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (v n) (f (v n)) -> p (Direction v n) (f (Direction 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 :: forall n a b.
(InSpace V3 n a, InSpace V2 n b, AffineMappable a b) =>
M44 n -> a -> b
m44AffineApply = AffineMap (V a) (V b) (N b) -> a -> b
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 :: forall n. Num n => 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 a. Lens' (V3 a) (V2 a)
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)
Lens' (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)
Lens' (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 :: forall n a b.
(InSpace V3 n a, InSpace V2 n b, AffineMappable a b) =>
M33 n -> V2 n -> a -> b
m33AffineApply M33 n
m = AffineMap (V a) (V b) (N b) -> a -> b
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 :: forall n. Num n => 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 a. Lens' (V3 a) (V2 a)
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 :: forall (u :: * -> *) (v :: * -> *) n.
(Representable u, R3 v, R3 u) =>
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 a. Lens' (v a) (V3 a)
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 a. Lens' (u a) (V3 a)
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 :: forall n. Fractional n => 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 a. Lens' (V3 a) (V2 a)
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 (f1 :: * -> *) a (g :: * -> *) b (p :: * -> * -> *)
       (f2 :: * -> *).
(Profunctor p, Functor f2) =>
p (f1 a) (f2 (g b)) -> p (Point f1 a) (f2 (Point g b))
_Point)