Feature morph (#62)

* Disable windows CI (because of hmatrix)
* Implement ear-clip triangulation.
* Implement common framework for polygon morphing.
* Draft implementations of compatible triangulation and mesh smoothing.
* Implement least-work morphing.
* Implement as-rigid-as-possible morphing.
* Implement SSSP.
* Draft article about polygon morphing.

Former-commit-id: f6f19f58b9dd58c655bcca0ed2d65f72726f0a06

examples/bug_play1.hs

@@ -3,7 +3,6 @@
 module Main(main) where
 
 import Reanimate
-import Reanimate.Scene
 
 -- This should give circle.
 main :: IO ()

examples/bug_play2.hs

@@ -3,7 +3,6 @@
 module Main(main) where
 
 import Reanimate
-import Reanimate.Scene
 
 -- This should give rect.
 main :: IO ()

examples/bug_play3.hs

@@ -3,7 +3,6 @@
 module Main(main) where
 
 import Reanimate
-import Reanimate.Scene
 
 -- This should give rect.
 main :: IO ()

examples/doc_queryNow.hs

@@ -5,7 +5,6 @@ module Main(main) where
 
 import Reanimate
 import Reanimate.Builtin.Documentation
-import Data.Monoid ((<>))
 import qualified Data.Text as T
 
 main :: IO ()

examples/fourier.hs

@@ -8,7 +8,6 @@ import qualified Data.Text as T
 
 import           Graphics.SvgTree
 import           Reanimate
-import           Reanimate.LaTeX  (latex)
 
 waveMultiplier :: Int
 -- waveMultiplier = 1 -- Sawtooth wave

examples/morphology_closest.hs

@@ -0,0 +1,61 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Codec.Picture.Types
+import           Control.Monad
+import           Graphics.SvgTree         (LineJoin (..))
+import           Reanimate
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth defaultStrokeWidth) $
+  mapA (withStrokeColor "black") $
+  mapA (withStrokeLineJoin JoinRound) $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (-4) 4 $
+        center $ latex "no-op"
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (4) 4 $
+        center $ latex "closest"
+      forM_ pairs $ uncurry showPair
+  where
+    showPair from to =
+      waitOn $ do
+        fork $ play $ mkAnimation 4 (morph rawLinear from to)
+          # mapA (translate (-4) (-0.5))
+          # signalA (curveS 4)
+        fork $ play $ mkAnimation 4 (morph linear from to)
+          # mapA (translate (4) (-0.5))
+          # signalA (curveS 4)
+
+    pairs = zip stages (tail stages ++ [head stages])
+    stages = map (lowerTransformations . scale 8 . pathify . center) $ colorize
+      [ latex "X"
+      , latex "$\\aleph$"
+      , latex "Y"
+      , latex "$\\infty$"
+      , latex "I"
+      , latex "$\\pi$"
+      , latex "1"
+      , latex "S"
+      , mkRect 0.5 0.5
+      ]
+
+colorize :: [SVG] -> [SVG]
+colorize lst =
+  [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt
+  | elt <- lst
+  | n <- [0..]
+  ]

examples/morphology_color.hs

@@ -0,0 +1,45 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Reanimate
+import           Reanimate.Interpolate
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  setDuration 5 $
+  mapA (withStrokeWidth 0) $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      doMorph yellow blue
+      doMorph blue yellow
+  where
+    doMorph from to =
+      play $ pauseAtEnd 0.5 $ animate $ \t ->
+        mkGroup
+          [ translate (-screenWidth/2 + screenWidth/6*(n*2+1)) 0 $ mkGroup
+            [ translate 0 3 $ scale 1.5 $ center $ latex label
+            , translate 0 (-0.5) $ morph conf from to t
+            ]
+          | conf <- [ linear
+                    , linear{morphColorComponents=xyzComponents}
+                    , linear{morphColorComponents=hsvComponents}]
+          | label <- ["LAB", "XYZ", "HSV"]
+          | n <- [0..]
+          ]
+    radius = 2.5
+    yellow = withFillColor "yellow" $ mkCircle radius
+    blue   = withFillColor "blue" $ mkCircle radius
+    -- green  = withFillColor "green" $ mkCircle radius
+    -- pink   = withFillColor "pink" $ mkCircle radius
+    -- red    = withFillColor "red" $ mkCircle radius
+    -- purple = withFillColor "purple" $ mkCircle radius

examples/morphology_intro.hs

