{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE UnicodeSyntax   #-}
{-|
Copyright   : Written by David Himmelstrup
License     : Unlicense
Maintainer  : lemmih@gmail.com
Stability   : experimental
Portability : POSIX
-}
module Reanimate.Morph.Common
  ( PointCorrespondence
  , Trajectory
  , ObjectCorrespondence
  , Morph(..)
  , morph
  , splitObjectCorrespondence
  , dupObjectCorrespondence
  , genesisObjectCorrespondence
  , toShapes
  , normalizePolygons
  , annotatePolygons
  , unsafeSVGToPolygon
  ) where

import           Control.Lens
import qualified Data.Vector               as V
import           Graphics.SvgTree          (DrawAttributes, Texture (..),
                                            drawAttributes, fillColor,
                                            fillOpacity, groupOpacity,
                                            strokeColor, strokeOpacity)
import           Linear.V2
import           Reanimate.Animation
import           Reanimate.ColorComponents
import           Reanimate.Ease
import           Reanimate.Math.Polygon    (APolygon, Epsilon, Polygon,
                                            mkPolygon, pAddPoints, pCentroid,
                                            pCutEqual, pSize, polygonPoints)
import           Reanimate.PolyShape
import           Reanimate.Svg

-- import Debug.Trace

-- Correspondence
-- Trajectory
-- Color interpolation
-- Polygon holes
-- Polygon splitting

-- Graphical polygon? FIXME: Come up with a better name.
type GPolygon = (DrawAttributes, Polygon)

-- | Method determining how points in the source polygon align with
--   points in the target polygon.
type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon)

-- | Method for interpolating between two aligned polygons.
type Trajectory = (Polygon, Polygon) → (Double → Polygon)

-- | Method for pairing sets of polygons.
type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)]

-- | Morphing strategy
data Morph = Morph
  { Morph -> Double
morphTolerance            :: Double
    -- ^ Morphing curves is not always possible and
    --   sometimes shapes are reduced to polygons or meta-curves.
    --   This parameter determined the accuracy of this transformation.
  , Morph -> ColorComponents
morphColorComponents      :: ColorComponents
    -- ^ Color components used for color interpolation. LAB is usually
    --   the best option here.
  , Morph -> PointCorrespondence
morphPointCorrespondence  :: PointCorrespondence
    -- ^ Desired point-correspondence algorithm.
  , Morph -> Trajectory
morphTrajectory           :: Trajectory
    -- ^ Desired interpolation algorithm.
  , Morph -> ObjectCorrespondence
morphObjectCorrespondence :: ObjectCorrespondence
    -- ^ Desired object-correspondence algorithm.
  }

{-# INLINE morph #-}
-- | Apply morphing strategy to interpolate between two SVG images.
morph :: Morph -> SVG -> SVG -> Double -> SVG
morph :: Morph -> SVG -> SVG -> Double -> SVG
morph Morph{Double
ColorComponents
ObjectCorrespondence
Trajectory
PointCorrespondence
morphObjectCorrespondence :: ObjectCorrespondence
morphTrajectory :: Trajectory
morphPointCorrespondence :: PointCorrespondence
morphColorComponents :: ColorComponents
morphTolerance :: Double
morphObjectCorrespondence :: Morph -> ObjectCorrespondence
morphTrajectory :: Morph -> Trajectory
morphPointCorrespondence :: Morph -> PointCorrespondence
morphColorComponents :: Morph -> ColorComponents
morphTolerance :: Morph -> Double
..} SVG
src SVG
dst = \Double
t ->
  case Double
t of
    Double
0 -> SVG -> SVG
lowerTransformations SVG
src
    Double
1 -> SVG -> SVG
lowerTransformations SVG
dst
    Double
_ -> [SVG] -> SVG
mkGroup
          [ APolygon Rational -> SVG
forall a. Real a => APolygon a -> SVG
render (Double -> APolygon Rational
genPoints Double
t)
              SVG -> (SVG -> SVG) -> SVG
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes) -> SVG -> Identity SVG
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> SVG -> Identity SVG)
-> DrawAttributes -> SVG -> SVG
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double -> DrawAttributes
genAttrs Double
t
          | (Double -> DrawAttributes
genAttrs, Double -> APolygon Rational
genPoints) <- [(Double -> DrawAttributes, Double -> APolygon Rational)]
gens
          ]
  where
    render :: APolygon a -> SVG
