{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -fno-warn-unused-imports       #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Core.Transform
-- Copyright   :  (c) 2011-2015 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- "Diagrams" defines the core library of primitives
-- forming the basis of an embedded domain-specific language for
-- describing and rendering diagrams.
--
-- The @Transform@ module defines generic transformations
-- parameterized by any vector space.
--
-----------------------------------------------------------------------------

module Diagrams.Core.Transform
       (
         -- * Transformations

         -- ** Invertible linear transformations
         (:-:)(..), (<->), linv, lapp

         -- ** General transformations
       , Transformation(..)
       , inv, transp, transl
       , dropTransl
       , apply
       , papply
       , fromLinear
       , fromOrthogonal
       , fromSymmetric
       , basis
       , dimension
       , onBasis
       , listRep
       , matrixRep
       , matrixHomRep
       , determinant
       , isReflection
       , avgScale
       , eye

         -- * The Transformable class

       , HasLinearMap
       , HasBasis
       , Transformable(..)

         -- * Translational invariance

       , TransInv(TransInv)

         -- * Vector space independent transformations
         -- | Most transformations are specific to a particular vector
         --   space, but a few can be defined generically over any
         --   vector space.

       , translation, translate
       , scaling, scale

       ) where

import           Control.Lens            (Rewrapped, Traversable, Wrapped (..),
                                          iso, (&), (.~))
import qualified Data.Map                as M
import           Data.Semigroup
import qualified Data.Set                as S

import           Data.Monoid.Action
import           Data.Monoid.Deletable

import           Linear.Affine
import           Linear.Vector

import           Data.Foldable           (Foldable, toList)
import           Data.Functor.Rep

import           Diagrams.Core.HasOrigin
import           Diagrams.Core.Measure
import           Diagrams.Core.Points    ()
import           Diagrams.Core.V

------------------------------------------------------------
--  Transformations  ---------------------------------------
------------------------------------------------------------

-------------------------------------------------------
--  Invertible linear transformations  ----------------
-------------------------------------------------------

-- | @(v1 :-: v2)@ is a linear map paired with its inverse.
data (:-:) u v = (u -> v) :-: (v -> u)
infixr 7 :-:

-- | Create an invertible linear map from two functions which are
--   assumed to be linear inverses.
(<->) :: (u -> v) -> (v -> u) -> (u :-: v)
u -> v
f <-> :: (u -> v) -> (v -> u) -> u :-: v
<-> v -> u
g = u -> v
f (u -> v) -> (v -> u) -> u :-: v
forall u v. (u -> v) -> (v -> u) -> u :-: v
:-: v -> u
g

instance Semigroup (a :-: a) where
  (a -> a
f :-: a -> a
f') <> :: (a :-: a) -> (a :-: a) -> a :-: a
<> (a -> a
g :-: a -> a
g') = a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g (a -> a) -> (a -> a) -> a :-: a
forall u v. (u -> v) -> (v -> u) -> u :-: v
:-: a -> a
g' (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f'

-- | Invertible linear maps from a vector space to itself form a
--   monoid under composition.
instance Monoid (v :-: v) where
  mempty :: v :-: v
mempty  = v -> v
forall a. a -> a
id (v -> v) -> (v -> v) -> v :-: v
forall u v. (u -> v) -> (v -> u) -> u :-: v
:-: v -> v
forall a. a -> a
id
  mappend :: (v :-: v) -> (v :-: v) -> v :-: v
mappend = (v :-: v) -> (v :-: v) -> v :-: v
forall a. Semigroup a => a -> a -> a
(<>)

-- | Invert a linear map.
linv :: (u :-: v) -> (v :-: u)
linv :: (u :-: v) -> v :-: u
linv (u -> v
f :-: v -> u
g) = v -> u
g (v -> u) -> (u -> v) -> v :-: u
forall u v. (u -> v) -> (v -> u) -> u :-: v
:-: u -> v
f

-- | Apply a linear map to a vector.
lapp :: (u :-: v) -> u -> v
lapp :: (u :-: v) -> u -> v
lapp (u -> v
f :-: v -> u
_) = u -> v
f

--------------------------------------------------
--  Affine transformations  ----------------------
--------------------------------------------------

-- | General (affine) transformations, represented by an invertible
--   linear map, its /transpose/, and a vector representing a
--   translation component.
--
--   By the /transpose/ of a linear map we mean simply the linear map
--   corresponding to the transpose of the map's matrix
--   representation.  For example, any scale is its own transpose,
--   since scales are represented by matrices with zeros everywhere
--   except the diagonal.  The transpose of a rotation is the same as
--   its inverse.
--
--   The reason we need to keep track of transposes is because it
--   turns out that when transforming a shape according to some linear
--   map L, the shape's /normal vectors/ transform according to L's
--   inverse transpose.  (For a more detailed explanation and proof,
--   see <https://wiki.haskell.org/Diagrams/Dev/Transformations>.)
--   This is exactly what we need when transforming bounding
--   functions, which are defined in terms of /perpendicular/
--   (i.e. normal) hyperplanes.
--
--   For more general, non-invertible transformations, see
--   @Diagrams.Deform@ (in @diagrams-lib@).

data Transformation v n = Transformation (v n :-: v n) (v n :-: v n) (v n)

type instance V (Transformation v n) = v
type instance N (Transformation v n) = n

-- | Identity matrix.
eye :: (HasBasis v, Num n) => v (v n)
eye :: v (v n)
eye = (Rep v -> v n) -> v (v n)
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate ((Rep v -> v n) -> v (v n)) -> (Rep v -> v n) -> v (v n)
forall a b. (a -> b) -> a -> b
$ \(E e) -> v n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero v n -> (v n -> v n) -> v n
forall a b. a -> (a -> b) -> b
& (n -> Identity n) -> v n -> Identity (v n)
forall x. Lens' (v x) x
e ((n -> Identity n) -> v n -> Identity (v n)) -> n -> v n -> v n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
1

-- | Invert a transformation.
inv :: (Functor v, Num n) => Transformation v n -> Transformation v n
inv :: Transformation v n -> Transformation v n
inv (Transformation v n :-: v n
t v n :-: v n
t' v n
v) = (v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation ((v n :-: v n) -> v n :-: v n
forall u v. (u :-: v) -> v :-: u
linv v n :-: v n
t) ((v n :-: v n) -> v n :-: v n
forall u v. (u :-: v) -> v :-: u
linv v n :-: v n
t')
                                             (v n -> v n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated ((v n :-: v n) -> v n -> v n
forall u v. (u :-: v) -> u -> v
lapp ((v n :-: v n) -> v n :-: v n
forall u v. (u :-: v) -> v :-: u
linv v n :-: v n
t) v n
v))

-- | Get the transpose of a transformation (ignoring the translation
--   component).
transp :: Transformation v n -> (v n :-: v n)
transp :: Transformation v n -> v n :-: v n
transp (Transformation v n :-: v n
_ v n :-: v n
t' v n
_) = v n :-: v n
t'

-- | Get the translational component of a transformation.
transl :: Transformation v n -> v n
transl :: Transformation v n -> v n
transl (Transformation v n :-: v n
_ v n :-: v n
_ v n
v) = v n
v

-- | Drop the translational component of a transformation, leaving only
--   the linear part.
dropTransl :: (Additive v, Num n) => Transformation v n -> Transformation v n
dropTransl :: Transformation v n -> Transformation v n
dropTransl (Transformation v n :-: v n
a v n :-: v n
a' v n
_) = (v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation v n :-: v n
a v n :-: v n
a' v n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero

-- | Transformations are closed under composition; @t1 <> t2@ is the
--   transformation which performs first @t2@, then @t1@.
instance (Additive v, Num n) => Semigroup (Transformation v n) where
  Transformation v n :-: v n
t1 v n :-: v n
t1' v n
v1 <> :: Transformation v n -> Transformation v n -> Transformation v n
<> Transformation v n :-: v n
t2 v n :-: v n
t2' v n
v2
    = (v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation (v n :-: v n
t1 (v n :-: v n) -> (v n :-: v n) -> v n :-: v n
forall a. Semigroup a => a -> a -> a
<> v n :-: v n
t2) (v n :-: v n
t2' (v n :-: v n) -> (v n :-: v n) -> v n :-: v n
forall a. Semigroup a => a -> a -> a
<> v n :-: v n
t1') (v n
v1 v n -> v n -> v n
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ (v n :-: v n) -> v n -> v n
forall u v. (u :-: v) -> u -> v
lapp v n :-: v n
t1 v n
v2)

instance (Additive v, Num n) => Monoid (Transformation v n) where
  mempty :: Transformation v n
mempty = (v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation v n :-: v n
forall a. Monoid a => a
mempty v n :-: v n
forall a. Monoid a => a
mempty v n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
  mappend :: Transformation v n -> Transformation v n -> Transformation v n
mappend = Transformation v n -> Transformation v n -> Transformation v n
forall a. Semigroup a => a -> a -> a
(<>)

-- | Transformations can act on transformable things.
instance (Transformable a, V a ~ v, N a ~ n) => Action (Transformation v n) a where
  act :: Transformation v n -> a -> a
act = Transformation v n -> a -> a
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform

-- | Apply a transformation to a vector.  Note that any translational
--   component of the transformation will not affect the vector, since
--   vectors are invariant under translation.
apply :: Transformation v n -> v n -> v n
apply :: Transformation v n -> v n -> v n
apply (Transformation (v n -> v n
t :-: v n -> v n
_) v n :-: v n
_ v n
_) = v n -> v n
t

-- | Apply a transformation to a point.
papply :: (Additive v, Num n) => Transformation v n -> Point v n -> Point v n
papply :: Transformation v n -> Point v n -> Point v n
papply (Transformation v n :-: v n
t v n :-: v n
_ v n
v) (P v n
p) = v n -> Point v n
forall (f :: * -> *) a. f a -> Point f a
P (v n -> Point v n) -> v n -> Point v n
forall a b. (a -> b) -> a -> b
$ (v n :-: v n) -> v n -> v n
forall u v. (u :-: v) -> u -> v
lapp v n :-: v n
t v n
p v n -> v n -> v n
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ v n
v

-- | Create a general affine transformation from an invertible linear
--   transformation and its transpose.  The translational component is
--   assumed to be zero.
fromLinear :: (Additive v, Num n) => (v n :-: v n) -> (v n :-: v n) -> Transformation v n
fromLinear :: (v n :-: v n) -> (v n :-: v n) -> Transformation v n
fromLinear v n :-: v n
l1 v n :-: v n
l2 = (v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation v n :-: v n
l1 v n :-: v n
l2 v n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero

-- | An orthogonal linear map is one whose inverse is also its transpose.
fromOrthogonal :: (Additive v, Num n) => (v n :-: v n) -> Transformation v n
fromOrthogonal :: (v n :-: v n) -> Transformation v n
fromOrthogonal v n :-: v n
t = (v n :-: v n) -> (v n :-: v n) -> Transformation v n
forall (v :: * -> *) n.
(Additive v, Num n) =>
(v n :-: v n) -> (v n :-: v n) -> Transformation v n
fromLinear v n :-: v n
t ((v n :-: v n) -> v n :-: v n
forall u v. (u :-: v) -> v :-: u
linv v n :-: v n
t)

-- | A symmetric linear map is one whose transpose is equal to its self.
fromSymmetric :: (Additive v, Num n) => (v n :-: v n) -> Transformation v n
fromSymmetric :: (v n :-: v n) -> Transformation v n
fromSymmetric v n :-: v n
t = (v n :-: v n) -> (v n :-: v n) -> Transformation v n
forall (v :: * -> *) n.
(Additive v, Num n) =>
(v n :-: v n) -> (v n :-: v n) -> Transformation v n
fromLinear v n :-: v n
t v n :-: v n
t

-- | Get the dimension of an object whose vector space is an instance of
--   @HasLinearMap@, e.g. transformations, paths, diagrams, etc.
dimension :: forall a. (Additive (V a), Traversable (V a)) => a -> Int
dimension :: a -> Int
dimension a
_ = [V a Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([V a Int]
forall (t :: * -> *) a. (Additive t, Traversable t, Num a) => [t a]
basis :: [V a Int])

-- | Get the matrix equivalent of the linear transform,
--   (as a list of columns) and the translation vector.  This
--   is mostly useful for implementing backends.
onBasis :: (Additive v, Traversable v, Num n) => Transformation v n -> ([v n], v n)
onBasis :: Transformation v n -> ([v n], v n)
onBasis (Transformation (v n -> v n
f :-: v n -> v n
_) v n :-: v n
_ v n
t) = ((v n -> v n) -> [v n] -> [v n]
forall a b. (a -> b) -> [a] -> [b]
map v n -> v n
f [v n]
forall (t :: * -> *) a. (Additive t, Traversable t, Num a) => [t a]
basis, v n
t)

-- Remove the nth element from a list
remove :: Int -> [a] -> [a]
remove :: Int -> [a] -> [a]
remove Int
n [a]
xs = [a]
ys [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
tail [a]
zs
  where
    ([a]
ys, [a]
zs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs

-- Minor matrix of cofactore C(i,j)
minor :: Int -> Int -> [[a]] -> [[a]]
minor :: Int -> Int -> [[a]] -> [[a]]
minor Int
i Int
j [[a]]
xs = Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
remove Int
j ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
remove Int
i) [[a]]
xs

-- The determinant of a square matrix represented as a list of lists
-- representing column vectors, that is [column].
det :: Num a => [[a]] -> a
det :: [[a]] -> a
det ([a]
a:[]) = [a] -> a
forall a. [a] -> a
head [a]
a
det [[a]]
m = [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(-a
1)a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^Int
i a -> a -> a
forall a. Num a => a -> a -> a
* ([a]
c1 [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
i) a -> a -> a
forall a. Num a => a -> a -> a
* [[a]] -> a
forall a. Num a => [[a]] -> a
det (Int -> Int -> [[a]] -> [[a]]
forall a. Int -> Int -> [[a]] -> [[a]]
minor Int
i Int
0 [[a]]
m) | Int
i <- [Int
0 .. (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]]
  where
    c1 :: [a]
c1 = [[a]] -> [a]
forall a. [a] -> a
head [[a]]
m
    n :: Int
n = [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
m

-- | Convert a vector v to a list of scalars.
listRep :: Foldable v => v n -> [n]
listRep :: v n -> [n]
listRep = v n -> [n]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Convert the linear part of a `Transformation` to a matrix
--   representation as a list of column vectors which are also lists.
matrixRep :: (Additive v, Traversable v, Num n) => Transformation v n -> [[n]]
matrixRep :: Transformation v n -> [[n]]
matrixRep (Transformation (v n -> v n
f :-: v n -> v n
_) v n :-: v n
_ v n
_) = (v n -> [n]) -> [v n] -> [[n]]
forall a b. (a -> b) -> [a] -> [b]
map (v n -> [n]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (v n -> [n]) -> (v n -> v n) -> v n -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v n -> v n
f) [v n]
forall (t :: * -> *) a. (Additive t, Traversable t, Num a) => [t a]
basis

-- | Convert a `Transformation v` to a homogeneous matrix representation.
--   The final list is the translation.
--   The representation leaves off the last row of the matrix as it is
--   always [0,0, ... 1] and this representation is the defacto standard
--   for backends.
matrixHomRep :: (Additive v, Traversable v, Num n) => Transformation v n -> [[n]]
matrixHomRep :: Transformation v n -> [[n]]
matrixHomRep Transformation v n
t = [[n]]
mr [[n]] -> [[n]] -> [[n]]
forall a. [a] -> [a] -> [a]
++ [v n -> [n]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList v n
tl]
  where
    mr :: [[n]]
mr = Transformation v n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixRep Transformation v n
t
    tl :: v n
tl = Transformation v n -> v n
forall (v :: * -> *) n. Transformation v n -> v n
transl Transformation v n
t

-- | The determinant of (the linear part of) a `Transformation`.
determinant :: (Additive v, Traversable v, Num n) => Transformation v n -> n
determinant :: Transformation v n -> n
determinant = [[n]] -> n
forall a. Num a => [[a]] -> a
det ([[n]] -> n)
-> (Transformation v n -> [[n]]) -> Transformation v n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation v n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixRep

-- | Determine whether a `Transformation` includes a reflection
--   component, that is, whether it reverses orientation.
isReflection :: (Additive v, Traversable v, Num n, Ord n) => Transformation v n -> Bool
isReflection :: Transformation v n -> Bool
isReflection = (n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<n
0) (n -> Bool)
-> (Transformation v n -> n) -> Transformation v n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation v n -> n
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> n
determinant

-- | Compute the \"average\" amount of scaling performed by a
--   transformation.  Satisfies the properties
--
--   @
--   avgScale (scaling k) == k
--   avgScale (t1 <> t2)  == avgScale t1 * avgScale t2
--   @
--
avgScale :: (Additive v, Traversable v, Floating n) => Transformation v n -> n
avgScale :: Transformation v n -> n
avgScale Transformation v n
t = (n -> n
forall a. Num a => a -> a
abs (n -> n) -> (Transformation v n -> n) -> Transformation v n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation v n -> n
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> n
determinant) Transformation v n
t n -> n -> n
forall a. Floating a => a -> a -> a
** (n -> n
forall a. Fractional a => a -> a
recip (n -> n) -> (Transformation v n -> n) -> Transformation v n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> n)
-> (Transformation v n -> Int) -> Transformation v n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation v n -> Int
forall a. (Additive (V a), Traversable (V a)) => a -> Int
dimension) Transformation v n
t

{-

avgScale is computed as the nth root of the positive determinant.
This works because the determinant is the factor by which a transformation
scales area/volume. See http://en.wikipedia.org/wiki/Determinant.

Proofs for the specified properties:

1. |det (scaling k)|^(1/n) = (k^n)^(1/n) = k
2. |det t1|^(1/n) * |det t2|^(1/n)
   = (|det t1| * |det t2|)^(1/n)
   = |det t1 * det t2|^(1/n)
   = |det (t1 <> t2)|^(1/n)

-}

------------------------------------------------------------
--  The Transformable class  -------------------------------
------------------------------------------------------------

-- | 'HasLinearMap' is a constraint synonym, just to
--   help shorten some of the ridiculously long constraint sets.
type HasLinearMap v = (HasBasis v, Traversable v)

-- | An 'Additive' vector space whose representation is made up of basis elements.
type HasBasis v = (Additive v, Representable v, Rep v ~ E v)

-- | Type class for things @t@ which can be transformed.
class Transformable t where

  -- | Apply a transformation to an object.
  transform :: Transformation (V t) (N t) -> t -> t

instance (Additive v, Num n) => Transformable (Transformation v n) where
  transform :: Transformation (V (Transformation v n)) (N (Transformation v n))
-> Transformation v n -> Transformation v n
transform Transformation (V (Transformation v n)) (N (Transformation v n))
t1 Transformation v n
t2 = Transformation v n
Transformation (V (Transformation v n)) (N (Transformation v n))
t1 Transformation v n -> Transformation v n -> Transformation v n
forall a. Semigroup a => a -> a -> a
<> Transformation v n
t2

instance (Additive v, Num n) => HasOrigin (Transformation v n) where
  moveOriginTo :: Point (V (Transformation v n)) (N (Transformation v n))
-> Transformation v n -> Transformation v n
moveOriginTo Point (V (Transformation v n)) (N (Transformation v n))
p = Vn (Transformation v n) -> Transformation v n -> Transformation v n
forall t. Transformable t => Vn t -> t -> t
translate (Point v n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Point v n -> Point v n -> Diff (Point v) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point v n
Point (V (Transformation v n)) (N (Transformation v n))
p)

instance (Transformable t, Transformable s, V t ~ V s, N t ~ N s)
      => Transformable (t, s) where
  transform :: Transformation (V (t, s)) (N (t, s)) -> (t, s) -> (t, s)
transform Transformation (V (t, s)) (N (t, s))
t (t
x,s
y) =  ( Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V t) (N t)
Transformation (V (t, s)) (N (t, s))
t t
x
                       , Transformation (V s) (N s) -> s -> s
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V s) (N s)
Transformation (V (t, s)) (N (t, s))
t s
y
                       )

instance (Transformable t, Transformable s, Transformable u, V s ~ V t, N s ~ N t, V s ~ V u, N s ~ N u)
      => Transformable (t,s,u) where
  transform :: Transformation (V (t, s, u)) (N (t, s, u))
-> (t, s, u) -> (t, s, u)
transform Transformation (V (t, s, u)) (N (t, s, u))
t (t
x,s
y,u
z) = ( Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V t) (N t)
Transformation (V (t, s, u)) (N (t, s, u))
t t
x
                        , Transformation (V s) (N s) -> s -> s
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V s) (N s)
Transformation (V (t, s, u)) (N (t, s, u))
t s
y
                        , Transformation (V u) (N u) -> u -> u
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V u) (N u)
Transformation (V (t, s, u)) (N (t, s, u))
t u
z
                        )

-- Transform functions by conjugation. That is, reverse-transform argument and
-- forward-transform result. Intuition: If someone shrinks you, you see your
-- environment enlarged. If you rotate right, you see your environment
-- rotating left. Etc. This technique was used extensively in Pan for modular
-- construction of image filters. Works well for curried functions, since all
-- arguments get inversely transformed.

instance ( V t ~ v, N t ~ n, V t ~ V s, N t ~ N s, Functor v, Num n
         , Transformable t, Transformable s)
         => Transformable (s -> t) where
  transform :: Transformation (V (s -> t)) (N (s -> t)) -> (s -> t) -> s -> t
transform Transformation (V (s -> t)) (N (s -> t))
tr s -> t
f = Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V t) (N t)
Transformation (V (s -> t)) (N (s -> t))
tr (t -> t) -> (s -> t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> t
f (s -> t) -> (s -> s) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation (V s) (N s) -> s -> s
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (Transformation v n -> Transformation v n
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv Transformation v n
Transformation (V (s -> t)) (N (s -> t))
tr)

instance Transformable t => Transformable [t] where
  transform :: Transformation (V [t]) (N [t]) -> [t] -> [t]
transform = (t -> t) -> [t] -> [t]
forall a b. (a -> b) -> [a] -> [b]
map ((t -> t) -> [t] -> [t])
-> (Transformation (V t) (N t) -> t -> t)
-> Transformation (V t) (N t)
-> [t]
-> [t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform

instance (Transformable t, Ord t) => Transformable (S.Set t) where
  transform :: Transformation (V (Set t)) (N (Set t)) -> Set t -> Set t
transform = (t -> t) -> Set t -> Set t
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ((t -> t) -> Set t -> Set t)
-> (Transformation (V t) (N t) -> t -> t)
-> Transformation (V t) (N t)
-> Set t
-> Set t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform

instance Transformable t => Transformable (M.Map k t) where
  transform :: Transformation (V (Map k t)) (N (Map k t)) -> Map k t -> Map k t
transform = (t -> t) -> Map k t -> Map k t
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((t -> t) -> Map k t -> Map k t)
-> (Transformation (V t) (N t) -> t -> t)
-> Transformation (V t) (N t)
-> Map k t
-> Map k t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform

instance (Additive v, Num n) => Transformable (Point v n) where
  transform :: Transformation (V (Point v n)) (N (Point v n))
-> Point v n -> Point v n
transform = Transformation (V (Point v n)) (N (Point v n))
-> Point v n -> Point v n
forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Point v n -> Point v n
papply

instance Transformable m => Transformable (Deletable m) where
  transform :: Transformation (V (Deletable m)) (N (Deletable m))
-> Deletable m -> Deletable m
transform = (m -> m) -> Deletable m -> Deletable m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m -> m) -> Deletable m -> Deletable m)
-> (Transformation (V m) (N m) -> m -> m)
-> Transformation (V m) (N m)
-> Deletable m
-> Deletable m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation (V m) (N m) -> m -> m
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform

------------------------------------------------------------
--  Translational invariance  ------------------------------
------------------------------------------------------------

-- | @TransInv@ is a wrapper which makes a transformable type
--   translationally invariant; the translational component of
--   transformations will no longer affect things wrapped in
--   @TransInv@.
newtype TransInv t = TransInv t
  deriving (TransInv t -> TransInv t -> Bool
(TransInv t -> TransInv t -> Bool)
-> (TransInv t -> TransInv t -> Bool) -> Eq (TransInv t)
forall t. Eq t => TransInv t -> TransInv t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransInv t -> TransInv t -> Bool
$c/= :: forall t. Eq t => TransInv t -> TransInv t -> Bool
== :: TransInv t -> TransInv t -> Bool
$c== :: forall t. Eq t => TransInv t -> TransInv t -> Bool
Eq, Eq (TransInv t)
Eq (TransInv t)
-> (TransInv t -> TransInv t -> Ordering)
-> (TransInv t -> TransInv t -> Bool)
-> (TransInv t -> TransInv t -> Bool)
-> (TransInv t -> TransInv t -> Bool)
-> (TransInv t -> TransInv t -> Bool)
-> (TransInv t -> TransInv t -> TransInv t)
-> (TransInv t -> TransInv t -> TransInv t)
-> Ord (TransInv t)
TransInv t -> TransInv t -> Bool
TransInv t -> TransInv t -> Ordering
TransInv t -> TransInv t -> TransInv t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall t. Ord t => Eq (TransInv t)
forall t. Ord t => TransInv t -> TransInv t -> Bool
forall t. Ord t => TransInv t -> TransInv t -> Ordering
forall t. Ord t => TransInv t -> TransInv t -> TransInv t
min :: TransInv t -> TransInv t -> TransInv t
$cmin :: forall t. Ord t => TransInv t -> TransInv t -> TransInv t
max :: TransInv t -> TransInv t -> TransInv t
$cmax :: forall t. Ord t => TransInv t -> TransInv t -> TransInv t
>= :: TransInv t -> TransInv t -> Bool
$c>= :: forall t. Ord t => TransInv t -> TransInv t -> Bool
> :: TransInv t -> TransInv t -> Bool
$c> :: forall t. Ord t => TransInv t -> TransInv t -> Bool
<= :: TransInv t -> TransInv t -> Bool
$c<= :: forall t. Ord t => TransInv t -> TransInv t -> Bool
< :: TransInv t -> TransInv t -> Bool
$c< :: forall t. Ord t => TransInv t -> TransInv t -> Bool
compare :: TransInv t -> TransInv t -> Ordering
$ccompare :: forall t. Ord t => TransInv t -> TransInv t -> Ordering
$cp1Ord :: forall t. Ord t => Eq (TransInv t)
Ord, Int -> TransInv t -> ShowS
[TransInv t] -> ShowS
TransInv t -> String
(Int -> TransInv t -> ShowS)
-> (TransInv t -> String)
-> ([TransInv t] -> ShowS)
-> Show (TransInv t)
forall t. Show t => Int -> TransInv t -> ShowS
forall t. Show t => [TransInv t] -> ShowS
forall t. Show t => TransInv t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransInv t] -> ShowS
$cshowList :: forall t. Show t => [TransInv t] -> ShowS
show :: TransInv t -> String
$cshow :: forall t. Show t => TransInv t -> String
showsPrec :: Int -> TransInv t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> TransInv t -> ShowS
Show, b -> TransInv t -> TransInv t
NonEmpty (TransInv t) -> TransInv t
TransInv t -> TransInv t -> TransInv t
(TransInv t -> TransInv t -> TransInv t)
-> (NonEmpty (TransInv t) -> TransInv t)
-> (forall b. Integral b => b -> TransInv t -> TransInv t)
-> Semigroup (TransInv t)
forall b. Integral b => b -> TransInv t -> TransInv t
forall t. Semigroup t => NonEmpty (TransInv t) -> TransInv t
forall t. Semigroup t => TransInv t -> TransInv t -> TransInv t
forall t b.
(Semigroup t, Integral b) =>
b -> TransInv t -> TransInv t
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> TransInv t -> TransInv t
$cstimes :: forall t b.
(Semigroup t, Integral b) =>
b -> TransInv t -> TransInv t
sconcat :: NonEmpty (TransInv t) -> TransInv t
$csconcat :: forall t. Semigroup t => NonEmpty (TransInv t) -> TransInv t
<> :: TransInv t -> TransInv t -> TransInv t
$c<> :: forall t. Semigroup t => TransInv t -> TransInv t -> TransInv t
Semigroup, Semigroup (TransInv t)
TransInv t
Semigroup (TransInv t)
-> TransInv t
-> (TransInv t -> TransInv t -> TransInv t)
-> ([TransInv t] -> TransInv t)
-> Monoid (TransInv t)
[TransInv t] -> TransInv t
TransInv t -> TransInv t -> TransInv t
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall t. Monoid t => Semigroup (TransInv t)
forall t. Monoid t => TransInv t
forall t. Monoid t => [TransInv t] -> TransInv t
forall t. Monoid t => TransInv t -> TransInv t -> TransInv t
mconcat :: [TransInv t] -> TransInv t
$cmconcat :: forall t. Monoid t => [TransInv t] -> TransInv t
mappend :: TransInv t -> TransInv t -> TransInv t
$cmappend :: forall t. Monoid t => TransInv t -> TransInv t -> TransInv t
mempty :: TransInv t
$cmempty :: forall t. Monoid t => TransInv t
$cp1Monoid :: forall t. Monoid t => Semigroup (TransInv t)
Monoid)

instance Wrapped (TransInv t) where
  type Unwrapped (TransInv t) = t
  _Wrapped' :: p (Unwrapped (TransInv t)) (f (Unwrapped (TransInv t)))
-> p (TransInv t) (f (TransInv t))
_Wrapped' = (TransInv t -> t)
-> (t -> TransInv t) -> Iso (TransInv t) (TransInv t) t t
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(TransInv t
t) -> t
t) t -> TransInv t
forall t. t -> TransInv t
TransInv

instance Rewrapped (TransInv t) (TransInv t')

type instance V (TransInv t) = V t
type instance N (TransInv t) = N t

instance HasOrigin (TransInv t) where
  moveOriginTo :: Point (V (TransInv t)) (N (TransInv t)) -> TransInv t -> TransInv t
moveOriginTo = (TransInv t -> TransInv t)
-> Point (V t) (N t) -> TransInv t -> TransInv t
forall a b. a -> b -> a
const TransInv t -> TransInv t
forall a. a -> a
id

instance (Num (N t), Additive (V t), Transformable t) => Transformable (TransInv t) where
  transform :: Transformation (V (TransInv t)) (N (TransInv t))
-> TransInv t -> TransInv t
transform (Transformation V (TransInv t) (N (TransInv t)) :-: V (TransInv t) (N (TransInv t))
a V (TransInv t) (N (TransInv t)) :-: V (TransInv t) (N (TransInv t))
a' V (TransInv t) (N (TransInv t))
_) (TransInv t
t)
    = t -> TransInv t
forall t. t -> TransInv t
TransInv (Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform ((V t (N t) :-: V t (N t))
-> (V t (N t) :-: V t (N t))
-> V t (N t)
-> Transformation (V t) (N t)
forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation V t (N t) :-: V t (N t)
V (TransInv t) (N (TransInv t)) :-: V (TransInv t) (N (TransInv t))
a V t (N t) :-: V t (N t)
V (TransInv t) (N (TransInv t)) :-: V (TransInv t) (N (TransInv t))
a' V t (N t)
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero) t
t)

instance (InSpace v n t, Transformable t, HasLinearMap v, Floating n)
    => Transformable (Measured n t) where
  transform :: Transformation (V (Measured n t)) (N (Measured n t))
-> Measured n t -> Measured n t
transform Transformation (V (Measured n t)) (N (Measured n t))
t = n -> Measured n t -> Measured n t
forall n a. Num n => n -> Measured n a -> Measured n a
scaleLocal n
n (Measured n t -> Measured n t)
-> (Measured n t -> Measured n t) -> Measured n t -> Measured n t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> t) -> Measured n t -> Measured n t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation v n
Transformation (V t) (N t)
t')
    where
      t' :: Transformation v n
t' = Transformation v n
Transformation (V (Measured n t)) (N (Measured n t))
t Transformation v n -> Transformation v n -> Transformation v n
forall a. Semigroup a => a -> a -> a
<> n -> Transformation v n
forall (v :: * -> *) n.
(Additive v, Fractional n) =>
n -> Transformation v n
scaling (n
1 n -> n -> n
forall a. Fractional a => a -> a -> a
/ Transformation v n -> n
forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale Transformation v n
Transformation (V (Measured n t)) (N (Measured n t))
t)
      n :: n
n = Transformation v n -> n
forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale Transformation v n
Transformation (V (Measured n t)) (N (Measured n t))
t

------------------------------------------------------------
--  Generic transformations  -------------------------------
------------------------------------------------------------

-- | Create a translation.
translation :: v n -> Transformation v n
translation :: v n -> Transformation v n
translation = (v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation v n :-: v n
forall a. Monoid a => a
mempty v n :-: v n
forall a. Monoid a => a
mempty

-- | Translate by a vector.
translate :: (Transformable t) => Vn t -> t -> t
translate :: Vn t -> t -> t
translate = Transformation (V t) (N t) -> t -> t
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (Transformation (V t) (N t) -> t -> t)
-> (Vn t -> Transformation (V t) (N t)) -> Vn t -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vn t -> Transformation (V t) (N t)
forall (v :: * -> *) n. v n -> Transformation v n
translation

-- | Create a uniform scaling transformation.
scaling :: (Additive v, Fractional n) => n -> Transformation v n
scaling :: n -> Transformation v n
scaling n
s = (v n :-: v n) -> Transformation v n
forall (v :: * -> *) n.
(Additive v, Num n) =>
(v n :-: v n) -> Transformation v n
fromSymmetric v n :-: v n
lin
  where lin :: v n :-: v n
lin = (n
s n -> v n -> v n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^) (v n -> v n) -> (v n -> v n) -> v n :-: v n
forall u v. (u -> v) -> (v -> u) -> u :-: v
<-> (v n -> n -> v n
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ n
s)

-- | Scale uniformly in every dimension by the given scalar.
scale :: (InSpace v n a, Eq n, Fractional n, Transformable a)
      => n -> a -> a
scale :: n -> a -> a
scale n
0 = String -> a -> a
forall a. HasCallStack => String -> a
error String
"scale by zero!  Halp!"  -- XXX what should be done here?
scale n
s = Transformation (V a) (N a) -> a -> a
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (Transformation (V a) (N a) -> a -> a)
-> Transformation (V a) (N a) -> a -> a
forall a b. (a -> b) -> a -> b
$ n -> Transformation v n
forall (v :: * -> *) n.
(Additive v, Fractional n) =>
n -> Transformation v n
scaling n
s