mirror of
https://github.com/reanimate/reanimate.git
synced 2026-09-09 07:03:11 +00:00
0aca2333e2* Remove redundant brackets * Various hlint fixes * Remove unused language pragrams and other fixes * Use addStatic more consistently in examples * Rename remaining usages of sceneAnimation to scene
104 lines
3.4 KiB
Haskell
Executable file
104 lines
3.4 KiB
Haskell
Executable file
#!/usr/bin/env stack
|
|
-- stack runghc --package reanimate
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Main(main) where
|
|
|
|
import Control.Lens ((^.))
|
|
import Control.Monad.State
|
|
import qualified Data.Vector.Unboxed as V
|
|
import Graphics.SvgTree
|
|
import Linear.Metric
|
|
import Linear.V2 (V2 (..))
|
|
import Linear.Vector
|
|
import Reanimate
|
|
import Reanimate.Builtin.Documentation
|
|
import Geom2D.CubicBezier.Linear
|
|
|
|
piSvg :: SVG
|
|
piSvg = pathify $ lowerTransformations $ center $ scale 10 $ latex "s"
|
|
|
|
main :: IO ()
|
|
main = reanimate $ docEnv $ mkAnimation 30 $ \t ->
|
|
mkGroup
|
|
[ mkBackgroundPixel rtfdBackgroundColor
|
|
, piSvg
|
|
, drawTangent t piSvg ]
|
|
|
|
drawTangent :: Double -> SVG -> SVG
|
|
drawTangent alpha | alpha >= 1 = id
|
|
drawTangent alpha = mapTree worker
|
|
where
|
|
worker (PathTree path) =
|
|
let (V2 posX posY, tangent) =
|
|
atPartial alpha $ toLineCommands $ path^.pathDefinition
|
|
normed@(V2 tangentX tangentY) = normalize tangent ^* 4
|
|
V2 midX midY = lerp 0.5 0 normed
|
|
V2 normVectX normVectY = normalize tangent ^* (svgWidth normalTxt*1.1)
|
|
tangentSvg =
|
|
translate posX posY $
|
|
rotate (unangle normed/pi*180 + 180) $
|
|
translate 0 (svgHeight tangentTxt/2)
|
|
tangentTxt
|
|
normalSvg =
|
|
translate posX posY $
|
|
rotate (unangle normed/pi*180 + 90) $
|
|
translate (svgWidth normalTxt/2*1.1) (svgHeight normalTxt/2*1.3)
|
|
normalTxt
|
|
in mkGroup
|
|
[ withStrokeWidth defaultStrokeWidth $
|
|
withStrokeColor "black" $
|
|
translate (posX-midX) (posY-midY) $
|
|
mkLine (0, 0) (tangentX, tangentY)
|
|
, withStrokeWidth defaultStrokeWidth $
|
|
withStrokeColor "black" $
|
|
translate posX posY $
|
|
mkLine (0, 0) (-normVectY, normVectX)
|
|
, withStrokeWidth (defaultStrokeWidth*2) $
|
|
withStrokeColor "white"
|
|
tangentSvg
|
|
, withFillOpacity 1 $ withFillColor "black" $ withStrokeWidth 0
|
|
tangentSvg
|
|
, withStrokeWidth (defaultStrokeWidth*2) $
|
|
withStrokeColor "white"
|
|
normalSvg
|
|
, withFillOpacity 1 $ withFillColor "black" $ withStrokeWidth 0
|
|
normalSvg
|
|
]
|
|
worker t = t
|
|
tangentTxt = scale 1.1 $ center $ latex "tangent"
|
|
normalTxt = scale 1.1 $ center $ latex "normal"
|
|
|
|
atPartial :: Double -> [LineCommand] -> (V2 Double, V2 Double)
|
|
atPartial alpha cmds = evalState (worker 0 cmds) zero
|
|
where
|
|
worker _d [] = pure (0, 0)
|
|
worker d (cmd:xs) = do
|
|
from <- get
|
|
len <- lineLength cmd
|
|
let frac = (targetLen-d) / len
|
|
if len == 0 || frac >= 1
|
|
then worker (d+len) xs
|
|
else do
|
|
let bezier = lineCommandToBezier from cmd
|
|
(pos, tangent) = evalBezierDeriv bezier frac
|
|
pure (pos, tangent)
|
|
totalLen = evalState (sum <$> mapM lineLength cmds) zero
|
|
targetLen = totalLen * alpha
|
|
|
|
lineCommandToBezier :: V2 Coord -> LineCommand -> AnyBezier Coord
|
|
lineCommandToBezier from line =
|
|
case line of
|
|
LineBezier [a] ->
|
|
AnyBezier $ V.fromList [from, a]
|
|
LineBezier [a,b] ->
|
|
AnyBezier $ V.fromList [from, a, b]
|
|
LineBezier [a,b,c] ->
|
|
AnyBezier $ V.fromList [from, a, b, c]
|
|
_ -> error (show line)
|
|
|
|
unangle :: (Floating a, Ord a) => V2 a -> a
|
|
unangle a@(V2 ax ay) =
|
|
let alpha = asin $ ay / norm a
|
|
in if ax < 0
|
|
then pi - alpha
|
|
else alpha
|