render APolygon a
p = [(Double, Double)] -> SVG
mkLinePathClosed
        [ (Double
x,Double
y) | V2 Double
x Double
y <- (V2 a -> V2 Double) -> [V2 a] -> [V2 Double]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Double) -> V2 a -> V2 Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac) ([V2 a] -> [V2 Double]) -> [V2 a] -> [V2 Double]
forall a b. (a -> b) -> a -> b
$ Vector (V2 a) -> [V2 a]
forall a. Vector a -> [a]
V.toList (Vector (V2 a) -> [V2 a]) -> Vector (V2 a) -> [V2 a]
forall a b. (a -> b) -> a -> b
$ APolygon a -> Vector (V2 a)
forall a. APolygon a -> Vector (V2 a)
polygonPoints APolygon a
p ]
    srcShapes :: [(DrawAttributes, APolygon Rational)]
srcShapes = Double -> SVG -> [(DrawAttributes, APolygon Rational)]
toShapes Double
morphTolerance SVG
src
    dstShapes :: [(DrawAttributes, APolygon Rational)]
dstShapes = Double -> SVG -> [(DrawAttributes, APolygon Rational)]
toShapes Double
morphTolerance SVG
dst
    pairs :: [((DrawAttributes, APolygon Rational),
  (DrawAttributes, APolygon Rational))]
pairs = ObjectCorrespondence
morphObjectCorrespondence [(DrawAttributes, APolygon Rational)]
srcShapes [(DrawAttributes, APolygon Rational)]
dstShapes
    gens :: [(Double -> DrawAttributes, Double -> APolygon Rational)]
gens =
      [ (ColorComponents
-> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
interpolateAttrs ColorComponents
morphColorComponents DrawAttributes
srcAttr DrawAttributes
dstAttr, Trajectory
morphTrajectory (APolygon Rational, APolygon Rational)
arranged)
      | ((DrawAttributes
srcAttr, APolygon Rational
srcPoly'), (DrawAttributes
dstAttr, APolygon Rational
dstPoly')) <- [((DrawAttributes, APolygon Rational),
  (DrawAttributes, APolygon Rational))]
pairs
      , let arranged :: (APolygon Rational, APolygon Rational)
arranged = PointCorrespondence
morphPointCorrespondence APolygon Rational
srcPoly' APolygon Rational
dstPoly'
      ]

-- | Add points to each polygon such that they end up with same size.
normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
normalizePolygons :: APolygon a -> APolygon a -> (APolygon a, APolygon a)
normalizePolygons APolygon a
src APolygon a
dst =
    (Int -> APolygon a -> APolygon a
forall a. PolyCtx a => Int -> APolygon a -> APolygon a
pAddPoints (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
dstNInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
srcN) APolygon a
src
    ,Int -> APolygon a -> APolygon a
forall a. PolyCtx a => Int -> APolygon a -> APolygon a
pAddPoints (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
srcNInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
dstN) APolygon a
dst)
  where
    srcN :: Int
srcN = APolygon a -> Int
forall a. APolygon a -> Int
pSize APolygon a
src
    dstN :: Int
dstN = APolygon a -> Int
forall a. APolygon a -> Int
pSize APolygon a
dst

interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
interpolateAttrs :: ColorComponents
-> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
interpolateAttrs ColorComponents
colorComps DrawAttributes
src DrawAttributes
dst Double
t =
    DrawAttributes
src DrawAttributes
-> (DrawAttributes -> DrawAttributes) -> DrawAttributes
forall a b. a -> (a -> b) -> b
& (Maybe Texture -> Identity (Maybe Texture))
-> DrawAttributes -> Identity DrawAttributes
forall c. HasDrawAttributes c => Lens' c (Maybe Texture)
fillColor ((Maybe Texture -> Identity (Maybe Texture))
 -> DrawAttributes -> Identity DrawAttributes)
