diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,22 @@ # Revision history for reanimate -## 0.4.0.0 +## 0.4.2.0 + +* Web-viewer: Use GHCi to reload code, reducing latency by ~100x. +* Improve caching for blender and povray. +* Hide many internal modules. +* Move hmatrix dependency to a separate package. +* Use hgeometry instead of broken C++ code. +* Introduce the basics for a new graphical object system. +* Introduce online playground. +* Introduce interactive embedded player. +* Hide internal modules and bring documentation coverage up to 100%. + +## 0.4.1.0 -- 2020-07-30 + +* Slightly improved error messages. + +## 0.4.0.0 -- 2020-07-28 * Show progress when running ffmpeg. * Small improvements to the scene API. diff --git a/data/github-icon-white.svg b/data/github-icon-white.svg new file mode 100644 --- /dev/null +++ b/data/github-icon-white.svg @@ -0,0 +1,6 @@ + + + + + + diff --git a/docs/gifs/doc_augustP.gif b/docs/gifs/doc_augustP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_augustP.gif differ diff --git a/docs/gifs/doc_balloon.gif b/docs/gifs/doc_balloon.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_balloon.gif differ diff --git a/docs/gifs/doc_cameraAttach.gif b/docs/gifs/doc_cameraAttach.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_cameraAttach.gif differ diff --git a/docs/gifs/doc_cameraFocus.gif b/docs/gifs/doc_cameraFocus.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_cameraFocus.gif differ diff --git a/docs/gifs/doc_cassiniP.gif b/docs/gifs/doc_cassiniP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_cassiniP.gif differ diff --git a/docs/gifs/doc_cylindricalEqualAreaP.gif b/docs/gifs/doc_cylindricalEqualAreaP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_cylindricalEqualAreaP.gif differ diff --git a/docs/gifs/doc_foucautP.gif b/docs/gifs/doc_foucautP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_foucautP.gif differ diff --git a/docs/gifs/doc_githubWhiteIcon.gif b/docs/gifs/doc_githubWhiteIcon.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_githubWhiteIcon.gif differ diff --git a/docs/gifs/doc_lagrangeP.gif b/docs/gifs/doc_lagrangeP.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_lagrangeP.gif differ diff --git a/docs/gifs/doc_linear.gif b/docs/gifs/doc_linear.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_linear.gif differ diff --git a/docs/gifs/doc_powerS.gif b/docs/gifs/doc_powerS.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_powerS.gif differ diff --git a/docs/gifs/doc_rawLinear.gif b/docs/gifs/doc_rawLinear.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_rawLinear.gif differ diff --git a/docs/gifs/doc_rotationalTrajectory.gif b/docs/gifs/doc_rotationalTrajectory.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_rotationalTrajectory.gif differ diff --git a/docs/gifs/doc_slideDownT.gif b/docs/gifs/doc_slideDownT.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_slideDownT.gif differ diff --git a/docs/gifs/doc_slideLeftT.gif b/docs/gifs/doc_slideLeftT.gif Binary files a/docs/gifs/doc_slideLeftT.gif and b/docs/gifs/doc_slideLeftT.gif differ diff --git a/docs/gifs/doc_slideUpT.gif b/docs/gifs/doc_slideUpT.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_slideUpT.gif differ diff --git a/docs/gifs/doc_spriteScope.gif b/docs/gifs/doc_spriteScope.gif new file mode 100644 Binary files /dev/null and b/docs/gifs/doc_spriteScope.gif differ diff --git a/docs/gifs/doc_ternaryPlot.gif b/docs/gifs/doc_ternaryPlot.gif Binary files a/docs/gifs/doc_ternaryPlot.gif and b/docs/gifs/doc_ternaryPlot.gif differ diff --git a/examples/demo_tangent.hs b/examples/demo_tangent.hs --- a/examples/demo_tangent.hs +++ b/examples/demo_tangent.hs @@ -6,8 +6,6 @@ import Control.Lens ((^.)) import Control.Monad.State import qualified Data.Vector.Unboxed as V -import Geom2D.CubicBezier (AnyBezier (..), Point (..), - evalBezierDeriv) import Graphics.SvgTree (Coord, Tree (..), mapTree, pathDefinition) import Linear.Metric @@ -15,10 +13,13 @@ 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 -> - let piSvg = pathify $ lowerTransformations $ center $ scale 10 $ latex "s" in mkGroup [ mkBackgroundPixel rtfdBackgroundColor , piSvg @@ -81,7 +82,7 @@ else do let bezier = lineCommandToBezier from cmd (pos, tangent) = evalBezierDeriv bezier frac - pure $ (fromPoint pos, fromPoint tangent) + pure $ (pos, tangent) totalLen = evalState (sum <$> mapM lineLength cmds) zero targetLen = totalLen * alpha @@ -89,18 +90,12 @@ lineCommandToBezier from line = case line of LineBezier [a] -> - AnyBezier $ V.fromList [toTuple from, toTuple a] + AnyBezier $ V.fromList [from, a] LineBezier [a,b] -> - AnyBezier $ V.fromList [toTuple from, toTuple a, toTuple b] + AnyBezier $ V.fromList [from, a, b] LineBezier [a,b,c] -> - AnyBezier $ V.fromList [toTuple from, toTuple a, toTuple b, toTuple c] + AnyBezier $ V.fromList [from, a, b, c] _ -> error (show line) - -fromPoint :: Point a -> V2 a -fromPoint (Point x y) = V2 x y - -toTuple :: V2 a -> (a,a) -toTuple (V2 x y) = (x, y) unangle :: (Floating a, Ord a) => V2 a -> a unangle a@(V2 ax ay) = diff --git a/examples/doc_augustP.hs b/examples/doc_augustP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_augustP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth augustP diff --git a/examples/doc_balloon.hs b/examples/doc_balloon.hs new file mode 100644 --- /dev/null +++ b/examples/doc_balloon.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Math.Balloon +import Graphics.SvgTree + +main :: IO () +main = reanimate $ docEnv $ pauseAtEnd 1 $ mkAnimation 5 $ \t -> + withStrokeLineJoin JoinRound $ + balloon (scale 8 $ center $ latex "X") t diff --git a/examples/doc_cameraAttach.hs b/examples/doc_cameraAttach.hs new file mode 100644 --- /dev/null +++ b/examples/doc_cameraAttach.hs @@ -0,0 +1,20 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Scene +import Control.Lens + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + cam <- newObject Camera + circ <- newObject $ Circle 2 + oModifyS circ $ + oContext .= withFillOpacity 1 . withFillColor "blue" + oShow circ + + cameraAttach cam circ + cameraZoom cam 2 2 + cameraZoom cam 2 1 diff --git a/examples/doc_cameraFocus.hs b/examples/doc_cameraFocus.hs new file mode 100644 --- /dev/null +++ b/examples/doc_cameraFocus.hs @@ -0,0 +1,25 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Scene +import Control.Lens + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + cam <- newObject Camera + circ <- newObject $ Circle 2; oShow circ + oModify circ $ oTranslate .~ (-3,0) + box <- newObject $ Rectangle 4 4; oShow box + oModify box $ oTranslate .~ (3,0) + + cameraAttach cam circ + cameraAttach cam box + cameraFocus cam (-3,0) + cameraZoom cam 2 2 + cameraZoom cam 2 1 + cameraFocus cam (3,0) + cameraZoom cam 2 2 + cameraZoom cam 2 1 diff --git a/examples/doc_cassiniP.hs b/examples/doc_cassiniP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_cassiniP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth cassiniP diff --git a/examples/doc_cylindricalEqualAreaP.hs b/examples/doc_cylindricalEqualAreaP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_cylindricalEqualAreaP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth (cylindricalEqualAreaP 0) diff --git a/examples/doc_foucautP.hs b/examples/doc_foucautP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_foucautP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth foucautP diff --git a/examples/doc_githubWhiteIcon.hs b/examples/doc_githubWhiteIcon.hs new file mode 100644 --- /dev/null +++ b/examples/doc_githubWhiteIcon.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ staticFrame 1 $ mkGroup + [ mkBackground "grey" + , githubWhiteIcon ] diff --git a/examples/doc_lagrangeP.hs b/examples/doc_lagrangeP.hs new file mode 100644 --- /dev/null +++ b/examples/doc_lagrangeP.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main (main) where + +import Reanimate +import Reanimate.GeoProjection +import Reanimate.Builtin.Images + +main :: IO () +main = reanimate $ animate $ + const $ scaleToSize screenWidth screenHeight $ + embedImage $ project smallEarth lagrangeP diff --git a/examples/doc_linear.hs b/examples/doc_linear.hs new file mode 100644 --- /dev/null +++ b/examples/doc_linear.hs @@ -0,0 +1,17 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Morph.Common +import Reanimate.Morph.Linear +import Graphics.SvgTree + +main :: IO () +main = reanimate $ docEnv $ playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t -> + withStrokeLineJoin JoinRound $ + let src = scale 8 $ center $ latex "X" + dst = scale 8 $ center $ latex "H" + in morph linear src dst t diff --git a/examples/doc_rawLinear.hs b/examples/doc_rawLinear.hs new file mode 100644 --- /dev/null +++ b/examples/doc_rawLinear.hs @@ -0,0 +1,17 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Morph.Common +import Reanimate.Morph.Linear +import Graphics.SvgTree + +main :: IO () +main = reanimate $ docEnv $ playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t -> + withStrokeLineJoin JoinRound $ + let src = scale 8 $ center $ latex "X" + dst = scale 8 $ center $ latex "H" + in morph rawLinear src dst t diff --git a/examples/doc_rotationalTrajectory.hs b/examples/doc_rotationalTrajectory.hs new file mode 100644 --- /dev/null +++ b/examples/doc_rotationalTrajectory.hs @@ -0,0 +1,18 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Morph.Common +import Reanimate.Morph.Linear +import Reanimate.Morph.Rotational +import Graphics.SvgTree + +main :: IO () +main = reanimate $ docEnv $ playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t -> + withStrokeLineJoin JoinRound $ + let src = scale 8 $ center $ latex "X" + dst = scale 8 $ center $ latex "H" + in morph linear{morphTrajectory=rotationalTrajectory (0.5,0.5)} src dst t diff --git a/examples/doc_slideDownT.golden b/examples/doc_slideDownT.golden new file mode 100644 --- /dev/null +++ b/examples/doc_slideDownT.golden @@ -0,0 +1,10 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_slideDownT.hs b/examples/doc_slideDownT.hs new file mode 100644 --- /dev/null +++ b/examples/doc_slideDownT.hs @@ -0,0 +1,15 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.Slide +import Reanimate.Transition + +main :: IO () +main = reanimate $ docEnv $ pauseAtEnd 1 $ signalT (curveS 2) slideDownT left right + where + left = drawCircle + right = staticFrame 1 (withFillOpacity 1 $ mkBackground "black") `parA` + mapA (flipXAxis . withStrokeColor "white") drawCircle diff --git a/examples/doc_slideLeftT.golden b/examples/doc_slideLeftT.golden --- a/examples/doc_slideLeftT.golden +++ b/examples/doc_slideLeftT.golden @@ -1,10 +1,10 @@ -0 -1 -2 -3 -4 -5 -6 -7 -8 -9 +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_slideLeftT.hs b/examples/doc_slideLeftT.hs --- a/examples/doc_slideLeftT.hs +++ b/examples/doc_slideLeftT.hs @@ -8,7 +8,7 @@ import Reanimate.Transition main :: IO () -main = reanimate $ docEnv $ signalT (curveS 2) slideLeftT left right +main = reanimate $ docEnv $ pauseAtEnd 1 $ signalT (curveS 2) slideLeftT left right where left = drawCircle right = staticFrame 1 (withFillOpacity 1 $ mkBackground "black") `parA` diff --git a/examples/doc_slideUpT.golden b/examples/doc_slideUpT.golden new file mode 100644 --- /dev/null +++ b/examples/doc_slideUpT.golden @@ -0,0 +1,10 @@ +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 diff --git a/examples/doc_slideUpT.hs b/examples/doc_slideUpT.hs new file mode 100644 --- /dev/null +++ b/examples/doc_slideUpT.hs @@ -0,0 +1,15 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.Slide +import Reanimate.Transition + +main :: IO () +main = reanimate $ docEnv $ pauseAtEnd 1 $ signalT (curveS 2) slideUpT left right + where + left = drawCircle + right = staticFrame 1 (withFillOpacity 1 $ mkBackground "black") `parA` + mapA (flipXAxis . withStrokeColor "white") drawCircle diff --git a/examples/doc_spriteScope.hs b/examples/doc_spriteScope.hs new file mode 100644 --- /dev/null +++ b/examples/doc_spriteScope.hs @@ -0,0 +1,19 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +module Main(main) where + +import Reanimate +import Reanimate.Builtin.Documentation + +main :: IO () +main = reanimate $ docEnv $ sceneAnimation $ do + -- the rect lives through the entire 3s animation + newSpriteSVG_ $ translate (-3) 0 $ mkRect 4 4 + wait 1 + spriteScope $ do + -- the circle only lives for 1 second. + local <- newSpriteSVG $ translate 3 0 $ mkCircle 2 + spriteE local $ overBeginning 0.3 fadeInE + spriteE local $ overEnding 0.3 fadeOutE + wait 1 + wait 1 diff --git a/examples/doc_ternaryPlot.hs b/examples/doc_ternaryPlot.hs --- a/examples/doc_ternaryPlot.hs +++ b/examples/doc_ternaryPlot.hs @@ -2,13 +2,15 @@ -- stack runghc --package reanimate module Main(main) where -import Reanimate hiding (raster) -import Reanimate.Builtin.Documentation -import Reanimate.Builtin.TernaryPlot -import Reanimate.ColorComponents -import Data.Colour.CIE -import Codec.Picture.Types +import Codec.Picture.Types +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.Builtin.TernaryPlot main :: IO () -main = reanimate $ docEnv $ animate $ const $ - ternaryPlot 1024 (\a b c -> promotePixel $ toRGB8 $ cieXYZ a b c) +main = reanimate $ docEnv $ staticFrame 1 $ + ternaryPlot 100 $ \aCoord bCoord cCoord -> promotePixel $ + let red = round $ aCoord*255 + green = round $ bCoord*255 + blue = round $ cCoord*255 + in PixelRGB8 red green blue diff --git a/examples/fe_morph.hs b/examples/fe_morph.hs new file mode 100644 --- /dev/null +++ b/examples/fe_morph.hs @@ -0,0 +1,83 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +module Main(main) where + +import Text.Printf + +{- FE articles/demos +scatter: https://codepen.io/mullany/pen/JmgbRB +distortion: https://codepen.io/mullany/pen/BWKePz +variable stroke width: https://codepen.io/mullany/pen/qaONQm +variable stroke gradient: https://codepen.io/mullany/pen/XXBMJd +heart: https://codepen.io/yoksel/pen/MLVjoB +elastic stroke: https://codepen.io/yoksel/pen/XJbzrO +-} + +import Codec.Picture.Types +import Control.Lens hiding (magma) +import Graphics.SvgTree +import Reanimate + +main :: IO () +main = reanimate $ sceneAnimation $ do + newSpriteSVG_ $ mkBackground "white" + let circles = + [ (900, 0.3) + , (760, 0.5) + , (670, 0.4) + , (600, 0.6) + , (450, 0.7) ] + play $ pauseAtEnd 2 $ mkAnimation 10 $ \t -> + mkGroup + [ mkGooeyFilter 0.2 -- fromToS 0.1 0.2 $ oscillateS t + , mkGroup + [ lowerTransformations $ center $ withFillColor "black" $ latex "Text" + , mkGroup + [rotate (t*rot) $ translate (fromToS 0 3.5 $ bellS 2 $ t) 0 $ + withFillColorPixel (promotePixel c) $ mkCircle (size*1.5) + | (n,(rot, size)) <- zip [0..] circles + , let c = turbo (n/fromIntegral (length circles-1)) + ] + ] & filterRef .~ pure (Ref "gooey") + + ] + -- wait 1 + +mkGooeyFilter :: Double -> SVG +mkGooeyFilter blur = + FilterTree $ mkFilter ("gooey") + [ FEGaussianBlur $ defaultSvg + & gaussianBlurStdDeviationX .~ Num blur + & gaussianBlurEdgeMode .~ EdgeNone + & filterResult .~ Just "blur" + , FEColorMatrix $ defaultSvg + & colorMatrixType .~ Matrix + & colorMatrixValues .~ printf + "1 0 0 0 0 \ + \0 1 0 0 0 \ + \0 0 1 0 0 \ + \0 0 0 %f %f" mul sub + & colorMatrixIn .~ pure (SourceRef "blur") + & filterResult .~ Just "colormatrix" + ] + where + -- Increase alpha contrast. Turns alphaMin to 0x00 and alphaMax to 0xFF. + -- Increasing alphaDiff makes the shapes softer. Decreasing it gives more + -- contrast. + -- alphaMin*mul + sub*255 = 0 + -- alphaMax*mul + sub*255 = 255 + -- alphaDiff*mul = 255 + -- mul = 255/alphaDiff + -- sub = -alphaMin*mul/255 + mul = 255/alphaDiff + sub = -alphaMin*mul/255 + alphaCenter = 255/2 :: Double + alphaDiff = 20 :: Double + alphaMin = alphaCenter - alphaDiff/2 + -- alphaMax = alphaCenter + alphaDiff/2 + +mkFilter :: String -> [FilterElement] -> Filter +mkFilter ident fe = defaultSvg & filterChildren .~ fe & attrId ?~ ident diff --git a/examples/intro_canvas.hs b/examples/intro_canvas.hs --- a/examples/intro_canvas.hs +++ b/examples/intro_canvas.hs @@ -6,28 +6,22 @@ ) where -import Reanimate -import Reanimate.Builtin.Documentation +import Data.Text (Text) +import qualified Data.Text as T +import Graphics.SvgTree hiding (Point, Text, height) +import Linear.Metric import Linear.V2 import Linear.Vector -import Linear.Metric -import Graphics.SvgTree hiding ( Text - , Point - , height - ) -import Data.Text ( Text ) -import qualified Data.Text as T +import Reanimate +import Reanimate.Builtin.Documentation +import Geom2D.CubicBezier.Linear import Text.Printf -import Geom2D.CubicBezier ( QuadBezier(..) - , evalBezier - , Point(..) - ) main :: IO () main = reanimate $ sceneAnimation $ do newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor newSpriteSVG_ static - dotPath <- newVar (QuadBezier (Point 0 0) (Point 0 0) (Point 0 0)) + dotPath <- newVar (QuadBezier (V2 0 0) (V2 0 0) (V2 0 0)) dotParam <- newVar 0 newSprite_ $ redDot <$> (evalBezier <$> unVar dotPath <*> unVar dotParam) let moveDot a b = do @@ -37,15 +31,15 @@ tweenVar dotParam 5 $ \v -> fromToS v 1 . curveS 2 wait 1 wait 1 - moveDot (Point 0 1) (Point 4 2) - moveDot (Point (-1) 0) (Point (-4) 3) - moveDot (Point (0) 0) (Point (-4) (-3)) - moveDot (Point (0) 0) (Point (5) (-2)) - moveDot (Point (6) 2) (Point 2 1) - moveDot (Point (0) 0) (Point 0 0) + moveDot (V2 0 1) (V2 4 2) + moveDot (V2 (-1) 0) (V2 (-4) 3) + moveDot (V2 (0) 0) (V2 (-4) (-3)) + moveDot (V2 (0) 0) (V2 (5) (-2)) + moveDot (V2 (6) 2) (V2 2 1) + moveDot (V2 (0) 0) (V2 0 0) -redDot :: Point Double -> SVG -redDot (Point x y) = translate x y $ mkGroup +redDot :: V2 Double -> SVG +redDot (V2 x y) = translate x y $ mkGroup [ translate 0 (-0.5) $ scale 0.5 $ outlinedText $ T.pack $ printf "%.1f,%.1f" x y , withFillColor "red" $ mkCircle 0.1 ] diff --git a/examples/intro_canvas_square.hs b/examples/intro_canvas_square.hs --- a/examples/intro_canvas_square.hs +++ b/examples/intro_canvas_square.hs @@ -6,22 +6,16 @@ ) where -import Reanimate -import Reanimate.Builtin.Documentation +import Data.Text (Text) +import qualified Data.Text as T +import Graphics.SvgTree hiding (Text, height) +import Linear.Metric import Linear.V2 import Linear.Vector -import Linear.Metric -import Graphics.SvgTree hiding ( Text - , Point - , height - ) -import Data.Text ( Text ) -import qualified Data.Text as T +import Reanimate +import Reanimate.Builtin.Documentation +import Geom2D.CubicBezier.Linear import Text.Printf -import Geom2D.CubicBezier ( QuadBezier(..) - , evalBezier - , Point(..) - ) newWidth, newHeight :: Double newWidth = 8 @@ -31,7 +25,7 @@ main = reanimate $ mapA squareViewBox $ sceneAnimation $ do newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor newSpriteSVG_ static - dotPath <- newVar (QuadBezier (Point 0 0) (Point 0 0) (Point 0 0)) + dotPath <- newVar (QuadBezier (V2 0 0) (V2 0 0) (V2 0 0)) dotParam <- newVar 0 newSprite_ $ redDot <$> (evalBezier <$> unVar dotPath <*> unVar dotParam) let moveDot a b = do @@ -40,18 +34,18 @@ writeVar dotParam 0 tweenVar dotParam 5 $ \v -> fromToS v 1 . curveS 2 wait 1 - moveDot (Point 0 1) (Point 2 1) - moveDot (Point (-1) 0) (Point (-1) 1.5) - moveDot (Point (0) 0) (Point (-2) (-3)) - moveDot (Point (0) 0) (Point (2.5) (-1)) - moveDot (Point (3) 1.5) (Point 1.5 1) - moveDot (Point (0) 0) (Point 0 0) + moveDot (V2 0 1) (V2 2 1) + moveDot (V2 (-1) 0) (V2 (-1) 1.5) + moveDot (V2 (0) 0) (V2 (-2) (-3)) + moveDot (V2 (0) 0) (V2 (2.5) (-1)) + moveDot (V2 (3) 1.5) (V2 1.5 1) + moveDot (V2 (0) 0) (V2 0 0) squareViewBox :: SVG -> SVG squareViewBox = withViewBox (-4, -4, 8, 8) -redDot :: Point Double -> SVG -redDot (Point x y) = translate x y $ mkGroup +redDot :: V2 Double -> SVG +redDot (V2 x y) = translate x y $ mkGroup [ translate 0 (-0.5) $ scale 0.5 $ outlinedText $ T.pack $ printf "%.1f,%.1f" x y , withFillColor "red" $ mkCircle 0.1 ] diff --git a/examples/latex_wheel.hs b/examples/latex_wheel.hs --- a/examples/latex_wheel.hs +++ b/examples/latex_wheel.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RecursiveDo #-} module Main (main) where +import Control.Lens ((&)) import Control.Monad (forM_) import Graphics.SvgTree (Tree) import Reanimate @@ -16,28 +17,28 @@ mainScene :: Animation mainScene = sceneAnimation $ mdo play $ drawCircle - # setDuration drawCircleT - # applyE (constE $ scaleXY (-1) 1) + & setDuration drawCircleT + & applyE (constE $ scaleXY (-1) 1) fork $ play $ drawCircle - # freezeAtPercentage 1 - # setDuration rotDur + & freezeAtPercentage 1 + & setDuration rotDur rotDur <- withSceneDuration $ waitOn $ forM_ svgs $ \svg -> do fork $ play $ drawTick - # setDuration rotateT - # repeatA rotateN - # applyE (overBeginning 0.5 drawInE) - # applyE (overEnding 0.5 drawOutE) + & 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) + & 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 + & setDuration drawCircleT + & reverseA return () where drawCircleT = 1 diff --git a/examples/morphology_closest.hs b/examples/morphology_closest.hs --- a/examples/morphology_closest.hs +++ b/examples/morphology_closest.hs @@ -6,8 +6,9 @@ import Codec.Picture import Codec.Picture.Types +import Control.Lens ((&)) import Control.Monad -import Graphics.SvgTree (LineJoin (..)) +import Graphics.SvgTree (LineJoin (..)) import Reanimate import Reanimate.Morph.Common import Reanimate.Morph.Linear @@ -34,11 +35,11 @@ showPair from to = waitOn $ do fork $ play $ mkAnimation 4 (morph rawLinear from to) - # mapA (translate (-4) (-0.5)) - # signalA (curveS 4) + & mapA (translate (-4) (-0.5)) + & signalA (curveS 4) fork $ play $ mkAnimation 4 (morph linear from to) - # mapA (translate (4) (-0.5)) - # signalA (curveS 4) + & mapA (translate (4) (-0.5)) + & signalA (curveS 4) pairs = zip stages (tail stages ++ [head stages]) stages = map (lowerTransformations . scale 8 . pathify . center) $ colorize diff --git a/examples/morphology_intro.hs b/examples/morphology_intro.hs --- a/examples/morphology_intro.hs +++ b/examples/morphology_intro.hs @@ -5,6 +5,7 @@ module Main(main) where import Codec.Picture +import Control.Lens ((&)) import Reanimate import Reanimate.Morph.Common import Reanimate.Morph.Linear @@ -23,7 +24,7 @@ play $ step stage2 stage3 play $ step stage3 stage4 play $ step stage4 stage1 - # setDuration 5 + & setDuration 5 where radius = 2.5 step from to = diff --git a/examples/morphology_leastwork.hs b/examples/morphology_leastwork.hs deleted file mode 100644 --- a/examples/morphology_leastwork.hs +++ /dev/null @@ -1,69 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ParallelListComp #-} -module Main(main) where - -import Codec.Picture -import Codec.Picture.Types -import Control.Monad -import Graphics.SvgTree (LineJoin (..)) -import Reanimate -import Reanimate.Morph.Common -import Reanimate.Morph.LeastWork -import Reanimate.Morph.Linear - -bgColor :: PixelRGBA8 -bgColor = PixelRGBA8 252 252 252 0xFF - -main :: IO () -main = reanimate $ - addStatic (mkBackgroundPixel bgColor) $ - mapA (withStrokeWidth defaultStrokeWidth) $ - mapA (withStrokeColor "black") $ - mapA (withStrokeLineJoin JoinRound) $ - mapA (withFillOpacity 1) $ - sceneAnimation $ do - _ <- newSpriteSVG $ - withStrokeWidth 0 $ translate (-3) 4 $ - center $ latex "linear" - _ <- newSpriteSVG $ - withStrokeWidth 0 $ translate (3) 4 $ - center $ latex "least-work" - forM_ pairs $ uncurry showPair - where - showPair from to = - waitOn $ do - fork $ play $ mkAnimation 4 (morph linear from to) - # mapA (translate (-3) (-0.5)) - # signalA (curveS 4) - fork $ play $ mkAnimation 4 (morph myMorph from to) - # mapA (translate (3) (-0.5)) - # signalA (curveS 4) - - stretchCosts = defaultStretchCosts - { stretchStiffness = 2 } - bendCosts = defaultBendCosts - myMorph = linear{morphPointCorrespondence = leastWork stretchCosts bendCosts } - pairs = zip stages (tail stages ++ [head stages]) - stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize - [ latex "X" - , latex "$\\aleph$" - , latex "Y" - , latex "$\\infty$" - , latex "I" - , latex "$\\pi$" - , latex "1" - , latex "T" - , latex "I" - , latex "L" - , latex "S" - , mkRect 0.5 0.5 - ] - -colorize :: [SVG] -> [SVG] -colorize lst = - [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt - | elt <- lst - | n <- [0..] - ] diff --git a/examples/morphology_linear.hs b/examples/morphology_linear.hs --- a/examples/morphology_linear.hs +++ b/examples/morphology_linear.hs @@ -6,7 +6,8 @@ import Codec.Picture import Codec.Picture.Types -import Graphics.SvgTree (LineJoin (..)) +import Control.Lens ((&)) +import Graphics.SvgTree (LineJoin (..)) import Reanimate import Reanimate.Morph.Common import Reanimate.Morph.Linear @@ -31,8 +32,8 @@ spriteE toS $ overBeginning 0.2 fadeInE spriteE toS $ overEnding 0.2 fadeOutE m <- fork $ newSpriteA $ animate (morph linear from to) - # signalA (curveS 4) - # mapA (translate (-4) 0) + & signalA (curveS 4) + & mapA (translate (-4) 0) wait 4 destroySprite m destroySprite toS diff --git a/examples/morphology_linebend.hs b/examples/morphology_linebend.hs deleted file mode 100644 --- a/examples/morphology_linebend.hs +++ /dev/null @@ -1,63 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ParallelListComp #-} -module Main(main) where - -import Codec.Picture -import Codec.Picture.Types -import Control.Monad -import Graphics.SvgTree (LineJoin (..)) -import Reanimate -import Reanimate.Morph.Common -import Reanimate.Morph.Linear -import Reanimate.Morph.LineBend - -bgColor :: PixelRGBA8 -bgColor = PixelRGBA8 252 252 252 0xFF - -main :: IO () -main = reanimate $ - addStatic (mkBackgroundPixel bgColor) $ - mapA (withStrokeWidth defaultStrokeWidth) $ - mapA (withStrokeColor "black") $ - mapA (withStrokeLineJoin JoinRound) $ - mapA (withFillOpacity 1) $ - sceneAnimation $ do - _ <- newSpriteSVG $ - withStrokeWidth 0 $ translate (-3) 4 $ - center $ latex "linear" - _ <- newSpriteSVG $ - withStrokeWidth 0 $ translate (3) 4 $ - center $ latex "line bend" - forM_ pairs $ uncurry showPair - where - showPair from to = - waitOn $ do - fork $ play $ mkAnimation 4 (morph linear from to) - # mapA (translate (-3) (-0.5)) - # signalA (curveS 4) - fork $ play $ mkAnimation 4 (morph myMorph from to) - # mapA (translate (3) (-0.5)) - # signalA (curveS 4) - - myMorph = linear{morphTrajectory = lineBend } - pairs = zip stages (tail stages ++ [head stages]) - stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize - [ latex "X" - , latex "$\\aleph$" - , latex "Y" - , latex "$\\infty$" - , latex "I" - , latex "$\\pi$" - , latex "1" - , latex "S" - , mkRect 0.5 0.5 - ] - -colorize :: [SVG] -> [SVG] -colorize lst = - [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt - | elt <- lst - | n <- [0..] - ] diff --git a/examples/morphology_linebend_intro.hs b/examples/morphology_linebend_intro.hs deleted file mode 100644 --- a/examples/morphology_linebend_intro.hs +++ /dev/null @@ -1,100 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ParallelListComp #-} -module Main(main) where - -import Codec.Picture -import Control.Monad -import Data.List (transpose) -import qualified Data.Vector as V -import Graphics.SvgTree (LineJoin (..)) -import Linear.V2 -import Reanimate -import Reanimate.Math.Polygon -import Reanimate.Morph.Common -import Reanimate.Morph.Linear -import Reanimate.Morph.LineBend - -bgColor :: PixelRGBA8 -bgColor = PixelRGBA8 252 252 252 0xFF - -spike1 :: Polygon -spike1 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList - [ V2 0 0, V2 2 0 - , V2 2 1 ] - -spike2 :: Polygon -spike2 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList - [ V2 0 0, V2 2 0 - , V2 0 1 ] - -spike3 :: Polygon -spike3 = pScale 2.5 $ mkPolygon $ V.map (\x -> x - V2 1 1) $ V.fromList - [ V2 0.5 0, V2 1.5 0 - , V2 1 2 ] - -polygonShape :: Polygon -> SVG -polygonShape p = mkLinePathClosed - [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ] - - -main :: IO () -main = reanimate $ - addStatic (mkBackgroundPixel bgColor) $ - mapA (withStrokeWidth defaultStrokeWidth) $ - mapA (withStrokeColor "black") $ - mapA (withStrokeLineJoin JoinRound) $ - mapA (withFillOpacity 1) $ - sceneAnimation $ do - _ <- newSpriteSVG $ - withStrokeWidth 0 $ translate (-4) 4 $ - center $ latex "linear" - _ <- newSpriteSVG $ - withStrokeWidth 0 $ translate (4) 4 $ - center $ latex "line bend" - showTrails - forM_ pairs $ uncurry showPair - where - showTrails = do - _ <- newSpriteSVG $ - translate (-4) (-0.5) $ - genTrails (map linearTrajectory pairs) - _ <- newSpriteSVG $ - translate (4) (-0.5) $ - genTrails (map lineBend pairs) - return () - showPair from to = - waitOn $ do - fork $ play $ mkAnimation 4 (morph linear (polygonShape from) (polygonShape to)) - # mapA (translate (-4) (-0.5)) - # mapA (withFillColor "lightgreen") - # signalA (curveS 4) - fork $ play $ mkAnimation 4 (morph myMorph (polygonShape from) (polygonShape to)) - # mapA (translate (4) (-0.5)) - # mapA (withFillColor "cyan") - # signalA (curveS 4) - myMorph = linear{morphTrajectory = lineBend } - pairs = zip stages (tail stages ++ [head stages]) - stages = - [ spike1 - , spike2 - , spike3 - ] - -genTrails :: [(Double -> Polygon)] -> SVG -genTrails plotters = - withFillOpacity 0 $ - withStrokeWidth (defaultStrokeWidth*0.5) $ - withStrokeColor "black" $ - withStrokeDashArray [0.1,0.05] $ - mkGroup $ map mkTrail $ transpose $ concat - [ - [ V.toList $ V.map (fmap realToFrac) (polygonPoints poly) - | n <- [0..steps] - , let poly = plotter (fromIntegral n / fromIntegral steps) - ] - | plotter <- plotters ] - where - steps = 100 :: Int - mkTrail lst = mkLinePath [ (x,y) | V2 x y <- lst ] diff --git a/examples/morphology_object_correspondence.hs b/examples/morphology_object_correspondence.hs --- a/examples/morphology_object_correspondence.hs +++ b/examples/morphology_object_correspondence.hs @@ -5,6 +5,7 @@ module Main(main) where import Codec.Picture +import Control.Lens ((&)) import Reanimate import Reanimate.Morph.Common import Reanimate.Morph.Linear @@ -21,9 +22,9 @@ sceneAnimation $ do let showLabel label = do fork $ play $ staticFrame 4 (center $ latex label) - # mapA (translate 0 4) - # applyE (overBeginning 0.1 fadeInE) - # applyE (overEnding 0.1 fadeOutE) + & mapA (translate 0 4) + & applyE (overBeginning 0.1 fadeInE) + & applyE (overEnding 0.1 fadeOutE) let sides = mkGroup [ translate (-4) 0 $ withFillColor "blue" $ mkCircle 2 @@ -35,21 +36,21 @@ showLabel "Cut" play $ step sides middle - # pauseAtEnd 1 + & pauseAtEnd 1 play $ step middle sides - # pauseAtEnd 1 + & pauseAtEnd 1 showLabel "Overlap" play $ stepDup sides middle - # pauseAtEnd 1 + & pauseAtEnd 1 play $ stepDup middle sides - # pauseAtEnd 1 + & pauseAtEnd 1 showLabel "Obliterate" play $ stepGenesis sides middle - # pauseAtEnd 1 + & pauseAtEnd 1 play $ stepGenesis middle sides - # pauseAtEnd 1 + & pauseAtEnd 1 where step from to = signalA (curveS 2) $ animate $ morph linear from to diff --git a/examples/morphology_point_correspondence.hs b/examples/morphology_point_correspondence.hs --- a/examples/morphology_point_correspondence.hs +++ b/examples/morphology_point_correspondence.hs @@ -6,9 +6,10 @@ import Codec.Picture import Codec.Picture.Types -import Control.Monad (replicateM_) -import qualified Data.Text as T -import qualified Data.Vector as V +import Control.Lens ((&)) +import Control.Monad (replicateM_) +import qualified Data.Text as T +import qualified Data.Vector as V import Linear.V2 import Linear.Vector import Reanimate @@ -52,7 +53,7 @@ replicateM_ 8 $ do offsetVal <- readVar offset play $ step pl1 (pl2 offsetVal 0) - # setDuration 3 + & setDuration 3 slideLeft where step from to = diff --git a/examples/morphology_point_trajectory.hs b/examples/morphology_point_trajectory.hs deleted file mode 100644 --- a/examples/morphology_point_trajectory.hs +++ /dev/null @@ -1,320 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -module Main where - -import Codec.Picture.Types -import Control.Lens -import Control.Monad -import Data.List -import Data.Maybe -import qualified Data.Text as T -import Data.Tuple -import qualified Data.Vector as V -import Linear.V2 -import Linear.Vector -import qualified Numeric.LinearAlgebra as Matrix -import Numeric.LinearAlgebra.HMatrix (Matrix, linearSolve, toLists, - (><)) -import Reanimate -import Reanimate.Math.Common -import Reanimate.Math.Polygon - -bgColor :: PixelRGBA8 -bgColor = PixelRGBA8 252 252 252 0xFF - -type Points = V.Vector (V2 Double) -type Edges = [(Int, Int, Int)] -data Mesh = Mesh { meshPoints :: Points, meshEdges :: Edges } -data MeshPair = MeshPair Points Points Edges --- The points in a RelMesh are: --- relMeshStatic ++ x where Ax = B -data RelMesh = RelMesh - { relMeshStatic :: Points - , relMeshEdges :: Edges - , relMeshA :: Matrix Double - , relMeshB :: Matrix Double - } -data RelMeshPair = RelMeshPair Points Edges (Matrix Double) (Matrix Double) (Matrix Double) (Matrix Double) --- Linear interpolation on RelMesh gives smooth morph. --- solveMesh :: RelMesh -> Mesh --- mkRelative :: Mesh -> RelMesh --- mkRelativePair :: MeshPair -> RelMeshPair --- triangulate :: Polygon -> Polygon -> MeshPair ? --- embed :: MeshPair -> MeshPair --- compatible :: Mesh -> Mesh -> Maybe MeshPair --- linearInterpolate :: MeshPair -> Double -> Mesh --- convexInterpolate :: RelMeshPair -> Double -> RelMesh - -meshToPolygon :: Mesh -> Polygon -meshToPolygon mesh = pScale 2 $ mkPolygon $ V.fromList - [ realToFrac <$> (meshPoints mesh V.! (n-1)) - | n <- polygonNodes ] - where - polygonNodes :: [Int] - polygonNodes = [5,8,9,7,4,6] - -main :: IO () -main = reanimate morphAnimation - -genTrails :: (Double -> Mesh) -> SVG -genTrails mkMesh = - withFillOpacity 0 $ - withStrokeWidth (defaultStrokeWidth*0.5) $ - withStrokeColor "black" $ - withStrokeDashArray [0.1,0.1] $ - mkGroup $ map mkTrail $ transpose - [ V.toList $ V.map (fmap realToFrac) $ polygonPoints $ meshToPolygon mesh - | n <- [0..steps] - , let mesh = mkMesh (fromIntegral n / fromIntegral steps) - ] - where - steps = 100 :: Int - mkTrail lst =mkLinePath [ (x,y) | V2 x y <- lst ] - -morphAnimation :: Animation -morphAnimation = playThenReverseA $ pauseAround 1 1 $ addStatic (mkBackgroundPixel bgColor) $ - signalA (curveS 2) $ mkAnimation 5 $ \t -> lowerTransformations $ scale 3 $ pathify $ - mkGroup - [ translate (-1.5) 0 $ withFillColor "lightgreen" $ mkGroup - [ withStrokeWidth defaultStrokeWidth $ - withStrokeColor "black" $ - polygonShape $ meshToPolygon $ linearInterpolate meshPair t - , linearTrails - , polygonNumDots (meshToPolygon $ linearInterpolate meshPair t) 0 - ] - , translate 1 0 $ withFillColor "cyan" $ mkGroup - [ withStrokeWidth defaultStrokeWidth $ - withStrokeColor "black" $ - polygonShape $ meshToPolygon $ solveMesh $ convexInterpolate relPair t - , curveTrails - , polygonNumDots (meshToPolygon $ solveMesh $ convexInterpolate relPair t) 0 - ] - ] - where - linearTrails = genTrails (linearInterpolate meshPair) - curveTrails = genTrails (solveMesh . convexInterpolate relPair) - relPair = mkRelativePair meshPair - meshPair = fromJust $ compatible example1 example2 - -mkLineP :: P -> P -> SVG -mkLineP (V2 x1 y1) (V2 x2 y2) = mkLine (x1,y1) (x2,y2) - --- FIXME: Check that the triangles are all anticlockwise. --- FIXME: Check that the edges connect all the points. --- FIXME: Check that the edgse leave no gaps. -compatible :: Mesh -> Mesh -> Maybe MeshPair -compatible a b = - if meshEdges a == meshEdges b && V.length (meshPoints a) == V.length (meshPoints b) - then Just $ MeshPair (meshPoints a) (meshPoints b) (meshEdges a) - else Nothing - -linearInterpolate :: MeshPair -> Double -> Mesh -linearInterpolate (MeshPair aP bP edges) t = Mesh - { meshPoints = V.zipWith (lerp (1-t)) aP bP - , meshEdges = edges } - -example1 :: Mesh -example1 = Mesh points edges - where - points = V.fromList - [ V2 1 0 - , V2 (-1/2) (sqrt 3 / 2) - , V2 (-1/2) (-sqrt 3 / 2) - , 3 * points V.! 0 ^/ 4 - , 3 * points V.! 1 ^/ 4 - , 3 * points V.! 2 ^/ 4 - , points V.! 0 ^/ 2 - , points V.! 1 ^/ 2 - , points V.! 2 ^/ 2 - ] - edges = - [ (1,5,4), (1,2,5), (2,6,5), (2,3,6), (3,4,6), (3,1,4) - , (4,8,7), (4,5,8), (5,9,8), (5,6,9), (6,7,9), (6,4,7), (7,8,9)] - -example2 :: Mesh -example2 = Mesh points edges - where - points = V.fromList - [ V2 1 0 - , V2 (-1/2) (sqrt 3 / 2) - , V2 (-1/2) (-sqrt 3 / 2) - , 3 * points V.! 2 ^/ 4 - , 3 * points V.! 0 ^/ 4 - , 3 * points V.! 1 ^/ 4 - , points V.! 1 ^/ 2 - , points V.! 2 ^/ 2 - , points V.! 0 ^/ 2 - ] - edges = meshEdges example1 - --- T = (U, G) --- G = [Polygon] --- U = nub $ concat G - -findStarNeighbours :: Eq a => [(a,a,a)] -> a -> [(a, a)] -findStarNeighbours allTrig self = - [ (b,c) - | (a,b,c) <- allTrig - , self == a - ] ++ - [ (c,a) - | (a,b,c) <- allTrig - , self == b - ] ++ - [ (a,b) - | (a,b,c) <- allTrig - , self == c - ] - -isInterior :: Eq a => [(a, a)] -> Bool -isInterior = isJust . getExteriorPoly - -getExteriorPoly :: Eq a => [(a, a)] -> Maybe [a] -getExteriorPoly [] = Nothing -getExteriorPoly ((a,b):rest) = worker [a] a b rest - where - worker acc start this [] = do - guard (start == this) - return (reverse acc) - worker acc start this xs = - case lookup this xs of - Just next -> worker (this:acc) start next (delete (this,next) xs) - Nothing -> - case lookup this (map swap xs) of - Just next -> worker (this:acc) start next (delete (next, this) xs) - Nothing -> Nothing - -convexInterpolate :: RelMeshPair -> Double -> RelMesh -convexInterpolate (RelMeshPair static edges leftM leftB rightM rightB) t = - RelMesh - { relMeshStatic = static - , relMeshEdges = edges - , relMeshA = Matrix.scale (1-t) leftM + - Matrix.scale t rightM - , relMeshB = Matrix.scale (1-t) leftB + - Matrix.scale t rightB - } - -solveMesh :: RelMesh -> Mesh -solveMesh (RelMesh static edges m b) = - case linearSolve m b of - Nothing -> error "Failed to solve mesh" - Just ret -> - Mesh (static <> V.fromList (worker (toLists ret))) edges - where - worker [] = [] - worker ([x]:[y]:rest) = V2 x y : worker rest - worker _ = error "invalid result" - -mkRelative :: Mesh -> RelMesh -mkRelative (Mesh points edges) = RelMesh (V.fromList exteriorPoints) edges mM bM - where - mM = (s><1) b - (s,exterior, (m, b)) = toParameters points edges - exteriorPoints = - [ points V.! (i-1) - | i <- exterior - ] - -mkRelativePair :: MeshPair -> RelMeshPair -mkRelativePair (MeshPair p1 p2 edges) = - let RelMesh static _ leftM leftB = mkRelative (Mesh p1 edges) - RelMesh _ _ rightM rightB = mkRelative (Mesh p2 edges) - in RelMeshPair static edges leftM leftB rightM rightB - -toParameters :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> (Int, [Int], ([[b]], [b])) -toParameters points groups = (length interior*2,exterior,unzip $ concat - [ let lst = [(if i == j then -1 else t) - | j <- interior - , let t = fromMaybe 0 $ lookup (i,j) lam_ij_cache - ] - pos = negate $ sum - [ pj ^* t - | j <- exterior - , let t = fromMaybe 0 $ lookup (i,j) lam_ij_cache - pj = points V.! (j-1) - ] - in [ (dupX lst, pos ^. _x) - , (dupY lst, pos ^. _y)] - | i <- interior ]) - where - lam_ij_cache = lam_ij points groups - dupX [] = [] - dupX (x:xs) = x:0:dupX xs - dupY [] = [] - dupY (x:xs) = 0:x:dupY xs - (interior, exterior) = - partition (isInterior . findStarNeighbours groups) [1 .. length points] - -lam_ij :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> [((Int, Int), b)] -lam_ij points groups = - [ ((i, j), t) - | i <- [1..V.length points] - , (j, t) <- lam_j points groups i - ] - -lam_j :: (Ord b, Fractional b) => V.Vector (V2 b) -> [(Int, Int, Int)] -> Int -> [(Int, b)] -lam_j points groups p = - [ (nP, sum [ t | (j,_k,t) <- mu, j == nP ] / fromIntegral (length nPoints)) - | let n = findStarNeighbours groups p - nPoints = fromMaybe [] $ getExteriorPoly n - mu = calcMu points groups p - , nP <- nPoints ] - -calcMu :: (Ord c, Fractional c) => V.Vector (V2 c) -> [(Int, Int, Int)] -> Int -> [(Int, Int, c)] -calcMu points groups p = concat - [ [ (nP, nP, t1) - , (a, nP, t2) - , (b, nP, t3) ] - -- (nP, a, b) - | {-p <- [1..length points]-} - let selfVert = points V.! (p-1) - n = findStarNeighbours groups p - nPoints :: [Int] - nPoints = fromMaybe [] $ getExteriorPoly n - , nP <- nPoints - , let vert = points V.! (nP-1) - , let line = (vert, selfVert) - , let (a,b,aP,bP) = head $ - [ (_a,_b,_aP,_bP) - | (_a,_b) <- n - , let _aP = points V.! (_a-1) - _bP = points V.! (_b-1) - segment = (points V.! (_a-1), points V.! (_b-1)) - , case rayIntersect line segment of - Nothing -> False - Just u -> isBetween u segment - , _a /= nP - , _b /= nP ] - -- , b == (nPoints ++ nPoints) !! i - , let (t1,t2,t3) = barycentricCoords vert aP bP selfVert - ] - -genColor :: Int -> Int -> PixelRGBA8 -genColor n m = - promotePixel $ parula (fromIntegral (n+offset) / fromIntegral (m+offset)) - where - offset = 5 - -polygonNumDots :: Polygon -> Double -> SVG -polygonNumDots p t = mkGroup $ reverse - [ mkGroup - [ colored n $ withStrokeWidth (defaultStrokeWidth*0.5) $ withStrokeColor "black" $ - translate x y $ mkCircle circR - , withFillColor "black" $ - translate x y $ ppNum n ] - | n <- [0..pSize p-1] - , let a = realToFrac <$> pAccess p n - b = realToFrac <$> pAccess p (pNext p n) - V2 x y = lerp t b a ] - where - circR = 0.1 - colored n = - let c = genColor n (pSize p-1) - in withFillColorPixel c - ppNum n = scaleToHeight (circR*1.5) $ center $ latex $ T.pack $ "\\texttt{" ++ show n ++ "}" - -polygonShape :: Polygon -> SVG -polygonShape p = mkLinePathClosed - [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ] diff --git a/examples/morphology_rigid.hs b/examples/morphology_rigid.hs deleted file mode 100644 --- a/examples/morphology_rigid.hs +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ParallelListComp #-} -module Main(main) where - -import Codec.Picture -import Codec.Picture.Types -import Control.Monad -import Graphics.SvgTree (LineJoin (..)) -import Reanimate -import Reanimate.Morph.Common -import Reanimate.Morph.Linear -import Reanimate.Morph.Rigid (rigidMorph) - -bgColor :: PixelRGBA8 -bgColor = PixelRGBA8 252 252 252 0xFF - -main :: IO () -main = reanimate $ - addStatic (mkBackgroundPixel bgColor) $ - mapA (withStrokeWidth defaultStrokeWidth) $ - mapA (withStrokeColor "black") $ - mapA (withStrokeLineJoin JoinRound) $ - mapA (withFillOpacity 1) $ - sceneAnimation $ do - _ <- newSpriteSVG $ - withStrokeWidth 0 $ translate (-3) 4 $ - center $ latex "linear" - _ <- newSpriteSVG $ - withStrokeWidth 0 $ translate (3) 4 $ - center $ latex "as-rigid-as-possible" - forM_ pairs $ uncurry showPair - where - showPair from to = - waitOn $ do - fork $ play $ mkAnimation 4 (morph linear from to) - # mapA (translate (-3) (-0.5) . lowerTransformations . scale 1) - # signalA (curveS 4) - fork $ play $ mkAnimation 4 (morph myMorph from to) - # mapA (translate (3) (-0.5) . lowerTransformations . scale 1) - # signalA (curveS 4) - - myMorph = linear{morphTrajectory = rigidMorph, morphTolerance = 0.001 } - pairs = zip stages (tail stages ++ [head stages]) - stages = map (lowerTransformations . scale 6 . pathify . center) $ colorize - [ latex "S" - , latex "C" - ] - -- [ latex "X" - -- , latex "$\\aleph$" - -- , latex "Y" - -- , latex "$\\infty$" - -- , latex "I" - -- , latex "$\\pi$" - -- , latex "1" - -- , latex "S" - -- , mkRect 0.5 0.5 - -- ] - -colorize :: [SVG] -> [SVG] -colorize lst = - [ withFillColorPixel (promotePixel $ parula (n/fromIntegral (length lst-1))) elt - | elt <- lst - | n <- [0..] - ] diff --git a/examples/morphology_rotational.hs b/examples/morphology_rotational.hs --- a/examples/morphology_rotational.hs +++ b/examples/morphology_rotational.hs @@ -6,8 +6,9 @@ import Codec.Picture import Codec.Picture.Types +import Control.Lens ((&)) import Control.Monad -import Graphics.SvgTree (LineJoin(..)) +import Graphics.SvgTree (LineJoin (..)) import Reanimate import Reanimate.Morph.Common import Reanimate.Morph.Linear @@ -35,11 +36,11 @@ showPair from to = waitOn $ do fork $ play $ mkAnimation 4 (morph linear from to) - # mapA (translate (-3) (-0.5)) - # signalA (curveS 4) + & mapA (translate (-3) (-0.5)) + & signalA (curveS 4) fork $ play $ mkAnimation 4 (morph myMorph from to) - # mapA (translate (3) (-0.5)) - # signalA (curveS 4) + & mapA (translate (3) (-0.5)) + & signalA (curveS 4) myMorph = linear{morphTrajectory = rotationalTrajectory origin } origin = (0.5, 0.5) pairs = zip stages (tail stages ++ [head stages]) diff --git a/examples/morphology_rotational_intro.hs b/examples/morphology_rotational_intro.hs --- a/examples/morphology_rotational_intro.hs +++ b/examples/morphology_rotational_intro.hs @@ -6,6 +6,7 @@ module Main(main) where import Codec.Picture +import Control.Lens ((&)) import Data.List (transpose) import qualified Data.Vector as V import Graphics.SvgTree (LineJoin (..)) @@ -84,9 +85,9 @@ showPair originVar from to = waitOn $ do fork $ play $ mkAnimation 2 (morph linear (polygonShape from) (polygonShape to)) - # mapA (translate (-4) (-0.5)) - # mapA (withFillColor "lightgreen") - # signalA (curveS 4) + & mapA (translate (-4) (-0.5)) + & mapA (withFillColor "lightgreen") + & signalA (curveS 4) s <- fork $ newSprite $ do origin <- unVar originVar t <- spriteT diff --git a/examples/polyshape_test1.hs b/examples/polyshape_test1.hs deleted file mode 100644 --- a/examples/polyshape_test1.hs +++ /dev/null @@ -1,92 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -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 deleted file mode 100644 --- a/examples/polyshape_test2.hs +++ /dev/null @@ -1,34 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -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 deleted file mode 100644 --- a/examples/polyshape_test3.hs +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -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 deleted file mode 100644 --- a/examples/polyshape_test4.hs +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -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/shatter.hs b/examples/shatter.hs deleted file mode 100644 --- a/examples/shatter.hs +++ /dev/null @@ -1,135 +0,0 @@ -#!/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 deleted file mode 100644 --- a/examples/signals.hs +++ /dev/null @@ -1,84 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Data.Text (Text, pack) -import Graphics.SvgTree hiding (Text) -import Numeric -import Reanimate.Animation -import Reanimate.Constants -import Reanimate - -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 deleted file mode 100644 --- a/examples/simulate_equation.hs +++ /dev/null @@ -1,201 +0,0 @@ -#!/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 deleted file mode 100644 --- a/examples/simulate_gravity.golden +++ /dev/null @@ -1,10 +0,0 @@ -0 -1 -2 -3 -4 -5 -6 -7 -8 -9 diff --git a/examples/simulate_gravity.hs b/examples/simulate_gravity.hs deleted file mode 100644 --- a/examples/simulate_gravity.hs +++ /dev/null @@ -1,79 +0,0 @@ -#!/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 --- a/examples/sorting.hs +++ b/examples/sorting.hs @@ -2,6 +2,7 @@ -- stack runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PackageImports #-} module Main (main) where import Codec.Picture @@ -13,7 +14,7 @@ import qualified Data.Vector.Unboxed as V import Reanimate import System.Random -import System.Random.Shuffle +import "random-shuffle" System.Random.Shuffle main :: IO () main = reanimate $ diff --git a/examples/tut_glue_blender.hs b/examples/tut_glue_blender.hs --- a/examples/tut_glue_blender.hs +++ b/examples/tut_glue_blender.hs @@ -3,20 +3,21 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE PackageImports #-} module Main (main) where import Reanimate import Reanimate.Builtin.Documentation import Codec.Picture.Types -import Control.Lens ((^.)) +import Control.Lens ((&), (^.)) import Control.Monad import Data.Monoid import qualified Data.Text as T import Graphics.SvgTree hiding (text) import NeatInterpolation import System.Random -import System.Random.Shuffle +import "random-shuffle" System.Random.Shuffle -- spritePercent = (/) <$> spriteT <*> spriteDur @@ -216,7 +217,7 @@ mapM_ destroySprite sprites -- Undraw equations play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg - # reverseA + & reverseA where glyphs = svgGlyphs svg strokedSvg = @@ -258,7 +259,7 @@ fork $ do wait (n*step) play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree) - # applyE (overEnding fillDur $ fadeLineOutE sWidth)) + & applyE (overEnding fillDur $ fadeLineOutE sWidth)) fork $ do wait (n*step+(1-fillDur)) newSprite $ do diff --git a/examples/tut_glue_fourier.hs b/examples/tut_glue_fourier.hs --- a/examples/tut_glue_fourier.hs +++ b/examples/tut_glue_fourier.hs @@ -3,26 +3,26 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Codec.Picture +import Control.Lens import Data.Complex import Graphics.SvgTree import Linear.V2 import Reanimate -import Reanimate.Ease -import Codec.Picture -- layer 3 main :: IO () main = reanimate $ setDuration 30 $ sceneAnimation $ do _ <- newSpriteSVG $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF) play $ fourierA (fromToS 0 5) -- Rotate 15 times - # setDuration 50 - # signalA (reverseS . powerS 2 . reverseS) -- Start fast, end slow - # pauseAtEnd 2 + & setDuration 50 + & signalA (reverseS . powerS 2 . reverseS) -- Start fast, end slow + & pauseAtEnd 2 play $ fourierA (constantS 0) -- Don't rotate at all - # setDuration 10 - # reverseA - # signalA (powerS 2) -- Start slow, end fast - # pauseAtEnd 2 + & setDuration 10 + & reverseA + & signalA (powerS 2) -- Start slow, end fast + & pauseAtEnd 2 -- layer 2 fourierA :: (Double -> Double) -> Animation diff --git a/examples/tut_glue_keyframe.hs b/examples/tut_glue_keyframe.hs --- a/examples/tut_glue_keyframe.hs +++ b/examples/tut_glue_keyframe.hs @@ -4,11 +4,11 @@ {-# LANGUAGE RecursiveDo #-} module Main (main) where -import Reanimate - +import Codec.Picture +import Control.Lens import Control.Monad (forM_) import Graphics.SvgTree (Tree) -import Codec.Picture +import Reanimate main :: IO () main = reanimate $ bg `parA` mainScene @@ -18,30 +18,30 @@ mainScene :: Animation mainScene = sceneAnimation $ mdo play $ drawCircle - # setDuration drawCircleT - # applyE (constE flipXAxis) - # signalA (curveS 2) + & setDuration drawCircleT + & applyE (constE flipXAxis) + & signalA (curveS 2) fork $ play $ drawCircle - # freezeAtPercentage 1 - # setDuration rotDur + & freezeAtPercentage 1 + & setDuration rotDur rotDur <- withSceneDuration $ waitOn $ forM_ svgs $ \svg -> do fork $ play $ drawTick - # setDuration rotateT - # repeatA rotateN - # applyE (overBeginning 0.5 drawInE) - # applyE (overEnding 0.5 drawOutE) + & 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) + & setDuration rotateT + & repeatA rotateN + & applyE (overBeginning rotateT drawInE) + & applyE (delayE rotateT $ overBeginning 1 fillInE) + & applyE (overEnding 0.5 fadeOutE) wait (rotateT / fromIntegral (1+length svgs)) play $ drawCircle - # setDuration drawCircleT - # reverseA - # signalA (curveS 2) + & setDuration drawCircleT + & reverseA + & signalA (curveS 2) return () where drawCircleT = 2.5 diff --git a/examples/tut_glue_latex.hs b/examples/tut_glue_latex.hs --- a/examples/tut_glue_latex.hs +++ b/examples/tut_glue_latex.hs @@ -1,19 +1,20 @@ #!/usr/bin/env stack -- stack runghc --package reanimate +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE PackageImports #-} module Main (main) where import Reanimate import Codec.Picture import Codec.Picture.Types -import Control.Lens ((^.)) +import Control.Lens ((&), (^.)) import Control.Monad import Data.Monoid import Graphics.SvgTree import System.Random -import System.Random.Shuffle +import "random-shuffle" System.Random.Shuffle main :: IO () main = reanimate $ parA bg latexExample @@ -38,7 +39,7 @@ mapM_ destroySprite sprites -- Undraw equations play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg - # reverseA + & reverseA where glyphs = svgGlyphs svg strokedSvg = @@ -80,7 +81,7 @@ fork $ do wait (n*step) play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree) - # applyE (overEnding fillDur $ fadeLineOutE sWidth)) + & applyE (overEnding fillDur $ fadeLineOutE sWidth)) fork $ do wait (n*step+(1-fillDur)) newSprite $ do diff --git a/examples/tut_glue_physics.hs b/examples/tut_glue_physics.hs deleted file mode 100644 --- a/examples/tut_glue_physics.hs +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Main (main) where - -import Chiphunk.Low -import Codec.Picture (PixelRGBA8 (..)) -import Control.Monad (forM_) -import Linear.V2 (V2 (..)) -import Reanimate -import Reanimate.Chiphunk -import Reanimate.PolyShape -import Reanimate.Ease -import System.IO.Unsafe (unsafePerformIO) - -shatter :: Animation -shatter = unsafePerformIO $ do - bodyStore <- newBodyStore - let gravity = Vect 0 (-1) -- Gravity points down (negative 1 y/s^2) - - space <- spaceNew - spaceGravity space $= gravity - - static <- get $ spaceStaticBody space - ground <- segmentShapeNew static - (Vect (-screenWidth/2) (-screenHeight/2)) - (Vect (screenWidth/2) (-screenHeight/2)) 0 - shapeFriction ground $= 1 - spaceAddShape space ground - - let toVect (V2 x y) = Vect x y - vectGroup = plDecompose $ svgToPolyShapes $ center $ scale 4 $ - latex "$F=ma$" - - forM_ vectGroup $ \polygon -> do - bd <- polygonsToBody space [map toVect polygon] - bodyPosition bd $= Vect 0 (screenHeight/3) - addToBodyStore bodyStore bd $ - renderPolyShape $ plFromPolygon polygon - - ani <- simulate space bodyStore fps stepsPerFrame shatterT - spaceFreeRecursive space - return $ mapA pp ani - where - shatterT = 10 - fps = 60 - stepsPerFrame = 10 - pp = withStrokeWidth 0.01 . withStrokeColor "black" . withFillColor "black" - -main :: IO () -main = reanimate $ parA bg $ sceneAnimation $ do - play $ shatter - play $ shatter - # reverseA - # setDuration 5 - # signalA (powerS 2) - where - bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF) diff --git a/examples/tut_glue_potrace.hs b/examples/tut_glue_potrace.hs --- a/examples/tut_glue_potrace.hs +++ b/examples/tut_glue_potrace.hs @@ -8,6 +8,7 @@ import Reanimate.Povray (povraySlow') import Codec.Picture +import Control.Lens import Control.Monad import Data.Text (Text) import qualified Data.Text as T @@ -25,7 +26,7 @@ tweenVar xRot (wobbleDur/2) $ \v -> fromToS v (v-90) . curveS 2 destroySprite wf play $ mkAnimation drawDuration (\t -> partialSvg t (wireframe (-45) 220)) - # reverseA + & reverseA where drawDuration = 10 wobbles = 3 diff --git a/examples/tut_glue_povray.hs b/examples/tut_glue_povray.hs --- a/examples/tut_glue_povray.hs +++ b/examples/tut_glue_povray.hs @@ -1,8 +1,9 @@ #!/usr/bin/env stack -- stack runghc --package reanimate +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE PackageImports #-} module Main (main) where import Reanimate @@ -10,15 +11,15 @@ import Codec.Picture import Codec.Picture.Types -import Control.Lens ((^.)) +import Control.Lens ((&), (^.)) import Control.Monad -import qualified Data.Text as T import Data.Monoid -import NeatInterpolation import Data.Text (Text) -import Graphics.SvgTree hiding (Text,text) +import qualified Data.Text as T +import Graphics.SvgTree hiding (Text, text) +import NeatInterpolation import System.Random -import System.Random.Shuffle +import "random-shuffle" System.Random.Shuffle main :: IO () @@ -109,7 +110,7 @@ mapM_ destroySprite sprites -- Undraw equations play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg - # reverseA + & reverseA where glyphs = svgGlyphs svg strokedSvg = @@ -151,7 +152,7 @@ fork $ do wait (n*step) play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree) - # applyE (overEnding fillDur $ fadeLineOutE sWidth)) + & applyE (overEnding fillDur $ fadeLineOutE sWidth)) fork $ do wait (n*step+(1-fillDur)) newSprite $ do diff --git a/examples/tut_glue_povray_ortho.hs b/examples/tut_glue_povray_ortho.hs --- a/examples/tut_glue_povray_ortho.hs +++ b/examples/tut_glue_povray_ortho.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE PackageImports #-} module Main (main) where import Reanimate @@ -10,7 +11,7 @@ import Codec.Picture import Codec.Picture.Types -import Control.Lens ((^.)) +import Control.Lens ((^.),(&)) import Control.Monad import Data.Monoid import Data.Text (Text) @@ -18,7 +19,7 @@ import Graphics.SvgTree hiding (Text,text) import NeatInterpolation import System.Random -import System.Random.Shuffle +import "random-shuffle" System.Random.Shuffle main :: IO () @@ -147,7 +148,7 @@ mapM_ destroySprite sprites -- Undraw equations play $ drawAnimation' (Just 0xdeadbeef) 1 0.1 strokedSvg - # reverseA + & reverseA where glyphs = svgGlyphs svg strokedSvg = @@ -189,7 +190,7 @@ fork $ do wait (n*step) play $ mapA fn $ (animate (\t -> withFillOpacity 0 $ partialSvg t tree) - # applyE (overEnding fillDur $ fadeLineOutE sWidth)) + & applyE (overEnding fillDur $ fadeLineOutE sWidth)) fork $ do wait (n*step+(1-fillDur)) newSprite $ do diff --git a/examples/voice_advanced.hs b/examples/voice_advanced.hs --- a/examples/voice_advanced.hs +++ b/examples/voice_advanced.hs @@ -7,7 +7,6 @@ import Control.Monad import qualified Data.Text as T import Reanimate -import Reanimate.Ease import Reanimate.Voice import Reanimate.Builtin.Documentation import Geom2D.CubicBezier ( QuadBezier(..) diff --git a/examples/voice_triggers.hs b/examples/voice_triggers.hs --- a/examples/voice_triggers.hs +++ b/examples/voice_triggers.hs @@ -1,15 +1,16 @@ #!/usr/bin/env stack -- stack runghc --package reanimate +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ApplicativeDo #-} module Main where +import Control.Lens import Control.Monad -import qualified Data.Text as T +import qualified Data.Text as T +import Graphics.SvgTree (ElementRef (..)) import Reanimate -import Reanimate.Voice import Reanimate.Builtin.Documentation -import Graphics.SvgTree ( ElementRef(..) ) +import Reanimate.Voice transcript :: Transcript transcript = loadTranscript "voice_triggers.txt" @@ -53,8 +54,8 @@ translate (screenWidth / 4) 0 $ scale t $ scaleToHeight 4 $ center img ) - # signalA (bellS 2) - # setDuration dur + & signalA (bellS 2) + & setDuration dur {-# INLINE masked #-} masked :: String -> Double -> SVG -> SVG -> SVG -> SVG 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.4.1.0 +version: 0.4.2.0 -- synopsis: -- description: license: PublicDomain @@ -11,7 +11,7 @@ maintainer: lemmih@gmail.com category: Graphics synopsis: Animation library based on SVGs. -homepage: https://github.com/reanimate/reanimate#readme +homepage: https://reanimate.github.io bug-reports: https://github.com/reanimate/reanimate/issues build-type: Simple extra-source-files: ChangeLog.md, examples/*.hs, examples/*.golden @@ -37,23 +37,6 @@ Type: git Location: git://github.com/lemmih/reanimate.git --- If both 'enable-hmatrix' and 'disable-hmatrix' are false, then use --- hmatrix on Macos and Linux but not Windows. -Flag enable-hmatrix - Description: Enable hmatrix dependency on Windows (requires openblas) - Default: False - Manual: True - -Flag disable-hmatrix - Description: Force disable hmatrix dependency - Default: False - Manual: True - -Flag test - Description: Enable testing (requires stack) - Default: False - Manual: True - library hs-source-dirs: src default-language: Haskell2010 @@ -68,24 +51,15 @@ Reanimate.Svg.Constructors Reanimate.Svg.BoundingBox Reanimate.Svg.LineCommand - -- Reanimate.Diagrams Reanimate.Transform - Reanimate.Misc + Reanimate.Math.Triangulate Reanimate.Math.Common Reanimate.Math.Polygon - Reanimate.Math.Triangulate - Reanimate.Math.EarClip - Reanimate.Math.Visibility Reanimate.Math.SSSP Reanimate.Math.Balloon - Reanimate.Math.Compatible - Reanimate.Math.Render Reanimate.Morph.Common Reanimate.Morph.Linear Reanimate.Morph.Rotational - Reanimate.Morph.LeastWork - Reanimate.Morph.LineBend - Reanimate.Morph.Cache Reanimate.Raster Reanimate.ColorComponents Reanimate.ColorMap @@ -102,38 +76,67 @@ Reanimate.Builtin.Slide Reanimate.Constants Reanimate.Parameters - Reanimate.Chiphunk Reanimate.PolyShape Reanimate.GeoProjection Reanimate.Builtin.Documentation Reanimate.Builtin.Images Reanimate.Debug Reanimate.Voice + Geom2D.CubicBezier.Linear other-modules: Reanimate.Cache + Reanimate.Morph.Cache Reanimate.Driver Reanimate.Driver.Check Reanimate.Driver.CLI Reanimate.Driver.Magick Reanimate.Driver.Server Reanimate.Driver.Compile + Reanimate.Misc Paths_reanimate - build-depends: base >=4.10 && <5, - time, text, filepath, process, directory, - containers, reanimate-svg >= 0.10.0.0, xml, bytestring, lens, linear, mtl, matrix, - JuicyPixels >= 3.3.3, attoparsec, parallel, - cubicbezier, websockets >= 0.12.7.0, - hashable, fsnotify, open-browser, random, random-shuffle, base64-bytestring, - vector >= 0.12.0.0, colour, cassava, ansi-terminal, temporary, - optparse-applicative, chiphunk >= 0.1.2.1, - geojson, aeson >= 1.3.0.0, earcut >= 0.1.0.4, - split, array, cereal, vector-space, - neat-interpolation >= 0.3 - if (flag(enable-hmatrix) || !os(windows)) && !flag(disable-hmatrix) { - build-depends: hmatrix >= 0.20.0.0 - exposed-modules: Reanimate.Morph.Rigid - Reanimate.Math.Smooth - Reanimate.Math.DCEL - } + Reanimate.Math.Visibility + build-depends: + base >=4.10 && <5, + JuicyPixels >=3.3.3, + aeson >=1.3.0.0, + ansi-terminal >=0.8.0.4, + array >=0.5.2.0, + attoparsec >=0.13.2.0, + base64-bytestring >=1.0.0.1, + bytestring >=0.10.8.0, + cassava >=0.5.1.0, + cereal >=0.5.5.0, + colour >=2.3.4, + containers >=0.5.11.0, + cubicbezier >=0.6.0.5, + directory >=1.3.1.0, + filelock >=0.1.1.2, + filepath >=1.4.2, + fsnotify >=0.3.0.1, + geojson >=3.0.4, + ghcid >=0.7, + hashable >=1.2.7.0, + hgeometry >=0.11.0.0, + hgeometry-combinatorial >=0.11.0.0, + lens >=4.16.1, + linear >=1.20.8, + matrix >=0.3.6.1, + mtl >=2.2.2, + neat-interpolation >=0.3, + open-browser >=0.2.1.0, + optparse-applicative >=0.14.2.0, + parallel >=3.2.1.0, + process >=1.6.3.0, + random >=1.1, + random-shuffle >=0.0.4, + reanimate-svg >=0.10.0.0, + split >=0.2.3.3, + temporary >=1.3, + text >=1.2.3.0, + time >=1.8.0.0, + vector >=0.12.0.0, + vector-space >=0.13, + websockets >=0.12.7.0, + xml >=1.3.14 ghc-options: -Wall -fno-ignore-asserts test-suite spec @@ -145,16 +148,15 @@ Properties Helpers hs-source-dirs: test - if !flag(test) { - Buildable: False - } ghc-options: -w build-depends: base, directory, filepath, bytestring, process, - reanimate, vector, linear, + reanimate, + vector, linear, QuickCheck >= 2.1.0, text, + temporary, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, tasty-rerun >= 1.1.17 diff --git a/src/Geom2D/CubicBezier/Linear.hs b/src/Geom2D/CubicBezier/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Geom2D/CubicBezier/Linear.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-| +Module : Geom2D.CubicBezier.Linear +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +Convenience wrapper around 'Geom2D.CubicBezier' + +-} +module Geom2D.CubicBezier.Linear + ( AnyBezier(..) + , CubicBezier(..) + , QuadBezier(..) + , OpenPath(..) + , ClosedPath(..) + , PathJoin(..) + , ClosedMetaPath(..) + , OpenMetaPath(..) + , MetaJoin(..) + , MetaNodeType(..) + , FillRule(..) + , Tension(..) + , quadToCubic + , arcLength + , arcLengthParam + , C.splitBezier + , colinear + , evalBezier + , evalBezierDeriv + , bezierHoriz + , bezierVert + , C.bezierSubsegment + , C.reorient + , closedPathCurves + , openPathCurves + , curvesToClosed + , closest + , unmetaOpen + , unmetaClosed + , union + , bezierIntersection + , interpolateVector + , vectorDistance + , findBezierInflection + , findBezierCusp + ) where + +import qualified Data.Vector.Unboxed as V +import qualified Geom2D.CubicBezier as C +import Graphics.SvgTree (FillRule (..)) +import Linear.V2 + +------------------------------------------------------------ +-- Data types + +-- | A bezier curve of any degree. +newtype AnyBezier a = AnyBezier (V.Vector (V2 a)) + +-- | A cubic bezier curve. +data CubicBezier a = CubicBezier + { cubicC0 :: !(V2 a) + , cubicC1 :: !(V2 a) + , cubicC2 :: !(V2 a) + , cubicC3 :: !(V2 a) + } deriving (Show, Eq) + +-- | A quadratic bezier curve. +data QuadBezier a = QuadBezier + { quadC0 :: !(V2 a) + , quadC1 :: !(V2 a) + , quadC2 :: !(V2 a) + } deriving (Show, Eq) + +-- | Open cubicbezier path. +data OpenPath a = OpenPath [(V2 a, PathJoin a)] (V2 a) + deriving (Show, Eq) + +-- | Closed cubicbezier path. +data ClosedPath a = ClosedPath [(V2 a, PathJoin a)] + deriving (Show, Eq) + +-- | Join two points with either a straight line or a bezier +-- curve with two control points. +data PathJoin a + = JoinLine + | JoinCurve (V2 a) (V2 a) + deriving (Show, Eq) + +-- | Closed meta path. +data ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)] + deriving (Show, Eq) + +-- | Open meta path +data OpenMetaPath a = OpenMetaPath [(V2 a, MetaJoin a)] (V2 a) + deriving (Show, Eq) + +-- | The tension value specifies how /tense/ the curve is. +-- A higher value means the curve approaches a line segment, +-- while a lower value means the curve is more round. Metafont +-- doesn't allow values below 3/4. +data Tension a + = Tension + { tensionValue :: a } + | TensionAtLeast -- ^ Like Tension, but keep the segment inside the + -- bounding triangle defined by the control points, + -- if there is one. + { tensionValue :: a } + deriving (Functor, Foldable, Traversable, Eq, Show) + +-- | Join two meta points with either a bezier curve or tension +-- contraints. +data MetaJoin a + = MetaJoin + { metaTypeL :: MetaNodeType a + , tensionL :: Tension a + , tensionR :: Tension a + , metaTypeR :: MetaNodeType a + } + | Controls (V2 a) (V2 a) + deriving (Show, Eq) + +-- | Node constraint type. +data MetaNodeType a + = Open + | Curl { curlgamma :: a } + | Direction { nodedir :: V2 a } + deriving (Show, Eq) + +------------------------------------------------------------ +-- Methods + +-- | Convert a quadratic bezier to a cubic bezier. +quadToCubic :: Fractional a => QuadBezier a -> CubicBezier a +quadToCubic = upCast . C.quadToCubic . downCast + +-- | @arcLength c t tol@ finds the arclength of the bezier @c@ at @t@, +-- within given tolerance @tol@. +arcLength :: CubicBezier Double -> Double -> Double -> Double +arcLength bezier t tol = C.arcLength (downCast bezier) t tol + +-- | @arcLengthParam c len tol@ finds the parameter where the curve @c@ +-- has the arclength @len@, within tolerance @tol@. +arcLengthParam :: CubicBezier Double -> Double -> Double -> Double +arcLengthParam bezier t tol = C.arcLengthParam (downCast bezier) t tol + +-- | Return @False@ if some points fall outside a line with a thickness of the given tolerance. +colinear :: CubicBezier Double -> Double -> Bool +colinear bezier tol = C.colinear (downCast bezier) tol + +-- | Calculate a value on the bezier curve. +evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a +evalBezier c p = upCast $ C.evalBezier c p + +-- | Calculate a value and the first derivative on the curve. +evalBezierDeriv :: (V.Unbox a, Fractional a,C.GenericBezier b) => b a -> a -> (V2 a, V2 a) +evalBezierDeriv c p = upCast $ C.evalBezierDeriv c p + +-- | Find the parameter where the bezier curve is horizontal. +bezierHoriz :: CubicBezier Double -> [Double] +bezierHoriz = C.bezierHoriz . downCast + +-- | Find the parameter where the bezier curve is vertical. +bezierVert :: CubicBezier Double -> [Double] +bezierVert = C.bezierVert . downCast + +-- | Create a normal path from a metapath. +unmetaOpen :: OpenMetaPath Double -> OpenPath Double +unmetaOpen = upCast . C.unmetaOpen . downCast + +-- | Create a normal path from a metapath. +unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double +unmetaClosed = upCast . C.unmetaClosed . downCast + +-- | `O((n+m)*log(n+m))`, for n segments and m intersections. +-- Union of paths, removing overlap and rounding to the given tolerance. +union :: [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double] +union p fill tol = upCast (C.union (downCast p) (downCast fill) tol) + +-- | Find the intersections between two Bezier curves, using the Bezier Clip algorithm. +-- Returns the parameters for both curves. +bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)] +bezierIntersection a b t = C.bezierIntersection (downCast a) (downCast b) t + +-- | Find the closest value on the bezier to the given point, within tolerance. +-- Return the first value found. +closest :: CubicBezier Double -> V2 Double -> Double -> Double +closest c p t = C.closest (downCast c) (downCast p) t + +-- | Return the closed path as a list of curves. +closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a] +closedPathCurves = upCast . C.closedPathCurves . downCast + +-- | Return the open path as a list of curves. +openPathCurves :: Fractional a => OpenPath a -> [CubicBezier a] +openPathCurves = upCast . C.openPathCurves . downCast + +-- | Make an open path from a list of curves. The last control point of each curve is ignored. +curvesToClosed :: [CubicBezier a] -> ClosedPath a +curvesToClosed = upCast . C.curvesToClosed . downCast + +-- | Interpolate between two vectors. +interpolateVector :: Num a => V2 a -> V2 a -> a -> V2 a +interpolateVector a b p = upCast $ C.interpolateVector (downCast a) (downCast b) p + +-- | Distance between two vectors. +vectorDistance :: Floating a => V2 a -> V2 a -> a +vectorDistance a b = C.vectorDistance (downCast a) (downCast b) + +-- | Find inflection points on the curve. +findBezierInflection :: CubicBezier Double -> [Double] +findBezierInflection = C.findBezierInflection . downCast + +-- | Find the cusps of a bezier. +findBezierCusp :: CubicBezier Double -> [Double] +findBezierCusp = C.findBezierCusp . downCast + +------------------------------------------------------------ +-- Instances + +instance C.GenericBezier QuadBezier where + degree = C.degree . downCast + toVector = C.toVector . downCast + unsafeFromVector = upCast . C.unsafeFromVector + +instance C.GenericBezier CubicBezier where + degree = C.degree . downCast + toVector = C.toVector . downCast + unsafeFromVector = upCast . C.unsafeFromVector + +instance C.GenericBezier AnyBezier where + degree = C.degree . downCast + toVector = C.toVector . downCast + unsafeFromVector = upCast . C.unsafeFromVector + +------------------------------------------------------------ +-- Casting + +class Cast a b | a -> b, b -> a where + downCast :: a -> b + upCast :: b -> a + +instance Cast a b => Cast [a] [b] where + downCast = map downCast + upCast = map upCast + +instance (Cast a a', Cast b b') => Cast (a,b) (a',b') where + downCast (a, b) = (downCast a, downCast b) + upCast (a, b) = (upCast a, upCast b) + +instance Cast (V2 a) (C.Point a) where + downCast (V2 a b) = C.Point a b + upCast (C.Point a b) = V2 a b + +instance Cast FillRule C.FillRule where + downCast FillEvenOdd = C.EvenOdd + downCast FillNonZero = C.NonZero + upCast C.EvenOdd = FillEvenOdd + upCast C.NonZero = FillNonZero + +instance Cast (CubicBezier a) (C.CubicBezier a) where + downCast (CubicBezier a b c d) = C.CubicBezier + (downCast a) (downCast b) (downCast c) (downCast d) + upCast (C.CubicBezier a b c d) = CubicBezier + (upCast a) (upCast b) (upCast c) (upCast d) + +instance Cast (QuadBezier a) (C.QuadBezier a) where + downCast (QuadBezier a b c) = C.QuadBezier + (downCast a) (downCast b) (downCast c) + upCast (C.QuadBezier a b c)= QuadBezier + (upCast a) (upCast b) (upCast c) + +instance V.Unbox a => Cast (AnyBezier a) (C.AnyBezier a) where + downCast (AnyBezier arr) = C.AnyBezier $ + V.map (\(V2 a b) -> (a,b)) arr + upCast (C.AnyBezier arr) = AnyBezier $ + V.map (\(a, b) -> V2 a b) arr + +instance Cast (MetaNodeType a) (C.MetaNodeType a) where + downCast Open = C.Open + downCast (Curl gamma) = C.Curl gamma + downCast (Direction dir) = C.Direction (downCast dir) + upCast C.Open = Open + upCast (C.Curl gamma) = Curl gamma + upCast (C.Direction dir) = Direction (upCast dir) + +instance Cast (Tension a) (C.Tension a) where + downCast (Tension v) = C.Tension v + downCast (TensionAtLeast v) = C.TensionAtLeast v + upCast (C.Tension v) = Tension v + upCast (C.TensionAtLeast v) = TensionAtLeast v + +instance Cast (MetaJoin a) (C.MetaJoin a) where + downCast (MetaJoin tyL tL tR tyR) = + C.MetaJoin (downCast tyL) (downCast tL) (downCast tR) (downCast tyR) + downCast (Controls p1 p2) = C.Controls (downCast p1) (downCast p2) + upCast (C.MetaJoin tyL tL tR tyR) = + MetaJoin (upCast tyL) (upCast tL) (upCast tR) (upCast tyR) + upCast (C.Controls p1 p2) = Controls (upCast p1) (upCast p2) + +instance Cast (PathJoin a) (C.PathJoin a) where + downCast JoinLine = C.JoinLine + downCast (JoinCurve a b) = C.JoinCurve (downCast a) (downCast b) + upCast C.JoinLine = JoinLine + upCast (C.JoinCurve a b) = JoinCurve (upCast a) (upCast b) + +instance Cast (OpenMetaPath a) (C.OpenMetaPath a) where + downCast (OpenMetaPath lst end) = C.OpenMetaPath + [ (downCast p, downCast j) + | (p, j) <- lst ] (downCast end) + upCast (C.OpenMetaPath lst end) = OpenMetaPath + [ (upCast p, upCast j) + | (p, j) <- lst ] (upCast end) + +instance Cast (ClosedMetaPath a) (C.ClosedMetaPath a) where + downCast (ClosedMetaPath lst) = C.ClosedMetaPath + [ (downCast p, downCast j) + | (p, j) <- lst ] + upCast (C.ClosedMetaPath lst) = ClosedMetaPath + [ (upCast p, upCast j) + | (p, j) <- lst ] + +instance Cast (OpenPath a) (C.OpenPath a) where + downCast (OpenPath lst end) = C.OpenPath + [ (downCast p, downCast j) + | (p, j) <- lst ] (downCast end) + upCast (C.OpenPath lst end) = OpenPath + [ (upCast p, upCast j) + | (p, j) <- lst ] (upCast end) + +instance Cast (ClosedPath a) (C.ClosedPath a) where + downCast (ClosedPath lst) = C.ClosedPath + [ (downCast p, downCast j) + | (p, j) <- lst ] + upCast (C.ClosedPath lst) = ClosedPath + [ (upCast p, upCast j) + | (p, j) <- lst ] diff --git a/src/Reanimate.hs b/src/Reanimate.hs --- a/src/Reanimate.hs +++ b/src/Reanimate.hs @@ -8,8 +8,8 @@ Portability : POSIX Reanimate is an animation library based on SVGs. It is designed to act like glue -between external components such as 'latex', 'ffmpeg', 'gnuplot', 'diagrams', -and 'povray'. +between external components such as \'latex\', \'ffmpeg\', \'gnuplot\', \'diagrams\', +and \'povray\'. = Canvas @@ -39,7 +39,7 @@ SVG, Time, Duration, - Animation(..), + Animation, mkAnimation, animate, staticFrame, @@ -70,12 +70,11 @@ fromToS, reverseS, curveS, + powerS, bellS, oscillateS, - fromListS, cubicBezierS, -- ** Scenes - (#), Scene , ZIndex , sceneAnimation -- :: (forall s. Scene s a) -> Animation @@ -116,7 +115,8 @@ , spriteTween -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () , spriteVar -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) , spriteE -- :: Sprite s -> Effect -> Scene s () - , spriteZ, -- :: Sprite s -> ZIndex -> Scene s () + , spriteZ -- :: Sprite s -> ZIndex -> Scene s () + , spriteScope, -- :: Scene s a -> Scene s a -- ** Effects Effect, diff --git a/src/Reanimate/Animation.hs b/src/Reanimate/Animation.hs --- a/src/Reanimate/Animation.hs +++ b/src/Reanimate/Animation.hs @@ -1,8 +1,20 @@ +{-| +Module : Reanimate.Animation +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +Declarative animation API based on combinators. For a higher-level interface, +see 'Reanimate.Scene'. + +-} module Reanimate.Animation ( Duration , Time , SVG - , Animation(..) -- TODO should this be exposed? The constructor is used directly in Effect.hs + , Animation -- * Creating animations , mkAnimation , animate @@ -27,7 +39,6 @@ , pauseAtEnd , pauseAtBeginning , pauseAround - , pauseUntil , repeatA , reverseA , playThenReverseA @@ -35,7 +46,6 @@ , freezeAtPercentage , addStatic -- * Misc - , (#) , getAnimationFrame , Sync(..) -- * Rendering @@ -60,11 +70,13 @@ -- | Time signal. Goes from 0 to 1, inclusive. type Time = Double +-- | SVG node. type SVG = Tree -- | Animations are SVGs over a finite time. data Animation = Animation Duration (Time -> SVG) +-- | Construct an animation with a given duration. mkAnimation :: Duration -> (Time -> SVG) -> Animation mkAnimation = Animation @@ -183,9 +195,11 @@ where t' = clamp 0 1 (t/d) +-- | Helper function for pretty-printing SVG nodes. renderTree :: SVG -> String renderTree t = maybe "" ppElement $ xmlOfTree t +-- | Helper function for pretty-printing SVG nodes as SVG documents. renderSvg :: Maybe Number -- ^ The number to use as value of the @width@ attribute of the resulting top-level svg element. If @Nothing@, the width attribute won't be rendered. -> Maybe Number -- ^ Similar to previous argument, but for @height@ attribute. -> SVG -- ^ SVG to render @@ -247,11 +261,6 @@ pauseAround :: Duration -> Duration -> Animation -> Animation pauseAround start end = pauseAtEnd end . pauseAtBeginning start --- XXX: Rename to 'setDurationFreeze'. Add 'setDurationDrop' and --- 'setDurationLoop'. -pauseUntil :: Duration -> Animation -> Animation -pauseUntil d a = pauseAtEnd (d-duration a) a - -- Freeze frame at time @t@. freezeFrame :: Time -> Animation -> (Time -> SVG) freezeFrame t (Animation d f) = const $ f (t/d) @@ -354,6 +363,7 @@ where len' = d - clamp 0 d len +-- | @lastA duration animation@ return the last @duration@ seconds of the animation. lastA :: Duration -> Animation -> Animation lastA len a = dropA (duration a - len) a @@ -362,9 +372,10 @@ | a < b = max a (min b number) | otherwise = max b (min a number) -(#) :: a -> (a -> b) -> b -o # f = f o +-- (#) :: a -> (a -> b) -> b +-- o # f = f o +-- | Ask for an animation frame using a given synchronization policy. getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG getAnimationFrame sync (Animation aDur aGen) t d = case sync of @@ -375,6 +386,7 @@ where takeFrac f = snd (properFraction f :: (Int, Double)) +-- | Animation synchronization policies. data Sync = SyncStretch | SyncLoop diff --git a/src/Reanimate/Blender.hs b/src/Reanimate/Blender.hs --- a/src/Reanimate/Blender.hs +++ b/src/Reanimate/Blender.hs @@ -1,40 +1,73 @@ {-# LANGUAGE OverloadedStrings #-} +{-| + [Blender](https://www.blender.org/) is a free and open-source 3D graphics toolkit. + It is usually used through a graphical user-interface but can also be + scripted via Python. These Blender scripts can access 100% of Blender's + functionality and offer a convenient way of coding 3D effects. + + Running Blender can be time-consuming but heavy caching means scripts + are only run when they change. + + Blender cheatsheet: + +> # To generate with a transparent background, set film_transparent = True: +> bpy.context.scene.render.film_transparent = True +> +> # Filmic is great for photorealism but bad for animations. +> # If you want your textures to keep their exact color values, +> # set the view_transform to 'Standard': +> bpy.context.scene.view_settings.view_transform = 'Standard' +> +> # Blender's default render engine is 'EEVEE', fast but not a raytracer. +> # To switch to raytracing, set the engine to 'CYCLES': +> bpy.context.scene.render.engine = 'CYCLES' +> +> # Rendering at full resolution can be slow. When developing, try +> # decreasing the resolution_percentage for faster renders. +> bpy.context.scene.render.resolution_percentage = 10 +> +> # The resolution of the final image are set by resolution_x and resolution_y: +> bpy.context.scene.render.resolution_x = 320 +> bpy.context.scene.render.resolution_y = 180 + +-} module Reanimate.Blender ( blender , blender' ) where -import Codec.Picture.Png -import qualified Data.ByteString as B +import Data.Hashable import Data.Text (Text) --- import qualified Data.Text as T import qualified Data.Text.IO as T import Graphics.SvgTree (Tree (..)) +import Reanimate.Animation import Reanimate.Cache +import Reanimate.Constants import Reanimate.Misc -import Reanimate.Raster import Reanimate.Parameters -import Reanimate.Animation +import Reanimate.Raster import Reanimate.Svg.Constructors import System.FilePath (replaceExtension, (<.>)) import System.IO.Unsafe (unsafePerformIO) -import Data.Hashable +-- | Run a Blender script and embed the resulting image file. The +-- image will be scaled to fit the screen exactly (assuming a default +-- canvas layout). Note that Blender resolution defaults to 1920x1080 +-- but can be changed in the script code. blender :: Text -> SVG blender script = unsafePerformIO $ mkBlenderImage script +-- | Generate Blender image as a separate PNG file. Can be embedded with +-- `mkImage`. blender' :: Text -> FilePath blender' script = unsafePerformIO $ mkBlenderImage' script mkBlenderImage :: Text -> IO Tree mkBlenderImage script | pNoExternals = pure $ mkText script -mkBlenderImage script = do - png <- B.readFile =<< mkBlenderImage' script - case decodePng png of - Left{} -> error "bad image" - Right img -> return $ center $ scaleToSize 16 9 $ embedDynamicImage img +mkBlenderImage script = + mkImage screenWidth screenHeight <$> mkBlenderImage' script mkBlenderImage' :: Text -> IO FilePath mkBlenderImage' _ | pNoExternals = pure "/blender/has/been/disabled" @@ -46,4 +79,4 @@ , "--python-exit-code", "1" , "--render-output", target, "--python", py_file] where - template = show (hash script) <.> "png" + template = encodeInt (hash script) <.> "png" diff --git a/src/Reanimate/Builtin/CirclePlot.hs b/src/Reanimate/Builtin/CirclePlot.hs --- a/src/Reanimate/Builtin/CirclePlot.hs +++ b/src/Reanimate/Builtin/CirclePlot.hs @@ -1,3 +1,14 @@ +{-| +Module : Reanimate.Builtin.CirclePlot +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +Convenience module for rendering circle plots. + +-} module Reanimate.Builtin.CirclePlot where import Codec.Picture 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 @@ -1,3 +1,15 @@ +{-| +Module : Reanimate.Builtin.Documentation +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +This module contains convenience functions used in documention +GIFs for a consistent look and feel. + +-} module Reanimate.Builtin.Documentation where import Reanimate.Animation @@ -6,6 +18,7 @@ import Reanimate.Constants import Codec.Picture +-- | Default environment for API documentation GIFs. docEnv :: Animation -> Animation docEnv = mapA $ \svg -> mkGroup [ mkBackground "white" @@ -25,11 +38,6 @@ partialSvg t $ pathify $ mkCircle (screenHeight/3) -drawBall :: Animation -drawBall = mkAnimation 2 $ \t -> - scale t $ withFillOpacity 1 $ withFillColor "red" $ - mkCircle (screenHeight/3) - -- | <> drawProgress :: Animation drawProgress = mkAnimation 2 $ \t -> @@ -41,6 +49,7 @@ where widthP = 0.8 +-- | Render a full-screen view of a color-map. showColorMap :: (Double -> PixelRGB8) -> SVG showColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img where @@ -49,5 +58,6 @@ img = generateImage pixelRenderer width height pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) +-- | Default background color for videos on reanimate.rtfd.io rtfdBackgroundColor :: PixelRGBA8 rtfdBackgroundColor = PixelRGBA8 252 252 252 0xFF diff --git a/src/Reanimate/Builtin/Flip.hs b/src/Reanimate/Builtin/Flip.hs --- a/src/Reanimate/Builtin/Flip.hs +++ b/src/Reanimate/Builtin/Flip.hs @@ -3,11 +3,17 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ApplicativeDo #-} {- HLINT ignore -} +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Builtin.Flip ( FlipSprite(..) , flipSprite , flipTransition - , flipTransitionOpts ) where import Reanimate.Animation @@ -21,6 +27,7 @@ import NeatInterpolation (text) import qualified Data.Text as T +-- | Control structure with parameters for the blender script. data FlipSprite s = FlipSprite { fsSprite :: Sprite s , fsBend :: Var s Double @@ -28,6 +35,8 @@ , fsWobble :: Var s Double } +-- | Project two animations on each side of a plane and flip the plane +-- upside down. flipSprite :: Animation -> Animation -> Scene s (FlipSprite s) flipSprite front back = do bend <- newVar 0 @@ -61,6 +70,7 @@ where dur = max (duration a) (duration b) +-- | 3D flip transition. flipTransition :: Transition flipTransition = flipTransitionOpts bend zoom wobble where diff --git a/src/Reanimate/Builtin/Images.hs b/src/Reanimate/Builtin/Images.hs --- a/src/Reanimate/Builtin/Images.hs +++ b/src/Reanimate/Builtin/Images.hs @@ -1,3 +1,14 @@ +{-| +Module : Reanimate.Builtin.Images +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +Collection of built-in images. + +-} module Reanimate.Builtin.Images ( svgLogo , haskellLogo @@ -46,6 +57,7 @@ githubIcon = unsafePerformIO $ embedImage "data/github-icon.svg" {-# NOINLINE githubWhiteIcon #-} +-- | <> githubWhiteIcon :: SVG githubWhiteIcon = unsafePerformIO $ embedImage "data/github-icon-white.svg" diff --git a/src/Reanimate/Builtin/Slide.hs b/src/Reanimate/Builtin/Slide.hs --- a/src/Reanimate/Builtin/Slide.hs +++ b/src/Reanimate/Builtin/Slide.hs @@ -1,3 +1,10 @@ +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Builtin.Slide where import Reanimate.Transition @@ -13,6 +20,7 @@ moveRight = constE (translate screenWidth 0) andE a b d t = a d t . b d t +-- | <> slideDownT :: Transition slideDownT = effectT slideDown (andE slideDown moveUp) where @@ -20,6 +28,7 @@ moveUp = constE (translate 0 screenHeight) andE a b d t = a d t . b d t +-- | <> slideUpT :: Transition slideUpT = effectT slideUp (andE slideUp moveDown) where 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 @@ -1,19 +1,56 @@ -module Reanimate.Builtin.TernaryPlot where +{-| +Module : Reanimate.Builtin.TernaryPlot +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +Implementation of ternary plots: + +-} +module Reanimate.Builtin.TernaryPlot + ( ACoord + , BCoord + , CCoord + , ternaryPlot + -- , atCenter + -- , radius + , toCartesianCoords + , toOffsetCartesianCoords + , fromCartesianCoords + ) where + import Codec.Picture import Graphics.SvgTree (Tree) import Reanimate.Raster import Reanimate.Svg --- (top, left, right) -- a+b+c=1 +-- | Left-most coordinate. type ACoord = Double +-- | Top-most coordinate. type BCoord = Double +-- | Right-most coordinate. type CCoord = Double --- Creates a centered ternary plot with a width of 5. -ternaryPlot :: Int -- ^ Pixels in the X-axis. - -> (ACoord -> BCoord -> CCoord -> PixelRGBA8) -> Tree +-- | Creates a centered ternary plot with a width of 5. +-- +-- Example: +-- +-- > ternaryPlot 100 $ \aCoord bCoord cCoord -> promotePixel $ +-- > let red = round $ aCoord*255 +-- > green = round $ bCoord*255 +-- > blue = round $ cCoord*255 +-- > in PixelRGB8 red green blue +-- +-- <> +ternaryPlot :: Int -- ^ Pixels in the X-axis. More pixels => higher quality. + -> (ACoord -> BCoord -> CCoord -> PixelRGBA8) + -- ^ a+b+c=1. A=1 is the left-most position, + -- B=1 is the top-most position, and + -- C=1 is the right-most position. + -> Tree ternaryPlot density fn = scaleToWidth stdWidth $ translate (-cX) (-cY) $ @@ -36,22 +73,27 @@ then PixelRGBA8 0 0 0 0 else fn aCoord bCoord cCoord -atCenter :: Double -> Tree -> Tree -atCenter stdWidth = translate (-cX*stdWidth) (-cY*stdWidth) - where - (cX, cY) = toCartesianCoords (1/3) (1/3) +-- atCenter :: Double -> Tree -> Tree +-- atCenter stdWidth = translate (-cX*stdWidth) (-cY*stdWidth) +-- where +-- (cX, cY) = toCartesianCoords (1/3) (1/3) -radius :: Double -radius = sqrt (cX*cX + cY*cY) - where - (cX, cY) = toCartesianCoords (1/3) (1/3) +-- radius :: Double +-- radius = sqrt (cX*cX + cY*cY) +-- where +-- (cX, cY) = toCartesianCoords (1/3) (1/3) +-- | Compute the XY coordinates from ternary coordinates. +-- Note that @CCoord@ is given because @a+b+c=1@. toCartesianCoords :: ACoord -> BCoord -> (Double, Double) toCartesianCoords a b = (x, y) where x = (a+2*b)/2 y = (sqrt 3 / 2) * a +-- | Compute the XY coordinates relative from the center of the +-- ternary plot. +-- Note that @CCoord@ is given because @a+b+c=1@. toOffsetCartesianCoords :: ACoord -> BCoord -> (Double, Double) toOffsetCartesianCoords a b = (tx-zx, ty-zy) @@ -59,6 +101,7 @@ (zx,zy) = toCartesianCoords (1/3) (1/3) (tx,ty) = toCartesianCoords a b +-- | Compute ternary coordinates from XY coordinates. fromCartesianCoords :: Double -> Double -> (ACoord, BCoord, CCoord) fromCartesianCoords x y = (a,b,1-a-b) where diff --git a/src/Reanimate/Chiphunk.hs b/src/Reanimate/Chiphunk.hs deleted file mode 100644 --- a/src/Reanimate/Chiphunk.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Reanimate.Chiphunk - ( simulate - , BodyStore - , newBodyStore - , addToBodyStore - , spaceFreeRecursive - , polyShapesToBody - , polygonsToBody - ) where - -import Chiphunk.Low -import Control.Monad -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as V -import Foreign.Ptr -import Graphics.SvgTree (Tree) -import Linear.V2 (V2(..)) -import Reanimate.Animation -import Reanimate.PolyShape -import Reanimate.Svg.Constructors - -type BodyStore = IORef (Map WordPtr Tree) - -newBodyStore :: IO BodyStore -newBodyStore = newIORef Map.empty - -addToBodyStore :: BodyStore -> Body -> Tree -> IO () -addToBodyStore store body svg = do - key <- atomicModifyIORef' store $ \m -> - case Map.maxViewWithKey m of - Nothing -> (Map.singleton 1 svg, 1) - Just ((maxKey,_),_) -> - (Map.insert (maxKey+1) svg m, maxKey+1) - bodyUserData body $= wordPtrToPtr key - -renderBodyStore :: Space -> BodyStore -> IO Tree -renderBodyStore space store = do - m <- readIORef store - lst <- newIORef [] - spaceEachBody space (\body _dat -> do - key <- get (bodyUserData body) - case Map.lookup (ptrToWordPtr key) m of - Nothing -> putStrLn "Body doesn't have an associated SVG" - Just svg -> do - Vect posX posY <- get $ bodyPosition body - angle <- get $ bodyAngle body - let bodySvg = - translate posX posY $ - rotate (angle/pi*180) - svg - modifyIORef lst (bodySvg:) - ) nullPtr - result <- readIORef lst - return $ mkGroup result - - -simulate :: Space -> BodyStore -> Double -> Int -> Double -> IO Animation -simulate space store fps stepsPerFrame dur = do - let timeStep = 1/(fps*fromIntegral stepsPerFrame) - frames = round (dur * fps) - v <- V.new frames - forM_ [0..frames-1] $ \nth -> do - svg <- renderBodyStore space store - V.write v nth svg - replicateM_ stepsPerFrame $ spaceStep space timeStep - frozen <- V.unsafeFreeze v - return $ mkAnimation dur $ \t -> - let key = round (t * fromIntegral (frames-1)) - in frozen V.! key - -polyShapesToBody :: Space -> [PolyShape] -> IO Body -polyShapesToBody space poly = - polygonsToBody space (map (map toVect) $ plDecompose poly) - where - toVect (V2 x y) = Vect x y - -polygonsToBody :: Space -> [[Vect]] -> IO Body -polygonsToBody space polygons = do - plBody <- bodyNew 0 0 - spaceAddBody space plBody - - forM_ polygons $ \vects -> do - polyShape <- polyShapeNewRaw plBody vects 0.00 - shapeDensity polyShape $= 1 - spaceAddShape space polyShape - shapeFriction polyShape $= 0.7 - shapeElasticity polyShape $= 0.5 - return plBody - -spaceFreeRecursive :: Space -> IO () -spaceFreeRecursive space = do - spaceEachBody space (\body _ -> bodyFree body) nullPtr - spaceEachShape space (\shape _ -> shapeFree shape) nullPtr - spaceFree space diff --git a/src/Reanimate/ColorComponents.hs b/src/Reanimate/ColorComponents.hs --- a/src/Reanimate/ColorComponents.hs +++ b/src/Reanimate/ColorComponents.hs @@ -1,6 +1,27 @@ {-# LANGUAGE RecordWildCards #-} -module Reanimate.ColorComponents where +{- | + Colors are three dimensional and can be projected into many color spaces + with different properties. + Interpolating directly in the RGB color space is unintuitive and rarely useful. + If you want to transition through color, you most likely want either the XYZ space + (for physically accurate color transitions) or the LAB space (for esthetically + pleasing colors). +-} +module Reanimate.ColorComponents + ( ColorComponents(..) + , rgbComponents + , hsvComponents + , labComponents + , xyzComponents + , lchComponents + , interpolate + , interpolateRGB8 + , interpolateRGBA8 + , toRGB8 + , fromRGB8 + ) where + import Codec.Picture import Codec.Picture.Types import Data.Colour @@ -12,9 +33,13 @@ import Data.Fixed import Reanimate.Ease +-- | Constructor and destructor for color's three components. data ColorComponents = ColorComponents { colorUnpack :: Colour Double -> (Double, Double, Double) - , colorPack :: Double -> Double -> Double -> Colour Double } + -- ^ Unpack a color into its three components. + , colorPack :: Double -> Double -> Double -> Colour Double + -- ^ Restore a color from three coordinates. + } -- | > interpolate rgbComponents yellow blue -- @@ -71,6 +96,7 @@ pack l c h = cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c) +-- | Smoothly interpolate between two colors using the given color components. interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double) interpolate ColorComponents{..} from to = \d -> colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d) @@ -78,9 +104,11 @@ (a1,b1,c1) = colorUnpack from (a2,b2,c2) = colorUnpack to +-- | Convenience interpolation function for RGB8 values. interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8) interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to) +-- | Convenience interpolation function for RGBA8 values. interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8) interpolateRGBA8 comps from to = \t -> case interp t of @@ -90,10 +118,12 @@ where interp = interpolateRGB8 comps (dropTransparency from) (dropTransparency to) +-- | Convenience function for expressing a color as an RGB8 value. toRGB8 :: Colour Double -> PixelRGB8 toRGB8 c = PixelRGB8 r g b where RGB r g b = toSRGBBounded c +-- | Convenience function for expressing an RGB8 value as a color. fromRGB8 :: PixelRGB8 -> Colour Double fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b diff --git a/src/Reanimate/ColorMap.hs b/src/Reanimate/ColorMap.hs --- a/src/Reanimate/ColorMap.hs +++ b/src/Reanimate/ColorMap.hs @@ -1,4 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} +{-| + A colormap takes a number between 0 and 1 (inclusive) and spits out a color. + The colors do not have an alpha component but one can be added with + `Codec.Picture.Types.promotePixel`. +-} module Reanimate.ColorMap ( turbo , viridis diff --git a/src/Reanimate/ColorSpace.hs b/src/Reanimate/ColorSpace.hs --- a/src/Reanimate/ColorSpace.hs +++ b/src/Reanimate/ColorSpace.hs @@ -1,8 +1,20 @@ -module Reanimate.ColorSpace where +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} +module Reanimate.ColorSpace + ( Nanometer + , coneSensitivity + , bigXYZCoordinates + , lightXYZCoordinates + , nmToColor + ) where import qualified Data.ByteString.Lazy as BS import Data.Colour.CIE -import Data.Colour.CIE.Illuminant (d65) import Data.Csv import Data.Map (Map) import qualified Data.Map as Map @@ -11,12 +23,11 @@ import Paths_reanimate import System.IO.Unsafe -import Graphics.SvgTree (Tree) -import Reanimate.Svg.Constructors - +-- | Wavelengths in nanometers. type Nanometer = Integer {-# NOINLINE lightXYZCoordinates #-} +-- | (small) xyz values for each wavelength of light. lightXYZCoordinates :: Map Nanometer (Double, Double, Double) lightXYZCoordinates = unsafePerformIO $ do dat <- BS.readFile =<< getDataFileName "data/CIExyz.csv" @@ -26,6 +37,7 @@ [ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ] {-# NOINLINE bigXYZCoordinates #-} +-- | (big) XYZ values for each wavelength of light. bigXYZCoordinates :: Map Nanometer (Double, Double, Double) bigXYZCoordinates = unsafePerformIO $ do dat <- BS.readFile =<< getDataFileName "data/CIE_XYZ.csv" @@ -34,34 +46,16 @@ Right vec -> return $ Map.fromList [ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ] +-- | Helper function for converting a wavelength of light into the +-- perceived color. nmToColor :: Nanometer -> Maybe (Colour Double) nmToColor nm = do (x, y, z) <- Map.lookup nm bigXYZCoordinates return $ cieXYZ x y z -renderXYZCoordinates :: Tree -renderXYZCoordinates = - withFillOpacity 0 $ - mkLinePath - [ (x, 1-y) - | (_nm, (x,y,_z)) <- Map.toList lightXYZCoordinates - ] - -lightLABCoordinates :: Map Nanometer (Double, Double, Double) -lightLABCoordinates = Map.map fn lightXYZCoordinates - where - fn (x,y,z) = cieLABView d65 (cieXYZ x y z) - -renderLABCoordinates :: Tree -renderLABCoordinates = - withFillOpacity 0 $ - mkLinePath - [ (a/350, (1-b)/150) - | (_nm, (_l,a,b)) <- Map.toList lightLABCoordinates - ] - {-# NOINLINE coneSensitivity #-} -- (Long, Medium, Short) +-- | Cone sensitivity by light wavelength. coneSensitivity :: Map Nanometer (Double, Double, Double) coneSensitivity = unsafePerformIO $ do dat <- BS.readFile =<< getDataFileName "data/cone_sensitivity_lms.csv" @@ -69,19 +63,3 @@ Left err -> error err Right vec -> return $ Map.fromList [ (nm, (l,m,fromMaybe 0 s)) | (nm,l,m,s) <- V.toList vec, nm <= 700 ] - -renderSensitivity :: Tree -renderSensitivity = mkGroup - [ withStrokeColor "blue" $ draw (\(_,_,s) -> s) - , withStrokeColor "green" $ draw (\(_,m,_) -> m) - , withStrokeColor "red" $ draw (\(l,_,_) -> l) - ] - where - draw fn = withFillOpacity 0 $ mkLinePath - [ (fromIntegral (ang-minAng) / maxAng * width, fn val * height) - | (ang, val) <- Map.toList coneSensitivity - ] - width = 100 - height = -50 - maxAng = fromIntegral $ fst (Map.findMax coneSensitivity) - minAng - minAng = fst (Map.findMin coneSensitivity) diff --git a/src/Reanimate/Constants.hs b/src/Reanimate/Constants.hs --- a/src/Reanimate/Constants.hs +++ b/src/Reanimate/Constants.hs @@ -1,3 +1,8 @@ +{- | + Reanimate configures a consistent, default canvas. The values of this default + can be observed via the constants in this module. Keep in mind, these values + describe the /default/ canvas and will not apply to custom viewports. +-} module Reanimate.Constants ( screenWidth , screenHeight @@ -11,9 +16,24 @@ import Graphics.SvgTree -screenWidth, screenHeight, screenTop :: Fractional a => a -screenBottom, screenLeft, screenRight :: Fractional a => a +-- | Number of units from the left-most point to the right-most point on the screen. +screenWidth :: Fractional a => a +-- | Number of units from the bottom to the top of the screen. +screenHeight :: Fractional a => a + +-- | Position of the top of the screen. +screenTop :: Fractional a => a + +-- | Position of the bottom of the screen. +screenBottom :: Fractional a => a + +-- | Position of the left side of the screen. +screenLeft :: Fractional a => a + +-- | Position of the right side of the screen. +screenRight :: Fractional a => a + screenWidth = 16 screenHeight = 9 screenTop = screenHeight/2 @@ -21,8 +41,11 @@ screenLeft = -screenWidth/2 screenRight = screenWidth/2 +-- | SVG allows measurements in inches which have to be converted to local units. +-- This value describes how many local units there are in an inch. defaultDPI :: Dpi defaultDPI = 96 +-- | Default thickness of lines. defaultStrokeWidth :: Double defaultStrokeWidth = 0.05 diff --git a/src/Reanimate/Debug.hs b/src/Reanimate/Debug.hs --- a/src/Reanimate/Debug.hs +++ b/src/Reanimate/Debug.hs @@ -1,3 +1,10 @@ +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Debug ( traceSVG , traceA @@ -20,16 +27,19 @@ traceBuffer = unsafePerformIO (newIORef []) {-# NOINLINE traceSVG #-} +-- | Add SVG image to trace stack. traceSVG :: SVG -> a -> a traceSVG = traceA . staticFrame (recip 60) {-# NOINLINE traceA #-} +-- | Add animation to trace stack. traceA :: Animation -> a -> a traceA a v = unsafePerformIO $ do modifyIORef' traceBuffer (a :) evaluate v {-# NOINLINE playTraces #-} +-- | Evaluate argument and play back the trace stack. playTraces :: a -> Animation playTraces v = unsafePerformIO $ do _ <- evaluate v diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -87,7 +87,7 @@ > view Play animation in browser window. > render Render animation to file. -Neither the 'check' nor the 'view' command take any additional arguments. +Neither the \'check\' nor the \'view\' command take any additional arguments. Rendering animation can be controlled with these arguments: > Usage: PROG render [-o|--target FILE] [--fps FPS] [-w|--width PIXELS] @@ -109,7 +109,9 @@ reanimate animation = do Options {..} <- getDriverOptions case optsCommand of - Raw -> setFPS 60 >> renderSvgs animation + Raw {..} -> do + setFPS 60 + renderSvgs rawOutputFolder rawFrameOffset rawPrettyPrint animation Test -> do setNoExternals True -- hSetBinaryMode stdout True diff --git a/src/Reanimate/Driver/CLI.hs b/src/Reanimate/Driver/CLI.hs --- a/src/Reanimate/Driver/CLI.hs +++ b/src/Reanimate/Driver/CLI.hs @@ -22,6 +22,10 @@ data Command = Raw + { rawOutputFolder :: FilePath + , rawFrameOffset :: Int + , rawPrettyPrint :: Bool + } | Test | Check | View @@ -99,14 +103,15 @@ options = Options <$> commandP commandP :: Parser Command -commandP = subparser(command "raw" rawCommand - <> command "test" testCommand +commandP = subparser( + command "test" testCommand <> commandGroup "Internal commands" <> internal ) <|> hsubparser ( command "check" checkCommand <> command "view" viewCommand <> command "render" renderCommand + <> command "raw" rawCommand ) <|> infoParser viewCommand @@ -114,7 +119,22 @@ rawCommand = info parse (progDesc "Output raw SVGs for animation at 60 fps. Used internally by viewer.") where - parse = pure Raw + parse = Raw + <$> strOption + ( long "output" <> + short 'o' <> + metavar "PATH" <> + help "Output folder" <> + value ".") + <*> option auto + ( long "offset" <> + metavar "NUMBER" <> + help "Frame offset" <> + value 0) + <*> switch + ( long "pretty-print" <> + short 'p' <> + help "Pretty print svg") testCommand :: ParserInfo Command testCommand = info (parse <**> helper) diff --git a/src/Reanimate/Driver/Magick.hs b/src/Reanimate/Driver/Magick.hs --- a/src/Reanimate/Driver/Magick.hs +++ b/src/Reanimate/Driver/Magick.hs @@ -6,12 +6,12 @@ import System.Directory (findExecutable) -- |The name of the ImageMagick command. On Unix-like operating systems, the --- command 'convert' does not conflict with the name of other commands. On --- Windows, ImageMagick version 7 is readily available, the command 'magick' --- should be present, and is preferred over 'convert'. If it is not present, --- 'convert' is assumed to be the relevant command. +-- command \'convert\' does not conflict with the name of other commands. On +-- Windows, ImageMagick version 7 is readily available, the command \'magick\' +-- should be present, and is preferred over \'convert\'. If it is not present, +-- \'convert\' is assumed to be the relevant command. magickCmd :: String --- The use of 'unsafeperformIO' is justified on the basis that if 'magick' is +-- The use of 'unsafeperformIO' is justified on the basis that if \'magick\' is -- found once, it will always be present. magickCmd = unsafePerformIO $ do mPath <- findExecutable "magick" diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs --- a/src/Reanimate/Driver/Server.hs +++ b/src/Reanimate/Driver/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Reanimate.Driver.Server ( serve @@ -5,30 +6,30 @@ ) where import Control.Concurrent -import Control.Exception (SomeException, catch, finally) +import Control.Exception (SomeException, catch, finally) import Control.Monad -import Control.Monad.Fix (fix) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Read as T -import GHC.Environment (getFullArgs) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import Data.Time +import GHC.Environment (getFullArgs) +import Language.Haskell.Ghcid import Network.WebSockets import Paths_reanimate -import Reanimate.Misc (runCmdLazy, runCmd_) -import System.Directory (createDirectoryIfMissing, - doesFileExist, findFile, - listDirectory, makeAbsolute, - removeDirectoryRecursive, - withCurrentDirectory) -import System.Environment (getProgName) +import Reanimate.Misc (runCmdLazy, runCmd_) +import System.Directory (createDirectoryIfMissing, + doesFileExist, findFile, listDirectory, + makeAbsolute, + withCurrentDirectory) +import System.Environment (getProgName) import System.Exit -import System.Process import System.FilePath import System.FSNotify import System.IO import System.IO.Temp -import Web.Browser (openBrowser) +import System.Process +import Web.Browser (openBrowser) opts :: ConnectionOptions opts = defaultConnectionOptions @@ -39,49 +40,56 @@ hSetBuffering stdin NoBuffering self <- maybe requireOwnSource pure mbSelfPath when verbose $ - putStrLn $ "Found own source code at: " ++ self + logMsg $ "Found own source code at: " ++ self hasConnectionVar <- newMVar False + ghci <- ghciBackend mbGHCPath self + -- There might already browser window open. Wait 2s to see if that window -- connects to us. If not, open a new window. _ <- forkIO $ do threadDelay (2*10^(6::Int)) hasConn <- readMVar hasConnectionVar unless hasConn openViewer - - putStrLn "Listening..." + logMsg "Listening..." let options = ServerOptions { serverHost = "127.0.0.1" , serverPort = 9161 , serverConnectionOptions = opts , serverRequirePong = Nothing } - runServerWithOptions options $ \pending -> do - putStrLn "New connection received." - hasConn <- swapMVar hasConnectionVar True - if hasConn - then do - putStrLn "Already connected to browser. Rejecting." - rejectRequestWith pending defaultRejectRequest - else withSystemTempDirectory "reanimate-svgs" $ \tmpDir -> do - createDirectoryIfMissing True tmpDir - conn <- acceptRequest pending - slave <- newEmptyMVar - let handler = modifyMVar_ slave $ \tid -> do - putStrLn "Reloading code..." - killThread tid - forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn self tmpDir - killSlave = do - tid <- takeMVar slave - killThread tid - stop <- watchFile watch self handler - putMVar slave =<< forkIO (return ()) - handler - let loop = do - -- FIXME: We don't use msg here. - _msg <- receiveData conn :: IO T.Text - handler - loop - loop `finally` (removeDirectoryRecursive tmpDir >> swapMVar hasConnectionVar False >> stop >> killSlave) + withSystemTempDirectory "reanimate-svgs" $ \tmpDir -> + runServerWithOptions options $ \pending -> do + logMsg "New connection received." + hasConn <- swapMVar hasConnectionVar True + if hasConn + then do + logMsg "Already connected to browser. Rejecting." + rejectRequestWith pending defaultRejectRequest + else do + createDirectoryIfMissing True tmpDir + conn <- acceptRequest pending + slave <- newEmptyMVar + let handler = modifyMVar_ slave $ \tid -> do + logMsg "Reloading code..." + killThread tid + forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self tmpDir + killSlave = do + tid <- takeMVar slave + killThread tid + stop <- watchFile watch self handler + putMVar slave =<< forkIO (return ()) + handler + let loop = do + -- FIXME: We don't use msg here. + _msg <- receiveData conn :: IO T.Text + handler + loop + cleanup = do + stop + killSlave + _ <- swapMVar hasConnectionVar False + return () + loop `finally` cleanup ignoreErrors :: IO () -> IO () ignoreErrors action = action `catch` \(_::SomeException) -> return () @@ -89,76 +97,97 @@ openViewer :: IO () openViewer = do url <- getDataFileName "viewer-elm/dist/index.html" - putStrLn "Opening browser..." + logMsg "Opening browser..." bSucc <- openBrowser url if bSucc - then putStrLn "Browser opened." + then logMsg "Browser opened." else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url -slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> FilePath -> FilePath -> IO () -slaveHandler verbose mbGHCPath extraGHCOpts conn self svgDir = +slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> GhciBackend + -> FilePath -> FilePath -> IO () +slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self svgDir = withCurrentDirectory (takeDirectory self) $ withSystemTempDirectory "reanimate" $ \tmpDir -> withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do - -- cap <- getNumCapabilities - let n = 25 - sem <- newQSemN n + outputFolder <- createTempDirectory svgDir "svgs" + let frameFileName frameIdx = + outputFolder show frameIdx <.> "svg" + + sentFrameCount <- newMVar False hClose handle lock <- newMVar () - sendTextData conn (T.pack "status\nCompiling") + sendWebMessage conn $ WebStatus "Compiling" + ghciThread <- forkIO $ do + firstFrame <- newIORef True + ghciReload ghci + logMsg "GHCi reload done." + ghciGenerate ghci outputFolder $ \frameIdx -> do + first <- readIORef firstFrame + writeIORef firstFrame False + if first + then do + modifyMVar_ sentFrameCount $ \sent -> do + unless sent $ + sendWebMessage conn $ WebFrameCount frameIdx + logMsg "Framecount sent." + return True + else + withMVar lock $ \_ -> + sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx) + logMsg "GHCi render done." ret <- case mbGHCPath of Nothing -> do let args = ["ghc", "--"] ++ ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable] when verbose $ - putStrLn $ "Running: " ++ showCommandForUser "stack" args + logMsg $ "Running: " ++ showCommandForUser "stack" args runCmd_ "stack" args Just ghc -> do let args = ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable] when verbose $ - putStrLn $ "Running: " ++ showCommandForUser ghc args + logMsg $ "Running: " ++ showCommandForUser ghc args runCmd_ ghc args + logMsg "Compile done." case ret of Left err -> - sendTextData conn $ T.pack $ "error\n" ++ unlines (lines err) - Right{} -> runCmdLazy tmpExecutable execOpts $ \getFrame -> do - (frameCount,_) <- expectFrame sem =<< getFrame - sendTextData conn (T.pack $ "frame_count\n" ++ show frameCount) - fix $ \loop -> do - (frameIdx, frame) <- expectFrame sem =<< getFrame - -- putStrLn $ "Got frame: " ++ show frameIdx - let fileName = svgDir takeBaseName tmpExecutable <.> show frameIdx <.> "svg" - -- pngName = replaceExtension fileName "png" - _ <- forkIO $ do - waitQSemN sem 1 - T.writeFile fileName frame - -- runCmd "rsvg-convert" - -- [ fileName - -- , "--width=256" -- "--width=1024" - -- , "--height=144" -- "--height=576" - -- , "--output", pngName ] - withMVar lock $ \_ -> - sendTextData conn (T.pack $ "frame\n" ++ show frameIdx ++ "\n" ++ fileName) - signalQSemN sem 1 - loop + sendWebMessage conn $ WebError $ unlines (lines err) + Right{} -> runCmdLazy tmpExecutable (execOpts outputFolder) $ \getFrame -> do + frameCount <- expectFrame =<< getFrame + modifyMVar_ sentFrameCount $ \sent -> do + unless sent $ + sendWebMessage conn $ WebFrameCount frameCount + return True + replicateM_ frameCount $ do + frameIdx <- expectFrame =<< getFrame + withMVar lock $ \_ -> + sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx) + logMsg "Optimized render done." + killThread ghciThread where - execOpts = ["raw", "+RTS", "-N", "-M2G", "-RTS"] - expectFrame :: QSemN -> Either String Text -> IO (Integer, Text) - expectFrame sem (Left "") = do - waitQSemN sem 25 -- =<< getNumCapabilities - sendTextData conn (T.pack "status\nDone") + execOpts output = + [ "raw", "--output", output, "--offset", "1" + , "+RTS", "-N", "-M2G", "-RTS"] + expectFrame :: Either String Text -> IO Int + expectFrame (Left "") = do + sendWebMessage conn $ WebStatus "Done" exitSuccess - expectFrame _ (Left err) = do - sendTextData conn $ T.pack $ "error\n" ++ err + expectFrame (Left err) = do + sendWebMessage conn $ WebError err exitWith (ExitFailure 1) - expectFrame _ (Right frame) = + expectFrame (Right frame) = case T.decimal frame of Left err -> do hPutStrLn stderr (T.unpack frame) hPutStrLn stderr $ "expectFrame: " ++ err - sendTextData conn $ T.pack $ "error\n" ++ err + sendWebMessage conn $ WebError err exitWith (ExitFailure 1) - Right (frameNumber, rest) -> - pure (frameNumber, rest) + Right (frameNumber, "") -> + pure frameNumber + Right {} -> do + let err = "Unexpected output" + hPutStrLn stderr (T.unpack frame) + hPutStrLn stderr $ "expectFrame: " ++ err + sendWebMessage conn $ WebError err + exitWith (ExitFailure 1) watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening watchFile watch file action = watchTree watch (takeDirectory file) check (const action) @@ -205,3 +234,65 @@ isHaskellFile :: FilePath -> Bool isHaskellFile path = takeExtension path `elem` [".hs", ".lhs"] + +logMsg :: String -> IO () +logMsg msg = do + now <- getCurrentTime + putStrLn $ formatTime defaultTimeLocale fmt now ++ ": " ++ msg + where + fmt = "%F %T%2Q" + +------------------------------------------------------------------------------- +-- Ghci interface + +-- stack +-- cabal +-- raw +-- none? +data GhciBackend = GhciBackend (MVar Ghci) + +ghciBackend :: Maybe FilePath -> FilePath -> IO GhciBackend +ghciBackend mbGHCPath self = do + let ghciProc = + case mbGHCPath of + Just ghcPath -> + proc ghcPath $ ["--interactive", "+RTS"] ++ words memoryLimit ++ ["-RTS"] + Nothing -> + proc "stack" ["exec", "ghci", "--rts-options="++memoryLimit] + (ghci, _loads) <- startGhciProcess ghciProc $ \_stream _msg -> return () + void $ exec ghci $ ":load " ++ self + ref <- newMVar ghci + return $ GhciBackend ref + +ghciReload :: GhciBackend -> IO () +ghciReload (GhciBackend ref) = + withMVar ref $ \ghci -> + void $ reload ghci + +ghciGenerate :: GhciBackend -> FilePath -> (Int -> IO ()) -> IO () +ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci -> do + execStream ghci (":main raw --output=" ++ target ++ " --offset=1") + $ \_ msg -> + case reads msg of + [(frameIdx,"")] -> cb frameIdx + _ -> return () + +memoryLimit :: String +memoryLimit = "-M1G" + +------------------------------------------------------------------------------- +-- Websocket API + +data WebMessage + = WebStatus String + | WebError String + | WebFrameCount Int + | WebFrame Int FilePath + +sendWebMessage :: Connection -> WebMessage -> IO () +sendWebMessage conn msg = sendTextData conn $ + case msg of + WebStatus txt -> T.pack "status\n" <> T.pack txt + WebError txt -> T.pack "error\n" <> T.pack txt + WebFrameCount n -> T.pack $ "frame_count\n" ++ show n + WebFrame n path -> T.pack $ "frame\n" ++ show n ++ "\n" ++ path diff --git a/src/Reanimate/Ease.hs b/src/Reanimate/Ease.hs --- a/src/Reanimate/Ease.hs +++ b/src/Reanimate/Ease.hs @@ -1,3 +1,7 @@ +{-| + Easing functions modify the rate of change in animations. + More examples can be seen here: . +-} module Reanimate.Ease ( Signal , constantS @@ -7,7 +11,6 @@ , powerS , bellS , oscillateS - , fromListS , cubicBezierS ) where @@ -15,15 +18,6 @@ -- composition. type Signal = Double -> Double -fromListS :: [(Double, Signal)] -> Signal -fromListS fns t = worker 0 fns - where - worker _ [] = 0 - worker now [(len, fn)] = fn (min 1 ((t-now) / min (1-now) len)) - worker now ((len, fn):rest) - | now+len < t = worker (now+len) rest - | otherwise = fn ((t-now) / len) - -- | Constant signal. -- -- Example: @@ -67,6 +61,13 @@ then 0.5 * (2*s)**steepness else 1-0.5 * (2 - 2*s)**steepness +-- | Power curve signal. Takes a steepness parameter. 2 is a good default. +-- +-- Example: +-- +-- > signalA (powerS 2) drawProgress +-- +-- <> powerS :: Double -> Signal powerS steepness s = s**steepness @@ -94,7 +95,7 @@ bellS steepness = curveS steepness . oscillateS -- | Cubic Bezier signal. Gives you a fair amount of control over how the --- signal will 'curve'. +-- signal will curve. -- -- Example: -- diff --git a/src/Reanimate/Effect.hs b/src/Reanimate/Effect.hs --- a/src/Reanimate/Effect.hs +++ b/src/Reanimate/Effect.hs @@ -79,7 +79,8 @@ -- | Modify the animation by applying the effect. If desired, you can apply multiple effects to single animation by calling this function multiple times. applyE :: Effect -> Animation -> Animation -applyE fn (Animation d genFrame) = Animation d $ \t -> fn d (d*t) $ genFrame t +applyE fn ani = let d = duration ani + in mkAnimation d $ \t -> fn d (d*t) $ frameAt (d*t) ani -- | Build an effect from an image-modifying function. This effect does not change as time passes. constE :: (Tree -> Tree) -> Effect diff --git a/src/Reanimate/GeoProjection.hs b/src/Reanimate/GeoProjection.hs --- a/src/Reanimate/GeoProjection.hs +++ b/src/Reanimate/GeoProjection.hs @@ -1,6 +1,19 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} +{-| +Module : Reanimate.GeoProjection +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +This module provides functions for mapping the surface of +a sphere on to a 2D plane. It also has convenience functions +for loading GeoJSON data. + +-} module Reanimate.GeoProjection ( Projection(..) , XYCoord(..) @@ -108,143 +121,8 @@ !xPx = round $ ((lam+pi)/tau) * wMax !yPx = round $ (1-((phi+halfPi)/pi)) * hMax -{- HLINT ignore -} --- findValidCoord :: Int -> Int -> Double -> Double -> (XYCoord -> LonLat) -> XYCoord -> XYCoord --- findValidCoord !w !h !wMax !hMax !p_inv (XYCoord x y) = foldr const (XYCoord x y) --- [ XYCoord x' y' --- | let !xi = round $ x * wMax --- !yi = round $ y * hMax --- , !ax <- [xi, xi-1, xi+1] --- , ax >= 0 --- , ax < w --- , let !x' = fromIntegral ax / wMax --- , !ay <- [yi, yi-1, yi+1] --- , ay >= 0 --- , ay < h --- , let !y' = fromIntegral ay / hMax --- , validLonLat $! p_inv $! XYCoord x' y' --- ] - --- isInWorld :: Projection -> XYCoord -> Bool --- isInWorld p coord = --- odd $ length $ isInWorld' p coord --- --- isInWorld' :: Projection -> XYCoord -> [(Double, Double)] --- isInWorld' p (XYCoord x y) = --- [ (x1, y1) --- | (XYCoord x1 y1, XYCoord x2 y2) <- world --- , (y1 > y) /= (y2 > y) -- y is between y1 and y2 --- , x < (x2 - x1) * (y - y1) / (y2 - y1) + x1 -- x is to the left of the line --- ] --- where --- world = worldPolygon p --- --- worldPolygon :: Projection -> [(XYCoord, XYCoord)] --- worldPolygon p = --- interp (-pi, -halfPi) (-pi, halfPi) ++ --- interp (-pi, halfPi) (pi, halfPi) ++ --- interp (pi, halfPi) (pi, -halfPi) ++ --- interp (pi, -halfPi) (-pi, -halfPi) --- where --- apply (lam, phi) = projectionForward p $ LonLat lam phi --- steps = 100 --- interp (x1, y1) (x2,y2) = --- [ ( apply (fromToS x1 x2 (n/steps), fromToS y1 y2 (n/steps)) --- , apply (fromToS x1 x2 ((n+1)/steps), fromToS y1 y2 ((n+1)/steps))) --- | n <- [0..steps-1]] - --- findNearestPixel :: MutableImage s PixelRGBA8 -> Int -> Int -> Int -> Int -> ST s PixelRGBA8 --- findNearestPixel src w h srcX srcY = worker $ take 20 --- [ (x, y) --- | n <- [1..] --- , x <- [srcX-n .. srcY+n] --- , y <- if x == srcX-n || x == srcX+n then [srcY-n,srcY+n] else [srcY-n .. srcY+n] --- , x >= 0 --- , y >= 0 --- , x < w --- , y < h --- ] --- where --- worker [] = pure $ PixelRGBA8 0xFF 0x00 0x00 0xFF --- worker ((x,y):rest) = do --- this <- readPixel src x y --- if this == blank --- then worker rest --- else return this --- blank = PixelRGBA8 0x00 0x00 0x00 0x00 - - --- Original version: 134,925 pixels/second --- Inlined projections: 136,332 pixels/second --- TEST: no write pixels: 134,288 pixels/second !!! --- Fast theta: 1,489,719 pixels/second --- Cached theta: 3,622,254 pixels/second - --- to equirectangularP: 9,015,326 pixels/second --- 9,680,217 --- 9,466,744 --- 14,830,330 --- to lambertP: 6,735,973 --- to mercatorP: 4,248,927 --- to mollweideP: 3,593,545 --- to hammerP: 3,237,699 --- to bottomleyP: 3,864,848 --- to sinusoidalP: 7,020,756 --- to wernerP: 4,433,295 --- to bonneP: 4,071,187 --- to augustP: 2,553,177 --- to collignonP: 5,486,849 --- to eckert1P: 7,428,849 --- to eckert3P: 6,666,936 --- to eckert5P: 6,106,492 --- to faheyP: 5,137,291 --- to foucautP: 3,983,151 --- to lagrangeP: 3,850,611 --- interpFastP :: Image PixelRGBA8 -> Projection -> Projection -> Double -> Image PixelRGBA8 --- interpFastP !src (Projection _ p1 p1_inv) (Projection _ p2 p2_inv) !t = runST $ do --- unsafeIOToST $ putStrLn "Allocating new array" --- !img <- newMutableImage w h --- unsafeIOToST $ putStrLn "done" --- start <- unsafeIOToST $ getCurrentTime --- let factor = 2 --- total = w*factor * h*factor --- let l1 = --- loopTo (w*factor) $ \x -> do --- loopTo (h*factor) $ \y -> do --- let thisIndex = (x*h*factor+y) --- when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do --- now <- getCurrentTime --- let diff = realToFrac (diffUTCTime now start):: Double --- printf "%.2f pixels/second\n" (fromIntegral (total-thisIndex) / diff) --- let !x1' = fromIntegral x / (wMax*fromIntegral factor) --- !y1' = fromIntegral y / (hMax*fromIntegral factor) --- !lonlat = p1_inv $! XYCoord x1' y1' --- -- p = srcPixel src lonlat --- -- unsafeIOToST (evaluate lonlat) --- --- when (validLonLat lonlat) $ do --- p <- srcPixelFast src wMax hMax lonlat --- when (pixelOpacity p /= 0) $ do --- let XYCoord !x1 !y1 = p1 lonlat --- -- !coord = p2 lonlat --- XYCoord !x2 !y2 = p2 lonlat -- findValidCoord w h wMax hMax p2_inv $ p2 lonlat --- !x3 = round $ fromToS x1 x2 t * wMax --- !y3 = round $ (1 - fromToS y1 y2 t) * hMax :: Int --- -- unsafeIOToST (evaluate coord) --- -- return () --- when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ --- writePixel img x3 y3 p --- l1 --- unsafeFreezeImage img --- where --- loopTo m fn = go m --- where go 0 = return () --- go n = fn (n-1) >> go (n-1) --- !w = imageWidth src --- !h = imageHeight src --- !wMax = fromIntegral (w-1) --- !hMax = fromIntegral (h-1) - +-- | Interpolate between two projections and apply the result to an image in +-- equirectangular format. The source image must have an aspect ratio of 2:1. interpP :: Image PixelRGBA8 -> Projection -> Projection -> Double -> Image PixelRGBA8 interpP src p1 _ 0 = project src p1 interpP src _ p2 1 = project src p2 @@ -252,49 +130,32 @@ !img <- newMutableImage w h let factor = 2 - -- total = w*factor * h*factor let l1 = do - -- start <- unsafeIOToST $ getCurrentTime loopTo (w*factor) $ \x -> do loopTo (h*factor) $ \y -> do - -- let thisIndex = (x*h*factor+y) - -- when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do - -- now <- getCurrentTime - -- let diff = realToFrac (diffUTCTime now start):: Double - -- printf "%.2f pixels/second: %s\n" (fromIntegral (total-thisIndex) / diff) label1 let !x1' = fromIntegral x / (wMax*fromIntegral factor) !y1' = fromIntegral y / (hMax*fromIntegral factor) !lonlat = p1_inv $! XYCoord x1' y1' - -- p = srcPixel src lonlat when (validLonLat lonlat) $ do p <- srcPixelFast src wMax hMax lonlat when (pixelOpacity p /= 0) $ do let XYCoord x1 y1 = p1 lonlat - -- XYCoord x2 y2 = findValidCoord w h wMax hMax p2_inv $ p2 lonlat XYCoord x2 y2 = p2 lonlat !x3 = round $ fromToS x1 x2 t * wMax !y3 = round $ (1 - fromToS y1 y2 t) * hMax when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ writePixel img x3 y3 p l2 = do - -- start <- unsafeIOToST $ getCurrentTime loopTo (w*factor) $ \x -> loopTo (h*factor) $ \y -> do - -- let thisIndex = (x*h*factor+y) - -- when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do - -- now <- getCurrentTime - -- let diff = realToFrac (diffUTCTime now start):: Double - -- printf "%.2f pixels/second: %s\n" (fromIntegral (total-thisIndex) / diff) label2 let !x2' = fromIntegral x / (wMax*fromIntegral factor) !y2' = fromIntegral y / (hMax*fromIntegral factor) !lonlat = p2_inv (XYCoord x2' y2') - -- p = srcPixel src lonlat when (validLonLat lonlat) $ do p <- srcPixelFast src wMax hMax lonlat when (pixelOpacity p /= 0) $ do let XYCoord x2 y2 = p2 lonlat - -- XYCoord x1 y1 = findValidCoord w h wMax hMax p1_inv $ p1 lonlat XYCoord x1 y1 = p1 lonlat !x3 = round $ fromToS x1 x2 t * wMax !y3 = round $ (1 - fromToS y1 y2 t) * hMax @@ -313,6 +174,11 @@ !wMax = fromIntegral (w-1) !hMax = fromIntegral (h-1) +-- | Interpolate between two projections and apply the result to an image in +-- equirectangular format. The source image must have an aspect ratio of 2:1. +-- Only the areas inside of the two bounding boxes (applying to the source and +-- target projection, respectively) are mapped. Pixels outside of these bounding-boxes +-- are undefined. interpBBP :: Image PixelRGBA8 -> Projection -> Projection -> (Double,Double,Double,Double) -> (Double,Double,Double,Double) -> Double -> Image PixelRGBA8 interpBBP !src (Projection _ p1 p1_inv) !(Projection _ p2 p2_inv) (fx,fy,fw,fh) (tx, ty, tw, th) !t = runST $ do @@ -325,18 +191,12 @@ !y1' = fromIntegral y / (hMax*fromIntegral factor) when (x1' >= fx && x1' <= fx+fw && y1' >= fy && y1' <= fy+fh) $ do let !lonlat = p1_inv $! XYCoord x1' y1' - -- p = srcPixel src lonlat when (validLonLat lonlat) $ do - -- let LonLat lam phi = lonlat - -- !xPx = ((lam+pi)/tau) - -- !yPx = (((phi+halfPi)/pi)) - -- when (xPx >= fx && xPx <= fx+fw && yPx >= fy && yPx <= fy+fh) $ do p <- srcPixelFast src wMax hMax lonlat when (pixelOpacity p /= 0) $ do let XYCoord x1 y1 = p1 lonlat XYCoord x2 y2 = p2 lonlat - -- XYCoord x2 y2 = findValidCoord w h wMax hMax p2_inv $ p2 lonlat !x3 = round $ fromToS x1 x2 t * wMax !y3 = round $ (1 - fromToS y1 y2 t) * hMax when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ @@ -348,12 +208,10 @@ !y2' = fromIntegral y / (hMax*fromIntegral factor) when (x2' >= tx && x2' <= tx+tw && y2' >= ty && y2' <= ty+th) $ do let !lonlat = p2_inv (XYCoord x2' y2') - -- p = srcPixel src lonlat when (validLonLat lonlat) $ do p <- srcPixelFast src wMax hMax lonlat when (pixelOpacity p /= 0) $ do let XYCoord x2 y2 = p2 lonlat - -- XYCoord x1 y1 = findValidCoord w h wMax hMax p1_inv $ p1 lonlat XYCoord x1 y1 = p1 lonlat !x3 = round $ fromToS x1 x2 t * wMax !y3 = round $ (1 - fromToS y1 y2 t) * hMax @@ -363,15 +221,6 @@ then l1 >> l2 else l2 >> l1 - -- when False $ - -- forM_ [0..w-1] $ \x -> - -- forM_ [0..h-1] $ \y -> do - -- let x1 = fromIntegral x / (wMax) - -- y1 = 1 - fromIntegral y / (hMax) - -- this <- readPixel img x y - -- when (isBlank this) $ - -- when (isInWorld (mergeP p1 p2 t) (XYCoord x1 y1)) $ - -- writePixel img x y =<< findNearestPixel img w h x y unsafeFreezeImage img where loopTo m fn = go m @@ -394,21 +243,32 @@ eqDouble :: Double -> Double -> Bool eqDouble a b = abs (a-b) < epsilon +-- | XY coordinates on a 2D plane. Valid ranges go from 0 to 1, inclusive. data XYCoord = XYCoord !Double !Double -- 0 to 1 deriving (Read,Show,Eq,Ord) + +-- | Longitude and latitude. Valid range for longitude is -pi to +pi. +-- Valid range for latitude is -pi/2 to +pi/2. data LonLat = LonLat !Double !Double -- -pi to +pi, -halfPi to +halfPi deriving (Read,Show,Eq,Ord) instance Hashable LonLat where hashWithSalt s (LonLat a b) = hashWithSalt s (a,b) + +-- | Projections are named bi-directional mappings between a sphere +-- and a 2D plane. data Projection = Projection - { projectionLabel :: String + { projectionLabel :: String -- ^ Name of the projection. , projectionForward :: !(LonLat -> XYCoord) - -- - -- (Double# -> Double# -> (# Double#, Double# #)) + -- ^ Mapping from longitude and latitude on a sphere to + -- XY coordinates on a 2D plane. , projectionInverse :: !(XYCoord -> LonLat) + -- ^ Mapping from XY coordinates on a 2D plane to longitude + -- and latitude on a sphere. } -- FIXME: Verify that 'src' has an aspect ratio of 2:1. +-- | Apply on an image in equirectangular format. The source image +-- therfore must have an aspect ratio of 2:1. project :: Image PixelRGBA8 -> Projection -> Image PixelRGBA8 project src (Projection _label _ pInv) = generateImage fn w h where @@ -430,6 +290,7 @@ _validXYCoord :: XYCoord -> Bool _validXYCoord (XYCoord x y) = x >= 0 && x <= 1 && y >= 0 && y <= 1 +-- | Returns @True@ iff a projection is consistent and complete. isValidP :: Projection -> Bool isValidP (Projection _label p pInv) = and [ check x y @@ -446,6 +307,7 @@ in not (validLonLat lonlat) || eqLonLat lonlat lonlat2 || trace (show (lonlat, lonlat2)) False +-- | Translate the lower-most point of a projection by an offset. moveBottomP :: Double -> Projection -> Projection moveBottomP offset (Projection label p pInv) = Projection label p' pInv' where @@ -454,9 +316,11 @@ XYCoord x y -> XYCoord x (fromToS offset 1 y) pInv' (XYCoord x y) = pInv (XYCoord x ((y-offset)/(1-offset))) +-- | Translate the top-most point of a projection by an offset. moveTopP :: Double -> Projection -> Projection moveTopP offset = flipYAxisP . moveBottomP offset . flipYAxisP +-- | Invert the Y axis of projection. flipYAxisP :: Projection -> Projection flipYAxisP (Projection label p pInv) = Projection label p' pInv' where @@ -467,6 +331,7 @@ let LonLat lam phi = pInv (XYCoord x (1-y)) in LonLat lam (negate phi) +-- | Scale X and Y axis of projection. scaleP :: Double -> Double -> Projection -> Projection scaleP xScale yScale (Projection label p pInv) = Projection label forward inverse where @@ -476,7 +341,8 @@ inverse (XYCoord x y) = pInv $ XYCoord ((x-0.5)/xScale+0.5) ((y-0.5)/yScale+0.5) - +-- | Attempt to smoothly interpolate two projections. The result may not be continuous +-- and 'interpP' may give prettier results. mergeP :: Projection -> Projection -> Double -> Projection mergeP p1 p2 t = Projection (projectionLabel p1 ++ "/" ++ projectionLabel p2) p pInv where @@ -587,6 +453,7 @@ lam = 2 * atan2 (z*x) (2*(2*z**2-1)) phi = asin (z*y) +-- | <> cylindricalEqualAreaP :: Double -> Projection cylindricalEqualAreaP phi0 = Projection "lambert" forward inverse where @@ -723,6 +590,7 @@ | v < lower = v+upper-lower | otherwise = v +-- | <> cassiniP :: Projection cassiniP = Projection "cassini" forward inverse where @@ -735,7 +603,7 @@ lam = atan2 (tan x) (cos y) phi = asin (sin y * cos x) - +-- | <> augustP :: Projection augustP = scaleP 0.70 0.70 $ Projection "august" forward inverse where @@ -875,6 +743,7 @@ phi = 2 * atan2 y (1 + faheyK) {-# INLINE foucautP #-} +-- | <> foucautP :: Projection foucautP = Projection "foucaut" forward inverse where @@ -898,6 +767,7 @@ lam = x * sqrtPi / 2 / (cos phi * cosk * cosk) {-# INLINE lagrangeP #-} +-- | <> lagrangeP :: Projection lagrangeP = Projection "lagrange" forward inverse where @@ -944,7 +814,7 @@ - +-- | Map for all features and render the geometry. drawFeatureCollection :: GeoFeatureCollection a -> (a -> SVG -> SVG) -> SVG drawFeatureCollection geo fn = mkGroup [ fn (feature ^. properties) $ renderGeometry (feature ^. geometry) @@ -952,6 +822,7 @@ ] {-# INLINE loadFeatureCollection #-} +-- | Load GeoJSON from a filepath and render the geometry. loadFeatureCollection :: FromJSON a => FilePath -> (a -> SVG -> SVG) -> SVG loadFeatureCollection path = unsafePerformIO $ do mbGeo <- decodeFileStrict path @@ -965,6 +836,7 @@ -- pointsToRadians :: SVG -> SVG -- applyProjection :: Projection -> SVG -> SVG +-- | Render GeoJSON geometry as SVG. renderGeometry :: GeospatialGeometry -> SVG renderGeometry shape = case shape of @@ -988,9 +860,15 @@ _ -> None +-- | Apply a projection to an SVG image. This is a lossy transformation +-- but the default tolerance is low enough that inaccuracies should not +-- be visible. applyProjection :: Projection -> SVG -> SVG applyProjection = applyProjection' 1e-2 +-- | Apply a projection to an SVG image with a specified tolerance. +-- Projections may turn straight lines into disjointed curves and +-- the tolerance argument determined the accuracy of this transformation. applyProjection' :: Double -> Projection -> SVG -> SVG applyProjection' tolerance p = mapSvgLines start where diff --git a/src/Reanimate/LaTeX.hs b/src/Reanimate/LaTeX.hs --- a/src/Reanimate/LaTeX.hs +++ b/src/Reanimate/LaTeX.hs @@ -1,5 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.LaTeX ( latex , latexWithHeaders @@ -40,6 +47,7 @@ latex :: T.Text -> Tree latex = latexWithHeaders [] +-- | Invoke latex with extra script headers. latexWithHeaders :: [T.Text] -> T.Text -> Tree latexWithHeaders = someTexWithHeaders "latex" "dvi" [] @@ -51,6 +59,7 @@ where script = mkTexScript exec args headers tex +-- | Invoke latex and separate results. latexChunks :: [T.Text] -> [Tree] latexChunks chunks | pNoExternals = map mkText chunks latexChunks chunks = worker (svgGlyphs $ latex $ T.concat chunks) chunks @@ -67,6 +76,7 @@ xelatex :: Text -> Tree xelatex = xelatexWithHeaders [] +-- | Invoke xelatex with extra script headers. xelatexWithHeaders :: [T.Text] -> T.Text -> Tree xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"] @@ -82,6 +92,7 @@ ctex :: T.Text -> Tree ctex = ctexWithHeaders [] +-- | Invoke xelatex with extra script headers + ctex headers. ctexWithHeaders :: [T.Text] -> T.Text -> Tree ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers) diff --git a/src/Reanimate/Math/Balloon.hs b/src/Reanimate/Math/Balloon.hs --- a/src/Reanimate/Math/Balloon.hs +++ b/src/Reanimate/Math/Balloon.hs @@ -1,6 +1,16 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -module Reanimate.Math.Balloon where +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} +module Reanimate.Math.Balloon + ( balloon + , balloon' + ) where import Control.Lens import qualified Data.Vector as V @@ -15,9 +25,20 @@ -- import Debug.Trace +-- | Inflate SVG shapes like a balloon. This works by hiding corners +-- that are more than @t@ percent distant from the starting point +-- relative to the maximum diameter of the shape. +-- +-- Example: +-- +-- > animate $ balloon (scale 8 $ center $ latex "X") +-- +-- <> balloon :: SVG -> (Double -> SVG) balloon = balloon' 0.01 +-- | Same as @balloon'@ but with a given tolerance for converting +-- SVG shapes to polygons. balloon' :: Double -> SVG -> (Double -> SVG) balloon' tol svg = \t -> mkGroup diff --git a/src/Reanimate/Math/Common.hs b/src/Reanimate/Math/Common.hs --- a/src/Reanimate/Math/Common.hs +++ b/src/Reanimate/Math/Common.hs @@ -1,3 +1,16 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-| +Module : Reanimate.Math.Common +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +Low-level primitives related to computational geometry. + +-} module Reanimate.Math.Common ( -- * Ring Ring(..) @@ -11,14 +24,13 @@ -- * Math , area -- :: Fractional a => V2 a -> V2 a -> V2 a -> a , area2X -- :: Fractional a => V2 a -> V2 a -> V2 a -> a - , epsilon -- :: Fractional a => a - , epsEq -- :: (Ord a, Fractional a) => a -> a -> Bool - , isLeftTurn -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool - , isLeftTurnOrLinear -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool - , isRightTurn -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool - , isRightTurnOrLinear -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool - , direction -- :: Fractional a => V2 a -> V2 a -> V2 a -> a + , isLeftTurn -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool + , isLeftTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool + , isRightTurn -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool + , isRightTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool + , direction -- :: Num a => V2 a -> V2 a -> V2 a -> a , isInside -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool + , isInsideStrict -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool , barycentricCoords -- :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a) , rayIntersect -- :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a) , isBetween -- :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool @@ -27,6 +39,7 @@ , approxDist -- :: (Real a, Fractional a) => V2 a -> V2 a -> a , distance' -- :: (Real a, Fractional a) => V2 a -> V2 a -> Double , triangleAngles -- :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double) + , Epsilon(..) ) where import Data.Vector (Vector) @@ -36,84 +49,111 @@ import Linear.V2 import Linear.V3 import Linear.Vector +import Linear.Epsilon +instance Epsilon Rational where + nearZero r = r==0 + +-- | Circular collection of pairs. newtype Ring a = Ring (Vector (V2 a)) +-- | Number of elements in the ring. ringSize :: Ring a -> Int ringSize (Ring v) = length v +-- | Safe method for accessing elements in the ring. ringAccess :: Ring a -> Int -> V2 a ringAccess (Ring v) i = v V.! mod i (length v) +-- | Clamp index to within the usable range for the ring. ringClamp :: Ring a -> Int -> Int ringClamp (Ring v) i = mod i (length v) +-- | Convert ring to a vector. ringUnpack :: Ring a -> Vector (V2 a) ringUnpack (Ring v) = v +-- | Convert vector to a ring. ringPack :: Vector (V2 a) -> Ring a ringPack = Ring +-- | Map each element of a ring. ringMap :: (V2 a -> V2 b) -> Ring a -> Ring b ringMap fn (Ring v) = Ring (V.map fn v) +-- | Compute the intersection of two pairs of nodes in the ring. ringRayIntersect :: Ring Rational -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) ringRayIntersect p (a,b) (c,d) = rayIntersect (ringAccess p a, ringAccess p b) (ringAccess p c, ringAccess p d) - +-- | Compute area of triangle. area :: Fractional a => V2 a -> V2 a -> V2 a -> a area a b c = 1/2 * area2X a b c +-- | Compute 2x area of triangle. This avoids a division. area2X :: Fractional a => V2 a -> V2 a -> V2 a -> a area2X (V2 a1 a2) (V2 b1 b2) (V2 c1 c2) = det33 (V3 (V3 a1 a2 1) (V3 b1 b2 1) (V3 c1 c2 1)) -epsilon :: Fractional a => a -epsilon = 1e-13 - -epsEq :: (Ord a, Fractional a) => a -> a -> Bool -epsEq a b = abs (a-b) < epsilon +compareEpsZero :: (Ord a, Fractional a, Epsilon a) => a -> Ordering +compareEpsZero val + | nearZero val = EQ + | otherwise = compare val 0 {-# INLINE isLeftTurn #-} --- Left turn. -isLeftTurn :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool +-- | Return @True@ iff the line from @p1@ to @p2@ makes a left-turn to @p3@. +isLeftTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool isLeftTurn p1 p2 p3 = - case compare (direction p1 p2 p3) 0 of + case compareEpsZero (direction p1 p2 p3) of LT -> True - EQ -> False -- colnear + EQ -> False -- colinear GT -> False {-# INLINE isLeftTurnOrLinear #-} -isLeftTurnOrLinear :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool +-- | Return @True@ iff the line from @p1@ to @p2@ does not make a right-turn to @p3@. +isLeftTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool isLeftTurnOrLinear p1 p2 p3 = - case compare (direction p1 p2 p3) 0 of + case compareEpsZero (direction p1 p2 p3) of LT -> True - EQ -> True -- colnear + EQ -> True -- colinear GT -> False {-# INLINE isRightTurn #-} -isRightTurn :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool +-- | Return @True@ iff the line from @p1@ to @p2@ makes a right-turn to @p3@. +isRightTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool isRightTurn a b c = not (isLeftTurnOrLinear a b c) {-# INLINE isRightTurnOrLinear #-} -isRightTurnOrLinear :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> Bool +-- | Return @True@ iff the line from @p1@ to @p2@ does not make a left-turn to @p3@. +isRightTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool isRightTurnOrLinear a b c = not (isLeftTurn a b c) {-# INLINE direction #-} -direction :: Fractional a => V2 a -> V2 a -> V2 a -> a +-- | Compute the change in direction in a line between the three points. +direction :: Num a => V2 a -> V2 a -> V2 a -> a direction p1 p2 p3 = crossZ (p3-p1) (p2-p1) {-# INLINE isInside #-} +-- | Returns @True@ if the fourth argument is inside the triangle or +-- on the border. isInside :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool isInside a b c d = - s >= 0 && s <= 1 && t >= 0 && t <= 1 + s >= 0 && s <= 1 && t >= 0 && t <= 1 && i >= 0 && i <= 1 where - (s, t, _) = barycentricCoords a b c d + (s, t, i) = barycentricCoords a b c d +{-# INLINE isInsideStrict #-} +-- | Returns @True@ iff the fourth argument is inside the triangle. +isInsideStrict :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool +isInsideStrict a b c d = + s > 0 && s < 1 && t > 0 && t < 1 && i > 0 && i < 1 + where + (s, t, i) = barycentricCoords a b c d + {-# INLINE barycentricCoords #-} +-- | Compute relative coordinates inside the triangle. Invariant: @a+b+c=1@ barycentricCoords :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a) barycentricCoords (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x y) = (lam1, lam2, lam3) @@ -126,6 +166,7 @@ {-# INLINE rayIntersect #-} +-- | Compute intersection of two infinite lines. rayIntersect :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a) rayIntersect (V2 x1 y1,V2 x2 y2) (V2 x3 y3, V2 x4 y4) | yBot == 0 = Nothing @@ -138,12 +179,14 @@ yBot = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) {-# INLINE isBetween #-} +-- | Returns @True@ iff a point is on a line segment. isBetween :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool isBetween (V2 x y) (V2 x1 y1, V2 x2 y2) = ((y1 > y) /= (y2 > y) || y == y1 || y == y2) && -- y is between y1 and y2 ((x1 > x) /= (x2 > x) || x == x1 || x == x2) {-# INLINE lineIntersect #-} +-- | Compute intersection of two line segments. lineIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a) lineIntersect a b = case rayIntersect a b of @@ -153,16 +196,20 @@ -- circleIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> [V2 a] -distSquared :: (Fractional a) => V2 a -> V2 a -> a +-- | Compute the square of the distance between two points. +distSquared :: (Num a) => V2 a -> V2 a -> a distSquared a b = quadrance (a ^-^ b) +-- | Approximate the distance between two points. approxDist :: (Real a, Fractional a) => V2 a -> V2 a -> a approxDist a b = realToFrac (sqrt (realToFrac (distSquared a b) :: Double)) +-- | Approximate the distance between two points. distance' :: (Real a, Fractional a) => V2 a -> V2 a -> Double distance' a b = sqrt (realToFrac (distSquared a b)) -- sum of angles is always pi. +-- | Approximate the angles of a triangle. triangleAngles :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double) triangleAngles a b c = (findAngle (b-a) (c-a) diff --git a/src/Reanimate/Math/Compatible.hs b/src/Reanimate/Math/Compatible.hs deleted file mode 100644 --- a/src/Reanimate/Math/Compatible.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -module Reanimate.Math.Compatible where - -import Data.List -import Data.Maybe -import Data.Ord -import qualified Data.Vector as V -import Linear.V2 -import Linear.Vector -import Reanimate.Math.Common -import Reanimate.Math.Polygon -import Reanimate.Debug -import Reanimate.Math.Render -import Reanimate.Svg -import Reanimate.Animation - --- import Debug.Trace - -truncateP :: V2 Rational -> V2 Rational -truncateP = fmap (realToFrac . (realToFrac :: Rational -> Double)) - -mkSteinerPoints :: V2 Rational -> V2 Rational -> Int -> [V2 Rational] -mkSteinerPoints a b s_ = [ lerp (i / (s + 1)) b a | i <- [1 .. s] ] - where s = fromIntegral s_ - --- 0..i,j..n-1 --- i..j -split1Link :: Polygon -> Int -> Int -> Int -> (Polygon, Polygon) -split1Link p i j s | j < i = split1Link p j i s -split1Link p i j s = - (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right) - where - n = pSize p - sp = mkSteinerPoints (pAccess p i) (pAccess p j) s - left = map (pAccess p) [0 .. i] ++ sp ++ map (pAccess p) [j .. n - 1] - right = map (pAccess p) [i .. j] ++ reverse sp - -steiner2Link :: Polygon -> Int -> Int -> V2 Rational -steiner2Link p i j | j < i = steiner2Link p j i -steiner2Link p i j - | isNeighbour - = error "steiner2Link: Points are neighbours" - | isParent - = error "steiner2Link: Points can directly see each other." - | not (isStraightLine || isGrandparent || oneBendBetween p i j) - = error - $ "steiner2Link: Cannot construct 2-link chain between points: " - ++ show (i, j, pParent p i j, pParent p i (pParent p i j)) - | otherwise - = truncateP $ lerp 0.5 (fst vect) (intersects !! 0) - where - distToV = approxDist (fst vect) - isNeighbour = i == pNext p j || i == pPrev p j - isParent = pParent p i j == i - isGrandparent = pParent p i (pParent p i j) == i - isStraightLine = - direction (pAccess p j) (pAccess p $ pParent p i j) (pAccess p i) == 0 - intersects = - sortOn distToV - $ snd vect - : [ u - | n <- [0 .. pSize p - 1] - , let edge = (pAccess p n, pAccess p $ pNext p n) - , u <- case rayIntersect vect edge of - Nothing -> [] - Just u -> [u] - , isBetween u edge - , u /= fst vect - , isForward vect u - ] - iP = pAdjustOffset p i - jP = pAdjustOffset p j - vect - | isStraightLine - = let p1 = lerp 0.5 (pAccess p i) (pAccess p j) - p2 = case p1 - pAccess p i of - V2 x y -> p1 + V2 (-y) x -- rotate 90 degrees. - in (p1, p2) - | otherwise - = fromMaybe - (error $ "No window overlap: " ++ show - (isStraightLine, isGrandparent, oneBendBetween p i j) - ) - $ listToMaybe - $ [ (p1, p1 + (p2 - p1) + (p3 - p1)) - | (a, b) <- ssspWindows iP - , (c, d) <- ssspWindows jP - , (p1, p2, p3) <- if - | a == c -> pure (a, b, d) - | a == d -> pure (a, b, c) - | b == c -> pure (b, a, d) - | b == d -> pure (b, a, c) - | otherwise -> [] - ] - isForward (a, b) v = not (isBetween a (b, v)) - --- 0..i,s,j..n-1 --- i..j,s -split2Link :: Polygon -> Int -> Int -> (Polygon, Polygon) -split2Link p i j | j < i = split2Link p j i -split2Link p i j = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right) - where - s = steiner2Link p i j - n = pSize p - left = map (pAccess p) [0 .. i] ++ [s] ++ map (pAccess p) [j .. n - 1] - right = map (pAccess p) [i .. j] ++ [s] - -data Link = OneLink | TwoLink - -splitNLink :: Polygon -> Int -> [(Link, Int)] -> (Polygon, Polygon) -splitNLink p i js = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right) - where - n = pSize p - left = map (pAccess p) [0 .. i] ++ steiners ++ map (pAccess p) [j .. n - 1] - right = map (pAccess p) [i .. j] ++ reverse steiners - j = snd (last js) - steiners = splitNLinks p i js --- 0, [(TwoLink,2),(OneLink,3)] --- 0, [(OneLink,5),(TwoLink,3)] -splitNLinks :: Polygon -> Int -> [(Link, Int)] -> [V2 Rational] -splitNLinks _p _i [] = [] -splitNLinks p i [(TwoLink, j )] = [steiner2Link p i j] -splitNLinks _p _i [(OneLink, _j)] = [] -splitNLinks p i ((TwoLink, j) : (OneLink, j') : xs) = - let - (l, r) = split2Link p i j - p' = selectContains l r (pAccess p j') - s = steiner2Link p i j - sIdx = - fromMaybe (error "missing steiner") $ V.elemIndex s (polygonPoints p') - in - s : splitNLinks p' sIdx ((TwoLink, j') : xs) -splitNLinks p i ((TwoLink, j) : (TwoLink, j') : xs) = - let - (l, r) = split2Link p i j - p' = selectContains l r (pAccess p j') - s = steiner2Link p i j - sIdx = - fromMaybe (error "missing steiner") $ V.elemIndex s (polygonPoints p') - in - s : splitNLinks p' sIdx ((OneLink, j) : (TwoLink, j') : xs) -splitNLinks p i ((OneLink, j) : (TwoLink, j') : xs) = - let - (l, r) = split2Link p j j' - p' = selectContains l r (pAccess p i) - p'' = selectContains l r (pAccess p j') - s = steiner2Link p j j' - s' = steiner2Link p' i sIdx - sIdx = fromMaybe (error "missing steiner sIdx") - $ V.elemIndex s (polygonPoints p') - sIdx' = fromMaybe (error "missing steiner sIdx'") - $ V.elemIndex s' (polygonPoints p'') - in - s' : s : splitNLinks p'' sIdx' ((OneLink, j') : xs) -splitNLinks _p _i _ = error "splitNLinks: invalid input" - -selectContains :: Polygon -> Polygon -> V2 Rational -> Polygon -selectContains p1 p2 elt | V.elem elt (polygonPoints p1) = p1 - | V.elem elt (polygonPoints p2) = p2 - | otherwise = error "elt not member of either polygons" --- [(P, Vis)] -> Polygon -> [P] -{- -If there is a 1-link path, connect it. - Recurse into the two new polygon pairs. - -If there is a 2-link path, connect it, possibly add bogus steiner point. - Recurse into the two new polygon pairs. - -If there is a n-link path, connect it, add bogus steiner points. - Recurse into the two new polygon pairs. --} - --- a 2 b 1 c --- ab = 2-link of (a,b) --- abc = 2-link of (cut-a-ab-b, c) --- steps: a ab abc c --- a, [(2,b), (1,c)] --- [(ab, p1,p2)] - -{- -, mkGroup - [ withStrokeColor "green" $mkGroup - [ mkLine (x1,y1) (x2,y2) - , mkLine (x1',y1') (x2',y2') ] - | (a,b) <- mWins - , (i,j) <- oWins - , a == i || a == j || b == i || b == j - , not (sort [a,b] == sort [i,j]) - , let V2 x1 y1 = realToFrac <$> a - V2 x2 y2 = realToFrac <$> b - V2 x1' y1' = realToFrac <$> i - V2 x2' y2' = realToFrac <$> j - ] --} - - - -type Points = V.Vector (V2 Rational) -type Edges = [(Int, Int, Int)] -data Mesh = Mesh { meshPoints :: Points, meshEdges :: Edges } -data MeshPair = MeshPair Points Points Edges --- The points in a RelMesh are: --- relMeshStatic ++ x where Ax = B --- data RelMesh = RelMesh --- { relMeshStatic :: Points --- , relMeshEdges :: Edges --- , relMeshA :: Matrix Double --- , relMeshB :: Matrix Double --- } --- data RelMeshPair = RelMeshPair Points Edges (Matrix Double) (Matrix Double) (Matrix Double) (Matrix Double) --- --- - --- Use SSSP to find 1-link connections --- Compute visibility windows for each node --- Check windows for ovelap, giving 2-link connections. --- Use floyd to generate all other connections --- (a,b,1) --- (a,b,2) --- floyd -compatiblyTriangulateP :: Polygon -> Polygon -> [(Polygon, Polygon)] -compatiblyTriangulateP a b - | pSize a /= pSize b = error "polygon size mismatch" - | otherwise = traceSVG (showStep a b) $ compatiblyTriangulateP' - (pSetOffset a 0) - (pSetOffset a 0) - (pSetOffset b 0) - -showStep :: Polygon -> Polygon -> SVG -showStep a b = mkGroup - [ translate (-3) 0 - $ mkGroup [withFillColor "grey" $ polygonShape a, polygonNumDots a] - , translate 3 0 - $ mkGroup [withFillColor "grey" $ polygonShape b, polygonNumDots b] - ] - -compatiblyTriangulateP' :: Polygon -> Polygon -> Polygon -> [(Polygon, Polygon)] -compatiblyTriangulateP' aOrigin a b - | n == 3 = traceSVG (showStep a b) $ {- trace ("Done") $ -} [(a, b)] - | otherwise = - -- trace ("aOneLink: " ++ show aOneLink) $ - -- trace ("bOneLink: " ++ show bOneLink) $ - -- trace ("aTwoLink: " ++ show aTwoLink) $ - -- trace ("bTwoLink: " ++ show bTwoLink) $ - traceSVG (showStep a b) $ case bestOneLink of - Nothing -> case bestTwoLink of - Nothing -> error $ "no 2-links" - Just (nodeL, nodeR) -> - {-trace - (show - ("two link" :: String, toOriginIndex nodeL, toOriginIndex nodeR) - ) - $ -} - let (aL, aR) = if (nodeL, nodeR) `elem` aOneLink - then split1Link a nodeL nodeR 1 - else split2Link a nodeL nodeR - (bL, bR) = if (nodeL, nodeR) `elem` bOneLink - then split1Link b nodeL nodeR 1 - else split2Link b nodeL nodeR - in compatiblyTriangulateP' aOrigin aL bL - ++ compatiblyTriangulateP' aOrigin aR bR - Just (nodeL, nodeR) -> - {-trace - (show ("one link" :: String, toOriginIndex nodeL, toOriginIndex nodeR) - ) - $ -} - let (aL, aR) = split1Link a nodeL nodeR 0 - (bL, bR) = split1Link b nodeL nodeR 0 - in compatiblyTriangulateP' aOrigin aL bL - ++ compatiblyTriangulateP' aOrigin aR bR - where - -- toOriginIndex idx = - -- ( idx - -- , fromMaybe (-1) (V.elemIndex (pAccess a idx) (polygonPoints aOrigin)) - -- + polygonOffset aOrigin - -- ) - n = pSize a - bestOneLink = - listToMaybe (sortOn (Down . nodeDist) (aOneLink `intersect` bOneLink)) - bestTwoLink = listToMaybe - (sortOn (Down . nodeDist) - ((aOneLink ++ aTwoLink) `intersect` (bOneLink ++ bTwoLink)) - ) - aOneLink = polygonOneLinks a - bOneLink = polygonOneLinks b - aTwoLink = polygonTwoLinks a - bTwoLink = polygonTwoLinks b - nodeDist (i, j) = min (j - i) (n - j + i) - -oneBendBetween :: Polygon -> Int -> Int -> Bool -oneBendBetween _p _a _b = False --- oneBendBetween p a b = --- direction --- (pAccess p b) --- (pAccess p (pParent p a b)) --- (pAccess p $ obstructedBy b) == 0 && --- (pParent p a b) /= obstructedBy b --- where --- obstructedBy n = --- case pParent p a n of --- i -> if i == a then n else obstructedBy i - -polygonTwoLinks :: Polygon -> [(Int, Int)] -polygonTwoLinks p = - [ (i, j) - | i <- [0 .. n - 1] - , j <- [i + 2 .. n - 1] - , not (i == 0 && j == n - 1) - , pParent p i j /= i -- check for 1-link - , let isTwoLink = pParent p i (pParent p i j) == i - isStraightLine = oneBendBetween p i j --- Points on a straight line should be 2-link even though they are not --- direct grandparents. - , isTwoLink || isStraightLine - ] - where n = pSize p - -polygonOneLinks :: Polygon -> [(Int, Int)] -polygonOneLinks p = - [ (i, j) - | i <- [0 .. pSize p - 1] - , j <- [i + 2 .. pSize p - 1] - , not (i == 0 && j == pSize p - 1) - , pParent p i j == i - ] diff --git a/src/Reanimate/Math/DCEL.hs b/src/Reanimate/Math/DCEL.hs deleted file mode 100644 --- a/src/Reanimate/Math/DCEL.hs +++ /dev/null @@ -1,891 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --- Code originally from: https://github.com/wereHamster/haskell-half-edge-mesh -module Reanimate.Math.DCEL where - -import Codec.Picture.Types -import Control.Lens -import Control.Monad.State -import Control.Monad.Writer -import Data.List -import qualified Data.List as L -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Vector as V --- import Debug.Trace -import Linear.Metric -import Linear.V2 -import Linear.Vector (lerp, (^/)) -import Reanimate -import Reanimate.Math.Common (isInside, lineIntersect, triangleAngles) -import Reanimate.Math.Polygon -import qualified Reanimate.Morph.Rigid as Rigid -import Text.Printf - -type VertexId = Int -type EdgeId = Int -type FaceId = Int - --- Invariants: --- No duplicate positions --- All edges have an opposite twin --- Edge prev/next keep the same direction (CW or CCW) --- twin (twin edge) = edge --- All next/prev links have the same face -data Mesh a = Mesh - { _meshIdCounter :: Int - , _meshOuterFace :: FaceId - , _meshVertices :: Map VertexId (Vertex a) - , _meshEdges :: Map EdgeId Edge - , _meshFaces :: Map FaceId Face - } deriving (Show) - -data Vertex a = Vertex - { _vertexId :: VertexId - , _vertexPosition :: a - -- , _vertexEdge :: EdgeId -- Index to CCW edge pointing to this vertex. - } deriving (Show) - -data Edge = Edge - { _edgeId :: EdgeId - , _edgeVertex :: VertexId - , _edgeTwin :: EdgeId - , _edgeNext :: EdgeId - , _edgePrev :: EdgeId - , _edgeFace :: FaceId - } deriving (Show) - -data Face = Face - { _faceId :: FaceId - , _faceEdge :: EdgeId - } deriving (Show) - -type MeshM position a = State (Mesh position) a - -validMesh :: Mesh a -> [String] -validMesh Mesh{..} = execWriter $ do - return () - -makeLenses ''Mesh -makeLenses ''Vertex -makeLenses ''Edge -makeLenses ''Face - -meshGetEdge :: EdgeId -> Mesh a -> Edge -meshGetEdge eid Mesh{..} = M.findWithDefault err eid _meshEdges - where - err = error $ "Edge not found: " ++ show eid - -meshGetVertex :: VertexId -> Mesh a -> Vertex a -meshGetVertex vid Mesh{..} = M.findWithDefault err vid _meshVertices - where - err = error $ "Vertex not found: " ++ show vid - -meshGetFace :: FaceId -> Mesh a -> Face -meshGetFace fid Mesh{..} = M.findWithDefault err fid _meshFaces - where - err = error $ "Face not found: " ++ show fid - -meshAngles :: Mesh (V2 Double) -> [Double] -meshAngles mesh@Mesh{..} = - [ faceMinAngle fid mesh - | fid <- M.keys _meshFaces - ] - -meshEdgeAngle :: Mesh (V2 Double) -> EdgeId -> Double -meshEdgeAngle m eId = - ang - where - edge = meshGetEdge eId m - next = meshGetEdge (edge ^. edgeNext) m - prev = meshGetEdge (edge ^. edgePrev) m - v1 = meshGetVertex (prev ^. edgeVertex) m ^. vertexPosition - v2 = meshGetVertex (edge ^. edgeVertex) m ^. vertexPosition - v3 = meshGetVertex (next ^. edgeVertex) m ^. vertexPosition - (_, ang, _) = triangleAngles v1 v2 v3 - -facePositions :: FaceId -> Mesh a -> [a] -facePositions fid m = - [ meshGetVertex (edge^.edgeVertex) m ^. vertexPosition - | eid <- faceEdges fid m - , let edge = meshGetEdge eid m - ] - -faceEdges :: FaceId -> Mesh a -> [EdgeId] -faceEdges fid m = worker (meshGetEdge lastEdge m ^.edgeNext) - where - face = meshGetFace fid m - lastEdge = face^.faceEdge - worker eid - | eid == lastEdge = [eid] - | otherwise = eid : worker (meshGetEdge eid m ^. edgeNext) - -faceMinAngle :: FaceId -> Mesh (V2 Double) -> Double -faceMinAngle fid m = minimum (map (meshEdgeAngle m) (faceEdges fid m)) - -ppMesh :: Show a => Mesh a -> String -ppMesh Mesh{..} = unlines - [ printf "Outer face: %d" _meshOuterFace - , "" - , "Vertices:" - , printf "%4s %5s %10s" ("ID"::String) ("Edge"::String) ("Position"::String) - , unlines - [ printf "%4d %10s" _vertexId (show _vertexPosition) - | Vertex{..} <- M.elems _meshVertices - ] - , "Edges:" - , printf "%4s %3s %4s %4s %4s %4s" - ("ID"::String) ("Vtx"::String) ("Twin"::String) ("Next"::String) - ("Prev"::String) ("Face"::String) - , unlines - [ printf "%4d %3d %4d %4d %4d %4d" _edgeId _edgeVertex _edgeTwin _edgeNext _edgePrev _edgeFace - | Edge{..} <- M.elems _meshEdges - ] - , "Faces:" - , unlines - [ printf "%4d %4d" _faceId _faceEdge - | Face{..} <- M.elems _meshFaces - ] - ] - -emptyMesh :: Mesh a -emptyMesh = Mesh 1 0 M.empty M.empty M.empty - --- addFace :: FaceId -> [a] -> MeshM a () --- addFace parentFace subPoly = do --- innerFace <- createFace --- vIds <- mapM getVertex pts --- edges <- forM (zip vIds (tail vIds ++ take 1 vIds)) $ \(v0, v1) -> do --- e <- do --- mbEdge <- findEdge' v0 v1 --- case mbEdge of --- Just e -> pure (e ^. edgeId) --- Nothing -> do --- e <- createEdge v1 --- twin <- createEdge v0 --- setTwinEdge e twin --- setFace twin parentFace --- return e --- setFace e innerFace --- modifyVertex (vertexEdge .~ e) v0 --- pure e - --- setFaceEdge innerFace (head edges) --- forM_ (zip edges (tail edges ++ take 1 edges)) $ \(e0, e1) -> --- linkEdges e0 e1 - -polygonsMesh :: Eq a => [a] -> [[a]] -> MeshM a () -polygonsMesh outer trigs = do - polygonMeshOuter (reverse outer) - modify $ meshFaces .~ M.empty - forM_ trigs $ \pts -> do - innerFace <- createFace - vIds <- mapM getVertex pts - edges <- forM (zip vIds (tail vIds ++ take 1 vIds)) $ \(_v0, v1) -> do - e <- createEdge v1 - setFace e innerFace - -- modifyVertex (vertexEdge .~ e) v0 - pure e - - setFaceEdge innerFace (head edges) - forM_ (zip edges (tail edges ++ take 1 edges)) $ \(e0, e1) -> - linkEdges e0 e1 - forM edges $ \e -> do - edge <- getEdge e - prev <- getEdge (edge ^. edgePrev) - mbTwin <- findEdge' (edge ^. edgeVertex) (prev ^. edgeVertex) - case mbTwin of - Nothing -> return () - Just twin -> - setTwinEdge e (twin^.edgeId) - --- Positions must be in CW order -polygonMesh :: [a] -> MeshM a () -polygonMesh vs = do - outerFace <- gets _meshOuterFace - innerFace <- createFace - vIds <- mapM createVertex vs - edges <- forM (zip vIds (tail vIds ++ take 1 vIds)) $ \(v0, v1) -> do - e <- createEdge v1 -- Edge from v0 to v1 - e' <- createEdge v0 -- Twin edge from v1 to v0 - setFace e innerFace - setFace e' outerFace - -- modifyVertex (vertexEdge .~ e) v0 - setTwinEdge e e' - pure e - - outerEdge <- _edgeTwin <$> getEdge (head edges) - setFaceEdge innerFace (head edges) - setFaceEdge outerFace outerEdge - - forM_ (zip edges (tail edges ++ take 1 edges)) $ \(e0, e1) -> do - linkEdges e0 e1 - e0' <- _edgeTwin <$> getEdge e0 - e1' <- _edgeTwin <$> getEdge e1 - linkEdges e1' e0' - -polygonMeshOuter :: [a] -> MeshM a () -polygonMeshOuter vs = do - outerFace <- gets _meshOuterFace - vIds <- mapM createVertex vs - edges <- forM vIds $ \v0 -> do - e' <- createEdge v0 - setFace e' outerFace - pure e' - - setFaceEdge outerFace (head edges) - - let f = Face outerFace (head edges) - modify $ meshFaces %~ M.insert outerFace f - - forM_ (zip edges (tail edges ++ take 1 edges)) $ \(e0, e1) -> do - linkEdges e0 e1 - - -newId :: MeshM a Int -newId = do - counter <- gets _meshIdCounter - modify $ meshIdCounter %~ succ - return counter - -createVertex :: a -> State (Mesh a) VertexId -createVertex position = do - k <- newId - let v = Vertex k position -- (error "_vertexEdge not set") - modify $ meshVertices %~ M.insert k v - return k - -getVertex :: Eq a => a -> State (Mesh a) VertexId -getVertex position = do - vs <- gets _meshVertices - case L.find comparingPosition (M.assocs vs) of - Nothing -> createVertex position - Just (k, _) -> return k - where comparingPosition (_k, v) = (_vertexPosition v) == position - -requireVertex :: VertexId -> MeshM a (Vertex a) -requireVertex vid = do - ret <- gets (M.lookup vid . _meshVertices) - case ret of - Nothing -> error "Invalid vertex id" - Just v -> pure v - -modifyVertex :: (Vertex a -> Vertex a) -> VertexId -> State (Mesh a) () -modifyVertex f k = modify $ meshVertices %~ M.adjust f k - -getEdge :: EdgeId -> State (Mesh a) Edge -getEdge e = do - edges <- gets _meshEdges - maybe (bug edges) return $ M.lookup e edges - --return $ fromJust $ M.lookup e edges - where bug _edges = error $ "Can't find edge with id " ++ (show e) - -withEdge :: EdgeId -> (Edge -> State (Mesh a) ()) -> State (Mesh a) () -withEdge e f = f =<< getEdge e - --- findEdge :: VertexId -> VertexId -> State (Mesh a) EdgeId --- findEdge v0 v1 = do --- edges <- gets _meshEdges --- case L.find comparingVertices (M.assocs edges) of --- Nothing -> error $ "No edge between: " ++ show (v0, v1) --- Just (k, _) -> return k --- where comparingVertices (k, e) = (k, _edgeNext e) == (v0, v1) - -createEdge :: VertexId -> State (Mesh a) EdgeId -createEdge v = do - k <- newId - let e = Edge k - v - (error $ "_edgeTwin not set " ++ show (k,v)) - (error $ "_edgeNext not set " ++ show (k,v)) - (error $ "_edgePrev not set " ++ show (k,v)) - (error $ "_edgeFace not set " ++ show (k,v)) - modify $ meshEdges %~ M.insert k e - return k - -modifyEdge :: (Edge -> Edge) -> EdgeId -> State (Mesh a) () -modifyEdge f k = modify $ meshEdges %~ M.adjust f k - -linkEdges :: EdgeId -> EdgeId -> State (Mesh a) () -linkEdges e0 e1 = do - setNextEdge e0 e1 - setPreviousEdge e1 e0 - -setNextEdge :: EdgeId -> EdgeId -> State (Mesh a) () -setNextEdge e0 e1 = modifyEdge (edgeNext .~ e1) e0 - -setPreviousEdge :: EdgeId -> EdgeId -> State (Mesh a) () -setPreviousEdge e0 e1 = modifyEdge (edgePrev .~ e1) e0 - -setTwinEdge :: EdgeId -> EdgeId -> MeshM a () -setTwinEdge e0 e1 = do - modifyEdge (edgeTwin .~ e1) e0 - modifyEdge (edgeTwin .~ e0) e1 - -setFace :: EdgeId -> FaceId -> State (Mesh a) () -setFace e0 f0 = modifyEdge (edgeFace .~ f0) e0 - -updateFaces :: EdgeId -> FaceId -> State (Mesh a) () -updateFaces e0 f0 = do - e <- getEdge e0 - setFace e0 f0 - worker (e ^. edgeNext) - where - worker e1 - | e0 == e1 = return () - | otherwise = do - e <- getEdge e1 - setFace e1 f0 - worker (e ^. edgeNext) - -createFace :: State (Mesh a) FaceId -createFace = do - k <- newId - let f = Face k (error "_faceEdge not set") - modify $ meshFaces %~ M.insert k f - return k - -modifyFace :: (Face -> Face) -> FaceId -> State (Mesh a) () -modifyFace f k = modify $ meshFaces %~ M.adjust f k - -setFaceEdge :: FaceId -> EdgeId -> MeshM a () -setFaceEdge f0 e0 = modifyFace (\f -> f { _faceEdge = e0 }) f0 - -deleteFace :: FaceId -> MeshM a () -deleteFace f0 = modify $ meshFaces %~ M.delete f0 - -getFace :: FaceId -> State (Mesh a) Face -getFace f = do - faces <- gets _meshFaces - maybe bug return (M.lookup f faces) - where bug = error $ "Can't find face with id " ++ (show f) - - -buildMesh :: State (Mesh a) b -> Mesh a -buildMesh f = execState f emptyMesh - -numVertices :: Mesh a -> Int -numVertices = M.size . _meshVertices - -numEdges :: Mesh a -> Int -numEdges = M.size . _meshEdges - -numFaces :: Mesh a -> Int -numFaces = M.size . _meshFaces - -vertices :: Mesh a -> [Vertex a] -vertices = M.elems . _meshVertices - -outgoingEdges :: VertexId -> Mesh a -> [Edge] -outgoingEdges v mesh = - [ meshGetEdge (edge ^. edgeTwin) mesh - | edge <- M.elems (_meshEdges mesh) - , _edgeVertex edge == v - ] - - --- for each inner node: --- get all neighbour nodes. sort by CCW --- compute laplacian --- compute angle-based --- check correctness --- move vertex - --- p e --- _ -> u -> v --- p' e' --- _ <- u <- v --- --- p e1 e --- _ -> u -> t -> v --- p' e1' e' --- _ <- u <- t <- v --- --- faces stay the same -splitEdge :: VertexId -> EdgeId -> MeshM a EdgeId -splitEdge t e = do - eEdge <- getEdge e - eEdgeTwin <- getEdge (eEdge ^. edgeTwin) - - e1 <- createEdge t - setFace e1 (eEdge ^. edgeFace) - -- modifyVertex (vertexEdge .~ e1) t - - e1' <- createEdge (eEdgeTwin ^. edgeVertex) - setFace e1' (eEdgeTwin ^. edgeFace) - setTwinEdge e1 e1' - - let oldPrev = eEdge ^. edgePrev - oldNext = eEdgeTwin ^. edgeNext - - linkEdges oldPrev e1 - linkEdges (eEdge ^. edgeTwin) e1' - linkEdges e1 e - linkEdges e1' oldNext - - modifyEdge (edgeVertex .~ t) (eEdge ^. edgeTwin) - - return e1 - -splitTriangle :: V2 Double -> EdgeId -> MeshM (V2 Double) (FaceId, FaceId, FaceId, FaceId) -splitTriangle vertex e = do - -- outer <- gets _meshOuterFace - edge <- getEdge e - next <- getEdge (edge^.edgeNext) - twin <- getEdge (edge^.edgeTwin) - next' <- getEdge (twin^.edgeNext) - - t <- createVertex vertex - _ <- splitEdge t e - - smoothVertex t - - (f1,f2) <- insertEdge (edge^.edgeFace) t (next^.edgeVertex) - (f3,f4) <- insertEdge (twin^.edgeFace) t (next'^.edgeVertex) - return (f1,f2,f3,f4) - -splitOuterTriangle :: V2 Double -> EdgeId -> MeshM (V2 Double) (FaceId, FaceId) -splitOuterTriangle vertex e = do - -- outer <- gets _meshOuterFace - edge <- getEdge e - twin <- getEdge (edge^.edgeTwin) - next' <- getEdge (twin^.edgeNext) - - t <- createVertex vertex - _ <- splitEdge t e - - (f1,f2) <- insertEdge (twin^.edgeFace) t (next'^.edgeVertex) - return (f1,f2) - -- return (outer, outer) - -findEdge :: FaceId -> VertexId -> MeshM a Edge -findEdge f v = do - edges <- gets (M.elems . _meshEdges) - case - listToMaybe [ e | e <- edges, e ^. edgeFace == f, e ^. edgeVertex == v ] - of - Nothing -> error $ "Edge not found: " ++ show (f, v) - Just e -> pure e - -findEdge' :: VertexId -> VertexId -> MeshM a (Maybe Edge) -findEdge' v0 v1 = do - m <- get - pure $ listToMaybe - [ e - | e <- M.elems (m^.meshEdges) - , e ^. edgeVertex == v1 - , let prev = meshGetEdge (e ^. edgePrev) m - , prev ^. edgeVertex == v0 - ] - -findEdge'' :: [FaceId] -> VertexId -> MeshM a (Maybe Edge) -findEdge'' fs v = do - edges <- gets (M.elems . _meshEdges) - pure $ - listToMaybe [ e | e <- edges, e ^. edgeFace `notElem` fs, e ^. edgeVertex == v ] - -{- - --} -deleteEdge :: EdgeId -> MeshM a () -deleteEdge e0 = do - e <- getEdge e0 - e' <- getEdge (e^.edgeTwin) - linkEdges (e^.edgePrev) (e'^.edgeNext) - linkEdges (e'^.edgePrev) (e^.edgeNext) - updateFaces (e^.edgeNext) (e^.edgeFace) - setFaceEdge (e^.edgeFace) (e^.edgeNext) - deleteFace (e'^.edgeFace) - modify $ meshEdges %~ M.delete (e^.edgeId) - modify $ meshEdges %~ M.delete (e'^.edgeId) - -insertEdge :: FaceId -> VertexId -> VertexId -> MeshM a (FaceId, FaceId) -insertEdge f0 v0 v1 = do - hv0 <- findEdge f0 v0 - hv1 <- findEdge f0 v1 - f1 <- createFace - f2 <- createFace - h1 <- createEdge v1 - h2 <- createEdge v0 - setFaceEdge f1 h1 - setFaceEdge f2 h2 - setTwinEdge h1 h2 - linkEdges (hv0 ^. edgeId) h1 - linkEdges (hv1 ^. edgeId) h2 - linkEdges h1 (hv1 ^. edgeNext) - linkEdges h2 (hv0 ^. edgeNext) - updateFaces (hv0 ^. edgeId) f1 - updateFaces (hv1 ^. edgeId) f2 - modify $ meshFaces %~ M.delete f0 - return (f1,f2) - -steinerNodes :: Mesh a -> [VertexId] -steinerNodes Mesh{..} = - [ v - | v <- M.keys _meshVertices - , S.notMember v notSteiner - ] - where - notSteiner = S.fromList - [ _edgeVertex edge - | edge <- M.elems _meshEdges - , _edgeFace edge == _meshOuterFace ] - --- findNeighbours :: VertexId -> Mesh a -> [Edge] --- findNeighbours vertex Mesh{..} = --- [ edge --- | edge <- M.elems _meshEdges --- , _edgeVertex edge == vertex --- ] - -{- -For each internal node: - * Find neighbours - * Compute angle-based position - * Compute laplacian position - * Update if possible --} -meshSmoothPosition :: Mesh (V2 Double) -> Mesh (V2 Double) -meshSmoothPosition = execState worker - where - worker = gets steinerNodes >>= mapM_ smoothVertex - -smoothVertex :: VertexId -> MeshM (V2 Double) () -smoothVertex steiner = do - self <- _vertexPosition <$> requireVertex steiner - es <- gets (outgoingEdges steiner) - vs <- mapM (requireVertex . _edgeVertex) es - let ps = V.fromList (sortEdges self (map _vertexPosition vs)) - angleBased = angleSmooth self ps - laplacian = sum ps ^/ (fromIntegral $ length ps) -- laplacian - if isValidLocation self ps angleBased - then modifyVertex (vertexPosition .~ angleBased) steiner - else if isValidLocation self ps laplacian - then modifyVertex (vertexPosition .~ laplacian) steiner - else return () - where - sortEdges :: V2 Double -> [V2 Double] -> [V2 Double] - sortEdges = sortOn . dir - -- Direction from south of 'a', to 'a', to 'b'. - dir :: V2 Double -> V2 Double -> Double - dir a b = (atan2 (crossZ (V2 0 1) (b - a)) (dot (V2 0 1) (b - a))) - - -angleSmooth :: V2 Double -> V.Vector (V2 Double) -> V2 Double -angleSmooth origin js = V.sum (V.generate n nth) ^/ V.sum (V.generate n factor) - where - n = length js - factor i = - let n_self = js V.! i - n_origin = origin - n_self - n_prev = js V.! mod (i - 1) n - n_self - n_next = js V.! mod (i + 1) n - n_self - a1 = acos (dot n_origin n_next / (norm n_origin * norm n_next)) - a2 = acos (dot n_origin n_prev / (norm n_origin * norm n_prev)) - alpha = a1 + a2 - in recip (alpha * alpha) - nth i = - let V2 x y = origin - n_self@(V2 x_0 y_0) = js V.! i - n_origin = origin - n_self - n_prev = js V.! mod (i - 1) n - n_self - n_next = js V.! mod (i + 1) n - n_self - a1 = acos (dot n_origin n_next / (norm n_origin * norm n_next)) - a2 = acos (dot n_origin n_prev / (norm n_origin * norm n_prev)) - alpha = a1 + a2 - b = (a2 - a1) / 2 - x' = x_0 + (x - x_0) * cos b - (y - y_0) * sin b - y' = y_0 + (x - x_0) * sin b + (y - y_0) * cos b - in V2 x' y' ^/ (alpha * alpha) - -isValidLocation :: V2 Double -> V.Vector (V2 Double) -> V2 Double -> Bool -isValidLocation origin edges newLoc = - or - [ isInside origin a b newLoc - | i <- [0 .. length edges - 1] - , let a = edges V.! i - b = edges V.! mod (i + 1) (length edges) - ] - && V.toList edges - == sortOn (dir newLoc) (V.toList edges) - && minAngle origin edges - < minAngle newLoc edges - where - dir :: V2 Double -> V2 Double -> Double - dir a b = (atan2 (crossZ (V2 0 1) (b - a)) (dot (V2 0 1) (b - a))) - -minAngle :: V2 Double -> V.Vector (V2 Double) -> Double -minAngle origin edges = minimum $ concat - [ [a1, a2, a3] - | i <- [0 .. length edges - 1] - , let a = edges V.! i - b = edges V.! mod (i + 1) (length edges) - (a1, a2, a3) = triangleAngles origin a b - ] - -flipEdge :: Edge -> MeshM (V2 Double) (FaceId, FaceId) -flipEdge e = do - e' <- getEdge (e^.edgeTwin) - - v0 <- _vertexPosition <$> requireVertex (e^.edgeVertex) - v1 <- _vertexPosition <$> requireVertex (e'^.edgeVertex) - - a' <- getEdge (e^.edgeNext) - b' <- getEdge (e'^.edgeNext) - - v0' <- _vertexPosition <$> requireVertex (a'^.edgeVertex) - v1' <- _vertexPosition <$> requireVertex (b'^.edgeVertex) - - case lineIntersect (v0, v1) (v0', v1') of - Nothing -> pure (e^.edgeFace, e'^.edgeFace) - Just{} -> do - deleteEdge (e^.edgeId) - insertEdge (e^.edgeFace) (a'^.edgeVertex) (b'^.edgeVertex) - -internalEdges :: Mesh a -> [EdgeId] -internalEdges m = - [ edge^.edgeId - | edge <- M.elems (m^.meshEdges) - , edge^.edgeFace /= m^.meshOuterFace - , let twin = meshGetEdge (edge^.edgeTwin) m - , edge^.edgeVertex < twin^.edgeVertex - , twin^.edgeFace /= m^.meshOuterFace - ] - -outerEdges :: Mesh a -> [EdgeId] -outerEdges m = - [ edge^.edgeId - | edge <- M.elems (m^.meshEdges) - , edge^.edgeFace == m^.meshOuterFace - ] - -longestEdge :: Mesh (V2 Double) -> Mesh (V2 Double) -> EdgeId -longestEdge m1 m2 = - maximumBy cmp (internalEdges m1) - where - cmp e1 e2 = - compare - (max (edgeLength e1 m1) (edgeLength e1 m2)) - (max (edgeLength e2 m1) (edgeLength e2 m2)) - -edgeLength :: EdgeId -> Mesh (V2 Double) -> Double -edgeLength eid m = - let edge = meshGetEdge eid m - twin = meshGetEdge (edge^.edgeTwin) m - p1 = _vertexPosition $ meshGetVertex (edge^.edgeVertex) m - p2 = _vertexPosition $ meshGetVertex (twin^.edgeVertex) m - in distance p1 p2 - -applyCompatible :: (t -> Mesh a -> Maybe (Mesh a)) -> (Mesh a -> [t]) -> Mesh a -> Mesh a -> (Mesh a, Mesh a) -applyCompatible _fn _vs m1 m2 - | _meshIdCounter m1 /= _meshIdCounter m2 = error "invalid ID counter" -applyCompatible fn vs m1 m2 = worker m1 m2 (vs m1) - where - worker l r [] = (l,r) - worker l r (eid:rest) = - case (,) <$> fn eid l <*> fn eid r of - Nothing -> worker l r rest - Just (l', r') -> worker l' r' rest - -delaunayFlip :: Mesh (V2 Double) -> Mesh (V2 Double) -> (Mesh (V2 Double), Mesh (V2 Double)) -delaunayFlip = applyCompatible delaunayFlip' internalEdges - -delaunayFlip' :: EdgeId -> Mesh (V2 Double) -> Maybe (Mesh (V2 Double)) -delaunayFlip' eid m = - let edge = meshGetEdge eid m - twin = meshGetEdge (edge^.edgeTwin) m - f1 = edge^.edgeFace - f2 = twin^.edgeFace - beforeAng = min (faceMinAngle f1 m) (faceMinAngle f2 m) - ((f1',f2'), mAfter) = runState (flipEdge edge) m - afterAng = min (faceMinAngle f1' mAfter) (faceMinAngle f2' mAfter) - in - if (afterAng < beforeAng) || f1' == f1 - then Nothing - else Just mAfter - -splitInternalEdges :: Mesh (V2 Double) -> Mesh (V2 Double) -> (Mesh (V2 Double), Mesh (V2 Double)) -splitInternalEdges = applyCompatible splitInternalEdge internalEdges - -splitInternalEdge :: EdgeId -> Mesh (V2 Double) -> Maybe (Mesh (V2 Double)) -splitInternalEdge eid m = evalState worker m - where - edgeFaces edge = do - twin <- getEdge (edge^.edgeTwin) - return (edge^.edgeFace, twin^.edgeFace) - worker = do - edge <- getEdge eid - twin <- getEdge (edge^.edgeTwin) - v0 <- _vertexPosition <$> requireVertex (edge^.edgeVertex) - v1 <- _vertexPosition <$> requireVertex (twin^.edgeVertex) - let middle = lerp 0.5 v0 v1 - (f1,f2) <- edgeFaces edge - mBefore <- get - let beforeAng = min (faceMinAngle f1 mBefore) (faceMinAngle f2 mBefore) - (f3,f4,f5,f6) <- splitTriangle middle eid - mAfter <- get - let afterAng = minimum - [ faceMinAngle f3 mAfter - , faceMinAngle f4 mAfter - , faceMinAngle f5 mAfter - , faceMinAngle f6 mAfter ] - return () - if (afterAng < beforeAng) - then return Nothing - else return (Just mAfter) - -splitLongestEdge :: Mesh (V2 Double) -> Mesh (V2 Double) -> (Mesh (V2 Double), Mesh (V2 Double)) -splitLongestEdge m1 m2 = - (splitInternalEdgeForced longest m1, splitInternalEdgeForced longest m2) - where - longest = longestEdge m1 m2 - -splitInternalEdgeForced :: EdgeId -> Mesh (V2 Double) -> Mesh (V2 Double) -splitInternalEdgeForced eid m = execState worker m - where - worker = do - edge <- getEdge eid - twin <- getEdge (edge^.edgeTwin) - v0 <- _vertexPosition <$> requireVertex (edge^.edgeVertex) - v1 <- _vertexPosition <$> requireVertex (twin^.edgeVertex) - let middle = lerp 0.5 v0 v1 - splitTriangle middle eid - -splitOuterEdges :: Mesh (V2 Double) -> Mesh (V2 Double) -> (Mesh (V2 Double), Mesh (V2 Double)) -splitOuterEdges = applyCompatible splitOuterEdge outerEdges - -splitOuterEdge :: EdgeId -> Mesh (V2 Double) -> Maybe (Mesh (V2 Double)) -splitOuterEdge eid m = evalState worker m - where - worker = do - edge <- getEdge eid - twin <- getEdge (edge^.edgeTwin) - v0 <- _vertexPosition <$> requireVertex (edge^.edgeVertex) - v1 <- _vertexPosition <$> requireVertex (twin^.edgeVertex) - let middle = lerp 0.5 v0 v1 - let f1 = twin^.edgeFace - mBefore <- get - let beforeAng = faceMinAngle f1 mBefore - (f2,f3) <- splitOuterTriangle middle eid - mAfter <- get - let afterAng = minimum - [ faceMinAngle f2 mAfter - , faceMinAngle f3 mAfter ] - if (afterAng < beforeAng) - then return Nothing - else return (Just mAfter) - -renderMesh :: Double -> Mesh (V2 Double) -> SVG -renderMesh radius m = mkGroup - [ mkGroup - [ withStrokeColor "black" $ - mkLine (x1, y1) (x2, y2) - | edge <- M.elems (_meshEdges m) - , _edgeFace edge /= _meshOuterFace m - , let twin = meshGetEdge (edge ^. edgeTwin) m - , let V2 x1 y1 = _vertexPosition (meshGetVertex (_edgeVertex edge) m) - V2 x2 y2 = _vertexPosition (meshGetVertex (_edgeVertex twin) m) - ] - -- , mkGroup - -- [ mkLinePathClosed - -- [ - -- | - -- ] [(Double, Double)] -> Tree - -- | face <- M.elems _meshFaces - -- ] - , mkGroup - [ translate x y $ withFillColor "red" $ mkCircle radius - | vertex <- M.elems (_meshVertices m) - , let V2 x y = _vertexPosition vertex - ] - ] - -renderMeshEdges :: Mesh (V2 Double) -> SVG -renderMeshEdges mesh@Mesh {..} = mkGroup - [ mkGroup - [ mkGroup - [ withStrokeColorPixel (promotePixel $ viridis $ ang/pi) $ - mkLine (x1, y1) (x2, y2) - ] - | edge <- M.elems _meshEdges - , _edgeFace edge /= _meshOuterFace - , let twin = meshGetEdge (edge ^. edgeTwin) mesh - V2 x1 y1 = _vertexPosition (meshGetVertex (_edgeVertex edge) mesh) - V2 x2 y2 = _vertexPosition (meshGetVertex (_edgeVertex twin) mesh) - ang = meshEdgeAngle mesh (edge^.edgeId) - , ang/pi*180 < 2 - ] - ] - -renderMeshSimple :: Double -> Mesh (V2 Double) -> SVG -renderMeshSimple radius Mesh {..} = mkGroup - [ mkGroup - [ translate x y $ mkGroup - [ withFillColor "red" $ mkCircle 0.01 - , scaleToHeight (radius*2) $ center $ latex $ T.pack $ show (_vertexId vertex) ] - | vertex <- M.elems _meshVertices - , let V2 x y = _vertexPosition vertex - ] - ] - -renderMeshColored :: Mesh (V2 Double) -> SVG -renderMeshColored m@Mesh{..} = mkGroup - [ withFillColorPixel c $ mkLinePathClosed $ - [ (x,y) | V2 x y <- facePositions fid m ] - | fid <- M.keys _meshFaces - , let ang = faceMinAngle fid m - bestAng = pi/3 - score = ang/bestAng - c = promotePixel $ viridis score - ] --- facePositions :: FaceId -> Mesh a -> [a] --- faceMinAngle :: FaceId -> Mesh (V2 Double) -> Double - -renderMeshStats :: Mesh (V2 Double) -> SVG -renderMeshStats mesh = mkGroup - [ latex $ T.pack $ printf "Min: %.1f" (minAng/pi*180) - , translate 0 (sep*1) $ - latex $ T.pack $ printf "Mean: %.1f" (meanAngle/pi*180) - , translate 0 (sep*2) $ - latex $ T.pack $ printf "Avg: %.1f" (avgAngle/pi*180) - , translate 0 (sep*3) $ - latex $ T.pack $ printf "Max: %.1f" (maxAngle/pi*180) - ] - where - sep = -1 - angs = meshAngles mesh - minAng = minimum angs - meanAngle = L.sort angs !! (length angs `div` 2) - avgAngle = sum angs / (fromIntegral $ length angs) - maxAngle = maximum angs - -toRigidMesh :: Mesh (V2 Double) -> Mesh (V2 Double) -> Rigid.Mesh -toRigidMesh meshA meshB = Rigid.Mesh - { meshPointsA = pointsA - , meshPointsB = pointsB - , meshOutline = outline - , meshTriangles = trigs } - where - pointsA = V.fromList $ map _vertexPosition $ M.elems (meshA^.meshVertices) - pointsB = V.fromList $ map _vertexPosition $ M.elems (meshB^.meshVertices) - outline = V.fromList - [ fromJust (V.elemIndex v pointsA) - | eid <- faceEdges (meshA^.meshOuterFace) meshA - , let edge = meshGetEdge eid meshA - v = _vertexPosition (meshGetVertex (edge^.edgeVertex) meshA) - ] - trigs = V.fromList - [ (aIdx, bIdx, cIdx) - | fid <- M.keys (meshA^.meshFaces) - , fid /= (meshA^.meshOuterFace) - , let edges = map (`meshGetEdge` meshA) (faceEdges fid meshA) - vs = map (`meshGetVertex` meshA) $ map _edgeVertex edges - ps = map _vertexPosition vs - [aIdx, bIdx, cIdx] = map (fromJust . (`V.elemIndex` pointsA)) ps - p = mkPolygon (V.fromList $ map (fmap realToFrac) ps) - , pIsSimple p || error "invalid polygon" - ] - diff --git a/src/Reanimate/Math/EarClip.hs b/src/Reanimate/Math/EarClip.hs deleted file mode 100644 --- a/src/Reanimate/Math/EarClip.hs +++ /dev/null @@ -1,119 +0,0 @@ -module Reanimate.Math.EarClip - ( earCut - , earCut' - , earClip - , earClip' - , isEarCorner - ) where - -import Data.List -import qualified Data.Set as Set -import Data.Tuple - -import Reanimate.Math.Common -import Reanimate.Math.Triangulate - -import qualified Data.Vector as V -import qualified Geometry.Earcut as C -import Linear.V2 - --- import Debug.Trace - -earCut :: (Real a) => Ring a -> Triangulation -earCut = last . earCut' - -earCut' :: (Real a) => Ring a -> [Triangulation] -earCut' p = - map (edgesToTriangulation (ringSize p)) $ inits $ nub - [ if fst pair < snd pair then pair else swap pair - | (a,b,c) <- V.toList (C.earcut lst) - , pair <- [(a,b), (a,c), (b,c)] - , fst pair /= (snd pair+1) `mod` ringSize p - , fst pair /= (snd pair-1) `mod` ringSize p - ] - where - lst = [ (x,y) | V2 x y <- V.toList $ V.map (fmap realToFrac) $ ringUnpack p ] - --- Triangulation by ear clipping. O(n^2) -earClip :: (Fractional a, Ord a) => Ring a -> Triangulation -earClip = last . earClip' - -earClip' :: (Fractional a, Ord a) => Ring a -> [Triangulation] -earClip' p = map (edgesToTriangulation $ ringSize p) $ inits $ - let ears = Set.fromList [ i - | i <- elts - , isEarCorner p elts (mod (i-1) n) i (mod (i+1) n) ] - in worker ears (mkQueue elts) - where - n = ringSize p - elts = [0 .. n-1] - -- worker :: Set.Set Int -> PolyQueue Int -> [(P,P)] - worker _ears queue | isSimpleQ queue = [] - worker ears queue - | x `Set.member` ears = - let dq = dropQ queue - v0 = prevQ 1 queue - v1 = prevQ 0 queue - v3 = peekQ dq - v4 = peekQ (nextQ dq) - e1 = if isEarCorner p (toList dq) v0 v1 v3 - then Set.insert v1 ears - else Set.delete v1 ears - e2 = if isEarCorner p (toList dq) v1 v3 v4 - then Set.insert v3 e1 - else Set.delete v3 e1 - in (v1,v3) : worker e2 dq - | otherwise = worker ears (nextQ queue) - where - x = peekQ queue - -data PolyQueue a = PolyQueue a [a] [a] [a] - --- sizeQ :: PolyQueue a -> Int --- sizeQ (PolyQueue _ a b _) = 1 + length a + length b - -mkQueue :: [a] -> PolyQueue a -mkQueue (x:xs) = PolyQueue x xs [] (reverse (x:xs)) -mkQueue [] = error "mkQueue: empty" - -toList :: PolyQueue a -> [a] -toList (PolyQueue e a b _) = e : a ++ b - -isSimpleQ :: PolyQueue a -> Bool -isSimpleQ (PolyQueue _ xs ys _) = - case xs ++ ys of - [_,_] -> True - _ -> False - -peekQ :: PolyQueue a -> a -peekQ (PolyQueue e _ _ _) = e - -nextQ :: PolyQueue a -> PolyQueue a -nextQ (PolyQueue x [] ys p) = - let (y:xs) = reverse (x:ys) - in PolyQueue y xs [] (x:p) -nextQ (PolyQueue x (y:xs) ys p) = PolyQueue y xs (x:ys) (x:p) - -dropQ :: PolyQueue a -> PolyQueue a -dropQ (PolyQueue _ [] ys p) = - let (x:xs) = reverse ys - in PolyQueue x xs [] p -dropQ (PolyQueue _ (x:xs) ys p) = PolyQueue x xs ys p - -prevQ :: Int -> PolyQueue a -> a -prevQ nth (PolyQueue _ _ _ p) = p!!nth - --- O(n) --- Returns true if ac can be cut from polygon. That is, true if 'b' is an ear. --- isEarCorner polygon a b c = True iff ac can be cut -isEarCorner :: (Fractional a, Ord a) => Ring a -> [Int] -> Int -> Int -> Int -> Bool -isEarCorner p polygon a b c = - isLeftTurn aP bP cP && - -- If it is a right turn then the line ac will be outside the polygon - and [ not (isInside aP bP cP (ringAccess p k)) - | k <- polygon, k /= a && k /= b && k /= c - ] - where - aP = ringAccess p a - bP = ringAccess p b - cP = ringAccess p c diff --git a/src/Reanimate/Math/Polygon.hs b/src/Reanimate/Math/Polygon.hs --- a/src/Reanimate/Math/Polygon.hs +++ b/src/Reanimate/Math/Polygon.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_HADDOCK hide #-} module Reanimate.Math.Polygon ( APolygon(..) , Polygon @@ -5,6 +8,7 @@ , P , mkPolygon -- :: (Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a , mkPolygonFromRing -- :: (Fractional a, Ord a) => Ring a -> APolygon a + , castPolygon -- :: (Real a, Fractional b, Ord a) => APolygon a -> APolygon b , pParent -- :: Polygon -> Int -> Int -> Int , pSetOffset -- :: APolygon a -> Int -> APolygon a , pAdjustOffset -- :: APolygon a -> Int -> APolygon a @@ -33,7 +37,10 @@ , pCircumference -- :: (Real a, Fractional a) => APolygon a -> a , pCircumference' -- :: (Real a, Fractional a) => APolygon a -> Double , pAddPoints -- :: Int -> Polygon -> Polygon + , pAddPointsRestricted -- :: [Int] -> Int -> Polygon -> Polygon + , pAddPointsBetween -- :: (Fractional a, Ord a, Real a) => (Int, Int) -> Int -> APolygon a -> APolygon a , pRayIntersect -- :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) + , pOverlap -- :: Polygon -> Polygon -> Polygon , pCuts -- :: Polygon -> [(Polygon,Polygon)] , pCutEqual -- :: Polygon -> (Polygon, Polygon) -- * Triangulation @@ -77,6 +84,7 @@ , pCopy -- :: Polygon -> Polygon , pGenerate -- :: [(Double, Double)] -> Polygon , pUnGenerate -- :: Polygon -> [(Double, Double)] + , Epsilon ) where -- import Control.Exception @@ -91,7 +99,7 @@ import Linear.V2 import Linear.Vector import Reanimate.Math.Common -import Reanimate.Math.EarClip +-- import Reanimate.Math.EarClip import Reanimate.Math.SSSP import Reanimate.Math.Triangulate @@ -119,14 +127,16 @@ instance Hashable a => Hashable (APolygon a) where hashWithSalt s p = V.foldl' hashWithSalt s (polygonPoints p) -instance (Real a, Fractional a, Ord a, Serialize a) => Serialize (APolygon a) where +instance (PolyCtx a, Serialize a) => Serialize (APolygon a) where put = put . V.toList . polygonPoints get = mkPolygon . V.fromList <$> get pRing :: APolygon a -> Ring a pRing = ringPack . polygonPoints -mkPolygon :: (Real a, Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a +type PolyCtx a = (Real a, Fractional a, Epsilon a) + +mkPolygon :: PolyCtx a => V.Vector (V2 a) -> APolygon a mkPolygon points = Polygon { polygonPoints = points , polygonOffset = 0 @@ -136,17 +146,20 @@ where n = length points ring = ringPack points - trig = earCut ring + trig = triangulate ring -- earClip ring -mkPolygonFromRing :: (Real a, Fractional a, Ord a) => Ring a -> APolygon a +castPolygon :: (PolyCtx a, PolyCtx b) => APolygon a -> APolygon b +castPolygon = mkPolygon . V.map (fmap realToFrac) . polygonPoints + +mkPolygonFromRing :: PolyCtx a => Ring a -> APolygon a mkPolygonFromRing = mkPolygon . ringUnpack pUnsafeMap :: (Ring a -> Ring a) -> APolygon a -> APolygon a pUnsafeMap fn p = p{ polygonPoints = ringUnpack (fn (pRing p)) } -- pParent p i j = shortest-path parent from j to i -pParent :: Polygon -> Int -> Int -> Int +pParent :: APolygon a -> Int -> Int -> Int pParent p i j = (sTree V.! mod (j + polygonOffset p) n - polygonOffset p) `mod` n where @@ -164,6 +177,7 @@ pAdjustOffset p offset = p { polygonOffset = (polygonOffset p + offset) `mod` pSize p } +{-# INLINE pSize #-} pSize :: APolygon a -> Int pSize = length . polygonPoints @@ -316,9 +330,10 @@ -- findSmallest = minimumBy (comparing area2X) -- shareEdge p1 p2 = - +{-# INLINE pAccess #-} pAccess :: APolygon a -> Int -> V2 a -pAccess p i = polygonPoints p V.! ((polygonOffset p + i) `mod` pSize p) +pAccess p i = -- polygonPoints p V.! ((polygonOffset p + i) `mod` pSize p) + polygonPoints p `V.unsafeIndex` ((polygonOffset p + i) `mod` pSize p) triangle :: Polygon triangle = mkPolygon $ V.fromList [V2 1 1, V2 0 0, V2 2 0] @@ -503,10 +518,10 @@ in lerp 0.99999 this prev else pAccess p n -pCycles :: Polygon -> [Polygon] +pCycles :: APolygon a -> [APolygon a] pCycles p = map (pAdjustOffset p) [0 .. pSize p-1] -pCycle :: (Real a, Fractional a, Ord a) => APolygon a -> Double -> APolygon a +pCycle :: PolyCtx a => APolygon a -> Double -> APolygon a pCycle p 0 = p pCycle p t = mkPolygon $ worker 0 0 where @@ -526,7 +541,7 @@ len = pCircumference' p limit = t * len -pCentroid :: Polygon -> V2 Rational +pCentroid :: Fractional a => APolygon a -> V2 a pCentroid p = V2 cx cy where a = pArea p @@ -535,13 +550,29 @@ fnX (V2 x y) (V2 x' y') = (x+x')*(x*y' - x'*y) fnY (V2 x y) (V2 x' y') = (y+y')*(x*y' - x'*y) -pMapEdges :: (V2 Rational -> V2 Rational -> a) -> Polygon -> V.Vector a -pMapEdges fn p = V.generate (pSize p) $ \i -> - fn (pAccess p i) (pAccess p $ i+1) +{-# INLINE pMapEdges #-} +pMapEdges :: (V2 a -> V2 a -> b) -> APolygon a -> V.Vector b +pMapEdges fn p = V.generate n $ \i -> + if i == n-1 + then fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0) + else fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1)) + where + n = pSize p + arr = polygonPoints p -pArea :: Polygon -> Rational +{-# SPECIALIZE pArea :: APolygon Double -> Double #-} +{-# SPECIALIZE pArea :: APolygon Rational -> Rational #-} +pArea :: (Fractional a) => APolygon a -> a pArea p = - 0.5 * V.sum (pMapEdges (\(V2 x y) (V2 x' y') -> x*y' - x'*y) p) + -- 0.5 * V.sum (pMapEdges (\(V2 x y) (V2 x' y') -> x*y' - x'*y) p) + 0.5 * worker 0 0 + where + fn (V2 x y) (V2 x' y') = x*y' - x'*y + arr = polygonPoints p + worker !acc i + | i == pSize p - 1 = acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0) + | otherwise = + worker (acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))) (i+1) pCircumference :: (Real a, Fractional a) => APolygon a -> a pCircumference p = sum @@ -555,7 +586,7 @@ -- Add points by splitting the longest lines in half repeatedly. -pAddPoints :: Int -> Polygon -> Polygon +pAddPoints :: PolyCtx a => Int -> APolygon a -> APolygon a pAddPoints n p | n <= 0 = p pAddPoints n p = pAddPoints (n-1) $ mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1] @@ -572,6 +603,45 @@ distSquared (pAccess p a) (pAccess p $ a+1) `compare` distSquared (pAccess p b) (pAccess p $ b+1) +pAddPointsRestricted :: PolyCtx a => [(V2 a, V2 a)] -> Int -> APolygon a -> APolygon a +pAddPointsRestricted _immutableEdges n p | n <= 0 = p +pAddPointsRestricted immutableEdges n p = pAddPointsRestricted immutableEdges (n-1) $ + mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1] + where + isImmutable idx = + (pAccess p idx, pAccess p $ idx+1) `elem` immutableEdges || + (pAccess p $ idx+1, pAccess p idx) `elem` immutableEdges + worker idx + | idx == longestEdge && not (isImmutable idx) = + let start = pAccess p idx + end = pAccess p $ idx+1 + middle = lerp 0.5 end start + in [start, middle] + | otherwise = [pAccess p idx] + longestEdge = maximumBy cmpLength [0 .. pSize p-1] + cmpLength a _ | isImmutable a = LT + cmpLength _ b | isImmutable b = GT + cmpLength a b = + distSquared (pAccess p a) (pAccess p $ a+1) `compare` + distSquared (pAccess p b) (pAccess p $ b+1) + +pAddPointsBetween :: PolyCtx a => (Int, Int) -> Int -> APolygon a -> APolygon a +pAddPointsBetween _ n p | n <= 0 = p +pAddPointsBetween (i,l) n p = pAddPointsBetween (i,l+1) (n-1) $ + mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1] + where + worker idx + | idx == longestEdge = + let start = pAccess p idx + end = pAccess p $ idx+1 + middle = lerp 0.5 end start + in [start, middle] + | otherwise = [pAccess p idx] + longestEdge = maximumBy cmpLength [i .. i+l-1] + cmpLength a b = + distSquared (pAccess p a) (pAccess p $ a+1) `compare` + distSquared (pAccess p b) (pAccess p $ b+1) + -- addPoints :: Int -> Polygon -> Polygon -- addPoints n p = mkPolygon $ V.fromList $ worker n 0 (map (pAccess p) [0..s]) -- where @@ -603,11 +673,11 @@ fn (V2 x1 y1) (V2 x2 y2) = (x2-x1)*(y2+y1) {-# INLINE pRayIntersect #-} -pRayIntersect :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational) +pRayIntersect :: PolyCtx a => APolygon a -> (Int, Int) -> (Int,Int) -> Maybe (V2 a) pRayIntersect p (a,b) (c,d) = rayIntersect (pAccess p a, pAccess p b) (pAccess p c, pAccess p d) -pCuts :: Polygon -> [(Polygon,Polygon)] +pCuts :: (Real a, Fractional a, Epsilon a) => APolygon a -> [(APolygon a,APolygon a)] pCuts p = [ pCutAt (pAdjustOffset p i) (j-i) | i <- [0 .. pSize p-1 ] @@ -615,26 +685,41 @@ , (j+1) `mod` pSize p /= i , pParent p i j == i ] -pCutEqual :: Polygon -> (Polygon, Polygon) +pCutEqual :: PolyCtx a => APolygon a -> (APolygon a, APolygon a) pCutEqual p = fromMaybe (p,p) $ listToMaybe $ sortOn f $ pCuts p where f (a,b) = abs (pArea a - pArea b) -- FIXME: This should be more efficient -pCutAt :: Polygon -> Int -> (Polygon, Polygon) +pCutAt :: PolyCtx a => APolygon a -> Int -> (APolygon a, APolygon a) pCutAt p i = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right) where n = pSize p left = map (pAccess p) [0 .. i] right = map (pAccess p) (0:[i..n-1]) - +pOverlap :: PolyCtx a => APolygon a -> APolygon a -> APolygon a +pOverlap a b = mkPolygon $ V.fromList $ clearDups $ concatMap edgeIntersect [0 .. pSize a-1] + where + clearDups (x:y:xs) + | x == y = clearDups (y:xs) + | otherwise = x : clearDups (y:xs) + clearDups xs = xs + edgeIntersect edge = + sortOn (distSquared (pAccess a edge)) $ catMaybes + [ lineIntersect (aP, aP') (bP, bP') + | i <- [0 .. pSize b-1] + , let aP = pAccess a edge + aP' = pAccess a (edge+1) + bP = pAccess b i + bP' = pAccess b (i+1) + ] --------------------------------------------------------- -- SSSP visibility and SSSP windows -ssspVisibility :: Polygon -> Polygon +ssspVisibility :: PolyCtx a => APolygon a -> APolygon a ssspVisibility p = mkPolygon $ V.fromList $ clearDups $ go [0 .. pSize p-1] -- ([root..pSize p-1] ++ [0 .. root-1]) where diff --git a/src/Reanimate/Math/Render.hs b/src/Reanimate/Math/Render.hs deleted file mode 100644 --- a/src/Reanimate/Math/Render.hs +++ /dev/null @@ -1,231 +0,0 @@ -module Reanimate.Math.Render where - -import Codec.Picture.Types -import Control.Monad --- import Data.List -import qualified Data.Text as T -import qualified Data.Vector as V -import Linear.V2 -import Reanimate.Animation -import Reanimate.ColorMap --- import Reanimate.Constants -import Reanimate.LaTeX --- import Reanimate.Math.Compatible --- import Reanimate.Math.EarClip -import Reanimate.Math.Polygon -import Reanimate.Math.Common -import Reanimate.Math.SSSP -import Reanimate.Math.Triangulate --- import Reanimate.Math.Visibility -import Reanimate.Scene -import Reanimate.Svg - - --- drawVisibility :: Polygon -> Animation --- drawVisibility p' = mkAnimation 5 $ \t -> --- let p = cyclePolygon p' (t::Double) in --- centerUsing (polygonShape p) $ --- mkGroup --- [ withFillColor "grey" $ polygonShape p --- , withFillColor "grey" $ polygonDots p --- , withFillColor "white" $ mkLinePathClosed --- [ (x,y) | V2 x y <- visibility (map (fmap realToFrac) $ V.toList $ polygonPoints p) ] --- , let V2 x y = fmap realToFrac $ pAccess p 0 in --- translate x y $ withFillColor "red" $ mkCircle 0.1 --- -- , withFillColor "blue" $ latex $ T.pack $ show (t) --- ] - --- drawSSSPVisibility :: Polygon -> Animation --- drawSSSPVisibility p' = mkAnimation 5 $ \t -> --- let p = pSetOffset p' (round $ t*(fromIntegral $ pSize p'-1)) --- vis = ssspVisibility p in --- centerUsing (polygonShape p) $ --- mkGroup --- [ withFillColor "grey" $ polygonShape p --- -- , withFillColor "grey" $ polygonDots p --- -- , withFillColor "white" $ polygonShape vis --- , let V2 x y = fmap realToFrac $ pAccess p 0 in --- translate x y $ withFillColor "red" $ mkCircle 0.1 --- -- , withFillColor "blue" $ latex $ T.pack $ show (t) --- ] - --- drawSSSPVisibilityFast :: Polygon -> Animation --- drawSSSPVisibilityFast p' = mkAnimation 5 $ \t -> --- let root = min (pSize p-1) $ (floor $ t*(fromIntegral $ pSize p)) --- p = pSetOffset p' root --- vis = ssspVisibility p in --- -- centerUsing (polygonShape p) $ --- mkGroup --- [ withFillColor "grey" $ polygonShape p --- , withFillColor "white" $ polygonShape vis --- , withFillColor "grey" $ polygonNumDots p --- , let V2 x y = fmap realToFrac $ pAccess p 0 in --- translate x y $ withFillColor "red" $ mkCircle 0.09 --- -- , withFillColor "blue" $ latex $ T.pack $ show (t) --- ] - --- drawCompatible :: Polygon -> Polygon -> Animation --- drawCompatible a b = sceneAnimation $ do --- newSpriteSVG $ translate (-3) 0 $ mkGroup --- [ withFillColor "grey" $ polygonShape a --- , withFillColor "grey" $ polygonNumDots a --- ] --- newSpriteSVG $ translate (3) 0 $ mkGroup --- [ withFillColor "grey" $ polygonShape b --- , withFillColor "grey" $ polygonNumDots b --- ] --- let compat = compatiblyTriangulateP a b --- forM_ compat $ \(l, r) -> do --- fork $ play $ staticFrame 1 $ --- translate (-3) 0 $ withStrokeColor "white" $ withStrokeWidth (defaultStrokeWidth*0.2) $ --- withFillOpacity 0 $ polygonShape l --- fork $ play $ staticFrame 1 $ --- translate (3) 0 $ withStrokeColor "white" $ withStrokeWidth (defaultStrokeWidth*0.2) $ --- withFillOpacity 0 $ polygonShape r - --- drawWindow :: Polygon -> SVG --- drawWindow p = --- let mWins = ssspWindows p --- in --- mkGroup --- [ mkGroup --- [ mkLine (x1,y1) (x2,y2) --- | (a,b) <- mWins --- , let V2 x1 y1 = realToFrac <$> a --- V2 x2 y2 = realToFrac <$> b --- ] --- ] - --- drawWindowOverlap :: Polygon -> Int -> Int -> SVG --- drawWindowOverlap p a b = --- let aWins = ssspWindows (modOffset p a) --- bWins = ssspWindows (modOffset p b) --- in --- mkGroup --- [ mkGroup $ --- [ withStrokeColor "green" $mkGroup --- [ mkLine (x1,y1) (x2,y2) --- , mkLine (x1',y1') (x2',y2') ] --- | (a,b) <- aWins --- , (i,j) <- bWins --- , a == i || a == j || b == i || b == j --- , not (sort [a,b] == sort [i,j]) --- , let V2 x1 y1 = realToFrac <$> a --- V2 x2 y2 = realToFrac <$> b --- V2 x1' y1' = realToFrac <$> i --- V2 x2' y2' = realToFrac <$> j --- ] --- ] - -polygonShape :: Polygon -> SVG -polygonShape p = mkLinePathClosed - [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList (polygonPoints p) ] - -polygonDots :: Polygon -> SVG -polygonDots p = mkGroup - [ translate x y $ mkCircle 0.1 | V2 x y <- V.toList $ V.map (fmap realToFrac) $ polygonPoints p ] - -polygonNumDots :: Polygon -> SVG -polygonNumDots p = mkGroup $ reverse - [ mkGroup - [ colored n $ - translate x y $ mkCircle circR - , withFillColor "black" $ - translate x y $ ppNum n ] - | n <- [0..pSize p-1] - , let V2 x y = realToFrac <$> pAccess p n ] - where - circR = 0.05 - colored n = - let c = promotePixel $ turbo (fromIntegral (n+2) / fromIntegral (pSize p-1+2)) - in withStrokeColorPixel c . withFillColorPixel c - ppNum n = - scaleToSize (circR*1.7) (circR*1.5) $ - center $ latex $ T.pack $ "\\texttt{" ++ show n ++ "}" - --- drawSSSP :: Polygon -> (Polygon -> SSSP) -> Animation --- drawSSSP p gen = mkAnimation 5 $ \t -> centerUsing outline $ --- let p' = cyclePolygons p !! (round $ t*(fromIntegral $ pSize p-1)) in --- mkGroup --- [ outline --- , renderSSSP p' (gen p') --- , withFillColor "grey" $ polygonNumDots $ p' --- ] --- where --- outline = --- withFillColor "grey" $ mkLinePathClosed --- [ (x,y) | V2 x y <- map (fmap realToFrac) (V.toList (polygonPoints p) ++ [pAccess p 0]) ] - -drawSSSP :: Polygon -> Animation -drawSSSP p = mkAnimation 5 $ \t -> centerUsing (polygonShape p) $ - let root = round $ t*fromIntegral (pSize p-1) - sTree = polygonSSSP p V.! root in - mkGroup - [ polygonShape p - , renderSSSP p sTree - , polygonNumDots p - ] - --- Inline such that 'trees' is only computed once. -{-# INLINE drawSSSPNaive #-} -drawSSSPNaive :: Polygon -> Animation -drawSSSPNaive p = mkAnimation 5 $ \t -> centerUsing (polygonShape p) $ - let root = round $ t*fromIntegral (pSize p-1) in - mkGroup - [ polygonShape p - , renderSSSP p (trees !! root) - , polygonNumDots p - ] - where - trees = - [ naive $ pRing $ pCopy $ pSetOffset p i - | i <- [0 .. pSize p-1]] - -renderSSSP :: Polygon -> SSSP -> SVG -renderSSSP p s = withFillOpacity 0 $ withStrokeColor "white" $ mkGroup - [ mkLinePath (lineFrom i) - | i <- [0 .. length s-1] ] - where - lineFrom i = - let V2 ax ay = realToFrac <$> pAccess p i - next = (s V.! i) - in (ax,ay) : if next == i then [] else lineFrom next - -drawTriangulation :: Polygon -> (Ring Rational -> [Triangulation]) -> Animation -drawTriangulation p gen = sceneAnimation $ - forM_ (gen $ pRing p) $ \t -> play $ staticFrame 1 $ renderTriangulation p t - -renderTriangulation :: Polygon -> Triangulation -> SVG -renderTriangulation p t = center $ mkGroup - [ withFillColor "grey" $ polygonShape p - , withStrokeColor "white" $ mkGroup $ concat - [ [ mkLine (ax,ay) (bx,by) ] - | i <- [0..pSize p-1] - , y <- t V.! i - , let V2 ax ay = realToFrac <$> rawAccess i - V2 bx by = realToFrac <$> rawAccess y - ] - , withFillColor "grey" $ polygonNumDots p - ] - where - rawAccess x = polygonPoints p V.! x - -renderDual :: Ring Rational -> Dual -> SVG -renderDual ring d = case d of - Dual (a,b,c) l r -> mkGroup - [ withFillColor "blue" $ mkTrig a b c - , worker c a l - , worker b c r - ] - where - mkTrig a b c = - let V2 x1 y1 = realToFrac <$> ringAccess ring a - V2 x2 y2 = realToFrac <$> ringAccess ring b - V2 x3 y3 = realToFrac <$> ringAccess ring c - in mkLinePathClosed [ (x1, y1), (x2,y2), (x3,y3) ] - worker _p1 _p2 EmptyDual = mkGroup [] - worker p1 p2 (NodeDual x l r) = mkGroup - [ mkTrig p1 p2 x - , worker x p2 l - , worker p1 x r - ] diff --git a/src/Reanimate/Math/SSSP.hs b/src/Reanimate/Math/SSSP.hs --- a/src/Reanimate/Math/SSSP.hs +++ b/src/Reanimate/Math/SSSP.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide #-} module Reanimate.Math.SSSP ( -- * Single-Source-Shortest-Path SSSP @@ -276,7 +277,7 @@ -- dualRoot (Dual (a,_,_) _ _) = a -- O(n*ln n), could be O(n) if I could figure out how to use fingertrees... -sssp :: (Fractional a, Ord a) => Ring a -> Dual -> SSSP +sssp :: (Fractional a, Ord a, Epsilon a) => Ring a -> Dual -> SSSP sssp p d = toSSSP $ case d of Dual (a,b,c) l r -> diff --git a/src/Reanimate/Math/Smooth.hs b/src/Reanimate/Math/Smooth.hs deleted file mode 100644 --- a/src/Reanimate/Math/Smooth.hs +++ /dev/null @@ -1,291 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Reanimate.Math.Smooth - ( steinerPoints - , renderMesh - , renderAMesh - , smoothMesh - , smoothStep - , angleSmooth - , meshMinAngle - , splitMeshEdges - ) -where - -import qualified Data.IntSet as ISet -import Control.Monad -import Control.Monad.ST -import Data.STRef -import Data.List -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV -import Linear.V2 -import Linear.Metric -import Linear.Vector -import Reanimate.Animation -import Reanimate.Constants -import Reanimate.Math.Common -import Reanimate.Math.Polygon -import Reanimate.Math.Render -import Reanimate.Math.Triangulate -import Reanimate.Morph.Rigid -import Reanimate.Svg - -steinerPoints :: Polygon -> [Polygon] -> [V2 Rational] -steinerPoints outerPolygon = concatMap - (V.toList . V.filter isSteiner . polygonPoints) - where isSteiner p = V.notElem p (polygonPoints outerPolygon) --- compatiblyTriangulateP :: Polygon -> Polygon -> [(Polygon, Polygon)] - -renderMesh :: Polygon -> [Polygon] -> SVG -renderMesh outerPolygon innerPolygons = mkGroup - [ mkGroup - [ withFillOpacity 1 - $ withStrokeWidth (defaultStrokeWidth * 0) - $ withStrokeColor "black" - $ withFillColor "lightgreen" - $ polygonShape p - | p <- innerPolygons - ] - , mkGroup - [ withFillColor "red" $ aroundCenter (scale 0.2) $ drawPoint - (realToFrac <$> p) - | p <- steiners - ] - ] - where steiners = steinerPoints outerPolygon innerPolygons - -renderAMesh :: Mesh -> SVG -renderAMesh m = mkGroup - [ translate (-1.5) 0 $ renderMesh - (mkPolygon outlineA) - [ mkPolygon $ V.fromList $ map (fmap realToFrac) - [pA V.! a, pA V.! b, pA V.! c] - | (a, b, c) <- V.toList (meshTriangles m) - ] - , translate (1.5) 0 $ renderMesh - (mkPolygon outlineB) - [ mkPolygon $ V.fromList $ map (fmap realToFrac) - [pB V.! a, pB V.! b, pB V.! c] - | (a, b, c) <- V.toList (meshTriangles m) - ] - ] - where - pA = meshPointsA m - pB = meshPointsB m - outlineA = V.map (\i -> realToFrac <$> meshPointsA m V.! i) (meshOutline m) - outlineB = V.map (\i -> realToFrac <$> meshPointsB m V.! i) (meshOutline m) - - -drawPoint :: V2 Double -> SVG -drawPoint (V2 x y) = translate x y $ mkCircle 0.1 - - --- Plot angles for a mesh. --- Plot min-angles for meshes as they are iteratively smoothed. - --- Smoothing algorithm: --- For each steiner point: --- Find desired position from each vertex, take average, update position. --- For each edge: --- Does flipping it increase min-angle in both meshes? --- If yes, do it. --- For long edges: --- Cut in half: --- Cut the two connected faces in half. --- all points --- steiner points --- - -{- -data Mesh = Mesh - { meshPointsA :: Vector P - , meshPointsB :: Vector P - , meshOutline :: Vector Int - -- , meshSteiner :: Vector Int - , meshTriangles :: Vector RelTrig } - --} -smoothMesh :: Mesh -> [Mesh] -smoothMesh m = runST $ do - trigs <- edgesToTriangulationM (length $ meshPointsA m) $ concat - [ [(a, b), (b, c), (c, a)] | (a, b, c) <- V.toList (meshTriangles m) ] - pA <- V.thaw $ V.map (fmap realToFrac) (meshPointsA m) - pB <- V.thaw $ V.map (fmap realToFrac) (meshPointsB m) - replicateM 120 $ do - smoothStep trigs pA steiner - smoothStep trigs pB steiner - newA <- V.freeze pA - newB <- V.freeze pB - return $ m { meshPointsA = newA, meshPointsB = newB } - where - steiner = V.fromList - [ i | i <- [0 .. length (meshPointsA m) - 1], V.notElem i (meshOutline m) ] - - -smoothStep - :: forall s - . V.MVector s [Int] - -> V.MVector s (V2 Double) - -> V.Vector Int - -> ST s () -smoothStep triangulation pts steiner = - forM_ [0 .. length steiner - 1] {-length steiner-1-} - $ \s_i -> do - let i = steiner V.! s_i - pt <- MV.read pts i - edges <- V.fromList <$> (sortEdges pt =<< MV.read triangulation i) - let angleBased = angleSmooth pt edges - laplacian = sum edges ^/ (fromIntegral $ length edges) -- laplacian - -- unsafeIOToST $ hPrint stderr (pt, edges, newX) - if isValidLocation pt edges angleBased - then MV.write pts i angleBased - else if isValidLocation pt edges laplacian - then MV.write pts i laplacian - else return () - where - sortEdges :: V2 Double -> [Int] -> ST s [V2 Double] - sortEdges pt edges = do - edgePoints <- mapM (MV.read pts) edges - return $ sortOn (dir pt) edgePoints - -- Direction from south of 'a', to 'a', to 'b'. - dir :: V2 Double -> V2 Double -> Double - dir a b = (atan2 (crossZ (V2 0 1) (b - a)) (dot (V2 0 1) (b - a))) - -angleSmooth :: V2 Double -> V.Vector (V2 Double) -> V2 Double -angleSmooth origin js = V.sum (V.generate n nth) ^/ V.sum (V.generate n factor) - where - n = length js - factor i = - let n_self = js V.! i - n_origin = origin - n_self - n_prev = js V.! mod (i - 1) n - n_self - n_next = js V.! mod (i + 1) n - n_self - a1 = acos (dot n_origin n_next / (norm n_origin * norm n_next)) - a2 = acos (dot n_origin n_prev / (norm n_origin * norm n_prev)) - alpha = a1 + a2 - in recip (alpha * alpha) - nth i = - let V2 x y = origin - n_self@(V2 x_0 y_0) = js V.! i - n_origin = origin - n_self - n_prev = js V.! mod (i - 1) n - n_self - n_next = js V.! mod (i + 1) n - n_self - a1 = acos (dot n_origin n_next / (norm n_origin * norm n_next)) - a2 = acos (dot n_origin n_prev / (norm n_origin * norm n_prev)) - alpha = a1 + a2 - b = (a2 - a1) / 2 - x' = x_0 + (x - x_0) * cos b - (y - y_0) * sin b - y' = y_0 + (x - x_0) * sin b + (y - y_0) * cos b - in V2 x' y' ^/ (alpha * alpha) - -isValidLocation :: V2 Double -> V.Vector (V2 Double) -> V2 Double -> Bool -isValidLocation origin edges newLoc = - or - [ isInside origin a b newLoc - | i <- [0 .. length edges - 1] - , let a = edges V.! i - b = edges V.! mod (i + 1) (length edges) - ] - && V.toList edges - == sortOn (dir newLoc) (V.toList edges) - && minAngle origin edges - < minAngle newLoc edges - where - dir :: V2 Double -> V2 Double -> Double - dir a b = (atan2 (crossZ (V2 0 1) (b - a)) (dot (V2 0 1) (b - a))) - -minAngle :: V2 Double -> V.Vector (V2 Double) -> Double -minAngle origin edges = minimum $ concat - [ [a1, a2, a3] - | i <- [0 .. length edges - 1] - , let a = edges V.! i - b = edges V.! mod (i + 1) (length edges) - (a1, a2, a3) = triangleAngles origin a b - ] - -meshMinAngle :: Mesh -> (Double, Double) -meshMinAngle m = - ( minimum $ concat - [ [a1, a2, a3] - | (a, b, c) <- V.toList (meshTriangles m) - , let (a1, a2, a3) = triangleAngles (meshPointsA m V.! a) - (meshPointsA m V.! b) - (meshPointsA m V.! c) - ] - , minimum $ concat - [ [a1, a2, a3] - | (a, b, c) <- V.toList (meshTriangles m) - , let (a1, a2, a3) = triangleAngles (meshPointsB m V.! a) - (meshPointsB m V.! b) - (meshPointsB m V.! c) - ] - ) - --- Smooth: --- Find all edges --- Sort counter-clockwise from 12 o'clock. (ie direction from south) --- Compute new position. --- Update position. - -{- -data Mesh = Mesh - { meshPointsA :: Vector P - , meshPointsB :: Vector P - , meshOutline :: Vector Int - -- , meshSteiner :: Vector Int - , meshTriangles :: Vector RelTrig } --} --- edge: a to b --- opposite points: c and d --- delete edge (a,b) --- insert point p --- insert edge (a,p) --- insert edge (p,b) --- insert edge (c,p) --- insert edge (p,d) -splitMeshEdges :: Double -> Mesh -> Mesh -splitMeshEdges maxLen mesh = runST $ do - t <- MV.replicate (n * 2) [] - forM_ (V.toList (meshTriangles mesh)) $ \(a, b, c) -> do - insertEdge t a b - insertEdge t b c - insertEdge t a c - forM_ [0 .. n - 1] $ \i -> MV.modify t (ISet.toList . ISet.fromList) i - triangulation <- V.freeze t - newPoints <- newSTRef [] - offset <- newSTRef n - forM_ [0 .. n - 1] $ \i -> forM_ (triangulation V.! i) $ \j -> - when (i < j) $ when (maxEdgeDistanceSquared i j > maxLen * maxLen) $ do - p <- readSTRef offset - writeSTRef offset (p + 1) - let (p1, p2) = splitEdge i j - modifySTRef newPoints ((p1, p2) :) - let [c, d] = (triangulation V.! i) `intersect` (triangulation V.! j) - deleteEdge t i j - insertEdge t i p - insertEdge t j p - insertEdge t c p - insertEdge t d p - -- Add 'newPoints' to mesh points - -- Convert edges to triangles - return undefined - where - splitEdge i j = - ( lerp 0.5 (meshPointsA mesh V.! i) (meshPointsA mesh V.! j) - , lerp 0.5 (meshPointsB mesh V.! i) (meshPointsB mesh V.! j) - ) - maxEdgeDistanceSquared i j = - distSquared (meshPointsA mesh V.! i) (meshPointsA mesh V.! j) - `max` distSquared (meshPointsB mesh V.! i) (meshPointsB mesh V.! j) - n = length (meshPointsA mesh) - deleteEdge v a b = do - MV.modify v (delete b) a - MV.modify v (delete a) b - insertEdge v a b = do - MV.modify v (b :) a - MV.modify v (a :) b - -- sortEdges :: V.Vector (V2 Double) -> V2 Double -> [Int] -> [Int] - -- sortEdges v pt = sortOn (\i -> dir pt (v V.! i)) - - -- dir :: V2 Double -> V2 Double -> Double - -- dir a b = (atan2 (crossZ (V2 0 1) (b - a)) (dot (V2 0 1) (b - a))) diff --git a/src/Reanimate/Math/Triangulate.hs b/src/Reanimate/Math/Triangulate.hs --- a/src/Reanimate/Math/Triangulate.hs +++ b/src/Reanimate/Math/Triangulate.hs @@ -1,18 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK hide #-} module Reanimate.Math.Triangulate ( Triangulation , edgesToTriangulation , edgesToTriangulationM , trianglesToTriangulation , trianglesToTriangulationM + , triangulate ) where +import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate') +import Algorithms.Geometry.PolygonTriangulation.Types +import Control.Lens import Control.Monad -import qualified Data.IntSet as ISet -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV import Control.Monad.ST - +import Data.Ext +import Data.Geometry.PlanarSubdivision (PolygonFaceData) +import Data.Geometry.Point +import Data.Geometry.Polygon +import qualified Data.IntSet as ISet +import qualified Data.PlaneGraph as Geo +import Data.Proxy +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import Linear.V2 +import Reanimate.Math.Common -- Max edges: n-2 -- Each edge is represented twice: 2n-4 -- Flat structure: @@ -52,3 +66,20 @@ MV.modify v (\x -> a : b : x) c forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i return v + + +triangulate :: forall a. (Fractional a, Ord a) => Ring a -> Triangulation +triangulate r = edgesToTriangulation (ringSize r) ds + where + ds :: [(Int,Int)] + ds = + [ (a^.Geo.vData, b^.Geo.vData) + | (d, Diagonal) <- V.toList (Geo.edges pg) + , let (a,b) = Geo.endPointData d pg ] + pg :: Geo.PlaneGraph () Int PolygonEdgeType PolygonFaceData a + pg = triangulate' Proxy p + p :: SimplePolygon Int a + p = fromPoints $ + [ Point2 x y :+ n + | (n,V2 x y) <- zip [0..] (V.toList (ringUnpack r)) ] + -- ringUnpack diff --git a/src/Reanimate/Math/Visibility.hs b/src/Reanimate/Math/Visibility.hs --- a/src/Reanimate/Math/Visibility.hs +++ b/src/Reanimate/Math/Visibility.hs @@ -20,7 +20,7 @@ -- v is visible: zsv is a left-turn -- v moves in front of the stack: s'sv is right turn -- v moves behind stack: -go :: (Ord a, Fractional a) => V2 a -> [V2 a] -> [V2 a] -> [V2 a] +go :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> [V2 a] -> [V2 a] go _z stack [] = stack go z stack@(s:s':_ss) (v:vs) | isLeftTurn z s v = {-trace ("Left: " ++ show (z,s,v)) $ -}go z (v:stack) vs @@ -34,7 +34,7 @@ v: 0,1 -} -rightTurn :: (Ord a, Fractional a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a] +rightTurn :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a] rightTurn z stack' v (v1:vs) | isRightTurn z v v1 = {-trace ("Double right: " ++ show (v,v1)) $ -}rightTurn z stack v1 vs | isLeftTurn z v v1 && isRightTurn (head stack') v v1 @@ -46,7 +46,7 @@ rightTurn z stack v [] = unwindStack z stack v [] -- scan forwards until edge intersects zv ray -scanc :: (Ord a, Fractional a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a] +scanc :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a] scanc z stack v (v1:v2:vs) | isBetween u (v1,v2) = -- trace ("Found: " ++ show (u, stack)) $ go z (u:stack) (v2:vs) @@ -56,7 +56,7 @@ Just u = rayIntersect (z,v) (v1,v2) scanc _z stack _v _vs = stack -unwindStack :: (Ord a, Fractional a) => V2 a -> [V2 a] -> V2 a -> t -> [V2 a] +unwindStack :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> V2 a -> t -> [V2 a] unwindStack z (s1:s2:ss) v vs | isRightTurn z s1 v && isLeftTurn z s2 v = (u:s2:ss) | otherwise = unwindStack z (s2:ss) v vs @@ -71,7 +71,7 @@ -- unwind stack -- 3. Find edge that crosses zv from left to right and is below v -fastForward :: (Ord a, Fractional a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a] +fastForward :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a] fastForward z stack v (v1:v2:vs) | isNothing i || not (isBetween u (v1, v2)) = {-trace ("FF past: " ++ show (z,v,v1,v2)) $ -}fastForward z stack v (v2:vs) | distSquared v u > distSquared z u = {-trace ("FF skip: " ++ show (z,v,v1,v2)) $ -}fastForward z stack v (v2:vs) diff --git a/src/Reanimate/Memo.hs b/src/Reanimate/Memo.hs --- a/src/Reanimate/Memo.hs +++ b/src/Reanimate/Memo.hs @@ -1,6 +1,23 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +With animations defined as SVG images over time, it is unfortunately +quite easy to write inefficient code where expensive expressions are +re-evaluated for every frame even if nothing has changed. This get +around this issue, this module defines a global key-value table that +can store expensive expressions such that they are evaluated only once. + +There is currently no way to clear values from the table and it is your +own responsibility to not consume all available memory. + +-} module Reanimate.Memo ( Key(..) , memo @@ -57,15 +74,20 @@ fn = Just . cacheMapInsert ks v . fromMaybe emptyCacheMap {-# NOINLINE cacheMap #-} +-- FIXME: There should be a way to clear the cache. cacheMap :: IORef CacheMap cacheMap = unsafePerformIO (newIORef emptyCacheMap) +-- | Keys can either by any boxed object with identity (to be compared with +-- StableNames) or a primitive type with an Eq instance. data Key = forall a. Key !a | forall a. (Typeable a, Eq a, Ord a) => KeyPrim !a fromKey :: Key -> IO DynamicName fromKey (Key val) = DynamicName <$> makeStableName val fromKey (KeyPrim val) = pure (DynamicKey val) +-- | Cache expensive value in global store. You must guarantee that the +-- key uniquely determines the value. memo :: Typeable a => [Key] -> a -> a memo !k v = unsafePerformIO $ do keys <- mapM fromKey k diff --git a/src/Reanimate/Morph/Common.hs b/src/Reanimate/Morph/Common.hs --- a/src/Reanimate/Morph/Common.hs +++ b/src/Reanimate/Morph/Common.hs @@ -1,6 +1,13 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UnicodeSyntax #-} +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Morph.Common ( PointCorrespondence , Trajectory @@ -26,9 +33,9 @@ import Reanimate.Animation import Reanimate.ColorComponents import Reanimate.Ease -import Reanimate.Math.Polygon (Polygon, mkPolygon, pAddPoints, - pCentroid, pCutEqual, pSize, - polygonPoints) +import Reanimate.Math.Polygon (APolygon, Epsilon, Polygon, + mkPolygon, pAddPoints, pCentroid, + pCutEqual, pSize, polygonPoints) import Reanimate.PolyShape import Reanimate.Svg @@ -43,18 +50,35 @@ -- Graphical polygon? FIXME: Come up with a better name. type GPolygon = (DrawAttributes, Polygon) +-- | Method determining how points in the source polygon align with +-- points in the target polygon. type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon) + +-- | Method for interpolating between two aligned polygons. type Trajectory = (Polygon, Polygon) → (Double → Polygon) + +-- | Method for pairing sets of polygons. type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)] +-- | Morphing strategy data Morph = Morph { morphTolerance :: Double + -- ^ Morphing curves is not always possible and + -- sometimes shapes are reduced to polygons or meta-curves. + -- This parameter determined the accuracy of this transformation. , morphColorComponents :: ColorComponents + -- ^ Color components used for color interpolation. LAB is usually + -- the best option here. , morphPointCorrespondence :: PointCorrespondence + -- ^ Desired point-correspondence algorithm. , morphTrajectory :: Trajectory + -- ^ Desired interpolation algorithm. , morphObjectCorrespondence :: ObjectCorrespondence + -- ^ Desired object-correspondence algorithm. } +{-# INLINE morph #-} +-- | Apply morphing strategy to interpolate between two SVG images. morph :: Morph -> SVG -> SVG -> Double -> SVG morph Morph{..} src dst = \t -> case t of @@ -77,7 +101,8 @@ , let arranged = morphPointCorrespondence srcPoly' dstPoly' ] -normalizePolygons :: Polygon -> Polygon -> (Polygon, Polygon) +-- | Add points to each polygon such that they end up with same size. +normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a) normalizePolygons src dst = (pAddPoints (max 0 $ dstN-srcN) src ,pAddPoints (max 0 $ srcN-dstN) dst) @@ -99,6 +124,7 @@ interpColor a _ = a interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t) +-- | Object-correspondence algorithm that spawn objects as necessary. genesisObjectCorrespondence :: ObjectCorrespondence genesisObjectCorrespondence left right = case (left, right) of @@ -112,6 +138,7 @@ where emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b) +-- | Object-correspondence algorithm that duplicate objects as necessary. dupObjectCorrespondence :: ObjectCorrespondence dupObjectCorrespondence left right = case (left, right) of @@ -128,6 +155,8 @@ (x:xs, y:ys) -> (x, y) : dupObjectCorrespondence xs ys +-- | Object-correspondence algorithm that splits objects in smaller pieces +-- as necessary. splitObjectCorrespondence :: ObjectCorrespondence -- splitObjectCorrespondence = dupObjectCorrespondence splitObjectCorrespondence left right = @@ -168,6 +197,7 @@ -- joinPairs _ _ _ = [] -- FIXME: sort by size, smallest to largest +-- | Extract shapes and their graphical attributes from an SVG node. toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)] toShapes tol src = [ (attrs, plToPolygon tol shape) @@ -175,9 +205,12 @@ , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph ] +-- | Extract the first polygon in an SVG node. Will fail if there +-- are no acceptable shapes. unsafeSVGToPolygon :: Double -> SVG -> Polygon unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src +-- | Map over each polygon in an SVG node. annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG annotatePolygons fn svg = mkGroup [ fn poly & drawAttributes .~ attr diff --git a/src/Reanimate/Morph/LeastWork.hs b/src/Reanimate/Morph/LeastWork.hs deleted file mode 100644 --- a/src/Reanimate/Morph/LeastWork.hs +++ /dev/null @@ -1,449 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Reanimate.Morph.LeastWork - ( StretchCosts(..) - , defaultStretchCosts - , zeroStretchCosts - , stretchWork - , BendCosts(..) - , defaultBendCosts - , bendWork - , bendInfo - , leastWork - , anyLeastWork - , rawLeastWork - , leastWork' - ) where - -import Control.Monad -import Control.Monad.ST -import Control.Monad.ST.Unsafe -import Data.Array.Base -import Data.Hashable -import Data.Maybe -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import Linear.Metric -import Linear.V2 -import Linear.Vector -import Reanimate.Math.Common -import Reanimate.Math.Polygon -import Reanimate.Morph.Cache -import Reanimate.Morph.Common -import Reanimate.Morph.Linear -import System.IO --- import Text.Printf - --- import Debug.Trace - -data StretchCosts = StretchCosts - { stretchStiffness :: Double - , stretchCollapsePenalty :: Double - , stretchElasticity :: Double - } - -instance Hashable StretchCosts where - hashWithSalt salt StretchCosts{..} = - hashWithSalt salt (stretchStiffness, stretchCollapsePenalty, stretchElasticity) - -defaultStretchCosts :: StretchCosts -defaultStretchCosts = StretchCosts - { stretchStiffness = 1 - , stretchCollapsePenalty = 2 - , stretchElasticity = 2 } - -zeroStretchCosts :: StretchCosts -zeroStretchCosts = defaultStretchCosts{ stretchStiffness = 0 } - --- stretch work paramters: --- stretch stiffness --- collapse penalty --- exponent -stretchWork :: StretchCosts -> Double -> Double -> Double -stretchWork _ 0 0 = 0 -stretchWork StretchCosts{..} lenStart lenEnd = checkNaN $ - stretchStiffness * (delta**stretchElasticity)/ - ((1-c)*lenMin + c*lenMax) - where - checkNaN v - | isNaN v = 0 - | otherwise = v - c = recip stretchCollapsePenalty - lenMin = min lenStart lenEnd - lenMax = max lenStart lenEnd - delta = lenEnd-lenStart - - -data BendCosts = BendCosts - { bendStiffness :: Double - , bendElasticity :: Double - , bendDeviationPenalty :: Double - , bendZeroPenalty :: Double - } - -instance Hashable BendCosts where - hashWithSalt salt BendCosts{..} = - hashWithSalt salt - (bendStiffness - ,bendElasticity - ,bendDeviationPenalty - ,bendZeroPenalty) - -defaultBendCosts :: BendCosts -defaultBendCosts = BendCosts - { bendStiffness = 1 - , bendElasticity = 2 - , bendDeviationPenalty = 10 - , bendZeroPenalty = 1000 } - -type PType = Double - -bendWork :: BendCosts -> V2 PType -> V2 PType -> V2 PType -> V2 PType -> Double -bendWork BendCosts{..} startA endA startB endB = - case bendInfo startA endA startB endB of - (deltaAngle, deviation, throughZero) -> - (bendStiffness * (deltaAngle + bendDeviationPenalty * deviation))**bendElasticity + - if throughZero then bendZeroPenalty else 0 - --- deltaX :: Fractional a => V2 a --- deltaX = V2 (recip 1000000000) 0 - --- testBendInfo :: Polygon -> Polygon -> [Int] -> [Int] -> (Double, Double, Bool) --- testBendInfo a b ~[a1,a2,a3] ~[b1,b2,b3] = --- let startA = realToFrac <$> (pAccess a a1 - pAccess a a2) --- endA = realToFrac <$> (pAccess b b1 - pAccess b b2) --- endB = realToFrac <$> (pAccess b b3 - pAccess b b2) --- startB = realToFrac <$> (pAccess a a3 - pAccess a a2) --- in bendInfo startA endA startB endB - --- zeroBendFactor :: Fractional a => a --- zeroBendFactor = 1 - -vZero :: (Ord a, Fractional a) => V2 a -> Bool -vZero (V2 x y) = abs x < epsilon && abs y < epsilon - -bendInfo :: V2 PType -> V2 PType -> V2 PType -> V2 PType -> (Double, Double, Bool) --- bendInfo startA endA startB endB --- | vZero startA, not (vZero endA) = bendInfo (endA ^* zeroBendFactor) endA startB endB --- | vZero endA, not (vZero startA) = bendInfo startA (startA ^* zeroBendFactor) startB endB --- | vZero startB, not (vZero endB) = bendInfo startA endA (endB ^* zeroBendFactor) endB --- | vZero endB, not (vZero startB) = bendInfo startA endA startB (startB ^* zeroBendFactor) -bendInfo startA endA startB endB = - -- trace (show $ map (fmap realToFrac) [startA, endA, startB, endB]) $ - -- trace (show (realToFrac <$> q0, realToFrac <$> q1, realToFrac <$> q2)) $ - -- (ang4, alpha+beta, throughZero) - (ang4, alpha+beta, throughZero) - where - !x0 = dot startA startB - !y0 = crossZ startA startB - !x1 = (dot endA startB + dot startA endB) / 2 - !y1 = (crossZ endA startB + crossZ startA endB) / 2 - !x2 = dot endA endB - !y2 = crossZ endA endB - fudge x | vZero x = V2 (-0.1) 0 - fudge x = x - q0,q1, q2 :: V2 PType - !q0 = fudge $ V2 x0 y0 - !q1 = V2 x1 y1 - !q2 = fudge $ V2 x2 y2 - curve n = q0^*squared (1-n) + q1^*(2*n*(1-n)) + q2^*squared n - squared a = a*a - ang3 = abs (angleR q0 q2) - ang4 = if isWrap then 2*pi - ang3 else ang3 - d0 = crossZ q0 q1 - d1 = crossZ q0 q2 / 2 - d2 = crossZ q1 q2 - roots = filter (>0) $ filter (<1) $ quadraticRoot (d0+d2-2*d1) (2*d1-2*d0) d0 - alpha = fromMaybe 0 $ listToMaybe - [ min q0Angle q2Angle - ang - | root <- roots - , let ang = angleR (V2 1 0) (curve root) - , ang < min q0Angle q2Angle ] - beta = fromMaybe 0 $ listToMaybe - [ ang - max q0Angle q2Angle - | root <- roots - , let ang = angleR (V2 1 0) (curve root) - , ang > max q0Angle q2Angle ] - q0Angle = angleR (V2 1 0) q0 - q2Angle = angleR (V2 1 0) q2 - isWrap = d1*d1 - d0*d2 < 0 && isInside q0 q1 q2 (V2 0 0) - throughZero = quadThroughZero q0 q1 q2 - -angleR :: V2 Double -> V2 Double -> Double -angleR a b = atan2 (realToFrac $ crossZ a b) (realToFrac $ dot a b) - -leastWork :: StretchCosts -> BendCosts -> PointCorrespondence -leastWork stretchCosts bendCosts = - cachePointCorrespondence key (leastWork_ stretchCosts bendCosts) - where - key = hash ("leastWork v0"::String, stretchCosts, bendCosts) - -leastWork_ :: StretchCosts -> BendCosts -> PointCorrespondence -leastWork_ stretchCosts bendCosts src dst - | pSize src > pSize dst = - case leastWork stretchCosts bendCosts dst src of - (dst', src') -> (src', dst') -leastWork_ stretchCosts bendCosts src dst = - worker undefined (-1) options - where - worker bestP _bestPScore [] = - --trace ("\nBest score: " ++ show _bestPScore) - bestP - worker bestP bestPScore (x:xs) = - let (src',dst', newScore) = leastWork' stretchCosts bendCosts src x in - if newScore < bestPScore || bestPScore < 0 - then worker (src',dst') newScore xs - else worker bestP bestPScore xs - options = pCycles dst - -- options = [pCycles dst !! 79 ] - -anyLeastWork :: StretchCosts -> BendCosts -> PointCorrespondence -anyLeastWork stretchCosts bendCosts src dst = - case closestLinearCorrespondence src dst of - (src', dst') -> case leastWork' stretchCosts bendCosts src' dst' of - (src'', dst'', _score) -> (src'', dst'') - -rawLeastWork :: StretchCosts -> BendCosts -> PointCorrespondence -rawLeastWork stretchCosts bendCosts src dst = - case leastWork' stretchCosts bendCosts src dst of - (src', dst', _score) -> (src', dst') - --- type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon) -leastWork' :: StretchCosts -> BendCosts -> Polygon -> Polygon -> (Polygon, Polygon, Double) -leastWork' stretchCosts bendCosts src dst = - leastWork'' stretchCosts bendCosts src dst - srcV dstV (mkDistances srcV) (mkDistances dstV) - where - srcV = V.map (fmap realToFrac) $ polygonPoints src - dstV = V.map (fmap realToFrac) $ polygonPoints dst - mkDistances poly = VU.generate (length poly) $ \i -> - distance (V.unsafeIndex poly i) (V.unsafeIndex poly ((i+1) `mod` length poly)) - -leastWork'' :: StretchCosts -> BendCosts -> Polygon -> Polygon - -> V.Vector (V2 Double) -> V.Vector (V2 Double) - -> VU.Vector Double -> VU.Vector Double - -> (Polygon, Polygon, Double) -leastWork'' stretchCosts bendCosts src dst srcV dstV srcDist dstDist = runST $ do - -- unsafeIOToST $ hPutStrLn stderr $ "Size: " ++ show (nSrc, nDst) - -- unsafeIOToST $ hFlush stderr - work <- asArray $ newArray ((0,0),(nSrc,nDst)) (0::Double) - north <- asArray $ newArray ((0,0),(nSrc,nDst)) (0::Int) - west <- asArray $ newArray ((0,0),(nSrc,nDst)) (0::Int) - let -- calc :: Int -> Int -> ST s () - calc = \i j -> do - let cond = False -- i==14 && j==26 - w0 <- if i==0 then return 0 else do - prevWork <- readArray work (i-1,j) - prevWest <- readArray west (i-1,j) - prevNorth <- readArray north (i-1,j) - let !len = VU.unsafeIndex srcDist (i-1) - -- !len = distance (realToFrac <$> pAccess src (i-1)) (realToFrac <$> pAccess src i) - !sWork = stretchWork stretchCosts len 0 - -- !srcPrev = realToFrac <$> pAccess src (i-1-prevWest) - !srcPrev = V.unsafeIndex srcV (i-1-prevWest) - -- !srcMiddle = realToFrac <$> pAccess src (i-1) - !srcMiddle = V.unsafeIndex srcV (i-1) - -- !srcNext = realToFrac <$> pAccess src i - !srcNext = V.unsafeIndex srcV i - -- !dstPrev = realToFrac <$> pAccess dst (j-prevNorth) - !dstPrev = V.unsafeIndex dstV (j-prevNorth) - -- !dstMiddle = realToFrac <$> pAccess dst j - !dstMiddle = V.unsafeIndex dstV j - !bWork = - bendWork bendCosts - (srcPrev-srcMiddle) (dstPrev-dstMiddle) - (srcNext-srcMiddle) (V2 0 0) - -- when (len' /= len) $ do - -- error $ "w0: Bad length: " ++ show (len', len, i, j) - when cond $ do - unsafeIOToST $ hPutStrLn stderr $ "West: " ++ show (i-1-prevWest, i-1, i) - unsafeIOToST $ hPutStrLn stderr $ "West: " ++ show (j-prevNorth, j, j) - unsafeIOToST $ hPutStrLn stderr $ "bWork: " ++ show (bWork) - unsafeIOToST $ hPutStrLn stderr $ "len: " ++ show (len) - unsafeIOToST $ hPutStrLn stderr $ "sWork: " ++ show (sWork) - return (prevWork + sWork + bWork + if prevWest==0&&prevNorth==1 then 10000 else 0) - w1 <- if j==0 then return 0 else do - prevWork <- readArray work (i,j-1) - prevWest <- readArray west (i,j-1) - prevNorth <- readArray north (i,j-1) - let len = VU.unsafeIndex dstDist (j-1) - --len = distance (realToFrac <$> pAccess dst (j-1)) (realToFrac <$> pAccess dst j) - sWork = stretchWork stretchCosts 0 len - -- srcPrev = realToFrac <$> pAccess src (i-prevWest) - -- srcMiddle = realToFrac <$> pAccess src i - -- dstPrev = realToFrac <$> pAccess dst (j-1-prevNorth) - -- dstMiddle = realToFrac <$> pAccess dst (j-1) - -- dstNext = realToFrac <$> pAccess dst j - srcPrev = V.unsafeIndex srcV (i-prevWest) - srcMiddle = V.unsafeIndex srcV i - dstPrev = V.unsafeIndex dstV (j-1-prevNorth) - dstMiddle = V.unsafeIndex dstV (j-1) - dstNext = V.unsafeIndex dstV j - bWork = - bendWork bendCosts - (srcPrev-srcMiddle) (dstPrev-dstMiddle) - (V2 0 0) (dstNext-dstMiddle) - -- when (len' /= len) $ do - -- error $ "w1: Bad length: " ++ show (len', len, j, realToFrac <$> pAccess dst (j-1), realToFrac <$> pAccess dst j) - when (isNaN bWork) $ - error $ "bWork NaN: " ++ show (i,j) - when (isNaN sWork) $ - error $ "sWork NaN: " ++ show (i,j, len) - when cond $ do - unsafeIOToST $ hPutStrLn stderr $ "North: " ++ show (i-prevWest, i, i) - unsafeIOToST $ hPutStrLn stderr $ "North: " ++ show (j-1-prevNorth, j-1, j) - unsafeIOToST $ hPutStrLn stderr $ "bWork: " ++ show (bWork) - unsafeIOToST $ hPutStrLn stderr $ "len: " ++ show (len) - unsafeIOToST $ hPutStrLn stderr $ "sWork: " ++ show (sWork) - return (prevWork + sWork + bWork + if prevWest==1&&prevNorth==0 then 10000 else 0) - w2 <- if j==0 || i==0 then return 0 else do - prevWork <- readArray work (i-1,j-1) - prevWest <- readArray west (i-1,j-1) - prevNorth <- readArray north (i-1,j-1) - -- let findPrev key = do - -- keyNorth <- readArray north - let -- startLen = distance (realToFrac <$> pAccess src (i-1)) (realToFrac <$> pAccess src i) - -- endLen = distance (realToFrac <$> pAccess dst (j-1)) (realToFrac <$> pAccess dst j) - startLen = VU.unsafeIndex srcDist (i-1) - endLen = VU.unsafeIndex dstDist (j-1) - sWork = stretchWork stretchCosts startLen endLen - -- srcPrev = realToFrac <$> pAccess src (i-1-prevWest) - -- srcMiddle = realToFrac <$> pAccess src (i-1) - -- srcNext = realToFrac <$> pAccess src i - -- dstPrev = realToFrac <$> pAccess dst (j-1-prevNorth) - -- dstMiddle = realToFrac <$> pAccess dst (j-1) - -- dstNext = realToFrac <$> pAccess dst j - srcPrev = V.unsafeIndex srcV (i-1-prevWest) - srcMiddle = V.unsafeIndex srcV (i-1) - srcNext = V.unsafeIndex srcV i - dstPrev = V.unsafeIndex dstV (j-1-prevNorth) - -- dstPrev' = V.unsafeIndex dstV (j-2) - dstMiddle = V.unsafeIndex dstV (j-1) - dstNext = V.unsafeIndex dstV j - bWork = - bendWork bendCosts - (srcPrev-srcMiddle) (dstPrev-dstMiddle) - (srcNext-srcMiddle) (dstNext-dstMiddle) - -- bWork' = - -- bendWork bendCosts - -- (srcPrev-srcMiddle) (dstPrev'-dstMiddle) - -- (srcNext-srcMiddle) (dstNext-dstMiddle) - when cond $ do - unsafeIOToST $ hPutStrLn stderr $ "Diag: " ++ show (i-1-prevWest, i-1, i) - unsafeIOToST $ hPutStrLn stderr $ "Diag: " ++ show (j-1-prevNorth, j-1, j) - unsafeIOToST $ hPutStrLn stderr $ "bWork: " ++ show (bWork) - -- unsafeIOToST $ hPutStrLn stderr $ "bWork': " ++ show (bWork') - return (prevWork + sWork + bWork) - let goNorth = do - when cond $ do - unsafeIOToST $ hPutStrLn stderr "Go north" - unsafeIOToST $ hPrint stderr (w0, w1, w2) - writeArray work (i,j) w1 - writeArray north (i,j) 1 - goWest = do - when cond $ do - unsafeIOToST $ hPutStrLn stderr "Go west" - unsafeIOToST $ hPrint stderr (w0, w1, w2) - writeArray work (i,j) w0 - writeArray west (i,j) 1 - goNorthWest = do - when cond $ - unsafeIOToST $ hPutStrLn stderr "Go northwest" - writeArray work (i,j) w2 - writeArray north (i,j) 1 - writeArray west (i,j) 1 - -- when (j==2 && i==2) $ - -- unsafeIOToST $ hPrint stderr (i,j,w0, w1, w2) - when (isNaN w0 || isNaN w1 || isNaN w2) $ - error $ "NaN: " ++ show (w0,w1,w2, i, j) - if | i==0 -> goNorth - | j==0 -> goWest - | w2 <= w0 && w2 <= w1 -> goNorthWest - | w0 <= w1 && w0 <= w2 -> goWest - | w1 <= w0 && w1 <= w2 -> goNorth - | otherwise -> error $ "urk: " ++ show (w0, w1, w2, i, j) - forM_ [1.. max nSrc nDst-1] $ \idx -> do - forM_ [0..idx-1] $ \i -> do - when (idx < nSrc && i < nDst) $ - calc idx i - when (i < nSrc && idx < nDst) $ - calc i idx - when (idx < nSrc && idx < nDst) $ - calc idx idx - -- workMatrix <- unsafeFreeze work - -- unsafeIOToST $ do - -- hPutStr stderr " " - -- forM_ [0..nSrc-1] $ \i -> do - -- hPutStr stderr (printf "%6d " i) - -- hPutStr stderr "\n" - -- forM_ [0..nDst-1] $ \j -> do - -- hPutStr stderr (printf "%2d " j) - -- forM_ [0..nSrc-1] $ \i -> do - -- hPutStr stderr (printf "%6.1f " (workMatrix ! (i,j))) - -- hPutStr stderr "\n" - finalWork <- readArray work (nSrc-1,nDst-1) - let walk = \i j acc -> do - -- w <- readArray work (i,j) - -- when (i==14) $ - -- unsafeIOToST $ hPrint stderr (i,j) - let acc' = (i,j):acc - if (i==0 && j==0) - then return acc' - else do - isNorth <- (==1) <$> readArray north (i,j) - isWest <- (==1) <$> readArray west (i,j) - if | isNorth && isWest -> walk (i-1) (j-1) acc' - | isNorth -> walk i (j-1) acc' - | otherwise -> walk (i-1) j acc' - pairs <- walk (nSrc-1) (nDst-1) [] - return - ( mkPolygon $ V.fromList [ pAccess src idx | idx <- map fst pairs ] - , mkPolygon $ V.fromList [ pAccess dst idx | idx <- map snd pairs ] - , finalWork - ) - where - nSrc = pSize src - nDst = pSize dst - asArray :: ST s (STUArray s i e) -> ST s (STUArray s i e) - asArray = id - -{- -quadToCubic (QuadBezier a b c) = - CubicBezier a ((1/3)*^(a ^+^ 2*^b)) ((1/3)*^(2*^b ^+^ c)) c - -cubicRoot (p3 - 3*p2 + 3*p1 - p0) (3*p2 - 6*p1 + 3*p0) (3*p1 - 3*p0) p0 - where (CubicBezier (Point p0 _) (Point p1 _) (Point p2 _) (Point p3 _)) = b - -p3 = a -p2 = ((1/3)*^(a ^+^ 2*^b)) -p1 = ((1/3)*^(2*^b ^+^ c)) -p0 = c -cubicRoot 0 (a - 2b + c) (2b - 2c) c --} - -quadThroughZero :: V2 Double -> V2 Double -> V2 Double -> Bool -quadThroughZero a@(V2 _ q0) b@(V2 _ q1) c@(V2 _ q2) = - any (xPositive . eval) $ filter (\x -> x > 0 && x < 1) extrema - where - xPositive (V2 x _) = x>0 - eval n = a^*squared (1-n) + b^*(2*n*(1-n)) + c^*squared n - squared x = x*x - extrema = quadraticRoot (q2-2*q1+q0) (2*q1-2*q0) q0 - -quadraticRoot :: Double -> Double -> Double -> [Double] -quadraticRoot a b c - | a == 0 && b == 0 = [] - | a == 0 = [-c/b] - | otherwise = result - where - d = b*b - 4*a*c - bSign | b < 0 = -1 - | otherwise = 1 - q = - (b + bSign * sqrt d) / 2 - x1 = q/a - x2 = c/q - result | d < 0 = [] - | d == 0 = [x1] - | otherwise = [x1, x2] diff --git a/src/Reanimate/Morph/LineBend.hs b/src/Reanimate/Morph/LineBend.hs deleted file mode 100644 --- a/src/Reanimate/Morph/LineBend.hs +++ /dev/null @@ -1,108 +0,0 @@ -module Reanimate.Morph.LineBend - ( lineBend - , lineBendRaw - ) where - -import qualified Data.Vector as V -import Linear.Matrix (det22) -import Linear.Metric -import Linear.V2 -import Linear.Vector -import Reanimate.Math.Common -import Reanimate.Math.Polygon -import Reanimate.Morph.Common - -lineBend :: Trajectory -lineBend = lineBend' True - -lineBendRaw :: Trajectory -lineBendRaw = lineBend' False - --- Note: Returns polygon with n+1 elements. -lineBend' :: Bool -> Trajectory -lineBend' corrected (a,b) = \t -> - let u = 1 - t - -- phi = V.zipWith (\l r -> u*l + t*r) phi_a phi_b - phi = V.zipWith (\l r -> lerpAngle l r t) phi_a phi_b - -- alpha_zero = u * alpha_a_zero + t * alpha_b_zero - alpha_zero = lerpAngle alpha_a_zero alpha_b_zero t - alpha = V.scanl (+) alpha_zero phi - bigE = - V.sum $ V.zipWith (\diff alp -> squared diff * squared (cos alp)) lengths_diff alpha - bigF = - V.sum $ V.zipWith (\diff alp -> squared diff * sin alp * cos alp) lengths_diff alpha - bigG = - V.sum $ V.zipWith (\diff alp -> squared diff * squared (sin alp)) lengths_diff alpha - bigU = - 2 * V.sum - (V.zipWith3 (\len_a len_b alp -> (u*len_a + t*len_b) * cos alp) lengths_a lengths_b alpha) - bigV = - 2 * V.sum - (V.zipWith3 (\len_a len_b alp -> (u*len_a + t*len_b) * sin alp) lengths_a lengths_b alpha) - lam1 = det22 (V2 (V2 bigU bigF) (V2 bigV bigG)) / - det22 (V2 (V2 bigE bigF) (V2 bigF bigG)) - lam2 = det22 (V2 (V2 bigE bigU) (V2 bigF bigV)) / - det22 (V2 (V2 bigE bigF) (V2 bigF bigG)) - s_vect = V.fromList - [ -0.5 * squared (lengths_diff V.! n) * - (lam1 * cos (alpha V.! n) + - lam2 * sin (alpha V.! n)) - | n <- [0 .. pSize a-1]] - lengths = V.zipWith3 (\l r s -> u*l + t*r + if corrected then s else 0) lengths_a lengths_b s_vect - movingCenter :: V2 Double - movingCenter = lerp t (realToFrac <$> pCentroid b) (realToFrac <$> pCentroid a) - centerAng :: Double - centerAng = lerpAngle centoid_angle_a centoid_angle_b t - centerLen = u*centoid_len_a + t*centoid_len_b - -- V2 x_zero y_zero = lerp t (realToFrac <$> b V.! 0) (realToFrac <$> a V.! 0) - V2 x_zero y_zero = movingCenter + V2 (cos centerAng * centerLen) (sin centerAng * centerLen) - x_modifiers = V.zipWith (*) lengths (V.map cos alpha) - y_modifiers = V.zipWith (*) lengths (V.map sin alpha) - xs = V.scanl (+) x_zero x_modifiers - ys = V.scanl (+) y_zero y_modifiers - in mkPolygon $ V.map (fmap realToFrac) $ V.zipWith V2 xs ys - where - squared x = x*x - centoid_angle_a :: Double - centoid_angle_a = lineAngle (pCentroid a + V2 1 0) (pCentroid a) (pAccess a 0) - centoid_angle_b = lineAngle (pCentroid b + V2 1 0) (pCentroid b) (pAccess b 0) - centoid_len_a :: Double - centoid_len_a = realToFrac $ approxDist (pCentroid a) (pAccess a 0) - centoid_len_b = realToFrac $ approxDist (pCentroid b) (pAccess b 0) - alpha_a_zero = lineAngle (pAccess a 0 + V2 1 0) (pAccess a 0) (pAccess a 1) - alpha_b_zero = lineAngle (pAccess b 0 + V2 1 0) (pAccess b 0) (pAccess b 1) - lengths_a = computeLength a - lengths_b = computeLength b - lengths_diff' = V.zipWith (\l r -> abs (l-r)) lengths_a lengths_b - lengths_tol = 0.0001 * V.maximum lengths_diff' - lengths_diff = V.map (max lengths_tol) lengths_diff' - phi_a = computePhi a - phi_b = computePhi b - - computeLength :: Polygon -> V.Vector Double - computeLength poly = V.fromList - [ realToFrac $ approxDist this next - | n <- [0 .. pSize poly-1] - , let this = pAccess poly n - next = pAccess poly (pNext a n) - ] - computePhi poly = V.fromList $ - [ negate $ angle' (next-this) ((prev-this) ^* (-1)) - | n <- [1 .. pSize poly-1] - , let prev = pAccess poly (n-1) - this = pAccess poly n - next = pAccess poly (pNext a n) - ] - -lerpAngle :: Double -> Double -> (Double -> Double) -lerpAngle fromAng toAng t - | abs (fromAng - (toAng+2*pi)) < abs (fromAng - toAng) = (1-t)*fromAng + t*(toAng+2*pi) - | abs (fromAng - (toAng-2*pi)) < abs (fromAng - toAng) = (1-t)*fromAng + t*(toAng-2*pi) - | otherwise = (1-t)*fromAng + t*toAng - --- Angle from a through b to c. Measured on the right-hand side, from 0 to tau -lineAngle :: V2 Rational -> V2 Rational -> V2 Rational -> Double -lineAngle a b c = angle' (a-b) (c-b) - -angle' :: V2 Rational -> V2 Rational -> Double -angle' a b = atan2 (realToFrac $ crossZ a b) (realToFrac $ dot a b) diff --git a/src/Reanimate/Morph/Linear.hs b/src/Reanimate/Morph/Linear.hs --- a/src/Reanimate/Morph/Linear.hs +++ b/src/Reanimate/Morph/Linear.hs @@ -1,7 +1,14 @@ +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Morph.Linear ( linear, rawLinear - , linearCorrespondence , closestLinearCorrespondence + , closestLinearCorrespondenceA , linearTrajectory ) where @@ -14,25 +21,53 @@ import Reanimate.Morph.Cache import Reanimate.Morph.Common +-- | Linear interpolation strategy. +-- +-- Example: +-- +-- > playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t -> +-- > withStrokeLineJoin JoinRound $ +-- > let src = scale 8 $ center $ latex "X" +-- > dst = scale 8 $ center $ latex "H" +-- > in morph linear src dst t +-- +-- <> linear :: Morph linear = rawLinear { morphPointCorrespondence = cachePointCorrespondence (hash ("closest"::String)) closestLinearCorrespondence } +-- | Linear interpolation strategy without realigning corners. +-- May give better results if the polygons are already aligned. +-- Usually gives worse results. +-- +-- Example: +-- +-- > playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t -> +-- > withStrokeLineJoin JoinRound $ +-- > let src = scale 8 $ center $ latex "X" +-- > dst = scale 8 $ center $ latex "H" +-- > in morph rawLinear src dst t +-- +-- <> rawLinear :: Morph rawLinear = Morph { morphTolerance = 0.001 , morphColorComponents = labComponents - , morphPointCorrespondence = linearCorrespondence + , morphPointCorrespondence = normalizePolygons , morphTrajectory = linearTrajectory , morphObjectCorrespondence = splitObjectCorrespondence } -linearCorrespondence :: PointCorrespondence -linearCorrespondence = normalizePolygons - +-- | Cycle polygons until the sum of the point trajectory path lengths +-- is smallest. closestLinearCorrespondence :: PointCorrespondence -closestLinearCorrespondence src' dst' = +closestLinearCorrespondence = closestLinearCorrespondenceA + +-- | Cycle polygons until the sum of the point trajectory path lengths +-- is smallest. +closestLinearCorrespondenceA :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a) +closestLinearCorrespondenceA src' dst' = (src, worker dst (score dst) options) where (src, dst) = normalizePolygons src' dst' @@ -44,9 +79,11 @@ else worker bestP bestPScore xs options = pCycles dst score p = sum - [ approxDist (pAccess src n) (pAccess p n) + [ -- approxDist (pAccess src n) (pAccess p n) + distSquared (pAccess src n) (pAccess p n) | n <- [0 .. pSize src-1] ] +-- | Strategy for moving points in a linear (straight-line) trajectory. linearTrajectory :: Trajectory linearTrajectory (src,dst) | pSize src == pSize dst = \t -> mkPolygon $ diff --git a/src/Reanimate/Morph/Rigid.hs b/src/Reanimate/Morph/Rigid.hs deleted file mode 100644 --- a/src/Reanimate/Morph/Rigid.hs +++ /dev/null @@ -1,281 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{- -The shape of a triangle can be represented by two explicit points (ie vectors) -and a third implicit point at (0,0). A triangle defined by three points can be -converted by subtracting one of the points from the others: - shape (p1,p2,p3) = (p2-p1, p3-p1) -This keeps the shape intact but drops the position of the triangle. - -If P and Q are two such triangles, there exists a matrix A that transforms -P into Q: AP = Q -The 'A' matrix can be calculated by multiplying Q and the inverse of P: - A = QP_inv - -So, if we have a set of triangles, we can drop their positional information -and compute their shape transformation matrices. But can we do it in reverse? -Can we start with a set of transformation matrices (which don't give us the -positions of the triangles) and compute a set of points that represent triangles -with the right transformation? -In other words, if we have a set of triangles (with absolute position) and -a transformation matrix for each triangle, can we compute new absolute positions -such that AP=Q? - -Solving this is not straightforward as moving a single point will change the -transformation of multiple triangles. Fortunately, though, this problem can be -expression as linear equations and solved quickly with LAPACK. - -To express the problem as a linear system, we need 4 equations for each -triangle and 2 unknowns for each point. - -The system has this shape: Mx=B -We're trying to find 'x' which are the positions of the new points. -'M' is a matrix that transforms points into transformation matrices. -'B' is the target transformation matrices. - -With a bit of rewriting, we can reduce 'A = QP_inv' to 4 linear equations -with 6 unknowns. The 6 unknowns are the x and y positions for the three corners -in a triangle. -This is just another way of calculating the transformation matrix 'A' and we -can verify it by looking at the output of: - * computeA src dst - * applyCoeff (coeffOfB src) dst -The output should be the same because they're both computing 'A'. - -'applyCoeff' simply multiplies the coefficients by a 6x1 matrix containing -the x and y positions for 'dst'. - -So, this means we have roughly the right shape: Mx=B. M is the coefficients -we found for 'src', 'x' is dst, and 'B' is the transformation matrix that -turns 'src' into 'dst'. -We can get the coefficients for each triangle and place them together in a -single large matrix. Then we can put the desired transformation matrices in 'B' -and ask a linear solver to find 'x' which satisfies the equations. - -Phew, step one is done. We now have the machinery for turning arbitrary -transformation matrices into proper, connected triangles. Next step is figuring -out which rotational matrices to use. At the two extremes, we have the identity -matrices (representing our starting shape) and the matrices computed from the -target triangles (represetning out target shape). How can these two matrices be -interpolated for a smooth morph? - -There are several ways of interpolating matrices. Linear interpolation is -possible. But, it looks prettier if we separate rotation from shear. Then we -can use spherical linear interpolation on the rotation and linear interpolation -on the shear. - --} -module Reanimate.Morph.Rigid where - -import Data.Foldable (toList) -import Data.Vector (Vector) -import qualified Data.Vector as V -import Linear.Quaternion -import Linear.Vector -import Linear.V2 -import Linear.V3 -import qualified Numeric.LinearAlgebra as Matrix -import Numeric.LinearAlgebra.HMatrix (GMatrix, Matrix, - toLists, (!), (><)) -import Reanimate.Animation -import Reanimate.Svg - - -type P = V2 Double -type Trig = (P,P,P) -type RelTrig = (Int,Int,Int) - -data Mesh = Mesh - { meshPointsA :: Vector P - , meshPointsB :: Vector P - , meshOutline :: Vector Int - -- , meshSteiner :: Vector Int - , meshTriangles :: Vector RelTrig } - -renderMeshPair :: Mesh -> SVG -renderMeshPair Mesh{..} = withStrokeColor "black" $ mkGroup - [ mkLinePathClosed - [ (aPx, aPy) - , (bPx, bPy) - , (cPx, cPy)] - | (a,b,c) <- V.toList meshTriangles - , let V2 aPx aPy = meshPointsA V.! a - V2 bPx bPy = meshPointsA V.! b - V2 cPx cPy = meshPointsA V.! c - ] - --- applyA (computeA a b) a = b + some_constant_translation --- A = Q P_inv -computeA :: Trig -> Trig -> Matrix Double -computeA p q = matQ <> Matrix.inv matP - where - matP = trigToMatrix p - matQ = trigToMatrix q - --- A = UDV = U(VV_t)DV = (UV)(V_tDV) = RS --- R = UV --- S = V_tDV -computeRS :: Matrix Double -> (Matrix Double, Matrix Double) -computeRS a = (r, s) - where - (u,d,vt) = Matrix.svd a - v = Matrix.tr vt - r = u <> v - s = vt <> Matrix.diag d <> v - -matrixToQuaternion :: Matrix Double -> Quaternion Double -matrixToQuaternion r = q - where - w = 0.5 * sqrt (1 + r!0!0 + r!1!1 + 1) - z = 1/(4*w) * (r!0!1 - r!1!0) - q = Quaternion w (V3 0 0 z) - -quaternionToMatrix :: Quaternion Double -> Matrix Double -quaternionToMatrix q = (2><2) - [ 1 - 2*(qj*qj + qk*qk), 2*(qi*qj+qk*qr) - , 2*(qi*qj - qk*qr), 1 - 2*(qi*qi + qk*qk) ] - where - [qr,qi,qj,qk] = toList q - --- A = R((1-t)I + tS) -computeA_RSt :: Matrix Double -> Matrix Double -> Double -> Matrix Double -computeA_RSt r s t = r_t <> (realToFrac (1-t) * Matrix.ident 2 + realToFrac t * s) - where - i = Quaternion 1 0 - q = slerp i (matrixToQuaternion r) t - r_t = quaternionToMatrix q - -applyA :: Matrix Double -> Trig -> Trig -applyA a p = - case toLists (a <> matP) of - [ [x1, x2], [y1, y2] ] -> (V2 0 0, V2 x1 y1, V2 x2 y2) - _ -> error "invalid matrix" - where - matP = trigToMatrix p - -coeffOfB :: Trig -> Matrix Double -coeffOfB p = (4><6) - [ -a0-a2, 0, a0, 0, a2, 0 - , -a1-a3, 0, a1, 0, a3, 0 - , 0, -a0-a2, 0, a0, 0, a2 - , 0, -a1-a3, 0, a1, 0, a3 ] - where - [[a0,a1],[a2,a3]] = toLists (Matrix.inv (trigToMatrix p)) - -applyCoeff :: Matrix Double -> Trig -> Matrix Double -applyCoeff b (V2 x1 y1, V2 x2 y2, V2 x3 y3) = b <> matQ - where - matQ = (6><1) [ x1, y1, x2, y2, x3, y3] - -trigToMatrix :: Trig -> Matrix Double -trigToMatrix (p1,p2,p3) = matP - where - V2 p12x p12y = p2-p1 - V2 p13x p13y = p3-p1 - matP = (2><2) - [p12x, p13x - ,p12y, p13y] - - - -data Prep = Prep - { prepPivot :: (P, P) - , prepPointsA :: Vector P - , prepPointsB :: Vector P - , prepRS :: Vector (Matrix Double, Matrix Double) - , prepRSRev :: Vector (Matrix Double, Matrix Double) - , prepUToB :: GMatrix - } - -symmetric :: Bool -symmetric = True - -prepare :: Mesh -> Prep -prepare Mesh{..} = Prep - { prepPivot = (aOrigin, bOrigin) - , prepPointsA = - V.map (subtract aOrigin) $ - V.take pivotIdx meshPointsA <> V.drop (pivotIdx+1) meshPointsA - , prepPointsB = - V.map (subtract bOrigin) $ - V.take pivotIdx meshPointsB <> V.drop (pivotIdx+1) meshPointsB - , prepRS = rsList - , prepRSRev = rsRevList - , prepUToB = Matrix.mkSparse uToB } - where - aOrigin = meshPointsA V.! pivotIdx - bOrigin = meshPointsB V.! pivotIdx - pivotIdx = 0 - -- pivotIdx = case V.head meshTriangles of - -- (a,_,_) -> a - mkAbs p (a,b,c) = (p V.! a,p V.! b,p V.! c) - absATrigs = V.map (mkAbs meshPointsA) meshTriangles - absBTrigs = V.map (mkAbs meshPointsB) meshTriangles - aList = V.zipWith computeA absATrigs absBTrigs - rsList = V.map computeRS aList - revList = V.zipWith computeA absBTrigs absATrigs - rsRevList = V.map computeRS revList - n = length meshTriangles - -- nT = if symmetric then n*2 else n - -- pivotToB = ((nT*4)><2) $ concat - -- [ [ fromMaybe 0 (lookup (x,pivotIdx*2) bigM) - -- , fromMaybe 0 (lookup (x,pivotIdx*2+1) bigM)] - -- | x <- [0..(nT*4)-1] ] - uToB = - [ ((x,y-2),key) | ((x,y),key) <- bigM, y /= pivotIdx*2 && y /= pivotIdx*2+1 ] - bigM = - concat (zipWith worker [0..] (V.toList meshTriangles)) ++ - if symmetric - then concat $ zipWith workerRev [n..] (V.toList meshTriangles) - else [] - worker i src@(a,b,c) = concat $ - let effs = coeffOfB (mkAbs meshPointsA src) in - [ [((i*4+h, e*2), effs!h!(j*2)) - ,((i*4+h, e*2+1), effs!h!(j*2+1))] - | h <- [0..3] - , (e,j) <- zip [a,b,c] [0..] - ] - workerRev i dst@(a,b,c) = concat $ - let effs = coeffOfB (mkAbs meshPointsB dst) in - [ [((i*4+h, e*2), effs!h!(j*2)) - ,((i*4+h, e*2+1), effs!h!(j*2+1))] - | h <- [0..3] - , (e,j) <- zip [a,b,c] [0..] - ] - -interpolate :: Prep -> Double -> Vector P -interpolate Prep{..} t = V.fromList $ - pivot : worker (Matrix.toList solution) - where - -- solution = Matrix.cgSolve False prepUToB b - solution = Matrix.cgx $ last solutions - solutions = Matrix.cgSolve' - False - 1e-9 - 1e-9 - 1000 - prepUToB - b - (Matrix.fromList $ concat [ [x,y] | V2 x y <- V.toList target ]) - -- 0 - target = if t < 0.5 - then prepPointsA - else prepPointsB - worker (x:y:xs) = V2 x y ^+^ pivot : worker xs - worker _ = [] - pivot = case prepPivot of - (src, dst) -> lerp t dst src - n = V.length prepRS - b = Matrix.vector $ - [ concat (toLists a)!!j - | i <- [0..n-1] - , let (r,s) = prepRS V.! i - , let a = computeA_RSt r s t - , j <- [0..3] - ] ++ - [ concat (toLists a)!!j - | symmetric - , i <- [0..n-1] - , let (r,s) = prepRSRev V.! i - , let a = computeA_RSt r s (1-t) - , j <- [0..3] - ] diff --git a/src/Reanimate/Morph/Rotational.hs b/src/Reanimate/Morph/Rotational.hs --- a/src/Reanimate/Morph/Rotational.hs +++ b/src/Reanimate/Morph/Rotational.hs @@ -1,5 +1,13 @@ +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Morph.Rotational - ( rotationalTrajectory + ( Origin + , rotationalTrajectory , polygonOrigin ) where @@ -12,8 +20,22 @@ import Reanimate.Morph.Common import Reanimate.Math.Polygon +-- | Rotational origin relative to polygon center. +-- (0.5, 0.5) is center of polygon. Top right is (1,1) and +-- bottom left is (0,0) type Origin = (Double, Double) +-- | Interpolation by rotating around an origin point. +-- +-- Example: +-- +-- > playThenReverseA $ pauseAround 0.5 0.5 $ mkAnimation 3 $ \t -> +-- > withStrokeLineJoin JoinRound $ +-- > let src = scale 8 $ center $ latex "X" +-- > dst = scale 8 $ center $ latex "H" +-- > in morph linear{morphTrajectory=rotationalTrajectory (0.5,0.5)} src dst t +-- +-- <> rotationalTrajectory :: Origin -> Trajectory rotationalTrajectory origin (src,dst) = \t -> @@ -34,6 +56,7 @@ originAngle o = lineAngle (o + V2 1 0) o +-- | Compute the absolute position of rotational origin point in polygon. polygonOrigin :: Polygon -> Origin -> V2 Double polygonOrigin poly (originX, originY) = case pBoundingBox poly of diff --git a/src/Reanimate/Parameters.hs b/src/Reanimate/Parameters.hs --- a/src/Reanimate/Parameters.hs +++ b/src/Reanimate/Parameters.hs @@ -1,3 +1,7 @@ +{- | + Parameters define the global context of an animation. They are set once + before an animation is rendered and may not change during rendering. +-} module Reanimate.Parameters ( Raster(..) , Width @@ -20,16 +24,20 @@ import System.IO.Unsafe import Data.IORef +-- | Width of animation in pixels. type Width = Int +-- | Height of animation in pixels. type Height = Int +-- | Framerate of animation in frames per second. type FPS = Int +-- | Raster engines turn SVG images into pixels. data Raster - = RasterNone - | RasterAuto - | RasterInkscape - | RasterRSvg - | RasterMagick + = RasterNone -- ^ Do not use any external raster engine. Rely on the browser or ffmpeg. + | RasterAuto -- ^ Scan for installed raster engines and pick the fastest one. + | RasterInkscape -- ^ Use Inkscape to raster SVG images. + | RasterRSvg -- ^ Use rsvg-convert to raster SVG images. + | RasterMagick -- ^ Use imagemagick to raster SVG images. deriving (Show, Eq) {-# NOINLINE pRasterRef #-} @@ -37,9 +45,11 @@ pRasterRef = unsafePerformIO (newIORef RasterNone) {-# NOINLINE pRaster #-} +-- | Selected raster engine. pRaster :: Raster pRaster = unsafePerformIO (readIORef pRasterRef) +-- | Set raster engine. setRaster :: Raster -> IO () setRaster = writeIORef pRasterRef @@ -48,9 +58,11 @@ pFPSRef = unsafePerformIO (newIORef 0) {-# NOINLINE pFPS #-} +-- | Selected framerate. pFPS :: FPS pFPS = unsafePerformIO (readIORef pFPSRef) +-- | Set desired framerate. setFPS :: FPS -> IO () setFPS = writeIORef pFPSRef @@ -59,21 +71,24 @@ pWidthRef = unsafePerformIO (newIORef 0) {-# NOINLINE pWidth #-} +-- | Width of animation in pixel. pWidth :: Width pWidth = unsafePerformIO (readIORef pWidthRef) +-- | Set desired width of animation in pixel. setWidth :: Width -> IO () setWidth = writeIORef pWidthRef - {-# NOINLINE pHeightRef #-} pHeightRef :: IORef FPS pHeightRef = unsafePerformIO (newIORef 0) {-# NOINLINE pHeight #-} +-- | Height of animation in pixel. pHeight :: Height pHeight = unsafePerformIO (readIORef pHeightRef) +-- | Set desired height of animation in pixel. setHeight :: Height -> IO () setHeight = writeIORef pHeightRef @@ -82,9 +97,13 @@ pNoExternalsRef = unsafePerformIO (newIORef False) {-# NOINLINE pNoExternals #-} +-- | This parameter determined whether or not external tools are allowed. +-- If this flag is True then tools such as 'Reanimate.LaTeX.latex' and +-- 'Reanimate.Blender.blender' will not be invoked. pNoExternals :: Bool pNoExternals = unsafePerformIO (readIORef pNoExternalsRef) +-- | Set whether external tools are allowed. setNoExternals :: Bool -> IO () setNoExternals = writeIORef pNoExternalsRef @@ -93,8 +112,11 @@ pRootDirectoryRef = unsafePerformIO (newIORef (error "root directory not set")) {-# NOINLINE pRootDirectory #-} +-- | Root directory of animation. Images and other data has to be placed +-- here if they are referenced in an SVG image. pRootDirectory :: FilePath pRootDirectory = unsafePerformIO (readIORef pRootDirectoryRef) +-- | Set the root animation directory. setRootDirectory :: FilePath -> IO () setRootDirectory = writeIORef pRootDirectoryRef diff --git a/src/Reanimate/PolyShape.hs b/src/Reanimate/PolyShape.hs --- a/src/Reanimate/PolyShape.hs +++ b/src/Reanimate/PolyShape.hs @@ -1,6 +1,17 @@ +{-| +Module : Reanimate.PolyShape +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +A PolyShape is a closed set of curves. + +-} module Reanimate.PolyShape ( PolyShape(..) - , PolyShapeWithHoles(..) + , PolyShapeWithHoles , svgToPolyShapes -- :: Tree -> [PolyShape] , svgToPolygons -- :: Double -> Svg -> [Polygon] @@ -18,7 +29,6 @@ , plFromPolygon -- :: [RPoint] -> PolyShape , plToPolygon -- :: Double -> PolyShape -> Polygon - , plPolygonify -- :: Double -> PolyShape -> [Point Double] , plDecompose -- :: [PolyShape] -> [[RPoint]] , unionPolyShapes -- :: [PolyShape] -> [PolyShape] , unionPolyShapes' -- :: Double -> [PolyShape] -> [PolyShape] @@ -26,89 +36,89 @@ , decomposePolygon -- :: [Point Double] -> [[RPoint]] , plGroupShapes -- :: [PolyShape] -> [PolyShapeWithHoles] , mergePolyShapeHoles -- :: PolyShapeWithHoles -> PolyShape - , polyShapeTolerance - , plPartial, plPartialGroup, plPartial' - , splitPolyShape -- :: Double -> Int -> PolyShape -> [PolyShape] + , plPartial , plGroupTouching ) where -import Chiphunk.Low -import Control.Lens ((&), (.~)) -import Data.AdditiveGroup -import Data.List (minimumBy, nub, partition, sortOn) -import Data.Ord -import qualified Data.Vector as V -import Geom2D (rotate90L, rotate90R, ($*), (^*)) -import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..), - DPoint, FillRule (..), PathJoin (..), - Point (..), QuadBezier (..), arcLength, - arcLengthParam, bezierIntersection, - bezierSubsegment, closedPathCurves, - closest, colinear, curvesToClosed, - evalBezier, interpolateVector, - quadToCubic, reorient, splitBezier, - union, vectorDistance) -import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..), - defaultSvg, pathDefinition) +import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate') +import Control.Lens ((&), (.~), (^.)) +import Data.Ext +import Data.Geometry.PlanarSubdivision (PolygonFaceData (..)) +import qualified Data.Geometry.Point as Geo +import qualified Data.Geometry.Polygon as Geo +import Data.List (nub, partition, sortOn) +import qualified Data.PlaneGraph as Geo +import Data.Proxy +import qualified Data.Vector as V +import Geom2D.CubicBezier.Linear (ClosedPath (..), CubicBezier (..), FillRule (..), + PathJoin (..), QuadBezier (..), arcLength, + arcLengthParam, bezierIntersection, bezierSubsegment, + closedPathCurves, closest, colinear, curvesToClosed, + evalBezier, quadToCubic, reorient, splitBezier, union, + vectorDistance) +import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..), defaultSvg, pathDefinition) import Linear.V2 import Reanimate.Animation import Reanimate.Constants -import Reanimate.Math.EarClip -import Reanimate.Math.Polygon (Polygon, mkPolygon, pIsCCW, pRing, - pdualPolygons, polygonPoints) -import Reanimate.Math.SSSP +import Reanimate.Math.Polygon (Polygon, mkPolygon, pArea, pIsCCW) import Reanimate.Svg -- | Shape drawn by continuous line. May have overlap, may be convex. newtype PolyShape = PolyShape { unPolyShape :: ClosedPath Double } deriving (Show) +-- | Polyshape with smaller, fully-enclosed holes. data PolyShapeWithHoles = PolyShapeWithHoles { polyShapeParent :: PolyShape , polyShapeHoles :: [PolyShape] } +-- | Render a set of polyshapes as a single SVG path. renderPolyShapes :: [PolyShape] -> Tree renderPolyShapes pls = PathTree $ defaultSvg & pathDefinition .~ concatMap plPathCommands pls +-- | Render a polyshape as a single SVG path. renderPolyShape :: PolyShape -> Tree renderPolyShape pl = PathTree $ defaultSvg & pathDefinition .~ plPathCommands pl +-- | Render control-points of a polyshape as circles. renderPolyShapePoints :: PolyShape -> Tree renderPolyShapePoints = mkGroup . map renderPoint . plCurves where - renderPoint (CubicBezier (Point x y) _ _ _) = + renderPoint (CubicBezier (V2 x y) _ _ _) = translate x y $ mkCircle 0.02 +-- | Length of polyshape circumference. plLength :: PolyShape -> Double plLength = sum . map cubicLength . plCurves where cubicLength c = arcLength c 1 polyShapeTolerance +-- | Area of polyshape. plArea :: PolyShape -> Double -plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0 - where - toVect (Point x y) = Vect x y +plArea pl = realToFrac $ pArea $ plToPolygon polyShapeTolerance pl -- 1/10th of a pixel if rendered at 2560x1440 polyShapeTolerance :: Double polyShapeTolerance = screenWidth/25600 +-- | Construct a polyshape from the vertices in a polygon. plFromPolygon :: [RPoint] -> PolyShape plFromPolygon = PolyShape . ClosedPath . map worker where - worker (V2 x y) = (Point x y, JoinLine) + worker val = (val, JoinLine) +-- | Approximate a polyshape as a polygon within the given tolerance. plToPolygon :: Double -> PolyShape -> Polygon plToPolygon tol pl = - let p = V.init . V.fromList . map (\(Point x y) -> realToFrac <$> V2 x y) . + let p = V.init . V.fromList . map (fmap realToFrac) . plPolygonify tol $ pl in if pIsCCW (mkPolygon p) then mkPolygon p else mkPolygon (V.reverse p) - +-- | Partially draw polyshape. plPartial :: Double -> PolyShape -> PolyShape plPartial delta pl | delta >= 1 = pl plPartial delta pl = PolyShape $ curvesToClosed (lineOut ++ [joinB] ++ lineIn) @@ -133,47 +143,41 @@ -- toPDual :: Polygon -> Dual -> PDual -- pdualReduce :: Polygon -> PDual -> Int -> PDual -- pdualPolygons :: Polygon -> PDual -> [Polygon] -splitPolyShape :: Double -> Int -> PolyShape -> [PolyShape] -splitPolyShape tol n poly = - let polygon = toPolygon (plPolygonify tol poly) - trig = earClip $ pRing polygon - d = dual 0 trig - pd = toPDual (pRing polygon) d - reduced = pdualReduce (pRing polygon) pd n - polygons = pdualPolygons polygon reduced - in map toPolyShape polygons - where - toPolygon :: [Point Double] -> Polygon - toPolygon = mkPolygon . V.fromList . nub . map (\(Point x y) -> V2 (realToFrac x) (realToFrac y)) - toPolyShape :: Polygon -> PolyShape - toPolyShape = plFromPolygon . map (fmap realToFrac) . V.toList . polygonPoints - -plPartialGroup :: Double -> [PolyShape] -> [PolyShape] -plPartialGroup _delta [] = [] -plPartialGroup delta pls = - [ plPartial (delta*(maxLen/plLength pl)) pl | pl <- pls ] - where - maxLen = maximum $ map plLength pls +-- splitPolyShape :: Double -> Int -> PolyShape -> [PolyShape] +-- splitPolyShape tol n poly = +-- let polygon = toPolygon (plPolygonify tol poly) +-- trig = triangulate $ pRing polygon +-- d = dual 0 trig +-- pd = toPDual (pRing polygon) d +-- reduced = pdualReduce (pRing polygon) pd n +-- polygons = pdualPolygons polygon reduced +-- in map toPolyShape polygons +-- where +-- toPolygon :: [RPoint] -> Polygon +-- toPolygon = mkPolygon . V.fromList . nub . map (fmap realToFrac) +-- toPolyShape :: Polygon -> PolyShape +-- toPolyShape = plFromPolygon . map (fmap realToFrac) . V.toList . polygonPoints -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 ] +-- plPartial' :: Double -> ([RPoint], 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)]] +-- | Find intersection points. +plGroupTouching :: [PolyShape] -> [[([RPoint],PolyShape)]] plGroupTouching [] = [] plGroupTouching pls = worker [polyShapeOrigin (head pls)] pls where @@ -191,7 +195,7 @@ helper acc lst@((startP,startJ):rest) | startP `elem` seen = lst ++ reverse acc | otherwise = helper ((startP, startJ):acc) rest - plPoints :: PolyShape -> [Point Double] + plPoints :: PolyShape -> [RPoint] plPoints (PolyShape (ClosedPath lst)) = [ p | (p,_) <- lst ] @@ -206,17 +210,21 @@ plGroupShapes . unionPolyShapes -decomposePolygon :: [Point Double] -> [[RPoint]] +-- | Split polygon into smaller, convex polygons. +decomposePolygon :: [RPoint] -> [[RPoint]] decomposePolygon poly = - map (map fromVect . adjust) $ convexDecomposition (map toVect poly) tol + [ [ V2 x y + | v <- V.toList (Geo.boundaryVertices f pg) + , let Geo.Point2 x y =(pg^.Geo.vertexDataOf v) ^. Geo.location ] + | (f, Inside) <- V.toList (Geo.internalFaces pg) ] + where - tol = polyShapeTolerance - toVect (Point x y) = Vect x y - fromVect (Vect x y) = V2 x y - adjust [] = [] - adjust x = if head x == last x then adjust (init x) else x + pg = triangulate' Proxy p + p = Geo.fromPoints $ + [ Geo.Point2 x y :+ () + | V2 x y <- poly ] -plPolygonify :: Double -> PolyShape -> [Point Double] +plPolygonify :: Double -> PolyShape -> [RPoint] plPolygonify tol shape = startPoint (head curves) : concatMap worker curves where @@ -232,38 +240,41 @@ endPoint (CubicBezier _ _ _ d) = d startPoint (CubicBezier a _ _ _) = a - +-- | Convert a polyshape to a list of SVG path commands. plPathCommands :: PolyShape -> [PathCommand] plPathCommands = lineToPath . plLineCommands +-- | Convert a polyshape to a list of line commands. plLineCommands :: PolyShape -> [LineCommand] plLineCommands pl = case curves of [] -> [] (CubicBezier start _ _ _:_) -> - LineMove (toRPoint start) : + LineMove start : zipWith worker (drop 1 dstList ++ [start]) joinList ++ - [LineEnd (toRPoint start)] + [LineEnd start] where ClosedPath closedPath = unPolyShape pl (dstList, joinList) = unzip closedPath curves = plCurves pl worker dst JoinLine = - LineBezier [toRPoint dst] + LineBezier [dst] worker dst (JoinCurve a b) = - LineBezier $ map toRPoint [a,b,dst] - toRPoint :: Point Double -> RPoint - toRPoint (Point x y) = V2 x y + LineBezier [a,b,dst] +-- | Extract all shapes from SVG nodes. Drawing attributes such +-- as stroke and fill color are discarded. svgToPolyShapes :: Tree -> [PolyShape] svgToPolyShapes = cmdsToPolyShapes . toLineCommands . extractPath +-- | Extract all polygons from SVG nodes. Curves are approximated to +-- within the given tolerance. svgToPolygons :: Double -> SVG -> [Polygon] svgToPolygons tol = map (toPolygon . plPolygonify tol) . svgToPolyShapes where - toPolygon :: [Point Double] -> Polygon + toPolygon :: [RPoint] -> Polygon toPolygon = mkPolygon . - V.fromList . nub . map (\(Point x y) -> V2 (realToFrac x) (realToFrac y)) + V.fromList . nub . map (fmap realToFrac) cmdsToPolyShapes :: [LineCommand] -> [PolyShape] cmdsToPolyShapes [] = [] @@ -280,44 +291,41 @@ finalize acc $ worker newStart [] xs worker from acc (LineEnd orig:LineMove dst:xs) | from /= orig = - finalize ((toGPoint from, JoinLine):acc) $ + finalize ((from, JoinLine):acc) $ worker dst [] xs worker _from acc (LineEnd{}:LineMove dst:xs) = finalize acc $ worker dst [] xs worker from acc [LineEnd orig] | from /= orig = - finalize ((toGPoint from, JoinLine):acc) [] + finalize ((from, JoinLine):acc) [] worker _from acc [LineEnd{}] = finalize acc [] worker from acc (LineBezier [x]:xs) = - worker x ((toGPoint from, JoinLine) : acc) xs + worker x ((from, JoinLine) : acc) xs worker from acc (LineBezier [a,b]:xs) = - let quad = QuadBezier (toGPoint from) (toGPoint a) (toGPoint b) + let quad = QuadBezier from a b CubicBezier _ a' b' c' = quadToCubic quad - in worker from acc (LineBezier (map fromGPoint [a',b',c']):xs) + in worker from acc (LineBezier [a',b',c']:xs) worker from acc (LineBezier [a,b,c]:xs) = - worker c ((toGPoint from, JoinCurve (toGPoint a) (toGPoint b)) : acc) xs + worker c ((from, JoinCurve a b) : acc) xs worker _ _ _ = bad - toGPoint :: RPoint -> Point Double - toGPoint (V2 x y) = Point x y - fromGPoint :: Point Double -> RPoint - fromGPoint (Point x y) = V2 x y - +-- | Merge overlapping shapes. unionPolyShapes :: [PolyShape] -> [PolyShape] unionPolyShapes shapes = map PolyShape $ - union (map unPolyShape shapes) NonZero (polyShapeTolerance/10000) + union (map unPolyShape shapes) FillNonZero (polyShapeTolerance/10000) +-- | Merge overlapping shapes to within given tolerance. unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape] unionPolyShapes' tol shapes = map PolyShape $ - union (map unPolyShape shapes) NonZero tol + union (map unPolyShape shapes) FillNonZero tol --- True iff lhs is inside of rhs. --- lhs and rhs may not overlap. --- Implementation: Trace a vertical line through the origin of A and check --- of this line intersects and odd number of times on both sides of A. +-- | True iff lhs is inside of rhs. +-- lhs and rhs may not overlap. +-- Implementation: Trace a vertical line through the origin of A and check +-- of this line intersects and odd number of times on both sides of A. isInsideOf :: PolyShape -> PolyShape -> Bool lhs `isInsideOf` rhs = odd (length upHits) && odd (length downHits) @@ -325,7 +333,7 @@ (upHits, downHits) = polyIntersections origin rhs origin = polyShapeOrigin lhs -polyIntersections :: DPoint -> PolyShape -> ([DPoint],[DPoint]) +polyIntersections :: RPoint -> PolyShape -> ([RPoint],[RPoint]) polyIntersections origin rhs = (nub $ concatMap (intersections rayUp) curves ,nub $ concatMap (intersections rayDown) curves) @@ -335,15 +343,16 @@ intersections line bs = map (evalBezier bs . fst) (bezierIntersection bs line polyShapeTolerance) limit = 1000 - rayUp = CubicBezier origin origin origin (Point limit limit) - rayDown = CubicBezier origin origin origin (Point (-limit) (-limit)) + rayUp = CubicBezier origin origin origin (V2 limit limit) + rayDown = CubicBezier origin origin origin (V2 (-limit) (-limit)) -polyShapeOrigin :: PolyShape -> Point Double +polyShapeOrigin :: PolyShape -> V2 Double polyShapeOrigin (PolyShape closedPath) = case closedPath of - ClosedPath [] -> Point 0 0 + ClosedPath [] -> V2 0 0 ClosedPath ((start,_):_) -> start +-- | Find holes and group them with their parent. plGroupShapes :: [PolyShape] -> [PolyShapeWithHoles] plGroupShapes = worker where @@ -364,6 +373,7 @@ instance Eq PolyShape where a == b = plCurves a == plCurves b +-- | Cut out holes. mergePolyShapeHoles :: PolyShapeWithHoles -> PolyShape mergePolyShapeHoles (PolyShapeWithHoles parent []) = parent mergePolyShapeHoles (PolyShapeWithHoles parent (child:children)) = @@ -413,12 +423,12 @@ [x2p] ) where - vect = (childOrigin ^-^ p) ^* 0 -- 0.0001 - vectL = rotate90L $* vect - vectR = rotate90R $* vect + -- vect = (childOrigin - p) * 0 -- 0.0001 + vectL = 0 -- rotate90L $* vect + vectR = 0 -- rotate90R $* vect score = vectorDistance childOrigin p childOrigin = polyShapeOrigin child - childOrigin' = childOrigin ^-^ vectL + childOrigin' = childOrigin - vectL (pHead:pTail) = plCurves parent childCurves = plCurves child @@ -426,16 +436,17 @@ (a2p, p2b') = splitBezier pHead pParam p2b = case p2b' of - CubicBezier a b c d -> CubicBezier (a ^-^ vectL) b c d + CubicBezier a b c d -> CubicBezier (a - vectL) b c d p = evalBezier pHead pParam -- straight line to child origin - p2x = lineBetween (p ^-^ vectR) childOrigin + p2x = lineBetween (p - vectR) childOrigin -- straight line from child origin x2p = lineBetween childOrigin' p lineBetween a = CubicBezier a a a +-- | Destruct a polyshape into constituent curves. plCurves :: PolyShape -> [CubicBezier Double] plCurves = closedPathCurves . unPolyShape diff --git a/src/Reanimate/Povray.hs b/src/Reanimate/Povray.hs --- a/src/Reanimate/Povray.hs +++ b/src/Reanimate/Povray.hs @@ -1,4 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} +{-| + [Povray](http://povray.org/) is a scriptable raytracer. All povray functions + are cached and will reuse images when scripts stay the same. +-} module Reanimate.Povray ( povray , povrayQuick @@ -10,20 +14,19 @@ , povrayExtreme' ) where -import Codec.Picture.Png -import qualified Data.ByteString as B +import Data.Hashable import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Graphics.SvgTree (Tree (..)) import Reanimate.Cache +import Reanimate.Constants import Reanimate.Misc -import Reanimate.Raster import Reanimate.Parameters +import Reanimate.Raster import Reanimate.Svg.Constructors import System.FilePath (replaceExtension, (<.>)) import System.IO.Unsafe (unsafePerformIO) -import Data.Hashable povrayRaw :: [String] -> Text -> Tree povrayRaw args script = @@ -33,39 +36,58 @@ povrayRaw' args script = unsafePerformIO $ mkPovrayImage' args script +-- | Run the povray raytracer with a default resolution of 320x180 +-- and antialiasing enabled. The resulting image is scaled to fit +-- the screen exactly. povray :: [String] -> Text -> Tree povray args = povrayRaw (["+H180","+W320", "+A"] ++ args) +-- | Run the povray raytracer with a default resolution of 320x180 +-- and antialiasing enabled. The FilePath points to a PNG file +-- containing the resulting image. povray' :: [String] -> Text -> FilePath povray' args = povrayRaw' (["+H180","+W320", "+A"] ++ args) +-- | Run the povray raytracer with a default resolution of 320x180 +-- but without antialiasing. The resulting image is scaled to fit +-- the screen exactly. povrayQuick :: [String] -> Text -> Tree povrayQuick args = povrayRaw (["+H180","+W320"] ++ args) +-- | Run the povray raytracer with a default resolution of 320x180 +-- but without antialiasing. The FilePath points to a PNG file +-- containing the resulting image. povrayQuick' :: [String] -> Text -> FilePath povrayQuick' args = povrayRaw' (["+H180","+W320"] ++ args) +-- | Run the povray raytracer with a default resolution of 1440x2560 +-- and antialiasing enabled. The FilePath points to a PNG file +-- containing the resulting image. povraySlow :: [String] -> Text -> Tree povraySlow args = povrayRaw (["+H1440","+W2560", "+A"] ++ args) +-- | Run the povray raytracer with a default resolution of 1440x2560 +-- and antialiasing enabled. The FilePath points to a PNG file +-- containing the resulting image. povraySlow' :: [String] -> Text -> FilePath povraySlow' args = povrayRaw' (["+H1440","+W2560", "+A"] ++ args) +-- | Run the povray raytracer with a default resolution of 2160x3840 +-- and antialiasing enabled. The FilePath points to a PNG file +-- containing the resulting image. povrayExtreme :: [String] -> Text -> Tree povrayExtreme args = povrayRaw (["+H2160","+W3840", "+A"] ++ args) +-- | Run the povray raytracer with a default resolution of 2160x3840 +-- and antialiasing enabled. The FilePath points to a PNG file +-- containing the resulting image. povrayExtreme' :: [String] -> Text -> FilePath povrayExtreme' args = povrayRaw' (["+H2160","+W3840", "+A"] ++ args) mkPovrayImage :: [String] -> Text -> IO Tree mkPovrayImage _ script | pNoExternals = pure $ mkText script -mkPovrayImage args script = do - out <- mkPovrayImage' args script - -- return $ center $ scaleToSize 16 9 $ embedImageFile out - png <- B.readFile out - case decodePng png of - Left{} -> error "bad image" - Right img -> return $ center $ scaleToSize 16 9 $ embedDynamicImage img +mkPovrayImage args script = + mkImage screenWidth screenHeight <$> mkPovrayImage' args script mkPovrayImage' :: [String] -> Text -> IO FilePath mkPovrayImage' _ _ | pNoExternals = pure "/povray/has/been/disabled" @@ -75,5 +97,5 @@ T.writeFile pov_file script runCmd exec (args ++ ["-D","+UA", pov_file, "+o"++target]) where - template = show (hash key) <.> "png" + template = encodeInt (hash key) <.> "png" key = T.concat (script:map T.pack args) diff --git a/src/Reanimate/Raster.hs b/src/Reanimate/Raster.hs --- a/src/Reanimate/Raster.hs +++ b/src/Reanimate/Raster.hs @@ -1,3 +1,14 @@ +{-| +Module : Reanimate.Raster +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +Tools for generating, manipulating, and embedding raster images. + +-} module Reanimate.Raster ( mkImage -- :: Double -> Double -> FilePath -> SVG , cacheImage -- :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath @@ -119,6 +130,8 @@ target = pRootDirectory encodeInt hashPath <.> takeExtension path hashPath = hash path +-- | Write in-memory image to cache file if (and only if) such cache file doesn't +-- already exist. cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath cacheImage key gen = unsafePerformIO $ cacheFile template $ \path -> writePng path gen @@ -126,6 +139,8 @@ -- Warning: Caching svg elements with links to external objects does -- not work. 2020-06-01 +-- | Same as 'prerenderSvg' but returns the location of the rendered image +-- as a FilePath. prerenderSvgFile :: Hashable a => a -> Width -> Height -> SVG -> FilePath prerenderSvgFile key width height svg = unsafePerformIO $ cacheFile template $ \path -> do @@ -139,6 +154,11 @@ (Just $ Px $ fromIntegral height) svg +-- | Render SVG node to a PNG file and return a new node containing +-- that image. For static SVG nodes, this can hugely improve performance. +-- The first argument is the key that determines SVG uniqueness. It +-- is entirely your responsibility to ensure that all keys are unique. +-- If they are not, you will be served stale results from the cache. prerenderSvg :: Hashable a => a -> SVG -> SVG prerenderSvg key = mkImage screenWidth screenHeight . prerenderSvgFile key pWidth pHeight @@ -232,17 +252,17 @@ Left{} -> error "bad image" Right img -> return img --- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons. +-- | Use \'potrace\' to trace edges in a raster image and convert them to SVG polygons. vectorize :: FilePath -> SVG vectorize = vectorize_ [] --- | Same as 'vectorize' but takes a list of arguments for 'potrace'. +-- | Same as 'vectorize' but takes a list of arguments for \'potrace\'. vectorize_ :: [String] -> FilePath -> SVG vectorize_ _ path | pNoExternals = mkText $ T.pack path vectorize_ args path = unsafePerformIO $ do root <- getXdgDirectory XdgCache "reanimate" createDirectoryIfMissing True root - let svgPath = root show key <.> "svg" + let svgPath = root encodeInt key <.> "svg" hit <- doesFileExist svgPath unless hit $ withSystemTempFile "file.svg" $ \tmpSvgPath svgH -> withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do @@ -289,7 +309,7 @@ engine <- requireRaster pRaster applyRaster engine svgPath where - template = show (hash rendered) <.> "png" + template = encodeInt (hash rendered) <.> "png" rendered = renderSvg (Just $ Px $ fromIntegral width) (Just $ Px $ fromIntegral height) svg diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -1,8 +1,20 @@ {-# LANGUAGE MultiWayIf #-} +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX + +Internal tools for rastering SVGs and rendering videos. You are unlikely +to ever directly use the functions in this module. + +-} module Reanimate.Render ( render - , renderSvgs -- :: Animation -> IO () + , renderSvgs , renderSnippets -- :: Animation -> IO () + , renderOneFrame , Format(..) , Raster(..) , Width, Height, FPS @@ -13,13 +25,13 @@ import Control.Concurrent import Control.Exception -import Control.Monad (forM_, forever, unless, void, when) +import Control.Monad (forM_, forever, unless, void, when) import Data.Either import Data.Function -import qualified Data.Text as T -import qualified Data.Text.IO as T +import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Time -import Graphics.SvgTree (Number (..)) +import Graphics.SvgTree (Number (..)) import Numeric import Reanimate.Animation import Reanimate.Driver.Check @@ -28,24 +40,40 @@ import Reanimate.Parameters import System.Console.ANSI.Codes import System.Exit -import System.FilePath ((), replaceExtension) +import System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile) +import System.Directory +import System.FilePath (replaceExtension, (<.>), ()) import System.IO -import Text.Printf (printf) +import Text.Printf (printf) -renderSvgs :: Animation -> IO () -renderSvgs ani = do +idempotentFile :: FilePath -> IO () -> IO () +idempotentFile path action = do + _ <- withTryFileLock lockFile Exclusive $ \lock -> do + haveFile <- doesFileExist path + unless haveFile action + unlockFile lock + _ <- try (removeFile lockFile) :: IO (Either SomeException ()) + return () + return () + where + lockFile = path <.> "lock" + +-- | Generate SVGs at 60fps and put them in a folder. +renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO () +renderSvgs folder offset _prettyPrint ani = do print frameCount lock <- newMVar () - handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth -> do - let -- frame = frameAt (recip (fromIntegral rate-1) * fromIntegral nth) ani + handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do + let nth = (nth'+offset) `mod` frameCount now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth frame = frameAt (if frameCount <= 1 then 0 else now) ani svg = renderSvg Nothing Nothing frame - _ <- evaluate (length svg) + path = folder show nth <.> "svg" + + idempotentFile path $ writeFile path svg withMVar lock $ \_ -> do - putStr (show nth) - T.putStrLn $ T.concat . T.lines . T.pack $ svg + print nth hFlush stdout where rate = 60 @@ -54,7 +82,33 @@ hPutStrLn stderr msg exitWith (ExitFailure 1) +-- | Select a single frame that doesn't already exist in the output +-- folder and render it. If all frames have been rendered, print "Done". +renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO () +renderOneFrame folder offset _prettyPrint rate ani = + worker (frameOrder rate frameCount) + where + worker [] = putStrLn "Done" + worker (x:xs) = do + let nth = (x+offset) `mod` frameCount + now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + frame = frameAt (if frameCount <= 1 then 0 else now) ani + svg = renderSvg Nothing Nothing frame + path = folder show nth <.> "svg" + tmpPath = path <.> "tmp" + haveFile <- doesFileExist path + if haveFile + then worker xs + else do + writeFile tmpPath svg + renameOrCopyFile tmpPath path + print nth + frameCount = round (duration ani * fromIntegral rate) :: Int + -- XXX: Merge with 'renderSvgs' +-- | Render 10 frames and print them to stdout. Used for testing. +-- +-- XXX: Not related to the snippets in the playground. renderSnippets :: Animation -> IO () renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth @@ -76,6 +130,7 @@ [0, nthFrame .. nFrames - 1] where isSeen x = any (\y -> x `mod` y == 0) seen +-- | Video formats supported by reanimate. data Format = RenderMp4 | RenderGif | RenderWebm deriving (Show) @@ -106,6 +161,7 @@ -- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String] -- gifArguments fps progress template target = +-- | Render animation to a video file with given parameters. render :: Animation -> FilePath @@ -256,7 +312,7 @@ where isValidRaster RasterNone = False isValidRaster RasterAuto = False - isValidRaster _ = True + isValidRaster _ = True width = Just $ Px $ fromIntegral width_ height = Just $ Px $ fromIntegral height_ @@ -290,6 +346,8 @@ rasterTemplate RasterAuto = "render-%05d.svg" rasterTemplate _ = "render-%05d.png" +-- | Resolve RasterNone and RasterAuto. If no valid raster can +-- be found, exit with an error message. requireRaster :: Raster -> IO Raster requireRaster raster = do raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster) @@ -302,6 +360,8 @@ exitWith (ExitFailure 1) _ -> pure raster' +-- | Resolve RasterNone and RasterAuto. If no valid raster can +-- be found, return RasterNone. selectRaster :: Raster -> IO Raster selectRaster RasterAuto = do rsvg <- hasRSvg @@ -314,6 +374,8 @@ | otherwise -> pure RasterNone selectRaster r = pure r +-- | Convert SVG file to a PNG file with selected raster engine. If +-- raster engine is RasterAuto or RasterNone, do nothing. applyRaster :: Raster -> FilePath -> IO () applyRaster RasterNone _ = return () applyRaster RasterAuto _ = return () diff --git a/src/Reanimate/Scene.hs b/src/Reanimate/Scene.hs --- a/src/Reanimate/Scene.hs +++ b/src/Reanimate/Scene.hs @@ -1,11 +1,9 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} {-| Module : Reanimate.Scene -Description : Imperative animation API Copyright : Written by David Himmelstrup License : Unlicense Maintainer : lemmih@gmail.com @@ -19,6 +17,7 @@ ( -- * Scenes Scene , ZIndex + , scene -- :: (forall s. Scene s a) -> Animation , sceneAnimation -- :: (forall s. Scene s a) -> Animation , play -- :: Animation -> Scene s () , fork -- :: Scene s a -> Scene s a @@ -61,9 +60,19 @@ , spriteScope -- :: Scene s a -> Scene s a -- * Object API - , Renderable(..) , Object , ObjectData + , oNew + , newObject + , oModify + , oModifyS + , oRead + , oTween + , oTweenS + , oTweenV + , oTweenVS + , Renderable(..) + -- ** Object Properties , oTranslate , oSVG , oContext @@ -88,15 +97,7 @@ , oLeftX , oRightX , oCenterXY - , newObject , oValue - , oModify - , oModifyS - , oRead - , oTween - , oTweenS - , oTweenV - , oTweenVS -- ** Graphics object methods , oShow @@ -127,7 +128,6 @@ -- * ST internals , liftST - , asAnimation -- :: (forall s. Scene s a) -> Scene s Animation , transitionO , evalScene ) @@ -159,6 +159,8 @@ -- [(Time, Animation, ZIndex)] -- Map Time [(Animation, ZIndex)] type Gen s = ST s (Duration -> Time -> (SVG, ZIndex)) +-- | A 'Scene' represents a sequence of animations and variables +-- that change over time. newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) } instance Functor (Scene s) where @@ -183,14 +185,21 @@ instance MonadFix (Scene s) where mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t) +-- | Lift an ST action into the Scene monad. liftST :: ST s a -> Scene s a liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, []) +-- | Evaluate the value of a scene. evalScene :: (forall s . Scene s a) -> a evalScene action = runST $ do (val, _, _ , _) <- unM action 0 return val +-- | Render a 'Scene' to an 'Animation'. +scene :: (forall s . Scene s a) -> Animation +scene = sceneAnimation + +-- | Render a 'Scene' to an 'Animation'. sceneAnimation :: (forall s . Scene s a) -> Animation sceneAnimation action = runST (do @@ -643,7 +652,22 @@ let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex) ) --- Destroy all local sprites at the end of a scene. +-- | Destroy all local sprites at the end of a scene. +-- +-- Example: +-- +-- > do -- the rect lives through the entire 3s animation +-- > newSpriteSVG_ $ translate (-3) 0 $ mkRect 4 4 +-- > wait 1 +-- > spriteScope $ do +-- > -- the circle only lives for 1 second. +-- > local <- newSpriteSVG $ translate 3 0 $ mkCircle 2 +-- > spriteE local $ overBeginning 0.3 fadeInE +-- > spriteE local $ overEnding 0.3 fadeOutE +-- > wait 1 +-- > wait 1 +-- +-- <> spriteScope :: Scene s a -> Scene s a spriteScope (M action) = M $ \t -> do (a, s, p, gens) <- action t @@ -657,10 +681,13 @@ else (None, 0) asAnimation :: (forall s'. Scene s' a) -> Scene s Animation -asAnimation scene = do +asAnimation s = do now <- queryNow - return $ dropA now (sceneAnimation (wait now >> scene)) + return $ dropA now (sceneAnimation (wait now >> s)) +-- | Apply a transformation with a given overlap. This makes sure +-- to keep timestamps intact such that events can still be timed +-- by transcripts. transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s () transitionO t o a b = do aA <- asAnimation a @@ -675,16 +702,22 @@ ------------------------------------------------------- -- Objects +-- | Objects can be any Haskell structure as long as it can be rendered to SVG. class Renderable a where toSVG :: a -> SVG instance Renderable Tree where toSVG = id +-- | Objects are SVG nodes (represented as Haskell values) with +-- identity, location, and several other properties that can +-- change over time. data Object s a = Object { objectSprite :: Sprite s , objectData :: Var s (ObjectData a) } + +-- | Container for object properties. data ObjectData a = ObjectData { _oTranslate :: (Double, Double) , _oValueRef :: a @@ -703,41 +736,60 @@ -- Basic lenses +-- FIXME: Maybe 'position' is a better name. +-- | Object position. Default: \<0,0\> oTranslate :: Lens' (ObjectData a) (Double, Double) oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val } +-- | Rendered SVG node of an object. Does not include context +-- or object properties. Read-only. oSVG :: Getter (ObjectData a) SVG oSVG = to _oSVG +-- | Custom render context. Is applied to the object for every +-- frame that it is shown. oContext :: Lens' (ObjectData a) (SVG -> SVG) oContext = lens _oContext $ \obj val -> obj { _oContext = val } +-- | Object margins (top, right, bottom, left) in local units. oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double) oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val } +-- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate, +-- width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox` +-- and has the same limitations. oBB :: Getter (ObjectData a) (Double, Double, Double, Double) oBB = to _oBB +-- | Object opacity. Default: 1 oOpacity :: Lens' (ObjectData a) Double oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val } +-- | Toggle for whether or not the object should be rendered. +-- Default: False oShown :: Lens' (ObjectData a) Bool oShown = lens _oShown $ \obj val -> obj { _oShown = val } +-- | Object's z-index. oZIndex :: Lens' (ObjectData a) Int oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val } +-- | Easing function used when modifying object properties. +-- Default: @'Reanimate.Ease.curveS' 2@ oEasing :: Lens' (ObjectData a) Signal oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val } +-- | Object's scale. Default: 1 oScale :: Lens' (ObjectData a) Double oScale = lens _oScale $ \obj val -> obj { _oScale = val } +-- | Origin point for scaling. Default: \<0,0\> oScaleOrigin :: Lens' (ObjectData a) (Double, Double) oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val } -- Smart lenses +-- | Lens for the source value contained in an object. oValue :: Renderable a => Lens' (ObjectData a) a oValue = lens _oValueRef $ \obj newVal -> let svg = toSVG newVal @@ -746,6 +798,7 @@ , _oSVG = svg , _oBB = boundingBox svg } +-- | Derived location of the top-most point of an object + margin. oTopY :: Lens' (ObjectData a) Double oTopY = lens getter setter where @@ -758,6 +811,7 @@ setter obj val = obj & (oTranslate . _2) +~ val-getter obj +-- | Derived location of the bottom-most point of an object + margin. oBottomY :: Lens' (ObjectData a) Double oBottomY = lens getter setter where @@ -769,6 +823,7 @@ setter obj val = obj & (oTranslate . _2) +~ val-getter obj +-- | Derived location of the left-most point of an object + margin. oLeftX :: Lens' (ObjectData a) Double oLeftX = lens getter setter where @@ -780,6 +835,7 @@ setter obj val = obj & (oTranslate . _1) +~ val-getter obj +-- | Derived location of the right-most point of an object + margin. oRightX :: Lens' (ObjectData a) Double oRightX = lens getter setter where @@ -792,6 +848,7 @@ setter obj val = obj & (oTranslate . _1) +~ val-getter obj +-- | Derived location of an object's center point. oCenterXY :: Lens' (ObjectData a) (Double, Double) oCenterXY = lens getter setter where @@ -807,59 +864,80 @@ obj & (oTranslate . _1) +~ dx-x & (oTranslate . _2) +~ dy-y +-- | Object's top margin. oMarginTop :: Lens' (ObjectData a) Double oMarginTop = oMargin . _1 +-- | Object's right margin. oMarginRight :: Lens' (ObjectData a) Double oMarginRight = oMargin . _2 +-- | Object's bottom margin. oMarginBottom :: Lens' (ObjectData a) Double oMarginBottom = oMargin . _3 +-- | Object's left margin. oMarginLeft :: Lens' (ObjectData a) Double oMarginLeft = oMargin . _4 +-- | Object's minimal X-coordinate.. oBBMinX :: Getter (ObjectData a) Double oBBMinX = oBB . _1 +-- | Object's minimal Y-coordinate.. oBBMinY :: Getter (ObjectData a) Double oBBMinY = oBB . _2 +-- | Object's width without margin. oBBWidth :: Getter (ObjectData a) Double oBBWidth = oBB . _3 +-- | Object's height without margin. oBBHeight :: Getter (ObjectData a) Double oBBHeight = oBB . _4 +------------------------------------------------------------------------------- +-- Object modifiers + +-- | Modify object properties. oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s () oModify o fn = modifyVar (objectData o) fn +-- | Modify object properties using a stateful API. oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s () oModifyS o fn = oModify o (execState fn) +-- | Query object property. oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b -oRead o l = do - v <- readVar (objectData o) - return $ view l v +oRead o l = view l <$> readVar (objectData o) +-- | Modify object properties over a set duration. oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () oTween o d fn = do -- Read 'easing' var here instead of taking it from 'v'. -- This allows different easing functions even at the same timestamp. ease <- oRead o oEasing tweenVar (objectData o) d (\v t -> fn (ease t) v) - -- tweenVar ref d (\v t -> fn t v) --- oTweenS :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () +-- | Modify object properties over a set duration using a stateful API. oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s () oTweenS o d fn = oTween o d (\t -> execState (fn t)) +-- | Modify object value over a set duration. This is a convenience function +-- for modifying `oValue`. oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s () oTweenV o d fn = oTween o d (\t -> oValue %~ fn t) +-- | Modify object value over a set duration using a stateful API. This is a +-- convenience function for modifying `oValue`. oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s () oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t)) +-- | Create new object. +oNew :: Renderable a => a -> Scene s (Object s a) +oNew = newObject + +-- | Create new object. newObject :: Renderable a => a -> Scene s (Object s a) newObject val = do ref <- newVar ObjectData @@ -888,28 +966,152 @@ withGroupOpacity _oOpacity $ _oContext _oSVG else None + spriteModify sprite $ do + ~ObjectData{_oZIndex=z} <- unVar ref + pure $ \(img,_) -> (img,z) return Object { objectSprite = sprite , objectData = ref } where svg = toSVG val +------------------------------------------------------------------------------- +-- Graphical transformations + +-- | Instantly show object. +oShow :: Object s a -> Scene s () +oShow o = oModify o $ oShown .~ True + +-- | Instantly hide object. +oHide :: Object s a -> Scene s () +oHide o = oModify o $ oShown .~ False + +-- | Fade in object over a set duration. +oFadeIn :: Object s a -> Duration -> Scene s () +oFadeIn o d = do + oModify o $ + oShown .~ True + oTweenS o d $ \t -> + oOpacity *= t + +-- | Fade out object over a set duration. +oFadeOut :: Object s a -> Duration -> Scene s () +oFadeOut o d = do + oModify o $ + oShown .~ True + oTweenS o d $ \t -> + oOpacity *= 1-t + +-- | Scale in object over a set duration. +oGrow :: Object s a -> Duration -> Scene s () +oGrow o d = do + oModify o $ + oShown .~ True + oTweenS o d $ \t -> + oScale *= t + +-- | Scale out object over a set duration. +oShrink :: Object s a -> Duration -> Scene s () +oShrink o d = + oTweenS o d $ \t -> + oScale *= 1-t + +-- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'. +-- | Morph source object into target object over a set duration. +oTransform :: Object s a -> Object s b -> Duration -> Scene s () +oTransform src dst d = do + srcSvg <- oRead src oSVG + srcCtx <- oRead src oContext + srcEase <- oRead src oEasing + srcLoc <- oRead src oTranslate + oModify src $ oShown .~ False + + dstSvg <- oRead dst oSVG + dstCtx <- oRead dst oContext + dstLoc <- oRead dst oTranslate + + m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg) + oModifyS m $ do + oShown .= True + oEasing .= srcEase + oTranslate .= srcLoc + fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc + oTweenV m d $ \t -> morphDelta .~ t + oModify m $ oShown .~ False + oModify dst $ oShown .~ True + where + moveTo t (dstX, dstY) (srcX, srcY) = + (fromToS srcX dstX t, fromToS srcY dstY t) + + +------------------------------------------------------------------------------- +-- Built-in objects + +-- | Basic object mapping to \ in SVG. newtype Circle = Circle {_circleRadius :: Double} + +-- | Circle radius in local units. +circleRadius :: Lens' Circle Double +circleRadius = iso _circleRadius Circle + instance Renderable Circle where toSVG (Circle r) = mkCircle r +-- | Basic object mapping to \ in SVG. data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double } + +-- | Rectangle width in local units. +rectWidth :: Lens' Rectangle Double +rectWidth = lens _rectWidth $ \obj val -> obj{_rectWidth=val} + +-- | Rectangle height in local units. +rectHeight :: Lens' Rectangle Double +rectHeight = lens _rectHeight $ \obj val -> obj{_rectHeight=val} + instance Renderable Rectangle where toSVG (Rectangle w h) = mkRect w h +-- | Object representing an interpolation between SVG nodes. data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG } + +-- | Control variable for the interpolation. A value of 0 gives the +-- source SVG and 1 gives the target svg. +morphDelta :: Lens' Morph Double +morphDelta = lens _morphDelta $ \obj val -> obj{_morphDelta = val} + +-- | Source shape. +morphSrc :: Lens' Morph SVG +morphSrc = lens _morphSrc $ \obj val -> obj{_morphSrc = val} + +-- | Target shape. +morphDst :: Lens' Morph SVG +morphDst = lens _morphDst $ \obj val -> obj{_morphDst = val} + instance Renderable Morph where toSVG (Morph t src dst) = morph linear src dst t +-- | Cameras can take control of objects and manipulate them +-- with convenient pan and zoom operations. data Camera = Camera instance Renderable Camera where toSVG Camera = None +-- | Connect an object to a camera such that +-- camera settings (position, zoom, and rotation) is +-- applied to the object. +-- +-- Example +-- +-- > do cam <- newObject Camera +-- > circ <- newObject $ Circle 2 +-- > oModifyS circ $ +-- > oContext .= withFillOpacity 1 . withFillColor "blue" +-- > oShow circ +-- > cameraAttach cam circ +-- > cameraZoom cam 1 2 +-- > cameraZoom cam 1 1 +-- +-- <> cameraAttach :: Object s Camera -> Object s a -> Scene s () cameraAttach cam obj = spriteModify (objectSprite obj) $ do @@ -923,6 +1125,25 @@ uncurry translate (camData^.oScaleOrigin & both %~ negate) in (ctx svg, zindex) +-- | +-- +-- Example +-- +-- > do cam <- newObject Camera +-- > circ <- newObject $ Circle 2; oShow circ +-- > oModify circ $ oTranslate .~ (-3,0) +-- > box <- newObject $ Rectangle 4 4; oShow box +-- > oModify box $ oTranslate .~ (3,0) +-- > cameraAttach cam circ +-- > cameraAttach cam box +-- > cameraFocus cam (-3,0) +-- > cameraZoom cam 2 2 -- Zoom in +-- > cameraZoom cam 2 1 -- Zoom out +-- > cameraFocus cam (3,0) +-- > cameraZoom cam 2 2 -- Zoom in +-- > cameraZoom cam 2 1 -- Zoom out +-- +-- <> cameraFocus :: Object s Camera -> (Double, Double) -> Scene s () cameraFocus cam (x,y) = do (ox, oy) <- oRead cam oScaleOrigin @@ -933,85 +1154,27 @@ oTranslate .= newLocation oScaleOrigin .= (x,y) +-- | Instantaneously set camera zoom level. cameraSetZoom :: Object s Camera -> Double -> Scene s () cameraSetZoom cam s = oModifyS cam $ oScale .= s +-- | Change camera zoom level over a set duration. cameraZoom :: Object s Camera -> Duration -> Double -> Scene s () cameraZoom cam d s = oTweenS cam d $ \t -> oScale %= \v -> fromToS v s t +-- | Instantaneously set camera location. cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s () cameraSetPan cam location = oModifyS cam $ do oTranslate .= location +-- | Change camera location over a set duration. cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s () cameraPan cam d (x,y) = oTweenS cam d $ \t -> do oTranslate._1 %= \v -> fromToS v x t oTranslate._2 %= \v -> fromToS v y t - -makeLenses ''Circle -makeLenses ''Rectangle -makeLenses ''Morph - -oShow :: Object s a -> Scene s () -oShow o = oModify o $ oShown .~ True - -oHide :: Object s a -> Scene s () -oHide o = oModify o $ oShown .~ False - -oFadeIn :: Object s a -> Duration -> Scene s () -oFadeIn o d = do - oModify o $ - oShown .~ True - oTweenS o d $ \t -> - oOpacity *= t - -oFadeOut :: Object s a -> Duration -> Scene s () -oFadeOut o d = do - oModify o $ - oShown .~ True - oTweenS o d $ \t -> - oOpacity *= 1-t - -oGrow :: Object s a -> Duration -> Scene s () -oGrow o d = do - oModify o $ - oShown .~ True - oTweenS o d $ \t -> - oScale *= t - -oShrink :: Object s a -> Duration -> Scene s () -oShrink o d = - oTweenS o d $ \t -> - oScale *= 1-t - --- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'. -oTransform :: Object s a -> Object s b -> Duration -> Scene s () -oTransform src dst d = do - srcSvg <- oRead src oSVG - srcCtx <- oRead src oContext - srcEase <- oRead src oEasing - srcLoc <- oRead src oTranslate - oModify src $ oShown .~ False - - dstSvg <- oRead dst oSVG - dstCtx <- oRead dst oContext - dstLoc <- oRead dst oTranslate - - m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg) - oModifyS m $ do - oShown .= True - oEasing .= srcEase - oTranslate .= srcLoc - fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc - oTweenV m d $ \t -> morphDelta .~ t - oModify m $ oShown .~ False - oModify dst $ oShown .~ True - where - moveTo t (dstX, dstY) (srcX, srcY) = - (fromToS srcX dstX t, fromToS srcY dstY t) diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs --- a/src/Reanimate/Svg.hs +++ b/src/Reanimate/Svg.hs @@ -1,4 +1,11 @@ {-# LANGUAGE LambdaCase #-} +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Svg ( module Reanimate.Svg , module Reanimate.Svg.Constructors @@ -20,6 +27,13 @@ import Reanimate.Svg.Unuse import qualified Reanimate.Transform as Transform +-- | Remove transformations (such as translations, rotations, scaling) +-- and apply them directly to the SVG nodes. Note, this function +-- may convert nodes (such as Circle or Rect) to paths. Also note +-- that /does/ change how the SVG is rendered. Particularly, stroke +-- width is affected by directly applying scaling. +-- +-- @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@ lowerTransformations :: Tree -> Tree lowerTransformations = worker False Transform.identity where @@ -55,6 +69,7 @@ -- If we haven't tried to pathify, run pathify only once. _ -> worker True m (pathify t) +-- | Remove all @id@ attributes. lowerIds :: Tree -> Tree lowerIds = mapTree worker where @@ -62,6 +77,7 @@ worker t@PathTree{} = t & attrId .~ Nothing worker t = t +-- | Optimize SVG tree without affecting how it is rendered. simplify :: Tree -> Tree simplify root = case worker root of @@ -89,6 +105,11 @@ | null (g^.groupChildren) = [] dropNulls t = [t] +-- | Separate grouped items. This is required by clip nodes. +-- +-- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1]) +-- = [ withFillColor "blue" $ mkCircle 1 +-- , withFillColor "blue" $ mkRect 1 1 ]@ removeGroups :: Tree -> [Tree] removeGroups = worker defaultSvg where @@ -111,6 +132,7 @@ | null (g^.groupChildren) = [] dropNulls t = [t] +-- | Extract all path commands from a node (and its children) and concatenate them. extractPath :: Tree -> [PathCommand] extractPath = worker . simplify . lowerTransformations . pathify where @@ -118,6 +140,10 @@ worker (PathTree p) = p^.pathDefinition worker _ = [] +-- | Map over indexed symbols. +-- +-- @withSubglyphs [0,2] (scale 2) (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2]) +-- = mkGroup [scale 2 (mkCircle 1), mkRect 2, scale 2 (mkEllipse 1 2)]@ withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree withSubglyphs target fn = \t -> evalState (worker t) 0 where @@ -142,6 +168,10 @@ then return $ fn svg else return svg +-- | Split symbols. +-- +-- @splitGlyphs [0,2] (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2]) +-- = ([mkRect 2], [mkCircle 1, mkEllipse 1 2])@ splitGlyphs :: [Int] -> Tree -> (Tree, Tree) splitGlyphs target = \t -> let (_, l, r) = execState (worker id t) (0, [], []) @@ -182,6 +212,7 @@ [ (\svg -> svg, ) , (\svg -> svg, )] -} +-- | Split symbols and include their context and drawing attributes. svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)] svgGlyphs = worker id defaultSvg where @@ -287,6 +318,7 @@ Num d -> Just d _ -> Nothing +-- | Map over all recursively-found path commands. mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG mapSvgPaths fn = mapTree worker where @@ -296,10 +328,12 @@ path & pathDefinition %~ fn t -> t +-- | Map over all recursively-found line commands. mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands) -- Only maps points in paths +-- | Map over all line command control points. mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG mapSvgPoints fn = mapSvgLines (map worker) where @@ -307,6 +341,7 @@ worker (LineBezier ps) = LineBezier (map fn ps) worker (LineEnd p) = LineEnd (fn p) +-- | Convert coordinate system from degrees to radians. svgPointsToRadians :: SVG -> SVG svgPointsToRadians = mapSvgPoints worker where diff --git a/src/Reanimate/Svg/BoundingBox.hs b/src/Reanimate/Svg/BoundingBox.hs --- a/src/Reanimate/Svg/BoundingBox.hs +++ b/src/Reanimate/Svg/BoundingBox.hs @@ -1,17 +1,28 @@ -module Reanimate.Svg.BoundingBox where +{-| + Bounding-boxes can be immensely useful for aligning objects + but they are not part of the SVG specification and cannot be + computed for all SVG nodes. In particular, you'll get bad results + when asking for the bounding boxes of Text nodes (because fonts + are difficult), clipped nodes, and filtered nodes. +-} +module Reanimate.Svg.BoundingBox + ( boundingBox + , svgHeight + , svgWidth + ) where -import Control.Arrow ((***)) -import Control.Lens ((^.)) +import Control.Arrow ((***)) +import Control.Lens ((^.)) import Data.List -import Data.Maybe (mapMaybe) -import Graphics.SvgTree hiding (height, line, path, use, - width) -import Linear.V2 hiding (angle) +import Data.Maybe (mapMaybe) +import qualified Data.Vector.Unboxed as V +import qualified Geom2D.CubicBezier.Linear as Bezier +import Graphics.SvgTree hiding (height, line, path, use, width) +import Linear.V2 hiding (angle) import Linear.Vector import Reanimate.Constants import Reanimate.Svg.LineCommand -import qualified Reanimate.Transform as Transform --- import qualified Geom2D.CubicBezier as Bezier +import qualified Reanimate.Transform as Transform -- | Return bounding box of SVG tree. -- The four numbers returned are (minimal X-coordinate, minimal Y-coordinate, width, height) @@ -30,16 +41,21 @@ worker (minx, miny, maxx, maxy) (V2 x y) = (min minx x, min miny y, max maxx x, max maxy y) +-- | Height of SVG node in local units (not pixels). Computed on best-effort basis +-- and will not give accurate results for all SVG nodes. svgHeight :: Tree -> Double svgHeight t = h where (_x, _y, _w, h) = boundingBox t +-- | Width of SVG node in local units (not pixels). Computed on best-effort basis +-- and will not give accurate results for all SVG nodes. svgWidth :: Tree -> Double svgWidth t = w where (_x, _y, w, _h) = boundingBox t +-- | Sampling of points in a line path. linePoints :: [LineCommand] -> [RPoint] linePoints = worker zero where @@ -51,7 +67,8 @@ LineBezier [p] -> p : worker p xs LineBezier ctrl -> -- approximation - [ last (partialBezierPoints (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++ + let bezier = Bezier.AnyBezier (V.fromList (from:ctrl)) + in [ Bezier.evalBezier bezier (recip chunks*i) | i <- [0..chunks]] ++ worker (last ctrl) xs LineEnd p -> p : worker p xs chunks = 10 @@ -90,7 +107,7 @@ pointToRPoint p = case mapTuple (toUserUnit defaultDPI) p of (Num x, Num y) -> V2 x y - _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format." + _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format." circleBoundingPoints circ = let (xnum, ynum) = circ ^. circleCenter diff --git a/src/Reanimate/Svg/Constructors.hs b/src/Reanimate/Svg/Constructors.hs --- a/src/Reanimate/Svg/Constructors.hs +++ b/src/Reanimate/Svg/Constructors.hs @@ -108,6 +108,7 @@ offsetY = -y-h/2 (x,y,w,h) = boundingBox t +-- | Same as 'aroundCenter' but only for the Y-axis. aroundCenterY :: (Tree -> Tree) -> Tree -> Tree aroundCenterY fn t = translate 0 (-offsetY) $ fn $ translate 0 offsetY t @@ -115,6 +116,7 @@ offsetY = -y-h/2 (_x,y,_w,h) = boundingBox t +-- | Same as 'aroundCenter' but only for the X-axis. aroundCenterX :: (Tree -> Tree) -> Tree -> Tree aroundCenterX fn t = translate (-offsetX) 0 $ fn $ translate offsetX 0 t @@ -185,6 +187,7 @@ where (_x, y, _w, h) = boundingBox t +-- | Center the second argument using the bounding-box of the first. centerUsing :: Tree -> Tree -> Tree centerUsing a = translate (-x-w/2) (-y-h/2) where @@ -203,9 +206,11 @@ withStrokeColor :: String -> Tree -> Tree withStrokeColor color = strokeColor .~ pure (mkColor color) +-- | See withStrokeColorPixel :: PixelRGBA8 -> Tree -> Tree withStrokeColorPixel color = strokeColor .~ pure (ColorRef color) +-- | See withStrokeDashArray :: [Double] -> Tree -> Tree withStrokeDashArray arr = strokeDashArray .~ pure (map Num arr) @@ -217,6 +222,7 @@ withFillColor :: String -> Tree -> Tree withFillColor color = fillColor .~ pure (mkColor color) +-- | See withFillColorPixel :: PixelRGBA8 -> Tree -> Tree withFillColorPixel color = fillColor .~ pure (ColorRef color) @@ -224,6 +230,7 @@ withFillOpacity :: Double -> Tree -> Tree withFillOpacity opacity = fillOpacity ?~ realToFrac opacity +-- | See withGroupOpacity :: Double -> Tree -> Tree withGroupOpacity opacity = groupOpacity ?~ realToFrac opacity @@ -347,6 +354,7 @@ mkBackground color = withFillOpacity 1 $ withStrokeWidth 0 $ withFillColor color $ mkRect screenWidth screenHeight +-- | Rectangle with a uniform color and the same size as the screen. mkBackgroundPixel :: PixelRGBA8 -> Tree mkBackgroundPixel pixel = withFillOpacity 1 $ withStrokeWidth 0 $ diff --git a/src/Reanimate/Svg/LineCommand.hs b/src/Reanimate/Svg/LineCommand.hs --- a/src/Reanimate/Svg/LineCommand.hs +++ b/src/Reanimate/Svg/LineCommand.hs @@ -1,18 +1,35 @@ -module Reanimate.Svg.LineCommand where +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} +module Reanimate.Svg.LineCommand + ( CmdM + , LineCommand(..) + , lineLength + , toLineCommands + , lineToPath + , lineToPoints + , partialSvg + ) where -import Control.Lens ((%~), (&), (.~)) +import Control.Lens ((%~), (&), (.~)) import Control.Monad.Fix import Control.Monad.State import Data.Functor -import qualified Data.Vector.Unboxed as V -import qualified Geom2D.CubicBezier as Bezier -import Graphics.SvgTree hiding (height, line, path, use, width) +import qualified Data.Vector.Unboxed as V +import qualified Geom2D.CubicBezier.Linear as Bezier +import Graphics.SvgTree hiding (height, line, path, use, width) import Linear.Metric -import Linear.V2 hiding (angle) +import Linear.V2 hiding (angle) import Linear.Vector +-- | Line command monad used for keeping track of the current location. type CmdM a = State RPoint a +-- | Simplified version of a PathCommand where all points are absolute. data LineCommand = LineMove RPoint -- | LineDraw RPoint @@ -20,6 +37,7 @@ | LineEnd RPoint deriving (Show) +-- | Convert from line commands to path commands. lineToPath :: [LineCommand] -> [PathCommand] lineToPath = map worker where @@ -31,6 +49,7 @@ worker LineBezier{} = error "Reanimate.Svg.lineToPath: invalid bezier curve" worker LineEnd{} = EndPath +-- | Using @n@ control points, approximate the path of the curves. lineToPoints :: Int -> [LineCommand] -> [RPoint] lineToPoints nPoints cmds = map lineEnd lineSegments @@ -58,10 +77,11 @@ adjustLineLength alpha from cmd = case cmd of LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from:points) 0 alpha - LineMove p -> LineMove p + LineMove p -> LineMove p -- LineDraw t -> LineDraw (lerp alpha t from) - LineEnd p -> LineBezier [lerp alpha p from] + LineEnd p -> LineBezier [lerp alpha p from] +-- | Estimated length of all segments in a line. lineLength :: LineCommand -> CmdM Double lineLength cmd = case cmd of @@ -79,15 +99,13 @@ rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double rpointsToBezier lst = - case map toBezierPoint lst of - [a,b] -> Bezier.CubicBezier a a b b - [a,b,c] -> Bezier.quadToCubic (Bezier.QuadBezier a b c) + case lst of + [a,b] -> Bezier.CubicBezier a a b b + [a,b,c] -> Bezier.quadToCubic (Bezier.QuadBezier a b c) [a,b,c,d] -> Bezier.CubicBezier a b c d - _ -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst - -toBezierPoint :: RPoint -> Bezier.Point Double -toBezierPoint (V2 a b) = Bezier.Point a b + _ -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst +-- | Convert from path commands to line commands. toLineCommands :: [PathCommand] -> [LineCommand] toLineCommands ps = evalState (worker zero Nothing ps) zero where @@ -238,15 +256,9 @@ partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint] partialBezierPoints ps a b = - let fromP (V2 i j) = (i, j) - toP (i, j) = V2 i j - c1 :: Bezier.AnyBezier Double - c1 = Bezier.unsafeFromVector (V.fromList $ map fromP ps) - os = V.toList $ Bezier.toVector $ Bezier.bezierSubsegment c1 a b - in map toP os - -interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand] -interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands + let c1 = Bezier.AnyBezier (V.fromList ps) + Bezier.AnyBezier os = Bezier.bezierSubsegment c1 a b + in V.toList os {- | Create an image showing portion of a path. Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath'). diff --git a/src/Reanimate/Svg/Unuse.hs b/src/Reanimate/Svg/Unuse.hs --- a/src/Reanimate/Svg/Unuse.hs +++ b/src/Reanimate/Svg/Unuse.hs @@ -1,3 +1,10 @@ +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Svg.Unuse ( replaceUses , unbox @@ -11,6 +18,7 @@ import Reanimate.Constants import Reanimate.Svg.Constructors +-- | Replace all @@ nodes with their definition. replaceUses :: Document -> Document replaceUses doc = doc & elements %~ map (mapTree replace) where @@ -41,7 +49,7 @@ Just tid -> Map.insert tid tree m -- FIXME: the viewbox is ignored. Can we use the viewbox as a mask? --- Transform out viewbox. defs and CSS rules are discarded. +-- | Transform out viewbox. Definitions and CSS rules are discarded. unbox :: Document -> Tree unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} = GroupTree $ defaultSvg @@ -50,6 +58,8 @@ GroupTree $ defaultSvg & groupChildren .~ doc^.elements +-- | Embed 'Document'. This keeps the entire document intact but makes +-- it more difficult to use, say, `Reanimate.Svg.pathify` on it. embedDocument :: Document -> Tree embedDocument doc = translate (-screenWidth/2) (screenHeight/2) $ diff --git a/src/Reanimate/Transform.hs b/src/Reanimate/Transform.hs --- a/src/Reanimate/Transform.hs +++ b/src/Reanimate/Transform.hs @@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PackageImports #-} +{-| + 2D transformation matrices capable of translating, scaling, + rotating, and skewing. +-} module Reanimate.Transform ( identity , transformPoint @@ -9,22 +12,24 @@ -- XXX: Use Linear.Matrix instead of Data.Matrix to drop the 'matrix' dependency. import Data.List -import "matrix" Data.Matrix (Matrix) -import qualified "matrix" Data.Matrix as M +import Data.Matrix (Matrix) +import qualified Data.Matrix as M import Data.Maybe import Graphics.SvgTree import Linear.V2 -type TMatrix = Matrix Coord - -identity :: TMatrix +-- | Identity matrix. +-- +-- @transformPoints identity x = x@ +identity :: Matrix Coord identity = M.identity 3 -fromList :: [Coord] -> TMatrix +fromList :: [Coord] -> Matrix Coord fromList [a,b,c,d,e,f] = M.fromList 3 3 [a,c,e,b,d,f,0,0,1] fromList _ = error "Reanimate.Transform.fromList: bad input" -transformPoint :: TMatrix -> RPoint -> RPoint +-- | Apply a transformation matrix to a 2D point. +transformPoint :: Matrix Coord -> RPoint -> RPoint transformPoint m (V2 x y) = V2 (a*x +c*y + e) (b*x + d*y +f) where !a = M.unsafeGet 1 1 m @@ -35,11 +40,13 @@ !f = M.unsafeGet 2 3 m -- (a:c:e:b:d:f:_) = M.toList m -mkMatrix :: Maybe [Transformation] -> TMatrix +-- | Convert multiple SVG transformations into a single transformation matrix. +mkMatrix :: Maybe [Transformation] -> Matrix Coord mkMatrix Nothing = identity mkMatrix (Just ts) = foldl' (*) identity (map transformationMatrix ts) -transformationMatrix :: Transformation -> TMatrix +-- | Convert an SVG transformation into a transformation matrix. +transformationMatrix :: Transformation -> Matrix Coord transformationMatrix transformation = case transformation of TransformMatrix a b c d e f -> fromList [a,b,c,d,e,f] @@ -55,7 +62,8 @@ rotate a = fromList [cos r,sin r,-sin r,cos r,0,0] where r = a * pi / 180 -toTransformation :: TMatrix -> Transformation +-- | Convert a transformation matrix back into an SVG transformation. +toTransformation :: Matrix Coord -> Transformation toTransformation m = TransformMatrix a b c d e f where [a,c,e,b,d,f,_,_,_] = M.toList m diff --git a/src/Reanimate/Transition.hs b/src/Reanimate/Transition.hs --- a/src/Reanimate/Transition.hs +++ b/src/Reanimate/Transition.hs @@ -1,3 +1,10 @@ +{-| +Copyright : Written by David Himmelstrup +License : Unlicense +Maintainer : lemmih@gmail.com +Stability : experimental +Portability : POSIX +-} module Reanimate.Transition ( Transition , signalT diff --git a/src/Reanimate/Voice.hs b/src/Reanimate/Voice.hs --- a/src/Reanimate/Voice.hs +++ b/src/Reanimate/Voice.hs @@ -10,6 +10,7 @@ module Reanimate.Voice ( Transcript(..) , TWord(..) + , Phone(..) , findWord -- :: Transcript -> [Text] -> Text -> TWord , findWords -- :: Transcript -> [Text] -> Text -> [TWord] , loadTranscript -- :: FilePath -> Transcript @@ -41,6 +42,8 @@ import Reanimate.Svg import Reanimate.Constants +-- | Aligned transcript. Contains the transcript text as well as +-- timing data for each word. data Transcript = Transcript { transcriptText :: Text , transcriptKeys :: Map Text Int @@ -51,6 +54,8 @@ parseJSON = withObject "transcript" $ \o -> Transcript <$> o .: "transcript" <*> pure Map.empty <*> o .: "words" +-- | Spoken word. Includes information about when it was spoken, +-- its duration, and its phonemes. data TWord = TWord { wordAligned :: Text , wordCase :: Text @@ -86,6 +91,7 @@ <*> o .: "word" +-- | Phoneme type data Phone = Phone { phoneDuration :: Double , phoneType :: Text @@ -286,6 +292,7 @@ ] ] +-- | Helper function for rendering a transcript. annotateWithTranscript :: Transcript -> Scene s () annotateWithTranscript t = forM_ (transcriptWords t) $ \tword -> do let svg = scale 1 $ latex (wordReference tword) diff --git a/test/Helpers.hs b/test/Helpers.hs --- a/test/Helpers.hs +++ b/test/Helpers.hs @@ -15,7 +15,6 @@ import Reanimate.Math.Common import Reanimate.Math.Polygon -import Reanimate.Math.EarClip import Reanimate.Math.SSSP -- [(0.8,1),(0.04,0.1),(0.05,1)] diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -13,8 +13,8 @@ import Reanimate.Math.Common import Reanimate.Math.Polygon -import Reanimate.Math.EarClip import Reanimate.Math.SSSP +import Reanimate.Math.Triangulate import Helpers import Debug.Trace @@ -47,9 +47,11 @@ prop_pCycle p = forAll (choose (0,1)) $ \t -> pIsSimple (pCycle p t) -prop_validEarClip p = isValidTriangulation p (earClip $ pRing p) +-- prop_validEarClip p = isValidTriangulation p (earClip $ pRing p) -prop_validEarCut p = isValidTriangulation p (earCut $ pRing p) +-- prop_validEarCut p = isValidTriangulation p (earCut $ pRing p) + +prop_validMonotone p = isValidTriangulation p (triangulate $ pRing p) -- dualToTrangulation . dual = id prop_dualInv p = diff --git a/test/UnitTests.hs b/test/UnitTests.hs --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -10,16 +10,29 @@ import Data.List (sort) import qualified Data.Text as T import qualified Data.Text.IO as T -import Reanimate.Misc (runCmd, withTempDir, withTempFile) import System.Directory import System.Exit import System.FilePath import System.IO +import System.IO.Temp +import System.IO.Unsafe import System.Process import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit +data BuildSystem + = Cabal + | Stack + +buildSystem :: BuildSystem +buildSystem = unsafePerformIO $ do + newbuild <- doesDirectoryExist "dist-newstyle" + stack <- doesDirectoryExist ".stack-work" + if newbuild then pure Cabal + else if stack then pure Stack + else error "Unknown build system." + unitTestFolder :: FilePath -> IO TestTree unitTestFolder path = do files <- sort <$> getDirectoryContents path @@ -36,31 +49,41 @@ ] genGolden :: FilePath -> IO LBS.ByteString -genGolden path = withTempDir $ \tmpDir -> withTempFile ".exe" $ \tmpExecutable -> do - let ghcOpts = ["-rtsopts", "--make", "-O0", "-Werror", "-Wall"] ++ - ["-odir", tmpDir, "-hidir", tmpDir, "-o", tmpExecutable] - runOpts = ["+RTS", "-M1G"] - -- XXX: Check for errors. - runCmd "stack" $ ["ghc","--", path] ++ ghcOpts +genGolden path = + withTempDir $ \tmpDir -> + withTempFile tmpDir "reanimate.exe" $ \tmpExecutable hd -> do + hClose hd + let ghcOpts = ["-rtsopts", "--make", "-O0", "-Werror", "-Wall"] ++ + ["-odir", tmpDir, "-hidir", tmpDir, "-o", tmpExecutable] ++ + ["-v0"] + runOpts = ["+RTS", "-M1G"] + -- XXX: Check for errors. + case buildSystem of + Stack -> callProcess "stack" $ ["ghc","--", path] ++ ghcOpts + Cabal -> callProcess "cabal" $ ["v2-exec", "ghc","--", "-package", "reanimate", path] ++ ghcOpts - (inh, outh, errh, pid) <- runInteractiveProcess tmpExecutable (["test"] ++ runOpts) - Nothing Nothing - -- hSetBinaryMode outh True - -- hSetNewlineMode outh universalNewlineMode - hClose inh - out <- BS.hGetContents outh - err <- T.hGetContents errh - code <- waitForProcess pid - case code of - ExitSuccess -> return $ LBS.fromChunks [out] - ExitFailure{} -> error $ "Failed to run: " ++ T.unpack err + (inh, outh, errh, pid) <- runInteractiveProcess tmpExecutable (["test"] ++ runOpts) + Nothing Nothing + -- hSetBinaryMode outh True + -- hSetNewlineMode outh universalNewlineMode + hClose inh + out <- BS.hGetContents outh + err <- T.hGetContents errh + code <- waitForProcess pid + case code of + ExitSuccess -> return $ LBS.fromChunks [out] + ExitFailure{} -> error $ "Failed to run: " ++ T.unpack err compileTestFolder :: FilePath -> IO TestTree compileTestFolder path = do files <- sort <$> getDirectoryContents path return $ testGroup "compile" [ testCase file $ do - (ret, _stdout, err) <- readProcessWithExitCode "stack" (["ghc","--", fullPath] ++ ghcOpts) "" + (ret, _stdout, err) <- + case buildSystem of + Stack -> readProcessWithExitCode "stack" (["ghc","--", fullPath] ++ ghcOpts) "" + Cabal -> readProcessWithExitCode "cabal" + (["v2-exec","ghc","--", "-package", "reanimate", fullPath] ++ ghcOpts) "" _ <- evaluate (length err) case ret of ExitFailure{} -> assertFailure $ "Failed to compile:\n" ++ err @@ -81,7 +104,10 @@ files <- sort <$> getDirectoryContents path return $ testGroup "videos" [ testCase dir $ do - (ret, _stdout, err) <- readProcessWithExitCode "stack" (["ghc","--", "-i"++pathdir, fullPath] ++ ghcOpts) "" + (ret, _stdout, err) <- + case buildSystem of + Stack -> readProcessWithExitCode "stack" (["ghc","--", "-i"++pathdir, fullPath] ++ ghcOpts) "" + Cabal -> readProcessWithExitCode "cabal" (["v2-exec", "ghc","--", "-package", "reanimate", "-i"++pathdir, fullPath] ++ ghcOpts) "" _ <- evaluate (length err) case ret of ExitFailure{} -> assertFailure $ "Failed to compile:\n" ++ err @@ -117,3 +143,6 @@ -- assertMaybe :: String -> Maybe a -> IO a -- assertMaybe _ (Just a) = return a -- assertMaybe msg Nothing = assertFailure msg + +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir = withSystemTempDirectory "reanimate"