@@ -0,0 +1,36 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Reanimate
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth 0) $
+  mapA (withStrokeColor "black") $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      play $ step stage1 stage2
+      play $ step stage2 stage3
+      play $ step stage3 stage4
+      play $ step stage4 stage1
+        # setDuration 5
+  where
+    radius = 2.5
+    step from to =
+      signalA (curveS 4) $ animate $ morph linear from to
+    stage1 = translate (-3) 0 $ withFillColor "red" $ mkCircle radius
+    stage2 = translate 3 0 $ withFillColor "blue" $ mkRect (radius*2) (radius*2)
+    stage3 = mkGroup
+      [translate (-1) (-1) $ withFillColor "green" $ mkRect (radius*0.5) (radius*0.5)
+      ,translate 1 (1) $ withFillColor "black" $ mkRect (radius*0.5) (radius*0.5) ]
+    stage4 = translate (-3) 0 $ withFillColor "purple" $ mkCircle (radius*0.24)

examples/morphology_leastwork.hs

@@ -0,0 +1,69 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Codec.Picture.Types
+import           Control.Monad
+import           Graphics.SvgTree          (LineJoin (..))
+import           Reanimate
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.LeastWork
+import           Reanimate.Morph.Linear
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth defaultStrokeWidth) $
+  mapA (withStrokeColor "black") $
+  mapA (withStrokeLineJoin JoinRound) $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (-3) 4 $
+        center $ latex "linear"
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (3) 4 $
+        center $ latex "least-work"
+      forM_ pairs $ uncurry showPair
+  where
+    showPair from to =
+      waitOn $ do
+        fork $ play $ mkAnimation 4 (morph linear from to)
+          # mapA (translate (-3) (-0.5))
+          # signalA (curveS 4)
+        fork $ play $ mkAnimation 4 (morph myMorph from to)
+          # mapA (translate (3) (-0.5))
+          # signalA (curveS 4)
+
+    stretchCosts = defaultStretchCosts
+      { stretchStiffness = 2 }
+    bendCosts = defaultBendCosts
+    myMorph = linear{morphPointCorrespondence = leastWork stretchCosts bendCosts }
+    pairs = zip stages (tail stages ++ [head stages])
+    stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize
+      [ latex "X"
+      , latex "$\\aleph$"
+      , latex "Y"
+      , latex "$\\infty$"
+      , latex "I"
+      , latex "$\\pi$"
+      , latex "1"
+      , latex "T"
+      , latex "I"
+      , latex "L"
+      , latex "S"
+      , mkRect 0.5 0.5
+      ]
+
+colorize :: [SVG] -> [SVG]
+colorize lst =
+  [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt
+  | elt <- lst
+  | n <- [0..]
+  ]

examples/morphology_linear.hs

@@ -0,0 +1,60 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Codec.Picture.Types
+import           Graphics.SvgTree         (LineJoin (..))
+import           Reanimate
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth defaultStrokeWidth) $
+  mapA (withStrokeColor "black") $
+  mapA (withStrokeLineJoin JoinRound) $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $
+      showPair (stages ++ take 1 stages)
+  where
+    showPair (from:to:rest) =
+      waitOn $ do
+        toS <- newSpriteSVG $
+          translate (4) 0 to
+        spriteE toS $ overBeginning 0.2 fadeInE
+        spriteE toS $ overEnding 0.2 fadeOutE
+        m <- fork $ newSpriteA $ animate (morph linear from to)
+          # signalA (curveS 4)
+          # mapA (translate (-4) 0)
+        wait 4
+        destroySprite m
+        destroySprite toS
+        showPair (to:rest)
+        return ()
+    showPair _ = return ()
+
+    stages = map (lowerTransformations . scale 8 . pathify . center) $ colorize
+      [ latex "X"
+      , latex "$\\aleph$"
+      , latex "Y"
+      , latex "$\\infty$"
+      , latex "I"
+      , latex "$\\pi$"
+      , latex "1"
+      , latex "S"
+      , mkRect 0.5 0.5
+      ]
+
+colorize :: [SVG] -> [SVG]
+colorize lst =
+  [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt
+  | elt <- lst
+  | n <- [0..]
+  ]

examples/morphology_linebend.hs

@@ -0,0 +1,63 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Codec.Picture.Types
+import           Control.Monad
+import           Graphics.SvgTree         (LineJoin (..))
+import           Reanimate
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+import           Reanimate.Morph.LineBend
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth defaultStrokeWidth) $
+  mapA (withStrokeColor "black") $
+  mapA (withStrokeLineJoin JoinRound) $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (-3) 4 $
+        center $ latex "linear"
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (3) 4 $
+        center $ latex "line bend"
+      forM_ pairs $ uncurry showPair
+  where
+    showPair from to =
+      waitOn $ do
+        fork $ play $ mkAnimation 4 (morph linear from to)
+          # mapA (translate (-3) (-0.5))
+          # signalA (curveS 4)
+        fork $ play $ mkAnimation 4 (morph myMorph from to)
+          # mapA (translate (3) (-0.5))
+          # signalA (curveS 4)
+
+    myMorph = linear{morphTrajectory = lineBend }
+    pairs = zip stages (tail stages ++ [head stages])
+    stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize
+      [ latex "X"
+      , latex "$\\aleph$"
+      , latex "Y"
+      , latex "$\\infty$"
+      , latex "I"
+      , latex "$\\pi$"
+      , latex "1"
+      , latex "S"
+      , mkRect 0.5 0.5
+      ]
+
+colorize :: [SVG] -> [SVG]
+colorize lst =
+  [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt
+  | elt <- lst
+  | n <- [0..]
+  ]

