Common.hs

{-# 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
  { 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.
  , morphColorComponents      :: ColorComponents
    -- ^ Color components used for color interpolation. LAB is usually
    --   the best option here.
  , morphPointCorrespondence  :: PointCorrespondence
    -- ^ Desired point-correspondence algorithm.
  , morphTrajectory           :: Trajectory
    -- ^ Desired interpolation algorithm.
  , 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{..} src dst = \t ->
  case t of
    -- 0 -> lowerTransformations src
    -- 1 -> lowerTransformations dst
    _ -> mkGroup
          [ render (genPoints t)
              & drawAttributes .~ genAttrs t
          | (genAttrs, genPoints) <- gens
          ]
  where
    render p = mkLinePathClosed
        [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ]
    srcShapes = toShapes morphTolerance src
    dstShapes = toShapes morphTolerance dst
    pairs = morphObjectCorrespondence srcShapes dstShapes
    gens =
      [ (interpolateAttrs morphColorComponents srcAttr dstAttr, morphTrajectory arranged)
      | ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs
      , let arranged = morphPointCorrespondence srcPoly' 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 src dst =
    (pAddPoints (max 0 $ dstN-srcN) src
    ,pAddPoints (max 0 $ srcN-dstN) dst)
  where
    srcN = pSize src
    dstN = pSize dst

interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
interpolateAttrs colorComps src dst t =
    src & fillColor .~ (interpColor <$> src^.fillColor <*> dst^.fillColor)
        & strokeColor .~ (interpColor <$> src^.strokeColor <*> dst^.strokeColor)
        & fillOpacity .~ (interpOpacity <$> src^.fillOpacity <*> dst^.fillOpacity)
        & groupOpacity .~ (interpOpacity <$> src^.groupOpacity <*> dst^.groupOpacity)
        & strokeOpacity .~ (interpOpacity <$> src^.strokeOpacity <*> dst^.strokeOpacity)
  where
    interpColor (ColorRef a) (ColorRef b) =
      ColorRef $ interpolateRGBA8 colorComps a b t
    -- interpolateColor (ColorRef a) FillNone = ColorRef a
    interpColor a _ = a
    interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t)

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

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

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

splitPolygon :: Int -> Polygon -> [Polygon]
splitPolygon 1 p = [p]
splitPolygon n p =
  let (a,b) = pCutEqual p
  in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) 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 tol src =
  [ (attrs, plToPolygon tol shape)
  | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src
  , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph
  ]

-- | Extract the first polygon in an SVG node. Will fail if there
--   are no acceptable shapes.
unsafeSVGToPolygon :: Double -> SVG -> Polygon
unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src

-- | Map over each polygon in an SVG node.
annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG
annotatePolygons fn svg = mkGroup
  [ fn poly & drawAttributes .~ attr
  | (attr, poly) <- toShapes 0.001 svg
  ]