{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE ImpredicativeTypes    #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.LinearMap
-- Copyright   :  (c) 2014-2015 diagrams team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Linear maps. Unlike 'Transformation's these are not restricted to the
-- same space. In practice these are used for projections in
-- "Diagrams.ThreeD.Projection". Unless you want to work with
-- projections you're probably better off using 'Diagrams.Transform'.
--
-- Currently only path-like things can be projected. In the future we
-- hope to support projecting diagrams.
--
-----------------------------------------------------------------------------

module Diagrams.LinearMap
  ( -- * Linear maps
    LinearMap (..)
  , LinearMappable (..)
    -- ** Applying linear maps
  , linmap

    -- * Affine maps
  , AffineMap (..)
  , AffineMappable (..)

    -- ** Constructing affine maps
  , mkAffineMap
  , toAffineMap
  ) where

import           Control.Lens
import           Data.FingerTree         as FT
import qualified Data.Foldable           as F

import           Diagrams.Core
import           Diagrams.Core.Transform
import           Diagrams.Located
import           Diagrams.Path
import           Diagrams.Segment
import           Diagrams.Trail          hiding (offset)

import           Linear.Affine
import           Linear.Metric
import           Linear.Vector


-- | Type for holding linear maps. Note that these are not affine transforms so
--   attemping apply a translation with 'LinearMap' will likely produce incorrect
--   results.
newtype LinearMap v u n = LinearMap { forall (v :: * -> *) (u :: * -> *) n. LinearMap v u n -> v n -> u n
lapply :: v n -> u n }

toLinearMap :: Transformation v n -> LinearMap v v n
toLinearMap :: forall (v :: * -> *) n. Transformation v n -> LinearMap v v n
toLinearMap (Transformation (v n -> v n
m :-: v n -> v n
_) v n :-: v n
_ v n
_) = forall (v :: * -> *) (u :: * -> *) n.
(v n -> u n) -> LinearMap v u n
LinearMap v n -> v n
m

-- | Class of things that have vectors that can be mapped over.
class LinearMappable a b where
  -- | Apply a linear map to an object. If the map is not linear,
  --   behaviour will likely be wrong.
  vmap :: (Vn a -> Vn b) -> a -> b
  -- this uses a function instead of LinearMap so we can also use this
  -- class to change number types

-- Note: instances need to be of the form
--
-- r ~ A u m => LinearMappable (A v n) r
--
-- so ghc knows there's only one possible result from calling vmap.

-- | Apply a linear map.
linmap :: (InSpace v n a, LinearMappable a b, N b ~ n)
     => LinearMap v (V b) n -> a -> b
linmap :: forall (v :: * -> *) n a b.
(InSpace v n a, LinearMappable a b, N b ~ n) =>
LinearMap v (V b) n -> a -> b
linmap = forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) (u :: * -> *) n. LinearMap v u n -> v n -> u n
lapply

instance r ~ Offset c u m => LinearMappable (Offset c v n) r where
  vmap :: (Vn (Offset c v n) -> Vn r) -> Offset c v n -> r
vmap Vn (Offset c v n) -> Vn r
f (OffsetClosed v n
v) = forall (v :: * -> *) n. v n -> Offset Closed v n
OffsetClosed (Vn (Offset c v n) -> Vn r
f v n
v)
  vmap Vn (Offset c v n) -> Vn r
_ Offset c v n
OffsetOpen       = forall (v :: * -> *) n. Offset Open v n
OffsetOpen
  {-# INLINE vmap #-}

instance r ~ Segment c u m => LinearMappable (Segment c v n) r where
  vmap :: (Vn (Segment c v n) -> Vn r) -> Segment c v n -> r
vmap Vn (Segment c v n) -> Vn r
f (Linear Offset c v n
offset)      = forall c (v :: * -> *) n. Offset c v n -> Segment c v n
Linear (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Segment c v n) -> Vn r
f Offset c v n
offset)
  vmap Vn (Segment c v n) -> Vn r
f (Cubic v n
v1 v n
v2 Offset c v n
offset) = forall c (v :: * -> *) n.
v n -> v n -> Offset c v n -> Segment c v n
Cubic (Vn (Segment c v n) -> Vn r
f v n
v1) (Vn (Segment c v n) -> Vn r
f v n
v2) (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Segment c v n) -> Vn r
f Offset c v n
offset)
  {-# INLINE vmap #-}

instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ SegTree u m)
    => LinearMappable (SegTree v n) r where
  vmap :: (Vn (SegTree v n) -> Vn r) -> SegTree v n -> r