examples/morphology_linebend_intro.hs

@@ -0,0 +1,100 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Control.Monad
+import           Data.List                (transpose)
+import qualified Data.Vector              as V
+import           Graphics.SvgTree         (LineJoin (..))
+import           Linear.V2
+import           Reanimate
+import           Reanimate.Math.Polygon
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+import           Reanimate.Morph.LineBend
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+spike1 :: Polygon
+spike1 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList
+  [ V2 0 0, V2 2 0
+  , V2 2 1 ]
+
+spike2 :: Polygon
+spike2 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList
+  [ V2 0 0, V2 2 0
+  , V2 0 1 ]
+
+spike3 :: Polygon
+spike3 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList
+  [ V2 0.5 0, V2 1.5 0
+  , V2 1 2 ]
+
+polygonShape :: Polygon -> SVG
+polygonShape p = mkLinePathClosed
+  [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ]
+
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth defaultStrokeWidth) $
+  mapA (withStrokeColor "black") $
+  mapA (withStrokeLineJoin JoinRound) $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (-4) 4 $
+        center $ latex "linear"
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (4) 4 $
+        center $ latex "line bend"
+      showTrails
+      forM_ pairs $ uncurry showPair
+  where
+    showTrails = do
+      _ <- newSpriteSVG $
+            translate (-4) (-0.5) $
+            genTrails (map linearTrajectory pairs)
+      _ <- newSpriteSVG $
+            translate (4) (-0.5) $
+            genTrails (map lineBend pairs)
+      return ()
+    showPair from to =
+      waitOn $ do
+        fork $ play $ mkAnimation 4 (morph linear (polygonShape from) (polygonShape to))
+          # mapA (translate (-4) (-0.5))
+          # mapA (withFillColor "lightgreen")
+          # signalA (curveS 4)
+        fork $ play $ mkAnimation 4 (morph myMorph (polygonShape from) (polygonShape to))
+          # mapA (translate (4) (-0.5))
+          # mapA (withFillColor "cyan")
+          # signalA (curveS 4)
+    myMorph = linear{morphTrajectory = lineBend }
+    pairs = zip stages (tail stages ++ [head stages])
+    stages =
+      [ spike1
+      , spike2
+      , spike3
+      ]
+
+genTrails :: [(Double -> Polygon)] -> SVG
+genTrails plotters =
+    withFillOpacity 0 $
+    withStrokeWidth (defaultStrokeWidth*0.5) $
+    withStrokeColor "black" $
+    withStrokeDashArray [0.1,0.05] $
+    mkGroup $ map mkTrail $ transpose $ concat
+      [
+        [ V.toList $ V.map (fmap realToFrac) (polygonPoints poly)
+        | n <- [0..steps]
+        , let poly = plotter (fromIntegral n / fromIntegral steps)
+        ]
+      | plotter <- plotters ]
+  where
+    steps = 100 :: Int
+    mkTrail lst = mkLinePath [ (x,y) | V2 x y <- lst ]

examples/morphology_object_correspondence.hs

@@ -0,0 +1,59 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Reanimate
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth 0) $
+  mapA (withStrokeColor "black") $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      let showLabel label = do
+            fork $ play $ staticFrame 4 (center $ latex label)
+              # mapA (translate 0 4)
+              # applyE (overBeginning 0.1 fadeInE)
+              # applyE (overEnding 0.1 fadeOutE)
+      let sides = mkGroup
+            [ translate (-4) 0 $ withFillColor "blue" $
+              mkCircle 2
+            , translate 4 0 $ withFillColor "green" $
+              mkCircle 2]
+          middle =
+            withFillColor "red" $
+            mkRect 4 4
+
+      showLabel "Cut"
+      play $ step sides middle
+        # pauseAtEnd 1
+      play $ step middle sides
+        # pauseAtEnd 1
+
+      showLabel "Overlap"
+      play $ stepDup sides middle
+        # pauseAtEnd 1
+      play $ stepDup middle sides
+        # pauseAtEnd 1
+
+      showLabel "Obliterate"
+      play $ stepGenesis sides middle
+        # pauseAtEnd 1
+      play $ stepGenesis middle sides
+        # pauseAtEnd 1
+  where
+    step from to =
+      signalA (curveS 2) $ animate $ morph linear from to
+    stepDup from to =
+      signalA (curveS 2) $ animate $ morph linear{morphObjectCorrespondence=dupObjectCorrespondence} from to
+    stepGenesis from to =
+      signalA (curveS 2) $ animate $ morph linear{morphObjectCorrespondence=genesisObjectCorrespondence} from to

