diff --git a/examples/colormaps.hs b/examples/colormaps.hs index c0c0518..72d31ee 100755 --- a/examples/colormaps.hs +++ b/examples/colormaps.hs @@ -21,8 +21,13 @@ import Reanimate.Raster import Reanimate.Signal import Reanimate.Svg +-- Cycle the animation if we want to upload it to youtube. +youtube :: Animation -> Animation +-- youtube = repeatAnimation 6 +youtube = id + main :: IO () -main = reanimate $ repeatAnimation 6 $ pauseAtEnd 2 $ autoReverse $ pauseAtEnd 2 $ mkAnimation 5 $ do +main = reanimate $ youtube $ pauseAtEnd 2 $ autoReverse $ pauseAtEnd 2 $ mkAnimation 5 $ do s <- getSignal $ signalCurve 2 let scaleWidth = 50 nubWidth = 2 diff --git a/examples/counter.hs b/examples/counter.hs new file mode 100755 index 0000000..f02066f --- /dev/null +++ b/examples/counter.hs @@ -0,0 +1,21 @@ +#!/usr/bin/env stack +-- stack --resolver lts-13.14 runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Control.Lens +import Data.Text (pack, Text) +import Numeric + +import Graphics.SvgTree hiding (Text) +import Reanimate.Driver (reanimate) +import Reanimate.LaTeX +import Reanimate.Monad +import Reanimate.Svg +import Reanimate.Signal + +main :: IO () +main = reanimate $ mkAnimation 2 $ do + s <- getSignal $ signalFromTo 0 (2*60-1) signalLinear + emit $ mkCircle (Num 0, Num 0) (Num s) diff --git a/reanimate.cabal b/reanimate.cabal index 2e0f0a4..1f703ca 100644 --- a/reanimate.cabal +++ b/reanimate.cabal @@ -60,7 +60,7 @@ library Paths_reanimate build-depends: base >=4.10 && <4.13, time, text, filepath, process, directory, - containers, reanimate-svg >= 0.9.0.2, xml, bytestring, lens, linear, mtl, matrix, + containers, reanimate-svg >= 0.9.1.1, xml, bytestring, lens, linear, mtl, matrix, JuicyPixels, attoparsec, parallel, diagrams, diagrams-svg, diagrams-core, diagrams-lib, diagrams-contrib, svg-builder, matrices, cubicbezier, palette, websockets, @@ -83,3 +83,19 @@ executable reanimate-server Cache build-depends: base >=4.10 && <4.13, text, websockets, process, filepath, directory, containers, hashable, time + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + UnitTests + hs-source-dirs: test + build-depends: + base, + directory, + filepath, + bytestring, process, + reanimate, + QuickCheck >= 2.1.0, + tasty, tasty-golden, + ansi-wl-pprint diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs index 01f118b..bb402fe 100644 --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -20,7 +20,7 @@ import Paths_reanimate import Reanimate.Misc (runCmdLazy, runCmd_, withTempDir, withTempFile) import Reanimate.Monad (Animation) -import Reanimate.Render (render, renderSvgs) +import Reanimate.Render (render, renderSvgs, renderSnippets) import Web.Browser (openBrowser) opts = defaultConnectionOptions @@ -33,6 +33,7 @@ reanimate animation = do hSetBuffering stdin NoBuffering case args of ["once"] -> renderSvgs animation + ["snippets"] -> renderSnippets animation ["render", target] -> render animation target _ -> withTempDir $ \tmpDir -> do diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs index b11be26..e8d3aab 100644 --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -1,6 +1,7 @@ module Reanimate.Render ( render , renderSvgs + , renderSnippets ) where import Control.Monad (forM_) @@ -25,8 +26,6 @@ renderSvgs :: Animation -> IO () renderSvgs ani = do print frameCount lock <- newMVar () - -- let renderedFrames = map (T.concat . T.lines . T.pack . nthFrame) frames - -- mapM_ T.putStrLn (renderedFrames `using` parBuffer 16 rdeepseq) concurrentForM_ (frameOrder rate frameCount) $ \nth -> do let -- frame = frameAt (recip (fromIntegral rate-1) * fromIntegral nth) ani @@ -39,11 +38,22 @@ renderSvgs ani = do T.putStrLn $ T.concat . T.lines . T.pack $ svg hFlush stdout where - frames = [0..frameCount-1] rate = 60 - nthFrame nth = renderSvg Nothing Nothing $ frameAt (recip (fromIntegral rate) * fromIntegral nth) ani frameCount = round (duration ani * fromIntegral rate) :: Int +-- XXX: Merge with 'renderSvgs' +renderSnippets :: Animation -> IO () +renderSnippets ani = do + print frameCount + forM_ [0..frameCount-1] $ \nth -> do + let now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth + frame = frameAt (if frameCount<=1 then 0 else now) ani + svg = renderSvg Nothing Nothing frame + putStr (show nth) + T.putStrLn $ T.concat . T.lines . T.pack $ svg + where + frameCount = 50 + frameOrder :: Int -> Int -> [Int] frameOrder fps nFrames = worker [] fps where diff --git a/stack.yaml b/stack.yaml index 5c42973..1ff3562 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,7 +6,7 @@ packages: - . extra-deps: -- reanimate-svg-0.9.0.2 +- reanimate-svg-0.9.1.1 - palette-0.3.0.2 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca - diagrams-contrib-1.4.3@sha256:bcfa6c85f8c33b8c48c3a61b7216afdebd51cd793c50da3a2dd358827d25fc76 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..afa5997 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,10 @@ +module Main (main) where + +import Test.Tasty + +import UnitTests + +main :: IO () +main = do + ts <- unitTestFolder "examples/" + defaultMain ts diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 index 0000000..69b1b55 --- /dev/null +++ b/test/UnitTests.hs @@ -0,0 +1,64 @@ +module UnitTests (unitTestFolder) where + +import Control.Monad (forM) +import qualified Data.ByteString.Lazy as LBS +import Data.Maybe (catMaybes) +import System.Directory +import System.FilePath +import System.IO +import System.Process +import Test.Tasty +import Test.Tasty.Golden +import Reanimate.Misc (withTempDir, + withTempFile) + +unitTestFolder :: FilePath -> IO TestTree +unitTestFolder path = do + files <- getDirectoryContents path + return $ testGroup "examples" + [ goldenVsStringDiff file (\ref new -> ["diff", ref, new]) fullPath (genGolden hsPath) + | file <- files + , let fullPath = path file + hsPath = replaceExtension fullPath "hs" + , takeExtension fullPath == ".golden" + ] + +genGolden :: FilePath -> IO LBS.ByteString +genGolden path = withTempDir $ \tmpDir -> withTempFile ".exe" $ \tmpExecutable -> do + let ghcOpts = ["-rtsopts", "--make", "-O2"] ++ + ["-odir", tmpDir, "-hidir", tmpDir, "-o", tmpExecutable] + runOpts = ["+RTS", "-M1G"] + -- XXX: Check for errors. + _ <- readProcessWithExitCode "stack" (["ghc","--", path] ++ ghcOpts) "" + -- ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [self, "-o", tmpExecutable] + -- ["-rtsopts", "--make", "-threaded", "-O2"] ++ + -- ["-odir", tmpDir, "-hidir", tmpDir] + (inh, outh, errh, pid) <- runInteractiveProcess tmpExecutable (["snippets"] ++ runOpts) + Nothing Nothing + hClose inh + hClose errh + LBS.hGetContents outh + +-------------------------------------------------------------------------------- +-- Helpers + +-- findAnExecutable :: [String] -> IO (Maybe FilePath) +-- findAnExecutable [] = return Nothing +-- findAnExecutable (x:xs) = do +-- mbExec <- findExecutable x +-- case mbExec of +-- Just exec -> return (Just exec) +-- Nothing -> findAnExecutable xs +-- +-- readFileOptional :: FilePath -> IO String +-- readFileOptional path = do +-- hasFile <- doesFileExist path +-- if hasFile then readFile path else return "" +-- +-- assertExitCode :: String -> ExitCode -> Assertion +-- assertExitCode _ ExitSuccess = return () +-- assertExitCode msg (ExitFailure code) = assertFailure (msg ++ ", code: " ++ show code) +-- +-- assertMaybe :: String -> Maybe a -> IO a +-- assertMaybe _ (Just a) = return a +-- assertMaybe msg Nothing = assertFailure msg