-> Maybe Texture -> DrawAttributes -> DrawAttributes
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Texture -> Texture -> Texture
interpColor (Texture -> Texture -> Texture)
-> Maybe Texture -> Maybe (Texture -> Texture)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawAttributes
srcDrawAttributes
-> Getting (Maybe Texture) DrawAttributes (Maybe Texture)
-> Maybe Texture
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Texture) DrawAttributes (Maybe Texture)
forall c. HasDrawAttributes c => Lens' c (Maybe Texture)
fillColor Maybe (Texture -> Texture) -> Maybe Texture -> Maybe Texture
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DrawAttributes
dstDrawAttributes
-> Getting (Maybe Texture) DrawAttributes (Maybe Texture)
-> Maybe Texture
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Texture) DrawAttributes (Maybe Texture)
forall c. HasDrawAttributes c => Lens' c (Maybe Texture)
fillColor)
        DrawAttributes
-> (DrawAttributes -> DrawAttributes) -> DrawAttributes
forall a b. a -> (a -> b) -> b
& (Maybe Texture -> Identity (Maybe Texture))
-> DrawAttributes -> Identity DrawAttributes
forall c. HasDrawAttributes c => Lens' c (Maybe Texture)
strokeColor ((Maybe Texture -> Identity (Maybe Texture))
 -> DrawAttributes -> Identity DrawAttributes)
-> Maybe Texture -> DrawAttributes -> DrawAttributes
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Texture -> Texture -> Texture
interpColor (Texture -> Texture -> Texture)
-> Maybe Texture -> Maybe (Texture -> Texture)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawAttributes
srcDrawAttributes
-> Getting (Maybe Texture) DrawAttributes (Maybe Texture)
-> Maybe Texture
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Texture) DrawAttributes (Maybe Texture)
forall c. HasDrawAttributes c => Lens' c (Maybe Texture)
strokeColor Maybe (Texture -> Texture) -> Maybe Texture -> Maybe Texture
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DrawAttributes
dstDrawAttributes
-> Getting (Maybe Texture) DrawAttributes (Maybe Texture)
-> Maybe Texture
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Texture) DrawAttributes (Maybe Texture)
forall c. HasDrawAttributes c => Lens' c (Maybe Texture)
strokeColor)
        DrawAttributes
-> (DrawAttributes -> DrawAttributes) -> DrawAttributes
forall a b. a -> (a -> b) -> b
& (Maybe Float -> Identity (Maybe Float))
-> DrawAttributes -> Identity DrawAttributes
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
fillOpacity ((Maybe Float -> Identity (Maybe Float))
 -> DrawAttributes -> Identity DrawAttributes)
-> Maybe Float -> DrawAttributes -> DrawAttributes
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Float -> Float -> Float
forall b a a. (Fractional b, Real a, Real a) => a -> a -> b
interpOpacity (Float -> Float -> Float) -> Maybe Float -> Maybe (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawAttributes
srcDrawAttributes
-> Getting (Maybe Float) DrawAttributes (Maybe Float)
-> Maybe Float
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Float) DrawAttributes (Maybe Float)
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
fillOpacity Maybe (Float -> Float) -> Maybe Float -> Maybe Float
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DrawAttributes
dstDrawAttributes
-> Getting (Maybe Float) DrawAttributes (Maybe Float)
-> Maybe Float
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Float) DrawAttributes (Maybe Float)
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
fillOpacity)
        DrawAttributes
-> (DrawAttributes -> DrawAttributes) -> DrawAttributes
forall a b. a -> (a -> b) -> b
& (Maybe Float -> Identity (Maybe Float))
-> DrawAttributes -> Identity DrawAttributes
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
groupOpacity ((Maybe Float -> Identity (Maybe Float))
 -> DrawAttributes -> Identity DrawAttributes)
-> Maybe Float -> DrawAttributes -> DrawAttributes
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Float -> Float -> Float
forall b a a. (Fractional b, Real a, Real a) => a -> a -> b
interpOpacity (Float -> Float -> Float) -> Maybe Float -> Maybe (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawAttributes
srcDrawAttributes
-> Getting (Maybe Float) DrawAttributes (Maybe Float)
-> Maybe Float
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Float) DrawAttributes (Maybe Float)
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
groupOpacity Maybe (Float -> Float) -> Maybe Float -> Maybe Float
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DrawAttributes
dstDrawAttributes
-> Getting (Maybe Float) DrawAttributes (Maybe Float)
-> Maybe Float
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Float) DrawAttributes (Maybe Float)
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
groupOpacity)
        DrawAttributes
