mirror of
https://github.com/reanimate/reanimate.git
synced 2026-09-14 09:32:22 +00:00
122 lines
3.8 KiB
Haskell
Executable file
122 lines
3.8 KiB
Haskell
Executable file
#!/usr/bin/env stack
|
|
-- stack --resolver lts-13.14 runghc --package reanimate
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Main (main) where
|
|
|
|
import Control.Lens
|
|
import Data.Complex
|
|
import qualified Data.Text as T
|
|
|
|
import Graphics.SvgTree
|
|
import Linear.V2
|
|
import Reanimate.Driver (reanimate)
|
|
import Reanimate.LaTeX
|
|
import Reanimate.Monad
|
|
import Reanimate.Svg
|
|
|
|
main :: IO ()
|
|
main = reanimate $ pauseAtEnd 2 $
|
|
-- fourierAnimation 1 2
|
|
fourierAnimation 1 2 `before`
|
|
fourierAnimation 2 3 `before`
|
|
fourierAnimation 3 4 `before`
|
|
fourierAnimation 4 5 `before`
|
|
fourierAnimation 5 6 `before`
|
|
fourierAnimation 6 7 `before`
|
|
fourierAnimation 7 8 `before`
|
|
fourierAnimation 8 9 `before`
|
|
fourierAnimation 9 10 `before`
|
|
fourierAnimation 10 15 `before`
|
|
fourierAnimation 15 25 `before`
|
|
fourierAnimation 25 40 `before`
|
|
fourierAnimation 40 40
|
|
|
|
sWidth :: Double
|
|
sWidth = 0.5
|
|
|
|
applyMorph :: Int -> [Complex Double] -> Complex Double -> [Complex Double]
|
|
applyMorph n coeffs mult =
|
|
map (*mult) (take n coeffs) ++
|
|
take (length coeffs - n * 2) (drop n coeffs) ++
|
|
map (*mult) (reverse $ take n $ reverse coeffs)
|
|
|
|
fourierAnimation :: Int -> Int -> Animation
|
|
fourierAnimation nCircles nextCircles = repeatAnimation 1 $ mkAnimation 10 $ do
|
|
emit $ mkBackground "black"
|
|
phi <- signal 0 1
|
|
|
|
let circles = applyMorph (nextCircles - nCircles) (findCoefficients nextCircles) circleAlpha
|
|
circleAlpha = realToFrac (max 0 (phi-0.80) / 0.20)
|
|
|
|
emit $ withStrokeWidth (Num 1) $ withStrokeColor "green" $
|
|
mkLinePath $ mkCirclePath circles
|
|
drawNCircles $ rearrangeCircles $ rotateCircles phi circles
|
|
|
|
emit $ withStrokeWidth (Num sWidth) $
|
|
withFillColor "white" $
|
|
translate (-140) (-80) $
|
|
scale 2 $ latex $ T.pack $ "Circles: " ++ show (nCircles*2+1)
|
|
|
|
piPoints :: [RPoint]
|
|
piPoints = lineToPoints 500 $
|
|
toLineCommands $ extractPath $ scale 30 $ center $ latexAlign "\\pi"
|
|
|
|
findCoefficient :: Int -> Complex Double
|
|
findCoefficient n =
|
|
sum [ toComplex point * exp (negate (fromIntegral n) * 2 *pi * i*t) * deltaT
|
|
| (idx, point) <- zip [0::Int ..] piPoints, let t = fromIntegral idx/nPoints ]
|
|
where
|
|
i = 0 :+ 1
|
|
toComplex (V2 x y) = x :+ y
|
|
deltaT = recip nPoints
|
|
nPoints = fromIntegral (length piPoints)
|
|
|
|
findCoefficients :: Int -> [Complex Double]
|
|
findCoefficients n = [ findCoefficient idx | idx <- [-n .. n] ]
|
|
|
|
rotateCircles :: Double -> [Complex Double] -> [Complex Double]
|
|
rotateCircles phi coeffs =
|
|
[ coeff * exp (fromIntegral idx *2*pi*i*realToFrac phi)| (coeff, idx) <- zip coeffs [-n..] ]
|
|
where
|
|
i = 0 :+ 1
|
|
n = length coeffs `div` 2
|
|
|
|
rearrangeCircles :: [Complex Double] -> [Complex Double]
|
|
rearrangeCircles [coeff] = [coeff]
|
|
rearrangeCircles coeffs =
|
|
coeffs !! n : zipList (reverse (take n coeffs)) (drop (n+1) coeffs)
|
|
where
|
|
zipList (x:xs) (y:ys) = x : y : zipList xs ys
|
|
zipList lst [] = lst
|
|
zipList [] lst = lst
|
|
n = length coeffs `div` 2
|
|
|
|
drawNCircles :: [Complex Double] -> Frame ()
|
|
drawNCircles circles = do
|
|
worker circles
|
|
emit $ withStrokeWidth (Num sWidth) $
|
|
withStrokeColor "white" $
|
|
withStrokeLineJoin JoinRound $
|
|
withFillOpacity 0 $
|
|
mkLinePath [ (x, y) | x :+ y <- scanl (+) 0 circles ]
|
|
where
|
|
worker [] = return ()
|
|
worker (x :+ y : rest) = do
|
|
let radius = sqrt(x*x+y*y)
|
|
emit $ withStrokeWidth (Num 0.2) $
|
|
withStrokeColor "dimgrey" $
|
|
withFillOpacity 0 $
|
|
CircleTree $ defaultSvg
|
|
& circleCenter .~ (Num 0, Num 0)
|
|
& circleRadius .~ Num radius
|
|
mapF (translate x y) $ worker rest
|
|
|
|
mkCirclePath :: [Complex Double] -> [(Double, Double)]
|
|
mkCirclePath circles =
|
|
[ (x, y)
|
|
| idx <- [0 .. granularity]
|
|
, let t = idx/granularity
|
|
x :+ y = sum (rotateCircles t circles)
|
|
]
|
|
where
|
|
granularity = 500
|