examples/morphology_point_correspondence.hs

@@ -0,0 +1,100 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Codec.Picture.Types
+import           Control.Monad                   (replicateM_)
+import qualified Data.Text                       as T
+import qualified Data.Vector                     as V
+import           Linear.V2
+import           Linear.Vector
+import           Reanimate
+import           Reanimate.Math.Polygon
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth 0) $
+  mapA (withStrokeColor "black") $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      let pl1 = translate (-4) 0 $ mkGroup
+            [ lowerTransformations $ scale 3 $ withFillOpacity 1 $
+              withStrokeColor "black" $
+              withStrokeWidth defaultStrokeWidth $
+              withFillColor "lightgreen" $
+              polygonShape octogon
+            , lowerTransformations $ scale 3 $ polygonNumDots octogon 0
+            ]
+          pl2 n t = translate 4 0 $ lowerTransformations $ scale 3 $ mkGroup
+            [ withFillOpacity 1 $
+              withStrokeColor "black" $
+              withStrokeWidth defaultStrokeWidth $
+              withFillColor "cyan" $
+              polygonShape (pSetOffset star n)
+            , polygonNumDots (pSetOffset star n) t ]
+      offset <- newVar 0
+      slide <- newVar 0
+      _ <- newSprite $ pl2 <$> unVar offset <*> unVar slide
+      _ <- newSpriteSVG $ pl1
+      let slideLeft = do
+            tweenVar slide 1 $ \v -> fromToS v 1 . curveS 4
+            writeVar slide 0
+            modifyVar offset succ
+      replicateM_ 8 $ do
+        offsetVal <- readVar offset
+        play $ step pl1 (pl2 offsetVal 0)
+          # setDuration 3
+        slideLeft
+  where
+    step from to =
+      signalA (curveS 2) $ animate $ morph rawLinear from to
+
+octogon :: Polygon
+octogon = mkPolygon $ V.fromList
+  [ realToFrac <$> V2 (cos phi) (sin phi)
+  | n <- [0..7]
+  , let phi = n*2*pi/8 + pi/8 :: Double
+  ]
+
+star :: Polygon
+star = pScale 0.5 $ mkPolygon $ V.fromList
+  [ V2 0 1, V2 (-2) 2, V2 (-1) 0
+  , V2 (-2) (-2), V2 0 (-1), V2 2 (-2)
+  , V2 1 0, V2 2 2 ]
+
+genColor :: Int -> Int -> PixelRGBA8
+genColor n m =
+    promotePixel $ parula (fromIntegral (n+offset) / fromIntegral (m+offset))
+  where
+    offset = 5
+
+polygonNumDots :: Polygon -> Double -> SVG
+polygonNumDots p t = mkGroup $ reverse
+    [ mkGroup
+      [ colored n $ withStrokeWidth (defaultStrokeWidth*0.5) $ withStrokeColor "black" $
+        translate x y $ pathify $ mkCircle circR
+      , withFillColor "black" $
+        translate x y $ ppNum n ]
+    | n <- [0..pSize p-1]
+    , let a = realToFrac <$> pAccess p n
+          b = realToFrac <$> pAccess p (pNext p n)
+          V2 x y = lerp t b a ]
+  where
+    circR = 0.1
+    colored n =
+      let c = genColor n (pSize p-1)
+      in withFillColorPixel c
+    ppNum n = scaleToHeight (circR*1.5) $ center $ latex $ T.pack $ "\\texttt{" ++ show n ++ "}"
+
+polygonShape :: Polygon -> SVG
+polygonShape p = mkLinePathClosed
+  [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ]

examples/morphology_point_trajectory.hs