-> (DrawAttributes -> DrawAttributes) -> DrawAttributes
forall a b. a -> (a -> b) -> b
& (Maybe Float -> Identity (Maybe Float))
-> DrawAttributes -> Identity DrawAttributes
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
strokeOpacity ((Maybe Float -> Identity (Maybe Float))
 -> DrawAttributes -> Identity DrawAttributes)
-> Maybe Float -> DrawAttributes -> DrawAttributes
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Float -> Float -> Float
forall b a a. (Fractional b, Real a, Real a) => a -> a -> b
interpOpacity (Float -> Float -> Float) -> Maybe Float -> Maybe (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawAttributes
srcDrawAttributes
-> Getting (Maybe Float) DrawAttributes (Maybe Float)
-> Maybe Float
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Float) DrawAttributes (Maybe Float)
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
strokeOpacity Maybe (Float -> Float) -> Maybe Float -> Maybe Float
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DrawAttributes
dstDrawAttributes
-> Getting (Maybe Float) DrawAttributes (Maybe Float)
-> Maybe Float
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Float) DrawAttributes (Maybe Float)
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
strokeOpacity)
  where
    interpColor :: Texture -> Texture -> Texture
interpColor (ColorRef PixelRGBA8
a) (ColorRef PixelRGBA8
b) =
      PixelRGBA8 -> Texture
ColorRef (PixelRGBA8 -> Texture) -> PixelRGBA8 -> Texture
forall a b. (a -> b) -> a -> b
$ ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> Double -> PixelRGBA8
interpolateRGBA8 ColorComponents
colorComps PixelRGBA8
a PixelRGBA8
b Double
t
    -- interpolateColor (ColorRef a) FillNone = ColorRef a
    interpColor Texture
a Texture
_ = Texture
a
    interpOpacity :: a -> a -> b
interpOpacity a
a a
b = Double -> b
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Double -> Signal
fromToS (a -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
a) (a -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
b) Double
t)

-- | Object-correspondence algorithm that spawn objects as necessary.
genesisObjectCorrespondence :: ObjectCorrespondence
genesisObjectCorrespondence :: ObjectCorrespondence
genesisObjectCorrespondence [(DrawAttributes, APolygon Rational)]
left [(DrawAttributes, APolygon Rational)]
right =
  case ([(DrawAttributes, APolygon Rational)]
left, [(DrawAttributes, APolygon Rational)]
right) of
    ([] , []) -> []
    ([], (DrawAttributes
y1,APolygon Rational
y2):[(DrawAttributes, APolygon Rational)]
ys) ->
      ((DrawAttributes
y1,APolygon Rational
y2), (DrawAttributes
y1, APolygon Rational -> APolygon Rational -> APolygon Rational
forall a a.
(Real a, Fractional a, Epsilon a) =>
APolygon a -> APolygon a -> APolygon a
emptyFrom APolygon Rational
y2 APolygon Rational
y2)) ((DrawAttributes, APolygon Rational),
 (DrawAttributes, APolygon Rational))
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
forall a. a -> [a] -> [a]
: ObjectCorrespondence
genesisObjectCorrespondence [] [(DrawAttributes, APolygon Rational)]
ys
    ((DrawAttributes
x1,APolygon Rational
x2):[(DrawAttributes, APolygon Rational)]
xs, []) ->
      ((DrawAttributes
x1,APolygon Rational
x2), (DrawAttributes
x1, APolygon Rational -> APolygon Rational -> APolygon Rational
forall a a.
(Real a, Fractional a, Epsilon a) =>
APolygon a -> APolygon a -> APolygon a
emptyFrom APolygon Rational
x2 APolygon Rational
x2)) ((DrawAttributes, APolygon Rational),
 (DrawAttributes, APolygon Rational))
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
forall a. a -> [a] -> [a]
: ObjectCorrespondence
genesisObjectCorrespondence [(DrawAttributes, APolygon Rational)]
xs []
    ((DrawAttributes, APolygon Rational)
x:[(DrawAttributes, APolygon Rational)]
xs, (DrawAttributes, APolygon Rational)
y:[(DrawAttributes, APolygon Rational)]
ys) ->
      ((DrawAttributes, APolygon Rational)
x,(DrawAttributes, APolygon Rational)
y) ((DrawAttributes, APolygon Rational),
 (DrawAttributes, APolygon Rational))
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
forall a. a -> [a] -> [a]
: ObjectCorrespondence
genesisObjectCorrespondence [(DrawAttributes, APolygon Rational)]
xs [(DrawAttributes, APolygon Rational)]
ys
  where
    emptyFrom :: APolygon a -> APolygon a -> APolygon a
