{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# 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) = (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 :: forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Deformation v v n
asDeformation 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
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

  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 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 :: 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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
+Int
1)) [FixedSegment v n
s1, FixedSegment v n
s2]
      where
        (FixedSegment v n
s1, 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 n
N (FixedSegment v 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)      = 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 Deformation v u n
t (FCubic Point v n
p0 Point v n
c1 Point v n
c2 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 :: 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 =
    (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) [Diff (Point u) n -> n
forall a. Floating a => Diff (Point u) a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (Diff (Point u) n -> n) -> Diff (Point 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 a. Num a => Point u a -> Point u a -> Diff (Point u) a
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 <- [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
    | 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 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]
_                      -> 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 Deformation
  (V (Located (Trail v n))) (V r) (N (Located (Trail v n)))
p 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' (n
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 a. Ord a => [a] -> a
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 Point v n
pt = v n -> n
forall a. Floating a => v a -> a
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 a. Num a => Point v a -> Point v a -> Diff (Point v) a
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' N (Path v n)
eps 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 r
(Unwrapped (Path v n) -> Identity (Unwrapped (Path u n)))
-> Path v n -> Identity (Path u n)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
Iso
  (Path v n) (Path u n) (Unwrapped (Path v n)) (Unwrapped (Path u n))
_Wrapped (([Located (Trail v n)] -> Identity [Located (Trail u n)])
 -> Path v n -> Identity r)
-> ((Located (Trail v n) -> Identity (Located (Trail u n)))
    -> [Located (Trail v n)] -> Identity [Located (Trail u n)])
-> ASetter (Path v n) r (Located (Trail v n)) (Located (Trail 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)]
Setter
  [Located (Trail v n)]
  [Located (Trail u n)]
  (Located (Trail v n))
  (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 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 r
(Unwrapped (Path v n) -> Identity (Unwrapped (Path u n)))
-> Path v n -> Identity (Path u n)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
Iso
  (Path v n) (Path u n) (Unwrapped (Path v n)) (Unwrapped (Path u n))
_Wrapped (([Located (Trail v n)] -> Identity [Located (Trail u n)])
 -> Path v n -> Identity r)
-> ((Located (Trail v n) -> Identity (Located (Trail u n)))
    -> [Located (Trail v n)] -> Identity [Located (Trail u n)])
-> ASetter (Path v n) r (Located (Trail v n)) (Located (Trail 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)]
Setter
  [Located (Trail v n)]
  [Located (Trail u n)]
  (Located (Trail v n))
  (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)