Common.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE UnicodeSyntax   #-}
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    (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)

type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon)
type Trajectory = (Polygon, Polygon) → (Double → Polygon)
type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)]

data Morph = Morph
  { morphTolerance            :: Double
  , morphColorComponents      :: ColorComponents
  , morphPointCorrespondence  :: PointCorrespondence
  , morphTrajectory           :: Trajectory
  , morphObjectCorrespondence :: ObjectCorrespondence
  }

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'
      ]

normalizePolygons :: Polygon -> Polygon -> (Polygon, Polygon)
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)

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)

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

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
toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)]
toShapes tol src =
  [ (attrs, plToPolygon tol shape)
  | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src
  , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph
  ]

unsafeSVGToPolygon :: Double -> SVG -> Polygon
unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src

annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG
annotatePolygons fn svg = mkGroup
  [ fn poly & drawAttributes .~ attr
  | (attr, poly) <- toShapes 0.001 svg
  ]