    {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE FlexibleContexts      #-}
    {-# LANGUAGE FlexibleInstances     #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE ScopedTypeVariables   #-}
    {-# LANGUAGE TypeFamilies          #-}
    {-# LANGUAGE UndecidableInstances  #-}

    module Diagrams.Deform
           ( Deformation(..)
           , Deformable(..)
           , asDeformation
           ) where

    import           Control.Lens        (mapped, over, _Wrapped)
    import           Data.Monoid         hiding ((<>))
    import           Data.Semigroup
    import           Prelude

    import           Diagrams.Core
    import           Diagrams.Located
    import           Diagrams.Parametric
    import           Diagrams.Path
    import           Diagrams.Segment
    import           Diagrams.Trail

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

    ------------------------------------------------------------
    -- Deformations

    -- | @Deformations@ are a superset of the affine transformations
    --   represented by the 'Transformation' type.  In general they are not
    --   invertible.  @Deformation@s include projective transformations.
    --   @Deformation@ can represent other functions from points to points
    --   which are "well-behaved", in that they do not introduce small wiggles.
    newtype Deformation v u n = Deformation (Point v n -> Point u n)

    instance Semigroup (Deformation v v n) where
      (Deformation p1) <> (Deformation p2) = Deformation (p1 . p2)

    instance Monoid (Deformation v v n) where
      mappend = (<>)
      mempty = Deformation id

    class Deformable a b where
      -- | @deform' epsilon d a@ transforms @a@ by the deformation @d@.
      -- If the type of @a@ is not closed under projection, approximate
      -- to accuracy @epsilon@.
      deform' :: N a -> Deformation (V a) (V b) (N a) -> a -> b

      -- | @deform d a@ transforms @a@ by the deformation @d@.
      -- If the type of @a@ is not closed under projection, @deform@
      -- should call @deform'@ with some reasonable default value of
      -- @epsilon@.
      deform :: Deformation (V a) (V b) (N a) -> a -> b

    -- | @asDeformation@ converts a 'Transformation' to a 'Deformation' by
    -- discarding the inverse transform.  This allows reusing
    -- @Transformation@s in the construction of @Deformation@s.
    asDeformation :: (Additive v, Num n) => Transformation v n -> Deformation v v n
    asDeformation t = Deformation (papply t)

    ------------------------------------------------------------
    -- Instances

    instance r ~ Point u n => Deformable (Point v n) r where
      deform' = const deform

      deform (Deformation l) = l

    -- | Cubic curves are not closed under perspective projections.
    -- Therefore @Segment@s are not an instance of Deformable.  However,
    -- the deformation of a @Segment@ can be approximated to arbitrary
    -- precision by a series of @Segment@s.  @deformSegment@ does this,
    -- which allows types built from lists of @Segment@s to themselves be
    -- @Deformable@.
    deformSegment :: (Metric v, Metric u, OrderedField n)
       => n -> Deformation v u n -> FixedSegment v n -> [FixedSegment u n]
    deformSegment epsilon t = go (0::Int)
      where
        go n s
          | n == 100               = [approx t s]
          | goodEnough epsilon t s = [approx t s]
          | otherwise              = concatMap (go (n+1)) [s1, s2]
          where
            (s1, s2) = splitAtParam s 0.5
    -- deformSegment epsilon t s
    --     | goodEnough epsilon t s = [approx t s]
    --     | otherwise              = concatMap (deformSegment epsilon t) [s1, s2]
    --   where
    --     (s1, s2) = splitAtParam s 0.5

    approx :: Deformation v u n -> FixedSegment v n -> FixedSegment u n
    approx t (FLinear p0 p1)      = FLinear (deform t p0) (deform t p1)
    approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1)
      where f = deform t

    goodEnough :: (Metric v, Metric u, OrderedField n) => n -> Deformation v u n -> FixedSegment v n -> Bool
    goodEnough e t s =
        all (< e) [norm $ deform t (s `atParam` u) .-. approx t s `atParam` u
                  | u <- [0.25, 0.5, 0.75]]

    instance (Metric v, Metric u, OrderedField n, r ~ Located (Trail u n))
        => Deformable (Located (Trail v n)) r where
      deform' eps p t
        | isLine $ unLoc t  = line `at` p0
        | otherwise = glueTrail line `at` p0
        where
          segs = concatMap (deformSegment eps p) $ fixTrail t
          p0 = case segs of
                 (FLinear start _:_)    -> start
                 (FCubic start _ _ _:_) -> start
                 _                      -> deform p (loc t)
          line = trailFromSegments $ map (unLoc . fromFixedSeg) segs

      deform p t = deform' (0.01 * extent) p t
        where
          -- estimate the "size" of the Trail' as
          -- the maximum distance to any vertex
          extent = maximum . map dist . trailVertices $ t
          dist pt = norm $ pt .-. loc t

    instance (Metric v, Metric u, OrderedField n, r ~ Path u n) => Deformable (Path v n) r where
      deform' eps p = over (_Wrapped . mapped) (deform' eps p)
      deform p      = over (_Wrapped . mapped) (deform p)