First stab at reanimate.

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for reani
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

src/Reanimate/Arrow.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings, Arrows #-}
+module Reanimate.Arrow where
+
+import Control.Arrow
+import qualified Control.Category as C
+import Data.Text (Text, pack)
+import Data.Monoid ((<>))
+import Data.Fixed
+import Lucid.Svg
+import Lucid ()
+
+data Animation a b = Animation Double (a -> Svg b)
+
+instance C.Category Animation where
+  id = Animation 0 pure
+  Animation a fn1 . Animation b fn2 = Animation (max a b) (\a -> fn2 a >>= fn1)
+
+instance Arrow Animation where
+  -- arr :: (b -> c) -> Animation b c
+  arr fn = Animation 0 (pure . fn)
+  -- first :: Animation b c -> Animation (b, d) (c, d)
+  first (Animation duration fn) =
+    Animation duration (\(b,d) -> do c <- fn b; pure (c, d))
+
+type Ani a = Animation Double a
+
+duration :: Double -> Animation a ()
+duration duration = Animation duration (\_ -> pure ())
+
+getDuration :: Animation a b -> Double
+getDuration (Animation d _) = d
+
+frameAt :: Double -> Ani () -> Svg ()
+frameAt n (Animation d fn) = svg $ fn (n `mod'` d)
+  where
+    svg :: Svg () -> Svg ()
+    svg content = do
+      doctype_
+      with (svg11_ content) [width_ "640" , height_ "360", viewBox_ "0 0 320 180"]
+
+emit :: Animation (Svg ()) ()
+emit = Animation 0 id

src/Reanimate/Combinators.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings, Arrows #-}
+module Reanimate.Combinators where
+
+import Control.Arrow
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+import Data.Monoid ((<>))
+import Data.Fixed
+import Lucid.Svg
+
+import Reanimate.Arrow
+
+fadeIn :: Double -> Ani a -> Ani a
+fadeIn window (Animation d fn) =
+    Animation d $ \t ->
+      let s = (t/window) in
+      if s < 1
+        then g_ [opacity_ (pack $ show s)] (fn t)
+        else fn t
+
+fadeOut :: Double -> Ani a -> Ani a
+fadeOut window (Animation d fn) =
+    Animation d $ \t ->
+      let s = (d-t)/window in
+      if s < 1
+        then g_ [opacity_ (pack $ show s)] (fn t)
+        else fn t
+
+fade :: Double -> Ani a -> Ani a
+fade window = fadeIn window . fadeOut window
+
+annotate :: (Svg a -> Svg a) -> Ani a -> Ani a
+annotate fn1 (Animation d fn2) =
+  Animation d (fn1 . fn2)
+
+progress :: Ani () -> Ani ()
+progress ani = proc t -> do
+  ani -< t
+  let txt = show (round ((t / getDuration ani) * 100)) ++ "%"
+  emit -< text_   [x_ "10", y_ "20", font_size_ "20"
+                  , text_anchor_ "bottom"
+                  , fill_ "white"] (toHtml txt)
+
+
+before :: Ani () -> Ani () -> Ani ()
+before (Animation d1 fn1) (Animation d2 fn2) =
+  Animation (d1+d2) (\t -> if t < d1 then fn1 t else fn2 (t-d1))
+
+follow :: [Ani ()] -> Ani ()
+follow = foldr before (arr $ pure ())
+
+sim :: [Ani ()] -> Ani ()
+sim = foldr par (arr $ pure ())
+
+par :: Ani () -> Ani () -> Ani ()
+par a b = proc t -> do
+  a -< t
+  b -< t
+  returnA -< ()
+
+type Path = [(Double, Double)]
+
+approxFnData :: Int -> (Double -> (Double, Double)) -> Path
+approxFnData steps fn =
+  fn 0 : [ fn (fromIntegral n/fromIntegral steps) | n <- [0..steps] ]
+
+renderPath :: Path -> Svg ()
+renderPath ((startX, startY):rest) =
+    path_ [stroke_ "white", fill_ "translucent", d_ path]
+  where
+    path = T.unlines $
+      ("M " <> pack (show startX) <> " " <> pack (show startY)):
+      [ "L " <> pack (show x) <> " " <> pack (show y) | (x, y) <- rest]
+
+morphPath :: Path -> Path -> Double -> Path
+morphPath src dst idx = zipWith worker src dst
+  where
+    worker (x1, y1) (x2, y2) =
+      (x1 + (x2-x1)*idx
+      ,y1 + (y2-y1)*idx)
+
+approxFn :: Int -> (Double -> (Double, Double)) -> Ani ()
+approxFn steps fn = proc t -> do
+    emit -< renderPath $ approxFnData steps fn