emptyFrom APolygon a
a APolygon a
b = Vector (V2 a) -> APolygon a
forall a. PolyCtx a => Vector (V2 a) -> APolygon a
mkPolygon (Vector (V2 a) -> APolygon a) -> Vector (V2 a) -> APolygon a
forall a b. (a -> b) -> a -> b
$ (V2 a -> V2 a) -> Vector (V2 a) -> Vector (V2 a)
forall a b. (a -> b) -> Vector a -> Vector b
V.map (V2 a -> V2 a -> V2 a
forall a b. a -> b -> a
const (V2 a -> V2 a -> V2 a) -> V2 a -> V2 a -> V2 a
forall a b. (a -> b) -> a -> b
$ APolygon a -> V2 a
forall a. Fractional a => APolygon a -> V2 a
pCentroid APolygon a
a) (APolygon a -> Vector (V2 a)
forall a. APolygon a -> Vector (V2 a)
polygonPoints APolygon a
b)

-- | Object-correspondence algorithm that duplicate objects as necessary.
dupObjectCorrespondence :: ObjectCorrespondence
dupObjectCorrespondence :: ObjectCorrespondence
dupObjectCorrespondence [(DrawAttributes, APolygon Rational)]
left [(DrawAttributes, APolygon Rational)]
right =
  case ([(DrawAttributes, APolygon Rational)]
left, [(DrawAttributes, APolygon Rational)]
right) of
    ([(DrawAttributes, APolygon Rational)]
_, []) -> []
    ([], [(DrawAttributes, APolygon Rational)]
_) -> []
    ([(DrawAttributes, APolygon Rational)
x], [(DrawAttributes, APolygon Rational)
y]) ->
      [((DrawAttributes, APolygon Rational)
x,(DrawAttributes, APolygon Rational)
y)]
    ([(DrawAttributes
x1,APolygon Rational
x2)], [(DrawAttributes, APolygon Rational)]
yShapes) ->
      let x2s :: [APolygon Rational]
x2s = Int -> APolygon Rational -> [APolygon Rational]
forall a. Int -> a -> [a]
replicate ([(DrawAttributes, APolygon Rational)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(DrawAttributes, APolygon Rational)]
yShapes) APolygon Rational
x2
      in ObjectCorrespondence
dupObjectCorrespondence ((APolygon Rational -> (DrawAttributes, APolygon Rational))
-> [APolygon Rational] -> [(DrawAttributes, APolygon Rational)]
forall a b. (a -> b) -> [a] -> [b]
map (DrawAttributes
x1,) [APolygon Rational]
x2s) [(DrawAttributes, APolygon Rational)]
yShapes
    ([(DrawAttributes, APolygon Rational)]
xShapes, [(DrawAttributes
y1,APolygon Rational
y2)]) ->
      let y2s :: [APolygon Rational]
y2s = Int -> APolygon Rational -> [APolygon Rational]
forall a. Int -> a -> [a]
replicate ([(DrawAttributes, APolygon Rational)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(DrawAttributes, APolygon Rational)]
xShapes) APolygon Rational
y2
      in ObjectCorrespondence
dupObjectCorrespondence [(DrawAttributes, APolygon Rational)]
xShapes ((APolygon Rational -> (DrawAttributes, APolygon Rational))
-> [APolygon Rational] -> [(DrawAttributes, APolygon Rational)]
forall a b. (a -> b) -> [a] -> [b]
map (DrawAttributes
y1,) [APolygon Rational]
y2s)
    ((DrawAttributes, APolygon Rational)
x:[(DrawAttributes, APolygon Rational)]
xs, (DrawAttributes, APolygon Rational)
y:[(DrawAttributes, APolygon Rational)]
ys) ->
      ((DrawAttributes, APolygon Rational)
x, (DrawAttributes, APolygon Rational)
y) ((DrawAttributes, APolygon Rational),
 (DrawAttributes, APolygon Rational))
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
forall a. a -> [a] -> [a]
: ObjectCorrespondence
dupObjectCorrespondence [(DrawAttributes, APolygon Rational)]
xs [(DrawAttributes, APolygon Rational)]
ys