@@ -0,0 +1,320 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-15.04 runghc --package reanimate
+module Main where
+
+import           Codec.Picture.Types
+import           Control.Lens
+import           Control.Monad
+import           Data.List
+import           Data.Maybe
+import qualified Data.Text                     as T
+import           Data.Tuple
+import qualified Data.Vector                   as V
+import           Linear.V2
+import           Linear.Vector
+import qualified Numeric.LinearAlgebra         as Matrix
+import           Numeric.LinearAlgebra.HMatrix (Matrix, linearSolve, toLists,
+                                                (><))
+import           Reanimate
+import           Reanimate.Math.Common
+import           Reanimate.Math.Polygon
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+type Points = V.Vector (V2 Double)
+type Edges = [(Int, Int, Int)]
+data Mesh = Mesh { meshPoints :: Points, meshEdges :: Edges }
+data MeshPair = MeshPair Points Points Edges
+-- The points in a RelMesh are:
+--   relMeshStatic ++ x where Ax = B
+data RelMesh = RelMesh
+  { relMeshStatic :: Points
+  , relMeshEdges  :: Edges
+  , relMeshA      :: Matrix Double
+  , relMeshB      :: Matrix Double
+  }
+data RelMeshPair = RelMeshPair Points Edges (Matrix Double) (Matrix Double) (Matrix Double) (Matrix Double)
+-- Linear interpolation on RelMesh gives smooth morph.
+-- solveMesh :: RelMesh -> Mesh
+-- mkRelative :: Mesh -> RelMesh
+-- mkRelativePair :: MeshPair -> RelMeshPair
+-- triangulate :: Polygon -> Polygon -> MeshPair ?
+-- embed :: MeshPair -> MeshPair
+-- compatible :: Mesh -> Mesh -> Maybe MeshPair
+-- linearInterpolate :: MeshPair -> Double -> Mesh
+-- convexInterpolate :: RelMeshPair -> Double -> RelMesh
+
+meshToPolygon :: Mesh -> Polygon
+meshToPolygon mesh = pScale 2 $ mkPolygon $ V.fromList
+    [ realToFrac <$> (meshPoints mesh V.! (n-1))
+    | n <- polygonNodes ]
+  where
+    polygonNodes :: [Int]
+    polygonNodes = [5,8,9,7,4,6]
+
+main :: IO ()
+main = reanimate morphAnimation
+
+genTrails :: (Double -> Mesh) -> SVG
+genTrails mkMesh =
+    withFillOpacity 0 $
+    withStrokeWidth (defaultStrokeWidth*0.5) $
+    withStrokeColor "black" $
+    withStrokeDashArray [0.1,0.1] $
+    mkGroup $ map mkTrail $ transpose
+      [ V.toList $ V.map (fmap realToFrac) $ polygonPoints $ meshToPolygon mesh
+      | n <- [0..steps]
+      , let mesh = mkMesh (fromIntegral n / fromIntegral steps)
+      ]
+  where
+    steps = 100 :: Int
+    mkTrail lst =mkLinePath [ (x,y) | V2 x y <- lst ]
+
+morphAnimation :: Animation
+morphAnimation = playThenReverseA $ pauseAround 1 1 $ addStatic (mkBackgroundPixel bgColor) $
+  signalA (curveS 2) $ mkAnimation 5 $ \t -> lowerTransformations $ scale 3 $ pathify $
+  mkGroup
+  [ translate (-1.5) 0 $ withFillColor "lightgreen" $ mkGroup
+    [ withStrokeWidth defaultStrokeWidth $
+      withStrokeColor "black" $
+      polygonShape $ meshToPolygon $ linearInterpolate meshPair t
+    , linearTrails
+    , polygonNumDots (meshToPolygon $ linearInterpolate meshPair t) 0
+    ]
+  , translate 1 0 $ withFillColor "cyan" $ mkGroup
+    [ withStrokeWidth defaultStrokeWidth $
+      withStrokeColor "black" $
+      polygonShape $ meshToPolygon $ solveMesh $ convexInterpolate relPair t
+    , curveTrails
+    , polygonNumDots (meshToPolygon $ solveMesh $ convexInterpolate relPair t) 0
+    ]
+  ]
+  where
+    linearTrails = genTrails (linearInterpolate meshPair)
+    curveTrails = genTrails (solveMesh . convexInterpolate relPair)
+    relPair = mkRelativePair meshPair
+    meshPair = fromJust $ compatible example1 example2
+
+mkLineP :: P -> P -> SVG
+mkLineP (V2 x1 y1) (V2 x2 y2) = mkLine (x1,y1) (x2,y2)
+
+-- FIXME: Check that the triangles are all anticlockwise.
+-- FIXME: Check that the edges connect all the points.
+-- FIXME: Check that the edgse leave no gaps.
+compatible :: Mesh -> Mesh -> Maybe MeshPair
+compatible a b =
+  if meshEdges a == meshEdges b && V.length (meshPoints a) == V.length (meshPoints b)
+    then Just $ MeshPair (meshPoints a) (meshPoints b) (meshEdges a)
+    else Nothing
+
+linearInterpolate :: MeshPair -> Double -> Mesh
+linearInterpolate (MeshPair aP bP edges) t = Mesh
+    { meshPoints = V.zipWith (lerp (1-t)) aP bP
+    , meshEdges = edges }
+
+example1 :: Mesh
+example1 = Mesh points edges
+  where
+    points = V.fromList
+      [ V2 1 0
+      , V2 (-1/2) (sqrt 3 / 2)
+      , V2 (-1/2) (-sqrt 3 / 2)
+      , 3 * points V.! 0 ^/ 4
+      , 3 * points V.! 1 ^/ 4
+      , 3 * points V.! 2 ^/ 4
+      , points V.! 0 ^/ 2
+      , points V.! 1 ^/ 2
+      , points V.! 2 ^/ 2
+      ]
+    edges =
+      [ (1,5,4), (1,2,5), (2,6,5), (2,3,6), (3,4,6), (3,1,4)
+      , (4,8,7), (4,5,8), (5,9,8), (5,6,9), (6,7,9), (6,4,7), (7,8,9)]
+
+example2 :: Mesh
+example2 = Mesh points edges
+  where
+    points = V.fromList
+      [ V2 1 0
+      , V2 (-1/2) (sqrt 3 / 2)
+      , V2 (-1/2) (-sqrt 3 / 2)
+      , 3 * points V.! 2 ^/ 4
+      , 3 * points V.! 0 ^/ 4
+      , 3 * points V.! 1 ^/ 4
+      , points V.! 1  ^/ 2
+      , points V.! 2 ^/ 2
+      , points V.! 0 ^/ 2
+      ]
+    edges = meshEdges example1
+
+-- T = (U, G)
+-- G = [Polygon]
+-- U = nub $ concat G
+
+findStarNeighbours :: Eq a => [(a,a,a)] -> a -> [(a, a)]
+findStarNeighbours allTrig self =
+  [ (b,c)
+  | (a,b,c) <- allTrig
+  , self == a
+  ] ++
+  [ (c,a)
+  | (a,b,c) <- allTrig
+  , self == b
+  ] ++
+  [ (a,b)
+  | (a,b,c) <- allTrig
+  , self == c
+  ]
+
+isInterior :: Eq a => [(a, a)] -> Bool
+isInterior = isJust . getExteriorPoly
+
+getExteriorPoly :: Eq a => [(a, a)] -> Maybe [a]
+getExteriorPoly [] = Nothing
+getExteriorPoly ((a,b):rest) = worker [a] a b rest
+  where
+    worker acc start this [] = do
+      guard (start == this)
+      return (reverse acc)
+    worker acc start this xs =
+      case lookup this xs of
+        Just next -> worker (this:acc) start next (delete (this,next) xs)
+        Nothing   ->
+          case lookup this (map swap xs) of
+            Just next -> worker (this:acc) start next (delete (next, this) xs)
+            Nothing   -> Nothing
+
+convexInterpolate :: RelMeshPair -> Double -> RelMesh
+convexInterpolate (RelMeshPair static edges leftM leftB rightM rightB) t =
+  RelMesh
+  { relMeshStatic = static
+  , relMeshEdges  = edges
+  , relMeshA      = Matrix.scale (1-t) leftM +
+                    Matrix.scale t rightM
+  , relMeshB      = Matrix.scale (1-t) leftB +
+                    Matrix.scale t rightB
+  }
+
+solveMesh :: RelMesh -> Mesh
+solveMesh (RelMesh static edges m b) =
+  case linearSolve m b of
+    Nothing -> error "Failed to solve mesh"
+    Just ret ->
+      Mesh (static <> V.fromList (worker (toLists ret))) edges
+  where
+    worker []             = []
+    worker ([x]:[y]:rest) = V2 x y : worker rest
+    worker _              = error "invalid result"
+
+mkRelative :: Mesh -> RelMesh
+mkRelative (Mesh points edges) = RelMesh (V.fromList exteriorPoints) edges mM bM
+  where
+    mM = (s><s) (concat m)
+    bM = (s><1) b
+    (s,exterior, (m, b)) = toParameters points edges
+    exteriorPoints =
+      [ points V.! (i-1)
+      | i <- exterior
+      ]
+
+mkRelativePair :: MeshPair -> RelMeshPair
+mkRelativePair (MeshPair p1 p2 edges) =
+  let RelMesh static _ leftM leftB = mkRelative (Mesh p1 edges)
+      RelMesh _ _ rightM rightB = mkRelative (Mesh p2 edges)
+  in RelMeshPair static edges leftM leftB rightM rightB
+
+toParameters :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> (Int, [Int], ([[b]], [b]))
+toParameters points groups = (length interior*2,exterior,unzip $ concat
+  [ let lst = [(if i == j then -1 else t)
+              | j <- interior
+              , let t = fromMaybe 0 $ lookup (i,j) lam_ij_cache
+              ]
+        pos = negate $ sum
+           [ pj ^* t
+           | j <- exterior
+           , let t = fromMaybe 0 $ lookup (i,j) lam_ij_cache
+                 pj = points V.! (j-1)
+           ]
+    in [ (dupX lst, pos ^. _x)
+       , (dupY lst, pos ^. _y)]
+  | i <- interior ])
+  where
+    lam_ij_cache = lam_ij points groups
+    dupX []     = []
+    dupX (x:xs) = x:0:dupX xs
+    dupY []     = []
+    dupY (x:xs) = 0:x:dupY xs
+    (interior, exterior) =
+      partition (isInterior . findStarNeighbours groups) [1 .. length points]
+
+lam_ij :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> [((Int, Int), b)]
+lam_ij points groups =
+  [ ((i, j), t)
+  | i <- [1..V.length points]
+  , (j, t) <- lam_j points groups i
+  ]
+
+lam_j :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> Int -> [(Int, b)]
+lam_j points groups p =
+  [ (nP, sum [ t | (j,_k,t) <- mu, j == nP ] / fromIntegral (length nPoints))
+  | let n = findStarNeighbours groups p
+        nPoints = fromMaybe [] $ getExteriorPoly n
+        mu = calcMu points groups p
+  , nP <- nPoints ]
+
+calcMu :: (Ord c, Fractional c) => V.Vector (V2 c) -> [(Int, Int, Int)] -> Int -> [(Int, Int, c)]
+calcMu points groups p = concat
+    [ [ (nP, nP, t1)
+      , (a, nP, t2)
+      , (b, nP, t3) ]
+      -- (nP, a, b)
+    | {-p <- [1..length points]-}
+      let selfVert = points V.! (p-1)
+          n = findStarNeighbours groups p
+          nPoints :: [Int]
+          nPoints = fromMaybe [] $ getExteriorPoly n
+    , nP <- nPoints
+    , let vert = points V.! (nP-1)
+    , let line = (vert, selfVert)
+    , let (a,b,aP,bP) = head $
+            [ (_a,_b,_aP,_bP)
+            | (_a,_b) <- n
+            , let _aP = points V.! (_a-1)
+                  _bP = points V.! (_b-1)
+                  segment = (points V.! (_a-1), points V.! (_b-1))
+            , case rayIntersect line segment of
+                Nothing -> False
+                Just u  -> isBetween u segment
+            , _a /= nP
+            , _b /= nP ]
+    -- , b == (nPoints ++ nPoints) !! i
+    , let (t1,t2,t3) = barycentricCoords vert aP bP selfVert
+    ]
+
+genColor :: Int -> Int -> PixelRGBA8
+genColor n m =
+    promotePixel $ parula (fromIntegral (n+offset) / fromIntegral (m+offset))
+  where
+    offset = 5
+
+polygonNumDots :: Polygon -> Double -> SVG
+polygonNumDots p t = mkGroup $ reverse
+    [ mkGroup
+      [ colored n $ withStrokeWidth (defaultStrokeWidth*0.5) $ withStrokeColor "black" $
+        translate x y $ mkCircle circR
+      , withFillColor "black" $
+        translate x y $ ppNum n ]
+    | n <- [0..pSize p-1]
+    , let a = realToFrac <$> pAccess p n
+          b = realToFrac <$> pAccess p (pNext p n)
+          V2 x y = lerp t b a ]
+  where
+    circR = 0.1
+    colored n =
+      let c = genColor n (pSize p-1)
+      in withFillColorPixel c
+    ppNum n = scaleToHeight (circR*1.5) $ center $ latex $ T.pack $ "\\texttt{" ++ show n ++ "}"
+
+polygonShape :: Polygon -> SVG
+polygonShape p = mkLinePathClosed
+  [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ]

