diff --git a/data/github-icon.svg b/data/github-icon.svg new file mode 100644 --- /dev/null +++ b/data/github-icon.svg @@ -0,0 +1,6 @@ + + + + + + diff --git a/data/haskell.svg b/data/haskell.svg new file mode 100644 --- /dev/null +++ b/data/haskell.svg @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/data/small_earth.jpg b/data/small_earth.jpg new file mode 100644 Binary files /dev/null and b/data/small_earth.jpg differ diff --git a/data/svg-logo.svg b/data/svg-logo.svg new file mode 100644 --- /dev/null +++ b/data/svg-logo.svg @@ -0,0 +1,64 @@ + + + SVG Logo + Designed for the SVG Logo Contest in 2006 by Harvey Rayner, and adopted by W3C in 2009. It is available under the Creative Commons license for those who have an SVG product or who are using SVG on their site. + + + + + SVG Logo + 14-08-2009 + + W3C + Harvey Rayner, designer + + See document description + + image/svg+xml + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/docs/gifs/doc_addStatic.gif b/docs/gifs/doc_addStatic.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_addStatic.gif differ diff --git a/docs/gifs/doc_applyVar.gif b/docs/gifs/doc_applyVar.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_applyVar.gif differ diff --git a/docs/gifs/doc_bonneP.gif b/docs/gifs/doc_bonneP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_bonneP.gif differ diff --git a/docs/gifs/doc_bottomleyP.gif b/docs/gifs/doc_bottomleyP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_bottomleyP.gif differ diff --git a/docs/gifs/doc_chainT.gif b/docs/gifs/doc_chainT.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_chainT.gif differ diff --git a/docs/gifs/doc_circlePlot.gif b/docs/gifs/doc_circlePlot.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_circlePlot.gif differ diff --git a/docs/gifs/doc_collignonP.gif b/docs/gifs/doc_collignonP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_collignonP.gif differ diff --git a/docs/gifs/doc_destroySprite.gif b/docs/gifs/doc_destroySprite.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_destroySprite.gif differ diff --git a/docs/gifs/doc_eckert1P.gif b/docs/gifs/doc_eckert1P.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_eckert1P.gif differ diff --git a/docs/gifs/doc_eckert3P.gif b/docs/gifs/doc_eckert3P.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_eckert3P.gif differ diff --git a/docs/gifs/doc_eckert5P.gif b/docs/gifs/doc_eckert5P.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_eckert5P.gif differ diff --git a/docs/gifs/doc_equirectangularP.gif b/docs/gifs/doc_equirectangularP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_equirectangularP.gif differ diff --git a/docs/gifs/doc_fadeT.gif b/docs/gifs/doc_fadeT.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_fadeT.gif differ diff --git a/docs/gifs/doc_faheyP.gif b/docs/gifs/doc_faheyP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_faheyP.gif differ diff --git a/docs/gifs/doc_fork.gif b/docs/gifs/doc_fork.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_fork.gif differ diff --git a/docs/gifs/doc_githubIcon.gif b/docs/gifs/doc_githubIcon.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_githubIcon.gif differ diff --git a/docs/gifs/doc_hammerP.gif b/docs/gifs/doc_hammerP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_hammerP.gif differ diff --git a/docs/gifs/doc_haskellLogo.gif b/docs/gifs/doc_haskellLogo.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_haskellLogo.gif differ diff --git a/docs/gifs/doc_hsv.gif b/docs/gifs/doc_hsv.gif Binary files a/docs/gifs/doc_hsv.gif and b/docs/gifs/doc_hsv.gif differ diff --git a/docs/gifs/doc_hsvComponents.gif b/docs/gifs/doc_hsvComponents.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_hsvComponents.gif differ diff --git a/docs/gifs/doc_labComponents.gif b/docs/gifs/doc_labComponents.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_labComponents.gif differ diff --git a/docs/gifs/doc_lambertP.gif b/docs/gifs/doc_lambertP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_lambertP.gif differ diff --git a/docs/gifs/doc_lchComponents.gif b/docs/gifs/doc_lchComponents.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_lchComponents.gif differ diff --git a/docs/gifs/doc_mercatorP.gif b/docs/gifs/doc_mercatorP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_mercatorP.gif differ diff --git a/docs/gifs/doc_mkBackground.gif b/docs/gifs/doc_mkBackground.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_mkBackground.gif differ diff --git a/docs/gifs/doc_mkText.gif b/docs/gifs/doc_mkText.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_mkText.gif differ diff --git a/docs/gifs/doc_mollweideP.gif b/docs/gifs/doc_mollweideP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_mollweideP.gif differ diff --git a/docs/gifs/doc_newSprite.gif b/docs/gifs/doc_newSprite.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_newSprite.gif differ diff --git a/docs/gifs/doc_newSpriteA'.gif b/docs/gifs/doc_newSpriteA'.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_newSpriteA'.gif differ diff --git a/docs/gifs/doc_newSpriteA.gif b/docs/gifs/doc_newSpriteA.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_newSpriteA.gif differ diff --git a/docs/gifs/doc_newSpriteSVG.gif b/docs/gifs/doc_newSpriteSVG.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_newSpriteSVG.gif differ diff --git a/docs/gifs/doc_orthoP.gif b/docs/gifs/doc_orthoP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_orthoP.gif differ diff --git a/docs/gifs/doc_overlapT.gif b/docs/gifs/doc_overlapT.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_overlapT.gif differ diff --git a/docs/gifs/doc_pathify.gif b/docs/gifs/doc_pathify.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_pathify.gif differ diff --git a/docs/gifs/doc_play.gif b/docs/gifs/doc_play.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_play.gif differ diff --git a/docs/gifs/doc_queryNow.gif b/docs/gifs/doc_queryNow.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_queryNow.gif differ diff --git a/docs/gifs/doc_rgbComponents.gif b/docs/gifs/doc_rgbComponents.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_rgbComponents.gif differ diff --git a/docs/gifs/doc_signalT.gif b/docs/gifs/doc_signalT.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_signalT.gif differ diff --git a/docs/gifs/doc_simpleVar.gif b/docs/gifs/doc_simpleVar.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_simpleVar.gif differ diff --git a/docs/gifs/doc_sinusoidalP.gif b/docs/gifs/doc_sinusoidalP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_sinusoidalP.gif differ diff --git a/docs/gifs/doc_smallEarth.gif b/docs/gifs/doc_smallEarth.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_smallEarth.gif differ diff --git a/docs/gifs/doc_spriteE.gif b/docs/gifs/doc_spriteE.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_spriteE.gif differ diff --git a/docs/gifs/doc_spriteMap.gif b/docs/gifs/doc_spriteMap.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_spriteMap.gif differ diff --git a/docs/gifs/doc_spriteTween.gif b/docs/gifs/doc_spriteTween.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_spriteTween.gif differ diff --git a/docs/gifs/doc_spriteVar.gif b/docs/gifs/doc_spriteVar.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_spriteVar.gif differ diff --git a/docs/gifs/doc_spriteZ.gif b/docs/gifs/doc_spriteZ.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_spriteZ.gif differ diff --git a/docs/gifs/doc_svgLogo.gif b/docs/gifs/doc_svgLogo.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_svgLogo.gif differ diff --git a/docs/gifs/doc_ternaryPlot.gif b/docs/gifs/doc_ternaryPlot.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_ternaryPlot.gif differ diff --git a/docs/gifs/doc_unVar.gif b/docs/gifs/doc_unVar.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_unVar.gif differ diff --git a/docs/gifs/doc_wait.gif b/docs/gifs/doc_wait.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_wait.gif differ diff --git a/docs/gifs/doc_waitOn.gif b/docs/gifs/doc_waitOn.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_waitOn.gif differ diff --git a/docs/gifs/doc_wernerP.gif b/docs/gifs/doc_wernerP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_wernerP.gif differ diff --git a/docs/gifs/doc_writeVar.gif b/docs/gifs/doc_writeVar.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_writeVar.gif differ diff --git a/docs/gifs/doc_xelatex.gif b/docs/gifs/doc_xelatex.gif Binary files a/docs/gifs/doc_xelatex.gif and b/docs/gifs/doc_xelatex.gif differ diff --git a/docs/gifs/doc_xyzComponents.gif b/docs/gifs/doc_xyzComponents.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_xyzComponents.gif differ diff --git a/examples/blender_default_cube.hs b/examples/blender_default_cube.hs new file mode 100644 --- /dev/null +++ b/examples/blender_default_cube.hs @@ -0,0 +1,38 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Main (main) where + +import Data.String.Here +import Reanimate + +main :: IO () +main = reanimate $ mkAnimation 5 $ \t -> + let s = t * pi in + mkGroup + [ mkBackground "black" + , blender (script s) + , withFillColor "white" $ + translate 0 2 $ + mkText "default cube" + ] + where + script s = [iTrim| +import bpy + +if __name__ == "__main__": + # Args + resolution_percentage = 40 + + # Setting + default_scene = bpy.context.scene + default_scene.render.resolution_percentage = resolution_percentage + default_scene.render.film_transparent = True + + default_cube = bpy.data.objects["Cube"] + default_cube.rotation_euler = (0,0,${s}) + + # Rendering + bpy.ops.render.render(animation=False, write_still=True) +|] diff --git a/examples/blender_sphere.hs b/examples/blender_sphere.hs new file mode 100644 --- /dev/null +++ b/examples/blender_sphere.hs @@ -0,0 +1,86 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Main (main) where + +import Data.String.Here +import qualified Data.Text as T +import Reanimate + +main :: IO () +main = reanimate $ mkAnimation 5 $ \t -> + let s = t * pi * 2 in + mkGroup + [ mkBackground "black" + , blender (script s) + ] + +texture :: FilePath +texture = svgAsPngFile (mkGroup + [ checker 10 10 + , withFillColor "red" $ + scale 2 $ center $ + latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"]) + +script :: Double -> T.Text +script s = [iTrim| +import os + +import bpy + +origin = bpy.data.objects['Cube'] + +bpy.ops.object.select_all(action='DESELECT') +origin.select_set(True) +bpy.ops.object.delete() + +bpy.ops.mesh.primitive_uv_sphere_add(segments=100,ring_count=100) +sphere = bpy.context.object +sphere.rotation_euler = (0,0,${s}) +bpy.ops.object.shade_smooth() + +# bpy.data.materials.new('Prog mat') +bpy.context.object.active_material = bpy.data.materials['Material'] +mat = bpy.context.object.active_material +image_node = mat.node_tree.nodes.new('ShaderNodeTexImage') +texture = mat.node_tree.nodes['Principled BSDF'] +texture.inputs['Roughness'].default_value = 1 +mat.node_tree.links.new(image_node.outputs['Color'], texture.inputs['Base Color']) + +image_node.image = bpy.data.images.load('${T.pack texture}') + +scn = bpy.context.scene +#scn.render.engine = 'CYCLES' +scn.render.film_transparent = True + +bpy.ops.render.render( write_still=True ) + +|] + + +checker :: Int -> Int -> SVG +checker w h = + withFillColor "white" $ + withStrokeColor "white" $ + withStrokeWidth 0.1 $ + mkGroup + [ withStrokeWidth 0 $ + withFillOpacity 0.8 $ mkBackground "blue" + , mkGroup + [ translate (stepX*x-offsetX + stepX/2) 0 $ + mkLine (0, -screenHeight/2*0.9) (0, screenHeight/2*0.9) + | x <- map fromIntegral [0..w-1] + ] + , + mkGroup + [ translate 0 (stepY*y-offsetY) $ + mkLine (-screenWidth/2, 0) (screenWidth/2, 0) + | y <- map fromIntegral [0..h] + ] + ] + where + stepX = screenWidth/fromIntegral w + stepY = screenHeight/fromIntegral h + offsetX = screenWidth/2 + offsetY = screenHeight/2 diff --git a/examples/bug_play1.golden b/examples/bug_play1.golden new file mode 100644 --- /dev/null +++ b/examples/bug_play1.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/bug_play1.hs b/examples/bug_play1.hs new file mode 100644 --- /dev/null +++ b/examples/bug_play1.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Scene + +-- This should give circle. +main :: IO () +main = reanimate $ signalA (constantS 0) $ sceneAnimation $ do + play $ animate $ const $ mkCircle 1 + play $ animate $ const $ mkRect 1 1 diff --git a/examples/bug_play2.golden b/examples/bug_play2.golden new file mode 100644 --- /dev/null +++ b/examples/bug_play2.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/bug_play2.hs b/examples/bug_play2.hs new file mode 100644 --- /dev/null +++ b/examples/bug_play2.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Scene + +-- This should give rect. +main :: IO () +main = reanimate $ signalA (constantS 0.5) $ sceneAnimation $ do + play $ animate $ const $ mkCircle 1 + play $ animate $ const $ mkRect 1 1 diff --git a/examples/bug_play3.golden b/examples/bug_play3.golden new file mode 100644 --- /dev/null +++ b/examples/bug_play3.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/bug_play3.hs b/examples/bug_play3.hs new file mode 100644 --- /dev/null +++ b/examples/bug_play3.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Scene + +-- This should give rect. +main :: IO () +main = reanimate $ signalA (constantS 1) $ sceneAnimation $ do + play $ animate $ const $ mkCircle 1 + play $ animate $ const $ mkRect 1 1 diff --git a/examples/colormaps.hs b/examples/colormaps.hs --- a/examples/colormaps.hs +++ b/examples/colormaps.hs @@ -42,11 +42,11 @@ , translate (-columnX) (rowInit-rowStep*3) $ mkOutline "jet" (dimmer s . jet) , translate (-columnX) (rowInit-rowStep*4) $ mkOutline "turbo" (dimmer s . turbo) - , translate (columnX) (rowInit-rowStep*0) $ mkOutline "magma" (dimmer s . magma) - , translate (columnX) (rowInit-rowStep*1) $ mkOutline "plasma" (dimmer s . plasma) - , translate (columnX) (rowInit-rowStep*2) $ mkOutline "sinebow" (dimmer s . sinebow) - , translate (columnX) (rowInit-rowStep*3) $ mkOutline "hsv" (dimmer s . hsv) - , translate (columnX) (rowInit-rowStep*4) $ mkOutline "parula" (dimmer s . parula) + , translate columnX (rowInit-rowStep*0) $ mkOutline "magma" (dimmer s . magma) + , translate columnX (rowInit-rowStep*1) $ mkOutline "plasma" (dimmer s . plasma) + , translate columnX (rowInit-rowStep*2) $ mkOutline "sinebow" (dimmer s . sinebow) + , translate columnX (rowInit-rowStep*3) $ mkOutline "hsv" (dimmer s . hsv) + , translate columnX (rowInit-rowStep*4) $ mkOutline "parula" (dimmer s . parula) ] where rowInit = 2.2 @@ -57,7 +57,7 @@ mkGroup [ center $ withFillColor "grey" $ mkRect (scaleWidth+0.05) (scaleHeight+0.05) , scaleToSize scaleWidth scaleHeight $ mkColorMap f - , translate (-scaleWidth/2) (0.5) $ centerY $ withFillColor "white" $ + , translate (-scaleWidth/2) 0.5 $ centerY $ withFillColor "white" $ scale 0.5 $ latex label ] scaleWidth = screenWidth/8*3 diff --git a/examples/counter.golden b/examples/counter.golden --- a/examples/counter.golden +++ b/examples/counter.golden @@ -1,50 +1,50 @@ -0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_addStatic.golden b/examples/doc_addStatic.golden new file mode 100644 --- /dev/null +++ b/examples/doc_addStatic.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_addStatic.hs b/examples/doc_addStatic.hs new file mode 100644 --- /dev/null +++ b/examples/doc_addStatic.hs @@ -0,0 +1,9 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ addStatic (mkBackground "lightblue") drawCircle diff --git a/examples/doc_andThen.golden b/examples/doc_andThen.golden new file mode 100644 --- /dev/null +++ b/examples/doc_andThen.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_applyVar.golden b/examples/doc_applyVar.golden new file mode 100644 --- /dev/null +++ b/examples/doc_applyVar.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_applyVar.hs b/examples/doc_applyVar.hs new file mode 100644 --- /dev/null +++ b/examples/doc_applyVar.hs @@ -0,0 +1,13 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + s <- fork $ newSpriteA drawBox + v <- newVar 0 + applyVar v s rotate + tweenVar v 2 $ \val -> fromToS val 90 diff --git a/examples/doc_bellS.golden b/examples/doc_bellS.golden new file mode 100644 --- /dev/null +++ b/examples/doc_bellS.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_bonneP.hs b/examples/doc_bonneP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_bonneP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth (bonneP (45/180*pi)) diff --git a/examples/doc_bottomleyP.hs b/examples/doc_bottomleyP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_bottomleyP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth (bottomleyP (30/180*pi)) diff --git a/examples/doc_chainT.golden b/examples/doc_chainT.golden new file mode 100644 --- /dev/null +++ b/examples/doc_chainT.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_chainT.hs b/examples/doc_chainT.hs new file mode 100644 --- /dev/null +++ b/examples/doc_chainT.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Transition +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ chainT (overlapT 0.5 fadeT) [drawBox, drawCircle, drawProgress] diff --git a/examples/doc_circlePlot.hs b/examples/doc_circlePlot.hs new file mode 100644 --- /dev/null +++ b/examples/doc_circlePlot.hs @@ -0,0 +1,16 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate hiding (raster, hsv) +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.CirclePlot +import Reanimate.Interpolate +import Data.Colour.RGBSpace.HSV +import Data.Colour.RGBSpace +import Data.Colour.SRGB +import Codec.Picture.Types + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ circlePlot 500 $ \ang r -> + promotePixel $ toRGB8 $ uncurryRGB sRGB $ hsv (ang/pi*180) r 1 diff --git a/examples/doc_cividis.golden b/examples/doc_cividis.golden new file mode 100644 --- /dev/null +++ b/examples/doc_cividis.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_cividis.hs b/examples/doc_cividis.hs --- a/examples/doc_cividis.hs +++ b/examples/doc_cividis.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap cividis - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap cividis diff --git a/examples/doc_collignonP.hs b/examples/doc_collignonP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_collignonP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth collignonP diff --git a/examples/doc_constantS.golden b/examples/doc_constantS.golden new file mode 100644 --- /dev/null +++ b/examples/doc_constantS.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_curveS.golden b/examples/doc_curveS.golden new file mode 100644 --- /dev/null +++ b/examples/doc_curveS.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_destroySprite.golden b/examples/doc_destroySprite.golden new file mode 100644 --- /dev/null +++ b/examples/doc_destroySprite.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_destroySprite.hs b/examples/doc_destroySprite.hs new file mode 100644 --- /dev/null +++ b/examples/doc_destroySprite.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + s <- newSpriteSVG $ withFillOpacity 1 $ mkCircle 1 + fork $ wait 1 >> destroySprite s + play drawBox diff --git a/examples/doc_drawBox.golden b/examples/doc_drawBox.golden new file mode 100644 --- /dev/null +++ b/examples/doc_drawBox.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_drawCircle.golden b/examples/doc_drawCircle.golden new file mode 100644 --- /dev/null +++ b/examples/doc_drawCircle.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_drawProgress.golden b/examples/doc_drawProgress.golden new file mode 100644 --- /dev/null +++ b/examples/doc_drawProgress.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_eckert1P.hs b/examples/doc_eckert1P.hs new file mode 100644 --- /dev/null +++ b/examples/doc_eckert1P.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth eckert1P diff --git a/examples/doc_eckert3P.hs b/examples/doc_eckert3P.hs new file mode 100644 --- /dev/null +++ b/examples/doc_eckert3P.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth eckert3P diff --git a/examples/doc_eckert5P.hs b/examples/doc_eckert5P.hs new file mode 100644 --- /dev/null +++ b/examples/doc_eckert5P.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth eckert5P diff --git a/examples/doc_equirectangularP.hs b/examples/doc_equirectangularP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_equirectangularP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth equirectangularP diff --git a/examples/doc_fadeT.golden b/examples/doc_fadeT.golden new file mode 100644 --- /dev/null +++ b/examples/doc_fadeT.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_fadeT.hs b/examples/doc_fadeT.hs new file mode 100644 --- /dev/null +++ b/examples/doc_fadeT.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Transition +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ drawBox `fadeT` drawCircle diff --git a/examples/doc_faheyP.hs b/examples/doc_faheyP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_faheyP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth faheyP diff --git a/examples/doc_fork.golden b/examples/doc_fork.golden new file mode 100644 --- /dev/null +++ b/examples/doc_fork.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_fork.hs b/examples/doc_fork.hs new file mode 100644 --- /dev/null +++ b/examples/doc_fork.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + fork $ play drawBox + play drawCircle diff --git a/examples/doc_fromToS.golden b/examples/doc_fromToS.golden new file mode 100644 --- /dev/null +++ b/examples/doc_fromToS.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_githubIcon.golden b/examples/doc_githubIcon.golden new file mode 100644 --- /dev/null +++ b/examples/doc_githubIcon.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_githubIcon.hs b/examples/doc_githubIcon.hs new file mode 100644 --- /dev/null +++ b/examples/doc_githubIcon.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ docEnv $ animate $ const githubIcon diff --git a/examples/doc_greyscale.golden b/examples/doc_greyscale.golden new file mode 100644 --- /dev/null +++ b/examples/doc_greyscale.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_greyscale.hs b/examples/doc_greyscale.hs --- a/examples/doc_greyscale.hs +++ b/examples/doc_greyscale.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap greyscale - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap greyscale diff --git a/examples/doc_hammerP.hs b/examples/doc_hammerP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_hammerP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth hammerP diff --git a/examples/doc_haskellLogo.golden b/examples/doc_haskellLogo.golden new file mode 100644 --- /dev/null +++ b/examples/doc_haskellLogo.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_haskellLogo.hs b/examples/doc_haskellLogo.hs new file mode 100644 --- /dev/null +++ b/examples/doc_haskellLogo.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ docEnv $ animate $ const haskellLogo diff --git a/examples/doc_hsv.golden b/examples/doc_hsv.golden new file mode 100644 --- /dev/null +++ b/examples/doc_hsv.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_hsv.hs b/examples/doc_hsv.hs --- a/examples/doc_hsv.hs +++ b/examples/doc_hsv.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap hsv - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap hsv diff --git a/examples/doc_hsvComponents.golden b/examples/doc_hsvComponents.golden new file mode 100644 --- /dev/null +++ b/examples/doc_hsvComponents.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_hsvComponents.hs b/examples/doc_hsvComponents.hs new file mode 100644 --- /dev/null +++ b/examples/doc_hsvComponents.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Interpolate +import Reanimate.Builtin.Documentation +import Codec.Picture + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ showColorMap $ interpolateRGB8 hsvComponents yellow blue + where + yellow = PixelRGB8 0xFF 0xFF 0x00 + blue = PixelRGB8 0x00 0x00 0xFF diff --git a/examples/doc_hsvMatlab.golden b/examples/doc_hsvMatlab.golden new file mode 100644 --- /dev/null +++ b/examples/doc_hsvMatlab.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_hsvMatlab.hs b/examples/doc_hsvMatlab.hs --- a/examples/doc_hsvMatlab.hs +++ b/examples/doc_hsvMatlab.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap hsvMatlab - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap hsvMatlab diff --git a/examples/doc_inferno.golden b/examples/doc_inferno.golden new file mode 100644 --- /dev/null +++ b/examples/doc_inferno.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_inferno.hs b/examples/doc_inferno.hs --- a/examples/doc_inferno.hs +++ b/examples/doc_inferno.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap inferno - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap inferno diff --git a/examples/doc_jet.golden b/examples/doc_jet.golden new file mode 100644 --- /dev/null +++ b/examples/doc_jet.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_jet.hs b/examples/doc_jet.hs --- a/examples/doc_jet.hs +++ b/examples/doc_jet.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap jet - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap jet diff --git a/examples/doc_labComponents.golden b/examples/doc_labComponents.golden new file mode 100644 --- /dev/null +++ b/examples/doc_labComponents.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_labComponents.hs b/examples/doc_labComponents.hs new file mode 100644 --- /dev/null +++ b/examples/doc_labComponents.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Interpolate +import Reanimate.Builtin.Documentation +import Codec.Picture + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ showColorMap $ interpolateRGB8 labComponents yellow blue + where + yellow = PixelRGB8 0xFF 0xFF 0x00 + blue = PixelRGB8 0x00 0x00 0xFF diff --git a/examples/doc_lambertP.hs b/examples/doc_lambertP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_lambertP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth lambertP diff --git a/examples/doc_latex.golden b/examples/doc_latex.golden new file mode 100644 --- /dev/null +++ b/examples/doc_latex.golden @@ -0,0 +1,50 @@ +0$e^{i\pi}+1=0$ +1$e^{i\pi}+1=0$ +2$e^{i\pi}+1=0$ +3$e^{i\pi}+1=0$ +4$e^{i\pi}+1=0$ +5$e^{i\pi}+1=0$ +6$e^{i\pi}+1=0$ +7$e^{i\pi}+1=0$ +8$e^{i\pi}+1=0$ +9$e^{i\pi}+1=0$ +10$e^{i\pi}+1=0$ +11$e^{i\pi}+1=0$ +12$e^{i\pi}+1=0$ +13$e^{i\pi}+1=0$ +14$e^{i\pi}+1=0$ +15$e^{i\pi}+1=0$ +16$e^{i\pi}+1=0$ +17$e^{i\pi}+1=0$ +18$e^{i\pi}+1=0$ +19$e^{i\pi}+1=0$ +20$e^{i\pi}+1=0$ +21$e^{i\pi}+1=0$ +22$e^{i\pi}+1=0$ +23$e^{i\pi}+1=0$ +24$e^{i\pi}+1=0$ +25$e^{i\pi}+1=0$ +26$e^{i\pi}+1=0$ +27$e^{i\pi}+1=0$ +28$e^{i\pi}+1=0$ +29$e^{i\pi}+1=0$ +30$e^{i\pi}+1=0$ +31$e^{i\pi}+1=0$ +32$e^{i\pi}+1=0$ +33$e^{i\pi}+1=0$ +34$e^{i\pi}+1=0$ +35$e^{i\pi}+1=0$ +36$e^{i\pi}+1=0$ +37$e^{i\pi}+1=0$ +38$e^{i\pi}+1=0$ +39$e^{i\pi}+1=0$ +40$e^{i\pi}+1=0$ +41$e^{i\pi}+1=0$ +42$e^{i\pi}+1=0$ +43$e^{i\pi}+1=0$ +44$e^{i\pi}+1=0$ +45$e^{i\pi}+1=0$ +46$e^{i\pi}+1=0$ +47$e^{i\pi}+1=0$ +48$e^{i\pi}+1=0$ +49$e^{i\pi}+1=0$ diff --git a/examples/doc_latexAlign.golden b/examples/doc_latexAlign.golden new file mode 100644 --- /dev/null +++ b/examples/doc_latexAlign.golden @@ -0,0 +1,50 @@ +0\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +1\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +2\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +3\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +4\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +5\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +6\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +7\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +8\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +9\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +10\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +11\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +12\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +13\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +14\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +15\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +16\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +17\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +18\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +19\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +20\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +21\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +22\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +23\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +24\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +25\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +26\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +27\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +28\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +29\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +30\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +31\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +32\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +33\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +34\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +35\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +36\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +37\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +38\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +39\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +40\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +41\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +42\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +43\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +44\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +45\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +46\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +47\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +48\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} +49\begin{align*}R = \frac{{\Delta x}}{{kA}}\end{align*} diff --git a/examples/doc_lchComponents.golden b/examples/doc_lchComponents.golden new file mode 100644 --- /dev/null +++ b/examples/doc_lchComponents.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_lchComponents.hs b/examples/doc_lchComponents.hs new file mode 100644 --- /dev/null +++ b/examples/doc_lchComponents.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Interpolate +import Reanimate.Builtin.Documentation +import Codec.Picture + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ showColorMap $ interpolateRGB8 lchComponents yellow blue + where + yellow = PixelRGB8 0xFF 0xFF 0x00 + blue = PixelRGB8 0x00 0x00 0xFF diff --git a/examples/doc_magma.golden b/examples/doc_magma.golden new file mode 100644 --- /dev/null +++ b/examples/doc_magma.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_magma.hs b/examples/doc_magma.hs --- a/examples/doc_magma.hs +++ b/examples/doc_magma.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap magma - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap magma diff --git a/examples/doc_mapA.golden b/examples/doc_mapA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_mapA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_mercatorP.hs b/examples/doc_mercatorP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_mercatorP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth mercatorP diff --git a/examples/doc_mkBackground.golden b/examples/doc_mkBackground.golden new file mode 100644 --- /dev/null +++ b/examples/doc_mkBackground.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_mkBackground.hs b/examples/doc_mkBackground.hs new file mode 100644 --- /dev/null +++ b/examples/doc_mkBackground.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate + +main :: IO () +main = reanimate $ animate $ const $ + mkBackground "yellow" diff --git a/examples/doc_mkText.golden b/examples/doc_mkText.golden new file mode 100644 --- /dev/null +++ b/examples/doc_mkText.golden @@ -0,0 +1,50 @@ +0 +1 +2t +3t +4t +5te +6te +7te +8te +9tex +10tex +11tex +12text +13text +14text +15text +16text +17text +18text +19text +20text +21text +22text +23text +24text +25text +26text +27text +28text +29text +30text +31text +32text +33text +34text +35text +36text +37text +38text +39text +40text +41text +42text +43text +44text +45text +46text +47text +48text +49text diff --git a/examples/doc_mkText.hs b/examples/doc_mkText.hs new file mode 100644 --- /dev/null +++ b/examples/doc_mkText.hs @@ -0,0 +1,15 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import qualified Data.Text as T + +main :: IO () +main = reanimate $ docEnv $ mkAnimation 2 $ \t -> + scale 2 $ + withStrokeWidth 0.05 $ + mkText (T.take (round $ t*15) "text") + diff --git a/examples/doc_mollweideP.hs b/examples/doc_mollweideP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_mollweideP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth mollweideP diff --git a/examples/doc_newSprite.golden b/examples/doc_newSprite.golden new file mode 100644 --- /dev/null +++ b/examples/doc_newSprite.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_newSprite.hs b/examples/doc_newSprite.hs new file mode 100644 --- /dev/null +++ b/examples/doc_newSprite.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + _ <- newSprite $ mkCircle <$> spriteT -- Circle sprite where radius=time. + wait 2 diff --git a/examples/doc_newSpriteA'.golden b/examples/doc_newSpriteA'.golden new file mode 100644 --- /dev/null +++ b/examples/doc_newSpriteA'.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_newSpriteA'.hs b/examples/doc_newSpriteA'.hs new file mode 100644 --- /dev/null +++ b/examples/doc_newSpriteA'.hs @@ -0,0 +1,13 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Animation +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + _ <- fork $ newSpriteA' SyncFreeze drawCircle + play drawBox + play $ reverseA drawBox diff --git a/examples/doc_newSpriteA.golden b/examples/doc_newSpriteA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_newSpriteA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_newSpriteA.hs b/examples/doc_newSpriteA.hs new file mode 100644 --- /dev/null +++ b/examples/doc_newSpriteA.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + _ <- fork $ newSpriteA drawCircle + play drawBox + play $ reverseA drawBox diff --git a/examples/doc_newSpriteSVG.golden b/examples/doc_newSpriteSVG.golden new file mode 100644 --- /dev/null +++ b/examples/doc_newSpriteSVG.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_newSpriteSVG.hs b/examples/doc_newSpriteSVG.hs new file mode 100644 --- /dev/null +++ b/examples/doc_newSpriteSVG.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + _ <- newSpriteSVG $ mkBackground "lightblue" + play drawCircle diff --git a/examples/doc_orthoP.hs b/examples/doc_orthoP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_orthoP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth (orthoP $ LonLat 0 0) diff --git a/examples/doc_oscillateS.golden b/examples/doc_oscillateS.golden new file mode 100644 --- /dev/null +++ b/examples/doc_oscillateS.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_overlapT.golden b/examples/doc_overlapT.golden new file mode 100644 --- /dev/null +++ b/examples/doc_overlapT.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_overlapT.hs b/examples/doc_overlapT.hs new file mode 100644 --- /dev/null +++ b/examples/doc_overlapT.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Transition +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ overlapT 0.5 fadeT drawBox drawCircle diff --git a/examples/doc_parA.golden b/examples/doc_parA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_parA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_parDropA.golden b/examples/doc_parDropA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_parDropA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_parLoopA.golden b/examples/doc_parLoopA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_parLoopA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_parula.golden b/examples/doc_parula.golden new file mode 100644 --- /dev/null +++ b/examples/doc_parula.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_parula.hs b/examples/doc_parula.hs --- a/examples/doc_parula.hs +++ b/examples/doc_parula.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap parula - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap parula diff --git a/examples/doc_pathify.golden b/examples/doc_pathify.golden new file mode 100644 --- /dev/null +++ b/examples/doc_pathify.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_pathify.hs b/examples/doc_pathify.hs new file mode 100644 --- /dev/null +++ b/examples/doc_pathify.hs @@ -0,0 +1,19 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv pathifyExample + +pathifyExample :: Animation +pathifyExample = animate $ \t -> gridLayout + [ [ partialSvg t $ pathify $ mkCircle 1 + , partialSvg t $ pathify $ mkRect 2 2 + ] + , [ partialSvg t $ pathify $ mkEllipse 1 0.5 + , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1) + ] + ] diff --git a/examples/doc_pause.golden b/examples/doc_pause.golden new file mode 100644 --- /dev/null +++ b/examples/doc_pause.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_pauseAround.golden b/examples/doc_pauseAround.golden new file mode 100644 --- /dev/null +++ b/examples/doc_pauseAround.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_pauseAtBeginning.golden b/examples/doc_pauseAtBeginning.golden new file mode 100644 --- /dev/null +++ b/examples/doc_pauseAtBeginning.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_pauseAtEnd.golden b/examples/doc_pauseAtEnd.golden new file mode 100644 --- /dev/null +++ b/examples/doc_pauseAtEnd.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_plasma.golden b/examples/doc_plasma.golden new file mode 100644 --- /dev/null +++ b/examples/doc_plasma.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_plasma.hs b/examples/doc_plasma.hs --- a/examples/doc_plasma.hs +++ b/examples/doc_plasma.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap plasma - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap plasma diff --git a/examples/doc_play.golden b/examples/doc_play.golden new file mode 100644 --- /dev/null +++ b/examples/doc_play.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_play.hs b/examples/doc_play.hs new file mode 100644 --- /dev/null +++ b/examples/doc_play.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + play drawBox + play drawCircle diff --git a/examples/doc_playThenReverseA.golden b/examples/doc_playThenReverseA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_playThenReverseA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_queryNow.golden b/examples/doc_queryNow.golden new file mode 100644 --- /dev/null +++ b/examples/doc_queryNow.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33Now=2.0 +34Now=2.0 +35Now=2.0 +36Now=2.0 +37Now=2.0 +38Now=2.0 +39Now=2.0 +40Now=2.0 +41Now=2.0 +42Now=2.0 +43Now=2.0 +44Now=2.0 +45Now=2.0 +46Now=2.0 +47Now=2.0 +48Now=2.0 +49Now=2.0 diff --git a/examples/doc_queryNow.hs b/examples/doc_queryNow.hs new file mode 100644 --- /dev/null +++ b/examples/doc_queryNow.hs @@ -0,0 +1,15 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Data.Monoid ((<>)) +import qualified Data.Text as T + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + now <- play drawCircle *> queryNow + play $ staticFrame 1 $ scale 2 $ withStrokeWidth 0.05 $ + mkText $ "Now=" <> T.pack (show now) diff --git a/examples/doc_repeatA.golden b/examples/doc_repeatA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_repeatA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_reverseA.golden b/examples/doc_reverseA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_reverseA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_reverseS.golden b/examples/doc_reverseS.golden new file mode 100644 --- /dev/null +++ b/examples/doc_reverseS.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_rgbComponents.golden b/examples/doc_rgbComponents.golden new file mode 100644 --- /dev/null +++ b/examples/doc_rgbComponents.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_seqA.golden b/examples/doc_seqA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_seqA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_signalA.golden b/examples/doc_signalA.golden new file mode 100644 --- /dev/null +++ b/examples/doc_signalA.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_simpleVar.golden b/examples/doc_simpleVar.golden new file mode 100644 --- /dev/null +++ b/examples/doc_simpleVar.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_simpleVar.hs b/examples/doc_simpleVar.hs new file mode 100644 --- /dev/null +++ b/examples/doc_simpleVar.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + var <- simpleVar mkCircle 0 + tweenVar var 2 $ \val -> fromToS val (screenHeight/2) diff --git a/examples/doc_sinebow.golden b/examples/doc_sinebow.golden new file mode 100644 --- /dev/null +++ b/examples/doc_sinebow.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_sinebow.hs b/examples/doc_sinebow.hs --- a/examples/doc_sinebow.hs +++ b/examples/doc_sinebow.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap sinebow - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap sinebow diff --git a/examples/doc_sinusoidalP.hs b/examples/doc_sinusoidalP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_sinusoidalP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth sinusoidalP diff --git a/examples/doc_smallEarth.hs b/examples/doc_smallEarth.hs new file mode 100644 --- /dev/null +++ b/examples/doc_smallEarth.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ + scaleToSize screenWidth screenHeight $ + embedImage smallEarth diff --git a/examples/doc_spriteE.golden b/examples/doc_spriteE.golden new file mode 100644 --- /dev/null +++ b/examples/doc_spriteE.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_spriteE.hs b/examples/doc_spriteE.hs new file mode 100644 --- /dev/null +++ b/examples/doc_spriteE.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + s <- fork $ newSpriteA drawCircle + spriteE s $ overBeginning 1 fadeInE + spriteE s $ overEnding 0.5 fadeOutE diff --git a/examples/doc_spriteMap.golden b/examples/doc_spriteMap.golden new file mode 100644 --- /dev/null +++ b/examples/doc_spriteMap.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_spriteMap.hs b/examples/doc_spriteMap.hs new file mode 100644 --- /dev/null +++ b/examples/doc_spriteMap.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + s <- fork $ newSpriteA drawCircle + wait 1 + spriteMap s flipYAxis diff --git a/examples/doc_spriteTween.golden b/examples/doc_spriteTween.golden new file mode 100644 --- /dev/null +++ b/examples/doc_spriteTween.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_spriteTween.hs b/examples/doc_spriteTween.hs new file mode 100644 --- /dev/null +++ b/examples/doc_spriteTween.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + s <- fork $ newSpriteA drawCircle + spriteTween s 1 $ \val -> translate (screenWidth*0.3*val) 0 diff --git a/examples/doc_spriteVar.golden b/examples/doc_spriteVar.golden new file mode 100644 --- /dev/null +++ b/examples/doc_spriteVar.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_spriteVar.hs b/examples/doc_spriteVar.hs new file mode 100644 --- /dev/null +++ b/examples/doc_spriteVar.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + s <- fork $ newSpriteA drawBox + v <- spriteVar s 0 rotate + tweenVar v 2 $ \val -> fromToS val 90 diff --git a/examples/doc_spriteZ.golden b/examples/doc_spriteZ.golden new file mode 100644 --- /dev/null +++ b/examples/doc_spriteZ.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_spriteZ.hs b/examples/doc_spriteZ.hs new file mode 100644 --- /dev/null +++ b/examples/doc_spriteZ.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + s1 <- newSpriteSVG $ withFillOpacity 1 $ withFillColor "blue" $ mkCircle 3 + _ <- newSpriteSVG $ withFillOpacity 1 $ withFillColor "red" $ mkRect 8 3 + wait 1 + spriteZ s1 1 + wait 1 diff --git a/examples/doc_svgLogo.golden b/examples/doc_svgLogo.golden new file mode 100644 --- /dev/null +++ b/examples/doc_svgLogo.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_svgLogo.hs b/examples/doc_svgLogo.hs new file mode 100644 --- /dev/null +++ b/examples/doc_svgLogo.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ docEnv $ animate $ const svgLogo diff --git a/examples/doc_turbo.golden b/examples/doc_turbo.golden new file mode 100644 --- /dev/null +++ b/examples/doc_turbo.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_turbo.hs b/examples/doc_turbo.hs --- a/examples/doc_turbo.hs +++ b/examples/doc_turbo.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap turbo - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap turbo diff --git a/examples/doc_unVar.golden b/examples/doc_unVar.golden new file mode 100644 --- /dev/null +++ b/examples/doc_unVar.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_unVar.hs b/examples/doc_unVar.hs new file mode 100644 --- /dev/null +++ b/examples/doc_unVar.hs @@ -0,0 +1,13 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + v <- newVar 0 + _ <- newSprite $ mkCircle <$> unVar v + tweenVar v 1 $ \val -> fromToS val 3 + tweenVar v 1 $ \val -> fromToS val 0 diff --git a/examples/doc_viridis.golden b/examples/doc_viridis.golden new file mode 100644 --- /dev/null +++ b/examples/doc_viridis.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_viridis.hs b/examples/doc_viridis.hs --- a/examples/doc_viridis.hs +++ b/examples/doc_viridis.hs @@ -2,17 +2,8 @@ -- stack runghc --package reanimate module Main(main) where -import Codec.Picture import Reanimate import Reanimate.Builtin.Documentation main :: IO () -main = reanimate $ docEnv $ animate $ const $ mkColorMap viridis - -mkColorMap :: (Double -> PixelRGB8) -> SVG -mkColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - where - width = 256 - height = 1 - img = generateImage pixelRenderer width height - pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +main = reanimate $ docEnv $ animate $ const $ showColorMap viridis diff --git a/examples/doc_wait.golden b/examples/doc_wait.golden new file mode 100644 --- /dev/null +++ b/examples/doc_wait.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_wait.hs b/examples/doc_wait.hs new file mode 100644 --- /dev/null +++ b/examples/doc_wait.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + fork $ play drawBox + wait 1 + play drawCircle diff --git a/examples/doc_waitOn.golden b/examples/doc_waitOn.golden new file mode 100644 --- /dev/null +++ b/examples/doc_waitOn.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_waitOn.hs b/examples/doc_waitOn.hs new file mode 100644 --- /dev/null +++ b/examples/doc_waitOn.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + waitOn $ fork $ play drawBox + play drawCircle diff --git a/examples/doc_wernerP.hs b/examples/doc_wernerP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_wernerP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth wernerP diff --git a/examples/doc_writeVar.golden b/examples/doc_writeVar.golden new file mode 100644 --- /dev/null +++ b/examples/doc_writeVar.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_writeVar.hs b/examples/doc_writeVar.hs new file mode 100644 --- /dev/null +++ b/examples/doc_writeVar.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + v <- newVar 0 + _ <- newSprite $ mkCircle <$> unVar v + writeVar v 1; wait 1 + writeVar v 2; wait 1 + writeVar v 3; wait 1 diff --git a/examples/doc_xyzComponents.golden b/examples/doc_xyzComponents.golden new file mode 100644 --- /dev/null +++ b/examples/doc_xyzComponents.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/doc_xyzComponents.hs b/examples/doc_xyzComponents.hs new file mode 100644 --- /dev/null +++ b/examples/doc_xyzComponents.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Interpolate +import Reanimate.Builtin.Documentation +import Codec.Picture + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ showColorMap $ interpolateRGB8 xyzComponents yellow blue + where + yellow = PixelRGB8 0xFF 0xFF 0x00 + blue = PixelRGB8 0x00 0x00 0xFF diff --git a/examples/fourier.hs b/examples/fourier.hs --- a/examples/fourier.hs +++ b/examples/fourier.hs @@ -7,12 +7,8 @@ import qualified Data.Text as T import Graphics.SvgTree -import Reanimate.Driver (reanimate) +import Reanimate import Reanimate.LaTeX (latex) -import Reanimate.Animation -import Reanimate.Svg -import Reanimate.Signal -import Reanimate.Constants waveMultiplier :: Int -- waveMultiplier = 1 -- Sawtooth wave @@ -75,7 +71,7 @@ mkCirclePath nCircles phiOffset = mkLinePath $ take 2000 $ zip [ 2 * i/granularity | i <- [0..]] $ drop (round $ (1-phiOffset/(2*pi)) * granularity) $ - cycle $ [ fourierYValue nCircles phi + cycle [ fourierYValue nCircles phi | x <- reverse [1..granularity] , let phi = 2*pi*(x/granularity) ] diff --git a/examples/fourier_draw.hs b/examples/fourier_draw.hs --- a/examples/fourier_draw.hs +++ b/examples/fourier_draw.hs @@ -10,7 +10,7 @@ import Reanimate main :: IO () -main = reanimate $ pauseAtEnd 2 $ +main = reanimate $ pauseAtEnd 2 fourierAnimation_ sWidth :: Double @@ -41,7 +41,7 @@ latex $ T.pack $ "Circles: " ++ show (length $ fourierCoefficients circles) ] -data Fourier = Fourier {fourierCoefficients :: [Complex Double]} +newtype Fourier = Fourier {fourierCoefficients :: [Complex Double]} pointAtFourier :: Fourier -> Complex Double pointAtFourier = sum . fourierCoefficients @@ -75,11 +75,11 @@ worker len (c:cs) = if magnitude c < len then c : worker (len - magnitude c) cs - else [c * (realToFrac (len / magnitude c))] + else [c * realToFrac (len / magnitude c)] rotateFourier :: Double -> Fourier -> Fourier rotateFourier phi (Fourier coeffs) = - Fourier $ worker (coeffs) (0::Integer) + Fourier $ worker coeffs (0::Integer) where worker [] _ = [] worker (x:rest) 0 = x : worker rest 1 diff --git a/examples/goo.golden b/examples/goo.golden --- a/examples/goo.golden +++ b/examples/goo.golden @@ -1,50 +1,50 @@ -0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/goo.hs b/examples/goo.hs --- a/examples/goo.hs +++ b/examples/goo.hs @@ -16,7 +16,7 @@ , FilterTree $ mkFilter "blur" [FEGaussianBlur $ defaultSvg & gaussianBlurStdDeviationX .~ Num dev - & filterResult .~ Just "blur" + & filterResult ?~ "blur" ] & filterWidth .~ pure (Percent 3) & filterX .~ pure (Percent (-1)) & filterHeight .~ pure (Percent 3) @@ -24,7 +24,7 @@ , FilterTree $ mkFilter "goo" [FEGaussianBlur $ defaultSvg & gaussianBlurStdDeviationX .~ Num dev - & filterResult .~ Just "blur" + & filterResult ?~ "blur" ,FEColorMatrix $ defaultSvg & colorMatrixType .~ Matrix & colorMatrixValues .~ "1 0 0 0 0 \ @@ -60,4 +60,4 @@ circ = mkCircle radius mkFilter :: String -> [FilterElement] -> Filter -mkFilter ident fe = defaultSvg & filterChildren .~ fe & attrId .~ Just ident +mkFilter ident fe = defaultSvg & filterChildren .~ fe & attrId ?~ ident diff --git a/examples/image.hs b/examples/image.hs new file mode 100644 --- /dev/null +++ b/examples/image.hs @@ -0,0 +1,22 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import qualified Graphics.SvgTree as Svg +import Control.Lens ((&), (.~)) +import Graphics.SvgTree + +main :: IO () +main = reanimate $ animate $ const $ + ImageTree $ defaultSvg + & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2)) + & Svg.imageWidth .~ Svg.Num w + & Svg.imageHeight .~ Svg.Num h + & Svg.imageHref .~ ("file://"++src) + + + where + w = screenWidth + h = screenHeight + src = "/home/lemmih/Coding/Haskell/reanimate/examples/haskell.svg" diff --git a/examples/latex_basic.golden b/examples/latex_basic.golden new file mode 100644 --- /dev/null +++ b/examples/latex_basic.golden @@ -0,0 +1,50 @@ +0\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +1\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +2\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +3\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +4\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +5\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +6\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +7\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +8\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +9\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +10\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +11\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +12\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +13\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +14\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +15\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +16\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +17\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +18\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +19\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +20\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +21\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +22\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +23\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +24\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +25\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +26\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +27\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +28\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +29\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +30\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +31\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +32\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +33\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +34\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +35\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +36\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +37\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +38\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +39\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +40\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +41\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +42\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +43\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +44\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +45\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +46\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +47\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +48\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} +49\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*}\begin{align*}\sum_{k=1}^\infty {1 \over k^2} = {\pi^2 \over 6}\end{align*} diff --git a/examples/latex_color.hs b/examples/latex_color.hs --- a/examples/latex_color.hs +++ b/examples/latex_color.hs @@ -14,7 +14,7 @@ withSubglyphs [1] (withFillColor "yellow") $ withSubglyphs [2] (withFillColor "green") $ withSubglyphs [3] (withFillColor "red") $ - withSubglyphs [4] (withFillColor "darkslategrey") $ + withSubglyphs [4] (withFillColor "darkslategrey") svg ] where svg = withStrokeWidth 0.01 $ scale 4 $ center $ latex "\\LaTeX" diff --git a/examples/latex_wheel.hs b/examples/latex_wheel.hs --- a/examples/latex_wheel.hs +++ b/examples/latex_wheel.hs @@ -7,8 +7,6 @@ import Control.Monad (forM_) import Graphics.SvgTree (Tree) import Reanimate -import Reanimate.Driver (reanimate) -import Reanimate.Effect main :: IO () main = reanimate $ bg `parA` mainScene @@ -23,7 +21,7 @@ fork $ play $ drawCircle # freezeAtPercentage 1 # setDuration rotDur - rotDur <- withSceneDuration $ waitAll $ + rotDur <- withSceneDuration $ waitOn $ forM_ svgs $ \svg -> do fork $ play $ drawTick # setDuration rotateT diff --git a/examples/parameters.hs b/examples/parameters.hs new file mode 100644 --- /dev/null +++ b/examples/parameters.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import qualified Data.Text as T + +main :: IO () +main = reanimate $ animate $ const $ + mkText $ T.pack $ "Test parameters: " ++ show (pFPS, pWidth, pHeight) + diff --git a/examples/polyshape_test1.hs b/examples/polyshape_test1.hs --- a/examples/polyshape_test1.hs +++ b/examples/polyshape_test1.hs @@ -1,7 +1,6 @@ #!/usr/bin/env stack -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main (main) where import Control.Lens () diff --git a/examples/polyshape_test2.hs b/examples/polyshape_test2.hs --- a/examples/polyshape_test2.hs +++ b/examples/polyshape_test2.hs @@ -1,7 +1,6 @@ #!/usr/bin/env stack -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main (main) where import Reanimate @@ -13,7 +12,7 @@ bigBox = head $ svgToPolyShapes $ pathify $ mkRect 2 2 smallBox = head $ svgToPolyShapes $ pathify $ - translate (0) (screenHeight*s) $ + translate 0 (screenHeight*s) $ rotate (-45) $ mkRect 1 1 diff --git a/examples/polyshape_test3.hs b/examples/polyshape_test3.hs --- a/examples/polyshape_test3.hs +++ b/examples/polyshape_test3.hs @@ -1,7 +1,6 @@ #!/usr/bin/env stack -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main (main) where import Reanimate diff --git a/examples/polyshape_test4.hs b/examples/polyshape_test4.hs --- a/examples/polyshape_test4.hs +++ b/examples/polyshape_test4.hs @@ -1,7 +1,6 @@ #!/usr/bin/env stack -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main (main) where import Reanimate diff --git a/examples/raster.golden b/examples/raster.golden # file too large to diff: examples/raster.golden diff --git a/examples/signals.hs b/examples/signals.hs --- a/examples/signals.hs +++ b/examples/signals.hs @@ -1,7 +1,6 @@ #!/usr/bin/env stack -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main (main) where import Data.Monoid ((<>)) @@ -10,10 +9,7 @@ import Numeric import Reanimate.Animation import Reanimate.Constants -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Signal -import Reanimate.Svg +import Reanimate main :: IO () main = reanimate $ pauseAtEnd 5 $ @@ -77,7 +73,7 @@ , translate (convertX $ 205) (convertX $ -5) $ scale 0.5 $ center $ latex "1" , translate (convertX $ 100) (convertX $ -30)$ scale 0.6 $ center $ latex name ] , withFillOpacity 0 $ withStrokeColor "green" $ -- withStrokeWidth 0.5 $ - lowerTransformations $ scaleXY (convertX $ 200) (convertX $ (50)) $ mkSignalLine (fromListS curveFns) + lowerTransformations $ scaleXY (convertX $ 200) (convertX $ 50) $ mkSignalLine (fromListS curveFns) ] ] diff --git a/examples/simulate_gravity.golden b/examples/simulate_gravity.golden --- a/examples/simulate_gravity.golden +++ b/examples/simulate_gravity.golden @@ -1,50 +1,50 @@ -0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -25 -26 -27 -28 -29 -30 -31 -32 -33 -34 -35 -36 -37 -38 -39 -40 -41 -42 -43 -44 -45 -46 -47 -48 -49 +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/slow.hs b/examples/slow.hs new file mode 100644 --- /dev/null +++ b/examples/slow.hs @@ -0,0 +1,25 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Control.Concurrent +import Control.Exception +import Control.Lens +import qualified Data.Text as T +import Graphics.SvgTree +import Reanimate +import System.IO.Unsafe + +main :: IO () +main = reanimate $ mkAnimation dur $ \t -> unsafePerformIO $ do + let frame = round (t*dur*fromIntegral pFPS) :: Integer + threadDelay (10^(6::Integer)) + evaluate $ mkGroup + [ mkBackground "black" + , translate (-4) 0 $ + withFillColor "white" $ + mkText (T.pack $ "Frame: " ++ show frame) + & textAnchor .~ pure TextAnchorStart + ] + where + dur = 2 diff --git a/examples/sorting.hs b/examples/sorting.hs --- a/examples/sorting.hs +++ b/examples/sorting.hs @@ -46,10 +46,9 @@ translate (-screenWidth*0.26) (-screenHeight*0.05) $ rotate (-90) $ scale 0.5 $ center $ latex "$Time \\rightarrow$" - , withFillColor "white" $ translate ((screenWidth*0.30)) 0 $ + , withFillColor "white" $ translate (screenWidth*0.30) 0 $ mkCircle ((1-t)*0.5) ] - where -- main :: IO () @@ -175,7 +174,7 @@ worker a 0 = writeS 0 a worker a j = do b <- readS (j-1) - if (a < b) + if a < b then do writeS j b worker a (j-1) diff --git a/examples/sunflower.hs b/examples/sunflower.hs --- a/examples/sunflower.hs +++ b/examples/sunflower.hs @@ -1,8 +1,11 @@ #!/usr/bin/env stack -- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} module Main (main) where +main :: IO () +main = return () + +{- import qualified Data.Colour.Palette.BrewerSet as D import Diagrams.Prelude hiding (Animation, boundingBox, center, circle, duration, @@ -40,3 +43,5 @@ sunflower n = frame 4 $ position $ take n $ zip mkCoords florets where florets = [ floret (sqrt (fromIntegral i)) | i <- [1::Int ..]] +-} + diff --git a/examples/tangent_and_normal.golden b/examples/tangent_and_normal.golden deleted file mode 100644 --- a/examples/tangent_and_normal.golden +++ /dev/null @@ -1,50 +0,0 @@ -0normaltangent -1normaltangent -2normaltangent -3normaltangent -4normaltangent -5normaltangent -6normaltangent -7normaltangent -8normaltangent -9normaltangent -10normaltangent -11normaltangent -12normaltangent -13normaltangent -14normaltangent -15normaltangent -16normaltangent -17normaltangent -18normaltangent -19normaltangent -20normaltangent -21normaltangent -22normaltangent -23normaltangent -24normaltangent -25normaltangent -26normaltangent -27normaltangent -28normaltangent -29normaltangent -30normaltangent -31normaltangent -32normaltangent -33normaltangent -34normaltangent -35normaltangent -36normaltangent -37normaltangent -38normaltangent -39normaltangent -40normaltangent -41normaltangent -42normaltangent -43normaltangent -44normaltangent -45normaltangent -46normaltangent -47normaltangent -48normaltangent -49normaltangent diff --git a/examples/tangent_and_normal.hs b/examples/tangent_and_normal.hs --- a/examples/tangent_and_normal.hs +++ b/examples/tangent_and_normal.hs @@ -1,8 +1,11 @@ #!/usr/bin/env stack -- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} module Main (main) where +main :: IO () +main = return () + +{- import Diagrams.Prelude hiding (Animation, boundingBox, center, circle, duration, fontSize, rotate, scale, @@ -55,3 +58,5 @@ rightAngleSquare :: SvgDiagram rightAngleSquare = square 0.1 # alignBL # D.rotate (signedAngleBetween tangentVector unitX) +-} + diff --git a/examples/tut_glue_animate.hs b/examples/tut_glue_animate.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_animate.hs @@ -0,0 +1,55 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Transition + +import Codec.Picture.Types +import Data.Text (Text) + +bgColor :: PixelRGBA8 +bgColor = PixelRGBA8 252 252 252 0xFF + +segmentDuration :: Double +segmentDuration = 3 + +transitionTime :: Double +transitionTime = 0.5 + +main :: IO () +main = reanimate $ bg `parA` + chainT transition + [animateCircleR, animateCircleP, animateRectR, animateColor + ,signalA (constantS 0) $ setDuration transitionTime animateCircleR] + where + transition = overlapT transitionTime fadeT + bg = animate $ const $ mkBackgroundPixel bgColor + +animateCircleR :: Animation +animateCircleR = mkSegment "radius" $ \t -> mkCircle (t*2) + +animateCircleP :: Animation +animateCircleP = mkSegment "drawn" $ \t -> + withFillOpacity 0 $ partialSvg t (pathify $ mkCircle 2) + +animateRectR :: Animation +animateRectR = mkSegment "rotation" $ \t -> rotate (t*360) $ mkRect 4 2 + +animateColor :: Animation +animateColor = mkSegment "color" $ \t -> + withFillColorPixel (promotePixel $ turbo t) $ mkRect 4 2 + +mkSegment :: Text -> (Time -> SVG) -> Animation +mkSegment label gen = mkAnimation segmentDuration $ \t -> env $ + mkGroup + [ gen t + , withStrokeWidth 0 $ translate 0 3 $ scale 2 $ + center $ latex label ] + +env :: SVG -> SVG +env = + withStrokeColor "red" . + withFillColor "black" . + withStrokeWidth (defaultStrokeWidth*2) diff --git a/examples/tut_glue_blender.hs b/examples/tut_glue_blender.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_blender.hs @@ -0,0 +1,249 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ApplicativeDo #-} +module Main (main) where + +import Reanimate + +import Codec.Picture.Types +import Control.Lens ((^.)) +import Control.Monad +import Data.Monoid +import Data.String.Here +import qualified Data.Text as T +import Graphics.SvgTree +import System.Random +import System.Random.Shuffle + +-- spritePercent = (/) <$> spriteT <*> spriteDur + +main :: IO () +main = seq texture $ reanimate $ pauseAtEnd 1 $ parA bg $ sceneAnimation $ do + bend <- newVar 0 + trans <- newVar 0 + rotX <- newVar 0 + rotY <- newVar 0 + _ <- newSprite $ do + getBend <- unVar bend + getTrans <- unVar trans + getRotX <- unVar rotX + getRotY <- unVar rotY + t <- spriteT + dur <- spriteDuration + return $ seq (texture (t/dur)) $ + blender (script (texture (t/dur)) getBend getTrans getRotX getRotY) + wait 2 + tweenVar trans 5 (\t v -> fromToS v (-2) $ curveS 2 t) + tweenVar bend 5 (\t v -> fromToS v 1 $ curveS 2 t) + tweenVar rotY 15 (\t v -> fromToS v (pi*2*2) $ curveS 2 t) + fork $ do + tweenVar rotX 5 (\t v -> fromToS v (-pi/5) $ curveS 2 t) + wait 5 + tweenVar rotX 5 (\t v -> fromToS v (pi/5) $ curveS 2 t) + wait (15-5) + tweenVar bend 5 (\t v -> fromToS v 0 $ curveS 2 t) + tweenVar rotX 5 (\t v -> fromToS v 0 $ curveS 2 t) + tweenVar trans 5 (\t v -> fromToS v 0 $ curveS 2 t) + wait 4 + -- tweenVar trans 1 (\t v -> fromToS v 0 $ curveS 2 t) + wait 1 + wait 2 + where + bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF) + +texture :: Double -> FilePath +texture t = svgAsPngFile $ mkGroup + [ checker 20 20 + , frameAt (t*duration latexExample) latexExample + ] + +script :: FilePath -> Double -> Double -> Double -> Double -> T.Text +script img bend transZ rotX rotY = [iTrim| +import os +import math + +import bpy + +cam = bpy.data.objects['Camera'] +cam.location = (0,0,22.25 + ${transZ}) +cam.rotation_euler = (0, 0, 0) +bpy.ops.object.empty_add(location=(0.0, 0, 0)) +focus_target = bpy.context.object +bpy.ops.object.select_all(action='DESELECT') +cam.select_set(True) +focus_target.select_set(True) +bpy.ops.object.parent_set() + +focus_target.rotation_euler = (${rotX}, 0, 0) + + +origin = bpy.data.objects['Cube'] +bpy.ops.object.select_all(action='DESELECT') +origin.select_set(True) +bpy.ops.object.delete() + +x = ${bend} +bpy.ops.mesh.primitive_plane_add() +plane = bpy.context.object +plane.scale = (16/2,${fromToS (9/2) 4 bend},1) +bpy.ops.object.shade_smooth() + +bpy.context.object.active_material = bpy.data.materials['Material'] +mat = bpy.context.object.active_material +image_node = mat.node_tree.nodes.new('ShaderNodeTexImage') +texture = mat.node_tree.nodes['Principled BSDF'] +texture.inputs['Roughness'].default_value = 1 +mat.node_tree.links.new(image_node.outputs['Color'], texture.inputs['Base Color']) + +image_node.image = bpy.data.images.load('${T.pack img}') + + +modifier = plane.modifiers.new(name='Subsurf', type='SUBSURF') +modifier.levels = 7 +modifier.render_levels = 7 +modifier.subdivision_type = 'SIMPLE' + +bpy.ops.object.empty_add(type='ARROWS',rotation=(math.pi/2,0,0)) +empty = bpy.context.object + +bendUp = plane.modifiers.new(name='Bend up', type='SIMPLE_DEFORM') +bendUp.deform_method = 'BEND' +bendUp.origin = empty +bendUp.deform_axis = 'X' +bendUp.factor = -math.pi*x + +bendAround = plane.modifiers.new(name='Bend around', type='SIMPLE_DEFORM') +bendAround.deform_method = 'BEND' +bendAround.origin = empty +bendAround.deform_axis = 'Z' +bendAround.factor = -math.pi*2*x + +bpy.context.view_layer.objects.active = plane +bpy.ops.object.modifier_apply(modifier='Subsurf') +bpy.ops.object.modifier_apply(modifier='Bend up') +bpy.ops.object.modifier_apply(modifier='Bend around') + +bpy.ops.object.select_all(action='DESELECT') +plane.select_set(True); +#bpy.ops.object.origin_set(type='ORIGIN_GEOMETRY') +bpy.ops.object.origin_clear() +bpy.ops.object.origin_set(type='GEOMETRY_ORIGIN') + +plane.rotation_euler = (0, ${rotY}, 0) + +scn = bpy.context.scene + +#scn.render.engine = 'CYCLES' +#scn.render.resolution_percentage = 10 + +scn.render.film_transparent = True + +bpy.ops.render.render( write_still=True ) +|] + +checker :: Int -> Int -> SVG +checker w h = + withStrokeColor "lightblue" $ + withStrokeWidth (defaultStrokeWidth/2) $ + mkGroup + [ withStrokeWidth 0 $ + withFillOpacity 1 $ mkBackground "grey" + , mkGroup + [ translate (stepX*x-offsetX + stepX/2) 0 $ + mkLine (0, -screenHeight/2*0.9) (0, screenHeight/2*0.9) + | x <- map fromIntegral [0..w-1] + ] + , + mkGroup + [ translate 0 (stepY*y-offsetY) $ + mkLine (-screenWidth/2, 0) (screenWidth/2, 0) + | y <- map fromIntegral [0..h] + ] + ] + where + stepX = screenWidth/fromIntegral w + stepY = screenHeight/fromIntegral h + offsetX = screenWidth/2 + offsetY = screenHeight/2 + + + + +----------------------------------- +-- COPIED FROM tut_glue_latex.hs -- + + +latexExample :: Animation +latexExample = sceneAnimation $ do + -- Draw equation + play $ drawAnimation strokedSvg + sprites <- forM glyphs $ \(fn, _, elt) -> + newSpriteA $ animate $ const $ fn elt + -- Yoink each glyph + forM_ (reverse sprites) $ \sprite -> do + spriteE sprite (overBeginning 1 $ aroundCenterE $ highlightE) + wait 0.5 + -- Flash glyphs randomly with color + forM_ (shuffleList (sprites++sprites)) $ \sprite -> do + spriteE sprite (overBeginning 0.5 $ aroundCenterE $ flashE) + wait 0.1 + wait 0.5 + mapM_ destroySprite sprites + -- Undraw equations + play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg + # reverseA + where + glyphs = svgGlyphs svg + strokedSvg = + withStrokeWidth (defaultStrokeWidth*0.5) $ + withStrokeColor "black" svg + svg = lowerTransformations $ simplify $ scale 2 $ center $ + latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" + shuffleList lst = shuffle' lst (length lst) (mkStdGen 0xdeadbeef) + +highlightE :: Effect +highlightE d t = + scale (1 + bellS 2 (t/d)*0.5) . rotate (wiggleS (t/d) * 20) + +flashE :: Effect +flashE d t = + withStrokeColor "black" . + withStrokeWidth (defaultStrokeWidth*0.5*bellS 2 (t/d)) . + withFillColorPixel (promotePixel $ turbo (t/d)) + +-- s-curve, sin, s-curve +wiggleS :: Signal +wiggleS t + | t < 0.25 = curveS 2 (t*4) + | t < 0.75 = sin ((t-0.25)*2*pi+pi/2) + | otherwise = curveS 2 ((t-0.75)*4)-1 + +-- + +drawAnimation :: SVG -> Animation +drawAnimation = drawAnimation' Nothing 0.5 0.3 + +drawAnimation' :: Maybe Int -> Double -> Double -> SVG -> Animation +drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do + forM_ (zip [0..] $ shuf $ svgGlyphs svg) $ \(n, (fn, attr, tree)) -> do + let sWidth = + case toUserUnit defaultDPI <$> getLast (attr ^. strokeWidth) of + Just (Num d) -> d + _ -> defaultStrokeWidth + fork $ do + wait (n*step) + play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree) + # applyE (overEnding fillDur $ fadeLineOutE sWidth)) + fork $ do + wait (n*step+(1-fillDur)) + newSprite $ do + t <- spriteT + pure $ + withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree + where + shuf lst = + case mbSeed of + Nothing -> lst + Just seed -> shuffle' lst (length lst) (mkStdGen seed) diff --git a/examples/tut_glue_fourier.hs b/examples/tut_glue_fourier.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_fourier.hs @@ -0,0 +1,125 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.Complex +import Graphics.SvgTree +import Linear.V2 +import Reanimate +import Reanimate.Signal +import Codec.Picture + +-- layer 3 +main :: IO () +main = reanimate $ parA bg $ sceneAnimation $ do + play $ fourierA (fromToS 0 15) -- Rotate 15 times + # setDuration 50 + # signalA (reverseS . powerS 2 . reverseS) -- Start fast, end slow + # pauseAtEnd 2 + play $ fourierA (constantS 0) -- Don't rotate at all + # setDuration 10 + # reverseA + # signalA (powerS 2) -- Start slow, end fast + # pauseAtEnd 2 + where + bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF) + +-- layer 2 +fourierA :: (Double -> Double) -> Animation +fourierA genPhi = animate $ \t -> + let circles = setFourierLength (t*piFourierLen) piFourier + coeffs = fourierCoefficients $ rotateFourier (genPhi t) circles + in mkGroup + [ drawCircles coeffs + , withStrokeColor "green" $ + withStrokeLineJoin JoinRound $ + withFillOpacity 0 $ + withStrokeWidth (defaultStrokeWidth*2) $ + mkLinePath $ mkFourierOutline circles + , let x :+ y = sum coeffs in + translate x y $ withFillColor "red" $ mkCircle (defaultStrokeWidth*3) + ] + +drawCircles :: [Complex Double] -> SVG +drawCircles [] = mkGroup [] +drawCircles ( x :+ y : xs) = + translate x y $ drawCircles' xs + +drawCircles' :: [Complex Double] -> SVG +drawCircles' circles = mkGroup + [ worker circles + , withStrokeColor "black" $ + withStrokeLineJoin JoinRound $ + withFillOpacity 0 $ + mkLinePath [ (x, y) | x :+ y <- scanl (+) 0 circles ]] + where + worker [] = None + worker (x :+ y : rest) = + let radius = sqrt(x*x+y*y) in + mkGroup + [ withStrokeColor "dimgrey" $ + withFillOpacity 0 $ + mkCircle radius + , translate x y $ worker rest ] + +-- layer 1 +newtype Fourier = Fourier {fourierCoefficients :: [Complex Double]} + +piFourier :: Fourier +piFourier = mkFourier $ lineToPoints 500 $ + toLineCommands $ extractPath $ scale 15 $ + center $ latexAlign "\\pi" + +piFourierLen :: Double +piFourierLen = sum $ map magnitude $ drop 1 $ take 500 $ fourierCoefficients piFourier + +pointAtFourier :: Fourier -> Complex Double +pointAtFourier = sum . fourierCoefficients + +mkFourier :: [RPoint] -> Fourier +mkFourier points = Fourier $ findCoefficient 0 : + concat [ [findCoefficient n, findCoefficient (-n)] | n <- [1..] ] + where + findCoefficient :: Int -> Complex Double + findCoefficient n = + sum [ toComplex point * exp (negate (fromIntegral n) * 2 *pi * i*t) * deltaT + | (idx, point) <- zip [0::Int ..] points, let t = fromIntegral idx/nPoints ] + i = 0 :+ 1 + toComplex (V2 x y) = x :+ y + deltaT = recip nPoints + nPoints = fromIntegral (length points) + +setFourierLength :: Double -> Fourier -> Fourier +setFourierLength _ (Fourier []) = Fourier [] +setFourierLength len0 (Fourier (first:lst)) = Fourier $ first : worker len0 lst + where + worker _len [] = [] + worker len (c:cs) = + if magnitude c < len + then c : worker (len - magnitude c) cs + else [c * realToFrac (len / magnitude c)] + +rotateFourier :: Double -> Fourier -> Fourier +rotateFourier phi (Fourier coeffs) = + Fourier $ worker coeffs (0::Integer) + where + worker [] _ = [] + worker (x:rest) 0 = x : worker rest 1 + worker [left] n = worker [left,0] n + worker (left:right:rest) n = + let n' = fromIntegral n in + left * exp (negate n' * 2 * pi * i * phi') : + right * exp (n' * 2 * pi * i * phi') : + worker rest (n+1) + i = 0 :+ 1 + phi' = realToFrac phi + +mkFourierOutline :: Fourier -> [(Double, Double)] +mkFourierOutline fourier = + [ (x, y) + | idx <- [0 .. granularity] + , let x :+ y = pointAtFourier $ rotateFourier (idx/granularity) fourier + ] + where + granularity = 500 diff --git a/examples/tut_glue_keyframe.hs b/examples/tut_glue_keyframe.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_keyframe.hs @@ -0,0 +1,83 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +module Main (main) where + +import Reanimate + +import Control.Monad (forM_) +import Graphics.SvgTree (Tree) +import Codec.Picture + +main :: IO () +main = reanimate $ bg `parA` mainScene + where + bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF) + +mainScene :: Animation +mainScene = sceneAnimation $ mdo + play $ drawCircle + # setDuration drawCircleT + # applyE (constE flipXAxis) + # signalA (curveS 2) + fork $ play $ drawCircle + # freezeAtPercentage 1 + # setDuration rotDur + rotDur <- withSceneDuration $ waitOn $ + forM_ svgs $ \svg -> do + fork $ play $ drawTick + # setDuration rotateT + # repeatA rotateN + # applyE (overBeginning 0.5 drawInE) + # applyE (overEnding 0.5 drawOutE) + fork $ play $ drawSVG svg + # setDuration rotateT + # repeatA rotateN + # applyE (overBeginning rotateT drawInE) + # applyE (delayE rotateT $ overBeginning 1 fillInE) + # applyE (overEnding 0.5 fadeOutE) + wait (rotateT / fromIntegral (1+length svgs)) + play $ drawCircle + # setDuration drawCircleT + # reverseA + # signalA (curveS 2) + return () + where + drawCircleT = 2.5 + rotateT = 5 + rotateN = 3 + + svgCAF = center $ latex "\\LaTeX" + getNth n = snd (splitGlyphs [n] svgCAF) + svgs = [ + withStrokeWidth 0.01 $ + scale 2 $ + translate 0 (tickLength*2) $ + withStrokeColor "black" $ + withFillColor "black" $ + center $ getNth n + | n <- [0..4]] + +radius, tickLength :: Double +radius = 1.25 +tickLength = 0.25 + +drawCircle :: Animation +drawCircle = animate $ \t -> + withFillOpacity 0 $ + withStrokeColor "black" $ + rotate (-90) $ + partialSvg t circPath + where + circPath = pathify $ mkCircle radius + +drawTick :: Animation +drawTick = drawSVG $ mkLine (0, 0) (0, tickLength) + +drawSVG :: Tree -> Animation +drawSVG svg = animate $ \t -> + withStrokeColor "black" $ + rotate (t*360) $ + translate 0 radius $ + svg diff --git a/examples/tut_glue_latex.hs b/examples/tut_glue_latex.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_latex.hs @@ -0,0 +1,94 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ApplicativeDo #-} +module Main (main) where + +import Reanimate + +import Codec.Picture +import Codec.Picture.Types +import Control.Lens ((^.)) +import Control.Monad +import Data.Monoid +import Graphics.SvgTree +import System.Random +import System.Random.Shuffle + +main :: IO () +main = reanimate $ parA bg latexExample + where + bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF) + +latexExample :: Animation +latexExample = sceneAnimation $ do + -- Draw equation + play $ drawAnimation strokedSvg + sprites <- forM glyphs $ \(fn, _, elt) -> + newSpriteA $ animate $ const $ fn elt + -- Yoink each glyph + forM_ (reverse sprites) $ \sprite -> do + spriteE sprite (overBeginning 1 $ aroundCenterE $ highlightE) + wait 0.5 + -- Flash glyphs randomly with color + forM_ (shuffleList (sprites++sprites)) $ \sprite -> do + spriteE sprite (overBeginning 0.5 $ aroundCenterE $ flashE) + wait 0.1 + wait 0.5 + mapM_ destroySprite sprites + -- Undraw equations + play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg + # reverseA + where + glyphs = svgGlyphs svg + strokedSvg = + withStrokeWidth (defaultStrokeWidth*0.5) $ + withStrokeColor "black" svg + svg = lowerTransformations $ simplify $ scale 2 $ center $ + latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" + shuffleList lst = shuffle' lst (length lst) (mkStdGen 0xdeadbeef) + +highlightE :: Effect +highlightE d t = + scale (1 + bellS 2 (t/d)*0.5) . rotate (wiggleS (t/d) * 20) + +flashE :: Effect +flashE d t = + withStrokeColor "black" . + withStrokeWidth (defaultStrokeWidth*0.5*bellS 2 (t/d)) . + withFillColorPixel (promotePixel $ turbo (t/d)) + +-- s-curve, sin, s-curve +wiggleS :: Signal +wiggleS t + | t < 0.25 = curveS 2 (t*4) + | t < 0.75 = sin ((t-0.25)*2*pi+pi/2) + | otherwise = curveS 2 ((t-0.75)*4)-1 + +-- + +drawAnimation :: SVG -> Animation +drawAnimation = drawAnimation' Nothing 0.5 0.3 + +drawAnimation' :: Maybe Int -> Double -> Double -> SVG -> Animation +drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do + forM_ (zip [0..] $ shuf $ svgGlyphs svg) $ \(n, (fn, attr, tree)) -> do + let sWidth = + case toUserUnit defaultDPI <$> getLast (attr ^. strokeWidth) of + Just (Num d) -> d + _ -> defaultStrokeWidth + fork $ do + wait (n*step) + play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree) + # applyE (overEnding fillDur $ fadeLineOutE sWidth)) + fork $ do + wait (n*step+(1-fillDur)) + newSprite $ do + t <- spriteT + return $ + withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree + where + shuf lst = + case mbSeed of + Nothing -> lst + Just seed -> shuffle' lst (length lst) (mkStdGen seed) diff --git a/examples/tut_glue_physics.hs b/examples/tut_glue_physics.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_physics.hs @@ -0,0 +1,59 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Chiphunk.Low +import Codec.Picture (PixelRGBA8 (..)) +import Control.Monad (forM_) +import Linear.V2 (V2 (..)) +import Reanimate +import Reanimate.Chiphunk +import Reanimate.PolyShape +import Reanimate.Signal +import System.IO.Unsafe (unsafePerformIO) + +shatter :: Animation +shatter = unsafePerformIO $ do + bodyStore <- newBodyStore + let gravity = Vect 0 (-1) -- Gravity points down (negative 1 y/s^2) + + space <- spaceNew + spaceGravity space $= gravity + + static <- get $ spaceStaticBody space + ground <- segmentShapeNew static + (Vect (-screenWidth/2) (-screenHeight/2)) + (Vect (screenWidth/2) (-screenHeight/2)) 0 + shapeFriction ground $= 1 + spaceAddShape space ground + + let toVect (V2 x y) = Vect x y + vectGroup = plDecompose $ svgToPolyShapes $ center $ scale 4 $ + latex "$F=ma$" + + forM_ vectGroup $ \polygon -> do + bd <- polygonsToBody space [map toVect polygon] + bodyPosition bd $= Vect 0 (screenHeight/3) + addToBodyStore bodyStore bd $ + renderPolyShape $ plFromPolygon polygon + + ani <- simulate space bodyStore fps stepsPerFrame shatterT + spaceFreeRecursive space + return $ mapA pp ani + where + shatterT = 10 + fps = 60 + stepsPerFrame = 10 + pp = withStrokeWidth 0.01 . withStrokeColor "black" . withFillColor "black" + +main :: IO () +main = reanimate $ parA bg $ sceneAnimation $ do + play $ shatter + play $ shatter + # reverseA + # setDuration 5 + # signalA (powerS 2) + where + bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF) diff --git a/examples/tut_glue_potrace.hs b/examples/tut_glue_potrace.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_potrace.hs @@ -0,0 +1,110 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Main (main) where + +import Reanimate +import Reanimate.Povray (povraySlow') + +import Codec.Picture +import Control.Monad +import Data.String.Here +import Data.Text (Text) + +main :: IO () +main = reanimate $ parA bg $ sceneAnimation $ do + play $ mkAnimation drawDuration $ \t -> partialSvg t (wireframe (-45) 220) + xRot <- newVar (-45) + yRot <- newVar 220 + wf <- newSprite $ wireframe <$> unVar xRot <*> unVar yRot + tweenVar yRot spinDur (\t v -> fromToS v (v+60*3) $ curveS 2 (t/spinDur)) + replicateM_ wobbles $ do + tweenVar xRot (wobbleDur/2) (\t v -> fromToS v (v+90) $ curveS 2 (t/(wobbleDur/2))) + fork $ do + wait (wobbleDur/2) + tweenVar xRot (wobbleDur/2) (\t v -> fromToS v (v-90) $ curveS 2 (t/(wobbleDur/2))) + wait wobbleDur + destroySprite wf + play $ mkAnimation drawDuration (\t -> partialSvg t (wireframe (-45) 220)) + # reverseA + where + drawDuration = 10 + wobbles = 3 + wobbleDur = 3 + spinDur = fromIntegral wobbles * wobbleDur + bg = animate $ const $ mkBackgroundPixel $ PixelRGBA8 252 252 252 0xFF + +wireframe :: Double -> Double -> SVG +wireframe rotX rotY = + withStrokeColor "black" $ + withStrokeWidth (defaultStrokeWidth*0.2) $ + withFillOpacity 0 $ + lowerTransformations $ + flipYAxis $ + translate (-screenWidth/2) (-screenHeight/2) $ + scale (screenWidth/2560) $ + mkPath $ extractPath $ + vectorize_ ["-t","100"] $ + povraySlow' [] $ + script (svgAsPngFile texture) rotX rotY + +texture :: SVG +texture = checker 10 10 + +script :: FilePath -> Double -> Double -> Text +script png rotX rotY = [iTrim| +#include "colors.inc" + +//Place the camera +camera { + perspective + location <0,0,-9> + look_at <0,0,0> + up y + right x*16/9 +} + +//Ambient light to "brighten up" darker pictures +global_settings { ambient_light White*3 } + +//Set a background color +background { color rgbt <0, 0, 0, 1> } // transparent + +//Sphere with specified center point and radius +sphere { + <0,0,0>, 3 + texture { + uv_mapping pigment{ + image_map{ png ${png} } + } + } + rotate <0,${rotY},0> + rotate <${rotX},0,0> +} +|] + +checker :: Int -> Int -> SVG +checker w h = + withStrokeColor "lightblue" $ + withStrokeWidth (defaultStrokeWidth*4) $ + mkGroup + [ withStrokeWidth 0 $ + withFillOpacity 0.8 $ mkBackground "white" + , mkGroup + [ translate (stepX*x-offsetX + stepX/2) 0 $ + mkLine (0, -screenHeight/2*0.9) (0, screenHeight/2*0.9) + | x <- map fromIntegral [0..w-1] + ] + , + mkGroup + [ translate 0 (stepY*y-offsetY) $ + mkLine (-screenWidth/2, 0) (screenWidth/2, 0) + | y <- map fromIntegral [0..h] + ] + ] + where + stepX = screenWidth/fromIntegral w + stepY = screenHeight/fromIntegral h + offsetX = screenWidth/2 + offsetY = screenHeight/2 diff --git a/examples/tut_glue_povray.hs b/examples/tut_glue_povray.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_povray.hs @@ -0,0 +1,161 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ApplicativeDo #-} +module Main (main) where + +import Reanimate +import Reanimate.Povray (povraySlow) + +import Codec.Picture +import Codec.Picture.Types +import Control.Lens ((^.)) +import Control.Monad +import Data.Monoid +import Data.String.Here +import Data.Text (Text) +import Graphics.SvgTree hiding (Text) +import System.Random +import System.Random.Shuffle + + +main :: IO () +main = reanimate $ parA bg $ sceneAnimation $ do + zPos <- newVar 0 + xRot <- newVar 0 + zRot <- newVar 0 + _ <- newSprite $ do + transZ <- unVar zPos + getX <- unVar xRot + getZ <- unVar zRot + t <- spriteT + dur <- spriteDuration + pure $ + povraySlow [] $ + script (svgAsPngFile (texture (t/dur))) transZ getX getZ + wait 2 + tweenVar zPos 9 (\t v -> fromToS v 8 (t/9)) + tweenVar xRot 9 (\t v -> fromToS v 360 $ curveS 2 (t/9)) + tweenVar zRot 9 (\t v -> fromToS v 360 $ curveS 2 (t/9)) + wait 10 + tweenVar zPos 2 (\t v -> fromToS v 0 $ curveS 3 (t/2)) + wait 2 + where + bg = animate $ const $ mkBackgroundPixel $ PixelRGBA8 252 252 252 0xFF + +texture :: Double -> SVG +texture t = frameAt (t*duration latexExample) latexExample + +script :: FilePath -> Double -> Double -> Double -> Text +script png transZ rotX rotZ = [iTrim| +#include "colors.inc" + +//Place the camera +camera { + perspective + location <0,0,-9> + look_at <0,0,0> + up y + right x*16/9 +} + +//Ambient light to "brighten up" darker pictures +global_settings { ambient_light White*3 } + +//Set a background color +background { color rgbt <0, 0, 0, 1> } // transparent + +polygon { + 4, + <0, 0>, <0, 1>, <1, 1>, <1, 0> + texture { + pigment{ + image_map{ png ${png} } + } + } + translate <-1/2,-1/2> + scale <16,9> + rotate <0,${rotX},${rotZ}> + translate <0,0,${transZ}> +} +|] + + +----------------------------------- +-- COPIED FROM tut_glue_latex.hs -- + + + +latexExample :: Animation +latexExample = sceneAnimation $ do + -- Draw equation + play $ drawAnimation strokedSvg + sprites <- forM glyphs $ \(fn, _, elt) -> + newSpriteA $ animate $ const $ fn elt + -- Yoink each glyph + forM_ (reverse sprites) $ \sprite -> do + spriteE sprite (overBeginning 1 $ aroundCenterE $ highlightE) + wait 0.5 + -- Flash glyphs randomly with color + forM_ (shuffleList (sprites++sprites)) $ \sprite -> do + spriteE sprite (overBeginning 0.5 $ aroundCenterE $ flashE) + wait 0.1 + wait 0.5 + mapM_ destroySprite sprites + -- Undraw equations + play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg + # reverseA + where + glyphs = svgGlyphs svg + strokedSvg = + withStrokeWidth (defaultStrokeWidth*0.5) $ + withStrokeColor "black" svg + svg = lowerTransformations $ simplify $ scale 2 $ center $ + latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" + shuffleList lst = shuffle' lst (length lst) (mkStdGen 0xdeadbeef) + +highlightE :: Effect +highlightE d t = + scale (1 + bellS 2 (t/d)*0.5) . rotate (wiggleS (t/d) * 20) + +flashE :: Effect +flashE d t = + withStrokeColor "black" . + withStrokeWidth (defaultStrokeWidth*0.5*bellS 2 (t/d)) . + withFillColorPixel (promotePixel $ turbo (t/d)) + +-- s-curve, sin, s-curve +wiggleS :: Signal +wiggleS t + | t < 0.25 = curveS 2 (t*4) + | t < 0.75 = sin ((t-0.25)*2*pi+pi/2) + | otherwise = curveS 2 ((t-0.75)*4)-1 + +-- + +drawAnimation :: SVG -> Animation +drawAnimation = drawAnimation' Nothing 0.5 0.3 + +drawAnimation' :: Maybe Int -> Double -> Double -> SVG -> Animation +drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do + forM_ (zip [0..] $ shuf $ svgGlyphs svg) $ \(n, (fn, attr, tree)) -> do + let sWidth = + case toUserUnit defaultDPI <$> getLast (attr ^. strokeWidth) of + Just (Num d) -> d + _ -> defaultStrokeWidth + fork $ do + wait (n*step) + play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree) + # applyE (overEnding fillDur $ fadeLineOutE sWidth)) + fork $ do + wait (n*step+(1-fillDur)) + newSprite $ do + t <- spriteT + return $ + withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree + where + shuf lst = + case mbSeed of + Nothing -> lst + Just seed -> shuffle' lst (length lst) (mkStdGen seed) diff --git a/examples/tut_glue_povray_ortho.hs b/examples/tut_glue_povray_ortho.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_povray_ortho.hs @@ -0,0 +1,197 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ApplicativeDo #-} +module Main (main) where + +import Reanimate +import Reanimate.Povray + +import Codec.Picture +import Codec.Picture.Types +import Control.Lens ((^.)) +import Control.Monad +import Data.Monoid +import Data.String.Here +import Data.Text (Text) +import Graphics.SvgTree hiding (Text) +import System.Random +import System.Random.Shuffle + + +main :: IO () +main = reanimate $ parA bg $ sceneAnimation $ do + xRot <- newVar (-30) + yRot <- newVar 180 + zRot <- newVar 0 + _ <- newSprite $ do + getX <- unVar xRot + getY <- unVar yRot + getZ <- unVar zRot + t <- spriteT + dur <- spriteDuration + return $ + povraySlow [] $ + script (svgAsPngFile (texture (t/dur))) getX getY getZ + wait 2 + let tDuration = 10 + tweenVar yRot tDuration (\t v -> fromToS v (v+180) $ curveS 2 (t/tDuration)) + tweenVar xRot (tDuration/2) (\t v -> fromToS v (v+60) $ curveS 2 (t/(tDuration/2))) + fork $ do + wait (tDuration/2) + tweenVar xRot (tDuration/2) (\t v -> fromToS v (v-60) $ curveS 2 (t/(tDuration/2))) + wait tDuration + wait 2 + where + bg = animate $ const $ mkBackgroundPixel $ PixelRGBA8 252 252 252 0xFF + +texture :: Double -> SVG +texture t = mkGroup + [ checker 20 20 + , frameAt (t*duration latexExample) latexExample + ] + +script :: FilePath -> Double -> Double -> Double -> Text +script png rotX rotY rotZ = [iTrim| +//Files with predefined colors and textures +#include "colors.inc" + +#include "shapes3.inc" + +//Place the camera +camera { + orthographic + location <0,0,-10> + look_at <0,0,0> + up y*9 + right x*16 +} + + +//Ambient light to "brighten up" darker pictures +global_settings { ambient_light White*3 } + +//Set a background color +//background { color White } +//background { color rgbt <0.1, 0, 0, 0> } // red +background { color rgbt <0, 0, 0, 1> } // transparent + +//Sphere with specified center point and radius +sphere { + <0,0,0>, 4 + texture { + uv_mapping pigment{ + image_map{ png ${png} } + } + } + rotate <0,${rotY},${rotZ}> + rotate <${rotX},0,0> +} + +|] + +checker :: Int -> Int -> SVG +checker w h = + withStrokeColor "lightblue" $ + withStrokeWidth (defaultStrokeWidth/2) $ + mkGroup + [ withStrokeWidth 0 $ + withFillOpacity 0.8 $ mkBackground "white" + , mkGroup + [ translate (stepX*x-offsetX + stepX/2) 0 $ + mkLine (0, -screenHeight/2*0.9) (0, screenHeight/2*0.9) + | x <- map fromIntegral [0..w-1] + ] + , + mkGroup + [ translate 0 (stepY*y-offsetY) $ + mkLine (-screenWidth/2, 0) (screenWidth/2, 0) + | y <- map fromIntegral [0..h] + ] + ] + where + stepX = screenWidth/fromIntegral w + stepY = screenHeight/fromIntegral h + offsetX = screenWidth/2 + offsetY = screenHeight/2 + + + + +----------------------------------- +-- COPIED FROM tut_glue_latex.hs -- + + +latexExample :: Animation +latexExample = sceneAnimation $ do + -- Draw equation + play $ drawAnimation strokedSvg + sprites <- forM glyphs $ \(fn, _, elt) -> + newSpriteA $ animate $ const $ fn elt + -- Yoink each glyph + forM_ (reverse sprites) $ \sprite -> do + spriteE sprite (overBeginning 1 $ aroundCenterE $ highlightE) + wait 0.5 + -- Flash glyphs randomly with color + forM_ (shuffleList (sprites++sprites)) $ \sprite -> do + spriteE sprite (overBeginning 0.5 $ aroundCenterE $ flashE) + wait 0.1 + wait 0.5 + mapM_ destroySprite sprites + -- Undraw equations + play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg + # reverseA + where + glyphs = svgGlyphs svg + strokedSvg = + withStrokeWidth (defaultStrokeWidth*0.5) $ + withStrokeColor "black" svg + svg = lowerTransformations $ simplify $ scale 2 $ center $ + latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" + shuffleList lst = shuffle' lst (length lst) (mkStdGen 0xdeadbeef) + +highlightE :: Effect +highlightE d t = + scale (1 + bellS 2 (t/d)*0.5) . rotate (wiggleS (t/d) * 20) + +flashE :: Effect +flashE d t = + withStrokeColor "black" . + withStrokeWidth (defaultStrokeWidth*0.5*bellS 2 (t/d)) . + withFillColorPixel (promotePixel $ turbo (t/d)) + +-- s-curve, sin, s-curve +wiggleS :: Signal +wiggleS t + | t < 0.25 = curveS 2 (t*4) + | t < 0.75 = sin ((t-0.25)*2*pi+pi/2) + | otherwise = curveS 2 ((t-0.75)*4)-1 + +-- + +drawAnimation :: SVG -> Animation +drawAnimation = drawAnimation' Nothing 0.5 0.3 + +drawAnimation' :: Maybe Int -> Double -> Double -> SVG -> Animation +drawAnimation' mbSeed fillDur step svg = sceneAnimation $ do + forM_ (zip [0..] $ shuf $ svgGlyphs svg) $ \(n, (fn, attr, tree)) -> do + let sWidth = + case toUserUnit defaultDPI <$> getLast (attr ^. strokeWidth) of + Just (Num d) -> d + _ -> defaultStrokeWidth + fork $ do + wait (n*step) + play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree) + # applyE (overEnding fillDur $ fadeLineOutE sWidth)) + fork $ do + wait (n*step+(1-fillDur)) + newSprite $ do + t <- spriteT + return $ + withStrokeWidth 0 $ fn $ withFillOpacity (min 1 $ t/fillDur) tree + where + shuf lst = + case mbSeed of + Nothing -> lst + Just seed -> shuffle' lst (length lst) (mkStdGen seed) diff --git a/examples/tut_glue_svg.hs b/examples/tut_glue_svg.hs new file mode 100644 --- /dev/null +++ b/examples/tut_glue_svg.hs @@ -0,0 +1,103 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate +import Reanimate.Transition +import Reanimate.Builtin.Images + +import Codec.Picture +import Control.Lens +import Data.Text (Text) +import Graphics.SvgTree hiding (Text) + +bgColor :: PixelRGBA8 +bgColor = PixelRGBA8 252 252 252 0xFF + +framePause :: Double +framePause = 3 + +transitionTime :: Double +transitionTime = 0.5 + +main :: IO () +main = reanimate $ bg `parA` chainT (overlapT transitionTime fadeT) + [comp1, comp2, comp3, comp4, comp5, comp6, comp7, setDuration transitionTime comp1] + where + bg = animate $ const $ mkBackgroundPixel bgColor + comp1 = svgComponent "Circles" (mkCircle 2) + comp2 = svgComponent "Rects" (mkRect 4 3) + comp3 = svgComponent "Lines" (mkLine (-2,0) (2,0)) + comp4 = svgComponent "Images" (scale 0.5 svgLogo) + comp5 = svgComponent "Paths" $ + withFillOpacity 0 $ + scale 8 $ withStrokeWidth (defaultStrokeWidth*0.3) $ + center $ latex "$\\pi$" + comp6 = svgComponent "Blurs" mkBlur + comp7 = svgComponent "Blobs" mkBlob + +svgComponent :: Text -> SVG -> Animation +svgComponent txt svg = mkAnimation framePause $ const $ + mkGroup + [ translate 0 (-1) $ + withStrokeWidth (defaultStrokeWidth*2) $ + withStrokeColor "red" $ withFillColor "black" svg + , translate 0 3 $ + withFillColor "black" $ scale 2 $ center $ latex txt + ] + +mkBlur :: SVG +mkBlur = mkGroup + [ FilterTree $ mkFilter "blur" + [FEGaussianBlur $ defaultSvg + & gaussianBlurStdDeviationX .~ Num dev + & filterResult ?~ "blur" + ] & filterWidth .~ pure (Percent 3) + & filterX .~ pure (Percent (-1)) + & filterHeight .~ pure (Percent 3) + & filterY .~ pure (Percent (-1)) + , circ + & filterRef .~ pure (Ref "blur") + ] + where + dev = 0.2 + radius = 2 + circ = mkCircle radius + +mkBlob :: SVG +mkBlob = + mkGroup + [ FilterTree $ mkFilter "goo" + [FEGaussianBlur $ defaultSvg + & gaussianBlurStdDeviationX .~ Num dev + & filterResult ?~ "blur" + ,FEColorMatrix $ defaultSvg + & colorMatrixType .~ Matrix + & colorMatrixValues .~ "1 0 0 0 0 \ + \0 1 0 0 0 \ + \0 0 1 0 0 \ + \0 0 0 " ++ show (sharpness*2) ++ " -" ++ show sharpness + & filterResult .~ pure "goo" + ,FEComposite $ defaultSvg + & compositeIn .~ pure SourceGraphic + & compositeIn2 .~ pure (SourceRef "goo") + & compositeOperator .~ CompositeAtop + ] & filterWidth .~ pure (Percent 3) + & filterX .~ pure (Percent (-1)) + & filterHeight .~ pure (Percent 3) + & filterY .~ pure (Percent (-1)) + , withStrokeWidth 0 $ withFillColor "red" $ mkGroup + [ translate (0.9*(-radius)) 0 circ + , translate (0.9*radius) 0 circ + ] & filterRef .~ pure (Ref "goo") + ] + where + sharpness = 10 :: Integer + dev = 0.2 + radius = 2 + circ = mkCircle radius + + +mkFilter :: String -> [FilterElement] -> Filter +mkFilter ident fe = defaultSvg & filterChildren .~ fe & attrId ?~ ident diff --git a/examples/vector_field.hs b/examples/vector_field.hs --- a/examples/vector_field.hs +++ b/examples/vector_field.hs @@ -1,9 +1,11 @@ #!/usr/bin/env stack -- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Main (main) where +main :: IO () +main = return () +{- import Diagrams.Prelude hiding (Animation, boundingBox, center, circle, duration, fontSize, rotate, scale, @@ -55,3 +57,5 @@ arrows = map arrowAtPoint locs field = position $ zip points arrows +-} + diff --git a/reanimate.cabal b/reanimate.cabal --- a/reanimate.cabal +++ b/reanimate.cabal @@ -3,7 +3,7 @@ -- see http://haskell.org/cabal/users-guide/ name: reanimate -version: 0.1.9.0 +version: 0.2.0.0 -- synopsis: -- description: license: PublicDomain @@ -23,15 +23,14 @@ viewer and auto-reloader. -data-files: viewer/build/*.js - viewer/build/*.html - viewer/build/static/js/2.822530b2.chunk.js - viewer/build/static/js/main.b15b405f.chunk.js - viewer/build/static/js/runtime~main.9eb600ee.js - viewer/build/static/css/main.f7ad3e9b.chunk.css +data-files: viewer-elm/dist/index.html + viewer-elm/dist/elm.js + viewer-elm/dist/style.css data/CIExyz.csv data/CIE_XYZ.csv data/cone_sensitivity_lms.csv + data/*.svg + data/*.jpg Source-Repository head Type: git @@ -51,9 +50,8 @@ Reanimate.Svg.Constructors Reanimate.Svg.BoundingBox Reanimate.Svg.LineCommand - Reanimate.Diagrams + -- Reanimate.Diagrams Reanimate.Transform - Reanimate.Driver Reanimate.Misc Reanimate.Raster Reanimate.ColorMap @@ -62,27 +60,35 @@ Reanimate.Memo Reanimate.Scene Reanimate.Povray + Reanimate.Blender + Reanimate.Transition Reanimate.Effect Reanimate.Builtin.TernaryPlot + Reanimate.Builtin.CirclePlot + Reanimate.Builtin.Flip Reanimate.Constants + Reanimate.Parameters Reanimate.Chiphunk Reanimate.PolyShape + Reanimate.GeoProjection Reanimate.Builtin.Documentation + Reanimate.Builtin.Images other-modules: Reanimate.Cache + Reanimate.Driver Reanimate.Driver.Check Reanimate.Driver.CLI Reanimate.Driver.Server Reanimate.Driver.Compile Paths_reanimate - build-depends: base >=4.10 && <4.13, + build-depends: base >=4.10 && <5, time, text, filepath, process, directory, - containers, reanimate-svg >= 0.9.3.0, xml, bytestring, lens, linear, mtl, matrix, - JuicyPixels, attoparsec, parallel, diagrams, diagrams-svg, - diagrams-core, diagrams-lib, diagrams-contrib, - svg-builder, cubicbezier, palette, websockets, + containers, reanimate-svg >= 0.9.7.0, xml, bytestring, lens, linear, mtl, matrix, + JuicyPixels, attoparsec, parallel, + cubicbezier, websockets, hashable, fsnotify, open-browser, random-shuffle, base64-bytestring, vector, colour, cassava, ansi-wl-pprint, here, temporary, - optparse-applicative, chiphunk >= 0.1.2.0 + optparse-applicative, chiphunk >= 0.1.2.1, + geojson, aeson >= 1.3.0.0 ghc-options: -Wall test-suite spec diff --git a/src/Reanimate.hs b/src/Reanimate.hs --- a/src/Reanimate.hs +++ b/src/Reanimate.hs @@ -23,13 +23,17 @@ -- * Animations are rendered with increasing fidelity until the frame -- rate eaches 60 fps. -- * Key commands for pausing, frame stepping, forward/rewind. + -- To pause press SPACE, to move -1\/+1\/-10\/+10 frames use LEFT\/RIGHT\/DOWN\/UP arrow keys. reanimate, -- * Animations SVG, + Time, Animation(..), mkAnimation, animate, + staticFrame, duration, + frameAt, -- ** Composition seqA, parA, @@ -47,6 +51,7 @@ playThenReverseA, repeatA, freezeAtPercentage, + addStatic, signalA, -- ** Signals Signal, @@ -59,19 +64,66 @@ fromListS, -- ** Scenes (#), - ZIndex, - Scene, - sceneAnimation, - fork, - play, - playZ, - queryNow, - waitAll, - waitUntil, - wait, - adjustZ , - withSceneDuration, + Scene + , ZIndex + , sceneAnimation -- :: (forall s. Scene s a) -> Animation + , play -- :: Animation -> Scene s () + , fork -- :: Scene s a -> Scene s a + , queryNow -- :: Scene s Time + , wait -- :: Duration -> Scene s () + , waitUntil -- :: Time -> Scene s () + , waitOn -- :: Scene s a -> Scene s a + , adjustZ -- :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a + , withSceneDuration -- :: Scene s () -> Scene s Duration + -- *** Variables + , Var + , newVar -- :: a -> Scene s (Var s a) + , readVar -- :: Var s a -> Scene s a + , writeVar -- :: Var s a -> a -> Scene s () + , modifyVar -- :: Var s a -> (a -> a) -> Scene s () + , tweenVar -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + , tweenVarUnclamped -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + , simpleVar -- :: (a -> SVG) -> a -> Scene s (Var s a) + , findVar -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) + -- *** Sprites + , Sprite + , Frame + , unVar -- :: Var s a -> Frame s a + , spriteT -- :: Frame s Time + , spriteDuration -- :: Frame s Duration + , newSprite -- :: Frame s SVG -> Scene s (Sprite s) + , newSpriteA -- :: Animation -> Scene s (Sprite s) + , newSpriteA' -- :: Sync -> Animation -> Scene s (Sprite s) + , newSpriteSVG -- :: SVG -> Scene s (Sprite s) + , destroySprite -- :: Sprite s -> Scene s () + , applyVar -- :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () + , spriteModify -- :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s () + , spriteMap -- :: Sprite s -> (SVG -> SVG) -> Scene s () + , spriteTween -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () + , spriteVar -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) + , spriteE -- :: Sprite s -> Effect -> Scene s () + , spriteZ, -- :: Sprite s -> ZIndex -> Scene s () + -- ** Effects + Effect, + overBeginning, + overEnding, + overInterval, + reverseE, + delayE, + applyE, + constE, + fadeInE, + fadeOutE, + fadeLineInE, + fadeLineOutE, + drawInE, + drawOutE, + fillInE, + scaleE, + translateE, + aroundCenterE, + -- * SVG module Reanimate.Svg.Constructors, module Reanimate.Svg.LineCommand, @@ -82,11 +134,18 @@ embedDynamicImage, embedPng, raster, + svgAsPngFile, + vectorize, + vectorize_, -- ** External SVG providers latex, latexAlign, xelatex, + -- * External 3D renderers povray, + povray', + blender, + blender', -- * Colormaps turbo, viridis, @@ -104,19 +163,26 @@ screenWidth, screenHeight, defaultDPI, - defaultStrokeWidth + defaultStrokeWidth, + -- * Parameters + pFPS, + pHeight, + pWidth ) where import Reanimate.Animation +import Reanimate.Blender import Reanimate.ColorMap import Reanimate.Constants import Reanimate.Driver import Reanimate.LaTeX +import Reanimate.Parameters import Reanimate.Povray import Reanimate.Raster +import Reanimate.Effect +import Reanimate.Scene import Reanimate.Signal import Reanimate.Svg import Reanimate.Svg.BoundingBox import Reanimate.Svg.Constructors import Reanimate.Svg.LineCommand -import Reanimate.Scene diff --git a/src/Reanimate/Animation.hs b/src/Reanimate/Animation.hs --- a/src/Reanimate/Animation.hs +++ b/src/Reanimate/Animation.hs @@ -1,8 +1,50 @@ -module Reanimate.Animation where +module Reanimate.Animation + ( Duration + , Time + , SVG + , Animation(..) -- TODO should this be exposed? The constructor is used directly in Effect.hs + -- * Creating animations + , mkAnimation + , animate + , staticFrame + , pause + -- * Querying animations + , duration + , frameAt + -- * Composing animations + , seqA + , andThen + , parA + , parLoopA + , parDropA + -- * Modifying animations + , setDuration + , adjustDuration + , mapA + , takeA + , dropA + , lastA + , pauseAtEnd + , pauseAtBeginning + , pauseAround + , pauseUntil + , repeatA + , reverseA + , playThenReverseA + , signalA + , freezeAtPercentage + , addStatic + -- * Misc + , (#) + , getAnimationFrame + , Sync(..) + -- * Rendering + , renderTree + , renderSvg + ) where import Control.Arrow () import Data.Fixed (mod') -import qualified Data.Map as M import Graphics.SvgTree (Alignment (..), Document (..), Number (..), PreserveAspectRatio (..), @@ -26,10 +68,14 @@ mkAnimation :: Duration -> (Time -> SVG) -> Animation mkAnimation = Animation --- | Construct animation with a duration of @1@. +-- | Construct an animation with a duration of @1@. animate :: (Time -> SVG) -> Animation animate = Animation 1 +-- | Create an animation with provided @duration@, which consists of stationary frame displayed for its entire duration. +staticFrame :: Duration -> SVG -> Animation +staticFrame d svg = Animation d (const svg) + -- | Query the duration of an animation. duration :: Animation -> Duration duration (Animation d _) = d @@ -129,15 +175,21 @@ andThen :: Animation -> Animation -> Animation andThen a b = a `parA` (pause (duration a) `seqA` b) -frameAt :: Double -> Animation -> Tree +-- | Calculate the frame that would be displayed at given point in @time@ of running @animation@. +-- +-- The provided time parameter is clamped between 0 and animation duration. +frameAt :: Time -> Animation -> SVG frameAt t (Animation d f) = f t' where - t' = min 1 (max 0 (t/d)) + t' = clamp 0 1 (t/d) -renderTree :: Tree -> String +renderTree :: SVG -> String renderTree t = maybe "" ppElement $ xmlOfTree t -renderSvg :: Maybe Number -> Maybe Number -> Tree -> String +renderSvg :: Maybe Number -- ^ The number to use as value of the @width@ attribute of the resulting top-level svg element. If @Nothing@, the width attribute won't be rendered. + -> Maybe Number -- ^ Similar to previous argument, but for @height@ attribute. + -> SVG -- ^ SVG to render + -> String -- ^ String representation of SVG XML markup renderSvg w h t = ppDocument doc -- renderSvg w h t = ppFastElement (xmlOfDocument doc) where @@ -148,7 +200,6 @@ , _width = w , _height = h , _elements = [withStrokeWidth defaultStrokeWidth $ scaleXY 1 (-1) t] - , _definitions = M.empty , _description = "" , _documentLocation = "" , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing @@ -162,7 +213,7 @@ -- -- <> -mapA :: (Tree -> Tree) -> Animation -> Animation +mapA :: (SVG -> SVG) -> Animation -> Animation mapA fn (Animation d f) = Animation d (fn . f) -- | Freeze the last frame for @t@ seconds at the end of the animation. @@ -202,7 +253,7 @@ pauseUntil d a = pauseAtEnd (d-duration a) a -- Freeze frame at time @t@. -freezeFrame :: Double -> Animation -> (Time -> SVG) +freezeFrame :: Time -> Animation -> (Time -> SVG) freezeFrame t (Animation d f) = const $ f (t/d) -- | Change the duration of an animation. Animates are stretched or squished @@ -251,10 +302,26 @@ repeatA n (Animation d f) = Animation (d*n) $ \t -> f ((t*n) `mod'` 1) -freezeAtPercentage :: Time -> Animation -> Animation + +-- | @freezeAtPercentage time animation@ creates an animation consisting of stationary frame, +-- that would be displayed in the provided @animation@ at given @time@. +-- The duration of the new animation is the same as the duration of provided @animation@. +freezeAtPercentage :: Time -- ^ value between 0 and 1. The frame displayed at this point in the original animation will be displayed for the duration of the new animation + -> Animation -- ^ original animation, from which the frame will be taken + -> Animation -- ^ new animation consisting of static frame displayed for the duration of the original animation freezeAtPercentage frac (Animation d genFrame) = Animation d $ const $ genFrame frac +-- | Overlay animation on top of static SVG image. +-- +-- Example: +-- +-- > addStatic (mkBackground "lightblue") drawCircle +-- +-- <> +addStatic :: SVG -> Animation -> Animation +addStatic static = mapA (\frame -> mkGroup [static, frame]) + -- | Modify the time component of an animation. Animation duration is unchanged. -- -- Example: @@ -264,3 +331,52 @@ -- <> signalA :: Signal -> Animation -> Animation signalA fn (Animation d gen) = Animation d $ gen . fn + +-- | @takeA duration animation@ creates a new animation consisting of initial segment of +-- @animation@ of given @duration@, played at the same rate as the original animation. +-- +-- The @duration@ parameter is clamped to be between 0 and @animation@'s duration. +-- New animation duration is equal to (eventually clamped) @duration@. +takeA :: Duration -> Animation -> Animation +takeA len (Animation d gen) = Animation len' $ \t -> + gen (t * len'/d) + where + len' = clamp 0 d len + +-- | @dropA duration animation@ creates a new animation by dropping initial segment +-- of length @duration@ from the provided @animation@, played at the same rate as the original animation. +-- +-- The @duration@ parameter is clamped to be between 0 and @animation@'s duration. +-- The duration of the resulting animation is duration of provided @animation@ minus (eventually clamped) @duration@. +dropA :: Duration -> Animation -> Animation +dropA len (Animation d gen) = Animation len' $ \t -> + gen (t * len'/d + len/d) + where + len' = d - clamp 0 d len + +lastA :: Duration -> Animation -> Animation +lastA len a = dropA (duration a - len) a + +clamp :: Double -> Double -> Double -> Double +clamp a b number + | a < b = max a (min b number) + | otherwise = max b (min a number) + +(#) :: a -> (a -> b) -> b +o # f = f o + +getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG +getAnimationFrame sync (Animation aDur aGen) t d = + case sync of + SyncStretch -> aGen (t/d) + SyncLoop -> aGen (takeFrac $ t/aDur) + SyncDrop -> if t > aDur then None else aGen (t/aDur) + SyncFreeze -> aGen (min 1 $ t/aDur) + where + takeFrac f = snd (properFraction f :: (Int, Double)) + +data Sync + = SyncStretch + | SyncLoop + | SyncDrop + | SyncFreeze diff --git a/src/Reanimate/Blender.hs b/src/Reanimate/Blender.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Blender.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +module Reanimate.Blender + ( blender + , blender' + ) where + +import Codec.Picture.Png +import qualified Data.ByteString as B +import Data.Text (Text) +-- import qualified Data.Text as T +import qualified Data.Text.IO as T +import Graphics.SvgTree (Tree (..)) +import Reanimate.Cache +import Reanimate.Misc +import Reanimate.Raster +import Reanimate.Parameters +import Reanimate.Animation +import Reanimate.Svg.Constructors +import System.FilePath (replaceExtension, (<.>)) +import System.IO.Unsafe (unsafePerformIO) +import Data.Hashable + +blender :: Text -> SVG +blender script = + unsafePerformIO $ mkBlenderImage script + +blender' :: Text -> FilePath +blender' script = + unsafePerformIO $ mkBlenderImage' script + +mkBlenderImage :: Text -> IO Tree +mkBlenderImage script | pNoExternals = pure $ mkText script +mkBlenderImage script = do + png <- B.readFile =<< mkBlenderImage' script + case decodePng png of + Left{} -> error "bad image" + Right img -> return $ center $ scaleToSize 16 9 $ embedDynamicImage img + +mkBlenderImage' :: Text -> IO FilePath +mkBlenderImage' _ | pNoExternals = pure "/blender/has/been/disabled" +mkBlenderImage' script = cacheFile template $ \target -> do + exec <- requireExecutable "blender" + let py_file = replaceExtension target "py" + T.writeFile py_file script + runCmd exec [ "--background","--render-format", "PNG" + , "--python-exit-code", "1" + , "--render-output", target, "--python", py_file] + where + template = show (hash script) <.> "png" diff --git a/src/Reanimate/Builtin/CirclePlot.hs b/src/Reanimate/Builtin/CirclePlot.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Builtin/CirclePlot.hs @@ -0,0 +1,31 @@ +module Reanimate.Builtin.CirclePlot where + +import Codec.Picture +import Graphics.SvgTree (Tree) +import Reanimate.Raster +import Reanimate.Svg +import Reanimate.Constants + +-- | Circle plots are scaled to 'screenHeight'. +-- +-- Example: +-- +-- > circlePlot 500 $ \ang r -> +-- > promotePixel $ toRGB8 $ uncurryRGB sRGB $ hsv (ang/pi*180) r 1 +-- +-- <> +circlePlot :: Int -- ^ Number of diagonal pixels. Only affects quality, not size. + -> (Double -> Double -> PixelRGBA8) + -- ^ Angle and radius in radians and percent respectively. + -> Tree +circlePlot density fn = + scaleToHeight screenHeight $ flipYAxis $ + embedImage $ generateImage gen density density + where + cN = fromIntegral $ density `div` 2 - 1 + gen x y = + let radius = sqrt ((fromIntegral x-cN)**2 + (fromIntegral y-cN)**2) + ang = atan2 (fromIntegral y-cN) (fromIntegral x-cN) + in if radius > cN + then PixelRGBA8 0 0 0 0 + else fn ang (radius / cN) diff --git a/src/Reanimate/Builtin/Flip.hs b/src/Reanimate/Builtin/Flip.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Builtin/Flip.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ApplicativeDo #-} +{- HLINT ignore -} +module Reanimate.Builtin.Flip + ( FlipSprite(..) + , flipSprite + , flipTransition + , flipTransitionOpts + ) where + +import Reanimate.Animation +import Reanimate.Blender +import Reanimate.Raster +import Reanimate.Scene +import Reanimate.Signal +import Reanimate.Transition +import Reanimate.Svg.Constructors + +import Data.String.Here +import qualified Data.Text as T + +data FlipSprite s = FlipSprite + { fsSprite :: Sprite s + , fsBend :: Var s Double + , fsZoom :: Var s Double + , fsWobble :: Var s Double + } + +flipSprite :: Animation -> Animation -> Scene s (FlipSprite s) +flipSprite front back = do + bend <- newVar 0 + trans <- newVar 0 + rotX <- newVar 0 + s <- newSprite $ do + getBend <- unVar bend + getTrans <- unVar trans + getRotX <- unVar rotX + t <- spriteT + dur <- spriteDuration + return $ + let rotY = fromToS 0 pi (t/dur) + frontTexture = svgAsPngFile (frameAt t $ setDuration dur front) + backTexture = svgAsPngFile (flipXAxis $ frameAt t $ setDuration dur back) + -- seq'ing frontTexture and backTexture is required to avoid segfaults. :( + in frontTexture `seq` backTexture `seq` + blender (script frontTexture backTexture getBend getTrans getRotX rotY) + return FlipSprite + { fsSprite = s + , fsBend = bend + , fsZoom = trans + , fsWobble = rotX } + +flipTransitionOpts :: Double -> Double -> Double -> Transition +flipTransitionOpts bend zoom wobble a b = sceneAnimation $ do + FlipSprite{..} <- flipSprite a b + fork $ tweenVar fsZoom dur $ \v -> fromToS v zoom . oscillateS + fork $ tweenVar fsBend dur $ \v -> fromToS v bend . oscillateS + fork $ tweenVar fsWobble dur $ \v -> fromToS v wobble . oscillateS + where + dur = max (duration a) (duration b) + +flipTransition :: Transition +flipTransition = flipTransitionOpts bend zoom wobble + where + bend = 1/3 + zoom = 3 + wobble = -pi*0.10 + +script :: FilePath -> FilePath -> Double -> Double -> Double -> Double -> T.Text +script frontImage backImage bend transZ rotX rotY = [iTrim| +import os +import math + +import bpy + +light = bpy.data.objects['Light'] +bpy.ops.object.select_all(action='DESELECT') +light.select_set(True) +bpy.ops.object.delete() + + +cam = bpy.data.objects['Camera'] +cam.location = (0,0,22.22 + ${transZ}) +cam.rotation_euler = (0, 0, 0) +bpy.ops.object.empty_add(location=(0.0, 0, 0)) +focus_target = bpy.context.object +bpy.ops.object.select_all(action='DESELECT') +cam.select_set(True) +focus_target.select_set(True) +bpy.ops.object.parent_set() + +focus_target.rotation_euler = (${rotX}, 0, 0) + + +origin = bpy.data.objects['Cube'] +bpy.ops.object.select_all(action='DESELECT') +origin.select_set(True) +bpy.ops.object.delete() + +x = ${bend} +bpy.ops.mesh.primitive_plane_add() +plane = bpy.context.object +plane.scale = (16/2,${fromToS (9/2) 4 bend},1) +bpy.ops.object.shade_smooth() + +bpy.context.object.active_material = bpy.data.materials['Material'] +mat = bpy.context.object.active_material +mix = mat.node_tree.nodes.new('ShaderNodeMixShader') +geo = mat.node_tree.nodes.new('ShaderNodeNewGeometry') + +mat.blend_method = 'HASHED' + +image_node = mat.node_tree.nodes.new('ShaderNodeTexImage') +gh_node = mat.node_tree.nodes.new('ShaderNodeTexImage') +output = mat.node_tree.nodes['Material Output'] + +gh_mix = mat.node_tree.nodes.new('ShaderNodeMixShader') +transparent = mat.node_tree.nodes.new('ShaderNodeBsdfTransparent') + +mat.node_tree.links.new(geo.outputs['Backfacing'], mix.inputs['Fac']) +mat.node_tree.links.new(mix.outputs['Shader'], output.inputs['Surface']) +mat.node_tree.links.new(image_node.outputs['Color'], mix.inputs[1]) + +#mat.node_tree.links.new(gh_node.outputs['Color'], mix.inputs[2]) +mat.node_tree.links.new(gh_node.outputs['Color'], gh_mix.inputs[2]) +mat.node_tree.links.new(gh_node.outputs['Alpha'], gh_mix.inputs['Fac']) +mat.node_tree.links.new(transparent.outputs['BSDF'], gh_mix.inputs[1]) +mat.node_tree.links.new(gh_mix.outputs['Shader'], mix.inputs[2]) + +image_node.image = bpy.data.images.load('${T.pack frontImage}') +image_node.interpolation = 'Closest' + +gh_node.image = bpy.data.images.load('${T.pack backImage}') +gh_node.interpolation = 'Closest' + + +modifier = plane.modifiers.new(name='Subsurf', type='SUBSURF') +modifier.levels = 7 +modifier.render_levels = 7 +modifier.subdivision_type = 'SIMPLE' + +bpy.ops.object.empty_add(type='ARROWS',rotation=(math.pi/2,0,0)) +empty = bpy.context.object + +bendUp = plane.modifiers.new(name='Bend up', type='SIMPLE_DEFORM') +bendUp.deform_method = 'BEND' +bendUp.origin = empty +bendUp.deform_axis = 'X' +bendUp.factor = -math.pi*x + +bendAround = plane.modifiers.new(name='Bend around', type='SIMPLE_DEFORM') +bendAround.deform_method = 'BEND' +bendAround.origin = empty +bendAround.deform_axis = 'Z' +bendAround.factor = -math.pi*2*x + +bpy.context.view_layer.objects.active = plane +bpy.ops.object.modifier_apply(modifier='Subsurf') +bpy.ops.object.modifier_apply(modifier='Bend up') +bpy.ops.object.modifier_apply(modifier='Bend around') + +bpy.ops.object.select_all(action='DESELECT') +plane.select_set(True); +bpy.ops.object.origin_clear() +bpy.ops.object.origin_set(type='GEOMETRY_ORIGIN') + +plane.rotation_euler = (0, ${rotY}, 0) + +scn = bpy.context.scene + +#scn.render.engine = 'CYCLES' +#scn.render.resolution_percentage = 10 + +scn.view_settings.view_transform = 'Standard' + + +scn.render.resolution_x = 2560 +scn.render.resolution_y = 1440 + +scn.render.film_transparent = True + +bpy.ops.render.render( write_still=True ) +|] diff --git a/src/Reanimate/Builtin/Images.hs b/src/Reanimate/Builtin/Images.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Builtin/Images.hs @@ -0,0 +1,51 @@ +module Reanimate.Builtin.Images + ( svgLogo + , haskellLogo + , githubIcon + , smallEarth + ) where + +import Codec.Picture +import qualified Data.ByteString as B +import Graphics.SvgTree (parseSvgFile) +import Paths_reanimate +import Reanimate.Animation +import Reanimate.Svg +import System.IO.Unsafe + +embedImage :: FilePath -> IO SVG +embedImage key = do + svg_file <- getDataFileName key + svg_data <- B.readFile svg_file + case parseSvgFile svg_file svg_data of + Nothing -> error "Malformed svg" + Just svg -> return $ embedDocument svg + +loadJPG :: FilePath -> Image PixelRGBA8 +loadJPG key = unsafePerformIO $ do + jpg_file <- getDataFileName key + dat <- B.readFile jpg_file + case decodeJpeg dat of + Left err -> error err + Right img -> return $ convertRGBA8 img + +{- HLINT ignore svgLogo -} +-- | <> +svgLogo :: SVG +svgLogo = unsafePerformIO $ embedImage "data/svg-logo.svg" + +{- HLINT ignore haskellLogo -} +-- | <> +haskellLogo :: SVG +haskellLogo = unsafePerformIO $ embedImage "data/haskell.svg" + +{- HLINT ignore githubIcon -} +-- | <> +githubIcon :: SVG +githubIcon = unsafePerformIO $ embedImage "data/github-icon.svg" + +-- | 300x150 equirectangular earth +-- +-- <> +smallEarth :: Image PixelRGBA8 +smallEarth = loadJPG "data/small_earth.jpg" diff --git a/src/Reanimate/Cache.hs b/src/Reanimate/Cache.hs --- a/src/Reanimate/Cache.hs +++ b/src/Reanimate/Cache.hs @@ -1,27 +1,43 @@ module Reanimate.Cache - ( cacheMem + ( cacheFile -- :: FilePath -> (FilePath -> IO ()) -> IO FilePath + , cacheMem , cacheDisk , cacheDiskSvg , cacheDiskKey , cacheDiskLines ) where +import Control.Monad (unless) import Data.Hashable import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Graphics.SvgTree (Tree (..), unparse) -import Reanimate.Animation (renderTree) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Graphics.SvgTree (Tree (..), unparse) +import Reanimate.Animation (renderTree) import System.Directory import System.FilePath import System.IO +import Control.Exception import System.IO.Unsafe -import Text.XML.Light (Content (..), parseXML) +import Text.XML.Light (Content (..), parseXML) +import System.IO.Temp -- Memory cache and disk cache + +cacheFile :: FilePath -> (FilePath -> IO ()) -> IO FilePath +cacheFile template gen = do + root <- getXdgDirectory XdgCache "reanimate" + createDirectoryIfMissing True root + let path = root template + hit <- doesFileExist path + unless hit $ withSystemTempFile template $ \tmp h -> do + hClose h + gen tmp + renameFile tmp path + evaluate path cacheDisk :: (T.Text -> Maybe a) -> (a -> T.Text) -> (Text -> IO a) -> (Text -> IO a) cacheDisk parse render gen key = do diff --git a/src/Reanimate/Chiphunk.hs b/src/Reanimate/Chiphunk.hs --- a/src/Reanimate/Chiphunk.hs +++ b/src/Reanimate/Chiphunk.hs @@ -49,9 +49,9 @@ angle <- get $ bodyAngle body let bodySvg = translate posX posY $ - rotate (angle/pi*180) $ + rotate (angle/pi*180) svg - modifyIORef lst $ (bodySvg:) + modifyIORef lst (bodySvg:) ) nullPtr result <- readIORef lst return $ mkGroup result @@ -72,7 +72,7 @@ in frozen V.! key polyShapesToBody :: Space -> [PolyShape] -> IO Body -polyShapesToBody space poly = do +polyShapesToBody space poly = polygonsToBody space (map (map toVect) $ plDecompose poly) where toVect (V2 x y) = Vect x y @@ -87,6 +87,7 @@ shapeDensity polyShape $= 1 spaceAddShape space polyShape shapeFriction polyShape $= 0.7 + shapeElasticity polyShape $= 0.5 return plBody spaceFreeRecursive :: Space -> IO () diff --git a/src/Reanimate/ColorMap.hs b/src/Reanimate/ColorMap.hs --- a/src/Reanimate/ColorMap.hs +++ b/src/Reanimate/ColorMap.hs @@ -163,9 +163,9 @@ pi_1_3 = pi / 3 pi_2_3 = pi * 2 / 3 x = (0.5 - t) * pi - r = round $ 255 * sin(x)**2 - g = round $ 255 * sin(x+pi_1_3)**2 - b = round $ 255 * sin(x+pi_2_3)**2 + r = round $ 255 * sin x**2 + g = round $ 255 * sin (x+pi_1_3)**2 + b = round $ 255 * sin (x+pi_2_3)**2 -- | Given a number t in the range [0,1], returns the corresponding color from -- the “cividis” color vision deficiency-optimized color scheme designed by @@ -499,7 +499,7 @@ toColor _ = error "Reanimate.ColorMap.colors: Broken data" ramp :: Vector PixelRGB8 -> Double -> PixelRGB8 -ramp v = \t -> v V.! (max 0 $ min (len-1) $ round $ t * (len'-1)) +ramp v = \t -> v V.! max 0 (min (len-1) $ round $ t * (len'-1)) where len = V.length v len' = fromIntegral len diff --git a/src/Reanimate/ColorSpace.hs b/src/Reanimate/ColorSpace.hs --- a/src/Reanimate/ColorSpace.hs +++ b/src/Reanimate/ColorSpace.hs @@ -16,7 +16,7 @@ type Nanometer = Integer - +{-# NOINLINE lightXYZCoordinates #-} lightXYZCoordinates :: Map Nanometer (Double, Double, Double) lightXYZCoordinates = unsafePerformIO $ do dat <- BS.readFile =<< getDataFileName "data/CIExyz.csv" @@ -25,6 +25,7 @@ Right vec -> return $ Map.fromList [ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ] +{-# NOINLINE bigXYZCoordinates #-} bigXYZCoordinates :: Map Nanometer (Double, Double, Double) bigXYZCoordinates = unsafePerformIO $ do dat <- BS.readFile =<< getDataFileName "data/CIE_XYZ.csv" @@ -33,10 +34,15 @@ Right vec -> return $ Map.fromList [ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ] +nmToColor :: Nanometer -> Maybe (Colour Double) +nmToColor nm = do + (x, y, z) <- Map.lookup nm bigXYZCoordinates + return $ cieXYZ x y z + renderXYZCoordinates :: Tree renderXYZCoordinates = withFillOpacity 0 $ - mkLinePath $ + mkLinePath [ (x, 1-y) | (_nm, (x,y,_z)) <- Map.toList lightXYZCoordinates ] @@ -49,11 +55,12 @@ renderLABCoordinates :: Tree renderLABCoordinates = withFillOpacity 0 $ - mkLinePath $ + mkLinePath [ (a/350, (1-b)/150) | (_nm, (_l,a,b)) <- Map.toList lightLABCoordinates ] +{-# NOINLINE coneSensitivity #-} -- (Long, Medium, Short) coneSensitivity :: Map Nanometer (Double, Double, Double) coneSensitivity = unsafePerformIO $ do diff --git a/src/Reanimate/Diagrams.hs b/src/Reanimate/Diagrams.hs deleted file mode 100644 --- a/src/Reanimate/Diagrams.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reanimate.Diagrams - ( renderDiagram - , SvgDiagram - ) where - -import qualified Data.ByteString.Lazy as BL -import qualified Diagrams.Backend.SVG as D -import qualified Diagrams.Core.Types as D -import Diagrams.Prelude -import qualified Graphics.Svg.Core as Svg -import Graphics.SvgTree (Tree (..), parseSvgFile) -import Reanimate.Svg.Unuse (unbox) - -renderDiagram :: SvgDiagram -> Tree -renderDiagram d = - case parseSvgFile "" (BL.toStrict $ Svg.renderBS (renderDia D.SVG opts d)) of - Nothing -> error "Malformed svg" - Just svg -> unbox svg - where - -- opts = SVGOptions (mkSizeSpec (V2 Nothing Nothing)) Nothing "" [] False - opts = D.SVGOptions absolute Nothing "" [] False - -type SvgDiagram = D.Diagram D.SVG diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -1,18 +1,21 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} module Reanimate.Driver ( reanimate ) where -import Control.Monad +import Control.Applicative ((<|>)) import Data.Maybe import Reanimate.Animation (Animation) import Reanimate.Driver.Check import Reanimate.Driver.CLI import Reanimate.Driver.Compile import Reanimate.Driver.Server +import Reanimate.Parameters import Reanimate.Render (FPS, Format (..), Height, Width, - render, renderSnippets, renderSvgs) + render, renderSnippets, renderSvgs) import System.Directory import System.FilePath import Text.Printf +import Data.Either presetFormat :: Preset -> Format presetFormat Youtube = RenderMp4 @@ -20,6 +23,7 @@ presetFormat Quick = RenderMp4 presetFormat MediumQ = RenderMp4 presetFormat HighQ = RenderMp4 +presetFormat LowFPS = RenderMp4 presetFPS :: Preset -> FPS presetFPS Youtube = 60 @@ -27,6 +31,7 @@ presetFPS Quick = 15 presetFPS MediumQ = 30 presetFPS HighQ = 30 +presetFPS LowFPS = 10 presetWidth :: Preset -> Width presetWidth Youtube = 2560 @@ -34,6 +39,7 @@ presetWidth Quick = 320 presetWidth MediumQ = 800 presetWidth HighQ = 1920 +presetWidth LowFPS = presetWidth HighQ presetHeight :: Preset -> Height presetHeight preset = presetWidth preset * 9 `div` 16 @@ -92,8 +98,9 @@ reanimate animation = do Options{..} <- getDriverOptions case optsCommand of - Raw -> renderSvgs animation + Raw -> setFPS 60 >> renderSvgs animation Test -> do + setNoExternals True -- hSetBinaryMode stdout True renderSnippets animation Check -> checkEnvironment @@ -119,12 +126,12 @@ RenderWebm -> replaceExtension self "webm" Just target -> makeAbsolute target - let fps = guessParameter renderFPS (fmap presetFPS renderPreset) $ - (formatFPS fmt) - width = guessParameter renderWidth (fmap presetWidth renderPreset) $ - (formatWidth fmt) - height = guessParameter renderHeight (fmap presetHeight renderPreset) $ - (formatHeight fmt) + let fps = guessParameter renderFPS (fmap presetFPS renderPreset) $ formatFPS fmt + (width, height) = + fromMaybe + ( maybe (formatWidth fmt) presetWidth renderPreset + , maybe (formatHeight fmt) presetHeight renderPreset ) + (userPreferredDimensions renderWidth renderHeight) if renderCompile then @@ -134,9 +141,13 @@ ,"--width", show width ,"--height", show height ,"--format", showFormat fmt + ,"--raster", showRaster renderRaster ,"--target", target ,"+RTS", "-N", "-RTS"] else do + setFPS fps + setWidth width + setHeight height printf "Animation options:\n\ \ fps: %d\n\ \ width: %d\n\ @@ -144,9 +155,33 @@ \ fmt: %s\n\ \ target: %s\n" fps width height (showFormat fmt) target - render animation target fmt width height fps - + raster <- selectRaster renderRaster + render animation target raster fmt width height fps +selectRaster :: Raster -> IO Raster +selectRaster RasterAuto = do + rsvg <- hasRSvg + ink <- hasInkscape + conv <- hasConvert + if | isRight rsvg -> pure RasterRSvg + | isRight ink -> pure RasterInkscape + | isRight conv -> pure RasterConvert + | otherwise -> pure RasterNone +selectRaster r = pure r guessParameter :: Maybe a -> Maybe a -> a -> a -guessParameter a b def = fromMaybe def (a `mplus` b) +guessParameter a b def = fromMaybe def (a <|> b) + + +-- If user specifies exactly one dimension explicitly, calculate the other +userPreferredDimensions :: Maybe Width -> Maybe Height -> Maybe (Width, Height) +userPreferredDimensions (Just width) (Just height) = Just (width, height) +userPreferredDimensions (Just width) Nothing = Just (width, makeEven $ width * 9 `div` 16) +userPreferredDimensions Nothing (Just height) = Just (makeEven $ height * 16 `div` 9, height) +userPreferredDimensions Nothing Nothing = Nothing + +-- Avoid ffmpeg failures "height not divisible by 2" +makeEven :: Int -> Int +makeEven x + | even x = x + | otherwise = x - 1 diff --git a/src/Reanimate/Driver/CLI.hs b/src/Reanimate/Driver/CLI.hs --- a/src/Reanimate/Driver/CLI.hs +++ b/src/Reanimate/Driver/CLI.hs @@ -1,19 +1,22 @@ -{-# LANGUAGE RecordWildCards #-} module Reanimate.Driver.CLI ( getDriverOptions , Options(..) , Command(..) , Preset(..) , Format(..) + , Raster(..) , showFormat + , showRaster ) where import Data.Char -import Data.Monoid ((<>)) +import Data.Monoid import Options.Applicative -import Reanimate.Render (Format (..), Width, Height, FPS) +import Prelude +import Reanimate.Render (FPS, Format (..), Height, Raster (..), + Width) -data Options = Options +newtype Options = Options { optsCommand :: Command } deriving (Show) @@ -30,12 +33,30 @@ , renderCompile :: Bool , renderFormat :: Maybe Format , renderPreset :: Maybe Preset + , renderRaster :: Raster } deriving (Show) -data Preset = Youtube | ExampleGif | Quick | MediumQ | HighQ +data Preset = Youtube | ExampleGif | Quick | MediumQ | HighQ | LowFPS deriving (Show) +readRaster :: String -> Maybe Raster +readRaster raster = + case map toLower raster of + "none" -> Just RasterNone + "auto" -> Just RasterAuto + "inkscape" -> Just RasterInkscape + "rsvg" -> Just RasterRSvg + "convert" -> Just RasterConvert + _ -> Nothing + +showRaster :: Raster -> String +showRaster RasterNone = "none" +showRaster RasterAuto = "auto" +showRaster RasterInkscape = "inkscape" +showRaster RasterRSvg = "rsvg" +showRaster RasterConvert = "convert" + readFormat :: String -> Maybe Format readFormat fmt = case map toLower fmt of @@ -57,6 +78,7 @@ "quick" -> Just Quick "medium" -> Just MediumQ "high" -> Just HighQ + "lowfps" -> Just LowFPS _ -> Nothing showPreset :: Preset -> String @@ -65,6 +87,7 @@ showPreset Quick = "quick" showPreset MediumQ = "medium" showPreset HighQ = "high" +showPreset LowFPS = "lowfps" options :: Parser Options options = Options <$> commandP @@ -82,7 +105,7 @@ <|> infoParser viewCommand rawCommand :: ParserInfo Command -rawCommand = info (parse) +rawCommand = info parse (progDesc "Output raw SVGs for animation at 60 fps. Used internally by viewer.") where parse = pure Raw @@ -142,6 +165,11 @@ (long "preset" <> showDefaultWith showPreset <> metavar "TYPE" <> help "Parameter presets: youtube, gif, quick, medium, high")) + <*> option (maybeReader readRaster) + (long "raster" <> showDefaultWith showRaster + <> metavar "RASTER" + <> value RasterNone + <> help "Raster engine: none, auto, inkscape, rsvg, convert") opts :: ParserInfo Options opts = info (options <**> helper ) diff --git a/src/Reanimate/Driver/Check.hs b/src/Reanimate/Driver/Check.hs --- a/src/Reanimate/Driver/Check.hs +++ b/src/Reanimate/Driver/Check.hs @@ -1,6 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module Reanimate.Driver.Check ( checkEnvironment + , hasRSvg + , hasInkscape + , hasConvert ) where import Control.Exception (SomeException, handle) @@ -22,15 +25,19 @@ checkEnvironment = do putStrLn "reanimate checks:" runCheck "Has ffmpeg" hasFFmpeg - runCheck "Has LaTeX" hasLaTeX - runCheck "Has XeLaTeX" hasXeLaTeX runCheck "Has dvisvgm" hasDvisvgm runCheck "Has povray" hasPovray + runCheck "Has blender" hasBlender + runCheck "Has rsvg-convert" hasRSvg + runCheck "Has inkscape" hasInkscape + runCheck "Has convert" hasConvert + runCheck "Has LaTeX" hasLaTeX runCheck ("Has LaTeX package '"++ "babel" ++ "'") $ hasTeXPackage "latex" "[english]{babel}" forM_ latexPackages $ \pkg -> runCheck ("Has LaTeX package '"++ pkg ++ "'") $ hasTeXPackage "latex" $ "{"++pkg++"}" + runCheck "Has XeLaTeX" hasXeLaTeX forM_ xelatexPackages $ \pkg -> runCheck ("Has XeLaTeX package '"++ pkg ++ "'") $ hasTeXPackage "xelatex" $ "{"++pkg++"}" @@ -38,20 +45,21 @@ latexPackages = ["preview" ,"amsmath" - ,"amssymb" - ,"dsfont" - ,"setspace" - ,"relsize" - ,"textcomp" - ,"mathrsfs" - ,"calligra" - ,"wasysym" - ,"ragged2e" - ,"physics" - ,"xcolor" - ,"textcomp" - ,"xfrac" - ,"microtype"] + --,"amssymb" + --,"dsfont" + --,"setspace" + --,"relsize" + --,"textcomp" + --,"mathrsfs" + --,"calligra" + --,"wasysym" + --,"ragged2e" + --,"physics" + --,"xcolor" + --,"textcomp" + --,"xfrac" + --,"microtype" + ] xelatexPackages = ["ctex"] runCheck msg fn = do @@ -76,35 +84,82 @@ hasPovray = hasProgram "povray" hasFFmpeg :: IO (Either String String) -hasFFmpeg = do - mbVersion <- ffmpegVersion - return $ case mbVersion of - Nothing -> Left "no" - Just vs | vs < minVersion -> Left $ "too old: " ++ showVersion vs ++ " < " ++ showVersion minVersion - | otherwise -> Right (showVersion vs) +hasFFmpeg = checkMinVersion minVersion <$> ffmpegVersion where minVersion = Version [4,1,3] [] +hasBlender :: IO (Either String String) +hasBlender = checkMinVersion minVersion <$> blenderVersion + where + minVersion = Version [2,80] [] + +hasRSvg :: IO (Either String String) +hasRSvg = checkMinVersion minVersion <$> rsvgVersion + where + minVersion = Version [2,44,0] [] + +hasInkscape :: IO (Either String String) +hasInkscape = checkMinVersion minVersion <$> inkscapeVersion + where + minVersion = Version [0,92] [] + +hasConvert :: IO (Either String String) +hasConvert = checkMinVersion minVersion <$> convertVersion + where + minVersion = Version [6,0,0] [] + ffmpegVersion :: IO (Maybe Version) -ffmpegVersion = do - mbPath <- findExecutable "ffmpeg" +ffmpegVersion = extractVersion "ffmpeg" ["-version"] $ \line -> + case take 3 $ words line of + ["ffmpeg", "version", vs] -> vs + _ -> "" + +blenderVersion :: IO (Maybe Version) +blenderVersion = extractVersion "blender" ["--version"] $ \line -> + case take 2 (words line) of + ["Blender", vs] -> vs + _ -> "" + +rsvgVersion :: IO (Maybe Version) +rsvgVersion = extractVersion "rsvg-convert" ["--version"] $ \line -> + case words line of + ["rsvg-convert", "version", vs] -> vs + _ -> "" + +inkscapeVersion :: IO (Maybe Version) +inkscapeVersion = extractVersion "inkscape" ["--version"] $ \line -> + case take 2 $ words line of + ["Inkscape", vs] -> vs + _ -> "" + +convertVersion :: IO (Maybe Version) +convertVersion = extractVersion "convert" ["-version"] $ \line -> + case take 3 $ words line of + ["Version:", "ImageMagick", vs] -> vs + _ -> "" + +checkMinVersion :: Version -> Maybe Version -> Either String String +checkMinVersion _minVersion Nothing = Left "no" +checkMinVersion minVersion (Just vs) + | vs < minVersion = Left $ "too old: " ++ showVersion vs ++ " < " ++ showVersion minVersion + | otherwise = Right (showVersion vs) + +extractVersion :: FilePath -> [String] -> (String -> String) -> IO (Maybe Version) +extractVersion execPath args outputFilter = do + mbPath <- findExecutable execPath case mbPath of - Nothing -> return Nothing + Nothing -> return Nothing Just path -> do - ret <- runCmd_ path ["-version"] + ret <- runCmd_ path args case ret of Left{} -> return $ Just noVersion Right out -> - case map (take 3 . words) $ take 1 $ lines out of - [["ffmpeg", "version", vs]] -> - return $ Just $ fromMaybe noVersion $ parseVS vs - _ -> return $ Just noVersion + pure $ Just $ fromMaybe noVersion $ parseVS $ outputFilter out where noVersion = Version [] [] parseVS vs = listToMaybe $ reverse [ v | (v, _) <- readP_to_S parseVersion vs ] - hasTeXPackage :: FilePath -> String -> IO (Either String String) hasTeXPackage exec pkg = handle (\(_::SomeException) -> return $ Left "n/a") $ withSystemTempDirectory "reanimate" $ \tmp_dir -> withTempFile tmp_dir "test.tex" $ \tex_file tex_handle -> do @@ -128,5 +183,5 @@ hasProgram exec = do mbPath <- findExecutable exec return $ case mbPath of - Nothing -> Left $ "'" ++ exec ++ "'' not found" + Nothing -> Left $ "'" ++ exec ++ "' not found" Just path -> Right path diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs --- a/src/Reanimate/Driver/Server.hs +++ b/src/Reanimate/Driver/Server.hs @@ -4,22 +4,22 @@ , findOwnSource ) where -import Control.Concurrent (forkIO, killThread, modifyMVar_, - newEmptyMVar, putMVar, takeMVar, - threadDelay) -import Control.Concurrent.MVar +import Control.Concurrent import Control.Exception (SomeException, catch, finally) import Control.Monad import Control.Monad.Fix (fix) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.Text.Read as T import GHC.Environment (getFullArgs) import Network.WebSockets import Paths_reanimate import Reanimate.Misc (runCmdLazy, runCmd_) -import System.Directory (doesFileExist, findFile, +import System.Directory (createDirectoryIfMissing, + doesFileExist, findFile, listDirectory, makeAbsolute, + removeDirectoryRecursive, withCurrentDirectory) import System.Environment (getProgName) import System.Exit @@ -54,73 +54,93 @@ then do putStrLn "Already connected to browser. Rejecting." rejectRequestWith pending defaultRejectRequest - else do + else withSystemTempDirectory "reanimate-svgs" $ \tmpDir -> do + createDirectoryIfMissing True tmpDir conn <- acceptRequest pending slave <- newEmptyMVar let handler = modifyMVar_ slave $ \tid -> do putStrLn "Reloading code..." killThread tid - forkIO $ ignoreErrors $ slaveHandler conn self + forkIO $ ignoreErrors $ slaveHandler conn self tmpDir killSlave = do tid <- takeMVar slave killThread tid stop <- watchFile watch self handler putMVar slave =<< forkIO (return ()) + handler let loop = do - -- FIXME: We don't use fps here. - _fps <- receiveData conn :: IO T.Text + -- FIXME: We don't use msg here. + _msg <- receiveData conn :: IO T.Text handler loop - loop `finally` (swapMVar hasConnectionVar False >> stop >> killSlave) + loop `finally` (removeDirectoryRecursive tmpDir >> swapMVar hasConnectionVar False >> stop >> killSlave) ignoreErrors :: IO () -> IO () ignoreErrors action = action `catch` \(_::SomeException) -> return () openViewer :: IO () openViewer = do - url <- getDataFileName "viewer/build/index.html" + url <- getDataFileName "viewer-elm/dist/index.html" putStrLn "Opening browser..." bSucc <- openBrowser url if bSucc then putStrLn "Browser opened." else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url -slaveHandler :: Connection -> FilePath -> IO () -slaveHandler conn self = +slaveHandler :: Connection -> FilePath -> FilePath -> IO () +slaveHandler conn self svgDir = withCurrentDirectory (takeDirectory self) $ withSystemTempDirectory "reanimate" $ \tmpDir -> withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do + -- cap <- getNumCapabilities + let n = 25 + sem <- newQSemN n hClose handle - sendTextData conn (T.pack "Compiling") + lock <- newMVar () + sendTextData conn (T.pack "status\nCompiling") ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [takeFileName self, "-o", tmpExecutable] case ret of Left err -> - sendTextData conn $ T.pack $ "Error" ++ unlines (drop 3 (lines err)) + sendTextData conn $ T.pack $ "error\n" ++ unlines (drop 3 (lines err)) Right{} -> runCmdLazy tmpExecutable execOpts $ \getFrame -> do - (frameCount,_) <- expectFrame =<< getFrame - sendTextData conn (T.pack $ show frameCount) + (frameCount,_) <- expectFrame sem =<< getFrame + sendTextData conn (T.pack $ "frame_count\n" ++ show frameCount) fix $ \loop -> do - (frameIdx, frame) <- expectFrame =<< getFrame - sendTextData conn (T.pack $ show frameIdx) - sendTextData conn frame + (frameIdx, frame) <- expectFrame sem =<< getFrame + -- putStrLn $ "Got frame: " ++ show frameIdx + let fileName = svgDir takeBaseName tmpExecutable <.> show frameIdx <.> "svg" + -- pngName = replaceExtension fileName "png" + _ <- forkIO $ do + waitQSemN sem 1 + T.writeFile fileName frame + -- runCmd "rsvg-convert" + -- [ fileName + -- , "--width=256" -- "--width=1024" + -- , "--height=144" -- "--height=576" + -- , "--output", pngName ] + withMVar lock $ \_ -> + sendTextData conn (T.pack $ "frame\n" ++ show frameIdx ++ "\n" ++ fileName) + signalQSemN sem 1 loop where - execOpts = ["raw", "+RTS", "-N", "-M1G", "-RTS"] - expectFrame :: Either String Text -> IO (Integer, Text) - expectFrame (Left "") = do - sendTextData conn (T.pack "Done") + execOpts = ["raw", "+RTS", "-N", "-M2G", "-RTS"] + expectFrame :: QSemN -> Either String Text -> IO (Integer, Text) + expectFrame sem (Left "") = do + waitQSemN sem 25 -- =<< getNumCapabilities + sendTextData conn (T.pack "status\nDone") exitSuccess - expectFrame (Left err) = do + expectFrame _ (Left err) = do sendTextData conn $ T.pack $ "Error" ++ err exitWith (ExitFailure 1) - expectFrame (Right frame) = + expectFrame _ (Right frame) = case T.decimal frame of Left err -> do hPutStrLn stderr (T.unpack frame) hPutStrLn stderr $ "expectFrame: " ++ err - sendTextData conn $ T.pack $ "Error" ++ err + sendTextData conn $ T.pack $ "error\n" ++ err exitWith (ExitFailure 1) - Right (frameNumber, rest) -> pure (frameNumber, rest) + Right (frameNumber, rest) -> + pure (frameNumber, rest) watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening watchFile watch file action = watchTree watch (takeDirectory file) check (const action) diff --git a/src/Reanimate/Effect.hs b/src/Reanimate/Effect.hs --- a/src/Reanimate/Effect.hs +++ b/src/Reanimate/Effect.hs @@ -1,50 +1,130 @@ -module Reanimate.Effect where +{-| Effects represent modifications applied to frames of the 'Animation'. +Effects can (and usually do) depend on time. +One or more effects can be applied over the entire duration of animation, or modified to affect +only a specific portion at the beginning \/ middle \/ end of the animation. +-} +module Reanimate.Effect + ( -- * Primitive Effects + Effect + , fadeInE + , fadeOutE + , fadeLineInE + , fadeLineOutE + , fillInE + , drawInE + , drawOutE + , translateE + , scaleE + , constE + -- * Modifying Effects + , overBeginning + , overEnding + , overInterval + , reverseE + , delayE + , aroundCenterE + -- * Applying Effects to Animations + , applyE + ) where import Graphics.SvgTree (Tree) import Reanimate.Animation import Reanimate.Svg -type Effect = Double -> Double -> Tree -> Tree +-- | An Effect represents a modification of a SVG 'Tree' that can vary with time. +type Effect = Duration -- ^ Duration of the effect (in seconds) + -> Time -- ^ Time elapsed from when the effect started (in seconds) + -> Tree -- ^ Image to be modified + -> Tree -- ^ Image after modification -overBeginning :: Double -> Effect -> Effect -overBeginning maxT fn = \_d t -> +-- | Modify the effect so that it only applies to the initial part of the animation. +overBeginning :: Duration -- ^ Duration of the initial segment of the animation over which the Effect should be applied + -> Effect -- ^ The Effect to modify + -> Effect -- ^ Effect which will only affect the initial segment of the animation +overBeginning maxT effect _d t = if t < maxT - then fn maxT t + then effect maxT t else id -overEnding :: Double -> Effect -> Effect -overEnding minT fn d t = +-- | Modify the effect so that it only applies to the ending part of the animation. +overEnding :: Duration -- ^ Duration of the ending segment of the animation over which the Effect should be applied + -> Effect -- ^ The Effect to modify + -> Effect -- ^ Effect which will only affect the ending segment of the animation +overEnding minT effect d t = if t >= blankDur - then fn minT (t-blankDur) + then effect minT (t-blankDur) else id where blankDur = d-minT +-- | Modify the effect so that it only applies within given interval of animation's running time. +overInterval :: Time -- ^ time after start of animation when the effect should start + -> Time -- ^ time after start of the animation when the effect should finish + -> Effect -- ^ The Effect to modify + -> Effect -- ^ Effect which will only affect the specified interval within the animation +overInterval start end effect _d t = + if start <= t && t <= end + then effect dur ((t - start) / dur) + else id + where + dur = end - start + +-- | @reverseE effect@ starts where the @effect@ ends and vice versa. reverseE :: Effect -> Effect -reverseE fn = \d t -> fn d (d-t) +reverseE fn d t = fn d (d-t) -delayE :: Double -> Effect -> Effect -delayE delayT fn = \d t -> overEnding (d-delayT) fn d t +-- | Delay the effect so that it only starts after specified duration and then runs till the end of animation. +delayE :: Duration -> Effect -> Effect +delayE delayT fn d = overEnding (d-delayT) fn d +-- | Modify the animation by applying the effect. If desired, you can apply multiple effects to single animation by calling this function multiple times. applyE :: Effect -> Animation -> Animation applyE fn (Animation d genFrame) = Animation d $ \t -> fn d (d*t) $ genFrame t +-- | Build an effect from an image-modifying function. This effect does not change as time passes. constE :: (Tree -> Tree) -> Effect constE fn _d _t = fn +-- | Change image opacity from 0 to 1. fadeInE :: Effect fadeInE d t = withGroupOpacity (t/d) +-- | Change image opacity from 1 to 0. Reverse of 'fadeInE'. fadeOutE :: Effect fadeOutE = reverseE fadeInE +-- | Change stroke width from 0 to given value. +fadeLineInE :: Double -> Effect +fadeLineInE w d t = withStrokeWidth (w*(t/d)) + +-- | Change stroke width from given value to 0. Reverse of 'fadeLineInE'. +fadeLineOutE :: Double -> Effect +fadeLineOutE = reverseE . fadeLineInE + +-- | Effect of progressively drawing the image. Note that this will only affect primitive shapes (see 'pathify'). drawInE :: Effect drawInE d t = withFillOpacity 0 . partialSvg (t/d) . pathify +-- | Reverse of 'drawInE'. drawOutE :: Effect drawOutE = reverseE drawInE +-- | Change fill opacity from 0 to 1. fillInE :: Effect fillInE d t = withFillOpacity f where f = t/d + +-- | Change scale from 1 to given value. +scaleE :: Double -> Effect +scaleE target d t = scale (1 + (target-1) * t/d) + +-- | Move the image from its current position to the target x y coordinates. +translateE :: Double -> Double -> Effect +translateE x y d t = translate (x * t/d) (y * t/d) + +-- | Transform the effect so that the image passed to the effect's image-modifying +-- function has coordinates (0, 0) shifted to the center of its bounding box. +-- Also see 'aroundCenter'. +aroundCenterE :: Effect -> Effect +aroundCenterE e d t = aroundCenter (e d t) diff --git a/src/Reanimate/GeoProjection.hs b/src/Reanimate/GeoProjection.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/GeoProjection.hs @@ -0,0 +1,791 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +module Reanimate.GeoProjection + ( Projection(..) + , XYCoord(..) + , LonLat(..) + , project + , interpP + , mergeP + , isValidP + , scaleP + , flipYAxisP + , moveBottomP + , moveTopP + -- * Projections + , equirectangularP + , mercatorP + , mollweideP + , hammerP + , lambertP + , bottomleyP + , sinusoidalP + , wernerP + , bonneP + , orthoP + , cassiniP + , augustP + , collignonP + , eckert1P + , eckert3P + , eckert5P + , faheyP + , foucautP + , lagrangeP + -- * GeoJSON helpers + , drawFeatureCollection -- :: GeoFeatureCollection a -> (a -> SVG -> SVG) -> SVG + , loadFeatureCollection -- :: FromJSON a => FilePath -> (a -> SVG -> SVG) -> SVG + , applyProjection -- :: Projection -> SVG -> SVG + , applyProjection' -- :: Double -> Projection -> SVG -> SVG + , renderGeometry + ) where + +import Codec.Picture +import Codec.Picture.Types +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.ST +import Data.Aeson +import Data.Foldable +import Data.Geospatial hiding (LonLat) +import Data.LinearRing +import qualified Data.LineString as Line +import Debug.Trace +import Graphics.SvgTree (Tree (None)) +import Linear (distance, lerp) +import Linear.V2 hiding (angle) +import Reanimate +import System.IO.Unsafe + + +-- Constants +halfPi, sqrtPi, sqrt2, epsilon, tau :: Double +halfPi = pi/2 +sqrtPi = sqrt pi +sqrt2 = sqrt 2 +epsilon = 1.0e-12 +tau = pi*2 + +toRads, cot :: Double -> Double +toRads dec = dec/180 * pi +cot = recip . tan + +srcPixel :: Pixel pixel => Image pixel -> LonLat -> pixel +srcPixel src (LonLat lam phi) = + pixelAt src xPx yPx + where + !xPx = round $ ((lam+pi)/tau) * fromIntegral (imageWidth src-1) + !yPx = round $ (1-((phi+halfPi)/pi)) * fromIntegral (imageHeight src-1) + +{- HLINT ignore -} +findValidCoord :: Image pixel -> Projection -> XYCoord -> XYCoord +findValidCoord !src !p (XYCoord x y) = foldr const (XYCoord x y) + [ XYCoord x' y' + | let !xi = round $ x * wMax + !yi = round $ y * hMax + , !ax <- [xi, xi-1, xi+1] + , ax >= 0 + , ax < w + , let !x' = fromIntegral ax / wMax + , !ay <- [yi, yi-1, yi+1] + , ay >= 0 + , ay < h + , let !y' = fromIntegral ay / hMax + , validLonLat $! projectionInverse p $! XYCoord x' y' + ] + where + !w = imageWidth src + !h = imageHeight src + !wMax = fromIntegral (w-1) + !hMax = fromIntegral (h-1) + +isInWorld :: Projection -> XYCoord -> Bool +isInWorld p coord = + odd $ length $ isInWorld' p coord + +isInWorld' :: Projection -> XYCoord -> [(Double, Double)] +isInWorld' p (XYCoord x y) = + [ (x1, y1) + | (XYCoord x1 y1, XYCoord x2 y2) <- world + , (y1 > y) /= (y2 > y) -- y is between y1 and y2 + , x < (x2 - x1) * (y - y1) / (y2 - y1) + x1 -- x is to the left of the line + ] + where + world = worldPolygon p + +worldPolygon :: Projection -> [(XYCoord, XYCoord)] +worldPolygon p = + interp (-pi, -halfPi) (-pi, halfPi) ++ + interp (-pi, halfPi) (pi, halfPi) ++ + interp (pi, halfPi) (pi, -halfPi) ++ + interp (pi, -halfPi) (-pi, -halfPi) + where + apply (lam, phi) = projectionForward p $ LonLat lam phi + steps = 100 + interp (x1, y1) (x2,y2) = + [ ( apply (fromToS x1 x2 (n/steps), fromToS y1 y2 (n/steps)) + , apply (fromToS x1 x2 ((n+1)/steps), fromToS y1 y2 ((n+1)/steps))) + | n <- [0..steps-1]] + +findNearestPixel :: MutableImage s PixelRGBA8 -> Int -> Int -> Int -> Int -> ST s PixelRGBA8 +findNearestPixel src w h srcX srcY = worker $ take 20 + [ (x, y) + | n <- [1..] + , x <- [srcX-n .. srcY+n] + , y <- if x == srcX-n || x == srcX+n then [srcY-n,srcY+n] else [srcY-n .. srcY+n] + , x >= 0 + , y >= 0 + , x < w + , y < h + ] + where + worker [] = pure $ PixelRGBA8 0xFF 0x00 0x00 0xFF + worker ((x,y):rest) = do + this <- readPixel src x y + if this == blank + then worker rest + else return this + blank = PixelRGBA8 0x00 0x00 0x00 0x00 + +interpP :: Image PixelRGBA8 -> Projection -> Projection -> Double -> Image PixelRGBA8 +interpP !src !p1 !p2 !t = runST $ do + !img <- newMutableImage w h + let blank = PixelRGBA8 0x00 0x00 0x00 0x00 + let isBlank pixel = pixel == blank + -- forM_ [0..w-1] $ \x -> + -- forM_ [0..h-1] $ \y -> do + -- let x1 = fromIntegral x / (wMax) + -- y1 = 1 - fromIntegral y / (hMax) + -- when (isInWorld (mergeP p1 p2 t) (XYCoord x1 y1)) $ + -- writePixel img x y $ PixelRGBA8 0xFF 0x00 0x00 0xFF + let factor = 2 + let l1 = + loopTo (w*factor) $ \x -> do + loopTo (h*factor) $ \y -> do + let !x1' = fromIntegral x / (wMax*fromIntegral factor) + !y1' = fromIntegral y / (hMax*fromIntegral factor) + !lonlat = projectionInverse p1 $! XYCoord x1' y1' + p = srcPixel src lonlat + when (validLonLat lonlat && pixelOpacity p /= 0) $ do + let XYCoord x1 y1 = projectionForward p1 lonlat + XYCoord x2 y2 = findValidCoord src p2 $ projectionForward p2 lonlat + !x3 = round $ fromToS x1 x2 t * wMax + !y3 = round $ (1 - fromToS y1 y2 t) * hMax + when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ + writePixel img x3 y3 p + l2 = + loopTo (w*factor) $ \x -> + loopTo (h*factor) $ \y -> do + let !x2' = fromIntegral x / (wMax*fromIntegral factor) + !y2' = fromIntegral y / (hMax*fromIntegral factor) + !lonlat = projectionInverse p2 (XYCoord x2' y2') + p = srcPixel src lonlat + when (validLonLat lonlat && pixelOpacity p /= 0) $ do + let XYCoord x2 y2 = projectionForward p2 lonlat + XYCoord x1 y1 = findValidCoord src p1 $ projectionForward p1 lonlat + !x3 = round $ fromToS x1 x2 t * wMax + !y3 = round $ (1 - fromToS y1 y2 t) * hMax + when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ do + writePixel img x3 y3 p + if t < 0.5 + then l1 >> l2 + else l2 >> l1 + + when False $ + forM_ [0..w-1] $ \x -> + forM_ [0..h-1] $ \y -> do + let x1 = fromIntegral x / (wMax) + y1 = 1 - fromIntegral y / (hMax) + this <- readPixel img x y + when (isBlank this) $ + when (isInWorld (mergeP p1 p2 t) (XYCoord x1 y1)) $ + writePixel img x y =<< findNearestPixel img w h x y + unsafeFreezeImage img + where + loopTo m fn = go m + where go 0 = return () + go n = fn (n-1) >> go (n-1) + !w = imageWidth src + !h = imageHeight src + !wMax = fromIntegral (w-1) + !hMax = fromIntegral (h-1) + +eqLonLat :: LonLat -> LonLat -> Bool +eqLonLat (LonLat x1 y1) (LonLat x2 y2) + = eqDouble x1 x2 && eqDouble y1 y2 +{- +eqCoords :: XYCoord -> XYCoord -> Bool +eqCoords (XYCoord x1 y1) (XYCoord x2 y2) + = eqDouble x1 x2 && eqDouble y1 y2 +-} +eqDouble :: Double -> Double -> Bool +eqDouble a b = abs (a-b) < epsilon + +data XYCoord = XYCoord !Double !Double -- 0 to 1 + deriving (Read,Show,Eq,Ord) +data LonLat = LonLat !Double !Double -- -pi to +pi, -halfPi to +halfPi + deriving (Read,Show,Eq,Ord) +data Projection = Projection + { projectionForward :: !(LonLat -> XYCoord) + , projectionInverse :: !(XYCoord -> LonLat) + } + +-- FIXME: Verify that 'src' has an aspect ratio of 2:1. +project :: Image PixelRGBA8 -> Projection -> Image PixelRGBA8 +project src (Projection _ pInv) = generateImage fn w h + where + w = imageWidth src + h = imageHeight src + fn xPx yPx = + let x = (fromIntegral xPx / fromIntegral (w-1)) + y = 1-(fromIntegral yPx / fromIntegral (h-1)) + lonlat = pInv (XYCoord x y) + in + if validLonLat lonlat + then srcPixel src lonlat + else PixelRGBA8 0 0 0 0 + +validLonLat :: LonLat -> Bool +validLonLat (LonLat lam phi) = + lam >= -pi && lam <= pi && phi >= -pi/2 && phi <= pi/2 + +_validXYCoord :: XYCoord -> Bool +_validXYCoord (XYCoord x y) = x >= 0 && x <= 1 && y >= 0 && y <= 1 + +isValidP :: Projection -> Bool +isValidP (Projection p pInv) = and + [ check x y + | x <- [0..w-1::Int] + , y <- [0..h-1::Int] ] + where + w = 100 + h = 100 + check xPx yPx = + let x = (fromIntegral xPx / fromIntegral (w-1)) + y = (fromIntegral yPx / fromIntegral (h-1)) + lonlat = pInv (XYCoord x y) + lonlat2 = pInv $ p lonlat + in not (validLonLat lonlat) || eqLonLat lonlat lonlat2 + || trace (show (lonlat, lonlat2)) False + +moveBottomP :: Double -> Projection -> Projection +moveBottomP offset (Projection p pInv) = Projection p' pInv' + where + p' (LonLat lon lat) = + case p (LonLat lon lat) of + XYCoord x y -> XYCoord x (fromToS offset 1 y) + pInv' (XYCoord x y) = pInv (XYCoord x ((y-offset)/(1-offset))) + +moveTopP :: Double -> Projection -> Projection +moveTopP offset = flipYAxisP . moveBottomP offset . flipYAxisP + +flipYAxisP :: Projection -> Projection +flipYAxisP (Projection p pInv) = Projection p' pInv' + where + p' (LonLat lam phi) = + let XYCoord x y = p (LonLat lam (negate phi)) + in XYCoord x (1-y) + pInv' (XYCoord x y) = + let LonLat lam phi = pInv (XYCoord x (1-y)) + in LonLat lam (negate phi) + +scaleP :: Double -> Double -> Projection -> Projection +scaleP xScale yScale (Projection p pInv) = Projection forward inverse + where + forward lonlat = + case p lonlat of + XYCoord x y -> XYCoord ((x-0.5)*xScale+0.5) ((y-0.5)*yScale+0.5) + inverse (XYCoord x y) = + let new = XYCoord ((x-0.5)/xScale+0.5) ((y-0.5)/yScale+0.5) + in pInv new + + +mergeP :: Projection -> Projection -> Double -> Projection +mergeP p1 p2 t = Projection p pInv + where + p lonlat = + let XYCoord x1 y1 = projectionForward p1 lonlat + XYCoord x2 y2 = projectionForward p2 lonlat + in XYCoord (fromToS x1 x2 t) (fromToS y1 y2 t) + pInv coord = + let LonLat lon1 lat1 = projectionInverse p1 coord + LonLat lon2 lat2 = projectionInverse p2 coord + in + if | oob lon1 lat1 && oob lon2 lat2 -> LonLat (0/0) (0/0) + | otherwise -> LonLat (fromToS lon1 lon2 t) (fromToS lat1 lat2 t) + oob lon lat = lon < (-pi) || lon > pi || lat < (-pi/2) || lat > pi/2 + +-- | <> +equirectangularP :: Projection +equirectangularP = Projection forward inverse + where + forward (LonLat lam phi) = XYCoord ((lam+pi)/tau) ((phi+pi/2)/pi) + inverse (XYCoord x y) = LonLat xPi yPi + where + xPi = fromToS (-pi) pi x + yPi = fromToS (-pi/2) (pi/2) y + +-- | <> +mercatorP :: Projection +mercatorP = Projection forward inverse + where + forward (LonLat lam phi) = + XYCoord ((lam+pi)/tau) + (min 1 $ max (0) $ (((log(tan(pi/4+phi/2))) + pi)/tau)) + inverse (XYCoord x y) = LonLat xPi (atan (sinh yPi)) + where + xPi = fromToS (-pi) pi x + yPi = fromToS (-pi) pi y + +-- | <> +mollweideP :: Projection +mollweideP = Projection forward inverse + where + forward (LonLat lam phi) = + XYCoord ((x+sqrt2*2)/(4*sqrt2)) ((y+sqrt2)/(2*sqrt2)) + where + x = (2*sqrt2)/pi * lam * cos theta + y = sqrt2*sin theta + theta = find_theta 100 + find_theta :: Int -> Double + find_theta 0 = phi + find_theta _ | abs phi == pi/2 = signum phi * pi/2 + find_theta n = + let sub = find_theta (n-1) + in sub - (2*sub+sin (2*sub)-pi*sin phi)/(2+2*cos(2*sub)) + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS (-2*sqrt2) (2*sqrt2) x' + y = fromToS (-sqrt2) sqrt2 y' + theta = asin (y/sqrt2) + lam = pi*x/(2*sqrt2*cos theta) + phi = asin ((2*theta+sin(2*theta))/pi) + +-- | <> +hammerP :: Projection +hammerP = Projection forward inverse + where + forward (LonLat lam phi) = + XYCoord ((x+sqrt2*2)/(4*sqrt2)) ((y+sqrt2)/(2*sqrt2)) + where + x = (2*sqrt2*cos phi*sin (lam/2))/sqrt (1+cos phi*cos (lam/2)) + y = (sqrt2*sin phi)/ sqrt (1+cos phi*cos (lam/2)) + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS (-2*sqrt2) (2*sqrt2) x' + y = fromToS (-sqrt2) sqrt2 y' + z = sqrt (1 - (x/4)**2 - (y/2)**2) + lam = 2 * atan2 (z*x) (2*(2*z**2-1)) + phi = asin (z*y) + +-- | <> +lambertP :: Projection +lambertP = Projection forward inverse + where + forward (LonLat lam phi) = + XYCoord ((lam+pi)/tau) ((sin phi+1)/2) + inverse (XYCoord x' y') = LonLat x (asin y) + where + x = fromToS (-pi) pi x' + y = fromToS (-1) 1 y' + +-- | <> +bottomleyP :: Double -> Projection +bottomleyP !phi_1 = Projection forward inverse + where + forward (LonLat lam phi) = + XYCoord ((x+pi)/tau) ((y+pi/2)/pi) + where + x = (rho * sin e) / sin phi_1 + y = pi/2 - rho * cos e + rho = pi/2 - phi + e = lam * sin phi_1 * sin rho / rho + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS (-pi) pi x' + y = fromToS (-pi/2) (pi/2) y' + x1 = x * sin phi_1 + y1 = pi/2 - y + rho = sqrt (x1*x1 + y1*y1) + e = atan2 x1 y1 + lam = (if rho == 0 then 1 else rho / sin rho) * e/sin phi_1 + phi = pi/2 - rho + +-- | <> +sinusoidalP :: Projection +sinusoidalP = Projection forward inverse + where + forward (LonLat lam phi) = + XYCoord ((x+pi)/tau) ((y+pi/2)/pi) + where + x = lam * cos phi + y = phi + inverse (XYCoord x' y') = LonLat (x/cos y) y + where + x = fromToS (-pi) pi x' + y = fromToS (-pi/2) (pi/2) y' + +-- | <> +wernerP :: Projection +wernerP = moveTopP 0.23 $ Projection forward inverse + where + forward (LonLat lam phi) = + XYCoord ((x+pi)/tau) ((y+pi/2)/pi) + where + rho = pi/2 - phi + e = if rho == 0 then rho else lam * sin rho / rho + x = rho * sin e + y = pi/2 - rho * cos e + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS (-pi) pi x' + y = fromToS (-pi/2) (pi/2) y' + rho = sqrt (x**2 + (pi/2 - y)**2) + e = atan2 x (pi/2 -y) + phi = pi/2 - rho + lam = e * rho / sin rho + +-- FIXME: find right scale and position. +-- | <> +bonneP :: Double -> Projection +bonneP 0 = sinusoidalP +bonneP phi_0 = moveTopP (-0.17*factor) $ scaleP 1 (fromToS 1 0.65 factor) $ Projection forward inverse + where + factor = sin phi_0 / sin (pi/4) + forward (LonLat lam phi ) = XYCoord ((x+pi)/tau) ((y+halfPi)/pi) + where + cotPhi0 = cot phi_0 + rho = cotPhi0 + phi_0 - phi + e = (lam * cos phi) / rho + x = rho * sin e + y = cotPhi0 - rho * cos e + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS (-pi) pi x' + y = fromToS (-pi/2) (pi/2) y' + cotPhi0 = cot phi_0 + rho = sqrt (x*x + (cot phi_0 - y)**2) + -- e = atan2 x (cot phi_1 + phi_1 + y) + phi = cotPhi0 + phi_0 - rho + lam = rho / cos phi * atan2 x (cotPhi0-y) + +-- | <> +orthoP :: LonLat -> Projection +orthoP (LonLat lam_0 phi_0) = Projection forward inverse + where + forward (LonLat lam phi) + | cosc < 0 = + let ang = atan2 y x + xV = cos ang + yV = sin ang + xPos = 7/32 + ((xV+1)/2 * 9/16) + in -- trace (show (x,y)) $ + XYCoord xPos ((yV+1)/2) + --XYCoord (0/0) (0/0) + | otherwise = XYCoord ((x+(16/9))/(16/9*2)) ((y+1)/2) + where + x = cos phi * sin (lam - lam_0) + y = cos phi_0 * sin phi - sin phi_0 * cos phi * cos (lam - lam_0) + cosc = sin phi_0 * sin phi + cos phi_0 * cos phi * cos (lam-lam_0) + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS (-16/9) (16/9) x' + y = fromToS (-1) 1 y' + lam = wrap (-pi) pi $ + lam_0 + atan2 (x * sin c) (rho * cos c * cos phi_0 - y * sin c * sin phi_0) + phi = wrap (-pi/2) (pi/2) $ + asin (cos c * sin phi_0 + (y * sin c * cos phi_0)/rho) + rho = sqrt (x*x + y*y) + c = asin rho + wrap lower upper v + | v > upper = v-upper+lower + | v < lower = v+upper-lower + | otherwise = v + +cassiniP :: Projection +cassiniP = Projection forward inverse + where + forward (LonLat lam phi) = + XYCoord ((asin (cos phi * sin lam)+halfPi)/pi) ((atan2 (tan phi) (cos lam)+pi)/tau) + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS (-halfPi) halfPi x' + y = fromToS (-pi) pi y' + lam = atan2 (tan x) (cos y) + phi = asin (sin y * cos x) + +augustP :: Projection +augustP = scaleP 0.70 0.70 $ Projection forward inverse + where + xHi = 16/3 + xLo = -xHi + yHi = 8 / 3 + yLo = -yHi + forward (LonLat lam phi) = XYCoord ((xPos-xLo)/(xHi-xLo)) ((yPos-yLo)/(yHi-yLo)) + where + tanPhi = tan (phi/2) + k = sqrt (1 - tanPhi * tanPhi) + c = 1 + k * cos (lam / 2) + x = sin (lam/2) * k / c + y = tanPhi / c + x2 = x*x + y2 = y*y + xPos = 4 / 3 * x * (3+x2 - 3*y2) + yPos = 4 / 3 * y * (3 + 3*x2 - y2) + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS xLo xHi x' * 3 / 8 + y = fromToS yLo yHi y' * 3 / 8 + x2 = x*x + y2 = y*y + s = 1 + x2 + y2 + sin3Eta = sqrt ((s - sqrt (s*s - 4 * y * y)) / 2) + eta = asin sin3Eta / 3 + xi = if sin3Eta /= 0 then acosh (abs (y / sin3Eta)) / 3 else asinh (abs x) / 3 + cosEta = cos eta + coshXi = cosh xi + d = coshXi * coshXi - cosEta * cosEta + lam = signum x * 2 * atan2 (sinh xi * cosEta) (0.25 - d) + phi = signum y * 2 * atan2 (coshXi * sin eta) (0.25 + d) + +-- | <> +collignonP :: Projection +collignonP = Projection forward inverse + where + yHi = sqrtPi + yLo = sqrtPi * (1 - sqrt2) + xLo = -pi*(2/sqrtPi)*sqrt2 + xHi = pi*(2/sqrtPi)*sqrt2 + forward (LonLat lam phi) = XYCoord ((x-xLo)/(xHi-xLo)) ((y-yLo)/(yHi-yLo)) + where + alpha = sqrt (1 - sin phi) + x = (2 / sqrtPi) * lam * alpha + y = sqrtPi * (1 - alpha) + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS xLo xHi x' + y = fromToS yLo yHi y' + l = (y / sqrtPi -1)**2 + lam = if l > 0 then x * sqrt (pi / l) / 2 else 0 + phi = asin (1-l) + +-- | <> +eckert1P :: Projection +eckert1P = Projection forward inverse + where + alpha = sqrt (8 / (3*pi)) + yLo = -alpha * halfPi + yHi = alpha * halfPi + xLo = -alpha * pi + xHi = alpha * pi + forward (LonLat lam phi) = XYCoord ((x-xLo)/(xHi-xLo)) ((y-yLo)/(yHi-yLo)) + where + x = alpha * lam * (1 - abs phi / pi) + y = alpha * phi + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS xLo xHi x' + y = fromToS yLo yHi y' + phi = y / alpha + lam = x / (alpha * (1 - abs phi / pi)) + +-- | <> +eckert3P :: Projection +eckert3P = Projection forward inverse + where + k = sqrt (pi * (4 + pi)) + yLo = negate yHi + yHi = 4/k * halfPi + xLo = negate xHi + xHi = 4/k * pi + forward (LonLat lam phi) = XYCoord ((x-xLo)/(xHi-xLo)) ((y-yLo)/(yHi-yLo)) + where + x = 2 / k * lam * (1 + sqrt (1 - 4*phi*phi/(pi*pi))) + y = 4 / k * phi + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS xLo xHi x' + y = fromToS yLo yHi y' + lam = x * k/2 / (1 + sqrt (1 - y*y* (4+pi)/(4*pi))) + phi = y * k/4 + +-- | <> +eckert5P :: Projection +eckert5P = Projection forward inverse + where + k = sqrt (2 + pi) + yLo = negate yHi + yHi = pi/k + xLo = negate xHi + xHi = tau/k + forward (LonLat lam phi) = XYCoord ((x-xLo)/(xHi-xLo)) ((y-yLo)/(yHi-yLo)) + where + x = lam * (1 + cos phi) / k + y = 2 * phi / k + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS xLo xHi x' + y = fromToS yLo yHi y' + lam = k * x / (1 + cos phi) + phi = y * k / 2 + +-- | <> +faheyP :: Projection +faheyP = Projection forward inverse + where + faheyK = cos (toRads 35) + yLo = negate yHi + yHi = 1 + faheyK + xLo = negate xHi + xHi = pi * faheyK * 16/9 + forward (LonLat lam phi) = XYCoord ((x-xLo)/(xHi-xLo)) ((y-yLo)/(yHi-yLo)) + where + t = tan (phi/2) + x = lam * faheyK * sqrt (1 - t*t) + y = (1 + faheyK) * t + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS xLo xHi x' + y = fromToS yLo yHi y' + t = y / (1 + faheyK) + lam = x / (faheyK * sqrt (1 - t*t)) + phi = 2 * atan2 y (1 + faheyK) + +foucautP :: Projection +foucautP = Projection forward inverse + where + yLo = negate yHi + yHi = sqrtPi * tan (halfPi/2) + xLo = negate xHi + xHi = tau/sqrtPi + forward (LonLat lam phi) = XYCoord ((x-xLo)/(xHi-xLo)) ((y-yLo)/(yHi-yLo)) + where + k = phi / 2 + cosk = cos k + x = 2 * lam / sqrtPi * cos phi * cosk * cosk + y = sqrtPi * tan k + inverse (XYCoord x' y') = LonLat lam phi + where + x = fromToS xLo xHi x' + y = fromToS yLo yHi y' + k = atan (y / sqrtPi) + cosk = cos k + phi = 2 * k + lam = x * sqrtPi / 2 / (cos phi * cosk * cosk) + +lagrangeP :: Projection +lagrangeP = Projection forward inverse + where + yLo = negate yHi + yHi = 2 + xLo = negate xHi + xHi = 2 + n = 0.5 + forward (LonLat lam phi) + | abs (abs phi - halfPi) < epsilon = XYCoord 0.5 (if phi < 0 then 0 else 1) + | otherwise = XYCoord ((x-xLo)/(xHi-xLo)) ((y-yLo)/(yHi-yLo)) + where + sinPhi = sin phi + v = ((1+sinPhi) / (1 - sinPhi))**(n/2) + c = 0.5 * (v + 1/v) + cos (lam*n) + x = 2 * sin (lam*n) / c + y = (v - 1/v) /c + inverse (XYCoord x' y') + | abs (abs y'-1) < epsilon = LonLat 0 (signum y * halfPi) + | otherwise = LonLat lam phi + where + x = fromToS xLo xHi x' / 2 + y = fromToS yLo yHi y' / 2 + x2 = x * x + y2 = y * y + t = 2 * y / (1 + x2 + y2) + t' = ((1+t) / (1-t)) ** (1/n) + lam = atan2 (2*x) (1-x2-y2) / n + phi = asin ((t'-1)/(t'+1)) + + + + + + + + + + + + + + + + +drawFeatureCollection :: GeoFeatureCollection a -> (a -> SVG -> SVG) -> SVG +drawFeatureCollection geo fn = mkGroup + [ fn (feature ^. properties) $ renderGeometry (feature ^. geometry) + | feature <- toList (geo ^. geofeatures) + ] + +{-# INLINE loadFeatureCollection #-} +loadFeatureCollection :: FromJSON a => FilePath -> (a -> SVG -> SVG) -> SVG +loadFeatureCollection path = unsafePerformIO $ do + mbGeo <- decodeFileStrict path + case mbGeo of + Nothing -> error $ "loadFeatureCollection: Invalid GeoJSON: " ++ path + Just geo -> return (drawFeatureCollection geo) + +-- drawFeatureCollection :: GeoFeatureCollection a -> (a -> SVG -> SVG) -> SVG +-- loadFeatureColection :: FromJSON a => FilePath -> (a -> SVG -> SVG) -> SVG +-- modifyPoints :: ((Double,Double) -> (Double, Double)) -> SVG -> SVG +-- pointsToRadians :: SVG -> SVG +-- applyProjection :: Projection -> SVG -> SVG + +renderGeometry :: GeospatialGeometry -> SVG +renderGeometry shape = + case shape of + MultiPolygon mpolygon -> + mkGroup $ map (renderGeometry . Polygon) $ toList (splitGeoMultiPolygon mpolygon) + Polygon poly -> + mkGroup + [ mkLinePath section + | section <- pure + [ (x, y) + | PointXY x y <- map retrieveXY (fromLinearRing (head (toList (poly^.unGeoPolygon)))) + ] + ] + Line line -> + mkLinePath + [ (x, y) + | PointXY x y <- map retrieveXY (Line.fromLineString (line ^. unGeoLine)) + ] + MultiLine ml -> + mkGroup $ map (renderGeometry . Line) $ toList (splitGeoMultiLine ml) + _ -> None + + +applyProjection :: Projection -> SVG -> SVG +applyProjection = applyProjection' 1e-2 + +applyProjection' :: Double -> Projection -> SVG -> SVG +applyProjection' tolerance p = mapSvgLines start + where + start (LineMove x:rest) = LineMove (proj x) : worker x rest + start _ = [] + worker a (LineEnd b : rest) = + let (x:xs) = reverse $ drop 1 $ mkChunks a b + in map (\v -> LineBezier [v]) (map proj $ reverse xs) ++ LineEnd (proj x) : start rest + worker a (LineBezier [b] : rest) = + let (x:xs) = reverse $ drop 1 $ mkChunks a b + in map (\v -> LineBezier [v]) (map proj $ reverse xs) ++ LineBezier [proj x] : worker x rest + worker _ (LineBezier ps : rest) = + LineBezier (map proj ps) : worker (last ps) rest + worker _ (LineMove x:rest) = LineMove (proj x) : worker x rest + worker _ [] = [] + lowTolerance = tolerance*tolerance + + proj (V2 lam phi) = + case projectionForward p $ LonLat lam phi of + XYCoord x y -> V2 x y + mkChunks a b = + let midway = lerp 0.5 a b in + if distance (proj a) (proj b) < tolerance || distance a b < lowTolerance + then [a, b] + else mkChunks a midway ++ drop 1 (mkChunks midway b) diff --git a/src/Reanimate/Interpolate.hs b/src/Reanimate/Interpolate.hs --- a/src/Reanimate/Interpolate.hs +++ b/src/Reanimate/Interpolate.hs @@ -1,73 +1,88 @@ -{-# LANGUAGE RecordWildCards #-} -module Reanimate.Interpolate where - -import Codec.Picture -import Data.Colour -import Data.Colour.CIE -import Data.Colour.CIE.Illuminant (d65) -import Data.Colour.SRGB -import Data.Colour.RGBSpace.HSV -import Data.Colour.RGBSpace -import Data.Fixed - -data ColorComponents = ColorComponents - { colorUnpack :: Colour Double -> (Double, Double, Double) - , colorPack :: Double -> Double -> Double -> Colour Double } - -rgbComponents :: ColorComponents -rgbComponents = ColorComponents rgbUnpack sRGB - where - rgbUnpack :: Colour Double -> (Double, Double, Double) - rgbUnpack c = - case toSRGB c of - RGB r g b -> (r,g,b) - -hsvComponents :: ColorComponents -hsvComponents = ColorComponents unpack pack - where - unpack = hsvView.toSRGB - pack a b c = uncurryRGB sRGB $ hsv a b c - -labComponents :: ColorComponents -labComponents = ColorComponents unpack pack - where - unpack = cieLABView d65 - pack = cieLAB d65 - -xyzComponents :: ColorComponents -xyzComponents = ColorComponents cieXYZView cieXYZ - -lchComponents :: ColorComponents -lchComponents = ColorComponents unpack pack - where - toDeg,toRad :: Double -> Double - toRad deg = deg/180 * pi - toDeg rad = rad/pi * 180 - unpack :: Colour Double -> (Double, Double, Double) - unpack color = - let (l,a,b) = cieLABView d65 color - c = sqrt (a*a + b*b) - h :: Double - h = (toDeg(atan2 b a) + 360) `mod'` 360 - isZero = round (c*10000) == (0::Integer) - in (l, c, if isZero then 0/0 else h) - pack l c h = - cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c) - -interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double) -interpolate ColorComponents{..} from to = \d -> - colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d) - where - (a1,b1,c1) = colorUnpack from - (a2,b2,c2) = colorUnpack to - -interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8) -interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to) - -toRGB8 :: Colour Double -> PixelRGB8 -toRGB8 c = PixelRGB8 r g b - where - RGB r g b = toSRGBBounded c - -fromRGB8 :: PixelRGB8 -> Colour Double -fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b +{-# LANGUAGE RecordWildCards #-} +module Reanimate.Interpolate where + +import Codec.Picture +import Data.Colour +import Data.Colour.CIE +import Data.Colour.CIE.Illuminant (d65) +import Data.Colour.SRGB +import Data.Colour.RGBSpace.HSV +import Data.Colour.RGBSpace +import Data.Fixed + +data ColorComponents = ColorComponents + { colorUnpack :: Colour Double -> (Double, Double, Double) + , colorPack :: Double -> Double -> Double -> Colour Double } + +-- | > interpolate rgbComponents yellow blue +-- +-- <> +rgbComponents :: ColorComponents +rgbComponents = ColorComponents rgbUnpack sRGB + where + rgbUnpack :: Colour Double -> (Double, Double, Double) + rgbUnpack c = + case toSRGB c of + RGB r g b -> (r,g,b) + +-- | > interpolate hsvComponents yellow blue +-- +-- <> +hsvComponents :: ColorComponents +hsvComponents = ColorComponents unpack pack + where + unpack = hsvView.toSRGB + pack a b c = uncurryRGB sRGB $ hsv a b c + +-- | > interpolate labComponents yellow blue +-- +-- <> +labComponents :: ColorComponents +labComponents = ColorComponents unpack pack + where + unpack = cieLABView d65 + pack = cieLAB d65 + +-- | > interpolate xyzComponents yellow blue +-- +-- <> +xyzComponents :: ColorComponents +xyzComponents = ColorComponents cieXYZView cieXYZ + +-- | > interpolate lchComponents yellow blue +-- +-- <> +lchComponents :: ColorComponents +lchComponents = ColorComponents unpack pack + where + toDeg,toRad :: Double -> Double + toRad deg = deg/180 * pi + toDeg rad = rad/pi * 180 + unpack :: Colour Double -> (Double, Double, Double) + unpack color = + let (l,a,b) = cieLABView d65 color + c = sqrt (a*a + b*b) + h :: Double + h = (toDeg(atan2 b a) + 360) `mod'` 360 + isZero = round (c*10000) == (0::Integer) + in (l, c, if isZero then 0/0 else h) + pack l c h = + cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c) + +interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double) +interpolate ColorComponents{..} from to = \d -> + colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d) + where + (a1,b1,c1) = colorUnpack from + (a2,b2,c2) = colorUnpack to + +interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8) +interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to) + +toRGB8 :: Colour Double -> PixelRGB8 +toRGB8 c = PixelRGB8 r g b + where + RGB r g b = toSRGBBounded c + +fromRGB8 :: PixelRGB8 -> Colour Double +fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b diff --git a/src/Reanimate/LaTeX.hs b/src/Reanimate/LaTeX.hs --- a/src/Reanimate/LaTeX.hs +++ b/src/Reanimate/LaTeX.hs @@ -2,16 +2,16 @@ {-# LANGUAGE ScopedTypeVariables #-} module Reanimate.LaTeX (latex,xelatex,latexAlign) where -import Control.Exception (SomeException, handle) import qualified Data.ByteString as B import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T -import Graphics.SvgTree (Tree (..), defaultSvg, parseSvgFile) +import Graphics.SvgTree (Tree (..), parseSvgFile) import Reanimate.Cache import Reanimate.Misc import Reanimate.Svg +import Reanimate.Parameters import System.FilePath (replaceExtension, takeFileName, ()) import System.IO.Unsafe (unsafePerformIO) @@ -24,8 +24,12 @@ -- -- <> latex :: T.Text -> Tree -latex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) latexToSVG) - ("% plain latex\n" <> tex) +latex tex | pNoExternals = mkText tex +latex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "dvi" exec args)) script + where + exec = "latex" + args = [] + script = mkTexScript exec args [] tex -- | Invoke xelatex and import the result as an SVG object. SVG objects are -- cached to improve performance. Xelatex has support for non-western scripts. @@ -36,8 +40,13 @@ -- -- <> xelatex :: Text -> Tree -xelatex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) xelatexToSVG) - ("% xelatex\n" <> tex) +xelatex tex | pNoExternals = mkText tex +xelatex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "xdv" exec args)) script + where + exec = "xelatex" + args = ["-no-pdf"] + headers = ["\\usepackage[UTF8]{ctex}"] + script = mkTexScript exec args headers tex -- | Invoke latex and import the result as an SVG object. SVG objects are -- cached to improve performance. This wraps the TeX code in an 'align*' @@ -54,17 +63,15 @@ postprocess :: Tree -> Tree postprocess = lowerTransformations . scaleXY 1 (-1) . scale 0.1 . pathify -latexToSVG :: Text -> IO Tree -latexToSVG tex = handle (\(_::SomeException) -> return (failedSvg tex)) $ do - latexBin <- requireExecutable "latex" +-- executable, arguments, header, tex +latexToSVG :: String -> String -> [String] -> Text -> IO Tree +latexToSVG dviExt latexExec latexArgs tex = do + latexBin <- requireExecutable latexExec dvisvgm <- requireExecutable "dvisvgm" withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file -> withTempFile "svg" $ \svg_file -> do - let dvi_file = tmp_dir replaceExtension (takeFileName tex_file) "dvi" - writeFile tex_file tex_document - appendFile tex_file tex_prologue - T.appendFile tex_file tex - appendFile tex_file tex_epilogue - runCmd latexBin ["-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file] + let dvi_file = tmp_dir replaceExtension (takeFileName tex_file) dviExt + T.writeFile tex_file tex + runCmd latexBin (latexArgs ++ ["-interaction=nonstopmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file]) runCmd dvisvgm [ dvi_file, "--precision=5" , "--exact" -- better bboxes. -- , "--bbox=1,1" -- increase bbox size. @@ -75,62 +82,34 @@ Nothing -> error "Malformed svg" Just svg -> return $ postprocess $ unbox $ replaceUses svg -xelatexToSVG :: Text -> IO Tree -xelatexToSVG tex = handle (\(_::SomeException) -> return (failedSvg tex)) $ do - xetexBin <- requireExecutable "xelatex" - dvisvgm <- requireExecutable "dvisvgm" - withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file -> withTempFile "svg" $ \svg_file -> do - let dvi_file = tmp_dir replaceExtension (takeFileName tex_file) "xdv" - writeFile tex_file tex_document - appendFile tex_file tex_xelatex - appendFile tex_file tex_prologue - T.appendFile tex_file tex - appendFile tex_file tex_epilogue - runCmd xetexBin ["-no-pdf", "-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file] - runCmd dvisvgm [ dvi_file - , "--exact" -- better bboxes. - -- , "--bbox=1,1" -- increase bbox size. - , "--no-fonts" -- use glyphs instead of fonts. - ,"--verbosity=0", "-o",svg_file] - svg_data <- B.readFile svg_file - case parseSvgFile svg_file svg_data of - Nothing -> error "Malformed svg" - Just svg -> return $ postprocess $ unbox $ replaceUses svg - -failedSvg :: Text -> Tree -failedSvg _tex = defaultSvg - -- text_ [ font_size_ "20" - -- , fill_ "white"] (toHtml $ "bad latex: "++tex) - -tex_document :: String -tex_document = "\\documentclass[preview]{standalone}\n" - -tex_xelatex :: String -tex_xelatex = - "\\usepackage[UTF8]{ctex}\n" +mkTexScript :: String -> [String] -> [Text] -> Text -> Text +mkTexScript latexExec latexArgs texHeaders tex = T.unlines $ + [ "% " <> T.pack (unwords (latexExec:latexArgs)) + , "\\documentclass[preview]{standalone}" + , "\\usepackage{amsmath}" + , "\\usepackage{gensymb}" + ] ++ texHeaders ++ + [ "\\usepackage[english]{babel}" + , "\\linespread{1}" + , "\\begin{document}" + , tex + , "\\end{document}" ] -tex_prologue :: String -tex_prologue = - "\\usepackage[english]{babel}\n\ - \\\usepackage{amsmath}\n\ - \\\usepackage{amssymb}\n\ - \\\usepackage{dsfont}\n\ - \\\usepackage{setspace}\n\ - \\\usepackage{relsize}\n\ - \\\usepackage{textcomp}\n\ - \\\usepackage{mathrsfs}\n\ - \\\usepackage{calligra}\n\ - \\\usepackage{wasysym}\n\ - \\\usepackage{ragged2e}\n\ - \\\usepackage{physics}\n\ - \\\usepackage{xcolor}\n\ - \\\usepackage{textcomp}\n\ - \\\usepackage{xfrac}\n\ - \\\usepackage{microtype}\n\ - \\\linespread{1}\n\ - \\\begin{document}\n" +{- Packages used by manim. -tex_epilogue :: String -tex_epilogue = - "\n\ - \\\end{document}" +\\\usepackage{amsmath}\n\ +\\\usepackage{amssymb}\n\ +\\\usepackage{dsfont}\n\ +\\\usepackage{setspace}\n\ +\\\usepackage{relsize}\n\ +\\\usepackage{textcomp}\n\ +\\\usepackage{mathrsfs}\n\ +\\\usepackage{calligra}\n\ +\\\usepackage{wasysym}\n\ +\\\usepackage{ragged2e}\n\ +\\\usepackage{physics}\n\ +\\\usepackage{xcolor}\n\ +\\\usepackage{textcomp}\n\ +\\\usepackage{xfrac}\n\ +\\\usepackage{microtype}\n\ +-} diff --git a/src/Reanimate/Misc.hs b/src/Reanimate/Misc.hs --- a/src/Reanimate/Misc.hs +++ b/src/Reanimate/Misc.hs @@ -28,8 +28,10 @@ runCmd :: FilePath -> [String] -> IO () runCmd exec args = do - _ <- runCmd_ exec args - return () + ret <- runCmd_ exec args + case ret of + Left err -> error $ showCommandForUser exec args ++ ":\n" ++ err + Right{} -> return () runCmd_ :: FilePath -> [String] -> IO (Either String String) runCmd_ exec args = do @@ -37,11 +39,15 @@ _ <- evaluate (length stdout + length stderr) case ret of ExitSuccess -> return (Right stdout) - ExitFailure err -> do + ExitFailure err | False -> return $ Left $ "Failed to run: " ++ showCommandForUser exec args ++ "\n" ++ "Error code: " ++ show err ++ "\n" ++ "stderr: " ++ stderr + ExitFailure{} | null stderr -> -- LaTeX prints errors to stdout. :( + return $ Left stdout + ExitFailure{} -> + return $ Left stderr runCmdLazy :: FilePath -> [String] -> (IO (Either String T.Text) -> IO a) -> IO a runCmdLazy exec args handler = do @@ -56,11 +62,12 @@ ret <- waitForProcess pid case ret of ExitSuccess -> return (Left "") - ExitFailure errMsg -> do + ExitFailure{} -> return (Left stderr) + {-ExitFailure errMsg -> do return $ Left $ "Failed to run: " ++ showCommandForUser exec args ++ "\n" ++ "Error code: " ++ show errMsg ++ "\n" ++ - "stderr: " ++ stderr + "stderr: " ++ stderr-} else do line <- T.hGetLine out return (Right line) diff --git a/src/Reanimate/Parameters.hs b/src/Reanimate/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Parameters.hs @@ -0,0 +1,60 @@ +module Reanimate.Parameters + ( pFPS + , pWidth + , pHeight + , pNoExternals + , setFPS + , setWidth + , setHeight + , setNoExternals + ) where + +import System.IO.Unsafe +import Data.IORef +import Reanimate.Render + +{-# NOINLINE pFPSRef #-} +pFPSRef :: IORef FPS +pFPSRef = unsafePerformIO (newIORef 0) + +{-# NOINLINE pFPS #-} +pFPS :: FPS +pFPS = unsafePerformIO (readIORef pFPSRef) + +setFPS :: FPS -> IO () +setFPS = writeIORef pFPSRef + +{-# NOINLINE pWidthRef #-} +pWidthRef :: IORef FPS +pWidthRef = unsafePerformIO (newIORef 0) + +{-# NOINLINE pWidth #-} +pWidth :: Width +pWidth = unsafePerformIO (readIORef pWidthRef) + +setWidth :: Width -> IO () +setWidth = writeIORef pWidthRef + + +{-# NOINLINE pHeightRef #-} +pHeightRef :: IORef FPS +pHeightRef = unsafePerformIO (newIORef 0) + +{-# NOINLINE pHeight #-} +pHeight :: Height +pHeight = unsafePerformIO (readIORef pHeightRef) + +setHeight :: Height -> IO () +setHeight = writeIORef pHeightRef + +{-# NOINLINE pNoExternalsRef #-} +pNoExternalsRef :: IORef Bool +pNoExternalsRef = unsafePerformIO (newIORef False) + +{-# NOINLINE pNoExternals #-} +pNoExternals :: Bool +pNoExternals = unsafePerformIO (readIORef pNoExternalsRef) + +setNoExternals :: Bool -> IO () +setNoExternals = writeIORef pNoExternalsRef + diff --git a/src/Reanimate/PolyShape.hs b/src/Reanimate/PolyShape.hs --- a/src/Reanimate/PolyShape.hs +++ b/src/Reanimate/PolyShape.hs @@ -31,7 +31,7 @@ import Chiphunk.Low import Control.Lens ((&), (.~)) -import Data.List (nub, partition, sortBy, minimumBy) +import Data.List (minimumBy, nub, partition, sortOn) import Data.Ord import Debug.Trace import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..), DPoint, @@ -39,9 +39,9 @@ arcLength, arcLengthParam, bezierIntersection, bezierSubsegment, closedPathCurves, closest, colinear, - curvesToClosed, curvesToClosed, - evalBezier, interpolateVector, reorient, - splitBezier, union, vectorDistance) + curvesToClosed, evalBezier, + interpolateVector, reorient, splitBezier, + union, vectorDistance) import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..), defaultSvg, pathDefinition) import Linear.V2 @@ -144,7 +144,7 @@ let (touching, notTouching) = partition (isTouching seen) shapes in if null touching then plGroupTouching notTouching - else map ((,)seen) (map (changeOrigin seen) touching) : + else map ((,) seen . changeOrigin seen) touching : worker (seen ++ concatMap plPoints touching) notTouching isTouching pts = any (`elem` pts) . plPoints changeOrigin seen (PolyShape (ClosedPath segments)) = PolyShape $ ClosedPath $ helper [] segments @@ -164,9 +164,7 @@ -- | Deconstruct a polyshape into non-intersecting, convex polygons. plDecompose' :: Double -> [PolyShape] -> [[RPoint]] plDecompose' tol = - concatMap decomposePolygon . - map (plPolygonify tol) . - map mergePolyShapeHoles . + concatMap (decomposePolygon . plPolygonify tol . mergePolyShapeHoles) . plGroupShapes . unionPolyShapes @@ -240,12 +238,12 @@ finalize ((toGPoint from, JoinLine):acc) $ worker dst [] xs worker _from acc (LineEnd{}:LineMove dst:xs) = - finalize (acc) $ + finalize acc $ worker dst [] xs worker from acc [LineEnd orig] | from /= orig = finalize ((toGPoint from, JoinLine):acc) [] worker _from acc [LineEnd{}] = - finalize (acc) [] + finalize acc [] worker from acc (LineBezier [x]:xs) = worker x ((toGPoint from, JoinLine) : acc) xs worker from acc (LineBezier [a,b,c]:xs) = @@ -306,7 +304,7 @@ { polyShapeParent = s , polyShapeHoles = holes } in prime : worker nonHoles - | otherwise = trace ("Found hole, putting back") $ worker (rest ++ [s]) + | otherwise = trace "Found hole, putting back" $ worker (rest ++ [s]) worker [] = [] parents :: PolyShape -> [PolyShape] -> [PolyShape] @@ -325,7 +323,7 @@ mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape mergePolyShapeHole parent child = snd $ head $ - sortBy (comparing fst) + sortOn fst [ cutSingleHole newParent child | newParent <- polyShapePermutations parent ] @@ -379,7 +377,7 @@ -- straight line from child origin x2p = lineBetween childOrigin p - lineBetween a b = CubicBezier a a a b + lineBetween a = CubicBezier a a a plCurves :: PolyShape -> [CubicBezier Double] plCurves = closedPathCurves . unPolyShape diff --git a/src/Reanimate/Povray.hs b/src/Reanimate/Povray.hs --- a/src/Reanimate/Povray.hs +++ b/src/Reanimate/Povray.hs @@ -1,51 +1,79 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Reanimate.Povray ( povray , povrayQuick , povraySlow + , povrayExtreme + , povray' + , povrayQuick' + , povraySlow' + , povrayExtreme' ) where import Codec.Picture.Png -import qualified Data.ByteString as B -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Graphics.SvgTree (Tree (..)) +import qualified Data.ByteString as B +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Graphics.SvgTree (Tree (..)) import Reanimate.Cache -import Reanimate.Memo import Reanimate.Misc import Reanimate.Raster +import Reanimate.Parameters import Reanimate.Svg.Constructors -import System.FilePath (replaceExtension) -import System.IO.Unsafe (unsafePerformIO) +import System.FilePath (replaceExtension, (<.>)) +import System.IO.Unsafe (unsafePerformIO) +import Data.Hashable povrayRaw :: [String] -> Text -> Tree povrayRaw args script = - memo [Key mkPovrayImage, KeyPrim args, KeyPrim script] - (unsafePerformIO $ mkPovrayImage args script) + unsafePerformIO $ mkPovrayImage args script +povrayRaw' :: [String] -> Text -> FilePath +povrayRaw' args script = + unsafePerformIO $ mkPovrayImage' args script + povray :: [String] -> Text -> Tree povray args = povrayRaw (["+H180","+W320", "+A"] ++ args) +povray' :: [String] -> Text -> FilePath +povray' args = povrayRaw' (["+H180","+W320", "+A"] ++ args) + povrayQuick :: [String] -> Text -> Tree povrayQuick args = povrayRaw (["+H180","+W320"] ++ args) +povrayQuick' :: [String] -> Text -> FilePath +povrayQuick' args = povrayRaw' (["+H180","+W320"] ++ args) + povraySlow :: [String] -> Text -> Tree povraySlow args = povrayRaw (["+H1440","+W2560", "+A"] ++ args) +povraySlow' :: [String] -> Text -> FilePath +povraySlow' args = povrayRaw' (["+H1440","+W2560", "+A"] ++ args) + +povrayExtreme :: [String] -> Text -> Tree +povrayExtreme args = povrayRaw (["+H2160","+W3840", "+A"] ++ args) + +povrayExtreme' :: [String] -> Text -> FilePath +povrayExtreme' args = povrayRaw' (["+H2160","+W3840", "+A"] ++ args) + mkPovrayImage :: [String] -> Text -> IO Tree -mkPovrayImage args script = cacheDiskKey key $ do - exec <- requireExecutable "povray" - withTempFile "pov" $ \pov_file -> do - let out = replaceExtension pov_file "png" +mkPovrayImage _ script | pNoExternals = pure $ mkText script +mkPovrayImage args script = do + out <- mkPovrayImage' args script + -- return $ center $ scaleToSize 16 9 $ embedImageFile out + png <- B.readFile out + case decodePng png of + Left{} -> error "bad image" + Right img -> return $ center $ scaleToSize 16 9 $ embedDynamicImage img + +mkPovrayImage' :: [String] -> Text -> IO FilePath +mkPovrayImage' _ _ | pNoExternals = pure "/povray/has/been/disabled" +mkPovrayImage' args script = cacheFile template $ \target -> do + exec <- requireExecutable "povray" + let pov_file = replaceExtension target "pov" T.writeFile pov_file script - ret <- runCmd_ exec (args ++ ["-D","+UA", pov_file, "+o"++out]) - case ret of - Left{} -> error "povray went wrong" - Right{} -> do - png <- B.readFile out - case decodePng png of - Left{} -> error "bad image" - Right img -> return $ center $ scaleToSize 16 9 $ embedDynamicImage img + runCmd exec (args ++ ["-D","+UA", pov_file, "+o"++target]) where + template = show (hash key) <.> "png" key = T.concat (script:map T.pack args) diff --git a/src/Reanimate/Raster.hs b/src/Reanimate/Raster.hs --- a/src/Reanimate/Raster.hs +++ b/src/Reanimate/Raster.hs @@ -3,20 +3,33 @@ , embedDynamicImage , embedPng , raster + , rasterSized + , vectorize + , vectorize_ + , svgAsPngFile + , svgAsPngFile' ) where import Codec.Picture import Codec.Picture.Types (dynamicMap) -import Control.Lens +import Control.Lens ((&), (.~)) +import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Base64.Lazy as Base64 import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Hashable +import qualified Data.Text as T import Graphics.SvgTree (Number (..), Tree (..), - defaultSvg) + defaultSvg, parseSvgFile) import qualified Graphics.SvgTree as Svg -import Reanimate.Misc import Reanimate.Animation +import Reanimate.Cache +import Reanimate.Misc +import Reanimate.Render +import Reanimate.Parameters import Reanimate.Svg.Constructors +import Reanimate.Svg.Unuse +import System.Directory import System.FilePath import System.IO import System.IO.Temp @@ -31,6 +44,15 @@ height = fromIntegral $ imageHeight img embedPng :: Double -> Double -> LBS.ByteString -> Tree +-- embedPng w h png = unsafePerformIO $ do +-- LBS.writeFile path png +-- return $ ImageTree $ defaultSvg +-- & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2)) +-- & Svg.imageWidth .~ Svg.Num w +-- & Svg.imageHeight .~ Svg.Num h +-- & Svg.imageHref .~ ("file://"++path) +-- where +-- path = "/tmp" show (hash png) <.> "png" embedPng w h png = flipYAxis $ ImageTree $ defaultSvg & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2)) @@ -52,19 +74,80 @@ Left err -> error err Right dat -> dat +-- embedImageFile :: FilePath -> Tree +-- embedImageFile path = unsafePerformIO $ do +-- png <- B.readFile path +-- case decodePng png of +-- Left{} -> error "bad image" +-- Right img -> return $ +-- let width = fromIntegral $ dynamicMap imageWidth img +-- height = fromIntegral $ dynamicMap imageHeight img in +-- ImageTree $ defaultSvg +-- & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2)) +-- & Svg.imageWidth .~ Svg.Num width +-- & Svg.imageHeight .~ Svg.Num height +-- & Svg.imageHref .~ ("file://" ++ path) + + + raster :: Tree -> DynamicImage -raster svg = unsafePerformIO $ - withSystemTempFile "reanimate.svg" $ \tmpFile handle -> do - let target = replaceExtension tmpFile "png" - -- ffmpeg <- requireExecutable "ffmpeg" - convert <- requireExecutable "convert" - hPutStr handle $ renderSvg (Just $ Num width) (Just $ Num height) svg - hClose handle - runCmd convert [ tmpFile, target ] - png <- B.readFile target - case decodePng png of - Left{} -> error "bad image" - Right img -> return img +raster = rasterSized 2560 1440 + +rasterSized :: Int -> Int -> Tree -> DynamicImage +rasterSized w h svg = unsafePerformIO $ do + png <- B.readFile (svgAsPngFile' w h svg) + case decodePng png of + Left{} -> error "bad image" + Right img -> return img + +vectorize :: FilePath -> Tree +vectorize = vectorize_ [] + +vectorize_ :: [String] -> FilePath -> Tree +vectorize_ _ path | pNoExternals = mkText $ T.pack path +vectorize_ args path = unsafePerformIO $ do + root <- getXdgDirectory XdgCache "reanimate" + createDirectoryIfMissing True root + let svgPath = root show key <.> "svg" + hit <- doesFileExist svgPath + unless hit $ + withSystemTempFile "file.svg" $ \tmpSvgPath svgH -> + withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do + hClose svgH + hClose bmpH + potrace <- requireExecutable "potrace" + convert <- requireExecutable "convert" + runCmd convert [ path, "-flatten", tmpBmpPath ] + runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath]) + renameFile tmpSvgPath svgPath + svg_data <- B.readFile svgPath + case parseSvgFile svgPath svg_data of + Nothing -> do + removeFile svgPath + error "Malformed svg" + Just svg -> return $ unbox $ replaceUses svg where + key = hash (path, args) + +-- imageAsFile :: DynamicImage -> FilePath +-- imageAsFile img + +svgAsPngFile :: Tree -> FilePath +svgAsPngFile = svgAsPngFile' width height + where width = 2560 - height = width * 9 / 16 + height = width * 9 `div` 16 + +svgAsPngFile' :: Int -> Int -> Tree -> FilePath +svgAsPngFile' _ _ _ | pNoExternals = "/svgAsPngFile/has/been/disabled" +svgAsPngFile' width height svg = unsafePerformIO $ cacheFile template $ \pngPath -> do + let svgPath = replaceExtension pngPath "svg" + -- ffmpeg <- requireExecutable "ffmpeg" + -- convert <- requireExecutable "convert" + -- inkscape <- requireExecutable "inkscape" + writeFile svgPath rendered + -- FIXME: raster should be configurable. + applyRaster RasterRSvg svgPath + where + template = show (hash rendered) <.> "png" + rendered = renderSvg (Just $ Px $ fromIntegral width) (Just $ Px $ fromIntegral height) svg diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -3,27 +3,32 @@ , renderSvgs , renderSnippets , Format(..) + , Raster(..) , Width, Height, FPS + , applyRaster ) where import Control.Concurrent import Control.Exception -import Control.Monad (forM_) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Graphics.SvgTree (Number (..)) -import Reanimate.Misc +import Control.Monad (forM_, void) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Graphics.SvgTree (Number (..)) +import Numeric import Reanimate.Animation -import System.FilePath (()) +import Reanimate.Misc +import System.FilePath (()) +import System.FilePath (replaceExtension) +import System.Exit import System.IO -import Text.Printf (printf) +import Text.Printf (printf) renderSvgs :: Animation -> IO () renderSvgs ani = do print frameCount lock <- newMVar () - concurrentForM_ (frameOrder rate frameCount) $ \nth -> do + handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth -> do let -- frame = frameAt (recip (fromIntegral rate-1) * fromIntegral nth) ani now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth frame = frameAt (if frameCount<=1 then 0 else now) ani @@ -36,10 +41,13 @@ where rate = 60 frameCount = round (duration ani * fromIntegral rate) :: Int + errHandler (ErrorCall msg) = do + hPutStrLn stderr msg + exitWith (ExitFailure 1) -- XXX: Merge with 'renderSvgs' renderSnippets :: Animation -> IO () -renderSnippets ani = do +renderSnippets ani = forM_ [0..frameCount-1] $ \nth -> do let now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth frame = frameAt now ani @@ -59,10 +67,18 @@ filterFrameList :: [Int] -> Int -> Int -> [Int] filterFrameList seen nthFrame nFrames = - filter (not.isSeen) $ [0, nthFrame .. nFrames-1] + filter (not.isSeen) [0, nthFrame .. nFrames-1] where isSeen x = any (\y -> x `mod` y == 0) seen +data Raster + = RasterNone + | RasterAuto + | RasterInkscape + | RasterRSvg + | RasterConvert + deriving (Show) + data Format = RenderMp4 | RenderGif | RenderWebm deriving (Show) @@ -72,15 +88,16 @@ render :: Animation -> FilePath + -> Raster -> Format -> Width -> Height -> FPS -> IO () -render ani target format width height fps = do +render ani target raster format width height fps = do printf "Starting render of animation: %.1f\n" (duration ani) ffmpeg <- requireExecutable "ffmpeg" - generateFrames ani width height fps $ \template -> + generateFrames raster ani width height fps $ \template -> withTempFile "txt" $ \progress -> writeFile progress "" >> case format of RenderMp4 -> @@ -94,14 +111,14 @@ RenderGif -> withTempFile "png" $ \palette -> do runCmd ffmpeg ["-i", template, "-y" ,"-vf", "fps="++show fps++",scale=320:-1:flags=lanczos,palettegen" - ,"-t", show (duration ani) + ,"-t", showFFloat Nothing (duration ani) "" , palette ] - runCmd ffmpeg ["-i", template, "-y" + runCmd ffmpeg ["-framerate", show fps,"-i", template, "-y" ,"-i", palette ,"-progress", progress ,"-filter_complex" ,"fps="++show fps++",scale=320:-1:flags=lanczos[x];[x][1:v]paletteuse" - ,"-t", show (duration ani) + ,"-t", showFFloat Nothing (duration ani) "" , target] RenderWebm -> runCmd ffmpeg ["-r", show fps, "-i", template, "-y" @@ -112,32 +129,70 @@ --------------------------------------------------------------------------------- -- Helpers -generateFrames :: Animation -> Width -> Height -> FPS -> (FilePath -> IO a) -> IO a -generateFrames ani width_ height_ rate action = withTempDir $ \tmp -> do +generateFrames :: Raster -> Animation -> Width -> Height -> FPS -> (FilePath -> IO a) -> IO a +generateFrames raster ani width_ height_ rate action = withTempDir $ \tmp -> do done <- newMVar (0::Int) let frameName nth = tmp printf nameTemplate nth - concurrentForM_ frames $ \n -> do + putStr $ "\r0/" ++ show frameCount + hFlush stdout + handle h $ concurrentForM_ frames $ \n -> do writeFile (frameName n) $ renderSvg width height $ nthFrame n + applyRaster raster (frameName n) modifyMVar_ done $ \nDone -> do putStr $ "\r" ++ show (nDone+1) ++ "/" ++ show frameCount hFlush stdout return (nDone+1) putStrLn "\n" - action (tmp nameTemplate) + action (tmp rasterTemplate raster) where - width = Just $ Num $ fromIntegral width_ - height = Just $ Num $ fromIntegral height_ + width = Just $ Px $ fromIntegral width_ + height = Just $ Px $ fromIntegral height_ + h UserInterrupt = do + hPutStrLn stderr "\nCtrl-C detected. Trying to generate video with available frames. \ + \Hit ctrl-c again to abort." + return () + h other = throwIO other frames = [0..frameCount-1] nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani frameCount = round (duration ani * fromIntegral rate) :: Int nameTemplate :: String nameTemplate = "render-%05d.svg" +rasterTemplate :: Raster -> String +rasterTemplate RasterNone = "render-%05d.svg" +rasterTemplate _ = "render-%05d.png" + +applyRaster :: Raster -> FilePath -> IO () +applyRaster RasterNone _ = return () +applyRaster RasterAuto _ = return () +applyRaster RasterInkscape path = + runCmd "inkscape" + [ "--without-gui" + , "--file=" ++ path + , "--export-png=" ++ replaceExtension path "png" ] +applyRaster RasterRSvg path = + runCmd "rsvg-convert" + [ path + , "--unlimited" + , "--output", replaceExtension path "png" ] +applyRaster RasterConvert path = + runCmd "convert" + [ path + , replaceExtension path "png" ] + concurrentForM_ :: [a] -> (a -> IO ()) -> IO () concurrentForM_ lst action = do n <- getNumCapabilities sem <- newQSemN n + eVar <- newEmptyMVar forM_ lst $ \elt -> do waitQSemN sem 1 - forkIO (action elt `finally` signalQSemN sem 1) + emp <- isEmptyMVar eVar + if emp + then void $ forkIO (catch (action elt) (void . tryPutMVar eVar) `finally` signalQSemN sem 1) + else signalQSemN sem 1 waitQSemN sem n + mbE <- tryTakeMVar eVar + case mbE of + Nothing -> return () + Just e -> throwIO (e :: SomeException) diff --git a/src/Reanimate/Scene.hs b/src/Reanimate/Scene.hs --- a/src/Reanimate/Scene.hs +++ b/src/Reanimate/Scene.hs @@ -1,101 +1,206 @@ -{-# LANGUAGE RankNTypes #-} -module Reanimate.Scene where +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RankNTypes #-} +{-| +Module : Reanimate.Scene +Description : Imperative animation API +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +Scenes are an imperative way of defining animations. + +-} +module Reanimate.Scene + ( -- * Scenes + Scene + , ZIndex + , sceneAnimation -- :: (forall s. Scene s a) -> Animation + , play -- :: Animation -> Scene s () + , fork -- :: Scene s a -> Scene s a + , queryNow -- :: Scene s Time + , wait -- :: Duration -> Scene s () + , waitUntil -- :: Time -> Scene s () + , waitOn -- :: Scene s a -> Scene s a + , adjustZ -- :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a + , withSceneDuration -- :: Scene s () -> Scene s Duration + -- * Variables + , Var + , newVar -- :: a -> Scene s (Var s a) + , readVar -- :: Var s a -> Scene s a + , writeVar -- :: Var s a -> a -> Scene s () + , modifyVar -- :: Var s a -> (a -> a) -> Scene s () + , tweenVar -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + , tweenVarUnclamped -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + , simpleVar -- :: (a -> SVG) -> a -> Scene s (Var s a) + , findVar -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) + -- * Sprites + , Sprite + , Frame + , unVar -- :: Var s a -> Frame s a + , spriteT -- :: Frame s Time + , spriteDuration -- :: Frame s Duration + , newSprite -- :: Frame s SVG -> Scene s (Sprite s) + , newSpriteA -- :: Animation -> Scene s (Sprite s) + , newSpriteA' -- :: Sync -> Animation -> Scene s (Sprite s) + , newSpriteSVG -- :: SVG -> Scene s (Sprite s) + , destroySprite -- :: Sprite s -> Scene s () + , applyVar -- :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () + , spriteModify -- :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s () + , spriteMap -- :: Sprite s -> (SVG -> SVG) -> Scene s () + , spriteTween -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () + , spriteVar -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) + , spriteE -- :: Sprite s -> Effect -> Scene s () + , spriteZ -- :: Sprite s -> ZIndex -> Scene s () + + -- * ST internals + , liftST + ) + where + import Control.Monad.Fix import Control.Monad.ST import Data.List -import Data.Ord import Data.STRef +import Graphics.SvgTree (Tree (None)) import Reanimate.Animation -import Reanimate.Signal +import Reanimate.Effect +import Reanimate.Svg.Constructors +-- | The ZIndex property specifies the stack order of sprites and animations. Elements +-- with a higher ZIndex will be drawn on top of elements with a lower index. type ZIndex = Int -(#) :: a -> (a -> b) -> b -o # f = f o -- (seq duration, par duration) -- [(Time, Animation, ZIndex)] -- Map Time [(Animation, ZIndex)] -type Timeline = [(Time, Animation, ZIndex)] -newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, Timeline) } - -unionTimeline :: Timeline -> Timeline -> Timeline -unionTimeline = (++) - -emptyTimeline :: Timeline -emptyTimeline = [] +type Gen s = ST s (Duration -> Time -> (SVG, ZIndex)) +newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) } instance Functor (Scene s) where fmap f action = M $ \t -> do - (a, d1, d2, tl) <- unM action t - return (f a, d1, d2, tl) + (a, d1, d2, gens) <- unM action t + return (f a, d1, d2, gens) instance Applicative (Scene s) where - pure a = M $ \_ -> return (a, 0, 0, emptyTimeline) + pure a = M $ \_ -> return (a, 0, 0, []) f <*> g = M $ \t -> do - (f', s1, p1, tl1) <- unM f t - (g', s2, p2, tl2) <- unM g (t+s1) - return (f' g', s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2) + (f', s1, p1, gen1) <- unM f t + (g', s2, p2, gen2) <- unM g (t+s1) + return (f' g', s1+s2, max p1 (s1+p2), gen1++gen2) instance Monad (Scene s) where return = pure f >>= g = M $ \t -> do - (a, s1, p1, tl1) <- unM f t - (b, s2, p2, tl2) <- unM (g a) (t+s1) - return (b, s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2) + (a, s1, p1, gen1) <- unM f t + (b, s2, p2, gen2) <- unM (g a) (t+s1) + return (b, s1+s2, max p1 (s1+p2), gen1++gen2) instance MonadFix (Scene s) where - mfix fn = M $ \t -> mfix (\v -> let (a,_s,_p,_tl) = v in unM (fn a) t) + mfix fn = M $ \t -> mfix (\v -> let (a,_s,_p,_gens) = v in unM (fn a) t) liftST :: ST s a -> Scene s a -liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, emptyTimeline) +liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, []) sceneAnimation :: (forall s. Scene s a) -> Animation -sceneAnimation action = foldl' parDropA (pause 0) $ - map snd $ sortBy (comparing fst) - [ (z, pause startT `seqA` a) - | (startT, a, z) <- tl - ] - where - (_, _, _, tl) = runST (unM action 0) +sceneAnimation action = + runST (do + (_, s, p, gens) <- unM action 0 + let dur = max s p + genFns <- sequence gens + return $ mkAnimation dur (\t -> + mkGroup $ + map fst $ + sortOn snd + [ spriteRender dur (t*dur) + | spriteRender <- genFns ]) + ) +-- | Execute actions in a scene without advancing the clock. Note that scenes do not end before +-- all forked actions have completed. +-- +-- Example: +-- +-- > do fork $ play drawBox +-- > play drawCircle +-- +-- <> fork :: Scene s a -> Scene s a fork (M action) = M $ \t -> do - (a, s, p, tl) <- action t - return (a, 0, max s p, tl) + (a, s, p, gens) <- action t + return (a, 0, max s p, gens) +-- | Play an animation once and then remove it. This advances the clock by the duration of the +-- animation. +-- +-- Example: +-- +-- > do play drawBox +-- > play drawCircle +-- +-- <> play :: Animation -> Scene s () -play = playZ 0 - -playZ :: ZIndex -> Animation -> Scene s () -playZ z ani = M $ \t -> do - let d = duration ani - return ((), d, 0, [(t, ani, z)]) +play ani = newSpriteA ani >>= destroySprite +-- | Query the current clock timestamp. +-- +-- Example: +-- +-- > do now <- play drawCircle *> queryNow +-- > play $ staticFrame 1 $ scale 2 $ withStrokeWidth 0.05 $ +-- > mkText $ "Now=" <> T.pack (show now) +-- +-- <> queryNow :: Scene s Time -queryNow = M $ \t -> return (t, 0, 0, emptyTimeline) +queryNow = M $ \t -> return (t, 0, 0, []) --- Wait until all forked and sequential animations have finished. -waitAll :: Scene s a -> Scene s a -waitAll (M action) = M $ \t -> do - (a, s, p, tl) <- action t - return (a, max s p, 0, tl) +-- | Advance the clock by a given number of seconds. +-- +-- Example: +-- +-- > do fork $ play drawBox +-- > wait 1 +-- > play drawCircle +-- +-- <> +wait :: Duration -> Scene s () +wait d = M $ \_ -> + return ((), d, 0, []) +-- | Wait until the clock is equal to the given timestamp. waitUntil :: Time -> Scene s () waitUntil tNew = do now <- queryNow wait (max 0 (tNew - now)) -wait :: Duration -> Scene s () -wait d = M $ \_ -> - return ((), d, 0, emptyTimeline) +-- | Wait until all forked and sequential animations have finished. +-- +-- Examples: +-- +-- > do waitOn $ fork $ play drawBox +-- > play drawCircle +-- +-- <> +waitOn :: Scene s a -> Scene s a +waitOn (M action) = M $ \t -> do + (a, s, p, gens) <- action t + return (a, max s p, 0, gens) +-- | Change the ZIndex of a scene. adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a adjustZ fn (M action) = M $ \t -> do - (a, s, p, tl) <- action t - return (a, s, p, [ (startT, ani, fn z) | (startT, ani, z) <- tl ]) + (a, s, p, gens) <- action t + return (a, s, p, map genFn gens) + where + genFn gen = do + frameGen <- gen + return $ \d t -> + let (svg, z) = frameGen d t + in (svg, fn z) +-- | Query the duration of a scene. withSceneDuration :: Scene s () -> Scene s Duration withSceneDuration s = do t1 <- queryNow @@ -103,39 +208,340 @@ t2 <- queryNow return (t2-t1) -data Object s = Object (STRef s (Maybe Timeline)) +addGen :: Gen s -> Scene s () +addGen gen = M $ \_ -> return ((), 0, 0, [gen]) -newObject :: Scene s (Object s) -newObject = Object <$> liftST (newSTRef Nothing) +-- | Time dependent variable. +newtype Var s a = Var (STRef s (Time -> a)) -stretchTimeline :: Timeline -> Scene s () -stretchTimeline = mapM_ worker +-- | Create a new variable with a default value. +-- Variables always have a defined value even if they are read at a timestamp that is +-- earlier than when the variable was created. For example: +-- +-- > do v <- fork (wait 10 >> newVar 0) -- Create a variable at timestamp '10'. +-- > readVar v -- Read the variable at timestamp '0'. +-- > -- The value of the variable will be '0'. +newVar :: a -> Scene s (Var s a) +newVar def = Var <$> liftST (newSTRef (const def)) + +-- | Read the value of a variable at the current timestamp. +readVar :: Var s a -> Scene s a +readVar (Var ref) = liftST (readSTRef ref) <*> queryNow + +-- | Write the value of a variable at the current timestamp. +-- +-- Example: +-- +-- > do v <- newVar 0 +-- > newSprite $ mkCircle <$> unVar v +-- > writeVar v 1; wait 1 +-- > writeVar v 2; wait 1 +-- > writeVar v 3; wait 1 +-- +-- <> +writeVar :: Var s a -> a -> Scene s () +writeVar var val = modifyVar var (const val) + +-- | Modify the value of a variable at the current timestamp and all future timestamps. +modifyVar :: Var s a -> (a -> a) -> Scene s () +modifyVar (Var ref) fn = do + now <- queryNow + liftST $ modifySTRef ref $ \prev t -> + if t < now + then prev t + else fn (prev t) + +-- | Modify a variable between @now@ and @now+duration@. +-- Note: The modification function is invoked for past timestamps (with a time value of 0) and +-- for timestamps after @now+duration@ (with a time value of 1). See 'tweenVarUnclamped'. +tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () +tweenVar (Var ref) dur fn = do + now <- queryNow + liftST $ modifySTRef ref $ \prev t -> + fn (prev t) (max 0 (min dur $ t-now)/dur) + wait dur + +-- | Modify a variable between @now@ and @now+duration@. +-- Note: The modification function is invoked for past timestamps (with a negative time value) and +-- for timestamps after @now+duration@ (with a time value greater than 1). +tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () +tweenVarUnclamped (Var ref) dur fn = do + now <- queryNow + liftST $ modifySTRef ref $ \prev t -> + fn (prev t) ((t-now)/dur) + wait dur + +-- | Create and render a variable. The rendering will be born at the current timestamp +-- and will persist until the end of the scene. +-- +-- Example: +-- +-- > do var <- simpleVar mkCircle 0 +-- > tweenVar var 2 $ \val -> fromToS val (screenHeight/2) +-- +-- <> +simpleVar :: (a -> SVG) -> a -> Scene s (Var s a) +simpleVar render def = do + v <- newVar def + _ <- newSprite $ render <$> unVar v + return v + +-- | Helper function for filtering variables. +findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) +findVar _cond [] = error "Variable not found." +findVar cond (v:vs) = do + val <- readVar v + if cond val then return v else findVar cond vs + +-- | Sprites are animations with a given time of birth as well as a time of death. +-- They can be controlled using variables, tweening, and effects. +data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex)))) + +-- | Sprite frame generator. Generates frames over time in a stateful environment. +newtype Frame s a = Frame { unFrame :: ST s (Time -> Duration -> Time -> a) } + +instance Functor (Frame s) where + fmap fn (Frame gen) = Frame $ do + m <- gen + return (\real_t d t -> fn $ m real_t d t) + +instance Applicative (Frame s) where + pure v = Frame $ return (\_ _ _ -> v) + Frame f <*> Frame g = Frame $ do + m1 <- f + m2 <- g + return $ \real_t d t -> + m1 real_t d t (m2 real_t d t) + +-- | Dereference a variable as a Sprite frame. +-- +-- Example: +-- +-- > do v <- newVar 0 +-- > newSprite $ mkCircle <$> unVar v +-- > tweenVar v 1 $ \val -> fromToS val 3 +-- > tweenVar v 1 $ \val -> fromToS val 0 +-- +-- <> +unVar :: Var s a -> Frame s a +unVar (Var ref) = Frame $ do + fn <- readSTRef ref + return $ \real_t _d _t -> fn real_t + + +-- | Dereference seconds since sprite birth. +spriteT :: Frame s Time +spriteT = Frame $ return (\_real_t _d t -> t) + +-- | Dereference duration of the current sprite. +spriteDuration :: Frame s Duration +spriteDuration = Frame $ return (\_real_t d _t -> d) + +-- | Create new sprite defined by a frame generator. Unless otherwise specified using +-- 'destroySprite', the sprite will die at the end of the scene. +-- +-- Example: +-- +-- > do newSprite $ mkCircle <$> spriteT -- Circle sprite where radius=time. +-- > wait 2 +-- +-- <> +newSprite :: Frame s SVG -> Scene s (Sprite s) +newSprite render = do + now <- queryNow + ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0)) + addGen $ do + fn <- unFrame render + (spriteDur, spriteEffectGen) <- readSTRef ref + spriteEffect <- spriteEffectGen + return $ \d absT -> + let relD = (if spriteDur < 0 then d else spriteDur)-now + relT = absT-now in + if relT < 0 || (relD+now/=d && relD <= relT) + then (None, 0) + else spriteEffect relD relT (fn absT relD relT) + return $ Sprite now ref + +-- | Create a new sprite from an animation. This advances the clock by the +-- duration of the animation. Unless otherwise specified using +-- 'destroySprite', the sprite will die at the end of the scene. +-- +-- Note: If the scene doesn't end immediately after the duration of the +-- animation, the animation will be stretched to match the lifetime of the +-- sprite. See 'newSpriteA'' and 'play'. +-- +-- Example: +-- +-- > do fork $ newSpriteA drawCircle +-- > play drawBox +-- > play $ reverseA drawBox +-- +-- <> +newSpriteA :: Animation -> Scene s (Sprite s) +newSpriteA = newSpriteA' SyncStretch + +-- | Create a new sprite from an animation and specify the synchronization policy. This advances +-- the clock by the duration of the animation. +-- +-- Example: +-- +-- > do fork $ newSpriteA' SyncFreeze drawCircle +-- > play drawBox +-- > play $ reverseA drawBox +-- +-- <> +newSpriteA' :: Sync -> Animation -> Scene s (Sprite s) +newSpriteA' sync animation = + newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration) + <* wait (duration animation) + +-- | Create a sprite from a static SVG image. +-- +-- Example: +-- +-- > do newSpriteSVG $ mkBackground "lightblue" +-- > play drawCircle +-- +-- <> +newSpriteSVG :: SVG -> Scene s (Sprite s) +newSpriteSVG = newSprite . pure + +-- | Change the rendering of a sprite using data from a variable. If data from several variables +-- is needed, use a frame generator instead. +-- +-- Example: +-- +-- > do s <- fork $ newSpriteA drawBox +-- > v <- newVar 0 +-- > applyVar v s rotate +-- > tweenVar v 2 $ \val -> fromToS val 90 +-- +-- <> +applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () +applyVar var sprite fn = + spriteModify sprite $ do + varFn <- unVar var + return $ \(svg, zindex) -> + (fn varFn svg, zindex) + +-- | Destroy a sprite, preventing it from being rendered in the future of the scene. +-- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used. +-- +-- Example: +-- +-- > do s <- newSpriteSVG $ withFillOpacity 1 $ mkCircle 1 +-- > fork $ wait 1 >> destroySprite s +-- > play drawBox +-- +-- <> +destroySprite :: Sprite s -> Scene s () +destroySprite (Sprite _ ref) = do + now <- queryNow + liftST $ modifySTRef ref $ \(ttl, render) -> + (if ttl < 0 then now else min ttl now, render) + +-- | Low-level frame modifier. +spriteModify :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s () +spriteModify (Sprite born ref) modFn = + liftST $ modifySTRef ref $ \(ttl, renderGen) -> + (ttl, do + render <- renderGen + modRender <- unFrame modFn + return $ \relD relT -> + let absT = relT + born + in modRender absT relD relT . render relD relT) + +-- | Map the SVG output of a sprite. +-- +-- Example: +-- +-- > do s <- fork $ newSpriteA drawCircle +-- > wait 1 +-- > spriteMap s flipYAxis +-- +-- <> +spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s () +spriteMap sprite@(Sprite born _) fn = do + now <- queryNow + let tDelta = now - born + spriteModify sprite $ do + t <- spriteT + return $ \(svg, zindex) -> (if (t-tDelta) < 0 then svg else fn svg, zindex) + +-- | Modify the output of a sprite between @now@ and @now+duration@. +-- +-- Example: +-- +-- > do s <- fork $ newSpriteA drawCircle +-- > spriteTween s 1 $ \val -> translate (screenWidth*0.3*val) 0 +-- +-- <> +spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () +spriteTween sprite@(Sprite born _) dur fn = do + now <- queryNow + let tDelta = now - born + spriteModify sprite $ do + t <- spriteT + return $ \(svg, zindex) -> + (fn (clamp 0 1 $ (t-tDelta)/dur) svg, zindex) + wait dur where - worker (t, a, z) = M $ \tNow -> -- 3 - let tNew = t + duration a -- 1+1=2 - dNew = tNow - tNew -- 3-2=1 - aNew = setDuration dNew (signalA (constantS 1) a) in - if (dNew > 0) - then return ((), 0, 0, [(tNew, aNew, z)]) - else return ((), 0, 0, emptyTimeline) + clamp a b v + | v < a = a + | v > b = b + | otherwise = v -dropObject :: Object s -> Scene s () -dropObject (Object ref) = do - mbTimeline <- liftST $ readSTRef ref - case mbTimeline of - Nothing -> return () - Just timeline -> do - liftST $ writeSTRef ref Nothing - stretchTimeline timeline +-- | Create a new variable and apply it to a sprite. +-- +-- Example: +-- +-- > do s <- fork $ newSpriteA drawBox +-- > v <- spriteVar s 0 rotate +-- > tweenVar v 2 $ \val -> fromToS val 90 +-- +-- <> +spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) +spriteVar sprite def fn = do + v <- newVar def + applyVar v sprite fn + return v -listen :: Scene s a -> Scene s (a, Timeline) -listen scene = M $ \t -> do - (a, s, p, tl) <- unM scene t - return ((a,tl), s, p, tl) +-- | Apply an effect to a sprite. +-- +-- Example: +-- +-- > do s <- fork $ newSpriteA drawCircle +-- > spriteE s $ overBeginning 1 fadeInE +-- > spriteE s $ overEnding 0.5 fadeOutE +-- +-- <> +spriteE :: Sprite s -> Effect -> Scene s () +spriteE (Sprite born ref) effect = do + now <- queryNow + liftST $ modifySTRef ref $ \(ttl, renderGen) -> + (ttl, do + render <- renderGen + return $ \d t svg -> + let (svg', z) = render d t svg + in (delayE (max 0 $ now-born) effect d t svg', z)) -withObject :: Object s -> Scene s a -> Scene s a -withObject obj@(Object ref) scene = do - dropObject obj - (a, tl) <- listen scene - liftST $ writeSTRef ref (Just tl) - return a +-- | Set new ZIndex of a sprite. +-- +-- Example: +-- +-- > do s1 <- newSpriteSVG $ withFillOpacity 1 $ withFillColor "blue" $ mkCircle 3 +-- > newSpriteSVG $ withFillOpacity 1 $ withFillColor "red" $ mkRect 8 3 +-- > wait 1 +-- > spriteZ s1 1 +-- > wait 1 +-- +-- <> +spriteZ :: Sprite s -> ZIndex -> Scene s () +spriteZ (Sprite born ref) zindex = do + now <- queryNow + liftST $ modifySTRef ref $ \(ttl, renderGen) -> + (ttl, do + render <- renderGen + return $ \d t svg -> + let (svg', z) = render d t svg + in (svg', if t < now-born then z else zindex)) diff --git a/src/Reanimate/Signal.hs b/src/Reanimate/Signal.hs --- a/src/Reanimate/Signal.hs +++ b/src/Reanimate/Signal.hs @@ -4,6 +4,7 @@ , fromToS , reverseS , curveS + , powerS , bellS , oscillateS , fromListS @@ -30,7 +31,7 @@ -- -- <> constantS :: Double -> Signal -constantS x = const x +constantS = const -- | Signal with new starting and end values. -- @@ -64,6 +65,9 @@ if s < 0.5 then 0.5 * (2*s)**steepness else 1-0.5 * (2 - 2*s)**steepness + +powerS :: Double -> Signal +powerS steepness s = s**steepness -- | Oscillate signal. -- diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs --- a/src/Reanimate/Svg.hs +++ b/src/Reanimate/Svg.hs @@ -7,12 +7,14 @@ , module Reanimate.Svg.Unuse ) where -import Control.Lens ((%~), (&), (.~), (^.)) +import Control.Lens ((%~), (&), (.~), (^.), (?~)) import Control.Monad.State import Graphics.SvgTree hiding (height, line, path, use, width) import Linear.V2 hiding (angle) +import Data.Monoid ((<>)) import Reanimate.Constants +import Reanimate.Animation (SVG) import Reanimate.Svg.Constructors import Reanimate.Svg.LineCommand import Reanimate.Svg.BoundingBox @@ -38,7 +40,8 @@ GroupTree g -> GroupTree $ g & groupChildren %~ map (worker m') & transform .~ Nothing - _ -> mkGroup [t] & transform .~ Just [ Transform.toTransformation m ] + ClipPathTree{} -> t + _ -> mkGroup [t] & transform ?~ [ Transform.toTransformation m ] lowerIds :: Tree -> Tree lowerIds = mapTree worker @@ -56,7 +59,7 @@ where worker None = [] worker (DefinitionTree d) = - concatMap dropNulls $ + concatMap dropNulls [DefinitionTree $ d & groupChildren %~ concatMap worker] worker (GroupTree g) | g ^. drawAttributes == defaultSvg = @@ -74,6 +77,28 @@ | null (g^.groupChildren) = [] dropNulls t = [t] +removeGroups :: Tree -> [Tree] +removeGroups = worker defaultSvg + where + worker _attr None = [] + worker _attr (DefinitionTree d) = + concatMap dropNulls $ + [DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)] + worker attr (GroupTree g) + | g ^. drawAttributes == defaultSvg = + concatMap dropNulls $ + concatMap (worker attr) (g^.groupChildren) + | otherwise = + concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren) + worker attr t = dropNulls (t & drawAttributes .~ attr) + + dropNulls None = [] + dropNulls (DefinitionTree d) + | null (d^.groupChildren) = [] + dropNulls (GroupTree g) + | null (g^.groupChildren) = [] + dropNulls t = [t] + extractPath :: Tree -> [PathCommand] extractPath = worker . simplify . lowerTransformations . pathify where @@ -156,6 +181,24 @@ in concatMap (worker acc' attr') (g ^. groupChildren) t -> [(acc, attr, t)] +{-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or + 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being + drawn progressively with 'partialSvg'. + + Example: + + > pathifyExample :: Animation + > pathifyExample = animate $ \t -> gridLayout + > [ [ partialSvg t $ pathify $ mkCircle 1 + > , partialSvg t $ pathify $ mkRect 2 2 + > ] + > , [ partialSvg t $ pathify $ mkEllipse 1 0.5 + > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1) + > ] + > ] + + <> + -} pathify :: Tree -> Tree pathify = mapTree worker where @@ -163,7 +206,8 @@ \case RectangleTree rect | Just (x,y,w,h) <- unpackRect rect -> PathTree $ defaultSvg - & drawAttributes .~ rect ^. drawAttributes & strokeLineCap .~ pure CapSquare + & drawAttributes .~ rect ^. drawAttributes + & strokeLineCap .~ pure CapSquare & pathDefinition .~ [MoveTo OriginAbsolute [V2 x y] ,HorizontalTo OriginRelative [w] @@ -181,12 +225,35 @@ & drawAttributes .~ circ ^. drawAttributes & pathDefinition .~ [MoveTo OriginAbsolute [V2 (x-r) y] - ,EllipticalArc OriginRelative [(r, r, 0,True,False,(V2 (r*2) 0)) - ,(r, r, 0,True,False,(V2 (-r*2) 0))]] + ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0) + ,(r, r, 0,True,False,V2 (-r*2) 0)]] + PolyLineTree pl -> + let points = pl ^. polyLinePoints + in PathTree $ defaultSvg + & drawAttributes .~ pl ^. drawAttributes + & pathDefinition .~ pointsToPathCommands points + PolygonTree pg -> + let points = pg ^. polygonPoints + in PathTree $ defaultSvg + & drawAttributes .~ pg ^. drawAttributes + -- Polygon automatically connects the last point to the first. For path we must do + -- it explicitly + & pathDefinition .~ (pointsToPathCommands points ++ [EndPath]) + EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip -> + PathTree $ defaultSvg + & drawAttributes .~ elip ^. drawAttributes + & pathDefinition .~ + [ MoveTo OriginAbsolute [V2 (cx-rx) cy] + , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0) + ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]] t -> t unpackCircle circ = do let (x,y) = circ ^. circleCenter liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius) + unpackEllipse elip = do + let (x,y) = elip ^. ellipseCenter + liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius) + (unpackNumber $ elip ^. ellipseYRadius) unpackLine line = do let (x1,y1) = line ^. linePoint1 (x2,y2) = line ^. linePoint2 @@ -198,7 +265,36 @@ w <- unpackNumber =<< rect ^. rectWidth h <- unpackNumber =<< rect ^. rectHeight return (x,y,w,h) + pointsToPathCommands points = case points of + [] -> [] + (p:ps) -> [ MoveTo OriginAbsolute [p] + , LineTo OriginAbsolute ps ] unpackNumber n = case toUserUnit defaultDPI n of Num d -> Just d _ -> Nothing + +mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG +mapSvgPaths fn = mapTree worker + where + worker = + \case + PathTree path -> PathTree $ + path & pathDefinition %~ fn + t -> t + +mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG +mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands) + +-- Only maps points in paths +mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG +mapSvgPoints fn = mapSvgLines (map worker) + where + worker (LineMove p) = LineMove (fn p) + worker (LineBezier ps) = LineBezier (map fn ps) + worker (LineEnd p) = LineEnd (fn p) + +svgPointsToRadians :: SVG -> SVG +svgPointsToRadians = mapSvgPoints worker + where + worker (V2 x y) = V2 (x/180*pi) (y/180*pi) diff --git a/src/Reanimate/Svg/BoundingBox.hs b/src/Reanimate/Svg/BoundingBox.hs --- a/src/Reanimate/Svg/BoundingBox.hs +++ b/src/Reanimate/Svg/BoundingBox.hs @@ -1,18 +1,20 @@ module Reanimate.Svg.BoundingBox where -import Control.Arrow -import Control.Lens ((^.)) +import Control.Arrow ((***)) +import Control.Lens ((^.)) import Data.List -import Graphics.SvgTree hiding (height, line, path, use, - width) -import Linear.V2 hiding (angle) +import Data.Maybe (mapMaybe) +import Graphics.SvgTree hiding (height, line, path, use, + width) +import Linear.V2 hiding (angle) import Linear.Vector import Reanimate.Constants import Reanimate.Svg.LineCommand -import qualified Reanimate.Transform as Transform +import qualified Reanimate.Transform as Transform -- import qualified Geom2D.CubicBezier as Bezier --- (x,y,w,h) +-- | Return bounding box of SVG tree. +-- The four numbers returned are (minimal X-coordinate, minimal Y-coordinate, width, height) boundingBox :: Tree -> (Double, Double, Double, Double) boundingBox t = case svgBoundingPoints t of @@ -27,12 +29,12 @@ svgHeight :: Tree -> Double svgHeight t = h where - (_w, h, _x, _y) = boundingBox t + (_x, _y, _w, h) = boundingBox t svgWidth :: Tree -> Double svgWidth t = w where - (w, _h, _x, _y) = boundingBox t + (_x, _y, w, _h) = boundingBox t linePoints :: [LineCommand] -> [RPoint] linePoints = worker zero @@ -44,7 +46,7 @@ -- LineDraw to -> from:to:worker to xs -- FIXME: Use approximation from Geom2D.Bezier LineBezier ctrl -> -- approximation - [ last (partial_bezier_points (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++ + [ last (partialBezierPoints (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++ worker (last ctrl) xs LineEnd p -> p : worker p xs chunks = 10 @@ -59,9 +61,9 @@ FilterTree{} -> [] DefinitionTree{} -> [] PathTree p -> linePoints $ toLineCommands (p^.pathDefinition) - CircleTree{} -> error "Bounding box: CircleTree" - PolyLineTree{} -> error "Bounding box: PolyLineTree" - EllipseTree{} -> error "Bounding box: EllipseTree" + CircleTree c -> circleBoundingPoints c + PolyLineTree pl -> pl ^. polyLinePoints + EllipseTree e -> ellipseBoundingPoints e LineTree line -> map pointToRPoint [line^.linePoint1, line^.linePoint2] RectangleTree rect -> case pointToRPoint (rect^.rectUpperLeftCorner) of @@ -84,3 +86,23 @@ case mapTuple (toUserUnit defaultDPI) p of (Num x, Num y) -> V2 x y _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format." + + circleBoundingPoints circ = + let (xnum, ynum) = circ ^. circleCenter + rnum = circ ^. circleRadius + in case mapMaybe unpackNumber [xnum, ynum, rnum] of + [x, y, r] -> [ V2 (x + r * cos angle) (y + r * sin angle) | angle <- [0, pi/10 .. 2 * pi]] + _ -> [] + + ellipseBoundingPoints e = + let (xnum,ynum) = e ^. ellipseCenter + xrnum = e ^. ellipseXRadius + yrnum = e ^. ellipseYRadius + in case mapMaybe unpackNumber [xnum, ynum, xrnum, yrnum] of + [x,y,xr,yr] -> [V2 (x + xr * cos angle) (y + yr * sin angle) | angle <- [0, pi/10 .. 2 * pi]] + _ -> [] + + unpackNumber n = + case toUserUnit defaultDPI n of + Num d -> Just d + _ -> Nothing diff --git a/src/Reanimate/Svg/Constructors.hs b/src/Reanimate/Svg/Constructors.hs --- a/src/Reanimate/Svg/Constructors.hs +++ b/src/Reanimate/Svg/Constructors.hs @@ -1,5 +1,58 @@ -module Reanimate.Svg.Constructors where +{-| Functions for creating basic SVG elements and applying transformations to them. -} +module Reanimate.Svg.Constructors + ( -- * Primitive shapes + mkCircle + , mkEllipse + , mkRect + , mkLine + , mkPath + , mkPathString + , mkPathText + , mkLinePath + , mkClipPath + , mkText + -- * Grouping shapes and definitions + , mkGroup + , mkDefinitions + , mkUse + -- * Attributes + , withId + , withStrokeColor + , withStrokeColorPixel + , withStrokeLineJoin + , withFillColor + , withFillColorPixel + , withFillOpacity + , withGroupOpacity + , withStrokeWidth + , withClipPathRef + -- * Transformations + , center + , centerX + , centerY + , translate + , rotate + , rotateAroundCenter + , rotateAround + , scale + , scaleToSize + , scaleToWidth + , scaleToHeight + , scaleXY + , flipXAxis + , flipYAxis + , aroundCenter + , aroundCenterX + , aroundCenterY + , withTransformations + -- * Other + , mkColor + , mkBackground + , mkBackgroundPixel + , gridLayout + ) where + import Codec.Picture (PixelRGBA8 (..)) import Control.Lens ((&), (.~), (?~)) import Data.Attoparsec.Text (parseOnly) @@ -13,146 +66,248 @@ import Reanimate.Constants import Reanimate.Svg.BoundingBox +-- | Apply list of transformations to given image. withTransformations :: [Transformation] -> Tree -> Tree withTransformations transformations t = mkGroup [t] & transform ?~ transformations +-- | @translate x y image@ moves the @image@ by @x@ along X-axis and by @y@ along Y-axis. translate :: Double -> Double -> Tree -> Tree translate x y = withTransformations [Translate x y] +-- | @rotate angle image@ rotates the @image@ around origin @(0,0)@ counterclockwise by @angle@ +-- given in degrees. rotate :: Double -> Tree -> Tree rotate a = withTransformations [Rotate a Nothing] +-- | @rotate angle point image@ rotates the @image@ around given @point@ counterclockwise by +-- @angle@ given in degrees. rotateAround :: Double -> RPoint -> Tree -> Tree rotateAround a (V2 x y) = withTransformations [Rotate a (Just (x,y))] +-- | @rotate angle image@ rotates the @image@ around the center of its bounding box counterclockwise +-- by @angle@ given in degrees. rotateAroundCenter :: Double -> Tree -> Tree rotateAroundCenter a t = - rotateAround a (V2 (x+w/h) (y+h/2)) t + rotateAround a (V2 (x+w/2) (y+h/2)) t where (x,y,w,h) = boundingBox t +-- | @aroundCenter f image@ first moves the image so the center of its bounding box is at the origin +-- @(0, 0)@, applies transformation @f@ to it and then moves the transformed image back to its +-- original position. +aroundCenter :: (Tree -> Tree) -> Tree -> Tree +aroundCenter fn t = + translate (-offsetX) (-offsetY) $ fn $ translate offsetX offsetY t + where + offsetX = -x-w/2 + offsetY = -y-h/2 + (x,y,w,h) = boundingBox t + +aroundCenterY :: (Tree -> Tree) -> Tree -> Tree +aroundCenterY fn t = + translate 0 (-offsetY) $ fn $ translate 0 offsetY t + where + offsetY = -y-h/2 + (_x,y,_w,h) = boundingBox t + +aroundCenterX :: (Tree -> Tree) -> Tree -> Tree +aroundCenterX fn t = + translate (-offsetX) 0 $ fn $ translate offsetX 0 t + where + offsetX = -x-w/2 + (x,_y,w,_h) = boundingBox t + +-- | Scale the image uniformly by given factor along both X and Y axes. +-- For example @scale 2 image@ makes the image twice as large, while @scale 0.5 image@ makes it +-- half the original size. Negative values are also allowed, and lead to flipping the image along +-- both X and Y axes. scale :: Double -> Tree -> Tree scale a = withTransformations [Scale a Nothing] +-- | @scaleToSize width height@ resizes the image so that its bounding box has corresponding @width@ +-- and @height@. scaleToSize :: Double -> Double -> Tree -> Tree scaleToSize w h t = scaleXY (w/w') (h/h') t where (_x, _y, w', h') = boundingBox t +-- | @scaleToWidth width@ scales the image so that the width of its bounding box ends up having +-- given @width@. scaleToWidth :: Double -> Tree -> Tree scaleToWidth w t = scale (w/w') t where (_x, _y, w', _h') = boundingBox t +-- | @scaleToHeight height@ scales the image so that the height of its bounding box ends up having +-- given @height@. scaleToHeight :: Double -> Tree -> Tree scaleToHeight h t = scale (h/h') t where (_x, _y, _w', h') = boundingBox t +-- | Similar to 'scale', except scale factors for X and Y axes are specified separately. scaleXY :: Double -> Double -> Tree -> Tree scaleXY x y = withTransformations [Scale x (Just y)] + +-- | Flip the image along vertical axis so that what was on the right will end up on left and vice +-- versa. flipXAxis :: Tree -> Tree flipXAxis = scaleXY (-1) 1 +-- | Flip the image along horizontal so that what was on the top will end up in the bottom and vice +-- versa. flipYAxis :: Tree -> Tree flipYAxis = scaleXY 1 (-1) +-- | Translate given image so that the center of its bouding box coincides with coordinates +-- @(0, 0)@. center :: Tree -> Tree center t = translate (-x-w/2) (-y-h/2) t where (x, y, w, h) = boundingBox t +-- | Translate given image so that the X-coordinate of the center of its bouding box is 0. centerX :: Tree -> Tree centerX t = translate (-x-w/2) 0 t where (x, _y, w, _h) = boundingBox t +-- | Translate given image so that the Y-coordinate of the center of its bouding box is 0. centerY :: Tree -> Tree centerY t = translate 0 (-y-h/2) t where (_x, y, _w, h) = boundingBox t +-- | Create 'Texture' based on SVG color name. +-- See for the list of available names. +-- If the provided name doesn't correspond to valid SVG color name, white-ish color is used. mkColor :: String -> Texture mkColor name = case Map.lookup (T.pack name) svgNamedColors of Nothing -> ColorRef (PixelRGBA8 240 248 255 255) Just c -> ColorRef c +-- | See withStrokeColor :: String -> Tree -> Tree withStrokeColor color = strokeColor .~ pure (mkColor color) +withStrokeColorPixel :: PixelRGBA8 -> Tree -> Tree +withStrokeColorPixel color = strokeColor .~ pure (ColorRef color) + +-- | See withStrokeLineJoin :: LineJoin -> Tree -> Tree withStrokeLineJoin ljoin = strokeLineJoin .~ pure ljoin +-- | See withFillColor :: String -> Tree -> Tree withFillColor color = fillColor .~ pure (mkColor color) withFillColorPixel :: PixelRGBA8 -> Tree -> Tree withFillColorPixel color = fillColor .~ pure (ColorRef color) +-- | See withFillOpacity :: Double -> Tree -> Tree withFillOpacity opacity = fillOpacity ?~ realToFrac opacity withGroupOpacity :: Double -> Tree -> Tree withGroupOpacity opacity = groupOpacity ?~ realToFrac opacity +-- | See withStrokeWidth :: Double -> Tree -> Tree withStrokeWidth width = strokeWidth .~ pure (Num width) -withClipPathRef :: ElementRef -> Tree -> Tree -withClipPathRef ref = clipPathRef .~ pure ref +-- | See +withClipPathRef :: ElementRef -- ^ Reference to clip path defined previously (e.g. by 'mkClipPath') + -> Tree -- ^ Image that will be clipped by the referenced clip path + -> Tree +withClipPathRef ref sub = mkGroup [sub] & clipPathRef .~ pure ref +-- | Assigns ID attribute to given image. withId :: String -> Tree -> Tree withId idTag = attrId ?~ idTag +-- | @mkRect width height@ creates a rectangle with given @with@ and @height@, centered at @(0, 0)@. +-- See mkRect :: Double -> Double -> Tree mkRect width height = translate (-width/2) (-height/2) $ RectangleTree $ defaultSvg & rectUpperLeftCorner .~ (Num 0, Num 0) & rectWidth ?~ Num width & rectHeight ?~ Num height +-- | Create a circle with given radius, centered at @(0, 0)@. +-- See mkCircle :: Double -> Tree mkCircle radius = CircleTree $ defaultSvg & circleCenter .~ (Num 0, Num 0) & circleRadius .~ Num radius +-- | Create an ellipse given X-axis radius, and Y-axis radius, with center at @(0, 0)@. +-- See +mkEllipse :: Double -> Double -> Tree +mkEllipse rx ry = EllipseTree $ defaultSvg + & ellipseCenter .~ (Num 0, Num 0) + & ellipseXRadius .~ Num rx + & ellipseYRadius .~ Num ry + +-- | Create a line segment between two points given by their @(x, y)@ coordinates. +-- See mkLine :: (Double,Double) -> (Double, Double) -> Tree mkLine (x1,y1) (x2,y2) = LineTree $ defaultSvg & linePoint1 .~ (Num x1, Num y1) & linePoint2 .~ (Num x2, Num y2) +-- | Merges multiple images into one. +-- See mkGroup :: [Tree] -> Tree mkGroup forest = GroupTree $ defaultSvg & groupChildren .~ forest +-- | Create definition of graphical objects that can be used at later time. +-- See mkDefinitions :: [Tree] -> Tree mkDefinitions forest = DefinitionTree $ defaultSvg & groupChildren .~ forest +-- | Create an element by referring to existing element defined previously. +-- For example you can create a graphical element, assign ID to it using 'withId', wrap it in +-- 'mkDefinitions' and then use it via @use "myId"@. +-- See mkUse :: String -> Tree mkUse name = UseTree (defaultSvg & useName .~ name) Nothing -mkClipPath :: String -> [Tree] -> Tree -mkClipPath idTag forest = withId idTag $ ClipPathTree (defaultSvg - & clipPathContent .~ forest) +-- | A clip path restricts the region to which paint can be applied. +-- See +mkClipPath :: String -- ^ ID of the clip path, which can then be referred to by other elements + -- using 'withClipPathRef'. + -> [Tree] -- ^ List of shapes that will determine the final shape of the clipping region + -> Tree +mkClipPath idTag forest = withId idTag $ ClipPathTree $ defaultSvg + & clipPathContent .~ forest +-- | Create a path from the list of path commands. +-- See mkPath :: [PathCommand] -> Tree mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds +-- | Similar to 'mkPathText', but taking SVG path command as a String. mkPathString :: String -> Tree mkPathString = mkPathText . T.pack +-- | Create path from textual representation of SVG path command. +-- If the text doesn't represent valid path command, this function fails with 'Prelude.error'. +-- Use 'mkPath' for type safe way of creating paths. mkPathText :: T.Text -> Tree mkPathText str = case parseOnly pathParser str of Left err -> error err Right cmds -> mkPath cmds +-- | Create a path from a list of @(x, y)@ coordinates of points along the path. mkLinePath :: [(Double, Double)] -> Tree mkLinePath [] = mkGroup [] mkLinePath ((startX, startY):rest) = @@ -161,22 +316,55 @@ cmds = [ MoveTo OriginAbsolute [V2 startX startY] , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] ] +-- | Rectangle with a uniform color and the same size as the screen. +-- +-- Example: +-- +-- > animate $ const $ mkBackground "yellow" +-- +-- <> mkBackground :: String -> Tree -mkBackground color = withFillColor color $ mkRect screenWidth screenHeight +mkBackground color = withFillOpacity 1 $ withStrokeWidth 0 $ + withFillColor color $ mkRect screenWidth screenHeight mkBackgroundPixel :: PixelRGBA8 -> Tree mkBackgroundPixel pixel = + withFillOpacity 1 $ withStrokeWidth 0 $ withFillColorPixel pixel $ mkRect screenWidth screenHeight +-- | Take list of rows, where each row consists of number of images and display them in regular +-- grid structure. +-- All rows will get equal amount of vertical space. +-- The images within each row will get equal amount of horizontal space, independent of the other +-- rows. Each row can contain different number of cells. gridLayout :: [[Tree]] -> Tree gridLayout rows = mkGroup [ translate (-screenWidth/2+colSep*nCol) (screenHeight/2-rowSep*nRow) elt - | (nRow, col) <- zip [1..] rows - , let nCols = length col + | (nRow, row) <- zip [1..] rows + , let nCols = length row colSep = screenWidth / fromIntegral (nCols+1) - , (nCol, elt) <- zip [1..] col ] + , (nCol, elt) <- zip [1..] row ] where rowSep = screenHeight / fromIntegral (nRows+1) nRows = length rows + +-- | Insert a native text object anchored at the middle. +-- +-- Example: +-- +-- > mkAnimation 2 $ \t -> scale 2 $ withStrokeWidth 0.05 $ mkText (T.take (round $ t*15) "text") +-- +-- <> +mkText :: T.Text -> Tree +mkText str = + flipYAxis + (TextTree Nothing $ defaultSvg + & textRoot .~ span_ + & fontSize .~ pure (Num 2)) + & textAnchor .~ pure TextAnchorMiddle + -- Note: TextAnchorMiddle is placed on the 'flipYAxis' group such that it can easily + -- be overwritten by the user. + where + span_ = defaultSvg & spanContent .~ [SpanText str] diff --git a/src/Reanimate/Svg/LineCommand.hs b/src/Reanimate/Svg/LineCommand.hs --- a/src/Reanimate/Svg/LineCommand.hs +++ b/src/Reanimate/Svg/LineCommand.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE LambdaCase #-} module Reanimate.Svg.LineCommand where import Control.Lens ((%~), (&), (.~)) import Control.Monad.Fix import Control.Monad.State +import Data.Functor import Graphics.SvgTree hiding (height, line, path, use, width) import Linear.Metric import Linear.V2 hiding (angle) import Linear.Vector --- import qualified Geom2D.CubicBezier as Bezier +import qualified Data.Vector.Unboxed as V +import qualified Geom2D.CubicBezier as Bezier type CmdM a = State RPoint a @@ -57,7 +58,7 @@ adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand adjustLineLength alpha from cmd = case cmd of - LineBezier points -> LineBezier $ drop 1 $ partial_bezier_points (from:points) 0 alpha + LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from:points) 0 alpha LineMove p -> LineMove p -- LineDraw t -> LineDraw (lerp alpha t from) LineEnd p -> LineBezier [lerp alpha p from] @@ -65,7 +66,7 @@ lineLength :: LineCommand -> CmdM Double lineLength cmd = case cmd of - LineMove to -> pure 0 <* put to + LineMove to -> 0 <$ put to -- LineDraw to -> gets (distance to) <* put to LineBezier points -> gets (distance (last points)) <* put (last points) LineEnd to -> gets (distance to) <* put to @@ -90,12 +91,12 @@ mkStraightLine p = LineBezier [p] toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand] -toLineCommand startPos mbPrevControlPt cmd = do +toLineCommand startPos mbPrevControlPt cmd = case cmd of MoveTo OriginAbsolute [] -> pure [] MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure.LineMove) MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure.LineMove) - LineTo OriginAbsolute lst -> forM lst (\to -> put to *> pure (mkStraightLine to)) + LineTo OriginAbsolute lst -> forM lst (\to -> put to $> mkStraightLine to) LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine) HorizontalTo OriginAbsolute lst -> forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine @@ -105,9 +106,9 @@ forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine VerticalTo OriginRelative lst -> forM lst $ \y -> modify (_y %~ (+y)) *> gets mkStraightLine - CurveTo OriginAbsolute quads -> do - forM quads $ \(a,b,c) -> put c *> pure (LineBezier [a,b,c]) - CurveTo OriginRelative quads -> do + CurveTo OriginAbsolute quads -> + forM quads $ \(a,b,c) -> put c $> LineBezier [a,b,c] + CurveTo OriginRelative quads -> forM quads $ \(a,b,c) -> do from <- get <* modify (+c) pure $ LineBezier $ map (+from) [a,b,c] @@ -117,9 +118,9 @@ from <- get <* adjustPosition o to let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl pure $ LineBezier [c1,makeAbsolute o from c2,makeAbsolute o from to] - QuadraticBezier OriginAbsolute pairs -> do - forM pairs $ \(a,b) -> put b *> pure (LineBezier [a,b]) - QuadraticBezier OriginRelative pairs -> do + QuadraticBezier OriginAbsolute pairs -> + forM pairs $ \(a,b) -> put b $> LineBezier [a,b] + QuadraticBezier OriginRelative pairs -> forM pairs $ \(a,b) -> do from <- get <* modify (+b) pure $ LineBezier $ map (+from) [a,b] @@ -130,10 +131,10 @@ let c1 = maybe from (mirrorPoint from) mbControl pure $ LineBezier [c1,makeAbsolute o from to] EllipticalArc o points -> concat <$> - (forM points $ \(rotX, rotY, angle, largeArc, sweepFlag, to) -> do + forM points (\(rotX, rotY, angle, largeArc, sweepFlag, to) -> do from <- get <* adjustPosition o to return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to)) - EndPath -> put startPos *> pure [LineEnd startPos] + EndPath -> put startPos $> [LineEnd startPos] where mirrorPoint c p = c*2-p adjustPosition OriginRelative p = modify (+p) @@ -153,6 +154,7 @@ tb = atan2 vy vx -- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs +{- HLINT ignore convertSvgArc -} convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand] convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y) | x0 == x && y0 == y @@ -188,7 +190,7 @@ dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry) dtheta = if (not sweepFlag && dtheta' > 0) then (dtheta' - 2 * pi) - else (if (sweepFlag && dtheta' < 0) then (dtheta' + 2 * pi) else dtheta') + else (if (sweepFlag && dtheta' < 0) then dtheta' + 2 * pi else dtheta') segments' = ceiling (abs (dtheta / (pi / 2.0))) delta = dtheta / fromInteger segments' @@ -217,30 +219,30 @@ dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2) dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2) - --- Algorithm taken from manim. It's magic. -bezier :: [RPoint] -> Double -> RPoint -bezier points t = sum - [ point ^* (((1-t)**(fromIntegral $ n-k)) * (t**fromIntegral k) * fromIntegral (choose n k)) - | (k, point) <- zip [0..] points - , let n = length points-1 ] - where - choose n k = product [n,n-1 .. n-k+1] `div` product [1..k] - -partial_bezier_points :: [RPoint] -> Double -> Double -> [RPoint] -partial_bezier_points points a b - | isNaN end_prop || isInfinite end_prop = replicate (length points) (last points) - | otherwise = [ bezier (take (i+1) a_to_1) end_prop | i <- [0..length points-1] ] - where - a_to_1 = [ bezier (drop i points) a | i <- [0..length points-1] ] - end_prop = (b-a) / (1-a) - - +partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint] +partialBezierPoints ps a b = + let fromP (V2 i j) = (i, j) + toP (i, j) = V2 i j + c1 :: Bezier.AnyBezier Double + c1 = Bezier.unsafeFromVector (V.fromList $ map fromP ps) + os = V.toList $ Bezier.toVector $ Bezier.bezierSubsegment c1 a b + in map toP os interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand] interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands -partialSvg :: Double -> Tree -> Tree +{- | Create an image showing portion of a path. + Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath'). + You can also use this with other SVG shapes if you convert them to path first (see 'Reanimate.Svg.pathify'). + + Typical usage: + + > animate $ \t -> partialSvg t myPath +-} +partialSvg :: Double -- ^ number between 0 and 1 inclusively, determining what portion of the path to show + -> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument + -> Tree +partialSvg alpha | alpha >= 1 = id partialSvg alpha = mapTree worker where worker (PathTree path) = diff --git a/src/Reanimate/Svg/Unuse.hs b/src/Reanimate/Svg/Unuse.hs --- a/src/Reanimate/Svg/Unuse.hs +++ b/src/Reanimate/Svg/Unuse.hs @@ -1,18 +1,17 @@ module Reanimate.Svg.Unuse ( replaceUses , unbox + , embedDocument ) where -import Control.Lens ((%~), (&), (.~), (^.),(?~)) -import qualified Data.Map as Map -import Graphics.SvgTree hiding (height, line, path, use, - width) +import Control.Lens ((%~), (&), (.~), (?~), (^.)) +import qualified Data.Map as Map +import Graphics.SvgTree hiding (line, path, use) import Reanimate.Constants import Reanimate.Svg.Constructors replaceUses :: Document -> Document replaceUses doc = doc & elements %~ map (mapTree replace) - & definitions .~ Map.empty where replaceDefinition PathTree{} = None replaceDefinition t = t @@ -32,8 +31,7 @@ (Num a, Num b) -> Translate a b _ -> TransformUnknown docTree = mkGroup (doc^.elements) - idMap = foldTree updMap Map.empty docTree `Map.union` - (doc^.definitions) + idMap = foldTree updMap Map.empty docTree updMap m tree = case tree^.attrId of Nothing -> m @@ -48,3 +46,12 @@ unbox doc = GroupTree $ defaultSvg & groupChildren .~ doc^.elements + +embedDocument :: Document -> Tree +embedDocument doc = + translate (-screenWidth/2) (screenHeight/2) $ + withFillOpacity 1 $ + withStrokeWidth 0 $ + flipYAxis $ + SvgTree $ doc & width .~ Nothing + & height .~ Nothing diff --git a/src/Reanimate/Transform.hs b/src/Reanimate/Transform.hs --- a/src/Reanimate/Transform.hs +++ b/src/Reanimate/Transform.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE PackageImports #-} module Reanimate.Transform ( identity @@ -26,7 +27,13 @@ transformPoint :: TMatrix -> RPoint -> RPoint transformPoint m (V2 x y) = V2 (a*x +c*y + e) (b*x + d*y +f) where - (a:c:e:b:d:f:_) = M.toList m + !a = M.unsafeGet 1 1 m + !c = M.unsafeGet 1 2 m + !e = M.unsafeGet 1 3 m + !b = M.unsafeGet 2 1 m + !d = M.unsafeGet 2 2 m + !f = M.unsafeGet 2 3 m + -- (a:c:e:b:d:f:_) = M.toList m mkMatrix :: Maybe [Transformation] -> TMatrix mkMatrix Nothing = identity diff --git a/src/Reanimate/Transition.hs b/src/Reanimate/Transition.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Transition.hs @@ -0,0 +1,69 @@ +module Reanimate.Transition + ( Transition + , signalT + , mapT + , overlapT + , chainT + , effectT + , fadeT + ) where + +import Reanimate.Animation +import Reanimate.Signal +import Reanimate.Effect + +-- | A transition transforms one animation into another. +type Transition = Animation -> Animation -> Animation + +-- | Apply a signal to the timing of a transition. +signalT :: Signal -> Transition -> Transition +signalT = mapT . signalA + +-- | Map the result of a transition. +mapT :: (Animation -> Animation) -> Transition -> Transition +mapT fn t = \a b -> fn (t a b) + +-- | Apply transition only to @N@ seconds of the first +-- animation and to the last @N@ seconds of the second animation. +-- +-- Example: +-- +-- > overlapT 0.5 fadeT drawBox drawCircle +-- +-- <> +overlapT :: Double -> Transition -> Transition +overlapT overlap t a b = + aBefore `seqA` t aOverlap bOverlap `seqA` bAfter + where + aBefore = takeA (duration a - overlap) a + aOverlap = lastA overlap a + bOverlap = takeA overlap b + bAfter = dropA overlap b + + +-- | Create a transition between two animations by applying an effect to each respective animation. +effectT :: Effect -- ^ Effect to be applied to the first animation. + -> Effect -- ^ Effect to be applied to the second animation. + -> Transition +effectT eA eB a b = applyE eA a `parA` applyE eB b + +-- | Combine a list of animations using a given transition. +-- +-- Example: +-- +-- > chainT (overlapT 0.5 fadeT) [drawBox, drawCircle, drawProgress] +-- +-- <> +chainT :: Transition -> [Animation] -> Animation +chainT _ [] = pause 0 +chainT t (x:xs) = foldl t x xs + +-- | Fade out left-hand-side animation while fading in right-hand-side animation. +-- +-- Example: +-- +-- > drawBox `fadeT` drawCircle +-- +-- <> +fadeT :: Transition +fadeT = effectT fadeOutE fadeInE diff --git a/test/UnitTests.hs b/test/UnitTests.hs --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -6,6 +6,7 @@ import Control.Exception import qualified Data.ByteString.Lazy as LBS +import Data.List (sort) import Reanimate.Misc (withTempDir, withTempFile) import System.Directory import System.Exit @@ -18,9 +19,13 @@ unitTestFolder :: FilePath -> IO TestTree unitTestFolder path = do - files <- getDirectoryContents path + files <- sort <$> getDirectoryContents path + mbWDiff <- findExecutable "wdiff" + let diff = case mbWDiff of + Nothing -> ["diff", "--strip-trailing-cr"] + Just wdiff -> [wdiff, "--no-common"] return $ testGroup "animate" - [ goldenVsStringDiff file (\ref new -> ["diff", "--strip-trailing-cr", ref, new]) fullPath (genGolden hsPath) + [ goldenVsStringDiff file (\ref new -> diff ++ [ref, new]) fullPath (genGolden hsPath) | file <- files , let fullPath = path file hsPath = replaceExtension fullPath "hs" @@ -47,7 +52,7 @@ compileTestFolder :: FilePath -> IO TestTree compileTestFolder path = do - files <- getDirectoryContents path + files <- sort <$> getDirectoryContents path return $ testGroup "compile" [ testCase file $ do (ret, _stdout, err) <- readProcessWithExitCode "stack" (["ghc","--", fullPath] ++ ghcOpts) "" @@ -58,13 +63,14 @@ | file <- files , let fullPath = path file , takeExtension file == ".hs" || takeExtension file == ".lhs" + , notElem (replaceExtension file "golden") files ] where ghcOpts = ["-fno-code", "-O0", "-Werror", "-Wall"] compileVideoFolder :: FilePath -> IO TestTree compileVideoFolder path = do - files <- getDirectoryContents path + files <- sort <$> getDirectoryContents path return $ testGroup "videos" [ testCase dir $ do (ret, _stdout, err) <- readProcessWithExitCode "stack" (["ghc","--", "-i"++pathdir, fullPath] ++ ghcOpts) "" diff --git a/viewer-elm/dist/elm.js b/viewer-elm/dist/elm.js new file mode 100644 --- /dev/null +++ b/viewer-elm/dist/elm.js @@ -0,0 +1,1 @@ +!function(n){"use strict";function r(n,r,t){return t.a=n,t.f=r,t}function o(t){return r(2,t,function(r){return function(n){return t(r,n)}})}function b(e){return r(3,e,function(t){return function(r){return function(n){return e(t,r,n)}}})}function v(u){return r(4,u,function(e){return function(t){return function(r){return function(n){return u(e,t,r,n)}}}})}function t(a){return r(5,a,function(u){return function(e){return function(t){return function(r){return function(n){return a(u,e,t,r,n)}}}}})}function e(i){return r(6,i,function(a){return function(u){return function(e){return function(t){return function(r){return function(n){return i(a,u,e,t,r,n)}}}}}})}function u(o){return r(7,o,function(i){return function(a){return function(u){return function(e){return function(t){return function(r){return function(n){return o(i,a,u,e,t,r,n)}}}}}}})}function g(n,r,t){return 2===n.a?n.f(r,t):n(r)(t)}function p(n,r,t,e){return 3===n.a?n.f(r,t,e):n(r)(t)(e)}function w(n,r,t,e,u){return 4===n.a?n.f(r,t,e,u):n(r)(t)(e)(u)}function s(n,r,t,e,u,a){return 5===n.a?n.f(r,t,e,u,a):n(r)(t)(e)(u)(a)}function l(n,r,t,e,u,a,i){return 6===n.a?n.f(r,t,e,u,a,i):n(r)(t)(e)(u)(a)(i)}function f(n,r,t,e,u,a,i,o){return 7===n.a?n.f(r,t,e,u,a,i,o):n(r)(t)(e)(u)(a)(i)(o)}function k(n,r){for(var t,e=[],u=a(n,r,0,e);u&&(t=e.pop());u=a(t.a,t.b,0,e));return u}function a(n,r,t,e){if(n===r)return!0;if("object"!=typeof n||null===n||null===r)return"function"==typeof n&&R(5),!1;if(100i)return u}var l=t.$;if(4===l){for(var d=t.k;4===d.$;)d=d.k;return n(r,d,e,u,a+1,i,r.elm_event_node_ref)}var $=t.e;var h=r.childNodes;for(var m=0;m<$.length;m++){var g=1===l?$[m]:$[m].b,p=++a+(g.b||0);if(a<=c&&c<=p&&(u=n(h[m],g,e,u,a,p,o),!(f=e[u])||(c=f.r)>i))return u;a=p}return u}(n,r,t,0,0,r.b,e)}function mr(n,r,t,e){return 0===t.length?n:(hr(n,r,t,e),gr(n,t))}function gr(n,r){for(var t=0;t>1,A(r,r),1&n?A(t,r):t):t}),Oa=o(function(n,r){return p(Ma,n,r,"")}),Fa=b(function(n,r,t){return A(g(Oa,n-zt(t),function(n){return g(Ra,n,"")}(r)),t)}),Pa=an,xa=o(function(n,r){return g(Kn,n,Pa(r))})("disabled"),za=$a("id"),Sa=$a("title"),Ba=Jn("pre"),Ia=Jn("label"),qa=$a("max"),Ga=Jn("progress"),Ja=Jn("span"),Ua=$a("value"),Wa=o(function(n,r){return g(Ia,j,N([g(Ja,j,N([Ta(" | Loading frames ")])),g(Ga,N([Ua(Vr(n)),qa(Vr(r))]),j)]))}),Ka=v(function(n,r,t,e){for(;;){if(!e.b)return t/r;var u=n+r,a=e.a*n+t;n=.9*n,r=u,t=a,e=e.b}}),Ha=P,Va=o(function(n,r){for(;;){if(-2===r.$)return n;var t=r.d;n=g(Va,n+1,r.e),r=t}}),Ya=u(function(n,r,t,e,u,a,i){var o,f,c,v,s,b=k(o=g(Va,0,e),t)?Ta(""):g(Wa,o,t),l=n.$?Ta(""):g(La,N([(f=n.a,g($a,"src",/^\s*(javascript:|data:text\/html)/i.test(c=f)?"":c))]),j),d=u?Da:g(pa,N([ha("help-button"),ja(ga)]),N([Ta("?")])),$=Vr(t),h=zt($),m=g(Ba,N([ha("bar")]),N([(s=i,g(ma,N([ha("media-controls")]),N([g(pa,N([ja(Cu(-10)),xa(!s),Sa("10 frames back")]),N([Ta("<<")])),g(pa,N([ja(Cu(-1)),xa(!s),Sa("1 frame back")]),N([Ta("<")])),s?g(pa,N([ja(Tu),za("play-or-pause")]),N([Ta("Play")])):g(pa,N([ja(Nu),za("play-or-pause")]),N([Ta("Pause")])),g(pa,N([ja(Cu(1)),xa(!s),Sa("1 frame forward")]),N([Ta(">")])),g(pa,N([ja(Cu(10)),xa(!s),Sa("10 frames forward")]),N([Ta(">>")]))]))),g(Ja,j,N([Ta(" Frame: "+p(Fa,h,"0",Vr(r+1))+" / "+$+(i?" ":(v=a," @ "+Vr(Ha(1e3/w(Ka,1,0,0,v)))+" FPS")))])),b,d]));return g(ma,N([ha("viewer")]),N([l,m]))}),Za=Jn("h1"),Qa=Jn("li"),Xa=Jn("ul"),ni=re({aD:function(){return $(te,ae)},aK:function(n){return se(N([du((t=fe,function(n){return t(g(lu,bu,n))})),(r=oe,Se(g(Rt,r,de))),function(){n:for(;;)switch(n.$){case 3:return 1===n.a.j.$?vu(ce):ru;case 4:if(1!==n.a.$)break n;return g(nu,2e3,ve(ie));default:break n}return ru}()]));var r,t},aM:da,aN:function(i){return g(ma,N([ha("app")]),N([function(){switch(i.$){case 0:return Ta("Disconnected");case 1:return Ta("Connected");case 2:return Ta("Compiling ...");case 4:return function(n){switch(n.$){case 0:var r=n.a;return g(ma,j,N([g(Za,j,N([Ta("Compilation failed")])),g(Ba,j,N([Ta(r)]))]));case 1:return g(ma,j,N([Ta("Failed to establish connection. Possible causes include: "),g(Xa,j,N([g(Qa,j,N([Ta("The reanimate script is not running")])),g(Qa,j,N([Ta("At most one viewer window can connect at time. Maybe there's another browser window/tab already connected?")]))]))]));case 2:return Ta("Failed to decode Port message. The error was: "+lt(n.a));default:return Ta("Unexpected message: "+n.a)}}(i.a);default:var n=i.a.z,r=i.a.u,t=i.a.p,e=i.a.D,u=i.a.G,a=i.a.E;return f(Ya,e,t,n,r,u,a,!i.a.j.$)}}()]))}});fu={Main:{init:ni(Ot(0))(0)}},n.Elm?function n(r,t){for(var e in t)e in r?"init"==e?R(6):n(r[e],t[e]):r[e]=t[e]}(n.Elm,fu):n.Elm=fu}(this); diff --git a/viewer-elm/dist/index.html b/viewer-elm/dist/index.html new file mode 100644 --- /dev/null +++ b/viewer-elm/dist/index.html @@ -0,0 +1,56 @@ + + + + Reanimate - viewer + + + + + +
+ + + + diff --git a/viewer-elm/dist/style.css b/viewer-elm/dist/style.css new file mode 100644 --- /dev/null +++ b/viewer-elm/dist/style.css @@ -0,0 +1,64 @@ +body { + padding: 0; + margin: 0; +} + +.app { + height: 100vh; + background-color: #282c34; + color: white; + font-family: monospace; + overflow: hidden; +} + +.viewer { + position: static; +} + +.viewer img { + max-width: 100vw; + max-height: 100vh; + margin-top: auto; + margin-bottom: auto; +} + +.bar { + position: fixed; + top: 0; + margin-top: 0; + width: 100%; + background: rgba(0,0,0,0.5); +} + +.bar progress { + background-color: #eee; + border: 1px solid white; +} + +.media-controls { + display: inline-block; +} + +.help-button { + position: absolute; + right: 0; + top: 0; +} + +.help-dialog { + position: absolute; + top: 0; + right: 0; + color: white; + background-color: #555; + padding: 30px; +} + +.help-dialog table { + color: white; +} + +#play-or-pause { + text-align: center; + width: 60px; +} diff --git a/viewer/build/index.html b/viewer/build/index.html deleted file mode 100644 --- a/viewer/build/index.html +++ /dev/null @@ -1,1 +0,0 @@ -Reanimate Playground
diff --git a/viewer/build/service-worker.js b/viewer/build/service-worker.js deleted file mode 100644 --- a/viewer/build/service-worker.js +++ /dev/null @@ -1,34 +0,0 @@ -/** - * Welcome to your Workbox-powered service worker! - * - * You'll need to register this file in your web app and you should - * disable HTTP caching for this file too. - * See https://goo.gl/nhQhGp - * - * The rest of the code is auto-generated. Please don't update this file - * directly; instead, make changes to your Workbox build configuration - * and re-run your build process. - * See https://goo.gl/2aRDsh - */ - -importScripts("https://storage.googleapis.com/workbox-cdn/releases/3.6.3/workbox-sw.js"); - -importScripts( - "./precache-manifest.ea495bbf63da838cb91204dca53ee4e1.js" -); - -workbox.clientsClaim(); - -/** - * The workboxSW.precacheAndRoute() method efficiently caches and responds to - * requests for URLs in the manifest. - * See https://goo.gl/S9QRab - */ -self.__precacheManifest = [].concat(self.__precacheManifest || []); -workbox.precaching.suppressWarnings(); -workbox.precaching.precacheAndRoute(self.__precacheManifest, {}); - -workbox.routing.registerNavigationRoute("./index.html", { - - blacklist: [/^\/_/,/\/[^\/]+\.[^\/]+$/], -}); diff --git a/viewer/build/static/css/main.f7ad3e9b.chunk.css b/viewer/build/static/css/main.f7ad3e9b.chunk.css deleted file mode 100644 --- a/viewer/build/static/css/main.f7ad3e9b.chunk.css +++ /dev/null @@ -1,2 +0,0 @@ -body{margin:0;padding:0;font-family:-apple-system,BlinkMacSystemFont,Segoe UI,Roboto,Oxygen,Ubuntu,Cantarell,Fira Sans,Droid Sans,Helvetica Neue,sans-serif;-webkit-font-smoothing:antialiased;-moz-osx-font-smoothing:grayscale}code{font-family:source-code-pro,Menlo,Monaco,Consolas,Courier New,monospace}.App{height:100vh;background-color:#282c34;color:#fff;display:grid;grid-template-columns:1fr;grid-template-rows:auto;grid-auto-flow:column;-webkit-align-items:center;align-items:center;overflow:hidden}.controls{text-align:center}.controls svg{padding-left:5px;padding-right:5px}.viewer{position:static}.viewer svg{max-width:100vw;max-height:100vh;margin-top:auto;margin-bottom:auto}div.messages{position:fixed;top:0;width:100%;background:#282c34}div.messages pre{margin:0}.home{color:#fff;text-align:center;float:right;margin-right:2em} -/*# sourceMappingURL=main.f7ad3e9b.chunk.css.map */ diff --git a/viewer/build/static/js/2.822530b2.chunk.js b/viewer/build/static/js/2.822530b2.chunk.js deleted file mode 100644 --- a/viewer/build/static/js/2.822530b2.chunk.js +++ /dev/null @@ -1,2 +0,0 @@ -(window.webpackJsonp=window.webpackJsonp||[]).push([[2],[function(e,t,n){"use strict";e.exports=n(13)},function(e,t,n){e.exports=n(19)()},function(e,t,n){"use strict";function r(e){if(void 0===e)throw new ReferenceError("this hasn't been initialised - super() hasn't been called");return e}n.d(t,"a",function(){return r})},function(e,t,n){"use strict";function r(e,t,n){return t in e?Object.defineProperty(e,t,{value:n,enumerable:!0,configurable:!0,writable:!0}):e[t]=n,e}function i(e){for(var t=1;tN.length&&N.push(e)}function H(e,t,n){return null==e?0:function e(t,n,r,i){var l=typeof t;"undefined"!==l&&"boolean"!==l||(t=null);var u=!1;if(null===t)u=!0;else switch(l){case"string":case"number":u=!0;break;case"object":switch(t.$$typeof){case o:case a:u=!0}}if(u)return r(i,t,""===n?"."+R(t,0):n),1;if(u=0,n=""===n?".":n+":",Array.isArray(t))for(var s=0;sthis.eventPool.length&&this.eventPool.push(e)}function fe(e){e.eventPool=[],e.getPooled=se,e.release=ce}i(ue.prototype,{preventDefault:function(){this.defaultPrevented=!0;var e=this.nativeEvent;e&&(e.preventDefault?e.preventDefault():"unknown"!==typeof e.returnValue&&(e.returnValue=!1),this.isDefaultPrevented=ae)},stopPropagation:function(){var e=this.nativeEvent;e&&(e.stopPropagation?e.stopPropagation():"unknown"!==typeof e.cancelBubble&&(e.cancelBubble=!0),this.isPropagationStopped=ae)},persist:function(){this.isPersistent=ae},isPersistent:le,destructor:function(){var e,t=this.constructor.Interface;for(e in t)this[e]=null;this.nativeEvent=this._targetInst=this.dispatchConfig=null,this.isPropagationStopped=this.isDefaultPrevented=le,this._dispatchInstances=this._dispatchListeners=null}}),ue.Interface={type:null,target:null,currentTarget:function(){return null},eventPhase:null,bubbles:null,cancelable:null,timeStamp:function(e){return e.timeStamp||Date.now()},defaultPrevented:null,isTrusted:null},ue.extend=function(e){function t(){}function n(){return r.apply(this,arguments)}var r=this;t.prototype=r.prototype;var o=new t;return i(o,n.prototype),n.prototype=o,n.prototype.constructor=n,n.Interface=i({},r.Interface,e),n.extend=r.extend,fe(n),n},fe(ue);var de=ue.extend({data:null}),pe=ue.extend({data:null}),he=[9,13,27,32],ye=W&&"CompositionEvent"in window,ve=null;W&&"documentMode"in document&&(ve=document.documentMode);var ge=W&&"TextEvent"in window&&!ve,me=W&&(!ye||ve&&8=ve),be=String.fromCharCode(32),ke={beforeInput:{phasedRegistrationNames:{bubbled:"onBeforeInput",captured:"onBeforeInputCapture"},dependencies:["compositionend","keypress","textInput","paste"]},compositionEnd:{phasedRegistrationNames:{bubbled:"onCompositionEnd",captured:"onCompositionEndCapture"},dependencies:"blur compositionend keydown keypress keyup mousedown".split(" ")},compositionStart:{phasedRegistrationNames:{bubbled:"onCompositionStart",captured:"onCompositionStartCapture"},dependencies:"blur compositionstart keydown keypress keyup mousedown".split(" ")},compositionUpdate:{phasedRegistrationNames:{bubbled:"onCompositionUpdate",captured:"onCompositionUpdateCapture"},dependencies:"blur compositionupdate keydown keypress keyup mousedown".split(" ")}},_e=!1;function we(e,t){switch(e){case"keyup":return-1!==he.indexOf(t.keyCode);case"keydown":return 229!==t.keyCode;case"keypress":case"mousedown":case"blur":return!0;default:return!1}}function Ee(e){return"object"===typeof(e=e.detail)&&"data"in e?e.data:null}var Ce=!1;var Se={eventTypes:ke,extractEvents:function(e,t,n,r){var i=void 0,o=void 0;if(ye)e:{switch(e){case"compositionstart":i=ke.compositionStart;break e;case"compositionend":i=ke.compositionEnd;break e;case"compositionupdate":i=ke.compositionUpdate;break e}i=void 0}else Ce?we(e,n)&&(i=ke.compositionEnd):"keydown"===e&&229===n.keyCode&&(i=ke.compositionStart);return i?(me&&"ko"!==n.locale&&(Ce||i!==ke.compositionStart?i===ke.compositionEnd&&Ce&&(o=oe()):(re="value"in(ne=r)?ne.value:ne.textContent,Ce=!0)),i=de.getPooled(i,t,n,r),o?i.data=o:null!==(o=Ee(n))&&(i.data=o),q(i),o=i):o=null,(e=ge?function(e,t){switch(e){case"compositionend":return Ee(t);case"keypress":return 32!==t.which?null:(_e=!0,be);case"textInput":return(e=t.data)===be&&_e?null:e;default:return null}}(e,n):function(e,t){if(Ce)return"compositionend"===e||!ye&&we(e,t)?(e=oe(),ie=re=ne=null,Ce=!1,e):null;switch(e){case"paste":return null;case"keypress":if(!(t.ctrlKey||t.altKey||t.metaKey)||t.ctrlKey&&t.altKey){if(t.char&&1