-- | Object-correspondence algorithm that splits objects in smaller pieces
--   as necessary.
splitObjectCorrespondence :: ObjectCorrespondence
-- splitObjectCorrespondence = dupObjectCorrespondence
splitObjectCorrespondence :: ObjectCorrespondence
splitObjectCorrespondence [(DrawAttributes, APolygon Rational)]
left [(DrawAttributes, APolygon Rational)]
right =
  case ([(DrawAttributes, APolygon Rational)]
left, [(DrawAttributes, APolygon Rational)]
right) of
    ([(DrawAttributes, APolygon Rational)]
_, []) -> []
    ([], [(DrawAttributes, APolygon Rational)]
_) -> []
    ([(DrawAttributes, APolygon Rational)
x], [(DrawAttributes, APolygon Rational)
y]) ->
      [((DrawAttributes, APolygon Rational)
x,(DrawAttributes, APolygon Rational)
y)]
    ([(DrawAttributes
x1,APolygon Rational
x2)], [(DrawAttributes, APolygon Rational)]
yShapes) ->
      let x2s :: [APolygon Rational]
x2s = Int -> APolygon Rational -> [APolygon Rational]
splitPolygon ([(DrawAttributes, APolygon Rational)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(DrawAttributes, APolygon Rational)]
yShapes) APolygon Rational
x2
      in ObjectCorrespondence
splitObjectCorrespondence ((APolygon Rational -> (DrawAttributes, APolygon Rational))
-> [APolygon Rational] -> [(DrawAttributes, APolygon Rational)]
forall a b. (a -> b) -> [a] -> [b]
map (DrawAttributes
x1,) [APolygon Rational]
x2s) [(DrawAttributes, APolygon Rational)]
yShapes
    ([(DrawAttributes, APolygon Rational)]
xShapes, [(DrawAttributes
y1,APolygon Rational
y2)]) ->
      let y2s :: [APolygon Rational]
y2s = Int -> APolygon Rational -> [APolygon Rational]
splitPolygon ([(DrawAttributes, APolygon Rational)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(DrawAttributes, APolygon Rational)]
xShapes) APolygon Rational
y2
      in ObjectCorrespondence
splitObjectCorrespondence [(DrawAttributes, APolygon Rational)]
xShapes ((APolygon Rational -> (DrawAttributes, APolygon Rational))
-> [APolygon Rational] -> [(DrawAttributes, APolygon Rational)]
forall a b. (a -> b) -> [a] -> [b]
map (DrawAttributes
y1,) [APolygon Rational]
y2s)
    ((DrawAttributes, APolygon Rational)
x:[(DrawAttributes, APolygon Rational)]
xs, (DrawAttributes, APolygon Rational)
y:[(DrawAttributes, APolygon Rational)]
ys) ->
      ((DrawAttributes, APolygon Rational)
x,(DrawAttributes, APolygon Rational)
y) ((DrawAttributes, APolygon Rational),
 (DrawAttributes, APolygon Rational))
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
-> [((DrawAttributes, APolygon Rational),
     (DrawAttributes, APolygon Rational))]
forall a. a -> [a] -> [a]
: ObjectCorrespondence
splitObjectCorrespondence [(DrawAttributes, APolygon Rational)]
xs [(DrawAttributes, APolygon Rational)]
ys

splitPolygon :: Int -> Polygon -> [Polygon]
splitPolygon :: Int -> APolygon Rational -> [APolygon Rational]
splitPolygon Int
1 APolygon Rational
p = [APolygon Rational
p]
splitPolygon Int
n APolygon Rational
p =
  let (APolygon Rational
a,APolygon Rational
b) = APolygon Rational -> (APolygon Rational, APolygon Rational)
forall a. PolyCtx a => APolygon a -> (APolygon a, APolygon a)
pCutEqual APolygon Rational
p
  in Int -> APolygon Rational -> [APolygon Rational]
