content: #!/usr/bin/env stack
  -- stack runghc --package reanimate
  {-# LANGUAGE OverloadedStrings #-}
  module Main where
  
  import           Codec.Picture.Types
  import           Control.Exception
  import           Control.Lens                    ()
  import           Control.Monad
  import           Data.Function
  import           Data.List
  import           Data.List.NonEmpty              (NonEmpty)
  import qualified Data.List.NonEmpty              as NE
  import           Data.Maybe
  import           Data.Ratio
  import qualified Data.Text                       as T
  import           Data.Tuple
  import qualified Data.Vector                     as V
  import           Debug.Trace
  import           Linear.Matrix                   hiding (trace)
  import           Linear.Metric
  import           Linear.V2
  import           Linear.V3
  import           Linear.Vector
  import           Numeric.LinearAlgebra           hiding (polar, scale, (<>))
  import qualified Numeric.LinearAlgebra           as Matrix
  import           Numeric.LinearAlgebra.HMatrix   hiding (polar, scale, (<>))
  import           Reanimate
  import           Reanimate.Builtin.Documentation
  import           Reanimate.Debug
  import           Reanimate.Math.Balloon
  import           Reanimate.Math.Common
  import           Reanimate.Math.Compatible       (compatiblyTriangulateP)
  import qualified Reanimate.Math.DCEL             as DCEL
  import           Reanimate.Math.EarClip
  import           Reanimate.Math.Polygon
  import           Reanimate.Math.Render
  import           Reanimate.Math.Smooth
  import           Reanimate.Math.SSSP
  import           Reanimate.Math.Visibility
  import           Reanimate.Morph.Common
  import           Reanimate.Morph.LeastDifference
  import           Reanimate.Morph.LeastWork
  import           Reanimate.Morph.Linear
  import           Reanimate.Morph.Rigid
  import           Reanimate.PolyShape             (svgToPolygons)
  import           Text.Printf
  
  -- p1 = centerPolygon $ shape2
  --p1 = pScale 3.5 $ pAtCenter $ pAddPoints (0+2) (pSetOffset shape13 0)
  -- p1 = setOffset (addPoints 2 shape13) 0
  -- p2 = scalePolygon 0.5 $ centerPolygon shape20
  -- p1 = centerPolygon shape2
  --p2 = pScale 3.5 $ pAtCenter $ pAddPoints 0 (pSetOffset shape14 0)
  -- p2 = setOffset shape14 0
  p1 = pCopy $ pSetOffset (pCopy p1') 0
  p2 = pCopy $ pSetOffset (pCopy p2') 0
  (p1', p2') =
    -- normalizePolygons
    -- closestLinearCorrespondence
    (,)
    -- leastWork zeroStretchCosts defaultBendCosts
    -- leastWork defaultStretchCosts defaultBendCosts
    -- (pAtCenter $ unsafeSVGToPolygon 0.01 $ scale 6 $ latex "S")
    -- (pAtCenter $ unsafeSVGToPolygon 0.01 $ scale 6 $ latex "C")
    (pAtCenter $ unsafeSVGToPolygon 0.1 $ scale 6 $ latex "X")
    (pAtCenter $ unsafeSVGToPolygon 0.1 $ scale 6 $ latex "I")
  
  p1_ = castPolygon p1
  p2_ = castPolygon p2
  polys = triangulate_ p1_ p2_
  p1_circ = castPolygon (circumference (map fst polys') p1_)
  p2_circ = castPolygon (circumference (map snd polys') p2_)
  
  polys' = alignPolygons polys p1_ p2_
  (p1s, p2s) = unzip $ compatTriagPairs [ (castPolygon a, castPolygon b) | (a,b) <- polys' ]
  
  -- (p1s,p2s) = unzip (compatiblyTriangulateP p1 p2)
  
  m2 = DCEL.buildMesh $ DCEL.polygonsMesh
          (map (fmap realToFrac) $ V.toList $ polygonPoints p2_circ)
          (map (map (fmap realToFrac) . V.toList . polygonPoints) p2s)
  
  m1 = DCEL.buildMesh $ DCEL.polygonsMesh
          (map (fmap realToFrac) $ V.toList $ polygonPoints p1_circ)
          (map (map (fmap realToFrac) . V.toList . polygonPoints) p1s)
  
  pipeline1 = last . take 20 . iterate
    ( uncurry DCEL.delaunayFlip .
      uncurry DCEL.splitInternalEdges .
     (\(a,b) -> (DCEL.meshSmoothPosition a, DCEL.meshSmoothPosition b)))
  (m1final, m2final) = last $ take 30 $ iterate
    (pipeline1 .
      uncurry DCEL.splitLongestEdge .
      pipeline1
      ) (m1,m2)
  
  -- (m1good, m2good) = last $ take 9 $ iterate
  --   (pipeline1 .
  --     -- uncurry DCEL.splitLongestEdge .
  --     pipeline1
  --     ) (m1,m2)
  
  main :: IO ()
  -- main = do
  --   evaluate (last $ take 900 $ compatiblyTriangulateP p1 p2)
  --   return ()
  -- main = reanimate $ playTraces $ length $ take 29 p1s
  -- main = reanimate $ playThenReverseA $ pauseAround 0.5 0.5 $ scene $ do
  
  main = reanimate $ scene $ do
    newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor
    -- play
    --   $ playTraces
    --   $ traceA (mapA (withFillOpacity 0 . withStrokeColor "white") drawCircle)
    --   $ traceA (mapA (withFillOpacity 0 . withStrokeColor "white") drawBox)
    --   $ traceSVG ((withFillOpacity 0 . withStrokeColor "white") $ mkCircle 2)
    --   $ traceSVG ((withFillOpacity 0 . withStrokeColor "white") $ mkRect 2 2)
    --   $ 20
    -- play $ playTraces $ last $ take 35 $ compatiblyTriangulateP p1 p2
    -- fork $ newSpriteA $ drawCompatible p1 p2
    -- newSpriteSVG_ $ translate 5 0 $ lowerTransformations $ scale 2 $
    --   -- DCEL.renderMesh 0.02 m1final
    --   DCEL.renderMeshColored m1final
      -- renderMeshPair optMesh
    -- newSpriteSVG_ $ translate (-5) 0 $ lowerTransformations $ scale 2 $
    --   DCEL.renderMesh 0.02 m1good
  
    -- newSpriteSVG_ $
    --   translate (-3) 0 $ scale 1 $ mkGroup
    --   [ mkGroup []
    --   , withFillColor "grey" $ polygonShape p1
    --   , withFillColor "grey" $ polygonNumDots p1
    --   ]
    -- newSpriteSVG_ $
    --   translate 3 0 $ scale 1 $ mkGroup
    --   [ mkGroup []
    --   , withFillColor "grey" $ polygonShape p2
    --   , withFillColor "grey" $ polygonNumDots p2
    --   ]
    -- wait 1
    -- fork $ forM_ p1s $ \p1Piece -> do
    --   newSpriteSVG_ $
    --     translate (-3) 0 $ scale 1 $ mkGroup
    --     [ mkGroup []
    --     , withFillColor "white" $ polygonShape p1Piece
    --     -- , withFillColor "grey" $ polygonNumDots p1Piece
    --     ]
    --   wait (1/60)
    --   -- wait 1
    -- fork $ forM_ p2s $ \p1Piece -> do
    --   newSpriteSVG_ $
    --     translate 3 0 $ scale 1 $ mkGroup
    --     [ mkGroup []
    --     , withFillColor "white" $ polygonShape p1Piece
    --     -- , withFillColor "grey" $ polygonNumDots p1Piece
    --     ]
    --   wait (1/60)
    --   -- wait 1
  
    -- fork $ play $ mkAnimation 3 $ \t ->
    --   let points = interpolate prep t
    --   in  translate (-3) 0 $ scale 1 $ mkGroup
    --   [ mkGroup []
    --   , drawTrigs points (meshTriangles myMesh)
    --   -- , DCEL.renderMeshColored m1
    --   ]
    fork $ play $ mkAnimation 3 $ \t ->
      let points = interpolate optPrep t
      in  translate 3 0 $ lowerTransformations $ scale 1 $ mkGroup
        [ mkGroup []
        , drawTrigs points (meshTriangles optMesh)
        -- , DCEL.renderMeshColored m1final
        -- , withGroupOpacity 0.5 $ DCEL.renderMesh 0.02 m1final
        -- , withGroupOpacity 0.5 $ withFillOpacity 0 $ renderMeshPair optMesh
        -- , let V2 x y = V.head points in
        --   translate x y $ withFillColor "green" $
        --   mkCircle 0.03
        ]
          -- , scale 2 $ polygonNumDots p1
    -- play $ pauseAtEnd 1 $ mkAnimation 3 $ \t ->
    --   let points = interpolate bestPrep t
    --   in  translate 3 0 $ mkGroup [drawTrigs points (meshTriangles bestMesh)
    --       -- , scale 2 $ polygonNumDots p2
    --                                                                           ]
    -- play $ pauseAtEnd 1 $ mkAnimation 3 $ \t ->
    --   let points = interpolate prepRev t in
    --   mkGroup
    --   [ drawTrigs points (meshTriangles myMeshRev)
    --   -- , polygonNumDots shape2
    --   ]
    -- forM_ (myMesh : smoothMesh myMesh) $ \newMesh -> do
    --   let (minAngA, minAngB) = meshMinAngle newMesh
    --   txt <- newSpriteSVG $ withFillColor "white" $
    --     mkGroup
    --     [translate 5 2 $  center $
    --       latex $ T.pack $ printf "Min: %.1f" (minAngA/pi*180)
    --     ,translate 5 1 $  center $
    --       latex $ T.pack $ printf "Min: %.1f" (minAngB/pi*180) ]
    --   s <- newSpriteSVG $ renderAMesh newMesh
    --   wait (recip 60)
    --   destroySprite s
    --   destroySprite txt
    -- newSpriteSVG $ translate (-3) 0 $ scale 2 $ renderMesh p1 (map fst trigs)
    -- newSpriteSVG $ translate 3 0 $ scale 2 $ renderMesh p2 (map snd trigs)
    -- wait 1
   where
    prep      = prepare myMesh
    optPrep   = prepare optMesh
    -- bestPrep  = prepare bestMesh
    myMesh    = mkMesh p1 p2
    optMesh   = toRigidMesh  m1final m2final
    -- optMesh   = DCEL.toRigidMesh  m1good m2good
    -- bestMesh  = last $ smoothMesh myMesh
    prepRev   = prepare myMeshRev
    myMeshRev = reverseMesh myMesh
  
  
  
  reverseMesh :: Mesh -> Mesh
  reverseMesh mesh =
    mesh { meshPointsA = meshPointsB mesh, meshPointsB = meshPointsA mesh }
  
  mkMesh :: Polygon -> Polygon -> Mesh
  mkMesh a b = Mesh
    { meshPointsA   = V.map (fmap realToFrac) pointsA
    , meshPointsB   = V.map (fmap realToFrac) pointsB
    , meshOutline = V.map (fromJust . flip V.elemIndex pointsA) (polygonPoints a)
    , meshTriangles = relTrigs
    }
   where
    pointsA =
      V.fromList $ nub $ V.toList $ V.concat [ polygonPoints a | (a, b) <- trigs ]
    pointsB =
      V.fromList $ nub $ V.toList $ V.concat [ polygonPoints b | (a, b) <- trigs ]
    trigs = compatiblyTriangulateP a b
    mkRel arr p =
      ( fromJust $ V.elemIndex (pAccess p 0) arr
      , fromJust $ V.elemIndex (pAccess p 1) arr
      , fromJust $ V.elemIndex (pAccess p 2) arr
      )
    relTrigs = V.fromList [ mkRel pointsA a | (a, b) <- trigs ]
      -- data Mesh = Mesh (Vector P) (Vector (RelTrig, RelTrig))
  
  testMesh2 :: Mesh
  testMesh2 = mkMesh (pTranslate (V2 0 0) shape2) shape20
  
  testPrep = prepare testMesh2
  
  drawTrigs :: V.Vector (V2 Double) -> V.Vector RelTrig -> SVG
  drawTrigs points trigs = mkGroup
    [ mkGroup
        [ withFillOpacity 1
          $ withStrokeWidth (defaultStrokeWidth * 0)
          $ withStrokeColor "grey"
          $ withFillColor "black"
          $ drawPolygon
          $ map (points V.!) [a, b, c]
        | (a, b, c) <- V.toList trigs
        ]
      -- , a == 0
    -- , mkGroup
    --   [ withFillColor "red" $ mkGroup
    --     [ drawPoint (points V.! a), drawPoint (points V.! b), drawPoint (points V.! c)]
    --   | (a,b,c) <- V.toList trigs
    --   -- , a == 0
    --   ]
    ]
  
  drawTrigsLines :: V.Vector (V2 Double) -> V.Vector RelTrig -> SVG
  drawTrigsLines points trigs = withFillOpacity 0 $ withStrokeColor "black" $ mkGroup
    [ mkLinePathClosed
      [ (aPx, aPy)
      , (bPx, bPy)
      , (cPx, cPy)]
    | (a,b,c) <- V.toList trigs
    -- , a==2 || b == 2 || c == 2
    , let V2 aPx aPy = points V.! a
          V2 bPx bPy = points V.! b
          V2 cPx cPy = points V.! c
    ]
  
  drawPoint :: V2 Double -> SVG
  drawPoint (V2 x y) = translate x y $ mkCircle 0.1
  
  drawPolygon :: [V2 Double] -> SVG
  drawPolygon lst = mkLinePathClosed [ (x, y) | V2 x y <- lst ]
  
  drawCompatible :: Polygon -> Polygon -> Animation
  drawCompatible a b = scene $ do
    let left  = -6
        right = 4
    newSpriteSVG $ translate left 0 $ mkGroup
      [ withFillColor "grey" $ polygonShape a
      , withFillColor "grey" $ polygonNumDots a
      ]
    newSpriteSVG $ translate right 0 $ mkGroup
      [ withFillColor "grey" $ polygonShape b
      , withFillColor "grey" $ polygonNumDots b
      ]
    return ()
    -- let compat = compatiblyTriangulateP a b
    -- forM_ compat $ \(l, r) -> do
    --   fork $ play $ staticFrame 1 $
    --     translate left 0 $ withStrokeColor "white" $ withStrokeWidth (defaultStrokeWidth*0.2) $
    --     withFillOpacity 0 $ polygonShape l
    --   fork $ play $ staticFrame 1 $
    --     translate right 0 $ withStrokeColor "white" $ withStrokeWidth (defaultStrokeWidth*0.2) $
    --     withFillOpacity 0 $ polygonShape r
  