    {-# 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 :: Point v n -> Point v n
    p1) <> :: Deformation v v n -> Deformation v v n -> Deformation v v n
    <> (Deformation p2 :: Point v n -> Point v n
    p2) = (Point v n -> Point v n) -> Deformation v v n
    forall (v :: * -> *) (u :: * -> *) n.
    (Point v n -> Point u n) -> Deformation v u n
    Deformation (Point v n -> Point v n
    p1 (Point v n -> Point v n)
    -> (Point v n -> Point v n) -> Point v n -> Point v n
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Point v n -> Point v n
    p2)

    instance Monoid (Deformation v v n) where
      mappend :: Deformation v v n -> Deformation v v n -> Deformation v v n
    mappend = Deformation v v n -> Deformation v v n -> Deformation v v n
    forall a. Semigroup a => a -> a -> a
    (<>)
      mempty :: Deformation v v n
    mempty = (Point v n -> Point v n) -> Deformation v v n
    forall (v :: * -> *) (u :: * -> *) n.
    (Point v n -> Point u n) -> Deformation v u n
    Deformation Point v n -> Point v n
    forall a. a -> a
    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 :: Transformation v n -> Deformation v v n
    asDeformation t :: Transformation v n
    t = (Point v n -> Point v n) -> Deformation v v n
    forall (v :: * -> *) (u :: * -> *) n.
    (Point v n -> Point u n) -> Deformation v u n
    Deformation (Transformation 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 Transformation v n
    t)

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

    instance r ~ Point u n => Deformable (Point v n) r where
      deform' :: N (Point v n)
    -> Deformation (V (Point v n)) (V r) (N (Point v n))
    -> Point v n
    -> r
    deform' = (Deformation v u n -> Point v n -> Point u n)
    -> n -> Deformation v u n -> Point v n -> Point u n
    forall a b. a -> b -> a
    const Deformation v u n -> Point v n -> Point u n
    forall a b.
    Deformable a b =>
    Deformation (V a) (V b) (N a) -> a -> b
    deform

      deform :: Deformation (V (Point v n)) (V r) (N (Point v n)) -> Point v n -> r
    deform (Deformation l :: Point (V (Point v n)) (N (Point v n))
    -> Point (V r) (N (Point v n))
    l) = Point v n -> r
    Point (V (Point v n)) (N (Point v n))
    -> Point (V r) (N (Point v n))
    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 :: n -> Deformation v u n -> FixedSegment v n -> [FixedSegment u n]
    deformSegment epsilon :: n
    epsilon t :: Deformation v u n
    t = Int -> FixedSegment v n -> [FixedSegment u n]
    go (0::Int)
      where
        go :: Int -> FixedSegment v n -> [FixedSegment u n]
    go n :: Int
    n s :: FixedSegment v n
    s
          | Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 100               = [Deformation v u n -> FixedSegment v n -> FixedSegment u n
    forall (v :: * -> *) (u :: * -> *) n.
    Deformation v u n -> FixedSegment v n -> FixedSegment u n
    approx Deformation v u n
    t FixedSegment v n
    s]
          | n -> Deformation v u n -> FixedSegment v n -> Bool
    forall (v :: * -> *) (u :: * -> *) n.
    (Metric v, Metric u, OrderedField n) =>
    n -> Deformation v u n -> FixedSegment v n -> Bool
    goodEnough n
    epsilon Deformation v u n
    t FixedSegment v n
    s = [Deformation v u n -> FixedSegment v n -> FixedSegment u n
    forall (v :: * -> *) (u :: * -> *) n.
    Deformation v u n -> FixedSegment v n -> FixedSegment u n
    approx Deformation v u n
    t FixedSegment v n
    s]
          | Bool
    otherwise              = (FixedSegment v n -> [FixedSegment u n])
    -> [FixedSegment v n] -> [FixedSegment u n]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Int -> FixedSegment v n -> [FixedSegment u n]
    go (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +1)) [FixedSegment v n
    s1, FixedSegment v n
    s2]
          where
            (s1 :: FixedSegment v n
    s1, s2 :: FixedSegment v n
    s2) = FixedSegment v n
    -> N (FixedSegment v n) -> (FixedSegment v n, FixedSegment v n)
    forall p. Sectionable p => p -> N p -> (p, p)
    splitAtParam FixedSegment v n
    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 :: Deformation v u n -> FixedSegment v n -> FixedSegment u n
    approx t :: Deformation v u n
    t (FLinear p0 :: Point v n
    p0 p1 :: Point v n
    p1)      = Point u n -> Point u n -> FixedSegment u n
    forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
    FLinear (Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    -> Point v n -> Point u n
    forall a b.
    Deformable a b =>
    Deformation (V a) (V b) (N a) -> a -> b
    deform Deformation v u n
    Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    t Point v n
    p0) (Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    -> Point v n -> Point u n
    forall a b.
    Deformable a b =>
    Deformation (V a) (V b) (N a) -> a -> b
    deform Deformation v u n
    Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    t Point v n
    p1)
    approx t :: Deformation v u n
    t (FCubic p0 :: Point v n
    p0 c1 :: Point v n
    c1 c2 :: Point v n
    c2 p1 :: Point v n
    p1) = Point u n
    -> Point u n -> Point u n -> Point u n -> FixedSegment u n
    forall (v :: * -> *) n.
    Point v n
    -> Point v n -> Point v n -> Point v n -> FixedSegment v n
    FCubic (Point v n -> Point u n
    f Point v n
    p0) (Point v n -> Point u n
    f Point v n
    c1) (Point v n -> Point u n
    f Point v n
    c2) (Point v n -> Point u n
    f Point v n
    p1)
      where f :: Point v n -> Point u n
    f = Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    -> Point v n -> Point u n
    forall a b.
    Deformable a b =>
    Deformation (V a) (V b) (N a) -> a -> b
    deform Deformation v u n
    Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    t

    goodEnough :: (Metric v, Metric u, OrderedField n) => n -> Deformation v u n -> FixedSegment v n -> Bool
    goodEnough :: n -> Deformation v u n -> FixedSegment v n -> Bool
    goodEnough e :: n
    e t :: Deformation v u n
    t s :: FixedSegment v n
    s =
        (n -> Bool) -> [n] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (n -> n -> Bool
    forall a. Ord a => a -> a -> Bool
    < n
    e) [u n -> n
    forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
    norm (u n -> n) -> u n -> n
    forall a b. (a -> b) -> a -> b
    $ Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    -> Point v n -> Point u n
    forall a b.
    Deformable a b =>
    Deformation (V a) (V b) (N a) -> a -> b
    deform Deformation v u n
    Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    t (FixedSegment v n
    s FixedSegment v n
    -> N (FixedSegment v n)
    -> Codomain (FixedSegment v n) (N (FixedSegment v n))
    forall p. Parametric p => p -> N p -> Codomain p (N p)
    `atParam` n
    N (FixedSegment v n)
    u) Point u n -> Point u n -> Diff (Point u) n
    forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
    .-. Deformation v u n -> FixedSegment v n -> FixedSegment u n
    forall (v :: * -> *) (u :: * -> *) n.
    Deformation v u n -> FixedSegment v n -> FixedSegment u n
    approx Deformation v u n
    t FixedSegment v n
    s FixedSegment u n
    -> N (FixedSegment u n)
    -> Codomain (FixedSegment u n) (N (FixedSegment u n))
    forall p. Parametric p => p -> N p -> Codomain p (N p)
    `atParam` n
    N (FixedSegment u n)
    u
                  | n
    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' :: N (Located (Trail v n))
    -> Deformation
         (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
    -> Located (Trail v n)
    -> r
    deform' eps :: N (Located (Trail v n))
    eps p :: Deformation
      (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
    p t :: Located (Trail v n)
    t
        | Trail v n -> Bool
    forall (v :: * -> *) n. Trail v n -> Bool
    isLine (Trail v n -> Bool) -> Trail v n -> Bool
    forall a b. (a -> b) -> a -> b
    $ Located (Trail v n) -> Trail v n
    forall a. Located a -> a
    unLoc Located (Trail v n)
    t  = Trail u n
    line Trail u n
    -> Point (V (Trail u n)) (N (Trail u n)) -> Located (Trail u n)
    forall a. a -> Point (V a) (N a) -> Located a
    `at` Point u n
    Point (V (Trail u n)) (N (Trail u n))
    p0
        | Bool
    otherwise = Trail u n -> Trail u n
    forall (v :: * -> *) n.
    (Metric v, OrderedField n) =>
    Trail v n -> Trail v n
    glueTrail Trail u n
    line Trail u n
    -> Point (V (Trail u n)) (N (Trail u n)) -> Located (Trail u n)
    forall a. a -> Point (V a) (N a) -> Located a
    `at` Point u n
    Point (V (Trail u n)) (N (Trail u n))
    p0
        where
          segs :: [FixedSegment u n]
    segs = (FixedSegment v n -> [FixedSegment u n])
    -> [FixedSegment v n] -> [FixedSegment u n]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (n -> Deformation v u n -> FixedSegment v n -> [FixedSegment u n]
    forall (v :: * -> *) (u :: * -> *) n.
    (Metric v, Metric u, OrderedField n) =>
    n -> Deformation v u n -> FixedSegment v n -> [FixedSegment u n]
    deformSegment n
    N (Located (Trail v n))
    eps Deformation v u n
    Deformation
      (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
    p) ([FixedSegment v n] -> [FixedSegment u n])
    -> [FixedSegment v n] -> [FixedSegment u n]
    forall a b. (a -> b) -> a -> b
    $ Located (Trail v n) -> [FixedSegment v n]
    forall (v :: * -> *) n.
    (Metric v, OrderedField n) =>
    Located (Trail v n) -> [FixedSegment v n]
    fixTrail Located (Trail v n)
    t
          p0 :: Point u n
    p0 = case [FixedSegment u n]
    segs of
                 (FLinear start :: Point u n
    start _:_)    -> Point u n
    start
                 (FCubic start :: Point u n
    start _ _ _:_) -> Point u n
    start
                 _                      -> Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    -> Point v n -> Point u n
    forall a b.
    Deformable a b =>
    Deformation (V a) (V b) (N a) -> a -> b
    deform Deformation (V (Point v n)) (V (Point u n)) (N (Point v n))
    Deformation
      (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
    p (Located (Trail v n) -> Point (V (Trail v n)) (N (Trail v n))
    forall a. Located a -> Point (V a) (N a)
    loc Located (Trail v n)
    t)
          line :: Trail u n
    line = [Segment Closed u n] -> Trail u n
    forall (v :: * -> *) n.
    (Metric v, OrderedField n) =>
    [Segment Closed v n] -> Trail v n
    trailFromSegments ([Segment Closed u n] -> Trail u n)
    -> [Segment Closed u n] -> Trail u n
    forall a b. (a -> b) -> a -> b
    $ (FixedSegment u n -> Segment Closed u n)
    -> [FixedSegment u n] -> [Segment Closed u n]
    forall a b. (a -> b) -> [a] -> [b]
    map (Located (Segment Closed u n) -> Segment Closed u n
    forall a. Located a -> a
    unLoc (Located (Segment Closed u n) -> Segment Closed u n)
    -> (FixedSegment u n -> Located (Segment Closed u n))
    -> FixedSegment u n
    -> Segment Closed u n
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FixedSegment u n -> Located (Segment Closed u n)
    forall n (v :: * -> *).
    (Num n, Additive v) =>
    FixedSegment v n -> Located (Segment Closed v n)
    fromFixedSeg) [FixedSegment u n]
    segs

      deform :: Deformation
      (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
    -> Located (Trail v n) -> r
    deform p :: Deformation
      (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
    p t :: Located (Trail v n)
    t = N (Located (Trail v n))
    -> Deformation
         (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
    -> Located (Trail v n)
    -> r
    forall a b.
    Deformable a b =>
    N a -> Deformation (V a) (V b) (N a) -> a -> b
    deform' (0.01 n -> n -> n
    forall a. Num a => a -> a -> a
    * n
    extent) Deformation
      (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
    p Located (Trail v n)
    t
        where
          -- estimate the "size" of the Trail' as
          -- the maximum distance to any vertex
          extent :: n
    extent = [n] -> n
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum ([n] -> n)
    -> (Located (Trail v n) -> [n]) -> Located (Trail v n) -> n
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Point v n -> n) -> [Point v n] -> [n]
    forall a b. (a -> b) -> [a] -> [b]
    map Point v n -> n
    dist ([Point v n] -> [n])
    -> (Located (Trail v n) -> [Point v n])
    -> Located (Trail v n)
    -> [n]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Located (Trail v n) -> [Point v n]
    forall (v :: * -> *) n.
    (Metric v, OrderedField n) =>
    Located (Trail v n) -> [Point v n]
    trailVertices (Located (Trail v n) -> n) -> Located (Trail v n) -> n
    forall a b. (a -> b) -> a -> b
    $ Located (Trail v n)
    t
          dist :: Point v n -> n
    dist pt :: Point v n
    pt = v n -> n
    forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
    norm (v n -> n) -> v n -> n
    forall a b. (a -> b) -> a -> b
    $ Point v n
    pt Point v n -> Point v n -> Diff (Point v) n
    forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
    .-. Located (Trail v n) -> Point (V (Trail v n)) (N (Trail v n))
    forall a. Located a -> Point (V a) (N a)
    loc Located (Trail v n)
    t

    instance (Metric v, Metric u, OrderedField n, r ~ Path u n) => Deformable (Path v n) r where
      deform' :: N (Path v n)
    -> Deformation (V (Path v n)) (V r) (N (Path v n)) -> Path v n -> r
    deform' eps :: N (Path v n)
    eps p :: Deformation (V (Path v n)) (V r) (N (Path v n))
    p = ASetter (Path v n) r (Located (Trail v n)) (Located (Trail u n))
    -> (Located (Trail v n) -> Located (Trail u n)) -> Path v n -> r
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    over (([Located (Trail v n)] -> Identity [Located (Trail u n)])
    -> Path v n -> Identity (Path u n)
    forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
    _Wrapped (([Located (Trail v n)] -> Identity [Located (Trail u n)])
     -> Path v n -> Identity (Path u n))
    -> ((Located (Trail v n) -> Identity (Located (Trail u n)))
        -> [Located (Trail v n)] -> Identity [Located (Trail u n)])
    -> (Located (Trail v n) -> Identity (Located (Trail u n)))
    -> Path v n
    -> Identity (Path u n)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Located (Trail v n) -> Identity (Located (Trail u n)))
    -> [Located (Trail v n)] -> Identity [Located (Trail u n)]
    forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
    mapped) (N (Located (Trail v n))
    -> Deformation
         (V (Located (Trail v n)))
         (V (Located (Trail u n)))
         (N (Located (Trail v n)))
    -> Located (Trail v n)
    -> Located (Trail u n)
    forall a b.
    Deformable a b =>
    N a -> Deformation (V a) (V b) (N a) -> a -> b
    deform' N (Located (Trail v n))
    N (Path v n)
    eps Deformation
      (V (Located (Trail v n)))
      (V (Located (Trail u n)))
      (N (Located (Trail v n)))
    Deformation (V (Path v n)) (V r) (N (Path v n))
    p)
      deform :: Deformation (V (Path v n)) (V r) (N (Path v n)) -> Path v n -> r
    deform p :: Deformation (V (Path v n)) (V r) (N (Path v n))
    p      = ASetter (Path v n) r (Located (Trail v n)) (Located (Trail u n))
    -> (Located (Trail v n) -> Located (Trail u n)) -> Path v n -> r
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    over (([Located (Trail v n)] -> Identity [Located (Trail u n)])
    -> Path v n -> Identity (Path u n)
    forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
    _Wrapped (([Located (Trail v n)] -> Identity [Located (Trail u n)])
     -> Path v n -> Identity (Path u n))
    -> ((Located (Trail v n) -> Identity (Located (Trail u n)))
        -> [Located (Trail v n)] -> Identity [Located (Trail u n)])
    -> (Located (Trail v n) -> Identity (Located (Trail u n)))
    -> Path v n
    -> Identity (Path u n)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Located (Trail v n) -> Identity (Located (Trail u n)))
    -> [Located (Trail v n)] -> Identity [Located (Trail u n)]
    forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
    mapped) (Deformation
      (V (Located (Trail v n)))
      (V (Located (Trail u n)))
      (N (Located (Trail v n)))
    -> Located (Trail v n) -> Located (Trail u n)
    forall a b.
    Deformable a b =>
    Deformation (V a) (V b) (N a) -> a -> b
    deform Deformation
      (V (Located (Trail v n)))
      (V (Located (Trail u n)))
      (N (Located (Trail v n)))
    Deformation (V (Path v n)) (V r) (N (Path v n))
    p)