splitPolygon (Int
nInt -> Int -> Int
forall a. Integral a => a -> a -> a
`div`Int
2) APolygon Rational
a [APolygon Rational] -> [APolygon Rational] -> [APolygon Rational]
forall a. [a] -> [a] -> [a]
++ Int -> APolygon Rational -> [APolygon Rational]
splitPolygon ((Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div`Int
2) APolygon Rational
b

-- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)]
--           -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])]
-- joinPairs _ _ [] = []
-- joinPairs _ [] _ = []
-- joinPairs corr [(x1,x2)] [(y1,y2)] =
--   [(x1,y1, corr x2 y2)]
-- joinPairs corr [(x1,x2)] yShapes =
--   let x2s = splitPolyShape 0.001 (length yShapes) x2
--   in joinPairs corr (map (x1,) x2s) yShapes
-- joinPairs corr xShapes [(y1,y2)] =
--   let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2
--   in joinPairs corr xShapes (map (y1,) y2s)
-- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) =
--   (x1,y1, corr x2 y2) : joinPairs corr xs ys
-- joinPairs _ _ _ = []

-- FIXME: sort by size, smallest to largest
-- | Extract shapes and their graphical attributes from an SVG node.
toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)]
toShapes :: Double -> SVG -> [(DrawAttributes, APolygon Rational)]
toShapes Double
tol SVG
src =
  [ (DrawAttributes
attrs, Double -> PolyShape -> APolygon Rational
plToPolygon Double
tol PolyShape
shape)
  | (SVG -> SVG
_, DrawAttributes
attrs, SVG
glyph) <- SVG -> [(SVG -> SVG, DrawAttributes, SVG)]
svgGlyphs (SVG -> [(SVG -> SVG, DrawAttributes, SVG)])
-> SVG -> [(SVG -> SVG, DrawAttributes, SVG)]
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
lowerTransformations (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
pathify SVG
src
  , PolyShape
shape <- (PolyShapeWithHoles -> PolyShape)
-> [PolyShapeWithHoles] -> [PolyShape]
forall a b. (a -> b) -> [a] -> [b]
map PolyShapeWithHoles -> PolyShape
mergePolyShapeHoles ([PolyShapeWithHoles] -> [PolyShape])
-> [PolyShapeWithHoles] -> [PolyShape]
forall a b. (a -> b) -> a -> b
$ [PolyShape] -> [PolyShapeWithHoles]
plGroupShapes ([PolyShape] -> [PolyShapeWithHoles])
-> [PolyShape] -> [PolyShapeWithHoles]
forall a b. (a -> b) -> a -> b
$ SVG -> [PolyShape]
svgToPolyShapes SVG
glyph
  ]

-- | Extract the first polygon in an SVG node. Will fail if there
--   are no acceptable shapes.
unsafeSVGToPolygon :: Double -> SVG -> Polygon
unsafeSVGToPolygon :: Double -> SVG -> APolygon Rational
unsafeSVGToPolygon Double
tol SVG
src = (DrawAttributes, APolygon Rational) -> APolygon Rational
forall a b. (a, b) -> b
snd ((DrawAttributes, APolygon Rational) -> APolygon Rational)
-> (DrawAttributes, APolygon Rational) -> APolygon Rational
forall a b. (a -> b) -> a -> b
$ [(DrawAttributes, APolygon Rational)]
-> (DrawAttributes, APolygon Rational)
forall a. [a] -> a
head ([(DrawAttributes, APolygon Rational)]
 -> (DrawAttributes, APolygon Rational))
-> [(DrawAttributes, APolygon Rational)]
-> (DrawAttributes, APolygon Rational)
forall a b. (a -> b) -> a -> b
$ Double -> SVG -> [(DrawAttributes, APolygon Rational)]
toShapes Double
tol SVG
src

-- | Map over each polygon in an SVG node.
annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG
annotatePolygons :: (APolygon Rational -> SVG) -> SVG -> SVG
annotatePolygons APolygon Rational -> SVG
fn SVG
svg = [SVG] -> SVG
mkGroup
  [ APolygon Rational -> SVG
fn APolygon Rational
poly SVG -> (SVG -> SVG) -> SVG
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes) -> SVG -> Identity SVG
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> SVG -> Identity SVG)
-> DrawAttributes -> SVG -> SVG
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DrawAttributes
attr
  | (DrawAttributes
attr, APolygon Rational
poly) <- Double -> SVG -> [(DrawAttributes, APolygon Rational)]
toShapes Double
0.001 SVG
svg
  ]