diff --git a/examples/boundingbox.hs b/examples/boundingbox.hs new file mode 100644 --- /dev/null +++ b/examples/boundingbox.hs @@ -0,0 +1,46 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Graphics.SvgTree (Tree) +import Reanimate + +main :: IO () +main = reanimate bbox + +bbox :: Animation +bbox = bg `parA` + mapA (translate (-screenWidth/4) 0) bbox1 `parA` + mapA (translate (screenWidth/4) 0) bbox2 + where + bg = animate $ const $ mkBackground "black" + +bbox1 :: Animation +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 = playThenReverseA $ mkAnimation 2.5 $ \t -> + mkGroup + [ mkBoundingBox $ partialSvg t heartShape + , withStrokeColor "white" $ withFillOpacity 0 $ + partialSvg t heartShape ] + +mkBoundingBox :: Tree -> Tree +mkBoundingBox svg = withStrokeColor "red" $ withFillOpacity 0 $ + translate (x+w/2) (y+h/2) $ + 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\ + \a20.0 20.0 90.0 0 1 0.0,40.0\ + \a20.0 20.0 90.0 0 1 -40.0,0.0 Z" diff --git a/examples/colormaps.hs b/examples/colormaps.hs new file mode 100644 --- /dev/null +++ b/examples/colormaps.hs @@ -0,0 +1,80 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Codec.Picture +import qualified Data.Colour.CIE as CIE +import Data.Colour.CIE.Illuminant (d65) +import Data.Colour.RGBSpace +import Data.Colour.SRGB +import Data.Word +import Graphics.SvgTree (Tree) +import Reanimate + +-- Cycle the animation if we want to upload it to youtube. +youtube :: Animation -> Animation +-- youtube = repeatAnimation 6 +youtube = id + +main :: IO () +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 + in mkGroup + [ mkBackground "black" + , translate 0 (screenHeight/2*0.85) $ withFillColor "white" $ mkGroup + [ 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 (offsetWidth/2+1.5) textYOffset $ + scale 0.5 $ centerX $ latex "Greyscale" + ] + , translate (-columnX) (rowInit-rowStep*0) $ mkOutline "viridis" (dimmer s . viridis) + , translate (-columnX) (rowInit-rowStep*1) $ mkOutline "inferno" (dimmer s . inferno) + , translate (-columnX) (rowInit-rowStep*2) $ mkOutline "cividis" (dimmer s . cividis) + , translate (-columnX) (rowInit-rowStep*3) $ mkOutline "jet" (dimmer s . jet) + , translate (-columnX) (rowInit-rowStep*4) $ mkOutline "turbo" (dimmer s . turbo) + + , translate (columnX) (rowInit-rowStep*0) $ mkOutline "magma" (dimmer s . magma) + , translate (columnX) (rowInit-rowStep*1) $ mkOutline "plasma" (dimmer s . plasma) + , translate (columnX) (rowInit-rowStep*2) $ mkOutline "sinebow" (dimmer s . sinebow) + , translate (columnX) (rowInit-rowStep*3) $ mkOutline "hsv" (dimmer s . hsv) + , translate (columnX) (rowInit-rowStep*4) $ mkOutline "parula" (dimmer s . parula) + ] + where + rowInit = 2.2 + rowStep = 1.2 + columnX = screenWidth/4 + + mkOutline label f = + mkGroup + [ 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 + ] + scaleWidth = screenWidth/8*3 + scaleHeight = screenHeight/20 + +mkColorMap :: (Double -> PixelRGB8) -> Tree +mkColorMap f = center $ embedImage img + where + width = 1000 + height = 1 + img = generateImage pixelRenderer width height + pixelRenderer x _y = f (fromIntegral x / fromIntegral width) + +dimmer :: Double -> PixelRGB8 -> PixelRGB8 +dimmer switch (PixelRGB8 r g b) = + PixelRGB8 r' g' b' + where + (lStar, aStar, bStar) = CIE.cieLABView d65 (sRGBBounded r g b :: Colour Double) + RGB r' g' b' = toSRGBBounded $ CIE.cieLAB d65 lStar (aStar*c) (bStar*c) :: RGB Word8 + c = 1-switch diff --git a/examples/counter.golden b/examples/counter.golden new file mode 100644 --- /dev/null +++ b/examples/counter.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/counter.hs b/examples/counter.hs new file mode 100644 --- /dev/null +++ b/examples/counter.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate + +main :: IO () +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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 100644 --- /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 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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_rgbComponents.hs b/examples/doc_rgbComponents.hs new file mode 100644 --- /dev/null +++ b/examples/doc_rgbComponents.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Interpolate +import Reanimate.Builtin.Documentation +import Codec.Picture + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ showColorMap $ interpolateRGB8 rgbComponents yellow blue + where + yellow = PixelRGB8 0xFF 0xFF 0x00 + blue = PixelRGB8 0x00 0x00 0xFF diff --git a/examples/doc_seqA.hs b/examples/doc_seqA.hs new file mode 100644 --- /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 --- /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 --- /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_ternaryPlot.hs b/examples/doc_ternaryPlot.hs new file mode 100644 --- /dev/null +++ b/examples/doc_ternaryPlot.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate hiding (raster) +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.TernaryPlot +import Reanimate.Interpolate +import Data.Colour.CIE +import Codec.Picture.Types + +main :: IO () +main = reanimate $ docEnv $ animate $ const $ + ternaryPlot 1024 (\a b c -> promotePixel $ toRGB8 $ cieXYZ a b c) diff --git a/examples/doc_turbo.hs b/examples/doc_turbo.hs new file mode 100644 --- /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 --- /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 100644 --- /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 new file mode 100644 --- /dev/null +++ b/examples/fourier.hs @@ -0,0 +1,95 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.Complex +import qualified Data.Text as T + +import Graphics.SvgTree +import Reanimate.Driver (reanimate) +import Reanimate.LaTeX (latex) +import Reanimate.Animation +import Reanimate.Svg +import Reanimate.Signal +import Reanimate.Constants + +waveMultiplier :: Int +-- waveMultiplier = 1 -- Sawtooth wave +waveMultiplier = 2 -- Square wave + +main :: IO () +main = reanimate $ + 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 = 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 ] + , withStrokeWidth sWidth $ + withFillColor "white" $ + translate (-screenWidth/8*3) (screenHeight/8*3) $ + latex $ T.pack $ "Circles: " ++ show nCircles ] + +drawNCircles :: Int -> Double -> Tree +drawNCircles totalCircles phi = mkGroup + [ worker circles + , let x :+ y = sum circles in + withStrokeWidth sWidth $ + withStrokeColor "white" $ + mkLine (x, y) (screenWidth/4, y) ] + where + circles = [ nthCircle n phi | n <- [0..totalCircles-1] ] + worker [] = None + worker (x :+ y : rest) = + let radius = sqrt(x*x+y*y) in + mkGroup + [ withStrokeWidth sWidth $ + withStrokeColor "grey" $ + withFillOpacity 0 $ + mkCircle radius + , translate x y $ worker rest + , withStrokeWidth sWidth $ + withStrokeColor "white" $ + 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) $ + cycle $ [ fourierYValue nCircles phi + | x <- reverse [1..granularity] + , let phi = 2*pi*(x/granularity) + ] + where + granularity = 500 + +fourierYValue :: Int -> Double -> Double +fourierYValue n phi = + imagPart (sum [ nthCircle i phi | i <- [0..n-1]]) + +nthCircle :: Int -> Double -> Complex Double +nthCircle n phi = x :+ y + where + n' = fromIntegral (n*waveMultiplier+1) + x = cos (n'*phi) * radius + y = sin (n'*phi) * radius + radius = 2.5 * (2 / (n'*pi)) diff --git a/examples/fourier_draw.hs b/examples/fourier_draw.hs new file mode 100644 --- /dev/null +++ b/examples/fourier_draw.hs @@ -0,0 +1,122 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.Complex +import qualified Data.Text as T +import Graphics.SvgTree +import Linear.V2 +import Reanimate + +main :: IO () +main = reanimate $ pauseAtEnd 2 $ + fourierAnimation_ + +sWidth :: Double +sWidth = 0.02 + +piFourier :: Fourier +piFourier = mkFourier piPoints + +piPoints :: [RPoint] +piPoints = lineToPoints 500 $ + toLineCommands $ extractPath $ scale 10 $ center $ latexAlign "\\pi" + + +fourierAnimation_ :: Animation +fourierAnimation_ = mkAnimation 50 $ \t -> + let fLength = t + circles = setFourierLength (fLength*maxLength) piFourier + maxLength = sum $ map magnitude $ take 499 $ drop 1 $ fourierCoefficients piFourier + phi = fromToS 0 15 t + in mkGroup + [ mkBackground "black" + , drawCircles $ fourierCoefficients $ rotateFourier phi circles + , withStrokeColor "green" $ + withFillOpacity 0 $ + mkLinePath $ mkFourierOutline circles + , withFillColor "white" $ + translate (-screenWidth/16*7) (screenHeight/16*7) $ + latex $ T.pack $ "Circles: " ++ show (length $ fourierCoefficients circles) + ] + +data Fourier = Fourier {fourierCoefficients :: [Complex Double]} + +pointAtFourier :: Fourier -> Complex Double +pointAtFourier = sum . fourierCoefficients + +mkFourier :: [RPoint] -> Fourier +mkFourier points = Fourier $ findCoefficient 0 : + concat [ [findCoefficient n, findCoefficient (-n)] | n <- [1..] ] + where + findCoefficient :: Int -> Complex Double + findCoefficient n = + sum [ toComplex point * exp (negate (fromIntegral n) * 2 *pi * i*t) * deltaT + | (idx, point) <- zip [0::Int ..] points, let t = fromIntegral idx/nPoints ] + i = 0 :+ 1 + toComplex (V2 x y) = x :+ y + deltaT = recip nPoints + nPoints = fromIntegral (length points) + + +-- 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 _ (Fourier []) = Fourier [] +setFourierLength len0 (Fourier (first:lst)) = Fourier $ first : worker len0 lst + where + worker _len [] = [] + worker len (c:cs) = + if magnitude c < len + then c : worker (len - magnitude c) cs + else [c * (realToFrac (len / magnitude c))] + +rotateFourier :: Double -> Fourier -> Fourier +rotateFourier phi (Fourier coeffs) = + Fourier $ worker (coeffs) (0::Integer) + where + worker [] _ = [] + worker (x:rest) 0 = x : worker rest 1 + worker [left] n = worker [left,0] n + worker (left:right:rest) n = + let n' = fromIntegral n in + left * exp (negate n' * 2 * pi * i * phi') : + right * exp (n' * 2 * pi * i * phi') : + worker rest (n+1) + i = 0 :+ 1 + -- n = length coeffs `div` 2 + phi' = realToFrac phi + +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 ] ] + where + worker [] = None + worker (x :+ y : rest) = + let radius = sqrt(x*x+y*y) in + mkGroup + [ withStrokeWidth sWidth $ + withStrokeColor "dimgrey" $ + withFillOpacity 0 $ + mkCircle radius + , translate x y $ worker rest ] + +mkFourierOutline :: Fourier -> [(Double, Double)] +mkFourierOutline fourier = + [ (x, y) + | idx <- [0 .. granularity] + , let x :+ y = pointAtFourier $ rotateFourier (idx/granularity) fourier + ] + where + granularity = 500 diff --git a/examples/goo.golden b/examples/goo.golden new file mode 100644 --- /dev/null +++ b/examples/goo.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/goo.hs b/examples/goo.hs new file mode 100644 --- /dev/null +++ b/examples/goo.hs @@ -0,0 +1,63 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Lens + +import Graphics.SvgTree +import Reanimate + +main :: IO () +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") + ] + where + sharpness = 10 :: Integer + dev = 0.2 + radius = 1 + 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 new file mode 100644 --- /dev/null +++ b/examples/latex_basic.hs @@ -0,0 +1,17 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate + +main :: IO () +main = reanimate $ playThenReverseA $ mkAnimation 2 $ \t -> + mkGroup + [ mkBackground "black" + , withStrokeColor "white" $ withFillOpacity 0 text + , withFillColor "white" $ withFillOpacity t text + ] + where + 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 new file mode 100644 --- /dev/null +++ b/examples/latex_color.hs @@ -0,0 +1,20 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate + +main :: IO () +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 ] + where + svg = withStrokeWidth 0.01 $ scale 4 $ center $ latex "\\LaTeX" diff --git a/examples/latex_draw.hs b/examples/latex_draw.hs new file mode 100644 --- /dev/null +++ b/examples/latex_draw.hs @@ -0,0 +1,20 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Reanimate + +main :: IO () +main = reanimate $ + bg `parA` (playThenReverseA $ drawText `andThen` fillText) + where + bg = animate $ const $ mkBackground "black" + msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" + 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 t glyphs diff --git a/examples/latex_wheel.hs b/examples/latex_wheel.hs new file mode 100644 --- /dev/null +++ b/examples/latex_wheel.hs @@ -0,0 +1,81 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +module Main (main) where + +import Control.Monad (forM_) +import Graphics.SvgTree (Tree) +import Reanimate +import Reanimate.Driver (reanimate) +import Reanimate.Effect + +main :: IO () +main = reanimate $ bg `parA` mainScene + where + bg = animate $ const $ mkBackground "black" + +mainScene :: Animation +mainScene = sceneAnimation $ mdo + play $ drawCircle + # setDuration drawCircleT + # applyE (constE $ scaleXY (-1) 1) + fork $ play $ drawCircle + # freezeAtPercentage 1 + # setDuration rotDur + rotDur <- withSceneDuration $ waitAll $ + forM_ svgs $ \svg -> do + fork $ play $ drawTick + # setDuration rotateT + # repeatA rotateN + # applyE (overBeginning 0.5 drawInE) + # applyE (overEnding 0.5 drawOutE) + fork $ play $ drawSVG svg + # setDuration rotateT + # repeatA rotateN + # applyE (overBeginning rotateT drawInE) + # applyE (delayE rotateT $ overBeginning 1 fillInE) + # applyE (overEnding 0.5 fadeOutE) + wait (rotateT / fromIntegral (1+length svgs)) + play $ drawCircle + # setDuration drawCircleT + # reverseA + return () + where + drawCircleT = 1 + rotateT = 5 + rotateN = 3 + + svgCAF = center $ latex "\\LaTeX" + getNth n = snd (splitGlyphs [n] svgCAF) + svgs = [ + withStrokeWidth 0.01 $ + scale 2 $ + translate 0 (tickLength*2) $ + withStrokeColor "white" $ + withFillColor "white" $ + center $ getNth n + | n <- [0..4]] + +radius, tickLength :: Double +radius = 1.25 +tickLength = 0.25 + +drawCircle :: Animation +drawCircle = animate $ \t -> + withFillOpacity 0 $ + withStrokeColor "white" $ + rotate (-90) $ + partialSvg t circPath + where + circPath = pathify $ mkCircle radius + +drawTick :: Animation +drawTick = drawSVG $ mkLine (0, 0) (0, tickLength) + +drawSVG :: Tree -> Animation +drawSVG svg = animate $ \t -> + withStrokeColor "white" $ + rotate (t*360) $ + translate 0 radius $ + svg diff --git a/examples/polyshape_test1.hs b/examples/polyshape_test1.hs new file mode 100644 --- /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 100644 --- /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/polyshape_test3.hs b/examples/polyshape_test3.hs new file mode 100644 --- /dev/null +++ b/examples/polyshape_test3.hs @@ -0,0 +1,49 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Reanimate +import Reanimate.PolyShape +import qualified Geom2D.CubicBezier as G + +polygonTest :: Animation +polygonTest = mkAnimation 10 $ \t -> + let original = + renderPolyShapes [iShape] + originalP = + renderPolyShapes $ map (plPartial t) [iShape] + decomposed = + renderPolyShapes $ + map plFromPolygon $ plDecompose [iShape] + decomposedP = + renderPolyShapes $ map (plPartial' t) $ concat $ plGroupTouching $ + map plFromPolygon $ plDecompose $ [iShape] + in std $ gridLayout + [[original, originalP] + ,[decomposed, decomposedP]] + where + std = + withFillOpacity 1 . + withFillColor "blue" . + withStrokeWidth 0.02 . + withStrokeColor "white" + +main :: IO () +main = reanimate $ bg `parA` polygonTest + where + bg = animate $ const $ mkBackground "black" + +iShape :: PolyShape +iShape = PolyShape $ G.ClosedPath + [(G.Point 2 2, G.JoinLine) + ,(G.Point 0 2, G.JoinLine) + ,(G.Point 0 1, G.JoinLine) + ,(G.Point 1 1, G.JoinLine) + ,(G.Point 1 0, G.JoinLine) + ,(G.Point 3 0, G.JoinLine) + ,(G.Point 3 1, G.JoinLine) + ,(G.Point 4 1, G.JoinLine) + ,(G.Point 4 2, G.JoinLine) + ] diff --git a/examples/polyshape_test4.hs b/examples/polyshape_test4.hs new file mode 100644 --- /dev/null +++ b/examples/polyshape_test4.hs @@ -0,0 +1,34 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Reanimate +import Reanimate.PolyShape + +polygonTest :: Animation +polygonTest = mapA std $ + let shapes = svgToPolyShapes $ center $ scale 6 $ latex "$\\infty$" + groups = + plGroupTouching $ + map plFromPolygon $ plDecompose $ shapes + -- totalLen = sum $ map (maximum . map (plArea.snd)) groups + totalLen = fromIntegral $ length groups + anis = [ setDuration dur $ animate $ \t -> renderPolyShapes $ map (plPartial' t) group + | group <- groups + , let groupLen = 1 -- maximum (map (plArea.snd) group) + dur = groupLen/totalLen * totalT ] + in foldr andThen (pause 0) anis + where + totalT = 5 + std = + withFillOpacity 1 . + withFillColor "blue" . + withStrokeWidth 0.00 . + withStrokeColor "white" + +main :: IO () +main = reanimate $ bg `parA` polygonTest + where + bg = animate $ const $ mkBackground "black" diff --git a/examples/raster.golden b/examples/raster.golden new file mode 100644 # file too large to diff: examples/raster.golden diff --git a/examples/raster.hs b/examples/raster.hs new file mode 100644 --- /dev/null +++ b/examples/raster.hs @@ -0,0 +1,16 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Codec.Picture + +main :: IO () +main = reanimate $ mkAnimation 5 $ \t -> + mkGroup + [ mkBackground "black" + , rotate (t*360) $ scaleToWidth 6 $ embedImage img + ] + where + img = generateImage pixelRenderer 255 255 + pixelRenderer x y = PixelRGB8 (fromIntegral x) (fromIntegral y) 128 diff --git a/examples/shatter.hs b/examples/shatter.hs new file mode 100644 --- /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 new file mode 100644 --- /dev/null +++ b/examples/signals.hs @@ -0,0 +1,89 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Data.Monoid ((<>)) +import Data.Text (Text, pack) +import Graphics.SvgTree hiding (Text) +import Numeric +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 (\_ -> ([], "[]")) + `seqA` + curvesExample (\s -> + ( [(1, constantS s)] + , "[(1, constantS " <> ppD s <> ")]")) + `seqA` + curvesExample (\s -> + ( [(s, constantS 0), (1, id)] + , "[(" <> ppD s <> ", constantS 0), (1, id)]")) + `seqA` + curvesExample (\s -> + ( [(s, constantS 1), (1, reverseS)] + , "[(" <> ppD s <> ", constantS 1), (1, reverseS)]")) + `seqA` + curvesExample (\s -> + ( [(1, curveS (2+s*3))] + , "[(1, curveS "<> ppD (2+s*3) <>")]")) + `seqA` + curvesExample (\s -> + ( [(1, fromToS s 1 . curveS 5)] + , "[(1, fromToS "<> ppD s <>" 1 \\$ curveS 5)]")) + `seqA` + curvesExample (\s -> + ( [(1, bellS (2+s*3))] + , "[(1, bellS "<> ppD (2+s*3)<>")]")) + where + 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 $ \t -> + mkGroup + [ mkBackground "black" + , withFillColor "white" $ + translate 0 (screenHeight*0.35) $ + center $ latex "Signals" + , let (curveFns, name) = gen t in + center $ + mkGroup + [ withStrokeColor "white" $ withStrokeWidth 0.01 $ + mkGroup + [ mkLine (0, 0) + (convertX 200, 0) + , mkLine (0, 0) + (0, convertY 50) ] + , withStrokeColor "white" $ withStrokeWidth 0.01 $ + mkGroup + [ mkLine (0, convertX $ y) + (convertX 200, convertX y) + | y <- [10,20,30,40,50] ] + , withFillColor "white" $ + mkGroup + [ translate (convertX $ -5) (convertX $ -5) $ scale 0.5 $ center $ latex "0" + , 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 0.5 $ + lowerTransformations $ scaleXY (convertX $ 200) (convertX $ (50)) $ mkSignalLine (fromListS curveFns) + ] + ] + +mkSignalLine :: Signal -> Tree +mkSignalLine fn = mkLinePath + [ (x/steps, fn (x/steps)) + | x <- [0 .. steps] ] + where + steps = 1000 diff --git a/examples/simulate_equation.hs b/examples/simulate_equation.hs new file mode 100644 --- /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.golden b/examples/simulate_gravity.golden new file mode 100644 --- /dev/null +++ b/examples/simulate_gravity.golden @@ -0,0 +1,50 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +13 +14 +15 +16 +17 +18 +19 +20 +21 +22 +23 +24 +25 +26 +27 +28 +29 +30 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 diff --git a/examples/simulate_gravity.hs b/examples/simulate_gravity.hs new file mode 100644 --- /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 new file mode 100644 --- /dev/null +++ b/examples/sorting.hs @@ -0,0 +1,240 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module Main (main) where + +import Codec.Picture +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 Reanimate +import System.Random +import System.Random.Shuffle + +main :: IO () +main = reanimate $ + 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 $ \t -> + let img = generateImage pixelRenderer width height + seed = round (t * 3000) + pixelRenderer x y = turbo (fromIntegral num / fromIntegral width) + where + num = (sortedDat !! y) V.! x + sortedDat = runSort' seed algo width + -- width = 1024 + width = 500 + height = length sortedDat + in mkGroup + [ mkBackground "black" + + , translate 0 (-screenWidth*0.03) $ center $ scaleXY (-1) 1 $ + scaleToSize 7.5 7.5 $ embedImage img + , translate 0 (screenWidth*0.24) $ withFillColor "white" $ scale 1 $ center $ + latex name + , withFillColor "white" $ + translate (-screenWidth*0.26) (-screenHeight*0.05) $ + rotate (-90) $ scale 0.5 $ center $ + latex "$Time \\rightarrow$" + , withFillColor "white" $ translate ((screenWidth*0.30)) 0 $ + mkCircle ((1-t)*0.5) + ] + where + + +-- main :: IO () +-- main = print $ length $ runSort bubbleSort 2560 + +-- [3,4,1,2] +-- [ + +-- [1,2,3,4] +-- 0 3 +-- half: 0 + 3`div`2 = 1 +-- mergeSort 0 (0+1) +-- mergeSort (0+1) 3 + +data Env s = Env + { envHistory :: [Vector Int] + , envState :: V.MVector s Int } + +type S s a = StateT (Env s) (ST s) a + +-- 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 + arr <- V.thaw (V.fromList lst) + let env = Env [] arr + envHistory <$> execStateT sortFn env) + where + lst = shuffle' [1 .. len] len (mkStdGen seed) + +readS :: Int -> S s Int +readS idx = do + arr <- gets envState + GV.unsafeRead arr idx + +writeS :: Int -> Int -> S s () +writeS idx val = do + arr <- gets envState + GV.unsafeWrite arr idx val + +swapS :: Int -> Int -> S s () +swapS a b = do + arr <- gets envState + GV.unsafeSwap arr a b + +inputLength :: S s Int +inputLength = GV.length <$> gets envState + +snapshot :: S s () +snapshot = do + arr <- gets envState + vec <- V.freeze arr + modify $ \st -> st { envHistory = vec : envHistory st } + +mergeSort :: S s () +mergeSort = do + snapshot + len <- inputLength + mergeSort' 0 (len-1) + +mergeSort' :: Int -> Int -> S s () +mergeSort' start end | start == end = return () +mergeSort' start end = do + let half = start + (end-start) `div` 2 + mergeSort' start half + mergeSort' (half+1) end + leftVals <- mapM readS [start .. half] + rightVals <- mapM readS [half+1 .. end] + zipWithM_ writeS [start..] (merge leftVals rightVals) + snapshot + +merge :: Ord a => [a] -> [a] -> [a] +merge [] xs = xs +merge xs [] = xs +merge (x:xs) (y:ys) + | x < y = x : merge xs (y:ys) + | otherwise = y : merge (x:xs) ys + + +mergeSortUp :: S s () +mergeSortUp = do + snapshot + len <- inputLength + let chunkSizes = takeWhile (< len) $ map (2^) [0::Int ..] + forM_ chunkSizes $ bottomUpMergeSort' + +bottomUpMergeSort' :: Int -> S s () +bottomUpMergeSort' chunkSize = do + len <- inputLength + forM_ [0, chunkSize*2 .. len-1] $ \idx -> do + leftVals <- mapM readS (take chunkSize [idx .. len-1]) + rightVals <- mapM readS (take chunkSize (drop chunkSize [idx .. len-1])) + zipWithM_ writeS [idx..] (merge leftVals rightVals) + snapshot + +selectionSort :: S s () +selectionSort = do + snapshot + len <- inputLength + forM_ [0 .. len-1] $ \j -> do + i <- findMin j (j+1) len + swapS j i + snapshot + where + findMin j i len | i >= len = return j + findMin j i len = do + jVal <- readS j + iVal <- readS i + if iVal < jVal + then findMin i (i+1) len + else findMin j (i+1) len + +insertSort :: S s () +insertSort = do + snapshot + len <- inputLength + forM_ [1 .. len-1] $ \j -> do + a <- readS j + worker a j + snapshot + where + worker a 0 = writeS 0 a + worker a j = do + b <- readS (j-1) + if (a < b) + then do + writeS j b + worker a (j-1) + else + writeS j a + + +bubbleSort :: S s () +bubbleSort = do + worker True 0 + where + worker True 0 = do + snapshot + len <- inputLength + worker False (len-1) + worker False 0 = snapshot + worker changed n = do + a <- readS n + b <- readS (n-1) + if a < b + then do + writeS n b + writeS (n-1) a + when (n `mod` 50 == 0) snapshot + worker True (n-1) + else worker changed (n-1) + +quicksort :: S s () +quicksort = do + snapshot + len <- inputLength + worker [(0, len-1)] + where + worker :: [(Int,Int)] -> S s () + worker [] = return () + worker ((lo,hi):rest) = do + pivot <- readS (lo + (hi-lo) `div` 2) + p <- partition pivot lo hi + snapshot + worker $ insertWork (lo, p) $ insertWork (p+1, hi) $ rest + + partition pivot lo hi = do + loVal <- readS lo + hiVal <- readS hi + if loVal < pivot + then partition pivot (lo+1) hi + else if hiVal > pivot + then partition pivot lo (hi-1) + else if lo >= hi + then return hi + else do + writeS lo hiVal + writeS hi loVal + snapshot + partition pivot (lo+1) (hi-1) + + insertWork :: (Int,Int) -> [(Int,Int)] -> [(Int,Int)] + insertWork (lo, hi) rest | lo >= hi = rest + insertWork (lo, hi) [] = [(lo, hi)] + insertWork (lo, hi) ((lo', hi'):rest) + | hi-lo > hi'-lo' = (lo,hi) : (lo', hi') : rest + | otherwise = (lo', hi') : insertWork (lo, hi) rest diff --git a/examples/sphere.hs b/examples/sphere.hs new file mode 100644 --- /dev/null +++ b/examples/sphere.hs @@ -0,0 +1,66 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Main (main) where + +import Reanimate +import Data.String.Here + +main :: IO () +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 + +//Files with predefined colors and textures +#include "colors.inc" +#include "glass.inc" +#include "golds.inc" +#include "metals.inc" +#include "stones.inc" +#include "woods.inc" + +#include "shapes3.inc" + +//Place the camera +camera { + orthographic + angle 50 + location <0,0,-10> + look_at <0,0,0> + right x*image_width/image_height +} + + +//Ambient light to "brighten up" darker pictures +global_settings { ambient_light White*3 } + +//Set a background color +//background { color White } +//background { color rgbt <0.1, 0, 0, 0> } // red +background { color rgbt <0, 0, 0, 1> } // transparent + +//Sphere with specified center point and radius +sphere { + <0,0,0>, 2 + texture { + pigment{ color rgbt <0,0,1,0.1> } + } +} + +object { + Ring_Sphere(2.00, 2.02, 0.015, 0.015, 12, 12) + texture { + pigment{ color<1,1,1> } + } + rotate <0,${s},0> + rotate <-30,0,0> +} + + + |] diff --git a/examples/sunflower.hs b/examples/sunflower.hs new file mode 100644 --- /dev/null +++ b/examples/sunflower.hs @@ -0,0 +1,42 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Data.Colour.Palette.BrewerSet as D +import Diagrams.Prelude hiding (Animation, boundingBox, + center, circle, duration, + fontSize, rotate, scale, + translate) +import qualified Diagrams.Prelude as D +import Reanimate.Diagrams +import Reanimate hiding ((#)) + +main :: IO () +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 + dSvg n = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $ + D.scale 0.2 $ sunflower n + + mkCoords :: [P2 Double] + 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) + + floret :: Double -> SvgDiagram + floret r = D.circle 0.6 # lw none # fc (colors !! n) + where + n = floor (1.4 * sqrt r) `mod` 10 + colors = black : (reverse $ D.brewerSet D.YlOrBr 9) + + sunflower :: Int -> SvgDiagram + sunflower n = frame 4 $ position $ take n $ zip mkCoords florets + where + florets = [ floret (sqrt (fromIntegral i)) | i <- [1::Int ..]] diff --git a/examples/tangent_and_normal.golden b/examples/tangent_and_normal.golden new file mode 100644 --- /dev/null +++ b/examples/tangent_and_normal.golden @@ -0,0 +1,50 @@ +0normaltangent +1normaltangent +2normaltangent +3normaltangent +4normaltangent +5normaltangent +6normaltangent +7normaltangent +8normaltangent +9normaltangent +10normaltangent +11normaltangent +12normaltangent +13normaltangent +14normaltangent +15normaltangent +16normaltangent +17normaltangent +18normaltangent +19normaltangent +20normaltangent +21normaltangent +22normaltangent +23normaltangent +24normaltangent +25normaltangent +26normaltangent +27normaltangent +28normaltangent +29normaltangent +30normaltangent +31normaltangent +32normaltangent +33normaltangent +34normaltangent +35normaltangent +36normaltangent +37normaltangent +38normaltangent +39normaltangent +40normaltangent +41normaltangent +42normaltangent +43normaltangent +44normaltangent +45normaltangent +46normaltangent +47normaltangent +48normaltangent +49normaltangent diff --git a/examples/tangent_and_normal.hs b/examples/tangent_and_normal.hs new file mode 100644 --- /dev/null +++ b/examples/tangent_and_normal.hs @@ -0,0 +1,57 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Diagrams.Prelude hiding (Animation, boundingBox, + center, circle, duration, + fontSize, rotate, scale, + translate) +import qualified Diagrams.Prelude as D +import Reanimate.Diagrams +import Reanimate.Driver (reanimate) +import Reanimate.Animation +import Reanimate.Signal +import Reanimate.Svg + + +main :: IO () +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 ] + where + dia param = + frame 0.5 $ lc white $ + mconcat + [ lc green $ rightAngleSquare + , tangentLine + , fc white $ baselineText "tangent" # D.translate tangentVector + , normalLine + , fc white $ topLeftText "normal" # D.translate (-normalVector) + ] # moveTo pt # D.fontSize large + <> strokeLocTrail spline + where + pts = map p2 [(0,0), (1,1), (2,1), (3,0), (3.5,0)] + + spline :: Located (Trail V2 Double) + spline = cubicSpline False pts + + pt = atParam spline param + tangentVector :: V2 Double + tangentVector = D.normalize $ tangentAtParam spline param + normalVector = D.normalize $ normalAtParam spline param + + symmetricLine :: V2 Double -> SvgDiagram + symmetricLine v = fromOffsets [2 *^ v] # D.center + tangentLine :: SvgDiagram + tangentLine = symmetricLine tangentVector + normalLine = symmetricLine normalVector + + rightAngleSquare :: SvgDiagram + rightAngleSquare = square 0.1 # alignBL # D.rotate (signedAngleBetween tangentVector unitX) diff --git a/examples/vector_field.hs b/examples/vector_field.hs new file mode 100644 --- /dev/null +++ b/examples/vector_field.hs @@ -0,0 +1,57 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Main (main) where + +import Diagrams.Prelude hiding (Animation, boundingBox, + center, circle, duration, + fontSize, rotate, scale, + translate) +import qualified Diagrams.Prelude as D +import Reanimate.Diagrams +import Reanimate hiding ((#)) + + +main :: IO () +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 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) + m = norm $ vectorField (x, y) + +-- Head size is a function of the length of the vector +-- as are tail size and shaft length. + + hs = 0.02 * m + sW = 0.004 * m + sL = 0.05 + 0.1 * m + opts = (with & arrowHead .~ spike + & headLength .~ normalized hs + & shaftStyle %~ lwN sW) + +example :: Double -> SvgDiagram +example n = field + where + xOffset = cos (2*pi*n) + yOffset = sin (2*pi*n) + locs = [(x+xOffset, y+yOffset) | x <- [0.1, 0.3 .. 3.25], y <- [0.1, 0.3 .. 3.25]] + + points = map p2 locs + + arrows = map arrowAtPoint locs + field = position $ zip points arrows diff --git a/reanimate.cabal b/reanimate.cabal --- a/reanimate.cabal +++ b/reanimate.cabal @@ -3,7 +3,7 @@ -- see http://haskell.org/cabal/users-guide/ name: reanimate -version: 0.1.8.0 +version: 0.1.9.0 -- synopsis: -- description: license: PublicDomain @@ -13,7 +13,7 @@ synopsis: Animation library based on SVGs. homepage: https://github.com/Lemmih/reanimate build-type: Simple -extra-source-files: ChangeLog.md +extra-source-files: ChangeLog.md, examples/*.hs, examples/*.golden extra-doc-files: docs/gifs/*.gif @@ -45,8 +45,6 @@ Reanimate.Animation Reanimate.Signal Reanimate.Render - Reanimate.Examples - Reanimate.Combinators Reanimate.LaTeX Reanimate.Svg Reanimate.Svg.Unuse diff --git a/src/Reanimate/Builtin/Documentation.hs b/src/Reanimate/Builtin/Documentation.hs --- a/src/Reanimate/Builtin/Documentation.hs +++ b/src/Reanimate/Builtin/Documentation.hs @@ -2,7 +2,9 @@ import Reanimate.Animation import Reanimate.Svg +import Reanimate.Raster import Reanimate.Constants +import Codec.Picture docEnv :: Animation -> Animation docEnv = mapA $ \svg -> mkGroup @@ -38,3 +40,11 @@ withFillOpacity 1 $ mkCircle 0.5 ] where widthP = 0.8 + +showColorMap :: (Double -> PixelRGB8) -> SVG +showColorMap 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/src/Reanimate/Builtin/TernaryPlot.hs b/src/Reanimate/Builtin/TernaryPlot.hs --- a/src/Reanimate/Builtin/TernaryPlot.hs +++ b/src/Reanimate/Builtin/TernaryPlot.hs @@ -12,8 +12,9 @@ type CCoord = Double -- Creates a centered ternary plot with a width of 5. -raster :: Int -> (ACoord -> BCoord -> CCoord -> PixelRGBA8) -> Tree -raster density fn = +ternaryPlot :: Int -- ^ Pixels in the X-axis. + -> (ACoord -> BCoord -> CCoord -> PixelRGBA8) -> Tree +ternaryPlot density fn = scaleToWidth stdWidth $ translate (-cX) (-cY) $ scaleToWidth 1 $ diff --git a/src/Reanimate/Combinators.hs b/src/Reanimate/Combinators.hs deleted file mode 100644 --- a/src/Reanimate/Combinators.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Reanimate.Combinators where - -type Path = [(Double, Double)] - -approxFnData :: Int -> (Double -> (Double, Double)) -> Path -approxFnData steps fn = - fn 0 : [ fn (fromIntegral n/fromIntegral steps) | n <- [0..steps] ] - -morphPath :: Path -> Path -> Double -> Path -morphPath src dst idx = zipWith worker src dst - where - worker (x1, y1) (x2, y2) = - (x1 + (x2-x1)*idx - ,y1 + (y2-y1)*idx) diff --git a/src/Reanimate/Examples.hs b/src/Reanimate/Examples.hs deleted file mode 100644 --- a/src/Reanimate/Examples.hs +++ /dev/null @@ -1,563 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeFamilies #-} -module Reanimate.Examples where - -{- -import Control.Lens () -import qualified Data.Map as M -import Graphics.SvgTree as S hiding (circle, width) -import Linear.V2 - -import Reanimate.Combinators -import Reanimate.Diagrams -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Signal -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 () -sinewave = proc () -> do - duration 10 -< () - emit -< toHtml $ mkBackground "black" - idx <- signalOscillate 0 1 -< () - emit -< do - defs_ $ clipPath_ [id_ "clip"] $ toHtml $ - mkRect (Num 0, Num (-height)) (Num $ idx*width) (Num 320) - toHtml $ translate margin height $ withStrokeColor "white" $ - withClipPathRef (Ref "clip") $ mkPathText $ renderPathText $ approxFnData 1000 wave - toHtml $ withStrokeColor "white" $ - mkLine (Num margin, Num 10) (Num margin, Num 170) - toHtml $ withStrokeColor "white" $ - mkLine (Num margin, Num height) (Num (margin+width), Num height) - let (circX, circY) = wave idx - emit -< g_ [transform_ $ Lucid.translate margin height] $ - circle_ [num_ cx_ circX, num_ cy_ circY, r_ "3", fill_ "red"] - where - freq = 3; margin = 30; width = 260; height = 90 - wave idx = (idx*width, sin (idx*pi*2*freq) * 50) - -morph_wave :: Ani () -morph_wave = proc () -> do - duration 5 -< () - morph <- signalOscillate 0 1 -< () - emit -< toHtml $ mkBackground "black" - emit -< toHtml $ withStrokeColor "white" $ mkGroup - [ translate 30 50 $ mkPathText $ renderPathText wave1 - , translate 30 130 $ mkPathText $ renderPathText wave2 - , translate 30 90 $ mkPathText $ renderPathText $ morphPath wave1 wave2 morph - , mkLine (Num 30, Num 10) (Num 30, Num 170) - , mkLine (Num 30, Num 90) (Num 290, Num 90) ] - where - freq = 3; width = 260 - wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) - wave2 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*(freq*3)) * 20) - -morph_wave_circle :: Ani () -morph_wave_circle = proc t -> do - duration 5 -< () - idx <- signalOscillate 0 1 -< () - emit -< toHtml $ withStrokeColor "white" $ mkGroup - [ mkBackground "black" - , translate 30 90 $ mkPathText $ renderPathText $ morphPath circle wave1 idx - , mkLine (Num 30, Num 10) (Num 30, Num 170) - , mkLine (Num 30, Num 90) (Num 290, Num 90) ] - where - freq = 5; width = 260; radius = 50 - wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) - circle = approxFnData 1000 $ \idx -> - (cos (idx*pi*2+pi/2)*radius + width/2, sin (idx*pi*2+pi/2)*radius) - -progressMeters :: Ani () -progressMeters = proc () -> do - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - annotate' (adjustSpeed 1.0 progressMeter) -< g_ [transform_ $ Lucid.translate 40 20] - annotate' (adjustSpeed 2.0 progressMeter) -< g_ [transform_ $ Lucid.translate 140 20] - annotate' (adjustSpeed 0.5 progressMeter) -< g_ [transform_ $ Lucid.translate 240 20] - - emit -< do - text_ [x_ "55", y_ "150", font_size_ "20" - , text_anchor_ "middle" - , fill_ "white"] "1x" - text_ [x_ "155", y_ "150", font_size_ "20" - , text_anchor_ "middle" - , fill_ "white"] "2x" - text_ [x_ "255", y_ "150", font_size_ "20" - , text_anchor_ "middle" - , fill_ "white"] "0.5x" - -progressMeter :: Ani () -progressMeter = loop $ proc () -> do - duration 5 -< () - h <- signal 0 100 -< () - emit -< rect_ [ width_ "30", height_ "100", stroke_ "white", stroke_width_ "2", fill_opacity_ "0" ] - emit -< rect_ [ width_ "30", num_ height_ h, stroke_ "white", fill_ "white" ] - returnA -< () - -highlight :: Ani () -highlight = proc () -> do - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - emit -< do - path_ (commonAttrs "white" ++ [d_ $ renderPathText rect1]) - path_ (commonAttrs "white" ++ [d_ $ renderPathText rect2]) - - path_ (commonAttrs "white" ++ [d_ $ renderPathText rect3]) - path_ (commonAttrs "lightblue" ++ [d_ $ renderPathText rect4]) - path_ (commonAttrs "yellow" ++ [d_ $ renderPathText rect5]) - path_ (commonAttrs "red" ++ [d_ $ renderPathText rect6]) - - follow - [ mkTransition highlight1 highlight2 - , mkTransition highlight2 highlight3 - , mkTransition highlight3 highlight4 - , mkTransition highlight4 highlight5 - , mkTransition highlight5 highlight6 - , mkTransition highlight6 highlight1 - ] -< () - - where - mkTransition from to = pauseAtEnd 1 $ proc () -> do - duration 1 -< () - s <- signalSCurve 2 0 1 -< () - let trans = morphPath from to s - emit -< - path_ (highlightAttrs "green" ++ [d_ $ renderPathText trans <> "Z"]) - mkRect x y width height = - [ (x,y), (x+width, y), (x+width, y+height), (x,y+height) ] - rect1 = mkRect margin margin w h - rect2 = mkRect (320-margin-w*2) margin (w*2) h - rect3 = mkRect margin (180-margin-h) w h - rect4 = mkRect (320/3) (180-margin-h) w h - rect5 = mkRect (320/3*2-w) (180-margin-h) w h - rect6 = mkRect (320-margin-w) (180-margin-h) w h - highlight1 = mkRect (margin-b) (margin-b) (w+2*b) (h+2*b) - highlight2 = mkRect (320-margin-w*2-b) (margin-b) (w*2+2*b) (h+2*b) - highlight3 = mkRect (320-margin-w-b) (180-margin-h-b) (w+2*b) (h+2*b) - highlight4 = mkRect (320/3*2-w-b) (180-margin-h-b) (320/3+2*b) (h+2*b) - highlight5 = mkRect (320/3-b) (180-margin-h-b) (320/3+2*b) (h+2*b) - highlight6 = mkRect (margin-b) (180-margin-h-b) (320/3+2*b) (h+2*b) - b = 7 - margin = 30 - w = 30 - h = 30 - commonAttrs c = [stroke_width_ "2", stroke_ c, fill_ c] - highlightAttrs c = [stroke_width_ "2", stroke_ c, fill_opacity_ "0"] - -clip_rect :: Ani () -clip_rect = proc () -> do - emit -< toHtml $ mkBackground "black" - annotate' $ follow - [ sim - [ sim [ paintStatic prev | prev <- [max 0 (n-4) .. n-1] ] - , sim [ runAni "black" i | i <- [n-4], i>=0 ] - , runAni "white" n ] - | n <- [0..15] - ] -< g_ [transform_ $ Lucid.translate (320/2) (180/2)] - where - paintStatic nth = proc () -> - emit -< toHtml $ withStrokeColor "white" $ - square (20+nth*10) - runAni color nth = circle_clip $ proc () -> do - duration 1 -< () - emit -< toHtml $ withStrokeColor color $ - square (20+nth*10) - square side = center $ withFillOpacity 0 $ withStrokeWidth (Num 2) $ - mkRect (Num 0, Num 0) (Num side) (Num side) - -circle_clip :: Ani () -> Ani () -circle_clip sub = proc () -> do - arc <- signal (pi*2) 0 -< () - let startX = pack$show$sin 0 * 1000 - startY = pack$show$cos 0 * 1000 - xPos = pack$show$sin arc * 1000 - yPos = pack$show$cos arc * 1000 - long = if arc < pi then "1" else "0" - emit -< clipPath_ [id_ $ uniqName] $ - path_ [ d_ $ "M "<>startX<>" "<>startY<>" A 1000 1000 0 "<>long<>" 1 " - <>xPos<> " "<>yPos<>" L 0 0 Z"] - annotate' sub -< - g_ [clip_path_ $ "url(#"<>uniqName<>")"] - where - uniqName = "clip" -- XXX: Not very unique? - - -scaling :: Ani () -scaling = adjustSpeed 2 $ syncAll - [ proc () -> - annotate' animation -< g_ [transform_ $ Lucid.translate x y <> " " <> Lucid.scale 0.5 0.5] - | x <- [0,160] - , y <- [0,90] - | animation <- [sinewave, morph_wave, highlight, progressMeters]] - - -label :: String -> Ani () -label str = proc () -> do - emit -< text_ [x_ "0", y_ "16", font_size_ "16" - , fill_ "white"] (toHtml str) - -valentine :: Ani () -valentine = proc () -> do - follow - [ all_red - , sim [ background - , follow [backgroundDelay, sim [delay 6.4 (fallingLove 0.09) - ,delay 4.9 (fallingLove 0.12) - ,delay 4.5 (fallingLove 0.88) - ,delay 0.3 (fallingLove 0.43) - ,delay 5.3 (fallingLove 0.93) - ,delay 0.1 (fallingLove 0.80) - ,delay 1.1 (fallingLove 0.39) - ,delay 2.3 (fallingLove 0.21) - ,delay 2.9 (fallingLove 0.77) - ,delay 3.4 (fallingLove 0.46) - ,delay 6.2 (fallingLove 0.19) - ,delay 5.9 (fallingLove 0.53) - ,delay 3.2 (fallingLove 0.14) - ,delay 7.7 (fallingLove 0.99) ]] - , follow [heart_ani, heart_disappear] - , follow [backgroundDelay, message "", message "" - , message "", message "爱", message "" - , message "", message ""]] - ] -<() - where - all_red = proc () -> do - duration 1 -< () - emit -< rect_ [width_ "100%", height_ "100%", fill_ "red"] - background = freezeAtEnd $ proc () -> do - duration 2 -< () - n <- signal 0 0xFF -< () - let color = "#FF" ++ hex n ++ hex n - emit -< rect_ [width_ "100%", height_ "100%", fill_ $ pack color] - backgroundDelay = freezeAtEnd $ proc () -> do - duration (animationDuration background-1) -< () - returnA -< () - heart_ani = repeatAni 10 $ proc () -> do - duration 1 -< () - n <- signalOscillateSCurve 2 0.9 1.1 -< () - annotate' drawHeart -< g_ [transform_ $ Lucid.translate 160 110] . g_ [transform_ $ Lucid.scale n n <> " "] - heart_disappear = proc () -> do - duration 3 -< () - n <- signal 0.9 10 -< () - annotate' drawHeart -< g_ [transform_ $ Lucid.translate 160 110] . g_ [transform_ $ Lucid.scale n n <> " "] - white = loop $ proc () -> do - duration 1 -< () - emit -< rect_ [width_ "100%", height_ "100%", fill_ "#FFFFFF"] - fallingLove xPos = proc () -> do - duration 2 -< () - n <- signal 0 1 -< () - o <- signalOscillate (-1) 1 -< () - emit -< - g_ [transform_ $ Lucid.translate (xPos*360) (210*n)] $ - g_ [transform_ $ Lucid.rotate (45*o)] $ - text_ [font_size_ "18" - ,text_anchor_ "middle" - ,fill_ "red"] "爱" - message txt = proc () -> do - duration 1 -< () - o <- signalOscillate 0 1 -< () - n <- signalOscillateSCurve 2 0.9 1.1 -< () - emit -< - g_ [transform_ $ Lucid.translate 160 110, num_ opacity_ o] $ - g_ [transform_ $ Lucid.scale n n ] $ - text_ [x_ "0", y_ "-12", font_size_ "24" - , text_anchor_ "middle" - , fill_ "white"] txt - - drawHeart = proc () -> do - emit -< - g_ [transform_ $ Lucid.translate (-170) (-260)] $ - g_ [transform_ $ Lucid.rotateAround 225 150 121 <> " " <> Lucid.scale 0.4 0.4] $ - path_ ([stroke_ "red", fill_"red", d_ dat]) - dat = "M0 200 v-200 h200 a100,100 90 0,1 0,200 a100,100 90 0,1 -200,0 z" - hex n = if n < 0x10 then "0" ++ showHex (round n) "" - else showHex (round n) "" - -frequencies :: Ani () -frequencies = proc () -> do - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - n <- signal 0 2 -< () - follow -- [drawUpWave - [ drawLine - , drawFirstWave - , drawSecondWave - , drawUpWave - ] -< n - where - freqs = [11, 5, 17]; margin = 30; width = 260; height = 90 - drawLine = freezeAtEnd $ proc _ -> do - label "drawLine" -< () - duration 1 -< () - n <- signal margin (width+margin) -< () - emit -< do - line_ [ num_ x1_ margin, num_ y1_ height - , num_ x2_ n, num_ y2_ height - , stroke_ "white"] - circle_ [num_ cx_ n, num_ cy_ height, r_ "3", fill_ "red"] - drawFirstWave = freezeAtEnd $ proc move -> do - label "drawFirstWave" -< () - duration 3 -< () - n <- signal 0 1 -< () - emit -< do - g_ [transform_ $ Lucid.translate margin height] $ renderPath $ morphPath line1 (wave1 move) n - let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] - circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY*n), num_ r_ 3, fill_ "red"] - drawSecondWave = freezeAtEnd $ proc move -> do - label "drawSecondWave" -< () - duration 3 -< () - emit -< do - g_ [transform_ $ Lucid.translate margin height] $ renderPath $ wave1 move - let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] - circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"] - drawUpWave = freezeAtEnd $ proc move -> do - label "drawUpWave" -< () - duration 2 -< () - n <- signal 0 1 -< () - emit -< do - g_ [transform_ $ Lucid.scale 1 (1-0.5*n)] $ do - g_ [transform_ $ Lucid.translate margin height] $ renderPath $ wave1 move - let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] - circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"] - line1 = approxFnData 1000 $ \idx -> - (idx*width, 0) - wave1 n = approxFnData 1000 $ \idx -> - (idx*width, sum [ sin ((idx+n)*pi*2*freq) * 20 | freq <- freqs ]) - - -latex_basic :: Ani () -latex_basic = proc () -> do - duration 2 -< () - s <- signalOscillate 0 1 -< () - emit -< toHtml $ mkGroup - [ mkBackground "black" - , translate (320/2) (180/2) $ mkGroup - [ withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) text - , withFillColor "white" $ withFillOpacity s text] ] - where - text = scale 4 $ center $ latexAlign - "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" - -bezier :: Ani () -bezier = adjustSpeed 0.4 $ proc () -> do - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - follow - [ orderN [pointA, pointB] - , morph [pointA, pointA, pointB] [pointA, pointC, pointB] - , orderN [pointA, pointC, pointB] - , morph [pointA, pointC, pointB, pointB] [pointA, pointC, pointD, pointB] - , orderN [pointA, pointC, pointD, pointB] - , morph [pointA, pointC, pointD, pointB] [pointA, pointA, pointB, pointB]] -< () - where - pointA = (70,130); pointB = (270,120); pointC = (30,30); pointD = (250,50) - - morph old new = proc () -> do - duration 0.5 -< () - s <- signal 0 1 -< () - let new' = map (\(a,b) -> between a b s) (zip old new) - emit -< forM_ (zip new' (tail new')) $ \(a,b) -> do - renderPath $ - approxFnData 100 $ \idx -> - between a b idx - emit -< mapM_ secondaryCircleAt new' - emit -< primaryCircleAt (head new') - orderN lst = proc () -> do - duration 2 -< () - s <- signalOscillate 0 1 -< () - emit -< primaryCircleAt =<< orderN' (map const lst) s <* mapM_ secondaryCircleAt lst - orderN' [a] s = do - renderPath $ take (round $ 100*s) $ approxFnData 100 $ \idx -> a idx - return (a s) - orderN' lst s = do - forM_ (zip lst (tail lst)) $ \(a,b) -> renderPath $ - approxFnData 100 $ \idx -> - between (a s) (b s) idx - let middlePoints = map (\(a,b) -> \idx -> between (a idx) (b idx) idx) (zip lst (tail lst)) - orderN' middlePoints s <* mapM_ secondaryCircleAt (map ($s) middlePoints) - - secondaryCircleAt (x,y) = circle_ [num_ cx_ x, num_ cy_ y, num_ r_ 3, fill_ "green"] - primaryCircleAt (x,y) = circle_ [num_ cx_ x, num_ cy_ y, num_ r_ 3, fill_ "red"] - between a b _ | a==b = a - between (x1, y1) (x2, y2) idx = - ( x1 + idx * (x2 - x1) - , y1 + idx * (x2-x1) * (y2 - y1) / (x2 - x1)) - -pathSquare :: Ani () -pathSquare = proc () -> do - duration 2 -< () - s <- signalOscillate 0 1 -< () - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - emit -< g_ [stroke_ "white"] $ toHtml (square s) - where - square s = S.PathTree (myPath s) - myPath s = S.defaultSvg - & S.pathDefinition .~ interpolatePathCommands s myPathCmds - myPathCmds = - [ S.MoveTo S.OriginAbsolute [V2 100 100] - , S.LineTo S.OriginAbsolute [V2 200 150] - , S.LineTo S.OriginRelative [V2 (-10) (-100)] - , S.EndPath - ] - -latex_draw :: Ani () -latex_draw = pauseAtEnd 1 $ proc () -> do - emit -< toHtml $ mkBackground "black" - drawText `andThen` fillText -< () - where - msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" - glyphs = center $ latexAlign msg - placement = translate (320/2) (180/2) . scale 5 - fillText = proc () -> do - duration 1 -< () - s <- signal 0 1 -< () - emit -< toHtml $ placement $ - withFillColor "white" $ withFillOpacity s $ - glyphs - drawText = proc () -> do - duration 2 -< () - s <- signal 0 1 -< () - emit -< toHtml $ placement $ - withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) $ - partialSvg s glyphs - - -bbox :: Ani () -bbox = proc () -> do - emit -< toHtml $ mkBackground "black" - duration 5 -< () - annotate' bbox1 -< g_ [transform_ $ Lucid.translate (320/2-50) (180/2)] - annotate' bbox2 -< g_ [transform_ $ Lucid.translate (320/2+50) (180/2)] - -bbox1 :: Ani () -bbox1 = proc () -> do - s <- signal 0 1 -< () - emit -< do - toHtml $ mkBoundingBox $ rotate (360*s) svg - toHtml $ withFillColor "white" $ rotate (360*s) svg - where - svg = scale 3 $ center $ latexAlign "\\sum_{k=1}^\\infty" - -bbox2 :: Ani () -bbox2 = proc () -> do - s <- signalOscillate 0 1 -< () - emit -< do - toHtml $ mkBoundingBox $ partialSvg s heartShape - toHtml $ withStrokeColor "white" $ withFillOpacity 0 $ partialSvg s heartShape - -mkBoundingBox :: Tree -> Tree -mkBoundingBox svg = withStrokeColor "red" $ withFillOpacity 0 $ - mkRect (S.Num x, S.Num y) (S.Num w) (S.Num h) - where - (x, y, w, h) = boundingBox svg - -heartShape = - center $ rotateAroundCenter 225 $ mkPathString - "M0.0,40.0 v-40.0 h40.0\ - \a20.0 20.0 90.0 0 1 0.0,40.0\ - \a20.0 20.0 90.0 0 1 -40.0,0.0 Z" - -latex_color :: Ani () -latex_color = proc () -> do - duration 0.1 -< () - emit -< toHtml $ mkBackground "black" - emit -< toHtml $ translate (320/2) (180/2) $ withStrokeWidth (Num 0.2) $ - withStrokeColor "white" $ - withSubglyphs [0] (withFillColor "blue") $ - withSubglyphs [1] (withFillColor "yellow") $ - withSubglyphs [2] (withFillColor "green") $ - withSubglyphs [3] (withFillColor "red") $ - withSubglyphs [4] (withFillColor "darkslategrey") $ - svg - where - svg = scale 10 $ center $ latex "\\LaTeX" --} - -{- -morph_wave :: Animation -morph_wave = autoReverse $ mkAnimation 2.5 $ do - morph <- getSignal signalLinear - emit $ mkBackground "black" - emit $ withStrokeColor "white" $ translate (-320/2) (-180/2) $ mkGroup - [ translate 30 50 $ mkLinePath wave1 - , translate 30 130 $ mkLinePath wave2 - , translate 30 90 $ mkLinePath $ morphPath wave1 wave2 morph - , mkLine (Num 30, Num 10) (Num 30, Num 170) - , mkLine (Num 30, Num 90) (Num 290, Num 90) ] - where - freq = 3; width = 260 - wave1 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) - wave2 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*(freq*3)) * 20) - -morph_wave_circle :: Animation -morph_wave_circle = autoReverse $ mkAnimation 2.5 $ do - idx <- getSignal signalLinear - emit $ mkBackground "black" - emit $ withStrokeColor "white" $ translate (-320/2) (-180/2) $ mkGroup - [ translate 30 90 $ mkLinePath $ morphPath circle wave1 idx - , mkLine (Num 30, Num 10) (Num 30, Num 170) - , mkLine (Num 30, Num 90) (Num 290, Num 90) ] - where - freq = 5; width = 260; radius = 50 - wave1 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) - circle = approxFnData 100 $ \idx -> - (cos (idx*pi*2+pi/2)*radius + width/2, sin (idx*pi*2+pi/2)*radius) - -progressMeters :: Animation -progressMeters = - bg `sim` labels `sim` - mapA (translate (-100) 0) (adjustSpeed 1.0 progressMeter) `simLoop` - mapA (translate 0 0) (adjustSpeed 2.0 progressMeter) `simLoop` - mapA (translate 100 0) (adjustSpeed 0.5 progressMeter) - where - bg = mkAnimation 0 $ emit $ mkBackground "black" - labels = mkAnimation 0 $ emit $ translate 0 70 $ withFillColor "white" $ mkGroup - [ translate (-100) 0 $ scale 2 $ center $ latex "1x" - , translate 0 0 $ scale 2 $ center $ latex "2x" - , translate 100 0 $ scale 2 $ center $ latex "0.5x" - ] - -progressMeter :: Animation -progressMeter = mkAnimation 3 $ do - h <- getSignal $ signalFromTo 0 100 signalLinear - emit $ center $ mkGroup - [ withStrokeColor "white" $ withStrokeWidth (Num 2) $ withFillOpacity 0 $ - mkRect (Num 30) (Num 100) - , withFillColor "white" $ - mkRect (Num 30) (Num h) ] - - -diaSize :: Animation -diaSize = mkAnimation 0.1 $ do - emit $ mkBackground "white" - emit $ translate (-320/2) (-180/2) dSvg - where - dSvg = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $ - D.scale 3 $ - D.translate (V2 0 (-30)) $ - D.rotate (90 @@ deg) $ - D.lwO 0.1 $ D.strokePath (D.getTurtlePath (D.tree3 4)) - -wavyTree :: Animation -wavyTree = mkAnimation 1 $ do - s <- oscillate $ getSignal $ signalFromTo 1 2 signalLinear - emit $ mkBackground "white" - emit $ translate (-320/2) (-180/2) (dSvg s) - where - dSvg s = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $ - D.scale 3 $ - D.translate (V2 0 (-30)) $ - D.rotate (90 @@ deg) $ - D.lwO 0.1 $ D.strokePath (D.getTurtlePath (tree s)) - gens = 4 - 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/PolyShape.hs b/src/Reanimate/PolyShape.hs --- a/src/Reanimate/PolyShape.hs +++ b/src/Reanimate/PolyShape.hs @@ -11,6 +11,7 @@ , plLineCommands -- :: PolyShape -> [LineCommand] , plLength -- :: PolyShape -> Double + , plArea , plCurves -- :: PolyShape -> [CubicBezier Double] , isInsideOf -- :: PolyShape -> PolyShape -> Bool @@ -24,19 +25,23 @@ , plGroupShapes -- :: [PolyShape] -> [PolyShapeWithHoles] , mergePolyShapeHoles -- :: PolyShapeWithHoles -> PolyShape , polyShapeTolerance + , plPartial, plPartialGroup, plPartial' + , plGroupTouching ) where import Chiphunk.Low import Control.Lens ((&), (.~)) -import Data.List (nub, partition, sortBy) +import Data.List (nub, partition, sortBy, minimumBy) import Data.Ord import Debug.Trace import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..), DPoint, FillRule (..), PathJoin (..), Point (..), - arcLength, bezierIntersection, + arcLength, arcLengthParam, + bezierIntersection, bezierSubsegment, closedPathCurves, closest, colinear, - curvesToClosed, evalBezier, splitBezier, - union, vectorDistance) + curvesToClosed, curvesToClosed, + evalBezier, interpolateVector, reorient, + splitBezier, union, vectorDistance) import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..), defaultSvg, pathDefinition) import Linear.V2 @@ -72,6 +77,11 @@ where cubicLength c = arcLength c 1 polyShapeTolerance +plArea :: PolyShape -> Double +plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0 + where + toVect (Point x y) = Vect x y + -- 1/10th of a pixel if rendered at 2560x1440 polyShapeTolerance :: Double polyShapeTolerance = screenWidth/25600 @@ -81,6 +91,72 @@ where worker (V2 x y) = (Point x y, JoinLine) +plPartial :: Double -> PolyShape -> PolyShape +plPartial delta pl | delta >= 1 = pl +plPartial delta pl = PolyShape $ curvesToClosed (lineOut ++ [joinB] ++ lineIn) + where + lineOutEnd = cubicC3 (last lineOut) + lineInBegin = cubicC0 (head lineIn) + joinB = CubicBezier lineOutEnd lineOutEnd lineOutEnd lineInBegin + lineOut = takeLen (len*delta/2) $ plCurves pl + lineIn = + reverse $ map reorient $ + takeLen (len*delta/2) $ reverse $ map reorient $ plCurves pl + len = plLength pl + takeLen _ [] = [] + takeLen l (c:cs) = + let cLen = arcLength c 1 polyShapeTolerance in + if l < cLen + then [bezierSubsegment c 0 (arcLengthParam c l polyShapeTolerance)] + else c : takeLen (l-cLen) cs + +plPartialGroup :: Double -> [PolyShape] -> [PolyShape] +plPartialGroup _delta [] = [] +plPartialGroup delta pls = + [ plPartial (delta*(maxLen/plLength pl)) pl | pl <- pls ] + where + maxLen = maximum $ map plLength pls + +plPartial' :: Double -> ([DPoint], PolyShape) -> PolyShape +plPartial' delta (seen', PolyShape (ClosedPath lst)) = + case lst of + [] -> PolyShape (ClosedPath []) + (startP, startJoin) : rest -> PolyShape $ ClosedPath $ + (startP, startJoin) : worker startP rest + where + seen = filter (`elem` plPoints) seen' + closestSeen pt = minimumBy (comparing (vectorDistance pt)) seen + worker _ [] = [] + worker _ ((newP, newJoin) : rest) + | newP `elem` seen = (newP, newJoin) : worker newP rest + | otherwise = + let newAt = interpolateVector (closestSeen newP) newP delta + in (newAt, newJoin) : worker newAt rest + plPoints = + [ p | (p,_) <- lst ] + +plGroupTouching :: [PolyShape] -> [[([DPoint],PolyShape)]] +plGroupTouching [] = [] +plGroupTouching pls = worker [polyShapeOrigin (head pls)] pls + where + worker _ [] = [] + worker seen shapes = + let (touching, notTouching) = partition (isTouching seen) shapes + in if null touching + then plGroupTouching notTouching + else map ((,)seen) (map (changeOrigin seen) touching) : + worker (seen ++ concatMap plPoints touching) notTouching + isTouching pts = any (`elem` pts) . plPoints + changeOrigin seen (PolyShape (ClosedPath segments)) = PolyShape $ ClosedPath $ helper [] segments + where + helper acc [] = reverse acc + helper acc lst@((startP,startJ):rest) + | startP `elem` seen = lst ++ reverse acc + | otherwise = helper ((startP, startJ):acc) rest + plPoints :: PolyShape -> [Point Double] + plPoints (PolyShape (ClosedPath lst)) = + [ p | (p,_) <- lst ] + -- | Deconstruct a polyshape into non-intersecting, convex polygons. plDecompose :: [PolyShape] -> [[RPoint]] plDecompose = plDecompose' 0.001 @@ -102,7 +178,7 @@ 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 + adjust x = if head x == last x then adjust (init x) else x plPolygonify :: Double -> PolyShape -> [Point Double] plPolygonify tol shape = diff --git a/src/Reanimate/Scene.hs b/src/Reanimate/Scene.hs --- a/src/Reanimate/Scene.hs +++ b/src/Reanimate/Scene.hs @@ -5,8 +5,9 @@ import Control.Monad.ST import Data.List import Data.Ord +import Data.STRef import Reanimate.Animation -import Reanimate.Svg.Constructors +import Reanimate.Signal type ZIndex = Int @@ -47,17 +48,17 @@ instance MonadFix (Scene s) where mfix fn = M $ \t -> mfix (\v -> let (a,_s,_p,_tl) = v in unM (fn a) t) ---data Frame a = Frame {unFrame :: Duration -> Time -> State ([Tree] -> [Tree]) a} +liftST :: ST s a -> Scene s a +liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, emptyTimeline) + sceneAnimation :: (forall s. Scene s a) -> Animation -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 +sceneAnimation action = foldl' parDropA (pause 0) $ + map snd $ sortBy (comparing fst) + [ (z, pause startT `seqA` a) + | (startT, a, z) <- tl ] where - (_, s, p, tl) = runST (unM action 0) + (_, _, _, tl) = runST (unM action 0) fork :: Scene s a -> Scene s a fork (M action) = M $ \t -> do @@ -101,3 +102,40 @@ s t2 <- queryNow return (t2-t1) + +data Object s = Object (STRef s (Maybe Timeline)) + +newObject :: Scene s (Object s) +newObject = Object <$> liftST (newSTRef Nothing) + +stretchTimeline :: Timeline -> Scene s () +stretchTimeline = mapM_ worker + where + worker (t, a, z) = M $ \tNow -> -- 3 + let tNew = t + duration a -- 1+1=2 + dNew = tNow - tNew -- 3-2=1 + aNew = setDuration dNew (signalA (constantS 1) a) in + if (dNew > 0) + then return ((), 0, 0, [(tNew, aNew, z)]) + else return ((), 0, 0, emptyTimeline) + +dropObject :: Object s -> Scene s () +dropObject (Object ref) = do + mbTimeline <- liftST $ readSTRef ref + case mbTimeline of + Nothing -> return () + Just timeline -> do + liftST $ writeSTRef ref Nothing + stretchTimeline timeline + +listen :: Scene s a -> Scene s (a, Timeline) +listen scene = M $ \t -> do + (a, s, p, tl) <- unM scene t + return ((a,tl), s, p, tl) + +withObject :: Object s -> Scene s a -> Scene s a +withObject obj@(Object ref) scene = do + dropObject obj + (a, tl) <- listen scene + liftST $ writeSTRef ref (Just tl) + return a