src/Reanimate/Examples.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE OverloadedStrings, Arrows #-}
+module Reanimate.Examples where
+
+import Lucid.Svg
+import Data.Text (Text, pack)
+import Data.Monoid ((<>))
+import Control.Arrow
+
+import Reanimate.Arrow
+import Reanimate.Combinators
+
+import Debug.Trace
+
+test1 :: Ani ()
+test1 =
+  fade 1 $
+  proc t -> do
+    duration 10 -< t
+    emit -< circle_ [cx_ "160", cy_ "90", r_ "50", fill_ "blue"]
+
+test2 :: Ani ()
+test2 = proc t -> do
+  duration 5 -< t
+  emit -< rect_ [width_ "100%", height_ "100%", fill_ "red", r_ (pack $ show t)]
+
+sinewave :: Ani ()
+sinewave = proc t -> do
+  duration 5 -< ()
+  emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
+  let clipWidth = pack $ show $ t/getDuration sinewave * 260
+  emit -< defs_ $ clipPath_ [id_ "clip"] $ rect_ [x_ "0", y_ "-90", width_ clipWidth, height_ "100%"]
+  annotate (g_ [transform_ $ translate 30 90]) $
+    annotate (g_ [clip_path_ "url(#clip)"]) $
+      approxFn 1000 (\idx ->
+        let xPos = idx*260
+            xValue = idx*getDuration sinewave
+            yValue = sin (xValue*pi*2*freq) * 50
+        in (xPos, yValue)) -< t
+  emit -< line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"]
+  emit -< line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"]
+
+  let circX = pack $ show $ 30 + t/getDuration sinewave * (290-30)
+      circY = pack $ show $ 90 + sin (t*pi*2*freq) * 50
+
+  emit -< circle_ [cx_ circX, cy_ circY, r_ "3", fill_ "red"]
+  returnA -< ()
+  where
+    freq = 1/2
+
+morph_wave :: Ani ()
+morph_wave = proc t -> do
+  duration 5 -< ()
+  emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
+
+  annotate (g_ [transform_ $ translate 30 50]) $
+    (proc t -> emit -< renderPath wave1) -< t
+  annotate (g_ [transform_ $ translate 30 130]) $
+    (proc t -> emit -< renderPath wave2) -< t
+  annotate (g_ [transform_ $ translate 30 90]) $
+    (proc t -> do
+      let idx = if t/myD*2 < 1 then t/myD*2
+                else (2 - t/myD*2)
+      emit -< renderPath $ morphPath wave1 wave2 idx) -< t
+  emit -< line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"]
+  emit -< line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"]
+
+  returnA -< ()
+  where
+    myD = getDuration morph_wave
+    freq = 1/2
+    wave1 = approxFnData 1000 (\idx ->
+                  let xPos = idx*260
+                      xValue = idx*myD
+                      yValue = sin (xValue*pi*2*freq) * 20
+                  in (xPos, yValue))
+    wave2 = approxFnData 1000 (\idx ->
+                  let xPos = idx*260
+                      xValue = idx*myD
+                      yValue = sin (xValue*pi*2*(freq*3)) * 20
+                  in (xPos, yValue))
+
+morph_wave_circle :: Ani ()
+morph_wave_circle = proc t -> do
+  duration 5 -< ()
+  emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
+
+  annotate (g_ [transform_ $ translate 30 90]) $
+    (proc t -> do
+      let idx = if t/myD*2 < 1 then t/myD*2
+                else (2 - t/myD*2)
+      emit -< renderPath $ morphPath wave1 circle idx) -< t
+  emit -< line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"]
+  emit -< line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"]
+
+  returnA -< ()
+  where
+    myD = getDuration morph_wave
+    freq = 1/2
+    wave1 = approxFnData 1000 (\idx ->
+                  let xPos = idx*260
+                      xValue = idx*myD
+                      yValue = sin (xValue*pi*2*freq) * 20
+                  in (xPos, yValue))
+    circle = approxFnData 1000 $ \idx ->
+      (cos (idx*pi*2+pi/2)*50 + 130, sin (idx*pi*2+pi/2)*50)
+
+superGreeting :: Ani ()
+superGreeting = bg `par` follow
+  [ liangGreetings
+  , proc t -> do
+    duration 3 -< ()
+    emit -< text_   [x_ "160", y_ "110", font_size_ "20"
+                    , text_anchor_ "middle"
+                    , fill_ "black"] "I can even nest animations"
+    annotate (g_ [transform_ $ rotateAround 180 160 90 <> " " <> translate 0 (0), opacity_ "0.5"]) $
+      liangGreetings -< t
+  ]
+  where
+    bg = proc t -> emit -< rect_ [width_ "100%", height_ "100%", fill_ "lightblue"]
+
+liangGreetings :: Ani ()
+liangGreetings = follow
+  [ proc t -> do
+    duration 3 -< ()
+    emit -< text_   [x_ "160", y_ "110", font_size_ "20"
+                    , text_anchor_ "middle"
+                    , fill_ "black"] "Hi Liang"
+  , proc t -> do
+    duration 3 -< ()
+    emit -< text_   [x_ "160", y_ "110", font_size_ "20"
+                    , text_anchor_ "middle"
+                    , fill_ "black"] "I'm learning animations"
+  , sim
+    [ proc t -> do
+      emit -< text_   [x_ "160", y_ "110", font_size_ "20"
+                      , text_anchor_ "middle"
+                      , fill_ "black"] "Look!"
+    , fade 1 $ proc t -> do
+      duration 5 -< ()
+      let radius = pack $ show $ 20 + sin (t*10) * 3
+      emit -< circle_ [cx_ "160", cy_ "150", r_ radius, fill_ "red"]
+    ]
+  ]