vmap Vn (SegTree v n) -> Vn r
f = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped (forall v1 a1 v2 a2.
(Measured v1 a1, Measured v2 a2) =>
(a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
fmap' (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (SegTree v n) -> Vn r
f))
  {-# INLINE vmap #-}

instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail' l u m)
    => LinearMappable (Trail' l v n) r where
  vmap :: (Vn (Trail' l v n) -> Vn r) -> Trail' l v n -> r
vmap Vn (Trail' l v n) -> Vn r
f (Line SegTree v n
st)        = forall (v :: * -> *) n. SegTree v n -> Trail' Line v n
Line (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Trail' l v n) -> Vn r
f SegTree v n
st)
  vmap Vn (Trail' l v n) -> Vn r
f (Loop SegTree v n
st Segment Open v n
offset) = forall (v :: * -> *) n.
SegTree v n -> Segment Open v n -> Trail' Loop v n
Loop (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Trail' l v n) -> Vn r
f SegTree v n
st) (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Trail' l v n) -> Vn r
f Segment Open v n
offset)
  {-# INLINE vmap #-}

instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail u m)
    => LinearMappable (Trail v n) r where
  vmap :: (Vn (Trail v n) -> Vn r) -> Trail v n -> r
vmap Vn (Trail v n) -> Vn r
f (Trail (Line SegTree v n
st))        = forall l (v :: * -> *) n. Trail' l v n -> Trail v n
Trail forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) n. SegTree v n -> Trail' Line v n
Line (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Trail v n) -> Vn r
f SegTree v n
st)
  vmap Vn (Trail v n) -> Vn r
f (Trail (Loop SegTree v n
st Segment Open v n
offset)) = forall l (v :: * -> *) n. Trail' l v n -> Trail v n
Trail forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) n.
SegTree v n -> Segment Open v n -> Trail' Loop v n
Loop (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Trail v n) -> Vn r
f SegTree v n
st) (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Trail v n) -> Vn r
f Segment Open v n
offset)
  {-# INLINE vmap #-}

instance LinearMappable (Point v n) (Point u m) where
  vmap :: (Vn (Point v n) -> Vn (Point u m)) -> Point v n -> Point u m
vmap Vn (Point v n) -> Vn (Point u m)
f (P v n
v) = forall (f :: * -> *) a. f a -> Point f a
P (Vn (Point v n) -> Vn (Point u m)
f v n
v)
  {-# INLINE vmap #-}

instance r ~ FixedSegment u m => LinearMappable (FixedSegment v n) r where
  vmap :: (Vn (FixedSegment v n) -> Vn r) -> FixedSegment v n -> r
vmap Vn (FixedSegment v n) -> Vn r
f (FLinear Point v n
p0 Point v n
p1)      = forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
FLinear (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (FixedSegment v n) -> Vn r
f Point v n
p0) (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (FixedSegment v n) -> Vn r
f Point v n
p1)
  vmap Vn (FixedSegment v n) -> Vn r
f (FCubic Point v n
p0 Point v n
p1 Point v n
p2 Point v n
p3) = forall (v :: * -> *) n.
Point v n
-> Point v n -> Point v n -> Point v n -> FixedSegment v n
FCubic (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (FixedSegment v n) -> Vn r
f Point v n
p0) (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (FixedSegment v n) -> Vn r
f Point v n
p1)
                                       (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (FixedSegment v n) -> Vn r
f Point v n
p2) (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (FixedSegment v n) -> Vn r
f Point v n
p3)
  {-# INLINE vmap #-}

instance (LinearMappable a b, r ~ Located b) => LinearMappable (Located a) r where
  vmap :: (Vn (Located a) -> Vn r) -> Located a -> r
vmap Vn (Located a) -> Vn r
f (Loc Point (V a) (N a)
p a
a) = forall a. Point (V a) (N a) -> a -> Located a
Loc (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Located a) -> Vn r
f Point (V a) (N a)
p) (forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Located a) -> Vn r
f a
a)
  {-# INLINE vmap #-}

instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Path u m)
    => LinearMappable (Path v n) r where
  vmap :: (Vn (Path v n) -> Vn r) -> Path v n -> r
vmap Vn (Path v n) -> Vn r
f = forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a b. LinearMappable a b => (Vn a -> Vn b) -> a -> b
vmap Vn (Path v n) -> Vn r
f
  {-# INLINE vmap #-}

-- | Affine linear maps. Unlike 'Transformation' these do not have to be
--   invertible so we can map between spaces.
data AffineMap v u n = AffineMap (LinearMap v u n) (u n)

-- | Make an affine map from a linear function and a translation.
mkAffineMap :: (v n -> u n) -> u n -> AffineMap v u n
mkAffineMap :: forall (v :: * -> *) n (u :: * -> *).
(v n -> u n) -> u n -> AffineMap v u n
mkAffineMap v n -> u n
f = forall (v :: * -> *) (u :: * -> *) n.
LinearMap v u n -> u n -> AffineMap v u n
AffineMap (forall (v :: * -> *) (u :: * -> *) n.
(v n -> u n) -> LinearMap v u n
LinearMap v n -> u n
f)

toAffineMap :: Transformation v n -> AffineMap v v n
toAffineMap :: forall (v :: * -> *) n. Transformation v n -> AffineMap v v n
toAffineMap Transformation v n
t = forall (v :: * -> *) (u :: * -> *) n.
LinearMap v u n -> u n -> AffineMap v u n
AffineMap (forall (v :: * -> *) n. Transformation v n -> LinearMap v v n
toLinearMap Transformation v n
t) (forall (v :: * -> *) n. Transformation v n -> v n
transl Transformation v n
t)

class (LinearMappable a b, N a ~ N b) => AffineMappable a b where
  -- | Affine map over an object. Has a default implimentation of only
  --   applying the linear map
  amap :: (Additive (V a), F.Foldable (V a), Additive (V b), Num (N b))
       => AffineMap (V a) (V b) (N b) -> a -> b
  amap (AffineMap LinearMap (V a) (V b) (N b)
f V b (N b)
_) = forall (v :: * -> *) n a b.
(InSpace v n a, LinearMappable a b, N b ~ n) =>
LinearMap v (V b) n -> a -> b
linmap LinearMap (V a) (V b) (N b)
f
  {-# INLINE amap #-}

instance r ~ Offset c u n => AffineMappable (Offset c v n) r
instance r ~ Segment c u n => AffineMappable (Segment c v n) r
instance (Metric v, Metric u, OrderedField n, r ~ SegTree u n) => AffineMappable (SegTree v n) r
instance (Metric v, Metric u, OrderedField n, r ~ Trail' l u n) => AffineMappable (Trail' l v n) r
instance (Metric v, Metric u, OrderedField n, r ~ Trail u n) => AffineMappable (Trail v n) r

instance (Additive v, Num n, r ~ Point u n) => AffineMappable (Point v n) r where
  amap :: (Additive (V (Point v n)), Foldable (V (Point v n)),
 Additive (V r), Num (N r)) =>
AffineMap (V (Point v n)) (V r) (N r) -> Point v n -> r
amap (AffineMap LinearMap (V (Point v n)) (V r) (N r)
f V r (N r)
v) Point v n
p = forall (v :: * -> *) n a b.
(InSpace v n a, LinearMappable a b, N b ~ n) =>
LinearMap v (V b) n -> a -> b
linmap LinearMap (V (Point v n)) (V r) (N r)
f Point v n
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V r (N r)
v
  {-# INLINE amap #-}

instance r ~ FixedSegment u n => AffineMappable (FixedSegment v n) r where
  amap :: (Additive (V (FixedSegment v n)), Foldable (V (FixedSegment v n)),
 Additive (V r), Num (N r)) =>
AffineMap (V (FixedSegment v n)) (V r) (N r)
-> FixedSegment v n -> r
amap AffineMap (V (FixedSegment v n)) (V r) (N r)
m (FLinear Point v n
p0 Point v n
p1)      = forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
FLinear (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 (V (FixedSegment v n)) (V r) (N r)
m Point v n
p0) (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 (V (FixedSegment v n)) (V r) (N r)
m Point v n
p1)
  amap AffineMap (V (FixedSegment v n)) (V r) (N r)
m (FCubic Point v n
p0 Point v n
p1 Point v n
p2 Point v n
p3) = forall (v :: * -> *) n.
Point v n
-> Point v n -> Point v n -> Point v n -> FixedSegment v n
FCubic (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 (V (FixedSegment v n)) (V r) (N r)
m Point v n
p0) (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 (V (FixedSegment v n)) (V r) (N r)
m Point v n
p1) (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 (V (FixedSegment v n)) (V r) (N r)
m Point v n
p2) (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 (V (FixedSegment v n)) (V r) (N r)
m Point v n
p3)
  {-# INLINE amap #-}

instance (LinearMappable a b, N a ~ N b, r ~ Located b) => AffineMappable (Located a) r where
  amap :: (Additive (V (Located a)), Foldable (V (Located a)),
 Additive (V r), Num (N r)) =>
AffineMap (V (Located a)) (V r) (N r) -> Located a -> r
amap m :: AffineMap (V (Located a)) (V r) (N r)
m@(AffineMap LinearMap (V (Located a)) (V r) (N r)
l V r (N r)
_) (Loc Point (V a) (N a)
p a
x) = forall a. Point (V a) (N a) -> a -> Located a
Loc (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 (V (Located a)) (V r) (N r)
m Point (V a) (N a)
p) (forall (v :: * -> *) n a b.
(InSpace v n a, LinearMappable a b, N b ~ n) =>
LinearMap v (V b) n -> a -> b
linmap LinearMap (V (Located a)) (V r) (N r)
l a
x)
  {-# INLINE amap #-}

instance (Metric v, Metric u, OrderedField n, r ~ Path u n)
    => AffineMappable (Path v n) r where
  amap :: (Additive (V (Path v n)), Foldable (V (Path v n)), Additive (V r),
 Num (N r)) =>
AffineMap (V (Path v n)) (V r) (N r) -> Path v n -> r
amap AffineMap (V (Path v n)) (V r) (N r)
m = forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ 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 (V (Path v n)) (V r) (N r)
m
  {-# INLINE amap #-}