examples/morphology_rotational.hs

@@ -0,0 +1,63 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Codec.Picture.Types
+import           Control.Monad
+import           Graphics.SvgTree (LineJoin(..))
+import           Reanimate
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+import           Reanimate.Morph.Rotational
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth defaultStrokeWidth) $
+  mapA (withStrokeColor "black") $
+  mapA (withStrokeLineJoin JoinRound) $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (-3) 4 $
+        center $ latex "linear"
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (3) 4 $
+        center $ latex "rotational"
+      forM_ pairs $ uncurry showPair
+  where
+    showPair from to =
+      waitOn $ do
+        fork $ play $ mkAnimation 4 (morph linear from to)
+          # mapA (translate (-3) (-0.5))
+          # signalA (curveS 4)
+        fork $ play $ mkAnimation 4 (morph myMorph from to)
+          # mapA (translate (3) (-0.5))
+          # signalA (curveS 4)
+    myMorph = linear{morphTrajectory = rotationalTrajectory origin }
+    origin = (0.5, 0.5)
+    pairs = zip stages (tail stages ++ [head stages])
+    stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize
+      [ latex "X"
+      , latex "$\\aleph$"
+      , latex "Y"
+      , latex "$\\infty$"
+      , latex "I"
+      , latex "$\\pi$"
+      , latex "1"
+      , latex "S"
+      , mkRect 0.5 0.5
+      ]
+
+colorize :: [SVG] -> [SVG]
+colorize lst =
+  [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt
+  | elt <- lst
+  | n <- [0..]
+  ]