src/Reanimate/Render.hs

@@ -0,0 +1,45 @@
+module Reanimate.Render where
+
+import Lucid.Svg
+import Control.Monad
+import Control.Exception
+import System.FilePath
+import System.Directory
+import System.Process
+import Text.Printf
+import Reanimate.Arrow
+import Reanimate.Examples
+
+fps :: Int
+fps = 60
+
+nameTemplate :: String
+nameTemplate = "render-%05d.svg"
+
+render :: Ani () -> FilePath -> IO ()
+render ani target = do
+  putStrLn $ "Starting render of animation: " ++ show (round (getDuration ani)) ++ "s"
+  let frames :: Int
+      frames = round (getDuration ani * fromIntegral fps)
+  ffmpeg <- requireExecutable "ffmpeg"
+  tmp <- getTemporaryDirectory
+  forM_ [0..frames] $ \frame -> do
+    let s = fromIntegral frame / fromIntegral fps
+    let fileName = printf nameTemplate frame
+    renderToFile (tmp </> fileName) (frameAt s ani)
+  rawSystem ffmpeg ["-r", show fps, "-i", tmp </> "render-%05d.svg"
+                       , "-c:v", "libx264", "-vf", "fps="++show fps
+                       , "-pix_fmt", "yuv420p", target]
+     `finally`
+       forM_ [0..frames] (\frame -> do
+         let fileName = printf nameTemplate frame
+         removeFile (tmp </> fileName))
+  return ()
+
+
+requireExecutable :: String -> IO FilePath
+requireExecutable exec = do
+  mbPath <- findExecutable exec
+  case mbPath of
+    Nothing -> error $ "Couldn't find executable: " ++ exec
+    Just path -> return path

src/SvgViewer.hs

@@ -0,0 +1,74 @@
+import System.Environment (getArgs)
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Gdk.EventM
+import Graphics.Rendering.Cairo
+import Graphics.Rendering.Cairo.SVG
+
+import Control.Concurrent
+import Control.Monad
+import System.IO
+import System.Posix.IO
+import Data.IORef
+import Data.Time
+
+import Reanimate.Arrow
+import Reanimate.Examples
+
+animation = morph_wave_circle
+
+main :: IO ()
+main = do
+
+  frames <- newIORef (0::Int)
+  ref <- newIORef True
+  forkIO $ forever $ do
+    fps <- readIORef frames
+    writeIORef frames 0
+    -- putStrLn $ "FPS: " ++ show fps
+    threadDelay (10^6)
+    modifyIORef ref not
+
+  -- (file1:file2:_) <- getArgs
+  (width, height) <- svgGetSize <$> svgNewFromString (show $ frameAt 0 animation)
+  --
+  -- svg2 <- svgNewFromFile file2
+
+  t1 <- getCurrentTime
+
+  initGUI
+  dia <- dialogNew
+  dialogAddButton dia stockOk ResponseOk
+  contain <- dialogGetUpper dia
+  canvas <- drawingAreaNew
+  onSizeRequest canvas $ return (Requisition width height)
+  -- (readFd, writeFd) <- createPipe
+  -- readHandle <- fdToHandle readFd
+  -- writeHandle <- fdToHandle writeFd
+  canvas `on` exposeEvent $ do
+    liftIO $ modifyIORef frames succ
+    flag <- liftIO $ readIORef ref
+    svg <- liftIO $ do
+      t2 <- getCurrentTime
+      let time = realToFrac (diffUTCTime t2 t1)
+      svgNewFromString (show $ frameAt time animation)
+    updateCanvas canvas svg
+  flip idleAdd priorityDefaultIdle $ do
+    widgetQueueDraw canvas
+    return True
+  boxPackStartDefaults contain canvas
+  widgetShow canvas
+  dialogRun dia
+  return ()
+
+updateCanvas :: DrawingArea -> SVG -> EventM EExpose Bool
+updateCanvas canvas svg = do
+  win <- eventWindow
+  liftIO $ do
+   let (width, height) = svgGetSize svg
+   (width', height') <- widgetGetSize canvas
+   renderWithDrawable win $ do
+     scale (realToFrac width'  / realToFrac width)
+           (realToFrac height' / realToFrac height)
+     svgRender svg
+   return True

stack.yaml

@@ -0,0 +1,10 @@
+resolver: lts-10.10
+
+allow-newer: true
+
+extra-deps:
+- gio-0.13.5.0@sha256:1e02962f498f62ba68cff88e7f7379e2f8c192f311d867b22f4815518b2f9a86
+- gtk-0.15.0@sha256:a76d280dbeefbe08cf021c31bcd51c09cda97ebee7934debbfc14e1da4220b78
+- svgcairo-0.13.1.1@sha256:145b6acce7306e84652376efb3f00e9194ccd8787a62d3f93fb539c4a3382a2e
+- lucid-svg-0.7.0.0@sha256:2a2d0fe51329e8b89f723a8e86e6ab8d150d7b205591fffe4c09d8d11e022f98
+