content: {-# 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 { lapply :: v n -> u n }
  
  toLinearMap :: Transformation v n -> LinearMap v v n
  toLinearMap (Transformation (m :-: _) _ _) = LinearMap 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 = vmap . lapply
  
  instance r ~ Offset c u m => LinearMappable (Offset c v n) r where
    vmap f (OffsetClosed v) = OffsetClosed (f v)
    vmap _ OffsetOpen       = OffsetOpen
    {-# INLINE vmap #-}
  
  instance r ~ Segment c u m => LinearMappable (Segment c v n) r where
    vmap f (Linear offset)      = Linear (vmap f offset)
    vmap f (Cubic v1 v2 offset) = Cubic (f v1) (f v2) (vmap f offset)
    {-# INLINE vmap #-}
  
  instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ SegTree u m)
      => LinearMappable (SegTree v n) r where
    vmap f = over _Wrapped (fmap' (vmap 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 f (Line st)        = Line (vmap f st)
    vmap f (Loop st offset) = Loop (vmap f st) (vmap f offset)
    {-# INLINE vmap #-}
  
  instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail u m)
      => LinearMappable (Trail v n) r where
    vmap f (Trail (Line st))        = Trail $ Line (vmap f st)
    vmap f (Trail (Loop st offset)) = Trail $ Loop (vmap f st) (vmap f offset)
    {-# INLINE vmap #-}
  
  instance LinearMappable (Point v n) (Point u m) where
    vmap f (P v) = P (f v)
    {-# INLINE vmap #-}
  
  instance r ~ FixedSegment u m => LinearMappable (FixedSegment v n) r where
    vmap f (FLinear p0 p1)      = FLinear (vmap f p0) (vmap f p1)
    vmap f (FCubic p0 p1 p2 p3) = FCubic (vmap f p0) (vmap f p1)
                                         (vmap f p2) (vmap f p3)
    {-# INLINE vmap #-}
  
  instance (LinearMappable a b, r ~ Located b) => LinearMappable (Located a) r where
    vmap f (Loc p a) = Loc (vmap f p) (vmap f a)
    {-# INLINE vmap #-}
  
  instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Path u m)
      => LinearMappable (Path v n) r where
    vmap f = _Wrapped . mapped %~ vmap 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 f = AffineMap (LinearMap f)
  
  toAffineMap :: Transformation v n -> AffineMap v v n
  toAffineMap t = AffineMap (toLinearMap t) (transl 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 f _) = linmap 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 (AffineMap f v) p = linmap f p .+^ v
    {-# INLINE amap #-}
  
  instance r ~ FixedSegment u n => AffineMappable (FixedSegment v n) r where
    amap m (FLinear p0 p1)      = FLinear (amap m p0) (amap m p1)
    amap m (FCubic p0 p1 p2 p3) = FCubic (amap m p0) (amap m p1) (amap m p2) (amap m p3)
    {-# INLINE amap #-}
  
  instance (LinearMappable a b, N a ~ N b, r ~ Located b) => AffineMappable (Located a) r where
    amap m@(AffineMap l _) (Loc p x) = Loc (amap m p) (linmap l x)
    {-# INLINE amap #-}
  
  instance (Metric v, Metric u, OrderedField n, r ~ Path u n)
      => AffineMappable (Path v n) r where
    amap m = _Wrapped . mapped %~ amap m
    {-# INLINE amap #-}
  