diff --git a/.azure/azure-linux-template.yml b/.azure/azure-linux-template.yml index d74dd42..4238ba6 100644 --- a/.azure/azure-linux-template.yml +++ b/.azure/azure-linux-template.yml @@ -30,6 +30,11 @@ jobs: if [ -f "executable.txt" ]; then chmod +x $(cat executable.txt); fi condition: and(succeeded(), ne(variables['CACHE_RESTORED'], 'false')) - script: | + sudo add-apt-repository ppa:jonathonf/ffmpeg-4 + sudo apt-get update + sudo apt-get install ffmpeg + #sudo apt-get install texlive texlive-latex-base texlive-latex-extra texlive-fonts-extra texlive-science texlive-xetex texlive-latex-recommended texlive-lang-english texlive-lang-chinese + sudo apt-get install povray mkdir -p ~/.local/bin curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' case "$BUILD" in @@ -98,6 +103,7 @@ jobs: done ;; *) + stack ./examples/counter.hs check stack $ARGS test --pedantic ;; esac diff --git a/.azure/azure-osx-template.yml b/.azure/azure-osx-template.yml index 5b40083..af4a58e 100644 --- a/.azure/azure-osx-template.yml +++ b/.azure/azure-osx-template.yml @@ -29,11 +29,32 @@ jobs: if [ -f "executable.txt" ]; then chmod +x $(cat executable.txt); fi condition: and(succeeded(), ne(variables['CACHE_RESTORED'], 'false')) - script: | + #brew cask install basictex + #export PATH="/Library/TeX/texbin/:$PATH" + #sudo tlmgr update --self + #sudo tlmgr install standalone + #sudo tlmgr install preview + #sudo tlmgr install dvisvgm + #sudo tlmgr install scheme-full + #sudo tlmgr install amsmath + #sudo tlmgr install physics + #sudo tlmgr install doublestroke + #sudo tlmgr install calligra + #sudo tlmgr install fundus-calligra + #sudo tlmgr install relsize + #sudo tlmgr install wasysym + #sudo tlmgr install cjk + #sudo tlmgr install ctex + #sudo tlmgr install zhnumber + #xelatex -interaction=nonstopmode test.tex + brew install ffmpeg + brew install povray export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root; mkdir -p ~/.local/bin curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin; export PATH=$HOME/.local/bin:$PATH stack --install-ghc $ARGS test --only-dependencies + stack ./examples/counter.hs check stack $ARGS test --pedantic env: OS_NAME: ${{ parameters.os }} diff --git a/.azure/azure-windows-template.yml b/.azure/azure-windows-template.yml index a5fa825..fc892b7 100644 --- a/.azure/azure-windows-template.yml +++ b/.azure/azure-windows-template.yml @@ -30,9 +30,22 @@ jobs: condition: and(succeeded(), ne(variables['CACHE_RESTORED'], 'false')) - bash: | export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root; + curl -sSkL https://ffmpeg.zeranoe.com/builds/win64/static/ffmpeg-4.2.1-win64-static.zip -o ffmpeg.zip + unzip ffmpeg.zip + cp ffmpeg-4.2.1-win64-static/bin/* /usr/bin/ + + #curl -sSkL http://mirror.ctan.org/systems/texlive/tlnet/install-tl-windows.exe -o install-tl-windows.exe + #./install-tl-windows.exe -gui text + + #curl -sSkL https://miktex.org/download/win/miktexsetup-x64.zip -o miktexsetup-x64.zip + #unzip miktexsetup-x64.zip + #./miktexsetup.exe --verbose --local-package-repository=miktex-repository --package-set=complete download + #./miktexsetup.exe --verbose --local-package-repository=miktex-repository --shared --user-config="MiKTeX\2.9" --user-data="MiKTeX\2.9" --user-install="MiKTeX\2.9" --print-info-only install + curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip unzip -o /usr/bin/stack.zip -d /usr/bin/ stack --install-ghc $ARGS test --only-dependencies + stack ./examples/counter.hs check stack $ARGS test --pedantic env: OS_NAME: ${{ parameters.os }} diff --git a/README.md b/README.md index cc2a100..3dc9eb6 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,9 @@ -[![Hackage](https://img.shields.io/hackage/v/reanimate.svg)](http://hackage.haskell.org/package/reanimate) +[![Hackage](https://img.shields.io/hackage/v/reanimate.svg?color=success)](http://hackage.haskell.org/package/reanimate) [![Build Status](https://dev.azure.com/lemmih0612/reanimate/_apis/build/status/Lemmih.reanimate?branchName=master)](https://dev.azure.com/lemmih0612/reanimate/_build/latest?definitionId=1&branchName=master) [![Documentation Status](https://readthedocs.org/projects/reanimate/badge/?version=latest)](https://reanimate.readthedocs.io/en/latest/?badge=latest) +![Platforms](https://img.shields.io/badge/platform-linux%20%7C%20osx%20%7C%20windows-informational) + # reanimate Reanimate is a reactive framework for creating non-interactive animations from SVG images. diff --git a/docs/gen_doc_gifs.sh b/docs/gen_doc_gifs.sh new file mode 100755 index 0000000..e6920bf --- /dev/null +++ b/docs/gen_doc_gifs.sh @@ -0,0 +1,17 @@ +#!/usr/bin/env bash +ROOT=`stack path --project-root` + +TINY='^(doc_turbo|doc_viridis|doc_magma|doc_inferno|doc_plasma|doc_sinebow|doc_cividis|doc_jet|doc_hsv|doc_hsvMatlab|doc_greyscale|doc_parula)$' + +for src in $ROOT/examples/doc_*.hs; do + BASE=`basename $src .hs` + DST=$ROOT/docs/gifs/$BASE.gif + if [[ "$src" -nt "$DST" ]]; then + echo stack $src render -o $DST + if [[ "$BASE" =~ $TINY ]]; then + stack $src render -o $DST --width=320 --height=50 + else + stack $src render -o $DST + fi + fi +done diff --git a/docs/render_all.sh b/docs/gen_gallery.sh similarity index 84% rename from docs/render_all.sh rename to docs/gen_gallery.sh index 7dc88ef..4b8a93c 100755 --- a/docs/render_all.sh +++ b/docs/gen_gallery.sh @@ -1,5 +1,6 @@ #!/usr/bin/env bash +ROOT=`stack path --project-root` EXAMPLES='boundingbox colormaps goo latex_basic latex_color latex_draw latex_wheel raster sphere sunflower tangent_and_normal vector_field' @@ -7,18 +8,18 @@ WIDTH=640 HEIGHT=$((WIDTH*9/16)) FPS=30 -SRC_DIR=examples -DST_DIR=docs/rendered +SRC_DIR=$ROOT/examples +DST_DIR=$ROOT/docs/rendered OPTS='--fps $FPS --width $WIDTH --height $HEIGHT' -cat << EOF > docs/gallery.md +cat << EOF > $ROOT/docs/gallery.md # Gallery This file is auto-generated by docs/render_all.sh. DO NOT EDIT. EOF for e in $EXAMPLES; do - cat << EOF >> docs/gallery.md + cat << EOF >> $ROOT/docs/gallery.md ## $e
diff --git a/examples/boundingbox.hs b/examples/boundingbox.hs index 4224e23..c0159e1 100755 --- a/examples/boundingbox.hs +++ b/examples/boundingbox.hs @@ -3,50 +3,42 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens - -import Graphics.SvgTree (Number(..),Tree) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal -import Reanimate.Constants +import Graphics.SvgTree (Tree) +import Reanimate main :: IO () main = reanimate bbox bbox :: Animation -bbox = bg `sim` - mapA (translate (-screenWidth/4) 0) bbox1 `sim` +bbox = bg `parA` + mapA (translate (-screenWidth/4) 0) bbox1 `parA` mapA (translate (screenWidth/4) 0) bbox2 where - bg = mkAnimation 0 $ emit $ mkBackground "black" + bg = animate $ const $ mkBackground "black" bbox1 :: Animation -bbox1 = mkAnimation 5 $ do - s <- getSignal signalLinear - emit $ mkGroup - [ mkBoundingBox $ rotate (360*s) svg - , withFillColor "white" $ rotate (360*s) svg ] +bbox1 = mkAnimation 5 $ \t -> + mkGroup + [ mkBoundingBox $ rotate (360*t) svg + , withFillColor "white" $ rotate (360*t) svg ] where svg = scale 2 $ center $ latexAlign "\\sum_{k=1}^\\infty" bbox2 :: Animation -bbox2 = autoReverse $ mkAnimation 2.5 $ do - s <- getSignal signalLinear - emit $ mkGroup - [ mkBoundingBox $ partialSvg s heartShape +bbox2 = playThenReverseA $ mkAnimation 2.5 $ \t -> + mkGroup + [ mkBoundingBox $ partialSvg t heartShape , withStrokeColor "white" $ withFillOpacity 0 $ - partialSvg s heartShape ] + partialSvg t heartShape ] mkBoundingBox :: Tree -> Tree mkBoundingBox svg = withStrokeColor "red" $ withFillOpacity 0 $ translate (x+w/2) (y+h/2) $ - mkRect (Num w) (Num h) + mkRect w h where (x, y, w, h) = boundingBox svg +heartShape :: Tree heartShape = lowerTransformations $ scaleXY 1 (-1) $ scale 0.1 $ center $ rotateAroundCenter 225 $ mkPathString "M0.0,40.0 v-40.0 h40.0\ diff --git a/examples/colormaps.hs b/examples/colormaps.hs index c3b3492..96b47d2 100755 --- a/examples/colormaps.hs +++ b/examples/colormaps.hs @@ -3,24 +3,14 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens () - import Codec.Picture import qualified Data.Colour.CIE as CIE -import Data.Colour.CIE.Illuminant +import Data.Colour.CIE.Illuminant (d65) import Data.Colour.RGBSpace -import qualified Data.Colour.RGBSpace.HSL as HSL import Data.Colour.SRGB import Data.Word -import Graphics.SvgTree (Number (..), Tree) -import Reanimate.ColorMap -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Raster -import Reanimate.Signal -import Reanimate.Svg -import Reanimate.Constants +import Graphics.SvgTree (Tree) +import Reanimate -- Cycle the animation if we want to upload it to youtube. youtube :: Animation -> Animation @@ -28,22 +18,22 @@ youtube :: Animation -> Animation youtube = id main :: IO () -main = reanimate $ youtube $ pauseAtEnd 2 $ autoReverse $ pauseAtEnd 2 $ mkAnimation 5 $ do - s <- getSignal $ signalCurve 2 - let scaleWidth = screenWidth * 0.5 - nubWidth = 0.2 +main = reanimate $ youtube $ pauseAtEnd 2 $ playThenReverseA $ pauseAtEnd 2 $ mkAnimation 5 $ \t -> + let s = curveS 2 t + offsetWidth = screenWidth * 0.5 + nubWidth = 0.2 textYOffset = 0.2 - emit $ mkGroup + in mkGroup [ mkBackground "black" , translate 0 (screenHeight/2*0.85) $ withFillColor "white" $ mkGroup - [ translate (scaleWidth*s - scaleWidth/2) 0 $ - withFillColor "white" $ mkCircle (Num nubWidth) - , withStrokeColor "white" $ withStrokeWidth (Num 0.05) $ - mkLine (Num $ -(scaleWidth-nubWidth)/2,Num 0) - (Num $ (scaleWidth-nubWidth)/2, Num 0) - , translate (-scaleWidth/2-1.0) textYOffset $ + [ translate (offsetWidth*s - offsetWidth/2) 0 $ + withFillColor "white" $ mkCircle nubWidth + , withStrokeColor "white" $ withStrokeWidth 0.05 $ + mkLine (-(offsetWidth-nubWidth)/2, 0) + ((offsetWidth-nubWidth)/2, 0) + , translate (-offsetWidth/2-1.0) textYOffset $ scale 0.5 $ centerX $ latex "Color" - , translate (scaleWidth/2+1.5) textYOffset $ + , translate (offsetWidth/2+1.5) textYOffset $ scale 0.5 $ centerX $ latex "Greyscale" ] , translate (-columnX) (rowInit-rowStep*0) $ mkOutline "viridis" (dimmer s . viridis) @@ -65,7 +55,7 @@ main = reanimate $ youtube $ pauseAtEnd 2 $ autoReverse $ pauseAtEnd 2 $ mkAnima mkOutline label f = mkGroup - [ center $ withFillColor "grey" $ mkRect (Num $ scaleWidth+0.05) (Num $ scaleHeight+0.05) + [ center $ withFillColor "grey" $ mkRect (scaleWidth+0.05) (scaleHeight+0.05) , scaleToSize scaleWidth scaleHeight $ mkColorMap f , translate (-scaleWidth/2) (0.5) $ centerY $ withFillColor "white" $ scale 0.5 $ latex label diff --git a/examples/counter.hs b/examples/counter.hs index e57252f..f5a0a1b 100755 --- a/examples/counter.hs +++ b/examples/counter.hs @@ -1,21 +1,11 @@ #!/usr/bin/env stack -- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main (main) where -import Control.Lens -import Data.Text (pack, Text) -import Numeric - -import Graphics.SvgTree hiding (Text) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal +import Reanimate main :: IO () -main = reanimate $ mkAnimation 2 $ do - s <- getSignal $ signalFromTo 0 (2*60-1) signalLinear - emit $ mkCircle (Num s) +main = reanimate $ mkAnimation dur $ + mkCircle . fromToS 0 (dur*60-1) + where + dur = 2 diff --git a/examples/doc_andThen.hs b/examples/doc_andThen.hs new file mode 100644 index 0000000..101a4c4 --- /dev/null +++ b/examples/doc_andThen.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 $ drawBox `andThen` drawCircle diff --git a/examples/doc_bellS.hs b/examples/doc_bellS.hs new file mode 100644 index 0000000..991ee0f --- /dev/null +++ b/examples/doc_bellS.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 $ signalA (bellS 2) drawProgress diff --git a/examples/doc_cividis.hs b/examples/doc_cividis.hs new file mode 100644 index 0000000..53db6b6 --- /dev/null +++ b/examples/doc_cividis.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_constantS.hs b/examples/doc_constantS.hs new file mode 100644 index 0000000..f3a8711 --- /dev/null +++ b/examples/doc_constantS.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 $ signalA (constantS 0.5) drawProgress diff --git a/examples/doc_curveS.hs b/examples/doc_curveS.hs new file mode 100644 index 0000000..7c5ec53 --- /dev/null +++ b/examples/doc_curveS.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 $ signalA (curveS 2) drawProgress diff --git a/examples/doc_drawBox.hs b/examples/doc_drawBox.hs new file mode 100644 index 0000000..998bed4 --- /dev/null +++ b/examples/doc_drawBox.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 drawBox diff --git a/examples/doc_drawCircle.hs b/examples/doc_drawCircle.hs new file mode 100644 index 0000000..9d00231 --- /dev/null +++ b/examples/doc_drawCircle.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 drawCircle diff --git a/examples/doc_drawProgress.hs b/examples/doc_drawProgress.hs new file mode 100644 index 0000000..011e47c --- /dev/null +++ b/examples/doc_drawProgress.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 drawProgress diff --git a/examples/doc_fromToS.hs b/examples/doc_fromToS.hs new file mode 100644 index 0000000..0b0dfeb --- /dev/null +++ b/examples/doc_fromToS.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 $ signalA (fromToS 0.8 0.2) drawProgress diff --git a/examples/doc_greyscale.hs b/examples/doc_greyscale.hs new file mode 100644 index 0000000..acf34c4 --- /dev/null +++ b/examples/doc_greyscale.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_hsv.hs b/examples/doc_hsv.hs new file mode 100644 index 0000000..b3dda43 --- /dev/null +++ b/examples/doc_hsv.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_hsvMatlab.hs b/examples/doc_hsvMatlab.hs new file mode 100644 index 0000000..b642c0b --- /dev/null +++ b/examples/doc_hsvMatlab.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_inferno.hs b/examples/doc_inferno.hs new file mode 100644 index 0000000..9c2bb16 --- /dev/null +++ b/examples/doc_inferno.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_jet.hs b/examples/doc_jet.hs new file mode 100644 index 0000000..3ce28cc --- /dev/null +++ b/examples/doc_jet.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_latex.hs b/examples/doc_latex.hs new file mode 100755 index 0000000..3a1c3b3 --- /dev/null +++ b/examples/doc_latex.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ + withStrokeWidth 0 . withFillOpacity 1 . scale 3 . center $ + latex "$e^{i\\pi}+1=0$" diff --git a/examples/doc_latexAlign.hs b/examples/doc_latexAlign.hs new file mode 100755 index 0000000..867f3be --- /dev/null +++ b/examples/doc_latexAlign.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ + withStrokeWidth 0 . withFillOpacity 1 . scale 3 . center $ + latexAlign "R = \\frac{{\\Delta x}}{{kA}}" diff --git a/examples/doc_magma.hs b/examples/doc_magma.hs new file mode 100644 index 0000000..b6e9747 --- /dev/null +++ b/examples/doc_magma.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_mapA.hs b/examples/doc_mapA.hs new file mode 100644 index 0000000..d1c2010 --- /dev/null +++ b/examples/doc_mapA.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 $ mapA (scale 0.5) drawCircle diff --git a/examples/doc_oscillateS.hs b/examples/doc_oscillateS.hs new file mode 100644 index 0000000..32f713e --- /dev/null +++ b/examples/doc_oscillateS.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 $ signalA oscillateS drawProgress diff --git a/examples/doc_parA.hs b/examples/doc_parA.hs new file mode 100644 index 0000000..0f5fa8e --- /dev/null +++ b/examples/doc_parA.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 $ drawBox `parA` adjustDuration (*2) drawCircle diff --git a/examples/doc_parDropA.hs b/examples/doc_parDropA.hs new file mode 100644 index 0000000..9be14c6 --- /dev/null +++ b/examples/doc_parDropA.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 $ drawBox `parDropA` adjustDuration (*2) drawCircle diff --git a/examples/doc_parLoopA.hs b/examples/doc_parLoopA.hs new file mode 100644 index 0000000..a31f3c4 --- /dev/null +++ b/examples/doc_parLoopA.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 $ drawBox `parLoopA` adjustDuration (*2) drawCircle diff --git a/examples/doc_parula.hs b/examples/doc_parula.hs new file mode 100644 index 0000000..471aebc --- /dev/null +++ b/examples/doc_parula.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_pause.hs b/examples/doc_pause.hs new file mode 100644 index 0000000..f9ac261 --- /dev/null +++ b/examples/doc_pause.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 $ pause 1 `seqA` drawProgress diff --git a/examples/doc_pauseAround.hs b/examples/doc_pauseAround.hs new file mode 100644 index 0000000..b8abafd --- /dev/null +++ b/examples/doc_pauseAround.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 $ pauseAround 1 1 drawProgress diff --git a/examples/doc_pauseAtBeginning.hs b/examples/doc_pauseAtBeginning.hs new file mode 100644 index 0000000..a446b82 --- /dev/null +++ b/examples/doc_pauseAtBeginning.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 $ pauseAtBeginning 1 drawProgress diff --git a/examples/doc_pauseAtEnd.hs b/examples/doc_pauseAtEnd.hs new file mode 100644 index 0000000..c45549a --- /dev/null +++ b/examples/doc_pauseAtEnd.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 $ pauseAtEnd 1 drawProgress diff --git a/examples/doc_plasma.hs b/examples/doc_plasma.hs new file mode 100644 index 0000000..94e691c --- /dev/null +++ b/examples/doc_plasma.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_playThenReverseA.hs b/examples/doc_playThenReverseA.hs new file mode 100644 index 0000000..65ebf9b --- /dev/null +++ b/examples/doc_playThenReverseA.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 $ playThenReverseA drawCircle diff --git a/examples/doc_repeatA.hs b/examples/doc_repeatA.hs new file mode 100644 index 0000000..18bcdb5 --- /dev/null +++ b/examples/doc_repeatA.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 $ repeatA 1.5 drawCircle diff --git a/examples/doc_reverseA.hs b/examples/doc_reverseA.hs new file mode 100644 index 0000000..29eb1ad --- /dev/null +++ b/examples/doc_reverseA.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 $ reverseA drawCircle diff --git a/examples/doc_reverseS.hs b/examples/doc_reverseS.hs new file mode 100644 index 0000000..3428d6f --- /dev/null +++ b/examples/doc_reverseS.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 $ signalA reverseS drawProgress diff --git a/examples/doc_seqA.hs b/examples/doc_seqA.hs new file mode 100644 index 0000000..1fd2e36 --- /dev/null +++ b/examples/doc_seqA.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 (drawBox `seqA` drawCircle) diff --git a/examples/doc_signalA.hs b/examples/doc_signalA.hs new file mode 100644 index 0000000..4d422d7 --- /dev/null +++ b/examples/doc_signalA.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 $ signalA (fromToS 0.25 0.75) drawCircle diff --git a/examples/doc_sinebow.hs b/examples/doc_sinebow.hs new file mode 100644 index 0000000..9f84558 --- /dev/null +++ b/examples/doc_sinebow.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_turbo.hs b/examples/doc_turbo.hs new file mode 100644 index 0000000..81783c8 --- /dev/null +++ b/examples/doc_turbo.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_viridis.hs b/examples/doc_viridis.hs new file mode 100644 index 0000000..5154920 --- /dev/null +++ b/examples/doc_viridis.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- 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)) diff --git a/examples/doc_xelatex.hs b/examples/doc_xelatex.hs new file mode 100755 index 0000000..7e32661 --- /dev/null +++ b/examples/doc_xelatex.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ + withStrokeWidth 0 . withFillOpacity 1 . scale 4 . center $ + xelatex "中文" diff --git a/examples/fourier.hs b/examples/fourier.hs index 3b20d9b..6a4eb01 100755 --- a/examples/fourier.hs +++ b/examples/fourier.hs @@ -3,14 +3,13 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens import Data.Complex import qualified Data.Text as T import Graphics.SvgTree import Reanimate.Driver (reanimate) import Reanimate.LaTeX (latex) -import Reanimate.Monad +import Reanimate.Animation import Reanimate.Svg import Reanimate.Signal import Reanimate.Constants @@ -21,55 +20,58 @@ waveMultiplier = 2 -- Square wave main :: IO () main = reanimate $ - fourierAnimation 1 `before` - fourierAnimation 2 `before` - fourierAnimation 3 `before` - fourierAnimation 5 `before` - fourierAnimation 10 `before` - fourierAnimation 25 `before` - fourierAnimation 50 `before` + fourierAnimation 1 `seqA` + fourierAnimation 2 `seqA` + fourierAnimation 3 `seqA` + fourierAnimation 5 `seqA` + fourierAnimation 10 `seqA` + fourierAnimation 25 `seqA` + fourierAnimation 50 `seqA` fourierAnimation 100 +sWidth :: Double sWidth = 0.02 fourierAnimation :: Int -> Animation -fourierAnimation nCircles = repeatAnimation 2 $ mkAnimation 3 $ do - emit $ mkBackground "black" - phi <- getSignal $ signalFromTo 0 (2*pi) signalLinear - mapF (translate (-screenWidth/4) 0) $ do - drawNCircles nCircles phi - emit $ withStrokeColor "white" $ - withStrokeWidth (Num sWidth) $ +fourierAnimation nCircles = repeatA 2 $ mkAnimation 3 $ \t -> + let phi = fromToS 0 (2*pi) t + in mkGroup + [ mkBackground "black" + , translate (-screenWidth/4) 0 $ mkGroup + [ drawNCircles nCircles phi + , withStrokeColor "white" $ + withStrokeWidth sWidth $ withFillOpacity 0 $ translate (screenWidth/4) 0 $ - mkCirclePath nCircles phi - emit $ withStrokeWidth (Num sWidth) $ + mkCirclePath nCircles phi ] + , withStrokeWidth sWidth $ withFillColor "white" $ translate (-screenWidth/8*3) (screenHeight/8*3) $ - latex $ T.pack $ "Circles: " ++ show nCircles + latex $ T.pack $ "Circles: " ++ show nCircles ] -drawNCircles totalCircles phi = do - worker circles - let x :+ y = sum circles - emit $ withStrokeWidth (Num sWidth) $ +drawNCircles :: Int -> Double -> Tree +drawNCircles totalCircles phi = mkGroup + [ worker circles + , let x :+ y = sum circles in + withStrokeWidth sWidth $ withStrokeColor "white" $ - mkLine (Num x, Num y) (Num (screenWidth/4), Num y) + mkLine (x, y) (screenWidth/4, y) ] where circles = [ nthCircle n phi | n <- [0..totalCircles-1] ] - worker [] = return () - worker (x :+ y : rest) = do - let radius = sqrt(x*x+y*y) - emit $ withStrokeWidth (Num sWidth) $ + worker [] = None + worker (x :+ y : rest) = + let radius = sqrt(x*x+y*y) in + mkGroup + [ withStrokeWidth sWidth $ withStrokeColor "grey" $ withFillOpacity 0 $ - CircleTree $ defaultSvg - & circleCenter .~ (Num 0, Num 0) - & circleRadius .~ Num radius - mapF (translate x y) $ worker rest - emit $ withStrokeWidth (Num sWidth) $ + mkCircle radius + , translate x y $ worker rest + , withStrokeWidth sWidth $ withStrokeColor "white" $ - mkLine (Num 0, Num 0) (Num x, Num y) + mkLine (0, 0) (x, y) ] +mkCirclePath :: Int -> Double -> Tree mkCirclePath nCircles phiOffset = mkLinePath $ take 2000 $ zip [ 2 * i/granularity | i <- [0..]] $ drop (round $ (1-phiOffset/(2*pi)) * granularity) $ @@ -80,6 +82,7 @@ mkCirclePath nCircles phiOffset = mkLinePath $ take 2000 $ where granularity = 500 +fourierYValue :: Int -> Double -> Double fourierYValue n phi = imagPart (sum [ nthCircle i phi | i <- [0..n-1]]) diff --git a/examples/fourier_draw.hs b/examples/fourier_draw.hs index 5c83c4f..bfa52bd 100755 --- a/examples/fourier_draw.hs +++ b/examples/fourier_draw.hs @@ -3,19 +3,11 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens import Data.Complex -import Data.Fixed -import qualified Data.Text as T - +import qualified Data.Text as T import Graphics.SvgTree import Linear.V2 -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal -import Reanimate.Constants +import Reanimate main :: IO () main = reanimate $ pauseAtEnd 2 $ @@ -33,22 +25,21 @@ piPoints = lineToPoints 500 $ fourierAnimation_ :: Animation -fourierAnimation_ = mkAnimation 50 $ do - emit $ mkBackground "black" - phi <- getSignal $ signalFromTo 0 15 signalLinear - fLength <- getSignal signalLinear - - let circles = setFourierLength (fLength*maxLength) piFourier +fourierAnimation_ = mkAnimation 50 $ \t -> + let fLength = t + circles = setFourierLength (fLength*maxLength) piFourier maxLength = sum $ map magnitude $ take 499 $ drop 1 $ fourierCoefficients piFourier - - emit $ withStrokeColor "green" $ + phi = fromToS 0 15 t + in mkGroup + [ mkBackground "black" + , drawCircles $ fourierCoefficients $ rotateFourier phi circles + , withStrokeColor "green" $ + withFillOpacity 0 $ mkLinePath $ mkFourierOutline circles - drawCircles $ fourierCoefficients $ rotateFourier phi circles - - emit $ - withFillColor "white" $ + , withFillColor "white" $ translate (-screenWidth/16*7) (screenHeight/16*7) $ latex $ T.pack $ "Circles: " ++ show (length $ fourierCoefficients circles) + ] data Fourier = Fourier {fourierCoefficients :: [Complex Double]} @@ -69,17 +60,18 @@ mkFourier points = Fourier $ findCoefficient 0 : nPoints = fromIntegral (length points) -setFourierCircles :: Double -> Fourier -> Fourier -setFourierCircles n _ | n < 1 = error "Invalid argument. Need at least one circle." -setFourierCircles n (Fourier coeffs) = - Fourier $ take iCircles coeffs ++ [coeffs!!iCircles * realToFrac fCircle] - where - (iCircles, fCircle) = divMod' n 1 +-- setFourierCircles :: Double -> Fourier -> Fourier +-- setFourierCircles n _ | n < 1 = error "Invalid argument. Need at least one circle." +-- setFourierCircles n (Fourier coeffs) = +-- Fourier $ take iCircles coeffs ++ [coeffs!!iCircles * realToFrac fCircle] +-- where +-- (iCircles, fCircle) = divMod' n 1 setFourierLength :: Double -> Fourier -> Fourier -setFourierLength len (Fourier (first:lst)) = Fourier $ first : worker len lst +setFourierLength _ (Fourier []) = Fourier [] +setFourierLength len0 (Fourier (first:lst)) = Fourier $ first : worker len0 lst where - worker len [] = [] + worker _len [] = [] worker len (c:cs) = if magnitude c < len then c : worker (len - magnitude c) cs @@ -87,7 +79,7 @@ setFourierLength len (Fourier (first:lst)) = Fourier $ first : worker len lst rotateFourier :: Double -> Fourier -> Fourier rotateFourier phi (Fourier coeffs) = - Fourier $ worker (coeffs) 0 + Fourier $ worker (coeffs) (0::Integer) where worker [] _ = [] worker (x:rest) 0 = x : worker rest 1 @@ -98,29 +90,27 @@ rotateFourier phi (Fourier coeffs) = right * exp (n' * 2 * pi * i * phi') : worker rest (n+1) i = 0 :+ 1 - n = length coeffs `div` 2 + -- n = length coeffs `div` 2 phi' = realToFrac phi -drawCircles :: [Complex Double] -> Frame () -drawCircles circles = do - worker circles - emit $ withStrokeWidth (Num sWidth) $ +drawCircles :: [Complex Double] -> SVG +drawCircles circles = mkGroup + [ worker circles + , withStrokeWidth sWidth $ withStrokeColor "white" $ withStrokeLineJoin JoinRound $ withFillOpacity 0 $ - mkLinePath [ (x, y) | x :+ y <- scanl (+) 0 circles ] + mkLinePath [ (x, y) | x :+ y <- scanl (+) 0 circles ] ] where - worker [] = return () - worker (x :+ y : rest) = do - let radius = sqrt(x*x+y*y) - emit $ - withStrokeWidth (Num sWidth) $ + worker [] = None + worker (x :+ y : rest) = + let radius = sqrt(x*x+y*y) in + mkGroup + [ withStrokeWidth sWidth $ withStrokeColor "dimgrey" $ withFillOpacity 0 $ - CircleTree $ defaultSvg - & circleCenter .~ (Num 0, Num 0) - & circleRadius .~ Num radius - mapF (translate x y) $ worker rest + mkCircle radius + , translate x y $ worker rest ] mkFourierOutline :: Fourier -> [(Double, Double)] mkFourierOutline fourier = diff --git a/examples/goo.hs b/examples/goo.hs index 7f66774..34a5933 100755 --- a/examples/goo.hs +++ b/examples/goo.hs @@ -6,61 +6,58 @@ module Main (main) where import Control.Lens import Graphics.SvgTree -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal -import Reanimate.Combinators +import Reanimate main :: IO () -main = reanimate $ autoReverse $ mkAnimation 5 $ do - s <- getSignal $ signalFromTo 0 1.5 $ signalCurve 2 - emit $ mkBackground "black" - emit $ FilterTree $ mkFilter "blur" - [FEGaussianBlur $ defaultSvg - & gaussianBlurStdDeviationX .~ Num dev - & filterResult .~ Just "blur" - ] & filterWidth .~ pure (Percent 3) - & filterX .~ pure (Percent (-1)) - & filterHeight .~ pure (Percent 3) - & filterY .~ pure (Percent (-1)) - emit $ FilterTree $ mkFilter "goo" - [FEGaussianBlur $ defaultSvg - & gaussianBlurStdDeviationX .~ Num dev - & filterResult .~ Just "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)) - emit $ translate 0 (radius*2.2) $ withFillColor "red" $ mkGroup - [ translate (s*(-radius)) 0 circ - , translate (s*radius) 0 circ +main = reanimate $ playThenReverseA $ mkAnimation 5 $ \t -> + let s = fromToS 0 1.5 $ curveS 2 t in + mkGroup + [ mkBackground "black" + , FilterTree $ mkFilter "blur" + [FEGaussianBlur $ defaultSvg + & gaussianBlurStdDeviationX .~ Num dev + & filterResult .~ Just "blur" + ] & filterWidth .~ pure (Percent 3) + & filterX .~ pure (Percent (-1)) + & filterHeight .~ pure (Percent 3) + & filterY .~ pure (Percent (-1)) + , FilterTree $ mkFilter "goo" + [FEGaussianBlur $ defaultSvg + & gaussianBlurStdDeviationX .~ Num dev + & filterResult .~ Just "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)) + , translate 0 (radius*2.2) $ withFillColor "red" $ mkGroup + [ translate (s*(-radius)) 0 circ + , translate (s*radius) 0 circ + ] + , withFillColor "red" $ mkGroup + [ translate (s*(-radius)) 0 circ + , translate (s*radius) 0 circ + ] & filterRef .~ pure (Ref "blur") + , translate 0 (-radius*2.2) $ withFillColor "red" $ mkGroup + [ translate (s*(-radius)) 0 circ + , translate (s*radius) 0 circ + ] & filterRef .~ pure (Ref "goo") ] - emit $ withFillColor "red" $ mkGroup - [ translate (s*(-radius)) 0 circ - , translate (s*radius) 0 circ - ] & filterRef .~ pure (Ref "blur") - emit $ translate 0 (-radius*2.2) $ withFillColor "red" $ mkGroup - [ translate (s*(-radius)) 0 circ - , translate (s*radius) 0 circ - ] & filterRef .~ pure (Ref "goo") where - sharpness = 10 + sharpness = 10 :: Integer dev = 0.2 radius = 1 - circ = mkCircle (Num radius) + circ = mkCircle radius mkFilter :: String -> [FilterElement] -> Filter mkFilter ident fe = defaultSvg & filterChildren .~ fe & attrId .~ Just ident diff --git a/examples/latex_basic.hs b/examples/latex_basic.hs index 6133965..271dacb 100755 --- a/examples/latex_basic.hs +++ b/examples/latex_basic.hs @@ -3,23 +3,15 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens - -import Graphics.SvgTree (Number(..)) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal +import Reanimate main :: IO () -main = reanimate $ autoReverse $ mkAnimation 2 $ do - s <- getSignal signalLinear - emit $ mkGroup +main = reanimate $ playThenReverseA $ mkAnimation 2 $ \t -> + mkGroup [ mkBackground "black" , withStrokeColor "white" $ withFillOpacity 0 text - , withFillColor "white" $ withFillOpacity s text + , withFillColor "white" $ withFillOpacity t text ] where - text = withStrokeWidth (Num 0.01) $ scale 2 $ center $ latexAlign + text = withStrokeWidth 0.01 $ scale 2 $ center $ latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" diff --git a/examples/latex_color.hs b/examples/latex_color.hs index b0b0e42..bcd4f21 100755 --- a/examples/latex_color.hs +++ b/examples/latex_color.hs @@ -3,24 +3,18 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens - -import Graphics.SvgTree (Number(..)) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX (latex) -import Reanimate.Monad (emit, mkAnimation) -import Reanimate.Svg +import Reanimate main :: IO () -main = reanimate $ mkAnimation 1 $ do - emit $ mkBackground "black" - emit $ - withStrokeColor "white" $ +main = reanimate $ animate $ const $ + mkGroup + [ mkBackground "black" + , withStrokeColor "white" $ withSubglyphs [0] (withFillColor "blue") $ withSubglyphs [1] (withFillColor "yellow") $ withSubglyphs [2] (withFillColor "green") $ withSubglyphs [3] (withFillColor "red") $ withSubglyphs [4] (withFillColor "darkslategrey") $ - svg + svg ] where - svg = withStrokeWidth (Num 0.01) $ scale 4 $ center $ latex "\\LaTeX" + svg = withStrokeWidth 0.01 $ scale 4 $ center $ latex "\\LaTeX" diff --git a/examples/latex_draw.hs b/examples/latex_draw.hs index 0ed9cc8..521701d 100755 --- a/examples/latex_draw.hs +++ b/examples/latex_draw.hs @@ -3,27 +3,18 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens - -import Graphics.SvgTree (Number(..)) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal +import Reanimate main :: IO () main = reanimate $ - bg `sim` (autoReverse $ drawText `andThen` fillText) + bg `parA` (playThenReverseA $ drawText `andThen` fillText) where - bg = mkAnimation 0 $ emit (mkBackground "black") + bg = animate $ const $ mkBackground "black" msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" - glyphs = withStrokeWidth (Num 0.01) $ center $ latexAlign msg - fillText = mkAnimation 1 $ do - s <- getSignal signalLinear - emit $ scale 2 $ withFillColor "white" $ withFillOpacity s glyphs - drawText = mkAnimation 2 $ do - s <- getSignal signalLinear - emit $ scale 2 $ + glyphs = withStrokeWidth 0.01 $ center $ latexAlign msg + fillText = mkAnimation 1 $ \t -> + scale 2 $ withFillColor "white" $ withFillOpacity t glyphs + drawText = mkAnimation 2 $ \t -> + scale 2 $ withStrokeColor "white" $ withFillOpacity 0 $ - partialSvg s glyphs + partialSvg t glyphs diff --git a/examples/latex_wheel.hs b/examples/latex_wheel.hs index f0c6c6e..a33efc7 100644 --- a/examples/latex_wheel.hs +++ b/examples/latex_wheel.hs @@ -4,21 +4,17 @@ {-# LANGUAGE RecursiveDo #-} module Main (main) where -import Codec.Picture.Types -import Control.Monad (forM_) -import Data.Fixed (mod') -import Graphics.SvgTree (Number (..), Tree) -import Reanimate.Driver (reanimate) +import Control.Monad (forM_) +import Graphics.SvgTree (Tree) +import Reanimate +import Reanimate.Driver (reanimate) import Reanimate.Effect -import Reanimate.LaTeX (latex) -import Reanimate.Monad import Reanimate.Scene -import Reanimate.Signal (signalLinear) -import Reanimate.Svg main :: IO () -main = reanimate $ mkAnimation 0 (emit $ mkBackground "black") `sim` - mainScene +main = reanimate $ bg `parA` mainScene + where + bg = animate $ const $ mkBackground "black" mainScene :: Animation mainScene = sceneAnimation $ mdo @@ -32,29 +28,29 @@ mainScene = sceneAnimation $ mdo forM_ svgs $ \svg -> do fork $ play $ drawTick # setDuration rotateT - # repeatAnimation rotateN + # repeatA rotateN # applyE (overBeginning 0.5 drawInE) # applyE (overEnding 0.5 drawOutE) fork $ play $ drawSVG svg # setDuration rotateT - # repeatAnimation rotateN + # 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 - # reverseAnimation + # reverseA return () where drawCircleT = 1 rotateT = 5 rotateN = 3 - svg = center $ latex "\\LaTeX" - getNth n = snd (splitGlyphs [n] svg) + svgCAF = center $ latex "\\LaTeX" + getNth n = snd (splitGlyphs [n] svgCAF) svgs = [ - withStrokeWidth (Num 0.01) $ + withStrokeWidth 0.01 $ scale 2 $ translate 0 (tickLength*2) $ withStrokeColor "white" $ @@ -62,28 +58,25 @@ mainScene = sceneAnimation $ mdo center $ getNth n | n <- [0..4]] +radius, tickLength :: Double radius = 1.25 tickLength = 0.25 drawCircle :: Animation -drawCircle = mkAnimation 1 $ do - n <- getSignal signalLinear - emit $ +drawCircle = animate $ \t -> withFillOpacity 0 $ withStrokeColor "white" $ rotate (-90) $ - partialSvg n circPath + partialSvg t circPath where - circPath = pathify $ mkCircle (Num radius) + circPath = pathify $ mkCircle radius drawTick :: Animation -drawTick = drawSVG $ mkLine (Num 0, Num 0) (Num 0, Num $ tickLength) +drawTick = drawSVG $ mkLine (0, 0) (0, tickLength) drawSVG :: Tree -> Animation -drawSVG t = mkAnimation 1 $ do - n <- getSignal signalLinear - emit $ +drawSVG svg = animate $ \t -> withStrokeColor "white" $ - rotate (n*360) $ + rotate (t*360) $ translate 0 radius $ - t + svg diff --git a/examples/polyshape_test1.hs b/examples/polyshape_test1.hs new file mode 100755 index 0000000..f3a6ca7 --- /dev/null +++ b/examples/polyshape_test1.hs @@ -0,0 +1,93 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Control.Lens () +import Data.List +import qualified Geom2D.CubicBezier as G +import Reanimate +import Reanimate.PolyShape + + +polygonTest :: Animation +polygonTest = animate $ \_ -> + std $ gridLayout $ transpose + [ test0, test1, test2, test3, test4, test5 ] + where + test0 = column ppA poly1 + test1 = column ppA poly2 + test2 = column ppA poly3 + test3 = column ppA poly4 + test4 = column ppB [boxPolyShape] + test5 = column ppB [starPolyShape] + + column pp poly = map pp + [ poly + , map plFromPolygon $ plDecompose' 0.05 poly + , map plFromPolygon $ plDecompose poly ] + + + poly1 = + svgToPolyShapes $ lowerTransformations $ + center $ scale 3 $ + latex "$\\Phi$" + poly2 = + svgToPolyShapes $ lowerTransformations $ + center $ scale 3 $ + latex "$\\vartheta$" + poly3 = + svgToPolyShapes $ lowerTransformations $ + center $ scale 3 $ + latex "$\\Xi$" + poly4 = + svgToPolyShapes $ lowerTransformations $ + center $ scale 3 $ + latex "$\\Theta$" + + ppA = renderPolyShapes + ppB = lowerTransformations . scale 0.6 . center . renderPolyShapes + std = + withFillOpacity 1 . + withFillColor "blue" . + withStrokeWidth 0.01 . + withStrokeColor "white" + + +boxPolyShape :: PolyShape +boxPolyShape = PolyShape $ G.ClosedPath + [(G.Point 0 0, G.JoinLine) + ,(G.Point 0 3, G.JoinLine) + ,(G.Point 1 3, G.JoinLine) + ,(G.Point 1 1, G.JoinLine) + ,(G.Point 2 1, G.JoinLine) + ,(G.Point 2 2, G.JoinLine) + ,(G.Point 0 2, G.JoinLine) + ,(G.Point 0 3, G.JoinLine) + ,(G.Point 3 3, G.JoinLine) + ,(G.Point 3 0, G.JoinLine) + ] + +{- +squarePolyShape :: PolyShape +squarePolyShape = PolyShape $ G.ClosedPath + [(G.Point 0 0, G.JoinLine) + ,(G.Point 1 0, G.JoinLine) + ,(G.Point 1 1, G.JoinLine) + ,(G.Point 0 1, G.JoinLine)] +-} + +starPolyShape :: PolyShape +starPolyShape = PolyShape $ G.ClosedPath + [(G.Point 0 0, G.JoinLine) + ,(G.Point 1 2, G.JoinLine) + ,(G.Point 2 0, G.JoinLine) + ,(G.Point 0 1, G.JoinLine) + ,(G.Point 2 1, G.JoinLine) + ] + +main :: IO () +main = reanimate $ bg `parA` polygonTest + where + bg = animate $ const $ mkBackground "black" diff --git a/examples/polyshape_test2.hs b/examples/polyshape_test2.hs new file mode 100755 index 0000000..5f8aaae --- /dev/null +++ b/examples/polyshape_test2.hs @@ -0,0 +1,35 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Reanimate +import Reanimate.PolyShape + +polygonTest :: Animation +polygonTest = mkAnimation 10 $ \t -> + let s = fromToS 0.5 (-0.5) t + bigBox = head $ svgToPolyShapes $ pathify $ + mkRect 2 2 + smallBox = head $ svgToPolyShapes $ pathify $ + translate (0) (screenHeight*s) $ + rotate (-45) $ + mkRect 1 1 + + overlap = mkGroup $ map renderPolyShape [bigBox, smallBox] + merged = translate (screenWidth/2*0.1) 0 $ + mkGroup $ map renderPolyShape $ + unionPolyShapes [bigBox, smallBox] + in std $ gridLayout [[ overlap, merged ]] + where + std = + withFillOpacity 1 . + withFillColor "blue" . + withStrokeWidth 0.01 . + withStrokeColor "white" + +main :: IO () +main = reanimate $ bg `parA` polygonTest + where + bg = animate $ const $ mkBackground "black" diff --git a/examples/raster.hs b/examples/raster.hs index 00171d5..385df1e 100755 --- a/examples/raster.hs +++ b/examples/raster.hs @@ -1,25 +1,15 @@ #!/usr/bin/env stack -- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens - -import Graphics.SvgTree (Number(..)) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal -import Reanimate.Raster +import Reanimate import Codec.Picture main :: IO () -main = reanimate $ mkAnimation 5 $ do - s <- getSignal signalLinear - emit $ mkGroup +main = reanimate $ mkAnimation 5 $ \t -> + mkGroup [ mkBackground "black" - , rotate (s*360) $ center $ scaleToWidth 6 $ embedImage img + , rotate (t*360) $ center $ scaleToWidth 6 $ embedImage img ] where img = generateImage pixelRenderer 255 255 diff --git a/examples/shatter.hs b/examples/shatter.hs new file mode 100755 index 0000000..ed84241 --- /dev/null +++ b/examples/shatter.hs @@ -0,0 +1,135 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Chiphunk.Low +import Control.Monad +import Graphics.SvgTree (Tree) +import Linear.V2 +import Reanimate +import Reanimate.Chiphunk +import Reanimate.PolyShape +import System.IO.Unsafe + +test :: Animation +test = unsafePerformIO $ do + bodyStore <- newBodyStore + let gravity = Vect 0 (-1) + + -- Create an empty space. + space <- spaceNew + spaceCollisionSlop space $= (screenWidth/2560) + spaceGravity space $= gravity + + -- Add a static line segment shape for the ground. + -- We'll make it slightly tilted so the ball will roll off. + -- We attach it to a static body to tell Chipmunk it shouldn't be movable. + static <- get $ spaceStaticBody space + ground <- segmentShapeNew static + (Vect (-screenWidth/2) 0) + (Vect (screenWidth/2) (-screenHeight/2)) 0 + -- ground <- polyShapeNewRaw static + -- [ Vect (-screenWidth/2) (screenHeight/2) + -- , Vect (screenWidth/2) (-screenHeight/2) + -- , Vect (-screenWidth/2) (-screenHeight/2) + -- , Vect (-screenWidth/2) (screenHeight/2) ] 0 + shapeFriction ground $= 1 + spaceAddShape space ground + + + + -- Now let's make a ball that falls onto the line and rolls off. + -- First we need to make a cpBody to hold the physical properties of the object. + -- These include the mass, position, velocity, angle, etc. of the object. + -- Then we attach collision shapes to the Body to give it a size and shape. + + let toVect (V2 x y) = Vect x y + + let svg = center $ scale 2 $ latex "\\LaTeX" + poly = svgToPolyShapes svg + vectGroup = plDecompose poly + --mkCircle (Num radius) + -- vects = svgToVects svg + -- vects' = fst $ convexHull vects 0 + -- svg' = + -- withFillOpacity 0 $ withStrokeColor "white" $ + -- withStrokeWidth 0.01 $ + -- renderPolyShapes (map plFromPolygon vectGroup) + -- + -- ballBody <- polyShapesToBody space poly + -- bodyPosition ballBody $= Vect (-screenWidth/4) (screenHeight/2) + -- + -- addToBodyStore bodyStore ballBody $ + -- withFillColor "white" $ + -- mkGroup + -- [ svg' ] + + -- let splitPolys = vectGroup + forM_ vectGroup $ \polygon -> do + bd <- polygonsToBody space [map toVect polygon] + bodyPosition bd $= Vect 0 (screenHeight/3) + addToBodyStore bodyStore bd $ + renderPolyShape $ plFromPolygon polygon + -- withFillColor "white" $ + -- mkGroup + -- [ --withStrokeWidth (Num 0.005) $ + -- -- withStrokeWidth (Num 0.00) $ + -- -- withStrokeColor "white" $ + -- -- withFillOpacity 1 $ + -- renderPolyShape $ plFromPolygon polygon + -- ] + + ani <- simulate space bodyStore 60 60 10 + spaceFreeRecursive space + return ani + +-- data LineCommand +-- = LineMove RPoint +-- -- | LineDraw RPoint +-- | LineBezier [RPoint] +-- | LineEnd + +-- vectsToSVG :: [Vect] -> Tree +-- vectsToSVG (Vect x y:rest) = +-- mkPath $ +-- MoveTo OriginAbsolute [V2 x y] : +-- [ LineTo OriginAbsolute [V2 a b] | Vect a b <- rest ] ++ +-- [ EndPath ] +-- where +-- mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds + +-- polygonsToSVG :: [[Vect]] -> Tree +-- polygonsToSVG = merge . mkGroup . map vectsToSVG +-- where +-- merge svg = PathTree $ defaultSvg & pathDefinition .~ extractPath svg + +-- svgToVects :: Tree -> [Vect] +-- svgToVects svg = map worker (lineToPoints 200 cmds) +-- where +-- worker (V2 x y) = Vect x y +-- cmds = toLineCommands $ wibble $ extractPath svg +-- wibble xs = takeWhile (/=EndPath) xs ++ [EndPath] + +chunkPolyshapes :: Tree -> Tree +chunkPolyshapes t = + withStrokeColor "white" $ + withStrokeWidth 0.01 $ + withFillColor "white" $ t + +-- plArea :: PolyShape -> Double +-- plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0 +-- where +-- toVect (Point x y) = Vect x y + +reorient :: Tree -> Tree +reorient = id -- scale 4 . translate 0 (-0.9) + +main :: IO () +main = reanimate $ bg `parA` mapA reorient (line `parA` mapA chunkPolyshapes test) + where + bg = animate $ const $ mkBackground "black" + line = animate $ const $ withStrokeColor "white" $ + withStrokeWidth 0.01 $ + mkLine (-screenWidth/2, 0) + (screenWidth/2, -screenHeight/2) diff --git a/examples/signals.hs b/examples/signals.hs index 0567d50..ed41c3c 100755 --- a/examples/signals.hs +++ b/examples/signals.hs @@ -1,76 +1,74 @@ #!/usr/bin/env stack -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Main (main) where -import Control.Lens -import Data.Text (pack, Text) +import Data.Monoid ((<>)) +import Data.Text (Text, pack) +import Graphics.SvgTree hiding (Text) import Numeric -import Data.Monoid - -import Graphics.SvgTree hiding (Text) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal +import Reanimate.Animation import Reanimate.Constants +import Reanimate.Driver (reanimate) +import Reanimate.LaTeX +import Reanimate.Signal +import Reanimate.Svg main :: IO () main = reanimate $ pauseAtEnd 5 $ curvesExample (\_ -> ([], "[]")) - `before` + `seqA` curvesExample (\s -> - ( [(1, signalFlat s)] - , "[(1, signalFlat " <> showFloat s <> ")]")) - `before` + ( [(1, constantS s)] + , "[(1, constantS " <> ppD s <> ")]")) + `seqA` curvesExample (\s -> - ( [(s, signalFlat 0), (1, signalLinear)] - , "[(" <> showFloat s <> ", signalFlat 0), (1, signalLinear)]")) - `before` + ( [(s, constantS 0), (1, id)] + , "[(" <> ppD s <> ", constantS 0), (1, id)]")) + `seqA` curvesExample (\s -> - ( [(s, signalFlat 1), (1, signalReverse signalLinear)] - , "[(" <> showFloat s <> ", signalFlat 0), (1, signalReverse signalLinear)]")) - `before` + ( [(s, constantS 1), (1, reverseS)] + , "[(" <> ppD s <> ", constantS 1), (1, reverseS)]")) + `seqA` curvesExample (\s -> - ( [(1, signalCurve (2+s*3))] - , "[(1, signalCurve "<> showFloat (2+s*3) <>")]")) - `before` + ( [(1, curveS (2+s*3))] + , "[(1, curveS "<> ppD (2+s*3) <>")]")) + `seqA` curvesExample (\s -> - ( [(1, signalFromTo s 1 $ signalCurve 5)] - , "[(1, signalFromTo "<> showFloat s <>" 1 \\$ signalCurve 5)]")) - `before` + ( [(1, fromToS s 1 . curveS 5)] + , "[(1, fromToS "<> ppD s <>" 1 \\$ curveS 5)]")) + `seqA` curvesExample (\s -> - ( [(1, signalBell (2+s*3))] - , "[(1, signalBell "<> showFloat (2+s*3)<>")]")) + ( [(1, bellS (2+s*3))] + , "[(1, bellS "<> ppD (2+s*3)<>")]")) where - showFloat s = pack (showFFloat (Just 2) s "") + ppD s = pack (showFFloat (Just 2) s "") +convertX, convertY :: Double -> Double convertX x = x*(screenWidth/320) convertY y = y*(screenHeight/180) curvesExample :: (Double -> ([(Double, Double -> Double)], Text)) -> Animation -curvesExample gen = mkAnimation 2 $ do - emit $ mkBackground "black" - emit $ withFillColor "white" $ +curvesExample gen = mkAnimation 2 $ \t -> + mkGroup + [ mkBackground "black" + , withFillColor "white" $ translate 0 (screenHeight*0.35) $ center $ latex "Signals" - s <- getSignal signalLinear - let (curveFns, name) = gen s - emit $ - center $ - mkGroup - [ withStrokeColor "white" $ withStrokeWidth (Num 0.01) $ + , let (curveFns, name) = gen t in + center $ + mkGroup + [ withStrokeColor "white" $ withStrokeWidth 0.01 $ mkGroup - [ mkLine (Num 0, Num 0) - (Num $ convertX 200, Num 0) - , mkLine (Num $ 0, Num 0) - (Num $ 0, Num $ convertY 50) ] - , withStrokeColor "white" $ withStrokeWidth (Num 0.01) $ + [ mkLine (0, 0) + (convertX 200, 0) + , mkLine (0, 0) + (0, convertY 50) ] + , withStrokeColor "white" $ withStrokeWidth 0.01 $ mkGroup - [ mkLine (Num 0, Num $ convertX $ y) - (Num $ convertX 200, Num $ convertX y) + [ mkLine (0, convertX $ y) + (convertX 200, convertX y) | y <- [10,20,30,40,50] ] , withFillColor "white" $ mkGroup @@ -78,9 +76,10 @@ curvesExample gen = mkAnimation 2 $ do , translate (convertX $ -5) (convertX $ 50) $ scale 0.5 $ center $ latex "1" , 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 (Num 0.5) $ - lowerTransformations $ scaleXY (convertX $ 200) (convertX $ (50)) $ mkSignalLine (signalFromList curveFns) + , withFillOpacity 0 $ withStrokeColor "green" $ -- withStrokeWidth 0.5 $ + lowerTransformations $ scaleXY (convertX $ 200) (convertX $ (50)) $ mkSignalLine (fromListS curveFns) ] + ] mkSignalLine :: Signal -> Tree mkSignalLine fn = mkLinePath diff --git a/examples/simulate_equation.hs b/examples/simulate_equation.hs new file mode 100755 index 0000000..171d43b --- /dev/null +++ b/examples/simulate_equation.hs @@ -0,0 +1,201 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Chiphunk.Low +import Control.Monad +import Graphics.SvgTree (Tree) +import Linear.V2 +import Reanimate.Chiphunk +import Reanimate +import Reanimate.PolyShape +import System.IO.Unsafe + +test :: Animation +test = unsafePerformIO $ do + bodyStore <- newBodyStore + let gravity = Vect 0 (-1) + + -- Create an empty space. + space <- spaceNew + -- spaceCollisionSlop space $= (screenWidth/2560) + spaceGravity space $= gravity + + -- Add a static line segment shape for the ground. + -- We'll make it slightly tilted so the ball will roll off. + -- We attach it to a static body to tell Chipmunk it shouldn't be movable. + static <- get $ spaceStaticBody space + ground <- segmentShapeNew static + (Vect (-screenWidth/2) (screenHeight/2)) + (Vect (screenWidth/2) (-screenHeight/2)) 0 + shapeFriction ground $= 1 + spaceAddShape space ground + + -- Now let's make a ball that falls onto the line and rolls off. + -- First we need to make a cpBody to hold the physical properties of the object. + -- These include the mass, position, velocity, angle, etc. of the object. + -- Then we attach collision shapes to the Body to give it a size and shape. + + let toVect (V2 x y) = Vect x y + + let svg = center $ scale 2 $ latex "$\\Phi$" + poly = svgToPolyShapes svg + vectGroup = plDecompose' 1 poly + --mkCircle (Num radius) + -- vects = svgToVects svg + -- vects' = fst $ convexHull vects 0 + -- svg' = + -- withFillOpacity 0 $ withStrokeColor "white" $ + -- withStrokeWidth 0.01 $ + -- renderPolyShapes (map plFromPolygon vectGroup) + -- + -- ballBody <- polyShapesToBody space poly + -- bodyPosition ballBody $= Vect (-screenWidth/4) (screenHeight/2) + -- + -- addToBodyStore bodyStore ballBody $ + -- withFillColor "white" $ + -- mkGroup + -- [ svg' ] + + -- let splitPolys = vectGroup + forM_ vectGroup $ \polygon -> do + bd <- polygonsToBody space [map toVect polygon] + bodyPosition bd $= Vect 0 (screenHeight/3) + addToBodyStore bodyStore bd $ + renderPolyShape $ plFromPolygon polygon + -- withFillColor "white" $ + -- mkGroup + -- [ --withStrokeWidth (Num 0.005) $ + -- -- withStrokeWidth (Num 0.00) $ + -- -- withStrokeColor "white" $ + -- -- withFillOpacity 1 $ + -- renderPolyShape $ plFromPolygon polygon + -- ] + + ani <- simulate space bodyStore 60 10 10 + spaceFreeRecursive space + return ani + +-- data LineCommand +-- = LineMove RPoint +-- -- | LineDraw RPoint +-- | LineBezier [RPoint] +-- | LineEnd + +-- vectsToSVG :: [Vect] -> Tree +-- vectsToSVG (Vect x y:rest) = +-- mkPath $ +-- MoveTo OriginAbsolute [V2 x y] : +-- [ LineTo OriginAbsolute [V2 a b] | Vect a b <- rest ] ++ +-- [ EndPath ] +-- where +-- mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds + +-- polygonsToSVG :: [[Vect]] -> Tree +-- polygonsToSVG = merge . mkGroup . map vectsToSVG +-- where +-- merge svg = PathTree $ defaultSvg & pathDefinition .~ extractPath svg + +-- svgToVects :: Tree -> [Vect] +-- svgToVects svg = map worker (lineToPoints 200 cmds) +-- where +-- worker (V2 x y) = Vect x y +-- cmds = toLineCommands $ wibble $ extractPath svg +-- wibble xs = takeWhile (/=EndPath) xs ++ [EndPath] + +chunkPolyshapes :: Tree -> Tree +chunkPolyshapes t = + mkGroup + [ + -- withFillColor "white" $ + -- withFillOpacity 1 $ + -- withStrokeWidth (Num 0.01) $ + -- withStrokeColor "blue" $ + -- mkGroup $ map renderPolyShape $ + -- map mergePolyShapeHoles $ + -- plGroupShapes $ + -- -- unionPolyShapes $ + -- traceUnion $ + -- svgToPolyShapes t + withStrokeWidth 0.001 $ + withStrokeColor "red" $ + withFillOpacity 0 $ + mkGroup $ map renderPolyShape $ + svgToPolyShapes t + -- withStrokeWidth 0.001 $ + -- withStrokeColor "red" $ + -- mkGroup $ map renderPolyShape [pl12,pl13] + ] + +-- plArea :: PolyShape -> Double +-- plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0 +-- where +-- toVect (Point x y) = Vect x y + +reorient :: Tree -> Tree +reorient = scale 6 . translate 0 (-0.9) + +-- traceUnion t = +-- let out = unionPolyShapes t +-- in trace (unlines $ +-- ("Trace: " ++ show (sum $ map plArea t)) : +-- ("Check: " ++ show (sum $ map plArea out)) : +-- map show t ++ ["Out:"] ++ map show out) out + +-- pl1 = PolyShape {unPolyShape = ClosedPath [(Point 9.076152025049407e-2 0.8793158714390639,JoinLine),(Point 0.48865783997158957 0.5875446050720555,JoinLine),(Point 0.6291445682322502 0.560956966929786,JoinLine),(Point 0.684414274089106 0.6254399758525935,JoinLine),(Point 8.549729225029659e-2 0.9226054512958702,JoinLine)]} +-- pl2 = PolyShape {unPolyShape = ClosedPath [(Point 0.3174796674934045 (-0.17830385091116296),JoinLine),(Point 0.3930521201476444 (-0.22384314349780887),JoinLine),(Point 0.42400439387727545 (-0.17026635397131717),JoinLine),(Point 0.367180526197663 (-0.13743818486413273),JoinLine)]} +-- pl3 = PolyShape {unPolyShape = ClosedPath [(Point 3.818529643334073e-2 4.994390978944008e-2,JoinLine),(Point 3.5509598929490127e-3 3.0061273354143103e-2,JoinLine),(Point 2.6643683455205014e-2 (-1.3314171733262437e-2),JoinLine)]} +-- pl4 = PolyShape {unPolyShape = ClosedPath [(Point 8.041123459068245e-2 (-4.592522065745819e-2),JoinLine),(Point 0.29675416515553454 (-0.17235110729572378),JoinLine),(Point 0.34590008699238584 (-0.13081971694800998),JoinLine),(Point 0.22737727571852562 4.513304505856075e-2,JoinLine),(Point 0.10498823211784264 (-3.373201779345303e-3),JoinLine)]} +-- pl5 = PolyShape {unPolyShape = ClosedPath [(Point 4.1547772506933034e-2 0.10908491253751296,JoinLine),(Point 5.7556283592893165e-2 (-2.2936657573235042e-2),JoinLine),(Point 0.18645395693905423 2.887370173550552e-2,JoinLine),(Point 0.24063435970720265 0.12675372820097613,JoinLine),(Point 0.19807899284556882 0.17285980812856805,JoinLine),(Point 8.45668830191807e-2 0.18680141998908184,JoinLine)]} +-- pl6 = PolyShape {unPolyShape = ClosedPath [(Point (-0.2574090456009813) 0.22352645168090446,JoinLine),(Point (-0.27139525022076605) 0.16073053060077958,JoinLine),(Point (-9.444562231853837e-2) 4.994785063168361e-2,JoinLine),(Point (-4.012849544398306e-2) 6.733655689772311e-2,JoinLine),(Point (-4.6550067413171026e-2) 0.20017002713448606,JoinLine)]} +-- pl7 = PolyShape {unPolyShape = ClosedPath [(Point (-0.3714373753139388) 0.20874389306710772,JoinLine),(Point (-0.29452803703157854) 0.1655072120141602,JoinLine),(Point (-0.2835217605861194) 0.22889335799870397,JoinLine),(Point (-0.34012040364470725) 0.2621083279509192,JoinLine)]} +-- pl8 = PolyShape {unPolyShape = ClosedPath [(Point 0.1712163207191154 0.2149766965620984,JoinLine),(Point 0.19616659305280632 0.1905738263277067,JoinLine),(Point 0.6315796735654418 0.5328570813993471,JoinLine),(Point 0.49895896036053317 0.5862908698518825,JoinLine)]} +-- pl9 = PolyShape {unPolyShape = ClosedPath [(Point 0.10739670009207455 0.19390054402859663,JoinLine),(Point 0.16776933204268935 0.17681618959615353,JoinLine),(Point 0.19166035517967667 0.1970425575035583,JoinLine),(Point 0.16584071117957827 0.2205236594561943,JoinLine)]} +-- pl10 = PolyShape {unPolyShape = ClosedPath [(Point (-0.3669271639958152) 1.1382616686769857,JoinLine),(Point (-0.30169633405804164) 1.1454435521784956,JoinLine),(Point (-0.2858326377769962) 1.2078015601462844,JoinLine),(Point (-0.3736986541543818) 1.199765022618315,JoinLine)]} +-- pl11 = PolyShape {unPolyShape = ClosedPath [(Point (-3.0061173114158422e-2) 1.1779482589541495,JoinLine),(Point 5.4907529076574785e-3 1.2315286122957358,JoinLine),(Point (-3.4177530164954735e-2) 1.2269151735259667,JoinLine)]} +-- pl12 = PolyShape {unPolyShape = ClosedPath +-- [(Point (-0.301730083226429*10) 1.1457103198223786,JoinLine) +-- ,(Point (-0.10299641326632633*10) 1.0714677466302471,JoinLine) +-- ,(Point (-3.162369257155477e-2*10) 1.182092647608354,JoinLine) +-- ,(Point (-3.636877035247056e-2*10) 1.2310026399913667,JoinLine) +-- ,(Point (-0.28589249688644447*10) 1.208074964264014,JoinLine)]} +-- pl13 = PolyShape {unPolyShape = ClosedPath +-- [(Point (-9.39646610882567e-2*10) 0.96018603098516,JoinLine) +-- ,(Point (-6.465077411411442e-2*10) 0.9514465910530718,JoinLine) +-- ,(Point (0.14134955357291654*10) 1.2461928296570437,JoinLine) +-- ,(Point (8.29425965486209e-3*10) 1.2330682613363688,JoinLine) +-- ,(Point (-0.10287959610529117*10) 1.0717052650151784,JoinLine)]} +-- pl14 = PolyShape {unPolyShape = ClosedPath [(Point (-0.6410657779553459) 0.5634659418454123,JoinLine),(Point (-0.641345175626591) 0.555247219163176,JoinLine),(Point (-0.4420444191709594) 0.5513358399243028,JoinLine),(Point (-0.10594072095664082) 0.9023816092645105,JoinLine),(Point (-7.577913627887163e-2) 0.9355404742795719,JoinLine),(Point (-0.10373629906690308) 0.9479533236181756,JoinLine)]} +-- pl15 = PolyShape {unPolyShape = ClosedPath [(Point (-3.523485505752828e-2) 0.1998408875682416,JoinLine),(Point 1.2546982880291841e-2 0.15208851089779252,JoinLine),(Point 0.13018455413761065 0.208301106923033,JoinLine),(Point 8.433578523127425e-2 0.9418697065712005,JoinLine),(Point (-7.884702019521485e-2) 0.932428903501462,JoinLine),(Point (-8.084970167352624e-2) 0.9296667902794287,JoinLine)]} +-- pl16 = PolyShape {unPolyShape = ClosedPath [(Point (-7.878197627394322e-2) 0.9319709148544943,JoinLine),(Point 8.438182768423004e-2 0.941734614325483,JoinLine),(Point 8.518191684165782e-2 0.9853357574063363,JoinLine),(Point 8.15663333974107e-2 0.9853939259545145,JoinLine),(Point (-4.936159754845773e-2) 0.9727171460725276,JoinLine)]} +-- pl17 = PolyShape {unPolyShape = ClosedPath [(Point (-4.99911351869741e-2) 0.9726181699897635,JoinLine),(Point 8.094809532371453e-2 0.9851776987711782,JoinLine),(Point 7.384845354621125e-2 1.0968271981504014,JoinLine),(Point 4.400324523877765e-2 1.1025518925313644,JoinLine)]} +-- pl18 = PolyShape {unPolyShape = ClosedPath [(Point 4.8482888984171635e-2 1.1105768787999895,JoinLine),(Point 7.512899062784217e-2 1.0959654499901599,JoinLine),(Point 0.2822087302816073 1.1420633097553252,JoinLine),(Point 0.27513287205836434 1.2060076125068004,JoinLine),(Point 0.20204313118994668 1.2231219927110881,JoinLine)]} +-- pl19 = PolyShape {unPolyShape = ClosedPath [(Point 0.2748784478150325 1.2078902086770202,JoinLine),(Point 0.2820822061918643 1.1439601884266248,JoinLine),(Point 0.3457225261391361 1.127943000720636,JoinLine),(Point 0.36082444597621127 1.187946730956635,JoinLine)]} +-- pl20 = PolyShape {unPolyShape = ClosedPath [(Point (-0.6864531908080556) 0.5032767356555317,JoinLine),(Point (-9.929294916146593e-2) 0.20829491627795255,JoinLine),(Point (-8.483230342755331e-2) 0.23523598173633797,JoinLine),(Point (-0.49217693932265094) 0.547917843618004,JoinLine)]} +-- pl21 = PolyShape {unPolyShape = ClosedPath [(Point (-9.274301086931341e-2) 0.2153671046631685,JoinLine),(Point (-4.68781647762479e-2) 0.2005165600411279,JoinLine),(Point (-4.790067311086227e-2) 0.23865704773924823,JoinLine),(Point (-7.795810209993242e-2) 0.2330461435659677,JoinLine)]} + +-- unionTest = parsed +-- where +-- svg = center $ scale 2 $ latex "I" +-- poly = svgToPolyShapes svg +-- vectGroup = plDecompose' 1 poly +-- rendered = mkGroup $ take 100 $ map (renderPolyShape . plFromPolygon) vectGroup +-- parsed = svgToPolyShapes rendered +-- +-- myDecompose tol = +-- concatMap decomposePolygon . +-- map (plPolygonify tol) . +-- map mergePolyShapeHoles . +-- plGroupShapes . +-- unionPolyShapes + +main :: IO () +main = reanimate $ bg `parA` mapA reorient (line `parA` mapA chunkPolyshapes test) + where + bg = animate $ const $ mkBackground "black" + line = animate $ const $ withStrokeColor "white" $ + withStrokeWidth 0.01 $ + mkLine (-screenWidth/2, screenHeight/2) + (screenWidth/2, -screenHeight/2) diff --git a/examples/simulate_gravity.hs b/examples/simulate_gravity.hs new file mode 100755 index 0000000..6af3fed --- /dev/null +++ b/examples/simulate_gravity.hs @@ -0,0 +1,79 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Chiphunk.Low +import Reanimate.Chiphunk +import Reanimate +import System.IO.Unsafe + + +test :: Animation +test = unsafePerformIO $ do + bodyStore <- newBodyStore + let gravity = Vect 0 (-10) + + -- Create an empty space. + space <- spaceNew + spaceGravity space $= gravity + + -- Add a static line segment shape for the ground. + -- We'll make it slightly tilted so the ball will roll off. + -- We attach it to a static body to tell Chipmunk it shouldn't be movable. + static <- get $ spaceStaticBody space + ground <- segmentShapeNew static + (Vect (-screenWidth/2) 0) + (Vect (screenWidth/2) (-screenHeight/2)) 0 + shapeFriction ground $= 1 + spaceAddShape space ground + + -- Now let's make a ball that falls onto the line and rolls off. + -- First we need to make a cpBody to hold the physical properties of the object. + -- These include the mass, position, velocity, angle, etc. of the object. + -- Then we attach collision shapes to the Body to give it a size and shape. + + let radius = 1 + let mass = 1 + + -- The moment of inertia is like mass for rotation + -- Use the momentFor* functions to help you approximate it. + let moment = momentForCircle mass 0 radius (Vect 0 0) + + -- The spaceAdd* functions return the thing that you are adding. + ballBody <- bodyNew mass moment + spaceAddBody space ballBody + bodyPosition ballBody $= Vect 0 (screenHeight/2) + + -- Now we create the collision shape for the ball. + -- You can create multiple collision shapes that point to the same body. + -- They will all be attached to the body and move around to follow it. + ballShape <- circleShapeNew ballBody radius (Vect 0 0) + spaceAddShape space ballShape + shapeFriction ballShape $= 0.7 + + addToBodyStore bodyStore ballBody $ + withFillColor "white" $ + mkGroup + [ mkCircle radius + , withStrokeColor "black" $ + mkLine (0, 0) (0, radius) ] + + ani <- simulate space bodyStore 60 3 4 + + shapeFree ballShape + bodyFree ballBody + shapeFree ground + spaceFree space + return ani + + +main :: IO () +main = reanimate $ bg `parA` line `parA` test + where + bg = animate $ const $ mkBackground "black" + line = animate $ const $ withStrokeColor "white" $ + withStrokeWidth 0.01 $ + mkLine (-screenWidth/2, 0) + (screenWidth/2, -screenHeight/2) diff --git a/examples/sorting.hs b/examples/sorting.hs index 2ef82ba..7fd9ba4 100755 --- a/examples/sorting.hs +++ b/examples/sorting.hs @@ -4,43 +4,30 @@ {-# LANGUAGE RankNTypes #-} module Main (main) where -import Control.Lens () - import Codec.Picture -import Data.Text (Text) -import Graphics.SvgTree (Number (..)) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Raster -import Reanimate.Signal -import Reanimate.Svg -import Reanimate.ColorMap - import Control.Monad.ST import Control.Monad.State.Strict +import Data.Text (Text) import qualified Data.Vector.Generic.Mutable as GV import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V -import Debug.Trace +import Reanimate import System.Random import System.Random.Shuffle -import Reanimate.Constants main :: IO () main = reanimate $ - demonstrateAlgorithm "Bubble sort" bubbleSort `before` - demonstrateAlgorithm "Merge sort (left leaning)" mergeSort `before` - demonstrateAlgorithm "Merge sort" mergeSortUp `before` - demonstrateAlgorithm "Insertion sort" insertSort `before` - demonstrateAlgorithm "Selection sort" selectionSort `before` - adjustSpeed (1/3) (demonstrateAlgorithm "Quicksort" quicksort) + demonstrateAlgorithm "Bubble sort" bubbleSort `seqA` + demonstrateAlgorithm "Merge sort (left leaning)" mergeSort `seqA` + demonstrateAlgorithm "Merge sort" mergeSortUp `seqA` + demonstrateAlgorithm "Insertion sort" insertSort `seqA` + demonstrateAlgorithm "Selection sort" selectionSort `seqA` + adjustDuration (*3) (demonstrateAlgorithm "Quicksort" quicksort) demonstrateAlgorithm :: Text -> (forall s. S s ()) -> Animation -demonstrateAlgorithm name algo = mkAnimation 10 $ do - s <- getSignal signalLinear +demonstrateAlgorithm name algo = mkAnimation 10 $ \t -> let img = generateImage pixelRenderer width height - seed = round (s * 3000) + seed = round (t * 3000) pixelRenderer x y = turbo (fromIntegral num / fromIntegral width) where num = (sortedDat !! y) V.! x @@ -48,7 +35,7 @@ demonstrateAlgorithm name algo = mkAnimation 10 $ do -- width = 1024 width = 500 height = length sortedDat - emit $ mkGroup + in mkGroup [ mkBackground "black" , translate 0 (-screenWidth*0.03) $ center $ scaleXY (-1) 1 $ @@ -60,7 +47,7 @@ demonstrateAlgorithm name algo = mkAnimation 10 $ do rotate (-90) $ scale 0.5 $ center $ latex "$Time \\rightarrow$" , withFillColor "white" $ translate ((screenWidth*0.30)) 0 $ - mkCircle (Num $ (1-s)*0.5) + mkCircle ((1-t)*0.5) ] where @@ -83,8 +70,8 @@ data Env s = Env type S s a = StateT (Env s) (ST s) a -runSort :: (forall s. S s ()) -> Int -> [Vector Int] -runSort = runSort' 0xDEADBEEF +-- runSort :: (forall s. S s ()) -> Int -> [Vector Int] +-- runSort = runSort' 0xDEADBEEF runSort' :: Int -> (forall s. S s ()) -> Int -> [Vector Int] runSort' seed sortFn len = reverse $ runST (do @@ -93,9 +80,6 @@ runSort' seed sortFn len = reverse $ runST (do envHistory <$> execStateT sortFn env) where lst = shuffle' [1 .. len] len (mkStdGen seed) - skipDups (x:y:xs) | x == y = skipDups (x:xs) - skipDups (x:xs) = x : skipDups xs - skipDups [] = [] readS :: Int -> S s Int readS idx = do @@ -138,6 +122,7 @@ mergeSort' start end = do zipWithM_ writeS [start..] (merge leftVals rightVals) snapshot +merge :: Ord a => [a] -> [a] -> [a] merge [] xs = xs merge xs [] = xs merge (x:xs) (y:ys) @@ -149,7 +134,7 @@ mergeSortUp :: S s () mergeSortUp = do snapshot len <- inputLength - let chunkSizes = takeWhile (< len) $ map (2^) [0..] + let chunkSizes = takeWhile (< len) $ map (2^) [0::Int ..] forM_ chunkSizes $ bottomUpMergeSort' bottomUpMergeSort' :: Int -> S s () @@ -166,7 +151,6 @@ selectionSort = do snapshot len <- inputLength forM_ [0 .. len-1] $ \j -> do - jVal <- readS j i <- findMin j (j+1) len swapS j i snapshot diff --git a/examples/sphere.hs b/examples/sphere.hs index 800aeed..c437829 100755 --- a/examples/sphere.hs +++ b/examples/sphere.hs @@ -4,24 +4,15 @@ {-# LANGUAGE QuasiQuotes #-} module Main (main) where -import Control.Lens - -import Graphics.SvgTree (Number(..)) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal -import Reanimate.Raster -import Reanimate.Povray -import Codec.Picture +import Reanimate import Data.String.Here main :: IO () -main = reanimate $ mkAnimation 5 $ do - s <- getSignal $ signalFromTo 0 360 signalLinear - emit $ mkBackground "black" - emit $ povray [] (script s) +main = reanimate $ mkAnimation 5 $ \t -> + let s = fromToS 0 360 t in + mkGroup + [ mkBackground "black" + , povray [] (script s) ] where script s = [iTrim| //EXAMPLE OF SPHERE diff --git a/examples/sunflower.hs b/examples/sunflower.hs index b3dd0e9..a01a220 100755 --- a/examples/sunflower.hs +++ b/examples/sunflower.hs @@ -3,39 +3,29 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Codec.Picture.Types import qualified Data.Colour.Palette.BrewerSet as D -import qualified Diagrams.Backend.SVG as D import Diagrams.Prelude hiding (Animation, boundingBox, center, circle, duration, fontSize, rotate, scale, translate) import qualified Diagrams.Prelude as D -import qualified Diagrams.TwoD.Path.LSystem as D -import Graphics.SvgTree (Number (..)) -import Graphics.SvgTree as S -import Linear.V2 import Reanimate.Diagrams -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Signal -import Reanimate.Svg +import Reanimate main :: IO () -main = reanimate $ mkAnimation 10 $ do - n <- getSignal $ signalFromTo 1 500 signalLinear - rot <- getSignal $ signalFromTo 0 45 signalLinear - emit $ mkBackground "black" - emit $ rotate rot $ translate (-320/2) (-180/2) - (dSvg $ round n) +main = reanimate $ mkAnimation 10 $ \t -> + let n = fromToS 1 500 t + rot = fromToS 0 45 t + in mkGroup + [ mkBackground "black" + , rotate rot $ translate (-320/2) (-180/2) + (dSvg $ round n) ] where - cached = [ dSvg n | n <- [0..]] dSvg n = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $ D.scale 0.2 $ sunflower n mkCoords :: [P2 Double] - mkCoords =[coord (fromIntegral i) | i <- [1..]] + mkCoords =[coord (fromIntegral i) | i <- [1::Int ..]] where coord m = p2 $ fromPolar (sqrt m) (2.4 * m) fromPolar r theta = (r * cos theta, r * sin theta) @@ -49,4 +39,4 @@ main = reanimate $ mkAnimation 10 $ do sunflower :: Int -> SvgDiagram sunflower n = frame 4 $ position $ take n $ zip mkCoords florets where - florets = [ floret (sqrt (fromIntegral i)) | i <- [1 ..]] + florets = [ floret (sqrt (fromIntegral i)) | i <- [1::Int ..]] diff --git a/examples/tangent_and_normal.hs b/examples/tangent_and_normal.hs index 76eea6b..6c5d5cc 100755 --- a/examples/tangent_and_normal.hs +++ b/examples/tangent_and_normal.hs @@ -3,35 +3,28 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Codec.Picture.Types -import qualified Data.Colour.Palette.BrewerSet as D -import qualified Diagrams.Backend.SVG as D import Diagrams.Prelude hiding (Animation, boundingBox, center, circle, duration, fontSize, rotate, scale, translate) import qualified Diagrams.Prelude as D -import qualified Diagrams.TwoD.Path.LSystem as D -import Graphics.SvgTree (Number (..)) -import Graphics.SvgTree as S -import Linear.V2 import Reanimate.Diagrams import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad +import Reanimate.Animation import Reanimate.Signal import Reanimate.Svg main :: IO () -main = reanimate $ mkAnimation 5 $ do - s <- oscillate $ getSignal $ signalCurve 2 - emit $ mkBackground "black" - emit $ scale (2/50) $ scaleXY 1 (-1) $ +main = reanimate $ playThenReverseA $ mkAnimation 5 $ \t -> + let s = curveS 2 t in + mkGroup + [ mkBackground "black" + , scale (2/50) $ scaleXY 1 (-1) $ translate (-320/2) (-180/2) $ withStrokeColor "white" $ renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $ - D.scale 50 $ D.translate (V2 (-2) (-0.75)) $ dia s + D.scale 50 $ D.translate (V2 (-2) (-0.75)) $ dia s ] where dia param = frame 0.5 $ lc white $ diff --git a/examples/vector_field.hs b/examples/vector_field.hs index 4bf605e..4664c99 100755 --- a/examples/vector_field.hs +++ b/examples/vector_field.hs @@ -4,40 +4,31 @@ {-# LANGUAGE FlexibleContexts #-} module Main (main) where -import Codec.Picture.Types -import qualified Data.Colour.Palette.BrewerSet as D -import qualified Diagrams.Backend.SVG as D import Diagrams.Prelude hiding (Animation, boundingBox, center, circle, duration, fontSize, rotate, scale, translate) import qualified Diagrams.Prelude as D -import qualified Diagrams.TwoD.Path.LSystem as D -import Graphics.SvgTree (Number (..)) -import Graphics.SvgTree as S -import Linear.V2 import Reanimate.Diagrams -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Signal -import Reanimate.Svg +import Reanimate main :: IO () -main = reanimate $ repeatAnimation 5 $ mkAnimation 5 $ do - s <- getSignal signalLinear - emit $ mkBackground "black" - emit $ scale (2/50) $ center $ -- translate (-320/2) (-180/2) $ +main = reanimate $ repeatA 5 $ mkAnimation 5 $ \t -> + mkGroup + [ mkBackground "black" + , scale (2/50) $ center $ -- translate (-320/2) (-180/2) $ withStrokeColor "white" $ renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $ D.scale 50 $ lc white $ - example s + example t ] +vectorField :: (Double, Double) -> V2 Double vectorField (x, y) = r2 (sin (y + 1), sin (x + 1)) +arrowAtPoint :: (Double, Double) -> SvgDiagram arrowAtPoint (x, y) = arrowAt' opts (p2 (x, y)) (sL *^ vf) # alignTL where vf = vectorField (x, y) diff --git a/reanimate.cabal b/reanimate.cabal index 49d3d33..5d225b7 100644 --- a/reanimate.cabal +++ b/reanimate.cabal @@ -1,8 +1,9 @@ +cabal-version: 1.18 -- Initial reani.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: reanimate -version: 0.1.6.0 +version: 0.1.7.0 -- synopsis: -- description: license: PublicDomain @@ -13,7 +14,8 @@ synopsis: Animation library based on SVGs. homepage: https://github.com/Lemmih/reanimate build-type: Simple extra-source-files: ChangeLog.md -cabal-version: >=1.10 +extra-doc-files: docs/gifs/*.gif + description: Animation library based on SVGs. Can import (and manipulate) SVGs from @@ -23,8 +25,8 @@ description: data-files: viewer/build/*.js viewer/build/*.html - viewer/build/static/js/2.772a56e7.chunk.js - viewer/build/static/js/main.c36ecb4a.chunk.js + 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/CIExyz.csv @@ -39,13 +41,18 @@ library hs-source-dirs: src default-language: Haskell2010 default-extensions: PackageImports - exposed-modules: Reanimate.Monad + exposed-modules: Reanimate + Reanimate.Animation Reanimate.Signal Reanimate.Render Reanimate.Examples Reanimate.Combinators Reanimate.LaTeX Reanimate.Svg + Reanimate.Svg.Unuse + Reanimate.Svg.Constructors + Reanimate.Svg.BoundingBox + Reanimate.Svg.LineCommand Reanimate.Diagrams Reanimate.Transform Reanimate.Driver @@ -60,6 +67,9 @@ library Reanimate.Effect Reanimate.Builtin.TernaryPlot Reanimate.Constants + Reanimate.Chiphunk + Reanimate.PolyShape + Reanimate.Builtin.Documentation other-modules: Reanimate.Cache Reanimate.Driver.Check Reanimate.Driver.CLI @@ -68,13 +78,13 @@ library Paths_reanimate build-depends: base >=4.10 && <4.13, time, text, filepath, process, directory, - containers, reanimate-svg >= 0.9.1.1, xml, bytestring, lens, linear, mtl, matrix, + 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, matrices, cubicbezier, palette, websockets, + svg-builder, cubicbezier, palette, websockets, hashable, fsnotify, open-browser, random-shuffle, base64-bytestring, vector, colour, cassava, ansi-wl-pprint, here, temporary, - optparse-applicative + optparse-applicative, chiphunk ghc-options: -Wall test-suite spec diff --git a/src/Reanimate.hs b/src/Reanimate.hs new file mode 100644 index 0000000..2b52d05 --- /dev/null +++ b/src/Reanimate.hs @@ -0,0 +1,106 @@ +{-| +Module : Reanimate +Description : SVG-base animation library. +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +Reanimate is an animation library based on SVGs. It is designed to act like glue +between external components such as 'latex', 'ffmpeg', 'gnuplot', 'diagrams', +and 'povray'. + +-} +module Reanimate + ( -- * Driver + -- + -- | Reanimate features a web-based viewer which is opened by default if + -- no other parameters are given. Key features: + -- + -- * This viewer listens for changes to the source file and recompiles the + -- code automatically as needed. + -- * Animations are rendered with increasing fidelity until the frame + -- rate eaches 60 fps. + -- * Key commands for pausing, frame stepping, forward/rewind. + reanimate, + -- * Animations + SVG, + Animation(..), + mkAnimation, + animate, + duration, + -- ** Composition + seqA, + parA, + parLoopA, + parDropA, + pause, + andThen, + mapA, + pauseAtEnd, + pauseAtBeginning, + pauseAround, + adjustDuration, + setDuration, + reverseA, + playThenReverseA, + repeatA, + freezeAtPercentage, + signalA, + -- ** Signals + Signal, + constantS, + fromToS, + reverseS, + curveS, + bellS, + oscillateS, + fromListS, + -- * SVG + module Reanimate.Svg.Constructors, + module Reanimate.Svg.LineCommand, + module Reanimate.Svg.BoundingBox, + module Reanimate.Svg, + -- ** Raster data + embedImage, + embedDynamicImage, + embedPng, + raster, + -- ** External SVG providers + latex, + latexAlign, + xelatex, + povray, + -- * Colormaps + turbo, + viridis, + magma, + inferno, + plasma, + sinebow, + parula, + cividis, + jet, + hsv, + hsvMatlab, + greyscale, + -- * Constants + screenWidth, + screenHeight, + defaultDPI, + defaultStrokeWidth + ) where + +import Reanimate.Animation +import Reanimate.ColorMap +import Reanimate.Constants +import Reanimate.Driver +import Reanimate.LaTeX +import Reanimate.Povray +import Reanimate.Raster +import Reanimate.Signal +import Reanimate.Svg +import Reanimate.Svg.BoundingBox +import Reanimate.Svg.Constructors +import Reanimate.Svg.LineCommand diff --git a/src/Reanimate/Animation.hs b/src/Reanimate/Animation.hs new file mode 100644 index 0000000..89f914f --- /dev/null +++ b/src/Reanimate/Animation.hs @@ -0,0 +1,266 @@ +module Reanimate.Animation where + +import Control.Arrow () +import Data.Fixed (mod') +import qualified Data.Map as M +import Graphics.SvgTree (Alignment (..), Document (..), + Number (..), + PreserveAspectRatio (..), + Tree (..), xmlOfTree) +import Graphics.SvgTree.Printer +import Reanimate.Constants +import Reanimate.Signal +import Reanimate.Svg.Constructors +import Text.XML.Light.Output + +-- | Duration of an animation or effect. Usually measured in seconds. +type Duration = Double +-- | Time signal. Goes from 0 to 1, inclusive. +type Time = Double + +type SVG = Tree + +-- | Animations are SVGs over a finite time. +data Animation = Animation Duration (Time -> SVG) + +mkAnimation :: Duration -> (Time -> SVG) -> Animation +mkAnimation = Animation + +-- | Construct animation with a duration of @1@. +animate :: (Time -> SVG) -> Animation +animate = Animation 1 + +-- | Query the duration of an animation. +duration :: Animation -> Duration +duration (Animation d _) = d + +-- | Play animations in sequence. The @lhs@ animation is removed after it has +-- completed. New animation duration is '@duration lhs + duration rhs@'. +-- +-- Example: +-- +-- > drawBox `seqA` drawCircle +-- +-- <> +seqA :: Animation -> Animation -> Animation +seqA (Animation d1 f1) (Animation d2 f2) = + Animation totalD $ \t -> + if t < d1/totalD + then f1 (t * totalD/d1) + else f2 ((t-d1/totalD) * totalD/d2) + where + totalD = d1+d2 + +-- | Play two animation concurrently. Shortest animation freezes on last frame. +-- New animation duration is '@max (duration lhs) (duration rhs)@'. +-- +-- Example: +-- +-- > drawBox `parA` adjustDuration (*2) drawCircle +-- +-- <> +parA :: Animation -> Animation -> Animation +parA (Animation d1 f1) (Animation d2 f2) = + Animation (max d1 d2) $ \t -> + let t1 = t * totalD/d1 + t2 = t * totalD/d2 in + mkGroup + [ f1 (min 1 t1) + , f2 (min 1 t2) ] + where + totalD = max d1 d2 + +-- | Play two animation concurrently. Shortest animation loops. +-- New animation duration is '@max (duration lhs) (duration rhs)@'. +-- +-- Example: +-- +-- > drawBox `parLoopA` adjustDuration (*2) drawCircle +-- +-- <> +parLoopA :: Animation -> Animation -> Animation +parLoopA (Animation d1 f1) (Animation d2 f2) = + Animation totalD $ \t -> + let t1 = t * totalD/d1 + t2 = t * totalD/d2 in + mkGroup + [ f1 (t1 `mod'` 1) + , f2 (t2 `mod'` 1) ] + where + totalD = max d1 d2 + +-- | Play two animation concurrently. Animations disappear after playing once. +-- New animation duration is '@max (duration lhs) (duration rhs)@'. +-- +-- Example: +-- +-- > drawBox `parLoopA` adjustDuration (*2) drawCircle +-- +-- <> +parDropA :: Animation -> Animation -> Animation +parDropA (Animation d1 f1) (Animation d2 f2) = + Animation totalD $ \t -> + let t1 = t * totalD/d1 + t2 = t * totalD/d2 in + mkGroup + [ if t1>1 then None else f1 t1 + , if t2>1 then None else f2 t2 ] + where + totalD = max d1 d2 + +-- | Empty animation (no SVG output) with a fixed duration. +-- +-- Example: +-- +-- > pause 1 `seqA` drawProgress +-- +-- <> +pause :: Duration -> Animation +pause d = Animation d (const None) + +-- | Play left animation and freeze on the last frame, then play the right +-- animation. New duration is '@duration lhs + duration rhs@'. +-- +-- Example: +-- +-- > drawBox `andThen` drawCircle +-- +-- <> +andThen :: Animation -> Animation -> Animation +andThen a b = a `parA` (pause (duration a) `seqA` b) + +frameAt :: Double -> Animation -> Tree +frameAt t (Animation d f) = f t' + where + t' = min 1 (max 0 (t/d)) + +renderTree :: Tree -> String +renderTree t = maybe "" ppElement $ xmlOfTree t + +renderSvg :: Maybe Number -> Maybe Number -> Tree -> String +renderSvg w h t = ppDocument doc +-- renderSvg w h t = ppFastElement (xmlOfDocument doc) + where + width = 16 + height = 9 + doc = Document + { _viewBox = Just (-width/2, -height/2, width, height) + , _width = w + , _height = h + , _elements = [withStrokeWidth defaultStrokeWidth $ scaleXY 1 (-1) t] + , _definitions = M.empty + , _description = "" + , _documentLocation = "" + , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing + } + +-- | Map over the SVG produced by an animation at every frame. +-- +-- Example: +-- +-- > mapA (scale 0.5) drawCircle +-- +-- <> + +mapA :: (Tree -> Tree) -> Animation -> Animation +mapA fn (Animation d f) = Animation d (fn . f) + +-- | Freeze the last frame for @t@ seconds at the end of the animation. +-- +-- Example: +-- +-- > pauseAtEnd 1 drawProgress +-- +-- <> +pauseAtEnd :: Duration -> Animation -> Animation +pauseAtEnd t a = a `andThen` pause t + +-- | Freeze the first frame for @t@ seconds at the beginning of the animation. +-- +-- Example: +-- +-- > pauseAtBeginning 1 drawProgress +-- +-- <> +pauseAtBeginning :: Duration -> Animation -> Animation +pauseAtBeginning t a = + Animation t (freezeFrame 0 a) `seqA` a + +-- | Freeze the first and the last frame of the animation for a specified duration. +-- +-- Example: +-- +-- > pauseAround 1 1 drawProgress +-- +-- <> +pauseAround :: Duration -> Duration -> Animation -> Animation +pauseAround start end = pauseAtEnd end . pauseAtBeginning start + +-- XXX: Rename to 'setDurationFreeze'. Add 'setDurationDrop' and +-- 'setDurationLoop'. +pauseUntil :: Duration -> Animation -> Animation +pauseUntil d a = pauseAtEnd (d-duration a) a + +-- Freeze frame at time @t@. +freezeFrame :: Double -> Animation -> (Time -> SVG) +freezeFrame t (Animation d f) = const $ f (t/d) + +-- | Change the duration of an animation. Animates are stretched or squished +-- (rather than truncated) to fit the new duration. +adjustDuration :: (Duration -> Duration) -> Animation -> Animation +adjustDuration fn (Animation d gen) = + Animation (fn d) gen + +-- | Set the duration of an animation by adjusting its playback rate. The +-- animation is still played from start to finish without being cropped. +setDuration :: Duration -> Animation -> Animation +setDuration newD = adjustDuration (const newD) + +-- | Play an animation in reverse. Duration remains unchanged. Shorthand for: +-- @'signalA' 'reverseS'@. +-- +-- Example: +-- +-- > reverseA drawCircle +-- +-- <> +reverseA :: Animation -> Animation +reverseA = signalA reverseS + +-- | Play animation before playing it again in reverse. Duration is twice +-- the duration of the input. +-- +-- Example: +-- +-- > playThenReverseA drawCircle +-- +-- <> +playThenReverseA :: Animation -> Animation +playThenReverseA a = a `seqA` reverseA a + +-- | Loop animation @n@ number of times. This number may be fractional and it +-- may be less than 1. It must be greater than or equal to 0, though. +-- New duration is @n*duration input@. +-- +-- Example: +-- +-- > repeatA 1.5 drawCircle +-- +-- <> +repeatA :: Double -> Animation -> Animation +repeatA n (Animation d f) = Animation (d*n) $ \t -> + f ((t*n) `mod'` 1) + +freezeAtPercentage :: Time -> Animation -> Animation +freezeAtPercentage frac (Animation d genFrame) = + Animation d $ const $ genFrame frac + +-- | Modify the time component of an animation. Animation duration is unchanged. +-- +-- Example: +-- +-- > signalA (fromToS 0.25 0.75) drawCircle +-- +-- <> +signalA :: Signal -> Animation -> Animation +signalA fn (Animation d gen) = Animation d $ gen . fn diff --git a/src/Reanimate/Builtin/Documentation.hs b/src/Reanimate/Builtin/Documentation.hs new file mode 100644 index 0000000..b5c5b7a --- /dev/null +++ b/src/Reanimate/Builtin/Documentation.hs @@ -0,0 +1,35 @@ +module Reanimate.Builtin.Documentation where + +import Reanimate.Animation +import Reanimate.Svg +import Reanimate.Constants + +docEnv :: Animation -> Animation +docEnv = mapA $ \svg -> mkGroup + [ mkBackground "white" + , withFillOpacity 0 $ + withStrokeWidth 0.1 $ + withStrokeColor "black" (mkGroup [svg]) ] + +-- | <> +drawBox :: Animation +drawBox = mkAnimation 2 $ \t -> + partialSvg t $ pathify $ + mkRect (screenWidth/2) (screenHeight/2) + +-- | <> +drawCircle :: Animation +drawCircle = mkAnimation 2 $ \t -> + partialSvg t $ pathify $ + mkCircle (screenHeight/3) + +-- | <> +drawProgress :: Animation +drawProgress = mkAnimation 2 $ \t -> + mkGroup + [ mkLine (-screenWidth/2*widthP,0) + (screenWidth/2*widthP,0) + , translate (-screenWidth/2*widthP + screenWidth*widthP*t) 0 $ + withFillOpacity 1 $ mkCircle 0.5 ] + where + widthP = 0.8 diff --git a/src/Reanimate/Cache.hs b/src/Reanimate/Cache.hs index f458882..d3cefbd 100644 --- a/src/Reanimate/Cache.hs +++ b/src/Reanimate/Cache.hs @@ -14,7 +14,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Graphics.SvgTree (Tree (..), unparse) -import Reanimate.Monad (renderTree) +import Reanimate.Animation (renderTree) import System.Directory import System.FilePath import System.IO diff --git a/src/Reanimate/Chiphunk.hs b/src/Reanimate/Chiphunk.hs new file mode 100644 index 0000000..3ff4ef9 --- /dev/null +++ b/src/Reanimate/Chiphunk.hs @@ -0,0 +1,96 @@ +module Reanimate.Chiphunk + ( simulate + , BodyStore + , newBodyStore + , addToBodyStore + , spaceFreeRecursive + , polyShapesToBody + , polygonsToBody + ) where + +import Chiphunk.Low +import Control.Monad +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as V +import Foreign.Ptr +import Graphics.SvgTree (Tree) +import Linear.V2 (V2(..)) +import Reanimate.Animation +import Reanimate.PolyShape +import Reanimate.Svg.Constructors + +type BodyStore = IORef (Map WordPtr Tree) + +newBodyStore :: IO BodyStore +newBodyStore = newIORef Map.empty + +addToBodyStore :: BodyStore -> Body -> Tree -> IO () +addToBodyStore store body svg = do + key <- atomicModifyIORef' store $ \m -> + case Map.maxViewWithKey m of + Nothing -> (Map.singleton 1 svg, 1) + Just ((maxKey,_),_) -> + (Map.insert (maxKey+1) svg m, maxKey+1) + bodyUserData body $= wordPtrToPtr key + +renderBodyStore :: Space -> BodyStore -> IO Tree +renderBodyStore space store = do + m <- readIORef store + lst <- newIORef [] + spaceEachBody space (\body _dat -> do + key <- get (bodyUserData body) + case Map.lookup (ptrToWordPtr key) m of + Nothing -> putStrLn "Body doesn't have an associated SVG" + Just svg -> do + Vect posX posY <- get $ bodyPosition body + angle <- get $ bodyAngle body + let bodySvg = + translate posX posY $ + rotate (angle/pi*180) $ + svg + modifyIORef lst $ (bodySvg:) + ) nullPtr + result <- readIORef lst + return $ mkGroup result + + +simulate :: Space -> BodyStore -> Double -> Int -> Double -> IO Animation +simulate space store fps stepsPerFrame dur = do + let timeStep = 1/(fps*fromIntegral stepsPerFrame) + frames = round (dur * fps) + v <- V.new frames + forM_ [0..frames-1] $ \nth -> do + svg <- renderBodyStore space store + V.write v nth svg + replicateM_ stepsPerFrame $ spaceStep space timeStep + frozen <- V.unsafeFreeze v + return $ mkAnimation dur $ \t -> + let key = round (t * fromIntegral (frames-1)) + in frozen V.! key + +polyShapesToBody :: Space -> [PolyShape] -> IO Body +polyShapesToBody space poly = do + polygonsToBody space (map (map toVect) $ plDecompose poly) + where + toVect (V2 x y) = Vect x y + +polygonsToBody :: Space -> [[Vect]] -> IO Body +polygonsToBody space polygons = do + plBody <- bodyNew 0 0 + spaceAddBody space plBody + + forM_ polygons $ \vects -> do + polyShape <- polyShapeNewRaw plBody vects 0.00 + shapeDensity polyShape $= 1 + spaceAddShape space polyShape + shapeFriction polyShape $= 0.7 + return plBody + +spaceFreeRecursive :: Space -> IO () +spaceFreeRecursive space = do + spaceEachBody space (\body _ -> bodyFree body) nullPtr + spaceEachShape space (\shape _ -> shapeFree shape) nullPtr + spaceFree space diff --git a/src/Reanimate/ColorMap.hs b/src/Reanimate/ColorMap.hs index 8a375da..073c2bf 100644 --- a/src/Reanimate/ColorMap.hs +++ b/src/Reanimate/ColorMap.hs @@ -26,6 +26,8 @@ import Data.Colour.RGBSpace -- | Given a number t in the range [0,1], returns the corresponding color from -- the “turbo” color scheme by Anton Mikhailov. +-- +-- <> turbo :: Double -> PixelRGB8 turbo t = PixelRGB8 red green blue where @@ -38,6 +40,8 @@ turbo t = PixelRGB8 red green blue -- | Given a number t in the range [0,1], returns the corresponding color from -- the “viridis” perceptually-uniform color scheme designed by van der Walt, -- Smith and Firing for matplotlib, represented as an RGB string. +-- +-- <> viridis :: Double -> PixelRGB8 viridis = ramp (colors "44015444025645045745055946075a46085c460a5d460b5e470d60470e614710634711644713\ @@ -65,6 +69,8 @@ viridis = ramp (colors -- | Given a number t in the range [0,1], returns the corresponding color from -- the “magma” perceptually-uniform color scheme designed by van der Walt and -- Smith for matplotlib, represented as an RGB string. +-- +-- <> magma :: Double -> PixelRGB8 magma = ramp (colors "00000401000501010601010802010902020b02020d03030f0303120404140504160605180605\ @@ -92,6 +98,8 @@ magma = ramp (colors -- | Given a number t in the range [0,1], returns the corresponding color from -- the “inferno” perceptually-uniform color scheme designed by van der Walt -- and Smith for matplotlib, represented as an RGB string. +-- +-- <> inferno :: Double -> PixelRGB8 inferno = ramp (colors "00000401000501010601010802010a02020c02020e0302100403120403140504170604190705\ @@ -119,6 +127,8 @@ inferno = ramp (colors -- | Given a number t in the range [0,1], returns the corresponding color from -- the “plasma” perceptually-uniform color scheme designed by van der Walt and -- Smith for matplotlib, represented as an RGB string. +-- +-- <> plasma :: Double -> PixelRGB8 plasma = ramp (colors "0d088710078813078916078a19068c1b068d1d068e20068f2206902406912605912805922a05\ @@ -145,6 +155,8 @@ plasma = ramp (colors -- | Given a number t in the range [0,1], returns the corresponding color from -- the “sinebow” color scheme by Jim Bumgardner and Charlie Loyd. +-- +-- <> sinebow :: Double -> PixelRGB8 sinebow t = PixelRGB8 r g b where @@ -158,6 +170,8 @@ sinebow t = PixelRGB8 r g b -- | Given a number t in the range [0,1], returns the corresponding color from -- the “cividis” color vision deficiency-optimized color scheme designed by -- Nuñez, Anderton, and Renslow, represented as an RGB string. +-- +-- <> cividis :: Double -> PixelRGB8 cividis t = PixelRGB8 red green blue where @@ -168,6 +182,8 @@ cividis t = PixelRGB8 red green blue trunc = fromIntegral . min 255 . max 0 -- | Jet colormap. Used to be the default in matlab. Obsolete. +-- +-- <> jet :: Double -> PixelRGB8 jet t = PixelRGB8 red green blue where @@ -178,22 +194,32 @@ jet t = PixelRGB8 red green blue trunc = round . min 255 . max 0 . (*) 255 -- | hsv colormap. Goes from 0 degrees to 360 degrees. +-- +-- <> hsv :: Double -> PixelRGB8 hsv t = PixelRGB8 (round $ r*255) (round $ g*255) (round $ b*255) where RGB r g b = HSV.hsv (t * 360) 1 1 -- | Matlab hsv colormap. Goes from 0 degrees to 330 degrees. +-- +-- <> hsvMatlab :: Double -> PixelRGB8 hsvMatlab t = PixelRGB8 (round $ r*255) (round $ g*255) (round $ b*255) where RGB r g b = HSV.hsv (t * 330) 1 1 +-- | Greyscale colormap. +-- +-- <> greyscale :: Double -> PixelRGB8 greyscale t = PixelRGB8 v v v where v = round $ t * 255 +-- | Parula is the default colormap for matlab. +-- +-- <> parula :: Double -> PixelRGB8 parula = ramp vec where diff --git a/src/Reanimate/ColorSpace.hs b/src/Reanimate/ColorSpace.hs index 7d91bbf..bab96ba 100644 --- a/src/Reanimate/ColorSpace.hs +++ b/src/Reanimate/ColorSpace.hs @@ -12,7 +12,7 @@ import Paths_reanimate import System.IO.Unsafe import Graphics.SvgTree (Tree) -import Reanimate.Svg +import Reanimate.Svg.Constructors type Nanometer = Integer diff --git a/src/Reanimate/Constants.hs b/src/Reanimate/Constants.hs index 8ee78b0..5289b66 100644 --- a/src/Reanimate/Constants.hs +++ b/src/Reanimate/Constants.hs @@ -1,6 +1,19 @@ -module Reanimate.Constants where +module Reanimate.Constants + ( screenWidth + , screenHeight + , defaultDPI + , defaultStrokeWidth + ) where + +import Graphics.SvgTree screenWidth, screenHeight :: Num a => a screenWidth = 16 screenHeight = 9 + +defaultDPI :: Dpi +defaultDPI = 96 + +defaultStrokeWidth :: Double +defaultStrokeWidth = 0.05 diff --git a/src/Reanimate/Diagrams.hs b/src/Reanimate/Diagrams.hs index 666bb6b..f4d59a0 100644 --- a/src/Reanimate/Diagrams.hs +++ b/src/Reanimate/Diagrams.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# 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 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 (unbox) +import qualified Graphics.Svg.Core as Svg +import Graphics.SvgTree (Tree (..), parseSvgFile) +import Reanimate.Svg.Unuse (unbox) renderDiagram :: SvgDiagram -> Tree renderDiagram d = diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs index fb315ea..ae3bc1d 100644 --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -3,15 +3,15 @@ module Reanimate.Driver ( reanimate ) where import Control.Monad 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.Monad (Animation) import Reanimate.Render (FPS, Format (..), Height, Width, render, renderSnippets, renderSvgs) -import System.FilePath import System.Directory +import System.FilePath import Text.Printf presetFormat :: Preset -> Format @@ -53,12 +53,49 @@ formatHeight RenderMp4 = 1440 formatHeight RenderGif = 180 formatHeight RenderWebm = 1440 +{-| +Main entry-point for accessing an animation. Creates a program that takes the +following command-line arguments: + +> Usage: PROG [COMMAND] +> This program contains an animation which can either be viewed in a web-browser +> or rendered to disk. +> +> Available options: +> -h,--help Show this help text +> +> Available commands: +> check Run a system's diagnostic and report any missing +> external dependencies. +> view Play animation in browser window. +> render Render animation to file. + +Neither the 'check' nor the 'view' command take any additional arguments. +Rendering animation can be controlled with these arguments: + +> Usage: PROG render [-o|--target FILE] [--fps FPS] [-w|--width PIXELS] +> [-h|--height PIXELS] [--compile] [--format FMT] +> [--preset TYPE] +> Render animation to file. +> +> Available options: +> -o,--target FILE Write output to FILE +> --fps FPS Set frames per second. +> -w,--width PIXELS Set video width. +> -h,--height PIXELS Set video height. +> --compile Compile source code before rendering. +> --format FMT Video format: mp4, gif, webm +> --preset TYPE Parameter presets: youtube, gif, quick +> -h,--help Show this help text +-} reanimate :: Animation -> IO () reanimate animation = do Options{..} <- getDriverOptions case optsCommand of Raw -> renderSvgs animation - Test -> renderSnippets animation + Test -> do + -- hSetBinaryMode stdout True + renderSnippets animation Check -> checkEnvironment View -> serve Render{..} -> do diff --git a/src/Reanimate/Driver/CLI.hs b/src/Reanimate/Driver/CLI.hs index 4a06628..d9c404a 100644 --- a/src/Reanimate/Driver/CLI.hs +++ b/src/Reanimate/Driver/CLI.hs @@ -96,19 +96,19 @@ testCommand = info (parse <**> helper) checkCommand :: ParserInfo Command checkCommand = info (parse) - (progDesc "check") + (progDesc "Run a system's diagnostic and report any missing external dependencies.") where parse = pure Check viewCommand :: ParserInfo Command viewCommand = info (parse) - (progDesc "view") + (progDesc "Play animation in browser window.") where parse = pure View renderCommand :: ParserInfo Command renderCommand = info (parse) - (progDesc "render") + (progDesc "Render animation to file.") where -- fromPreset :: (Maybe Preset -> (Command -> Command)) -- fromPreset Nothing = id @@ -146,8 +146,8 @@ renderCommand = info (parse) opts :: ParserInfo Options opts = info (options <**> helper ) ( fullDesc - <> progDesc "PROG DESC" - <> header "HEADER" + <> progDesc "This program contains an animation which can either be viewed \ + \in a web-browser or rendered to disk." ) getDriverOptions :: IO Options diff --git a/src/Reanimate/Driver/Check.hs b/src/Reanimate/Driver/Check.hs index 2f9c087..59a5f98 100644 --- a/src/Reanimate/Driver/Check.hs +++ b/src/Reanimate/Driver/Check.hs @@ -26,6 +26,8 @@ checkEnvironment = do runCheck "Has XeLaTeX" hasXeLaTeX runCheck "Has dvisvgm" hasDvisvgm runCheck "Has povray" hasPovray + runCheck ("Has LaTeX package '"++ "babel" ++ "'") $ hasTeXPackage "latex" $ + "[english]{babel}" forM_ latexPackages $ \pkg -> runCheck ("Has LaTeX package '"++ pkg ++ "'") $ hasTeXPackage "latex" $ "{"++pkg++"}" @@ -34,7 +36,7 @@ checkEnvironment = do "{"++pkg++"}" where latexPackages = - ["babel" + ["preview" ,"amsmath" ,"amssymb" ,"dsfont" @@ -78,10 +80,11 @@ hasFFmpeg = do mbVersion <- ffmpegVersion return $ case mbVersion of Nothing -> Left "no" - Just vs | vs < minVersion -> Left "too old" + Just vs | vs < minVersion -> Left $ "too old: " ++ showVersion vs ++ " < " ++ showVersion minVersion | otherwise -> Right (showVersion vs) where minVersion = Version [4,1,3] [] + ffmpegVersion :: IO (Maybe Version) ffmpegVersion = do mbPath <- findExecutable "ffmpeg" @@ -90,15 +93,16 @@ ffmpegVersion = do Just path -> do ret <- runCmd_ path ["-version"] case ret of - Left{} -> return Nothing + Left{} -> return $ Just noVersion Right out -> case map (take 3 . words) $ take 1 $ lines out of [["ffmpeg", "version", vs]] -> - return $ parseVS vs - _ -> return Nothing + return $ Just $ fromMaybe noVersion $ parseVS vs + _ -> return $ Just noVersion where - parseVS vs = listToMaybe - [ v | (v, "") <- readP_to_S parseVersion vs ] + noVersion = Version [] [] + parseVS vs = listToMaybe $ reverse + [ v | (v, _) <- readP_to_S parseVersion vs ] hasTeXPackage :: FilePath -> String -> IO (Either String String) diff --git a/src/Reanimate/Effect.hs b/src/Reanimate/Effect.hs index 0aa9c93..4144f58 100644 --- a/src/Reanimate/Effect.hs +++ b/src/Reanimate/Effect.hs @@ -1,12 +1,9 @@ module Reanimate.Effect where import Graphics.SvgTree (Tree) -import Reanimate.Monad +import Reanimate.Animation import Reanimate.Svg -askTime :: Frame Time -askTime = Frame $ \_dur t -> return t - type Effect = Double -> Double -> Tree -> Tree overBeginning :: Double -> Effect -> Effect @@ -30,9 +27,7 @@ delayE :: Double -> Effect -> Effect delayE delayT fn = \d t -> overEnding (d-delayT) fn d t applyE :: Effect -> Animation -> Animation -applyE fn (Animation d genFrame) = Animation d $ do - t <- askTime - mapF (fn d t) genFrame +applyE fn (Animation d genFrame) = Animation d $ \t -> fn d (d*t) $ genFrame t constE :: (Tree -> Tree) -> Effect constE fn _d _t = fn diff --git a/src/Reanimate/Examples.hs b/src/Reanimate/Examples.hs index c4f1415..01dc77d 100644 --- a/src/Reanimate/Examples.hs +++ b/src/Reanimate/Examples.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} module Reanimate.Examples where +{- import Control.Lens () import qualified Data.Map as M import Graphics.SvgTree as S hiding (circle, width) @@ -22,6 +23,7 @@ import Reanimate.Svg import Diagrams.Prelude (deg, turn, withEnvelope, (@@)) import qualified Diagrams.Prelude as D import qualified Diagrams.TwoD.Path.LSystem as D +-} {- sinewave :: Ani () @@ -478,7 +480,7 @@ latex_color = proc () -> do svg = scale 10 $ center $ latex "\\LaTeX" -} - +{- morph_wave :: Animation morph_wave = autoReverse $ mkAnimation 2.5 $ do morph <- getSignal signalLinear @@ -558,3 +560,4 @@ wavyTree = mkAnimation 1 $ do tree s = D.lSystem gens (s/16 @@ turn) (D.symbols "F") rules rules = M.fromList [D.rule 'F' "FF-[->F+F+>F]+[+>F->F->F]"] +-} diff --git a/src/Reanimate/LaTeX.hs b/src/Reanimate/LaTeX.hs index b4eab3d..71dc30b 100644 --- a/src/Reanimate/LaTeX.hs +++ b/src/Reanimate/LaTeX.hs @@ -15,14 +15,42 @@ import Reanimate.Svg import System.FilePath (replaceExtension, takeFileName, ()) import System.IO.Unsafe (unsafePerformIO) +-- | Invoke latex and import the result as an SVG object. SVG objects are +-- cached to improve performance. +-- +-- Example: +-- +-- > withStrokeWidth 0 . withFillOpacity 1 . scale 3 . center $ +-- > latex "$e^{i\\pi}+1=0$" +-- +-- <> latex :: T.Text -> Tree latex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) latexToSVG) ("% plain latex\n" <> 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. +-- +-- Example: +-- +-- > withStrokeWidth 0 . withFillOpacity 1 . scale 4 . center $ +-- > xelatex "中文" +-- +-- <> xelatex :: Text -> Tree xelatex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) xelatexToSVG) ("% xelatex\n" <> 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*' +-- context. +-- +-- Example: +-- +-- > withStrokeWidth 0 . withFillOpacity 1 . scale 3 . center $ +-- > latexAlign "R = \\frac{{\\Delta x}}{{kA}}" +-- +-- <> latexAlign :: Text -> Tree latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"] @@ -40,7 +68,7 @@ latexToSVG tex = handle (\(_::SomeException) -> return (failedSvg tex)) $ do T.appendFile tex_file tex appendFile tex_file tex_epilogue runCmd latexBin ["-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file] - runCmd dvisvgm [ dvi_file + runCmd dvisvgm [ dvi_file, "--precision=5" , "--exact" -- better bboxes. -- , "--bbox=1,1" -- increase bbox size. , "--no-fonts" -- use glyphs instead of fonts. diff --git a/src/Reanimate/Monad.hs b/src/Reanimate/Monad.hs deleted file mode 100644 index fb884d3..0000000 --- a/src/Reanimate/Monad.hs +++ /dev/null @@ -1,158 +0,0 @@ -module Reanimate.Monad where - -import Control.Arrow () -import Control.Monad.State -import Data.Fixed (mod') -import qualified Data.Map as M -import Graphics.SvgTree (Document (..), Number (..), - Tree (..), - xmlOfTree) -import Graphics.SvgTree.Printer -import Reanimate.Signal -import Reanimate.Svg -import Text.XML.Light.Output - -type Duration = Double -type Time = Double - -data Frame a = Frame {unFrame :: Duration -> Time -> State ([Tree] -> [Tree]) a} - -instance Functor Frame where - fmap fn f = Frame $ \d t -> fmap fn (unFrame f d t) - -instance Applicative Frame where - pure a = Frame $ \_ _ -> pure a - fn <*> fa = Frame $ \d t -> do - f <- unFrame fn d t - a <- unFrame fa d t - pure (f a) - -instance Monad Frame where - return a = Frame $ \_ _ -> pure a - f >>= g = Frame $ \d t -> do - a <- unFrame f d t - unFrame (g a) d t - --- End behavior: --- Freeze at last frame --- Loop --- Disappear -data Animation = Animation Duration (Frame ()) - -mkAnimation :: Duration -> Frame () -> Animation -mkAnimation = Animation - -duration :: Animation -> Duration -duration (Animation d _) = d - -emit :: Tree -> Frame () -emit svg = Frame $ \_ _ -> modify (.(svg:)) - -before :: Animation -> Animation -> Animation -before (Animation d1 (Frame f1)) (Animation d2 (Frame f2)) = - Animation (d1+d2) (Frame $ \_ t -> if t < d1 then f1 d1 t else f2 d2 (t-d1)) - --- Play two animation concurrently. Shortest animation freezes on last frame. -sim :: Animation -> Animation -> Animation -sim (Animation d1 (Frame f1)) (Animation d2 (Frame f2)) = - Animation (max d1 d2) $ Frame $ \_ t -> do - f1 d1 (min d1 t) - f2 d2 (min d2 t) - --- Play two animation concurrently. Shortest animation loops. -simLoop :: Animation -> Animation -> Animation -simLoop (Animation d1 (Frame f1)) (Animation d2 (Frame f2)) = - Animation (max d1 d2) $ Frame $ \_ t -> do - f1 d1 (t `mod'` d1) - f2 d2 (t `mod'` d2) - --- Play two animation concurrently. Animations disappear after playing once. -simDrop :: Animation -> Animation -> Animation -simDrop (Animation d1 (Frame f1)) (Animation d2 (Frame f2)) = - Animation (max d1 d2) $ Frame $ \_ t -> do - when (t < d1) (f1 d1 t) - when (t < d2) (f2 d2 t) - -pause :: Double -> Animation -pause d = Animation d (pure ()) - -andThen :: Animation -> Animation -> Animation -andThen a b = a `sim` (pause (duration a) `before` b) - -getSignal :: Signal -> Frame Double -getSignal s = Frame $ \d t -> pure $ s (t/d) - -frameAt :: Double -> Animation -> Tree -frameAt t (Animation d (Frame f)) = mkGroup $ execState (f d (min d t)) id [] - -renderTree :: Tree -> String -renderTree t = maybe "" ppElement $ xmlOfTree t - -renderSvg :: Maybe Number -> Maybe Number -> Tree -> String -renderSvg w h t = ppDocument doc --- renderSvg w h t = ppFastElement (xmlOfDocument doc) - where - width = 16 - height = 9 - doc = Document - { _viewBox = Just (-width/2, -height/2, width, height) - , _width = w - , _height = h - , _elements = [withStrokeWidth (Num 0.05) $ scaleXY 1 (-1) t] - , _definitions = M.empty - , _description = "" - , _documentLocation = "" - } - -mapA :: (Tree -> Tree) -> Animation -> Animation -mapA fn (Animation d f) = Animation d (mapF fn f) - -mapF :: (Tree -> Tree) -> Frame a -> Frame a -mapF fn frame = Frame $ \d t -> do - case runState (unFrame frame d t) id of - (a, children) -> modify (. (fn (mkGroup (children [])):)) >> pure a - -pauseAtEnd :: Double -> Animation -> Animation -pauseAtEnd p a = a `andThen` pause p - -pauseUntil :: Double -> Animation -> Animation -pauseUntil p a = a `andThen` pause (p - duration a) - -pauseAtBeginning :: Double -> Animation -> Animation -pauseAtBeginning d1 a = - Animation d1 (freezeFrame 0 a) `before` a - -pauseAround :: Double -> Double -> Animation -> Animation -pauseAround start end = pauseAtEnd end . pauseAtBeginning start - -freezeFrame :: Double -> Animation -> Frame () -freezeFrame t (Animation d f) = Frame $ \_ _ -> unFrame f d t - -adjustSpeed :: Double -> Animation -> Animation -adjustSpeed factor (Animation d fn) = - Animation (d/factor) $ Frame $ \_dur t -> unFrame fn d (t*factor) - -setDuration :: Double -> Animation -> Animation -setDuration newD (Animation _ fn) = - Animation newD $ Frame $ \dur t -> unFrame fn dur t - -reverseAnimation :: Animation -> Animation -reverseAnimation (Animation d fn) = Animation d $ Frame $ \_dur t -> - unFrame fn d (d-t) - -autoReverse :: Animation -> Animation -autoReverse a = a `before` reverseAnimation a - -oscillate :: Frame a -> Frame a -oscillate f = Frame $ \d t -> do - if t < d/2 - then unFrame f d (t*2) - else unFrame f d (d*2-t*2) - -repeatAnimation :: Double -> Animation -> Animation -repeatAnimation n (Animation d f) = Animation (d*n) $ Frame $ \_ t -> - unFrame f d (t `mod'` d) - -freezeAtPercentage :: Double -> Animation -> Animation -freezeAtPercentage frac (Animation d genFrame) = - Animation d $ Frame $ \_ _ -> unFrame genFrame d (d*frac) diff --git a/src/Reanimate/PolyShape.hs b/src/Reanimate/PolyShape.hs new file mode 100644 index 0000000..967ad88 --- /dev/null +++ b/src/Reanimate/PolyShape.hs @@ -0,0 +1,318 @@ +module Reanimate.PolyShape + ( PolyShape(..) + , PolyShapeWithHoles(..) + , svgToPolyShapes -- :: Tree -> [PolyShape] + + , renderPolyShape -- :: PolyShape -> Tree + , renderPolyShapes -- :: [PolyShape] -> Tree + , renderPolyShapePoints -- :: PolyShape -> Tree + + , plPathCommands -- :: PolyShape -> [PathCommand] + , plLineCommands -- :: PolyShape -> [LineCommand] + + , plLength -- :: PolyShape -> Double + , plCurves -- :: PolyShape -> [CubicBezier Double] + , isInsideOf -- :: PolyShape -> PolyShape -> Bool + + , plFromPolygon -- :: [RPoint] -> PolyShape + , plPolygonify -- :: Double -> PolyShape -> [Point Double] + , plDecompose -- :: [PolyShape] -> [[RPoint]] + , unionPolyShapes -- :: [PolyShape] -> [PolyShape] + , unionPolyShapes' -- :: Double -> [PolyShape] -> [PolyShape] + , plDecompose' -- :: Double -> [PolyShape] -> [[RPoint]] + , decomposePolygon -- :: [Point Double] -> [[RPoint]] + , plGroupShapes -- :: [PolyShape] -> [PolyShapeWithHoles] + , mergePolyShapeHoles -- :: PolyShapeWithHoles -> PolyShape + , polyShapeTolerance + ) where + +import Chiphunk.Low +import Control.Lens ((&), (.~)) +import Data.List (nub, partition, sortBy) +import Data.Ord +import Debug.Trace +import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..), DPoint, + FillRule (..), PathJoin (..), Point (..), + arcLength, bezierIntersection, + closedPathCurves, closest, colinear, + curvesToClosed, evalBezier, splitBezier, + union, vectorDistance) +import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..), + defaultSvg, pathDefinition) +import Linear.V2 +import Reanimate.Constants +import Reanimate.Svg + +-- | Shape drawn by continuous line. May have overlap, may be convex. +newtype PolyShape = PolyShape { unPolyShape :: ClosedPath Double } + deriving (Show) + +data PolyShapeWithHoles = PolyShapeWithHoles + { polyShapeParent :: PolyShape + , polyShapeHoles :: [PolyShape] + } + + +renderPolyShapes :: [PolyShape] -> Tree +renderPolyShapes pls = + PathTree $ defaultSvg & pathDefinition .~ concatMap plPathCommands pls + +renderPolyShape :: PolyShape -> Tree +renderPolyShape pl = + PathTree $ defaultSvg & pathDefinition .~ plPathCommands pl + +renderPolyShapePoints :: PolyShape -> Tree +renderPolyShapePoints = mkGroup . map renderPoint . plCurves + where + renderPoint (CubicBezier (Point x y) _ _ _) = + translate x y $ mkCircle 0.02 + +plLength :: PolyShape -> Double +plLength = sum . map cubicLength . plCurves + where + cubicLength c = arcLength c 1 polyShapeTolerance + +-- 1/10th of a pixel if rendered at 2560x1440 +polyShapeTolerance :: Double +polyShapeTolerance = screenWidth/25600 + +plFromPolygon :: [RPoint] -> PolyShape +plFromPolygon = PolyShape . ClosedPath . map worker + where + worker (V2 x y) = (Point x y, JoinLine) + +-- | Deconstruct a polyshape into non-intersecting, convex polygons. +plDecompose :: [PolyShape] -> [[RPoint]] +plDecompose = plDecompose' 0.001 + +-- | Deconstruct a polyshape into non-intersecting, convex polygons. +plDecompose' :: Double -> [PolyShape] -> [[RPoint]] +plDecompose' tol = + concatMap decomposePolygon . + map (plPolygonify tol) . + map mergePolyShapeHoles . + plGroupShapes . + unionPolyShapes + +decomposePolygon :: [Point Double] -> [[RPoint]] +decomposePolygon poly = + map (map fromVect . adjust) $ convexDecomposition (map toVect poly) tol + where + tol = polyShapeTolerance + toVect (Point x y) = Vect x y + fromVect (Vect x y) = V2 x y + adjust [] = [] + adjust x = if head x == last x then adjust (init x) else x + +plPolygonify :: Double -> PolyShape -> [Point Double] +plPolygonify tol shape = + startPoint (head curves) : concatMap worker curves + where + curves = plCurves shape + worker c | endPoint c == startPoint c = + [] -- error $ "Bad bezier: " ++ show c + worker c = + if colinear c tol + then [endPoint c] + else + let (lhs,rhs) = splitBezier c 0.5 + in worker lhs ++ worker rhs + endPoint (CubicBezier _ _ _ d) = d + startPoint (CubicBezier a _ _ _) = a + + +plPathCommands :: PolyShape -> [PathCommand] +plPathCommands = lineToPath . plLineCommands + +plLineCommands :: PolyShape -> [LineCommand] +plLineCommands pl = + case curves of + [] -> [] + (CubicBezier start _ _ _:_) -> + LineMove (toRPoint start) : + zipWith worker (drop 1 dstList ++ [start]) joinList ++ + [LineEnd (toRPoint start)] + where + ClosedPath closedPath = unPolyShape pl + (dstList, joinList) = unzip closedPath + curves = plCurves pl + worker dst JoinLine = + LineBezier [toRPoint dst] + worker dst (JoinCurve a b) = + LineBezier $ map toRPoint [a,b,dst] + toRPoint :: Point Double -> RPoint + toRPoint (Point x y) = V2 x y + +svgToPolyShapes :: Tree -> [PolyShape] +svgToPolyShapes = cmdsToPolyShapes . toLineCommands . extractPath + +cmdsToPolyShapes :: [LineCommand] -> [PolyShape] +cmdsToPolyShapes [] = [] +cmdsToPolyShapes cmds = + case cmds of + (LineMove dst:cont) -> map PolyShape $ worker dst [] cont + _ -> bad + where + bad = error $ "Reanimate.PolyShape: Invalid commands: " ++ show cmds + finalize [] rest = rest + finalize acc rest = (ClosedPath $ reverse acc) : rest + worker _from acc [] = finalize acc [] + worker _from acc (LineMove newStart : xs) = + finalize acc $ + worker newStart [] xs + worker from acc (LineEnd orig:LineMove dst:xs) | from /= orig = + finalize ((toGPoint from, JoinLine):acc) $ + worker dst [] xs + worker _from acc (LineEnd{}:LineMove dst:xs) = + finalize (acc) $ + worker dst [] xs + worker from acc [LineEnd orig] | from /= orig = + finalize ((toGPoint from, JoinLine):acc) [] + worker _from acc [LineEnd{}] = + finalize (acc) [] + worker from acc (LineBezier [x]:xs) = + worker x ((toGPoint from, JoinLine) : acc) xs + worker from acc (LineBezier [a,b,c]:xs) = + worker c ((toGPoint from, JoinCurve (toGPoint a) (toGPoint b)) : acc) xs + worker _ _ _ = bad + + toGPoint :: RPoint -> Point Double + toGPoint (V2 x y) = Point x y + +unionPolyShapes :: [PolyShape] -> [PolyShape] +unionPolyShapes shapes = + map PolyShape $ + union (map unPolyShape shapes) NonZero (polyShapeTolerance/10000) + +unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape] +unionPolyShapes' tol shapes = + map PolyShape $ + union (map unPolyShape shapes) NonZero tol + +-- True iff lhs is inside of rhs. +-- lhs and rhs may not overlap. +-- Implementation: Trace a vertical line through the origin of A and check +-- of this line intersects and odd number of times on both sides of A. +isInsideOf :: PolyShape -> PolyShape -> Bool +lhs `isInsideOf` rhs = + odd (length upHits) && odd (length downHits) + where + (upHits, downHits) = polyIntersections origin rhs + origin = polyShapeOrigin lhs + +polyIntersections :: DPoint -> PolyShape -> ([DPoint],[DPoint]) +polyIntersections origin rhs = + (nub $ concatMap (intersections rayUp) curves + ,nub $ concatMap (intersections rayDown) curves) + where + curves = plCurves rhs + + intersections line bs = + map (evalBezier bs . fst) (bezierIntersection bs line polyShapeTolerance) + limit = 1000 + rayUp = CubicBezier origin origin origin (Point limit limit) + rayDown = CubicBezier origin origin origin (Point (-limit) (-limit)) + +polyShapeOrigin :: PolyShape -> Point Double +polyShapeOrigin (PolyShape closedPath) = + case closedPath of + ClosedPath [] -> Point 0 0 + ClosedPath ((start,_):_) -> start + +plGroupShapes :: [PolyShape] -> [PolyShapeWithHoles] +plGroupShapes = worker + where + worker (s:rest) + | null (parents s rest) = + let isOnlyChild x = parents x (s:rest) == [s] + (holes, nonHoles) = partition isOnlyChild rest + prime = PolyShapeWithHoles + { polyShapeParent = s + , polyShapeHoles = holes } + in prime : worker nonHoles + | otherwise = trace ("Found hole, putting back") $ worker (rest ++ [s]) + worker [] = [] + + parents :: PolyShape -> [PolyShape] -> [PolyShape] + parents self = filter (self `isInsideOf`) . filter (/=self) + +instance Eq PolyShape where + a == b = plCurves a == plCurves b + +mergePolyShapeHoles :: PolyShapeWithHoles -> PolyShape +mergePolyShapeHoles (PolyShapeWithHoles parent []) = parent +mergePolyShapeHoles (PolyShapeWithHoles parent (child:children)) = + mergePolyShapeHoles $ + PolyShapeWithHoles (mergePolyShapeHole parent child) children + +-- Merge +mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape +mergePolyShapeHole parent child = + snd $ head $ + sortBy (comparing fst) + [ cutSingleHole newParent child + | newParent <- polyShapePermutations parent ] + +{- +parent: + (a,b) + (b,c) + (c,a) + +child: + (x,y) + (y,z) + (z,x) + +P = split (a,b) +new: + (P,b) p2b + (b,c) pTail + (c,a) pTail + (a,P) a2p + + (P,x) p2x + + (x,y) childCurves + (y,z) childCurves + (z,x) childCurves + + (x,P) x2p + +-} +cutSingleHole :: PolyShape -> PolyShape -> (Double, PolyShape) +cutSingleHole parent child = + (score, PolyShape $ curvesToClosed $ + p2b:pTail ++ [a2p] ++ + [p2x] ++ childCurves ++ + [x2p] + ) + where + score = vectorDistance childOrigin p + childOrigin = polyShapeOrigin child + (pHead:pTail) = plCurves parent + childCurves = plCurves child + + pParam = closest pHead childOrigin polyShapeTolerance + + (a2p, p2b) = splitBezier pHead pParam + + p = evalBezier pHead pParam + -- straight line to child origin + p2x = lineBetween p childOrigin + -- straight line from child origin + x2p = lineBetween childOrigin p + + lineBetween a b = CubicBezier a a a b + +plCurves :: PolyShape -> [CubicBezier Double] +plCurves = closedPathCurves . unPolyShape + +polyShapePermutations :: PolyShape -> [PolyShape] +polyShapePermutations = + map (PolyShape . curvesToClosed) . cycleList . plCurves + where + cycleList lst = + let n = length lst in + [ take n $ drop i $ cycle lst + | i <- [0.. n-1] ] diff --git a/src/Reanimate/Povray.hs b/src/Reanimate/Povray.hs index 1439f46..6ff7c92 100644 --- a/src/Reanimate/Povray.hs +++ b/src/Reanimate/Povray.hs @@ -15,7 +15,7 @@ import Reanimate.Cache import Reanimate.Memo import Reanimate.Misc import Reanimate.Raster -import Reanimate.Svg +import Reanimate.Svg.Constructors import System.FilePath (replaceExtension) import System.IO.Unsafe (unsafePerformIO) diff --git a/src/Reanimate/Raster.hs b/src/Reanimate/Raster.hs index 30712d4..9ed9971 100644 --- a/src/Reanimate/Raster.hs +++ b/src/Reanimate/Raster.hs @@ -1,36 +1,68 @@ module Reanimate.Raster ( embedImage , embedDynamicImage + , embedPng + , raster ) where import Codec.Picture import Codec.Picture.Types (dynamicMap) import Control.Lens +import qualified Data.ByteString as B import qualified Data.ByteString.Base64.Lazy as Base64 import qualified Data.ByteString.Lazy.Char8 as LBS -import Graphics.SvgTree (Tree (..), defaultSvg) +import Graphics.SvgTree (Number (..), Tree (..), + defaultSvg) import qualified Graphics.SvgTree as Svg -import Reanimate.Svg +import Reanimate.Misc +import Reanimate.Animation +import System.FilePath +import System.IO +import System.IO.Temp +import System.IO.Unsafe + {-# INLINE embedImage #-} embedImage :: PngSavable a => Image a -> Tree -embedImage img = center $ flipYAxis $ +embedImage img = embedPng width height (encodePng img) + where + width = fromIntegral $ imageWidth img + height = fromIntegral $ imageHeight img + +embedPng :: Double -> Double -> LBS.ByteString -> Tree +embedPng w h png = ImageTree $ defaultSvg - & Svg.imageWidth .~ Svg.Num (fromIntegral $ imageWidth img) - & Svg.imageHeight .~ Svg.Num (fromIntegral $ imageHeight img) + & Svg.imageWidth .~ Svg.Num w + & Svg.imageHeight .~ Svg.Num h & Svg.imageHref .~ ("data:image/png;base64," ++ imgData) where - imgData = LBS.unpack $ Base64.encode (encodePng img) + imgData = LBS.unpack $ Base64.encode png + {-# INLINE embedDynamicImage #-} embedDynamicImage :: DynamicImage -> Tree -embedDynamicImage img = center $ flipYAxis $ - ImageTree $ defaultSvg - & Svg.imageWidth .~ Svg.Num (fromIntegral $ dynamicMap imageWidth img) - & Svg.imageHeight .~ Svg.Num (fromIntegral $ dynamicMap imageHeight img) - & Svg.imageHref .~ ("data:image/png;base64," ++ imgData) +embedDynamicImage img = embedPng width height imgData where + width = fromIntegral $ dynamicMap imageWidth img + height = fromIntegral $ dynamicMap imageHeight img imgData = case encodeDynamicPng img of Left err -> error err - Right dat -> LBS.unpack $ Base64.encode dat + Right dat -> dat + +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 + where + width = 2560 + height = width * 9 / 16 diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs index 8778457..e029fe0 100644 --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -13,7 +13,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Graphics.SvgTree (Number (..)) import Reanimate.Misc -import Reanimate.Monad +import Reanimate.Animation import System.FilePath (()) import System.IO import Text.Printf (printf) diff --git a/src/Reanimate/Scene.hs b/src/Reanimate/Scene.hs index cd36080..bf93ae8 100644 --- a/src/Reanimate/Scene.hs +++ b/src/Reanimate/Scene.hs @@ -6,7 +6,8 @@ import Control.Monad.ST import Data.List import Data.Ord import Debug.Trace -import Reanimate.Monad +import Reanimate.Animation +import Reanimate.Svg.Constructors data World type ZIndex = Int @@ -50,9 +51,9 @@ instance MonadFix (Scene s) where --data Frame a = Frame {unFrame :: Duration -> Time -> State ([Tree] -> [Tree]) a} sceneAnimation :: (forall s. Scene s a) -> Animation -sceneAnimation action = Animation (max s p) $ Frame $ \_ t -> - sequence_ $ map snd $ sortBy (comparing fst) - [ (z, unFrame frameGen dur (t-startT)) +sceneAnimation action = Animation (max s p) $ \t -> + mkGroup $ map snd $ sortBy (comparing fst) + [ (z, frameGen (t-startT)) | (startT, Animation dur frameGen, z) <- tl , t >= startT , t < startT+dur diff --git a/src/Reanimate/Signal.hs b/src/Reanimate/Signal.hs index da57e53..f9f61d7 100644 --- a/src/Reanimate/Signal.hs +++ b/src/Reanimate/Signal.hs @@ -1,9 +1,20 @@ -module Reanimate.Signal where +module Reanimate.Signal + ( Signal + , constantS + , fromToS + , reverseS + , curveS + , bellS + , oscillateS + , fromListS + ) where +-- | Signals are time-varying variables. Signals can be composed using function +-- composition. type Signal = Double -> Double -signalFromList :: [(Double, Signal)] -> Signal -signalFromList fns t = worker 0 fns +fromListS :: [(Double, Signal)] -> Signal +fromListS fns t = worker 0 fns where worker _ [] = 0 worker now [(len, fn)] = fn (min 1 ((t-now) / min (1-now) len)) @@ -11,25 +22,68 @@ signalFromList fns t = worker 0 fns | now+len < t = worker (now+len) rest | otherwise = fn ((t-now) / len) -signalFlat :: Double -> Signal -signalFlat x = const x +-- | Constant signal. +-- +-- Example: +-- +-- > signalA (constantS 0.5) drawProgress +-- +-- <> +constantS :: Double -> Signal +constantS x = const x -signalLinear :: Signal -signalLinear = id +-- | Signal with new starting and end values. +-- +-- Example: +-- +-- > signalA (fromToS 0.8 0.2) drawProgress +-- +-- <> +fromToS :: Double -> Double -> Signal +fromToS from to t = from + (to-from)*t -signalFromTo :: Double -> Double -> Signal -> Signal -signalFromTo from to c t = from + (to-from)*(c t) +-- | Reverse signal order. +-- +-- Example: +-- +-- > signalA reverseS drawProgress +-- +-- <> +reverseS :: Signal +reverseS t = 1-t -signalReverse :: Signal -> Signal -signalReverse fn t = fn (1-t) - -signalCurve :: Double -> Signal -signalCurve steepness s = +-- | S-curve signal. Takes a steepness parameter. 2 is a good default. +-- +-- Example: +-- +-- > signalA (curveS 2) drawProgress +-- +-- <> +curveS :: Double -> Signal +curveS steepness s = if s < 0.5 then 0.5 * (2*s)**steepness else 1-0.5 * (2 - 2*s)**steepness -signalBell :: Double -> Signal -signalBell steepness s - | s < 0.5 = signalCurve steepness (s/0.5) - | otherwise = signalCurve steepness (1-((s-0.5)/0.5)) +-- | Oscillate signal. +-- +-- Example: +-- +-- > signalA oscillateS drawProgress +-- +-- <> +oscillateS :: Signal +oscillateS t = + if t < 1/2 + then t*2 + else 2-t*2 + +-- | Bell-curve signal. Takes a steepness parameter. 2 is a good default. +-- +-- Example: +-- +-- > signalA (bellS 2) drawProgress +-- +-- <> +bellS :: Double -> Signal +bellS steepness = curveS steepness . oscillateS diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs index 6788de7..3a8fef0 100644 --- a/src/Reanimate/Svg.hs +++ b/src/Reanimate/Svg.hs @@ -1,387 +1,23 @@ {-# LANGUAGE LambdaCase #-} -module Reanimate.Svg where +module Reanimate.Svg + ( module Reanimate.Svg + , module Reanimate.Svg.Constructors + , module Reanimate.Svg.LineCommand + , module Reanimate.Svg.BoundingBox + , module Reanimate.Svg.Unuse + ) where -import Codec.Picture (PixelRGBA8 (..)) -import Codec.Picture.Types () -import Control.Arrow -import Control.Lens (set, (%~), (&), (.~), (^.)) -import Control.Monad.Fix +import Control.Lens ((%~), (&), (.~), (^.)) import Control.Monad.State -import Data.Attoparsec.Text (parseOnly) -import Data.List -import qualified Data.Map as Map -import qualified Data.Text as T import Graphics.SvgTree hiding (height, line, path, use, width) -import Graphics.SvgTree.NamedColors -import Graphics.SvgTree.PathParser -import Linear.Metric import Linear.V2 hiding (angle) -import Linear.Vector +import Reanimate.Constants +import Reanimate.Svg.Constructors +import Reanimate.Svg.LineCommand +import Reanimate.Svg.BoundingBox +import Reanimate.Svg.Unuse import qualified Reanimate.Transform as Transform --- import qualified Geom2D.CubicBezier as Bezier - -defaultDPI :: Dpi -defaultDPI = 96 - -replaceUses :: Document -> Document -replaceUses doc = doc & elements %~ map (mapTree replace) - & definitions .~ Map.empty - where - replaceDefinition PathTree{} = None - replaceDefinition t = t - - replace t@DefinitionTree{} = mapTree replaceDefinition t - replace (UseTree _ Just{}) = error "replaceUses: subtree in use?" - replace (UseTree use Nothing) = - case Map.lookup (use^.useName) idMap of - Nothing -> error $ "Unknown id: " ++ (use^.useName) - Just tree -> - GroupTree $ - defaultSvg & groupChildren .~ [tree] - & transform .~ Just [baseToTransformation (use^.useBase)] - replace x = x - baseToTransformation (x,y) = - case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of - (Num a, Num b) -> Translate a b - _ -> TransformUnknown - docTree = mkGroup (doc^.elements) - idMap = foldTree updMap Map.empty docTree `Map.union` - (doc^.definitions) - updMap m tree = - case tree^.attrId of - Nothing -> m - Just tid -> Map.insert tid tree m - -docIds :: Document -> [String] -docIds doc = Map.keys idMap ++ Map.keys (doc^.definitions) - where - docTree = GroupTree $ set groupChildren (doc^.elements) defaultSvg - idMap = foldTree updMap Map.empty docTree - updMap m tree = - case tree^.attrId of - Nothing -> m - Just tid -> Map.insert tid tree m - - --- Transform out viewbox. defs and CSS rules are discarded. -unbox :: Document -> Tree -unbox doc@Document{_viewBox = Just (minx, minw, _width, _height)} = - GroupTree $ defaultSvg - & groupChildren .~ doc^.elements - & transform .~ Just [Translate (-minx) (-minw)] -unbox doc = - GroupTree $ defaultSvg - & groupChildren .~ doc^.elements - -type CmdM a = State RPoint a - -data LineCommand - = LineMove RPoint - -- | LineDraw RPoint - | LineBezier [RPoint] - | LineEnd - deriving (Show) - -lineToPath :: [LineCommand] -> [PathCommand] -lineToPath = map worker - where - worker (LineMove p) = MoveTo OriginAbsolute [p] - -- worker (LineDraw p) = LineTo OriginAbsolute [p] - worker (LineBezier [a,b,c]) = CurveTo OriginAbsolute [(a,b,c)] - worker (LineBezier [a,b]) = QuadraticBezier OriginAbsolute [(a,b)] - worker (LineBezier [a]) = LineTo OriginAbsolute [a] - worker LineBezier{} = error "Reanimate.Svg.lineToPath: invalid bezier curve" - worker LineEnd = EndPath - -lineToPoints :: Int -> [LineCommand] -> [RPoint] -lineToPoints nPoints cmds = - map lineEnd lineSegments - where - lineSegments = [ partialLine (fromIntegral n/ fromIntegral nPoints) cmds | n <- [0 .. nPoints-1] ] - lineEnd [LineBezier pts] = last pts - lineEnd (_:xs) = lineEnd xs - lineEnd _ = error "invalid line" - -partialLine :: Double -> [LineCommand] -> [LineCommand] -partialLine alpha cmds = evalState (worker 0 cmds) zero - where - worker _d [] = pure [] - worker d (cmd:xs) = do - from <- get - len <- lineLength cmd - let frac = (targetLen-d) / len - if len == 0 || frac > 1 - then (cmd:) <$> worker (d+len) xs - else pure [adjustLineLength frac from cmd] - totalLen = evalState (sum <$> mapM lineLength cmds) zero - targetLen = totalLen * alpha - -adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand -adjustLineLength alpha from cmd = - case cmd of - LineBezier points -> LineBezier $ drop 1 $ partial_bezier_points (from:points) 0 alpha - LineMove p -> LineMove p - -- LineDraw t -> LineDraw (lerp alpha t from) - LineEnd -> LineEnd - -lineLength :: LineCommand -> CmdM Double -lineLength cmd = - case cmd of - LineMove to -> pure 0 <* put to - -- LineDraw to -> gets (distance to) <* put to - LineBezier points -> gets (distance (last points)) <* put (last points) - LineEnd -> pure 0 - -toLineCommands :: [PathCommand] -> [LineCommand] -toLineCommands ps = evalState (worker zero Nothing ps) zero - where - worker _startPos _mbPrevControlPt [] = pure [] - worker startPos mbPrevControlPt (cmd:cmds) = do - lcmds <- toLineCommand startPos mbPrevControlPt cmd - let startPos' = - case lcmds of - [LineMove pos] -> pos - _ -> startPos - (lcmds++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds - -cmdToControlPoint :: LineCommand -> Maybe RPoint -cmdToControlPoint (LineBezier points) = Just (last (init points)) -cmdToControlPoint _ = Nothing - -mkStraightLine :: RPoint -> LineCommand -mkStraightLine p = LineBezier [p] - -toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand] -toLineCommand startPos mbPrevControlPt cmd = do - 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 OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine) - HorizontalTo OriginAbsolute lst -> - forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine - HorizontalTo OriginRelative lst -> - forM lst $ \x -> modify (_x %~ (+x)) *> gets mkStraightLine - VerticalTo OriginAbsolute lst -> - 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 - forM quads $ \(a,b,c) -> do - from <- get <* modify (+c) - pure $ LineBezier $ map (+from) [a,b,c] - SmoothCurveTo o lst -> mfix $ \result -> do - let ctrl = mbPrevControlPt : map cmdToControlPoint result - forM (zip lst ctrl) $ \((c2,to), mbControl) -> do - 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 - forM pairs $ \(a,b) -> do - from <- get <* modify (+b) - pure $ LineBezier $ map (+from) [a,b] - SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do - let ctrl = mbPrevControlPt : map cmdToControlPoint result - forM (zip lst ctrl) $ \(to, mbControl) -> do - from <- get <* adjustPosition o to - 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 - from <- get <* adjustPosition o to - return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to)) - EndPath -> put startPos *> pure [LineBezier [startPos], LineEnd] - where - mirrorPoint c p = c*2-p - adjustPosition OriginRelative p = modify (+p) - adjustPosition OriginAbsolute p = put p - makeAbsolute OriginAbsolute _from p = p - makeAbsolute OriginRelative from p = from+p - - -calculateVectorAngle :: Double -> Double -> Double -> Double -> Double -calculateVectorAngle ux uy vx vy - | tb >= ta - = tb - ta - | otherwise - = pi * 2 - (ta - tb) - where - ta = atan2 uy ux - tb = atan2 vy vx - --- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs -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 - = [] - | radiusX == 0.0 && radiusY == 0.0 - = [LineBezier [V2 x y]] - | otherwise - = calcSegments x0 y0 theta1' segments' - where - sinPhi = sin (angle * pi/180) - cosPhi = cos (angle * pi/180) - - x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0 - y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0 - - numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash - - s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY)) - rx = if (numerator < 0.0) then (radiusX * s) else radiusX - ry = if (numerator < 0.0) then (radiusY * s) else radiusY - root = if (numerator < 0.0) - then (0.0) - else ((if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0) * - sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash))) - - cxdash = root * rx * y1dash / ry - cydash = -root * ry * x1dash / rx - - cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0 - cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0 - - theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) - 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') - - segments' = ceiling (abs (dtheta / (pi / 2.0))) - delta = dtheta / fromInteger segments' - t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0) - - calcSegments startX startY theta1 segments - | segments == 0 - = [] - | otherwise - = LineBezier [ V2 (startX + dx1) (startY + dy1) - , V2 (endpointX + dxe) (endpointY + dye) - , V2 endpointX endpointY ] : calcSegments endpointX endpointY theta2 (segments - 1) - where - cosTheta1 = cos theta1 - sinTheta1 = sin theta1 - theta2 = theta1 + delta - cosTheta2 = cos theta2 - sinTheta2 = sin theta2 - - endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx - endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy - - dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1) - dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1) - - 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) - - - -interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand] -interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands - -partialSvg :: Double -> Tree -> Tree -partialSvg alpha = mapTree worker - where - worker (PathTree path) = - PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands - worker t = t - --- (x,y,w,h) -boundingBox :: Tree -> (Double, Double, Double, Double) -boundingBox t = - case svgBoundingPoints t of - [] -> (0,0,0,0) - (V2 x y:rest) -> - let (minx, miny, maxx, maxy) = foldl' worker (x, y, x, y) rest - in (minx, miny, maxx-minx, maxy-miny) - where - worker (minx, miny, maxx, maxy) (V2 x y) = - (min minx x, min miny y, max maxx x, max maxy y) - -svgHeight :: Tree -> Double -svgHeight t = h - where - (_x,_y,_w,h) = boundingBox t - -svgWidth :: Tree -> Double -svgWidth t = w - where - (_x,_y,w,_h) = boundingBox t - -linePoints :: [LineCommand] -> [RPoint] -linePoints = worker zero - where - worker _from [] = [] - worker from (x:xs) = - case x of - LineMove to -> worker to xs - -- 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]] ++ - worker (last ctrl) xs - LineEnd -> worker from xs - chunks = 10 - -svgBoundingPoints :: Tree -> [RPoint] -svgBoundingPoints t = map (Transform.transformPoint m) $ - case t of - None -> [] - UseTree{} -> [] - GroupTree g -> concatMap svgBoundingPoints (g^.groupChildren) - SymbolTree (Symbol g) -> concatMap svgBoundingPoints (g^.groupChildren) - FilterTree{} -> [] - DefinitionTree{} -> [] - PathTree p -> linePoints $ toLineCommands (p^.pathDefinition) - CircleTree{} -> error "CircleTree" - PolyLineTree{} -> error "PolyLineTree" - EllipseTree{} -> error "EllipseTree" - LineTree line -> map pointToRPoint [line^.linePoint1, line^.linePoint2] - RectangleTree rect -> - case pointToRPoint (rect^.rectUpperLeftCorner) of - V2 x y -> [V2 x y] ++ - case mapTuple (fmap $ toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of - (Just (Num w), Just (Num h)) -> [V2 (x+w) (y+h)] - _ -> [] - TextTree{} -> [] - ImageTree img -> - case (img^.imageCornerUpperLeft, img^.imageWidth, img^.imageHeight) of - ((Num x, Num y), Num w, Num h) -> - [V2 x y, V2 (x+w) (y+h)] - _ -> [] - MeshGradientTree{} -> [] - _ -> [] - where - m = Transform.mkMatrix (t^.transform) - mapTuple f = f *** f - pointToRPoint p = - case mapTuple (toUserUnit defaultDPI) p of - (Num x, Num y) -> (V2 x y) - _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format." lowerTransformations :: Tree -> Tree lowerTransformations = worker Transform.identity @@ -391,7 +27,7 @@ lowerTransformations = worker Transform.identity LineMove p -> LineMove $ Transform.transformPoint m p -- LineDraw p -> LineDraw $ Transform.transformPoint m p LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps - LineEnd -> LineEnd + LineEnd p -> LineEnd $ Transform.transformPoint m p updPath m = lineToPath . map (updLineCmd m) . toLineCommands worker m t = let m' = m * Transform.mkMatrix (t^.transform) in @@ -419,13 +55,24 @@ simplify root = xs -> mkGroup xs where worker None = [] - worker (DefinitionTree d) - | null (d ^. groupChildren) = [] - | otherwise = [DefinitionTree $ d & groupChildren %~ concatMap worker] + worker (DefinitionTree d) = + concatMap dropNulls $ + [DefinitionTree $ d & groupChildren %~ concatMap worker] worker (GroupTree g) - | g ^. drawAttributes == defaultSvg = concatMap worker (g^.groupChildren) - | otherwise = [GroupTree $ g & groupChildren %~ concatMap worker] - worker t = [t] + | g ^. drawAttributes == defaultSvg = + concatMap dropNulls $ + concatMap worker (g^.groupChildren) + | otherwise = + dropNulls $ + GroupTree $ g & groupChildren %~ concatMap worker + worker t = dropNulls t + + 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 @@ -434,199 +81,6 @@ extractPath = worker . simplify . lowerTransformations . pathify worker (PathTree p) = p^.pathDefinition worker _ = [] -withTransformations :: [Transformation] -> Tree -> Tree -withTransformations transformations t = - mkGroup [t] & transform .~ Just transformations - -translate :: Double -> Double -> Tree -> Tree -translate x y = withTransformations [Translate x y] - -rotate :: Double -> Tree -> Tree -rotate a = withTransformations [Rotate a Nothing] - -rotateAround :: Double -> RPoint -> Tree -> Tree -rotateAround a (V2 x y) = withTransformations [Rotate a (Just (x,y))] - -rotateAroundCenter :: Double -> Tree -> Tree -rotateAroundCenter a t = - rotateAround a (V2 (x+w/h) (y+h/2)) t - where - (x,y,w,h) = boundingBox t - -scale :: Double -> Tree -> Tree -scale a = withTransformations [Scale a Nothing] - -scaleToSize :: Double -> Double -> Tree -> Tree -scaleToSize w h t = - scaleXY (w/w') (h/h') t - where - (_x, _y, w', h') = boundingBox t - -scaleToWidth :: Double -> Tree -> Tree -scaleToWidth w t = - scale (w/w') t - where - (_x, _y, w', _h') = boundingBox t - -scaleToHeight :: Double -> Tree -> Tree -scaleToHeight h t = - scale (h/h') t - where - (_x, _y, _w', h') = boundingBox t - -scaleXY :: Double -> Double -> Tree -> Tree -scaleXY x y = withTransformations [Scale x (Just y)] - -flipXAxis :: Tree -> Tree -flipXAxis = scaleXY (-1) 1 - -flipYAxis :: Tree -> Tree -flipYAxis = scaleXY 1 (-1) - - --- scalePoints :: Double -> Tree -> Tree --- scalePoints a = scalePointsXY a a --- --- scalePointsXY :: Double -> Double -> Tree -> Tree --- scalePointsXY x y = mapTree worker --- where --- worker t = --- case t of --- None -> t --- UseTree{} -> t --- GroupTree{} -> t --- SymbolTree{} -> t --- PathTree p -> PathTree $ p --- & pathDefinition %~ lineToPath . map scaleCmd . toLineCommands --- CircleTree{} -> error "scalePointsXY CircleTree" --- PolyLineTree{} -> error "scalePointsXY PolyLineTree" --- EllipseTree{} -> error "scalePointsXY EllipseTree" --- LineTree{} -> error "scalePointsXY LineTree" --- RectangleTree rect -> RectangleTree $ rect --- & rectUpperLeftCorner %~ (mapNumber (*x) *** mapNumber (*y)) --- & rectWidth %~ mapNumber (*x) --- & rectHeight %~ mapNumber (*y) --- TextTree{} -> t --- ImageTree{} -> t --- MeshGradientTree{} -> t --- scaleCmd (LineMove to) = LineMove (to * V2 x y) --- scaleCmd (LineDraw to) = LineDraw (to * V2 x y) --- scaleCmd (LineBezier points) = LineBezier (map (*V2 x y) points) - -center :: Tree -> Tree -center t = translate (-x-w/2) (-y-h/2) t - where - (x, y, w, h) = boundingBox t - -centerX :: Tree -> Tree -centerX t = translate (-x-w/2) 0 t - where - (x, _y, w, _h) = boundingBox t - -centerY :: Tree -> Tree -centerY t = translate 0 (-y-h/2) t - where - (_x, y, _w, h) = boundingBox t - -mkColor :: String -> Texture -mkColor name = - case Map.lookup (T.pack name) svgNamedColors of - Nothing -> ColorRef (PixelRGBA8 240 248 255 255) - Just c -> ColorRef c - -withStrokeColor :: String -> Tree -> Tree -withStrokeColor color = strokeColor .~ pure (mkColor color) - -withStrokeLineJoin :: LineJoin -> Tree -> Tree -withStrokeLineJoin ljoin = strokeLineJoin .~ pure ljoin - -withFillColor :: String -> Tree -> Tree -withFillColor color = fillColor .~ pure (mkColor color) - -withFillColorPixel :: PixelRGBA8 -> Tree -> Tree -withFillColorPixel color = fillColor .~ pure (ColorRef color) - -withFillOpacity :: Double -> Tree -> Tree -withFillOpacity opacity = fillOpacity .~ Just (realToFrac opacity) - -withGroupOpacity :: Double -> Tree -> Tree -withGroupOpacity opacity = groupOpacity .~ Just (realToFrac opacity) - -withStrokeWidth :: Number -> Tree -> Tree -withStrokeWidth width = strokeWidth .~ pure width - -withClipPathRef :: ElementRef -> Tree -> Tree -withClipPathRef ref = clipPathRef .~ pure ref - -withId :: String -> Tree -> Tree -withId idTag = attrId .~ Just idTag - -mkRect :: Number -> Number -> Tree -mkRect width height = center $ RectangleTree $ defaultSvg - & rectUpperLeftCorner .~ (Num 0, Num 0) - & rectWidth .~ Just width - & rectHeight .~ Just height - -mkCircle :: Number -> Tree -mkCircle radius = CircleTree $ defaultSvg - & circleCenter .~ (Num 0, Num 0) - & circleRadius .~ radius - --- XXX: This is broken. -mkBoundingRect :: Tree -> Double -> Tree -mkBoundingRect src margin = - translate (x-margin) (y-margin) $ - mkRect (Num $ w+margin*2) (Num $ h+margin*2) - where - (x, y, w, h) = boundingBox src - -mkLine :: Point -> Point -> Tree -mkLine point1 point2 = LineTree $ defaultSvg - & linePoint1 .~ point1 - & linePoint2 .~ point2 - -mkGroup :: [Tree] -> Tree -mkGroup forest = GroupTree $ defaultSvg - & groupChildren .~ forest - -mkDefinitions :: [Tree] -> Tree -mkDefinitions forest = DefinitionTree $ defaultSvg - & groupChildren .~ forest - -mkUse :: String -> Tree -mkUse name = UseTree (defaultSvg & useName .~ name) Nothing - -mkClipPath :: String -> [Tree] -> Tree -mkClipPath idTag forest = withId idTag $ ClipPathTree $ (defaultSvg - & clipPathContent .~ forest) - -mkPathString :: String -> Tree -mkPathString = mkPathText . T.pack - -mkPathText :: T.Text -> Tree -mkPathText str = - case parseOnly pathParser str of - Left err -> error err - Right cmds -> mkPath cmds - -mkPath :: [PathCommand] -> Tree -mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds - -mkLinePath :: [(Double, Double)] -> Tree -mkLinePath [] = mkGroup [] -mkLinePath ((startX, startY):rest) = - PathTree $ defaultSvg & pathDefinition .~ cmds - where - cmds = [ MoveTo OriginAbsolute [V2 startX startY] - , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] ] - -mkBackground :: String -> Tree -mkBackground color = withFillColor color $ mkRect (Num 320) (Num 180) - -mkBackgroundPixel :: PixelRGBA8 -> Tree -mkBackgroundPixel pixel = - withFillColorPixel pixel $ mkRect (Num 320) (Num 180) - withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree withSubglyphs target fn = \t -> evalState (worker t) 0 where diff --git a/src/Reanimate/Svg/BoundingBox.hs b/src/Reanimate/Svg/BoundingBox.hs new file mode 100644 index 0000000..5094f54 --- /dev/null +++ b/src/Reanimate/Svg/BoundingBox.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE LambdaCase #-} +module Reanimate.Svg.BoundingBox where + +import Control.Arrow +import Control.Lens ((^.)) +import Data.List +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 Geom2D.CubicBezier as Bezier + +-- (x,y,w,h) +boundingBox :: Tree -> (Double, Double, Double, Double) +boundingBox t = + case svgBoundingPoints t of + [] -> (0,0,0,0) + (V2 x y:rest) -> + let (minx, miny, maxx, maxy) = foldl' worker (x, y, x, y) rest + in (minx, miny, maxx-minx, maxy-miny) + where + worker (minx, miny, maxx, maxy) (V2 x y) = + (min minx x, min miny y, max maxx x, max maxy y) + +svgHeight :: Tree -> Double +svgHeight t = h + where + (_w, h, _x, _y) = boundingBox t + +svgWidth :: Tree -> Double +svgWidth t = w + where + (w, _h, _x, _y) = boundingBox t + +linePoints :: [LineCommand] -> [RPoint] +linePoints = worker zero + where + worker _from [] = [] + worker from (x:xs) = + case x of + LineMove to -> worker to xs + -- 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]] ++ + worker (last ctrl) xs + LineEnd p -> p : worker p xs + chunks = 10 + +svgBoundingPoints :: Tree -> [RPoint] +svgBoundingPoints t = map (Transform.transformPoint m) $ + case t of + None -> [] + UseTree{} -> [] + GroupTree g -> concatMap svgBoundingPoints (g^.groupChildren) + SymbolTree (Symbol g) -> concatMap svgBoundingPoints (g^.groupChildren) + FilterTree{} -> [] + DefinitionTree{} -> [] + PathTree p -> linePoints $ toLineCommands (p^.pathDefinition) + CircleTree{} -> error "Bounding box: CircleTree" + PolyLineTree{} -> error "Bounding box: PolyLineTree" + EllipseTree{} -> error "Bounding box: EllipseTree" + LineTree line -> map pointToRPoint [line^.linePoint1, line^.linePoint2] + RectangleTree rect -> + case pointToRPoint (rect^.rectUpperLeftCorner) of + V2 x y -> [V2 x y] ++ + case mapTuple (fmap $ toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of + (Just (Num w), Just (Num h)) -> [V2 (x+w) (y+h)] + _ -> [] + TextTree{} -> [] + ImageTree img -> + case (img^.imageCornerUpperLeft, img^.imageWidth, img^.imageHeight) of + ((Num x, Num y), Num w, Num h) -> + [V2 x y, V2 (x+w) (y+h)] + _ -> [] + MeshGradientTree{} -> [] + _ -> [] + where + m = Transform.mkMatrix (t^.transform) + mapTuple f = f *** f + pointToRPoint p = + case mapTuple (toUserUnit defaultDPI) p of + (Num x, Num y) -> (V2 x y) + _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format." diff --git a/src/Reanimate/Svg/Constructors.hs b/src/Reanimate/Svg/Constructors.hs new file mode 100644 index 0000000..d260656 --- /dev/null +++ b/src/Reanimate/Svg/Constructors.hs @@ -0,0 +1,182 @@ +module Reanimate.Svg.Constructors where + +import Codec.Picture (PixelRGBA8 (..)) +import Control.Lens ((&), (.~)) +import Data.Attoparsec.Text (parseOnly) +import qualified Data.Map as Map +import qualified Data.Text as T +import Graphics.SvgTree hiding (height, line, path, use, + width) +import Graphics.SvgTree.NamedColors +import Graphics.SvgTree.PathParser +import Linear.V2 hiding (angle) +import Reanimate.Constants +import Reanimate.Svg.BoundingBox + +withTransformations :: [Transformation] -> Tree -> Tree +withTransformations transformations t = + mkGroup [t] & transform .~ Just transformations + +translate :: Double -> Double -> Tree -> Tree +translate x y = withTransformations [Translate x y] + +rotate :: Double -> Tree -> Tree +rotate a = withTransformations [Rotate a Nothing] + +rotateAround :: Double -> RPoint -> Tree -> Tree +rotateAround a (V2 x y) = withTransformations [Rotate a (Just (x,y))] + +rotateAroundCenter :: Double -> Tree -> Tree +rotateAroundCenter a t = + rotateAround a (V2 (x+w/h) (y+h/2)) t + where + (x,y,w,h) = boundingBox t + +scale :: Double -> Tree -> Tree +scale a = withTransformations [Scale a Nothing] + +scaleToSize :: Double -> Double -> Tree -> Tree +scaleToSize w h t = + scaleXY (w/w') (h/h') t + where + (_x, _y, w', h') = boundingBox t + +scaleToWidth :: Double -> Tree -> Tree +scaleToWidth w t = + scale (w/w') t + where + (_x, _y, w', _h') = boundingBox t + +scaleToHeight :: Double -> Tree -> Tree +scaleToHeight h t = + scale (h/h') t + where + (_x, _y, _w', h') = boundingBox t + +scaleXY :: Double -> Double -> Tree -> Tree +scaleXY x y = withTransformations [Scale x (Just y)] + +flipXAxis :: Tree -> Tree +flipXAxis = scaleXY (-1) 1 + +flipYAxis :: Tree -> Tree +flipYAxis = scaleXY 1 (-1) + +center :: Tree -> Tree +center t = translate (-x-w/2) (-y-h/2) t + where + (x, y, w, h) = boundingBox t + +centerX :: Tree -> Tree +centerX t = translate (-x-w/2) 0 t + where + (x, _y, w, _h) = boundingBox t + +centerY :: Tree -> Tree +centerY t = translate 0 (-y-h/2) t + where + (_x, y, _w, h) = boundingBox t + +mkColor :: String -> Texture +mkColor name = + case Map.lookup (T.pack name) svgNamedColors of + Nothing -> ColorRef (PixelRGBA8 240 248 255 255) + Just c -> ColorRef c + +withStrokeColor :: String -> Tree -> Tree +withStrokeColor color = strokeColor .~ pure (mkColor color) + +withStrokeLineJoin :: LineJoin -> Tree -> Tree +withStrokeLineJoin ljoin = strokeLineJoin .~ pure ljoin + +withFillColor :: String -> Tree -> Tree +withFillColor color = fillColor .~ pure (mkColor color) + +withFillColorPixel :: PixelRGBA8 -> Tree -> Tree +withFillColorPixel color = fillColor .~ pure (ColorRef color) + +withFillOpacity :: Double -> Tree -> Tree +withFillOpacity opacity = fillOpacity .~ Just (realToFrac opacity) + +withGroupOpacity :: Double -> Tree -> Tree +withGroupOpacity opacity = groupOpacity .~ Just (realToFrac opacity) + +withStrokeWidth :: Double -> Tree -> Tree +withStrokeWidth width = strokeWidth .~ pure (Num width) + +withClipPathRef :: ElementRef -> Tree -> Tree +withClipPathRef ref = clipPathRef .~ pure ref + +withId :: String -> Tree -> Tree +withId idTag = attrId .~ Just idTag + +mkRect :: Double -> Double -> Tree +mkRect width height = translate (-width/2) (-height/2) $ RectangleTree $ defaultSvg + & rectUpperLeftCorner .~ (Num 0, Num 0) + & rectWidth .~ Just (Num width) + & rectHeight .~ Just (Num height) + +mkCircle :: Double -> Tree +mkCircle radius = CircleTree $ defaultSvg + & circleCenter .~ (Num 0, Num 0) + & circleRadius .~ Num radius + +mkLine :: (Double,Double) -> (Double, Double) -> Tree +mkLine (x1,y1) (x2,y2) = LineTree $ defaultSvg + & linePoint1 .~ (Num x1, Num y1) + & linePoint2 .~ (Num x2, Num y2) + +mkGroup :: [Tree] -> Tree +mkGroup forest = GroupTree $ defaultSvg + & groupChildren .~ forest + +mkDefinitions :: [Tree] -> Tree +mkDefinitions forest = DefinitionTree $ defaultSvg + & groupChildren .~ forest + +mkUse :: String -> Tree +mkUse name = UseTree (defaultSvg & useName .~ name) Nothing + +mkClipPath :: String -> [Tree] -> Tree +mkClipPath idTag forest = withId idTag $ ClipPathTree $ (defaultSvg + & clipPathContent .~ forest) + +mkPath :: [PathCommand] -> Tree +mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds + +mkPathString :: String -> Tree +mkPathString = mkPathText . T.pack + +mkPathText :: T.Text -> Tree +mkPathText str = + case parseOnly pathParser str of + Left err -> error err + Right cmds -> mkPath cmds + +mkLinePath :: [(Double, Double)] -> Tree +mkLinePath [] = mkGroup [] +mkLinePath ((startX, startY):rest) = + PathTree $ defaultSvg & pathDefinition .~ cmds + where + cmds = [ MoveTo OriginAbsolute [V2 startX startY] + , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] ] + +mkBackground :: String -> Tree +mkBackground color = withFillColor color $ mkRect screenWidth screenHeight + +mkBackgroundPixel :: PixelRGBA8 -> Tree +mkBackgroundPixel pixel = + withFillColorPixel pixel $ mkRect screenWidth screenHeight + +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 + colSep = screenWidth / fromIntegral (nCols+1) + , (nCol, elt) <- zip [1..] col ] + where + rowSep = screenHeight / fromIntegral (nRows+1) + nRows = length rows diff --git a/src/Reanimate/Svg/LineCommand.hs b/src/Reanimate/Svg/LineCommand.hs new file mode 100644 index 0000000..3a6b8de --- /dev/null +++ b/src/Reanimate/Svg/LineCommand.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE LambdaCase #-} +module Reanimate.Svg.LineCommand where + +import Control.Lens ((%~), (&), (.~)) +import Control.Monad.Fix +import Control.Monad.State +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 + +type CmdM a = State RPoint a + +data LineCommand + = LineMove RPoint + -- | LineDraw RPoint + | LineBezier [RPoint] + | LineEnd RPoint + deriving (Show) + +lineToPath :: [LineCommand] -> [PathCommand] +lineToPath = map worker + where + worker (LineMove p) = MoveTo OriginAbsolute [p] + -- worker (LineDraw p) = LineTo OriginAbsolute [p] + worker (LineBezier [a,b,c]) = CurveTo OriginAbsolute [(a,b,c)] + worker (LineBezier [a,b]) = QuadraticBezier OriginAbsolute [(a,b)] + worker (LineBezier [a]) = LineTo OriginAbsolute [a] + worker LineBezier{} = error "Reanimate.Svg.lineToPath: invalid bezier curve" + worker LineEnd{} = EndPath + +lineToPoints :: Int -> [LineCommand] -> [RPoint] +lineToPoints nPoints cmds = + map lineEnd lineSegments + where + lineSegments = [ partialLine (fromIntegral n/ fromIntegral nPoints) cmds | n <- [0 .. nPoints-1] ] + lineEnd [LineBezier pts] = last pts + lineEnd (_:xs) = lineEnd xs + lineEnd _ = error "invalid line" + +partialLine :: Double -> [LineCommand] -> [LineCommand] +partialLine alpha cmds = evalState (worker 0 cmds) zero + where + worker _d [] = pure [] + worker d (cmd:xs) = do + from <- get + len <- lineLength cmd + let frac = (targetLen-d) / len + if len == 0 || frac >= 1 + then (cmd:) <$> worker (d+len) xs + else pure [adjustLineLength frac from cmd] + totalLen = evalState (sum <$> mapM lineLength cmds) zero + targetLen = totalLen * alpha + +adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand +adjustLineLength alpha from cmd = + case cmd of + LineBezier points -> LineBezier $ drop 1 $ partial_bezier_points (from:points) 0 alpha + LineMove p -> LineMove p + -- LineDraw t -> LineDraw (lerp alpha t from) + LineEnd p -> LineBezier [lerp alpha p from] + +lineLength :: LineCommand -> CmdM Double +lineLength cmd = + case cmd of + LineMove to -> pure 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 + +toLineCommands :: [PathCommand] -> [LineCommand] +toLineCommands ps = evalState (worker zero Nothing ps) zero + where + worker _startPos _mbPrevControlPt [] = pure [] + worker startPos mbPrevControlPt (cmd:cmds) = do + lcmds <- toLineCommand startPos mbPrevControlPt cmd + let startPos' = + case lcmds of + [LineMove pos] -> pos + _ -> startPos + (lcmds++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds + +cmdToControlPoint :: LineCommand -> Maybe RPoint +cmdToControlPoint (LineBezier points) = Just (last (init points)) +cmdToControlPoint _ = Nothing + +mkStraightLine :: RPoint -> LineCommand +mkStraightLine p = LineBezier [p] + +toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand] +toLineCommand startPos mbPrevControlPt cmd = do + 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 OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine) + HorizontalTo OriginAbsolute lst -> + forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine + HorizontalTo OriginRelative lst -> + forM lst $ \x -> modify (_x %~ (+x)) *> gets mkStraightLine + VerticalTo OriginAbsolute lst -> + 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 + forM quads $ \(a,b,c) -> do + from <- get <* modify (+c) + pure $ LineBezier $ map (+from) [a,b,c] + SmoothCurveTo o lst -> mfix $ \result -> do + let ctrl = mbPrevControlPt : map cmdToControlPoint result + forM (zip lst ctrl) $ \((c2,to), mbControl) -> do + 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 + forM pairs $ \(a,b) -> do + from <- get <* modify (+b) + pure $ LineBezier $ map (+from) [a,b] + SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do + let ctrl = mbPrevControlPt : map cmdToControlPoint result + forM (zip lst ctrl) $ \(to, mbControl) -> do + from <- get <* adjustPosition o to + 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 + from <- get <* adjustPosition o to + return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to)) + EndPath -> put startPos *> pure [LineEnd startPos] + where + mirrorPoint c p = c*2-p + adjustPosition OriginRelative p = modify (+p) + adjustPosition OriginAbsolute p = put p + makeAbsolute OriginAbsolute _from p = p + makeAbsolute OriginRelative from p = from+p + + +calculateVectorAngle :: Double -> Double -> Double -> Double -> Double +calculateVectorAngle ux uy vx vy + | tb >= ta + = tb - ta + | otherwise + = pi * 2 - (ta - tb) + where + ta = atan2 uy ux + tb = atan2 vy vx + +-- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs +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 + = [] + | radiusX == 0.0 && radiusY == 0.0 + = [LineBezier [V2 x y]] + | otherwise + = calcSegments x0 y0 theta1' segments' + where + sinPhi = sin (angle * pi/180) + cosPhi = cos (angle * pi/180) + + x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0 + y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0 + + numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash + + s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY)) + rx = if (numerator < 0.0) then (radiusX * s) else radiusX + ry = if (numerator < 0.0) then (radiusY * s) else radiusY + root = if (numerator < 0.0) + then (0.0) + else ((if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0) * + sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash))) + + cxdash = root * rx * y1dash / ry + cydash = -root * ry * x1dash / rx + + cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0 + cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0 + + theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) + 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') + + segments' = ceiling (abs (dtheta / (pi / 2.0))) + delta = dtheta / fromInteger segments' + t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0) + + calcSegments startX startY theta1 segments + | segments == 0 + = [] + | otherwise + = LineBezier [ V2 (startX + dx1) (startY + dy1) + , V2 (endpointX + dxe) (endpointY + dye) + , V2 endpointX endpointY ] : calcSegments endpointX endpointY theta2 (segments - 1) + where + cosTheta1 = cos theta1 + sinTheta1 = sin theta1 + theta2 = theta1 + delta + cosTheta2 = cos theta2 + sinTheta2 = sin theta2 + + endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx + endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy + + dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1) + dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1) + + 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) + + + +interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand] +interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands + +partialSvg :: Double -> Tree -> Tree +partialSvg alpha = mapTree worker + where + worker (PathTree path) = + PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands + worker t = t diff --git a/src/Reanimate/Svg/Unuse.hs b/src/Reanimate/Svg/Unuse.hs new file mode 100644 index 0000000..a688988 --- /dev/null +++ b/src/Reanimate/Svg/Unuse.hs @@ -0,0 +1,50 @@ +module Reanimate.Svg.Unuse + ( replaceUses + , unbox + ) where + +import Control.Lens ((%~), (&), (.~), (^.)) +import qualified Data.Map as Map +import Graphics.SvgTree hiding (height, line, path, use, + width) +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 + + replace t@DefinitionTree{} = mapTree replaceDefinition t + replace (UseTree _ Just{}) = error "replaceUses: subtree in use?" + replace (UseTree use Nothing) = + case Map.lookup (use^.useName) idMap of + Nothing -> error $ "Unknown id: " ++ (use^.useName) + Just tree -> + GroupTree $ + defaultSvg & groupChildren .~ [tree] + & transform .~ Just [baseToTransformation (use^.useBase)] + replace x = x + baseToTransformation (x,y) = + case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of + (Num a, Num b) -> Translate a b + _ -> TransformUnknown + docTree = mkGroup (doc^.elements) + idMap = foldTree updMap Map.empty docTree `Map.union` + (doc^.definitions) + updMap m tree = + case tree^.attrId of + Nothing -> m + Just tid -> Map.insert tid tree m + +-- Transform out viewbox. defs and CSS rules are discarded. +unbox :: Document -> Tree +unbox doc@Document{_viewBox = Just (minx, minw, _width, _height)} = + GroupTree $ defaultSvg + & groupChildren .~ doc^.elements + & transform .~ Just [Translate (-minx) (-minw)] +unbox doc = + GroupTree $ defaultSvg + & groupChildren .~ doc^.elements diff --git a/stack-lts-11.yaml b/stack-lts-11.yaml index 64c1e76..1a9ca3b 100644 --- a/stack-lts-11.yaml +++ b/stack-lts-11.yaml @@ -6,8 +6,10 @@ packages: - . extra-deps: -- reanimate-svg-0.9.1.1 +- reanimate-svg-0.9.3.0 - palette-0.3.0.2 +- git: https://github.com/Lemmih/chiphunk.git + commit: 8328b1adb903abf034562ad95d1bfdaba1ce6397 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca - diagrams-contrib-1.4.3@sha256:bcfa6c85f8c33b8c48c3a61b7216afdebd51cd793c50da3a2dd358827d25fc76 - diagrams-core-1.4.1.1@sha256:6ef6b17785d77997c481eb085570e21b6a00cc91d086fbf49490504130ebc7d1 diff --git a/stack-lts-12.yaml b/stack-lts-12.yaml index f0626b0..e458f94 100644 --- a/stack-lts-12.yaml +++ b/stack-lts-12.yaml @@ -6,8 +6,10 @@ packages: - . extra-deps: -- reanimate-svg-0.9.1.1 +- reanimate-svg-0.9.3.0 - palette-0.3.0.2 +- git: https://github.com/Lemmih/chiphunk.git + commit: 8328b1adb903abf034562ad95d1bfdaba1ce6397 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca - diagrams-contrib-1.4.3@sha256:bcfa6c85f8c33b8c48c3a61b7216afdebd51cd793c50da3a2dd358827d25fc76 - diagrams-core-1.4.1.1@sha256:6ef6b17785d77997c481eb085570e21b6a00cc91d086fbf49490504130ebc7d1 diff --git a/stack.yaml b/stack.yaml index 1ff3562..ac12d48 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,8 +6,10 @@ packages: - . extra-deps: -- reanimate-svg-0.9.1.1 +- reanimate-svg-0.9.3.0 - palette-0.3.0.2 +- git: https://github.com/Lemmih/chiphunk.git + commit: 8328b1adb903abf034562ad95d1bfdaba1ce6397 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca - diagrams-contrib-1.4.3@sha256:bcfa6c85f8c33b8c48c3a61b7216afdebd51cd793c50da3a2dd358827d25fc76 - diagrams-core-1.4.1.1@sha256:6ef6b17785d77997c481eb085570e21b6a00cc91d086fbf49490504130ebc7d1 diff --git a/stack.yaml.lock b/stack.yaml.lock index e4feb08..b305b6c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,12 +5,12 @@ packages: - completed: - hackage: reanimate-svg-0.9.1.1@sha256:f00c2af90c1f801c63c7a65c085c145bcf660329a168ccd6253ab912a3eddd33,2448 + hackage: reanimate-svg-0.9.3.0@sha256:ba0414bce09a0f298b1ab5e1f0f9f75f4f47498e12dd0c6a75c2e63f33e34ca4,2448 pantry-tree: size: 1117 - sha256: adf1e2b20c77676d48ba990b1d1735a9c88ab38c1bf7f2d0c87690432aa3c183 + sha256: 1b559678d25e1fa98c75fad0315851c4c805f3cb6f2779ab4be7eb6868b4838e original: - hackage: reanimate-svg-0.9.1.1 + hackage: reanimate-svg-0.9.3.0 - completed: hackage: palette-0.3.0.2@sha256:50e210b7d21a0c394a6d672cc3c6d3bffcfa1be07419d72b99e68cfb65d6ca3c,1485 pantry-tree: @@ -18,6 +18,20 @@ packages: sha256: 9285e95a5701636961e83ed2036cca52a6b66e5ea809500ed6b845bc920f2791 original: hackage: palette-0.3.0.2 +- completed: + cabal-file: + size: 4595 + sha256: a84de7ba50404602b63825065cb178a7621b3b77c6cb0fb8fae0200c838c7ff5 + name: chiphunk + version: 0.1.1.0 + git: https://github.com/Lemmih/chiphunk.git + pantry-tree: + size: 6730 + sha256: 46939ee934e58d8896c35fa3c36b3d2b9947f671281618f540976b7ab6aa8675 + commit: 8328b1adb903abf034562ad95d1bfdaba1ce6397 + original: + git: https://github.com/Lemmih/chiphunk.git + commit: 8328b1adb903abf034562ad95d1bfdaba1ce6397 - completed: hackage: diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca,5483 pantry-tree: diff --git a/test.tex b/test.tex new file mode 100644 index 0000000..2e5afeb --- /dev/null +++ b/test.tex @@ -0,0 +1,6 @@ +\documentclass[preview]{standalone} +\usepackage[UTF8]{ctex} +\begin{document} +Blah +\end{document} + diff --git a/test/UnitTests.hs b/test/UnitTests.hs index d22fc05..1e4a25f 100644 --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -4,6 +4,7 @@ module UnitTests , compileVideoFolder ) where +import Control.Exception import qualified Data.ByteString.Lazy as LBS import Reanimate.Misc (withTempDir, withTempFile) import System.Directory @@ -19,7 +20,7 @@ unitTestFolder :: FilePath -> IO TestTree unitTestFolder path = do files <- getDirectoryContents path return $ testGroup "animate" - [ goldenVsStringDiff file (\ref new -> ["diff", "--brief", ref, new]) fullPath (genGolden hsPath) + [ goldenVsStringDiff file (\ref new -> ["diff", "--strip-trailing-cr", ref, new]) fullPath (genGolden hsPath) | file <- files , let fullPath = path file hsPath = replaceExtension fullPath "hs" @@ -38,6 +39,8 @@ genGolden path = withTempDir $ \tmpDir -> withTempFile ".exe" $ \tmpExecutable - -- ["-odir", tmpDir, "-hidir", tmpDir] (inh, outh, errh, _pid) <- runInteractiveProcess tmpExecutable (["test"] ++ runOpts) Nothing Nothing + -- hSetBinaryMode outh True + -- hSetNewlineMode outh universalNewlineMode hClose inh hClose errh LBS.hGetContents outh @@ -47,16 +50,17 @@ compileTestFolder path = do files <- getDirectoryContents path return $ testGroup "compile" [ testCase file $ do - (ret, _stdout, _stderr) <- readProcessWithExitCode "stack" (["ghc","--", fullPath] ++ ghcOpts) "" + (ret, _stdout, err) <- readProcessWithExitCode "stack" (["ghc","--", fullPath] ++ ghcOpts) "" + _ <- evaluate (length err) case ret of - ExitFailure{} -> assertFailure "Failed to compile" + ExitFailure{} -> assertFailure $ "Failed to compile:\n" ++ err ExitSuccess -> return () | file <- files , let fullPath = path file , takeExtension file == ".hs" || takeExtension file == ".lhs" ] where - ghcOpts = ["-fno-code", "-O0"] + ghcOpts = ["-fno-code", "-O0", "-Werror", "-Wall"] compileVideoFolder :: FilePath -> IO TestTree compileVideoFolder path = do diff --git a/videos/bakers-algorithm/bakers-algorithm.hs b/videos/bakers-algorithm/bakers-algorithm.hs index b33a26b..4b787c4 100755 --- a/videos/bakers-algorithm/bakers-algorithm.hs +++ b/videos/bakers-algorithm/bakers-algorithm.hs @@ -9,7 +9,7 @@ import Control.Lens import Graphics.SvgTree import Reanimate.Driver (reanimate) import Reanimate.LaTeX -import Reanimate.Monad +import Reanimate.Animation import Reanimate.Svg import Reanimate.Signal @@ -29,40 +29,44 @@ run out. -} main :: IO () main = reanimate $ pauseAtEnd 2 - (mkAnimation 0 $ emit $ mkBackground "black") `sim` + (animate $ const $ mkBackground "black") `parA` drawBox drawBox :: Animation -drawBox = mkAnimation 5 $ do - emit $ withFillColor "white" $ +drawBox = mkAnimation 5 $ \t -> + mkGroup + [ withFillColor "white" $ translate 0 (-70) $ scale 2 $ center $ latex "Baker's Algorithm" - s <- getSignal $ signalFromList [(0.7, signalFlat 0), (1, signalLinear)] - d <- getSignal $ signalFromList [(0.7, signalFlat 0), (1, signalLinear)] - draw <- getSignal $ signalFromList [(0.5, signalLinear), (1, signalFlat 1)] - let mlc = MemoryLineChart - { mlcWidth = 230 - , mlcHeight = 50 + s*50 - , mlcDivider = d - , mlcOuterBox = draw } - emit $ translate 0 20 $ renderMemoryLineChart mlc + , let s = fromListS [(0.7, constantS 0), (1, id)] t + d = fromListS [(0.7, constantS 0), (1, id)] t + draw = fromListS [(0.5, id), (1, constantS 1)] t + mlc = MemoryLineChart + { mlcWidth = 230 + , mlcHeight = 50 + s*50 + , mlcDivider = d + , mlcOuterBox = draw } + in translate 0 20 $ renderMemoryLineChart mlc + ] highlightBox :: Animation -highlightBox = mkAnimation 2 $ do - emit $ withFillColor "white" $ +highlightBox = mkAnimation 2 $ \t -> + mkGroup + [ withFillColor "white" $ translate 0 (-70) $ scale 2 $ center $ latex "Highlightbox" - let boxX = negate mlcWidth / 2 - boxY = negate mlcHeight / 2 - mlcWidth = 230 - mlcHeight = 50 - s <- getSignal $ signalFromList [(0.0, signalFlat 0), (1, signalBell 2)] - emit $ + , let boxX = negate mlcWidth / 2 + boxY = negate mlcHeight / 2 + mlcWidth = 230 + mlcHeight = 50 + s = fromListS [(0.0, constantS 0), (1, bellS 2)] t + in withStrokeColor "white" $ - withStrokeWidth (Num $ 0.5 + s) $ + withStrokeWidth (0.5 + s) $ withFillOpacity 0 $ translate (boxX + mlcWidth/2) (boxY + mlcHeight/2) $ - mkRect (Num mlcWidth) (Num mlcHeight) + mkRect mlcWidth mlcHeight + ] data MemoryLineChart = MemoryLineChart { mlcWidth :: Double @@ -80,15 +84,15 @@ mlcBox MemoryLineChart{..} = (boxX, boxY, mlcWidth, mlcHeight) renderMemoryLineChart :: MemoryLineChart -> Tree renderMemoryLineChart MemoryLineChart{..} = mkGroup [ withStrokeColor "white" $ - withStrokeWidth (Num 0.5) $ + withStrokeWidth 0.5 $ withFillOpacity 0 $ partialSvg mlcOuterBox $ pathify $ translate (boxX + mlcWidth/2) (boxY + mlcHeight/2) $ - mkRect (Num mlcWidth) (Num mlcHeight) + mkRect mlcWidth mlcHeight , withStrokeColor "white" $ - withStrokeWidth (Num 0.5) $ - mkLine (Num (negate $ mlcWidth/2), Num 0) - (Num (negate (mlcWidth/2) + lineWidth), Num 0) + withStrokeWidth 0.5 $ + mkLine (negate (mlcWidth/2), 0) + (negate (mlcWidth/2) + lineWidth, 0) , withFillColor "white" $ translate (negate (mlcWidth/2) - 10) 0 $ rotate (-90) $ center $ latex "Memory" diff --git a/videos/color-theory/Colorspace.hs b/videos/color-theory/Colorspace.hs index f27fac2..92a7439 100755 --- a/videos/color-theory/Colorspace.hs +++ b/videos/color-theory/Colorspace.hs @@ -23,8 +23,10 @@ import Reanimate.ColorSpace import Reanimate.Constants import Reanimate.Driver (reanimate) import Reanimate.LaTeX -import Reanimate.Monad +import Reanimate +import Reanimate.Animation import Reanimate.Raster +import Reanimate.Svg.BoundingBox import Reanimate.Scene import Reanimate.Effect import Reanimate.Signal @@ -42,7 +44,7 @@ colorSpacesScene = sceneAnimation $ mdo beginT <- queryNow fork $ play $ frame # setDuration (endT-beginT) - fork $ playZ 1 $ mkAnimation 1 (emit spectrumGrid) + fork $ playZ 1 $ animate (const spectrumGrid) # setDuration (endT-beginT) dur <- withSceneDuration $ do fork $ play $ drawSensitivity 1 short blueName @@ -131,12 +133,12 @@ colorSpacesScene = sceneAnimation $ mdo zCoords = [ (nm, z) | (nm, (x, y, z)) <- Map.toList bigXYZCoordinates ] -frame = mkAnimation 2 $ do +frame = mkAnimation 2 $ \t -> -- emit $ mkBackground "black" -- emit $ spectrumGrid - s <- getSignal signalLinear - let cm = hsv - emit $ mkGroup + let s = t + cm = hsv + in mkGroup [ mkClipPath "sRGB" [ simplify sRGBTriangle @@ -150,7 +152,7 @@ frame = mkAnimation 2 $ do [ simplify $ lowerTransformations $ translate 0 (margin/2) $ pathify $ - mkRect (Num spectrumWidth) (Num $ spectrumHeight+margin) + mkRect spectrumWidth (spectrumHeight+margin) ] ] @@ -278,7 +280,7 @@ spectrumWidth = screenWidth * 0.7 spectrumGrid :: Tree spectrumGrid = - withStrokeWidth (Num strokeWidth) $ + withStrokeWidth strokeWidth $ mkGroup [ center $ withFillOpacity 0 $ withStrokeColor "white" $ mkPath $ @@ -337,9 +339,8 @@ spectrumGrid = drawSensitivity :: Double -> [(Nanometer, Double)] -> String -> Animation -drawSensitivity maxHeight dat c = mkAnimation 1 $ do - limit <- getSignal signalLinear - emit $ sensitivitySVG maxHeight limit dat c +drawSensitivity maxHeight dat c = animate $ \limit -> + sensitivitySVG maxHeight limit dat c morphSensitivity :: Double @@ -348,12 +349,12 @@ morphSensitivity -> [(Nanometer, Double)] -> String -> Animation -morphSensitivity maxHeightA maxHeightB datA datB c = mkAnimation 1 $ do - m <- getSignal $ signalCurve 2 -- signalLinear - let maxHeight = signalFromTo maxHeightA maxHeightB id m - dat = [ (nm, signalFromTo a b id m) +morphSensitivity maxHeightA maxHeightB datA datB c = animate $ \t -> + let m = curveS 2 t + maxHeight = fromToS maxHeightA maxHeightB m + dat = [ (nm, fromToS a b m) | ((nm,a),(_,b)) <- zip datA datB ] - emit $ sensitivitySVG maxHeight 1 dat c + in sensitivitySVG maxHeight 1 dat c -- emit $ -- withClipPathRef (Ref "spectrum") $ @@ -380,8 +381,7 @@ sensitivitySVG maxHeight limit dat c = lastNM = 700 -- fromIntegral $ fst (last dat) drawLabel :: Text -> Double -> [(Nanometer, Double)] -> String -> Animation -drawLabel label maxHeight dat c = mkAnimation 1 $ do - emit $ +drawLabel label maxHeight dat c = animate $ const $ translate (0) (svgHeight labelSVG) $ translate (spectrumWidth*percent) labelY $ translate (-spectrumWidth/2) (-spectrumHeight/2) $ diff --git a/videos/color-theory/color-theory.hs b/videos/color-theory/color-theory.hs index 2506729..07b2f55 100755 --- a/videos/color-theory/color-theory.hs +++ b/videos/color-theory/color-theory.hs @@ -21,10 +21,12 @@ import Numeric import Reanimate.ColorMap import Reanimate.Driver (reanimate) import Reanimate.LaTeX -import Reanimate.Monad +import Reanimate +import Reanimate.Animation import Reanimate.Raster import Reanimate.Scene import Reanimate.Signal +import Reanimate.Effect import Reanimate.Svg import Reanimate.ColorSpace import Reanimate.Constants @@ -35,17 +37,14 @@ import Colorspace highdef = True takeA :: Double -> Animation -> Animation -takeA d1 (Animation d2 f) = Animation d $ Frame $ \_ t -> unFrame f d (min d t) - where - d = min d1 d2 +takeA = undefined dropA :: Double -> Animation -> Animation -dropA d1 (Animation d2 f) = Animation (max 0 (d2-d1)) $ - Frame $ \d t -> unFrame f d (t+d1) +dropA = undefined main :: IO () main = reanimate $ - (mkAnimation 0 $ emit $ mkBackground "black") `sim` + (animate $ const $ mkBackground "black") `parA` -- monalisaScene colorSpacesScene -- clipPathTest @@ -140,34 +139,33 @@ interpolateColorMap d cmap1 cmap2 = i a b = round (fromIntegral a + (fromIntegral b-fromIntegral a)*d) in PixelRGB8 (i r1 r2) (i g1 g2) (i b1 b2) -sceneFalseColorChain (x:y:xs) = sceneFalseColor x y `before` sceneFalseColorChain (y:xs) +sceneFalseColorChain (x:y:xs) = sceneFalseColor x y `seqA` sceneFalseColorChain (y:xs) sceneFalseColorChain _ = pause 0 sceneFalseColorIntro :: Animation -sceneFalseColorIntro = mkAnimation 2 $ do - s <- getSignal $ signalFromTo 1 2 $ signalCurve 3 - d <- getSignal $ signalCurve 3 - emit $ - translate ((screenWidth/4 - 0.75)*d) 0 $ +sceneFalseColorIntro = mkAnimation 2 $ \t -> + let s = fromToS 1 2 $ curveS 3 t + d = curveS 3 t + in mkGroup + [ translate ((screenWidth/4 - 0.75)*d) 0 $ scaleToSize (screenWidth/s) (screenHeight/s) $ center $ embedImage monalisaLarge - emit $ - withGroupOpacity d $ + , withGroupOpacity d $ translate ((screenWidth/4 - 0.75)*d) 0 $ scaleToSize (screenWidth/s) (screenHeight/s) $ - embedImage monalisa + embedImage monalisa ] sceneFalseColor :: (Double -> PixelRGB8) -> (Double -> PixelRGB8) -> Animation -sceneFalseColor cmap1 cmap2 = mkAnimation 5 $ do - s <- getSignal $ signalCurve 3 - let cm = interpolateColorMap s cmap1 cmap2 - emit $ translate (screenWidth/4 - 0.75) 0 $ +sceneFalseColor cmap1 cmap2 = mkAnimation 5 $ \t -> + let s = curveS 3 t + cm = interpolateColorMap s cmap1 cmap2 + in translate (screenWidth/4 - 0.75) 0 $ scaleToSize (screenWidth/2) (screenHeight/2) $ embedImage $ applyColorMap cm monalisa sceneColorMaps :: Animation -sceneColorMaps = mkAnimation 5 $ do - emit $ mkGroup +sceneColorMaps = mkAnimation 5 $ const $ + mkGroup [ translate xOffset (yInit - n*yStep) $ mkGroup [ renderColorMap width height cmap @@ -199,45 +197,33 @@ limitGreyPixels limit img = let pixel@(PixelRGB8 r _ _) = pixelAt img x y in if r < limit then promotePixel pixel else PixelRGBA8 0 0 0 1 --limit limit limit -latexTest :: Animation -latexTest = mkAnimation 5 $ do - let (_,_,baseW,baseH) = boundingBox $ latex "Hello world" - (_,_,txtW, txtH) = boundingBox $ latex "aa" - emit $ withFillColor "white" $ latex "Hello world" - emit $ translate (-10) (baseH-txtH) $ withFillColor "white" $ latex "aa" - emit $ withStrokeWidth (Num 0.3) $ withStrokeColor "white" $ - mkGroup - [ mkLine (Num (-100), Num 0) (Num 100, Num 0) - , mkLine (Num 0, Num (-100)) (Num 0, Num 100)] - renderColorMap :: Double -> Double -> (Double -> PixelRGB8) -> Tree renderColorMap width height cmap = mkGroup [ scaleToSize width height $ mkColorMap cmap - , center $ withStrokeWidth (Num 0.01) $ + , center $ withStrokeWidth 0.01 $ withStrokeColor "white" $ withFillOpacity 0 $ - mkRect (Num width) (Num height) + mkRect width height ] showColorMap :: Double -> Double -> Animation -showColorMap start end = mkAnimation 2 $ do - s <- getSignal $ signalCurve 2 - let n = signalFromTo start end id s - emit $ - translate 0 offsetY $ +showColorMap start end = mkAnimation 2 $ \t -> + let s = curveS 2 t + n = fromToS start end s + in translate 0 offsetY $ mkGroup [ withGroupOpacity 0.9 $ withFillColor "black" $ translate 0 (0) $ center $ - mkRect (Num $ width + height*2) (Num $ height*3) - , scaleToSize width height $ mkColorMap (cm . signalFromTo start end id) + mkRect (width + height*2) (height*3) + , scaleToSize width height $ mkColorMap (cm . fromToS start end) , translate (s*width - width/2) 0 $ center $ withStrokeColor "black" $ - mkLine (Num 0, Num 0) (Num 0, Num height) + mkLine (0, 0) (0, height) , center $ --withStrokeWidth (Num 0.5) $ withStrokeColor "white" $ withFillOpacity 0 $ - mkRect (Num width) (Num height) + mkRect width height , translate (s*width - width/2) (height) $ scale 0.3 $ centerX $ @@ -269,26 +255,27 @@ mkColorMap f = center $ embedImage img drawPixelImage :: Double -> Double -> Animation -drawPixelImage start end = mkAnimation 2 $ do - limit <- getSignal $ signalFromTo start end $ signalCurve 2 - emit $ scaleToSize screenWidth screenHeight $ center $ embedImage $ - limitGreyPixels (floor (limit*255)) monalisaLarge +drawPixelImage start end = mkAnimation 2 $ \t -> + let limit = fromToS start end $ curveS 2 t + in scaleToSize screenWidth screenHeight $ center $ embedImage $ + limitGreyPixels (floor (limit*255)) monalisaLarge drawHexPixels :: Animation -drawHexPixels = mkAnimation 1 $ do - when highdef $ - emit $ defs - emit $ withFillOpacity 1 $ withStrokeWidth (Num 0) $ withFillColor "white" $ +drawHexPixels = mkAnimation 1 $ \_ -> + mkGroup + [ if highdef then defs else None + , withFillOpacity 1 $ withStrokeWidth 0 $ withFillColor "white" $ mkGroup [ translate ((fromIntegral x+0.5)/fromIntegral width*screenWidth - screenWidth/2) (screenHeight/2 - (fromIntegral y+0.5)/fromIntegral height*screenHeight) $ if highdef then mkUse ("tag" ++ show r) - else mkCircle (Num 0.5) + else mkCircle 0.5 | x <- [0..width-1] , y <- [0..height-1] , let pixel@(PixelRGB8 r _ _) = pixelAt monalisa x y ] + ] where defs = preRender $ mkDefinitions images getNthSet n = centerX $ snd (splitGlyphs [n*2,n*2+1] allGlyphs) @@ -309,14 +296,7 @@ drawHexPixels = mkAnimation 1 $ do fadeIn :: Double -> Animation -> Animation -fadeIn fadeDuration (Animation d genFrame) = Animation d $ do - t <- askTime - mapF (withGroupOpacity (max 0 $ min 1 (t/fadeDuration))) genFrame +fadeIn t = applyE (overBeginning t fadeInE) fadeOut :: Double -> Animation -> Animation -fadeOut fadeDuration (Animation d genFrame) = Animation d $ do - t <- askTime - mapF (withGroupOpacity (max 0 $ min 1 ((d-t)/fadeDuration))) genFrame - -askTime :: Frame Time -askTime = Frame $ \_dur t -> return t +fadeOut t = applyE (overEnding t fadeOutE) diff --git a/videos/sorting-algorithms/sorting-algorithms.hs b/videos/sorting-algorithms/sorting-algorithms.hs index 77ca709..38a7fb9 100755 --- a/videos/sorting-algorithms/sorting-algorithms.hs +++ b/videos/sorting-algorithms/sorting-algorithms.hs @@ -1,63 +1,61 @@ #!/usr/bin/env stack -- stack --resolver lts-13.14 runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Main (main) where -import Control.Lens () +import Control.Lens () -import Graphics.SvgTree (Number(..), Tree) -import Reanimate.Driver (reanimate) -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Svg -import Reanimate.Signal -import Reanimate.ColorMap import Codec.Picture.Types +import Data.Fixed +import Data.List +import qualified Data.Text as T +import qualified Geom2D.CubicBezier as Bezier +import Graphics.SvgTree (Number (..), Tree) import Numeric -import qualified Data.Text as T -import qualified Geom2D.CubicBezier as Bezier -import Data.Fixed -import System.Random.Shuffle -import System.Random -import Data.List +import Reanimate.Animation +import Reanimate.ColorMap +import Reanimate.Driver (reanimate) +import Reanimate.LaTeX +import Reanimate.Signal +import Reanimate.Svg +import System.Random +import System.Random.Shuffle fixed :: Tree -> Animation -> Animation -fixed svg ani = mkAnimation 0 (emit svg) `sim` ani +fixed svg ani = animate (const svg) `parA` ani digitWidth = 25 digitCount = 10 main :: IO () main = reanimate $ fixed bg $ pauseAtEnd 1 $ - mkAnimation 5 $ do - s <- getSignal $ signalLinear - emit $ withFillColor "white" $ translate (negate $ digitWidth*digitCount/2) 0 $ + mkAnimation 5 $ \t -> + withFillColor "white" $ translate (negate $ digitWidth*digitCount/2) 0 $ -- sortingTransition (zip [9,0,1,2,3,4,5,6,8,7] squares) s -- sortingTransition (zip [9,0,1,2,3,4,5,6,8,7] digits) s -- sortingTransition (zip [1,0,2,3,4,5,6,7,8,9] digiSquares) s -- jumpTransition (zip [1,0,2,3,4,5,6,7,8,9] digiSquares) s - renderSortElements (mkJumpSorted lst) s + renderSortElements (mkJumpSorted lst) t where seed = 0xDEADBEEF lst = shuffle' (zip [0..] digiSquares) 10 (mkStdGen seed) bg = mkBackground "black" msg = "0 1 2 3 4 5 6 7 8 9" digits = - map (withStrokeColor "black" . withStrokeWidth (Num 0.2)) $ + map (withStrokeColor "black" . withStrokeWidth 0.2) $ map (lowerTransformations . scale 3 . pathify . center . latex . T.pack . show) [0..9] squares = map center [ withFillColorPixel (promotePixel $ viridis (n/9)) $ - mkRect (Num $ digitWidth+0.2) (Num digitWidth) | n <- [0..9]] + mkRect (digitWidth+0.2) digitWidth | n <- [0..9]] digiSquares = zipWith (\a b -> mkGroup [a,b]) squares digits -- msg = "Eve" glyphs = lowerTransformations $ scale 3 $ pathify $ center $ latexAlign msg - fillText = mkAnimation 1 $ do - s <- getSignal signalLinear - sat <- getSignal $ signalFromTo 0 0.7 signalLinear - emit $ withFillColor "white" $ withStrokeColor "white" $ withStrokeWidth (Num $ 0.4 * (1-s)) $ - withFillOpacity s glyphs + fillText = mkAnimation 1 $ \t -> + let sat = fromToS 0 0.7 t in + withFillColor "white" $ withStrokeColor "white" $ withStrokeWidth (0.4 * (1-t)) $ + withFillOpacity t glyphs -- withSubglyphs [0] (withFillColorPixel $ toRGBString sat 0.0) $ -- withSubglyphs [1] (withFillColorPixel $ toRGBString sat 0.1) $ -- withSubglyphs [2] (withFillColorPixel $ toRGBString sat 0.2) $ @@ -69,22 +67,20 @@ main = reanimate $ fixed bg $ pauseAtEnd 1 $ -- withSubglyphs [8] (withFillColorPixel $ toRGBString sat 0.8) $ -- withSubglyphs [9] (withFillColorPixel $ toRGBString sat 0.9) $ -- glyphs - drawText = mkAnimation 2 $ do - s <- getSignal signalLinear - emit $ - withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.4) $ - partialSvg s glyphs + drawText = mkAnimation 2 $ \t -> + withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth 0.4 $ + partialSvg t glyphs data Direction = Up | Down | Sideways type Delay = Double type Position = Int data SortElement = SortElement - { sortElementDirection :: Direction - , sortElementStartTime :: Double - , sortElementDuration :: Double + { sortElementDirection :: Direction + , sortElementStartTime :: Double + , sortElementDuration :: Double , sortElementStartPosition :: Position - , sortElementEndPosition :: Position - , sortElementTree :: Tree } + , sortElementEndPosition :: Position + , sortElementTree :: Tree } mkJumpSorted :: [(Int, Tree)] -> [SortElement] @@ -100,7 +96,7 @@ mkJumpSorted = fixParameters . worker Up . zip [0..] , sortElementEndPosition = target , sortElementTree = elt } : worker (flip dir) (yoink target rest) - flip Up = Down + flip Up = Down flip Down = Up -- 10 @@ -150,13 +146,13 @@ renderSortElement SortElement{..} t | t > sortElementStartTime + sortElementDuration = translate (fromIntegral sortElementEndPosition * digitWidth) 0 sortElementTree | otherwise = - let pos = signalCurve 2 $ (t - sortElementStartTime) / sortElementDuration + let pos = curveS 2 $ (t - sortElementStartTime) / sortElementDuration from = sortElementStartPosition to = sortElementEndPosition linear = fromIntegral from + (fromIntegral (to-from))*pos y = case sortElementDirection of - Down -> (sin (pos*pi) * digitWidth) - Up -> negate (sin (pos*pi) * digitWidth) + Down -> (sin (pos*pi) * digitWidth) + Up -> negate (sin (pos*pi) * digitWidth) Sideways -> 0 in translate (linear * digitWidth) y sortElementTree diff --git a/viewer/build/asset-manifest.json b/viewer/build/asset-manifest.json index 46609f2..5cc8a98 100644 --- a/viewer/build/asset-manifest.json +++ b/viewer/build/asset-manifest.json @@ -1,13 +1,13 @@ { "main.css": "./static/css/main.f7ad3e9b.chunk.css", - "main.js": "./static/js/main.c36ecb4a.chunk.js", - "main.js.map": "./static/js/main.c36ecb4a.chunk.js.map", + "main.js": "./static/js/main.b15b405f.chunk.js", + "main.js.map": "./static/js/main.b15b405f.chunk.js.map", "runtime~main.js": "./static/js/runtime~main.9eb600ee.js", "runtime~main.js.map": "./static/js/runtime~main.9eb600ee.js.map", - "static/js/2.772a56e7.chunk.js": "./static/js/2.772a56e7.chunk.js", - "static/js/2.772a56e7.chunk.js.map": "./static/js/2.772a56e7.chunk.js.map", + "static/js/2.822530b2.chunk.js": "./static/js/2.822530b2.chunk.js", + "static/js/2.822530b2.chunk.js.map": "./static/js/2.822530b2.chunk.js.map", "index.html": "./index.html", - "precache-manifest.2267f062fb7f449c2505790eb4da5a8a.js": "./precache-manifest.2267f062fb7f449c2505790eb4da5a8a.js", + "precache-manifest.ea495bbf63da838cb91204dca53ee4e1.js": "./precache-manifest.ea495bbf63da838cb91204dca53ee4e1.js", "service-worker.js": "./service-worker.js", "static/css/main.f7ad3e9b.chunk.css.map": "./static/css/main.f7ad3e9b.chunk.css.map" } \ No newline at end of file diff --git a/viewer/build/index.html b/viewer/build/index.html index 34b5d20..9a630c6 100644 --- a/viewer/build/index.html +++ b/viewer/build/index.html @@ -1 +1 @@ -Reanimate Playground
\ No newline at end of file +Reanimate Playground
\ No newline at end of file diff --git a/viewer/build/precache-manifest.2267f062fb7f449c2505790eb4da5a8a.js b/viewer/build/precache-manifest.2267f062fb7f449c2505790eb4da5a8a.js deleted file mode 100644 index 5d1ed97..0000000 --- a/viewer/build/precache-manifest.2267f062fb7f449c2505790eb4da5a8a.js +++ /dev/null @@ -1,22 +0,0 @@ -self.__precacheManifest = [ - { - "revision": "9eb600ee07a27cdad64f", - "url": "./static/js/runtime~main.9eb600ee.js" - }, - { - "revision": "c36ecb4adbf262048a84", - "url": "./static/js/main.c36ecb4a.chunk.js" - }, - { - "revision": "772a56e764e5091f7538", - "url": "./static/js/2.772a56e7.chunk.js" - }, - { - "revision": "c36ecb4adbf262048a84", - "url": "./static/css/main.f7ad3e9b.chunk.css" - }, - { - "revision": "430dab2dbf19c65bee33ef88f2b90bd1", - "url": "./index.html" - } -]; \ No newline at end of file diff --git a/viewer/build/service-worker.js b/viewer/build/service-worker.js index 343fa6e..7d2475d 100644 --- a/viewer/build/service-worker.js +++ b/viewer/build/service-worker.js @@ -14,7 +14,7 @@ importScripts("https://storage.googleapis.com/workbox-cdn/releases/3.6.3/workbox-sw.js"); importScripts( - "./precache-manifest.2267f062fb7f449c2505790eb4da5a8a.js" + "./precache-manifest.ea495bbf63da838cb91204dca53ee4e1.js" ); workbox.clientsClaim(); diff --git a/viewer/build/static/js/2.772a56e7.chunk.js b/viewer/build/static/js/2.772a56e7.chunk.js deleted file mode 100644 index b128397..0000000 --- a/viewer/build/static/js/2.772a56e7.chunk.js +++ /dev/null @@ -1,2 +0,0 @@ -(window.webpackJsonp=window.webpackJsonp||[]).push([[2],[function(e,t,n){"use strict";e.exports=n(11)},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 l(e){for(var t=1;tR.length&&R.push(e)}function U(e,t,n){return null==e?0:function e(t,n,r,l){var a=typeof t;"undefined"!==a&&"boolean"!==a||(t=null);var u=!1;if(null===t)u=!0;else switch(a){case"string":case"number":u=!0;break;case"object":switch(t.$$typeof){case i:case o:u=!0}}if(u)return r(l,t,""===n?"."+D(t,0):n),1;if(u=0,n=""===n?".":n+":",Array.isArray(t))for(var c=0;cthis.eventPool.length&&this.eventPool.push(e)}function fe(e){e.eventPool=[],e.getPooled=ce,e.release=se}l(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=oe)},stopPropagation:function(){var e=this.nativeEvent;e&&(e.stopPropagation?e.stopPropagation():"unknown"!==typeof e.cancelBubble&&(e.cancelBubble=!0),this.isPropagationStopped=oe)},persist:function(){this.isPersistent=oe},isPersistent:ae,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=ae,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 i=new t;return l(i,n.prototype),n.prototype=i,n.prototype.constructor=n,n.Interface=l({},r.Interface,e),n.extend=r.extend,fe(n),n},fe(ue);var de=ue.extend({data:null}),pe=ue.extend({data:null}),me=[9,13,27,32],he=$&&"CompositionEvent"in window,ye=null;$&&"documentMode"in document&&(ye=document.documentMode);var ve=$&&"TextEvent"in window&&!ye,ge=$&&(!he||ye&&8=ye),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(" ")}},we=!1;function xe(e,t){switch(e){case"keyup":return-1!==me.indexOf(t.keyCode);case"keydown":return 229!==t.keyCode;case"keypress":case"mousedown":case"blur":return!0;default:return!1}}function Te(e){return"object"===typeof(e=e.detail)&&"data"in e?e.data:null}var Se=!1;var _e={eventTypes:ke,extractEvents:function(e,t,n,r){var l=void 0,i=void 0;if(he)e:{switch(e){case"compositionstart":l=ke.compositionStart;break e;case"compositionend":l=ke.compositionEnd;break e;case"compositionupdate":l=ke.compositionUpdate;break e}l=void 0}else Se?xe(e,n)&&(l=ke.compositionEnd):"keydown"===e&&229===n.keyCode&&(l=ke.compositionStart);return l?(ge&&"ko"!==n.locale&&(Se||l!==ke.compositionStart?l===ke.compositionEnd&&Se&&(i=ie()):(re="value"in(ne=r)?ne.value:ne.textContent,Se=!0)),l=de.getPooled(l,t,n,r),i?l.data=i:null!==(i=Te(n))&&(l.data=i),H(l),i=l):i=null,(e=ve?function(e,t){switch(e){case"compositionend":return Te(t);case"keypress":return 32!==t.which?null:(we=!0,be);case"textInput":return(e=t.data)===be&&we?null:e;default:return null}}(e,n):function(e,t){if(Se)return"compositionend"===e||!he&&xe(e,t)?(e=ie(),le=re=ne=null,Se=!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