{-# 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 Point v n -> Point v n
p1) <> :: Deformation v v n -> Deformation v v n -> Deformation v v n
<> (Deformation Point v n -> Point v n
p2) = forall (v :: * -> *) (u :: * -> *) n.
(Point v n -> Point u n) -> Deformation v u n
Deformation (Point v n -> Point v n
p1 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 = forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: Deformation v v n
mempty = forall (v :: * -> *) (u :: * -> *) n.
(Point v n -> Point u n) -> Deformation v u n
Deformation 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 :: forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Deformation v v n
asDeformation Transformation v n
t = forall (v :: * -> *) (u :: * -> *) n.
(Point v n -> Point u n) -> Deformation v u n
Deformation (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' = forall a b. a -> b -> a
const 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 Point (V (Point v n)) (N (Point v n))
-> Point (V r) (N (Point v n))
l) = 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 :: forall (v :: * -> *) (u :: * -> *) n.
(Metric v, Metric u, OrderedField n) =>
n -> Deformation v u n -> FixedSegment v n -> [FixedSegment u n]
deformSegment n
epsilon Deformation v u n
t = Int -> FixedSegment v n -> [FixedSegment u n]
go (Int
0::Int)
  where
    go :: Int -> FixedSegment v n -> [FixedSegment u n]
go Int
n FixedSegment v n
s
      | Int
n forall a. Eq a => a -> a -> Bool
== Int
100               = [forall (v :: * -> *) (u :: * -> *) n.
Deformation v u n -> FixedSegment v n -> FixedSegment u n
approx Deformation v u n
t FixedSegment v n
s]
      | 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 = [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              = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> FixedSegment v n -> [FixedSegment u n]
go (Int
nforall a. Num a => a -> a -> a
+Int
1)) [FixedSegment v n
s1, FixedSegment v n
s2]
      where
        (FixedSegment v n
s1, FixedSegment v n
s2) = forall p. Sectionable p => p -> N p -> (p, p)
splitAtParam FixedSegment v n
s n
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 :: forall (v :: * -> *) (u :: * -> *) n.
Deformation v u n -> FixedSegment v n -> FixedSegment u n
approx Deformation v u n
t (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.
Deformable a b =>
Deformation (V a) (V b) (N a) -> a -> b
deform Deformation v u n
t Point v n
p0) (forall a b.
Deformable a b =>
Deformation (V a) (V b) (N a) -> a -> b
deform Deformation v u n
t Point v n
p1)
approx Deformation v u n
t (FCubic Point v n
p0 Point v n
c1 Point v n
c2 Point v n
p1) = 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 = forall a b.
Deformable a b =>
Deformation (V a) (V b) (N a) -> a -> b
deform Deformation v u n
t

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