examples/morphology_rotational_intro.hs

@@ -0,0 +1,125 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE ApplicativeDo     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp  #-}
+module Main(main) where
+
+import           Codec.Picture
+import           Data.List                  (transpose)
+import qualified Data.Vector                as V
+import           Graphics.SvgTree           (LineJoin (..))
+import           Linear.V2
+import           Linear.Vector
+import           Reanimate
+import           Reanimate.Math.Polygon
+import           Reanimate.Morph.Common
+import           Reanimate.Morph.Linear
+import           Reanimate.Morph.Rotational
+
+bgColor :: PixelRGBA8
+bgColor = PixelRGBA8 252 252 252 0xFF
+
+spike1 :: Polygon
+spike1 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList
+  [ V2 0 0, V2 2 0
+  , V2 2 1 ]
+
+spike2 :: Polygon
+spike2 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList
+  [ V2 0 0, V2 2 0
+  , V2 0 1 ]
+
+polygonShape :: Polygon -> SVG
+polygonShape p = mkLinePathClosed
+  [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ]
+
+
+main :: IO ()
+main = reanimate $
+  addStatic (mkBackgroundPixel bgColor) $
+  mapA (withStrokeWidth defaultStrokeWidth) $
+  mapA (withStrokeColor "black") $
+  mapA (withStrokeLineJoin JoinRound) $
+  mapA (withFillOpacity 1) $
+    sceneAnimation $ do
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (-4) 4 $
+        center $ latex "linear"
+      _ <- newSpriteSVG $
+        withStrokeWidth 0 $ translate (4) 4 $
+        center $ latex "rotational"
+      originVar <- newVar (0.5, 0.5)
+
+      showTrails originVar
+
+      let pushLeft newOrigin = do
+            fork $ tweenVar originVar 0.5 $ \(x,y) t ->
+                let t' = curveS 2 t in
+                (fromToS x (fst newOrigin) t', fromToS y (snd newOrigin) t')
+            showPair originVar spike1 spike2
+          pushRight newOrigin = do
+                fork $ tweenVar originVar 0.5 $ \(x,y) t ->
+                    let t' = curveS 2 t in
+                    (fromToS x (fst newOrigin) t', fromToS y (snd newOrigin) t')
+                showPair originVar spike2 spike1
+
+      pushLeft (1, 0.5)
+      pushRight (0.1, 0.95)
+      pushLeft (0.5, 1)
+      pushRight (0.5, 2)
+      pushLeft (-0.3, -0.2)
+      pushRight (0.5, 0.5)
+  where
+    showTrails originVar = do
+      _ <- newSpriteSVG $
+            translate (-4) (-0.5) $
+            genTrails (map linearTrajectory [(spike1, spike2)])
+      _ <- newSprite $ do
+            origin <- unVar originVar
+            pure $
+              translate (4) (-0.5) $
+              genTrails (map (rotationalTrajectory origin) [(spike1, spike2)])
+      return ()
+    showPair originVar from to =
+      waitOn $ do
+        fork $ play $ mkAnimation 2 (morph linear (polygonShape from) (polygonShape to))
+          # mapA (translate (-4) (-0.5))
+          # mapA (withFillColor "lightgreen")
+          # signalA (curveS 4)
+        s <- fork $ newSprite $ do
+          origin <- unVar originVar
+          t <- spriteT
+          d <- spriteDuration
+          pure $
+            let localTime = curveS 4 (t/d)
+                myMorph = linear{morphTrajectory = rotationalTrajectory origin }
+                originSrc = polygonOrigin from origin
+                originDst = polygonOrigin to origin
+                V2 originX originY = lerp localTime originDst originSrc
+            in
+            translate (4) (-0.5) $ mkGroup
+            [ withFillColor "cyan" $
+              morph myMorph (polygonShape from) (polygonShape to) localTime
+            , withFillColor "red" $ translate originX originY $
+              mkCircle 0.1
+            ]
+        wait 2
+        destroySprite s
+
+genTrails :: [(Double -> Polygon)] -> SVG
+genTrails plotters =
+    withFillOpacity 0 $
+    withStrokeWidth (defaultStrokeWidth*0.5) $
+    withStrokeColor "black" $
+    withStrokeDashArray [0.1,0.05] $
+    mkGroup $ map mkTrail $ transpose $ concat
+      [
+        [ V.toList $ V.map (fmap realToFrac) (polygonPoints poly)
+        | n <- [0..steps]
+        , let poly = plotter (fromIntegral n / fromIntegral steps)
+        ]
+      | plotter <- plotters ]
+  where
+    steps = 100 :: Int
+    mkTrail lst = mkLinePath [ (x,y) | V2 x y <- lst ]

examples/signals.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main (main) where
 
-import           Data.Monoid         ((<>))
 import           Data.Text           (Text, pack)
 import           Graphics.SvgTree    hiding (Text)
 import           Numeric