hashirama/reanimate
Watch
1
0
Fork
You've already forked reanimate
 0
mirror of https://github.com/reanimate/reanimate.git synced 2026-09-15 10:02:45 +00:00
Code Issues Projects Releases Wiki Activity

Add basic support for bounding boxes.

Browse source
This commit is contained in:
David 2019-02-18 16:00:03 +01:00
commit b8e7f0cb06
6 changed files with 337 additions and 108 deletions
Download patch file Download diff file Expand all files Collapse all files

37
README.md
View file

@ -41,6 +41,43 @@ latex_draw = pauseAtEnd 1 $ defineAnimation $ proc () -> do
``` ```
![Drawing LaTeX equations](gifs/latex_draw.gif) ![Drawing LaTeX equations](gifs/latex_draw.gif)
## Bounding boxes
```haskell
bbox :: Ani ()
bbox = proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
annotate' bbox1 -< g_ [transform_ $ Lucid.translate (320/2-50) (180/2)]
annotate' bbox2 -< g_ [transform_ $ Lucid.translate (320/2+50) (180/2)]
bbox1 :: Ani ()
bbox1 = defineAnimation $ proc () -> do
duration 5 -< ()
s <- signal 0 1 -< ()
let rotated = rotate (360*s) svg
(x, y, w, h) = boundingBox rotated
emit -< do
g_ [transform_ $ Lucid.translate x y] $
rect_ [num_ width_ w, num_ height_ h, stroke_ "red", fill_opacity_ "0", stroke_width_ "1"]
g_ [fill_ "white"] $ toHtml rotated
where
msg = "\\sum_{k=1}^\\infty"
svg = scale 3 $ center $ latexAlign msg
bbox2 :: Ani ()
bbox2 = defineAnimation $ proc () -> do
duration 5 -< ()
s <- signalOscillate 0 1 -< ()
let rotated = partialSvg s heartShape
(x, y, w, h) = boundingBox rotated
emit -< do
g_ [transform_ $ Lucid.translate x y] $
rect_ [num_ width_ w, num_ height_ h, stroke_ "red", fill_opacity_ "0", stroke_width_ "1"]
g_ [fill_ "white", fill_opacity_ "0", stroke_width_ "4", stroke_ "white"] $
toHtml rotated
```
![Bounding boxes](gifs/bbox.gif)
## Bezier curves ## Bezier curves
![Bezier curves](gifs/bezier.gif) ![Bezier curves](gifs/bezier.gif)

BIN
gifs/bbox.gif Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 217 KiB

16
reanimate.cabal
View file

@ -22,13 +22,22 @@ library
Reanimate.Combinators Reanimate.Combinators
Reanimate.LaTeX Reanimate.LaTeX
Reanimate.Svg Reanimate.Svg
Reanimate.Transform
other-modules: Reanimate.Misc other-modules: Reanimate.Misc
build-depends: base >=4.10 && <4.13, build-depends: base >=4.10 && <4.13,
lucid-svg, time, text, unix, lucid, filepath, process, directory, lucid-svg, time, text, unix, lucid, filepath, process, directory,
containers, svg-tree, xml, bytestring, lens, linear, mtl containers, svg-tree, xml, bytestring, lens, linear, mtl, matrix
Flag gtk-viewer
Description: Enable gtk-based viewer
Default: True
executable reanimate-viewer executable reanimate-viewer
main-is: SvgViewer.hs if flag(gtk-viewer)
buildable: True
else
buildable: False
main-is: SvgViewer.hs
-- other-extensions: -- other-extensions:
other-modules: Reanimate.Arrow other-modules: Reanimate.Arrow
Reanimate.Render Reanimate.Render
@ -37,9 +46,10 @@ executable reanimate-viewer
Reanimate.LaTeX Reanimate.LaTeX
Reanimate.Svg Reanimate.Svg
Reanimate.Misc Reanimate.Misc
Reanimate.Transform
build-depends: base >=4.10 && <4.13, cairo >=0.13 && <0.14, gtk, build-depends: base >=4.10 && <4.13, cairo >=0.13 && <0.14, gtk,
svgcairo, lucid-svg, time, text, unix, lucid, reanimate, svgcairo, lucid-svg, time, text, unix, lucid, reanimate,
filepath, process, directory, containers, svg-tree, xml, filepath, process, directory, containers, svg-tree, xml,
bytestring, lens, linear, mtl bytestring, lens, linear, mtl, matrix
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

110
src/Reanimate/Examples.hs
View file

@ -10,7 +10,13 @@ import Data.Monoid ((<>))
import Data.Text (Text, pack) import Data.Text (Text, pack)
import qualified Graphics.Svg as S import qualified Graphics.Svg as S
import Linear.V2 import Linear.V2
import Lucid.Svg import Lucid.Svg (Svg, circle_, clip_path_, cx_, cy_, d_, id_, defs_, clipPath_,
fill_, fill_opacity_, font_size_, g_,
height_, line_, opacity_, path_, r_,
rect_, stroke_, stroke_width_, text_,
text_anchor_, toHtml, transform_,
width_, x1_, x2_, x_, y1_, y2_, y_)
import qualified Lucid.Svg as Lucid
import Numeric import Numeric
import Text.Printf import Text.Printf
@ -19,6 +25,8 @@ import Reanimate.Combinators
import Reanimate.LaTeX import Reanimate.LaTeX
import Reanimate.Svg import Reanimate.Svg
import Debug.Trace
sinewave :: Ani () sinewave :: Ani ()
sinewave = proc () -> do sinewave = proc () -> do
duration 10 -< () duration 10 -< ()
@ -28,7 +36,7 @@ sinewave = proc () -> do
emit -< do emit -< do
defs_ $ clipPath_ [id_ "clip"] $ defs_ $ clipPath_ [id_ "clip"] $
rect_ [x_ "0", num_ y_ (-height), num_ width_ (idx * width), height_ "100%"] rect_ [x_ "0", num_ y_ (-height), num_ width_ (idx * width), height_ "100%"]
g_ [transform_ $ translate margin height, clip_path_ "url(#clip)"] $ g_ [transform_ $ Lucid.translate margin height, clip_path_ "url(#clip)"] $
renderPath $ approxFnData 1000 wave renderPath $ approxFnData 1000 wave
line_ [ num_ x1_ margin, num_ x2_ margin, y1_ "10", y2_ "170" line_ [ num_ x1_ margin, num_ x2_ margin, y1_ "10", y2_ "170"
, stroke_ "white"] , stroke_ "white"]
@ -36,7 +44,7 @@ sinewave = proc () -> do
, stroke_ "white"] , stroke_ "white"]
let (circX, circY) = wave idx let (circX, circY) = wave idx
emit -< g_ [transform_ $ translate margin height] $ emit -< g_ [transform_ $ Lucid.translate margin height] $
circle_ [num_ cx_ circX, num_ cy_ circY, r_ "3", fill_ "red"] circle_ [num_ cx_ circX, num_ cy_ circY, r_ "3", fill_ "red"]
where where
freq = 3; margin = 30; width = 260; height = 90 freq = 3; margin = 30; width = 260; height = 90
@ -49,9 +57,9 @@ morph_wave = proc () -> do
morph <- signalOscillate 0 1 -< () morph <- signalOscillate 0 1 -< ()
emit -< do emit -< do
g_ [transform_ $ translate 30 50] $ renderPath wave1 g_ [transform_ $ Lucid.translate 30 50] $ renderPath wave1
g_ [transform_ $ translate 30 130] $ renderPath wave2 g_ [transform_ $ Lucid.translate 30 130] $ renderPath wave2
g_ [transform_ $ translate 30 90] $ renderPath $ morphPath wave1 wave2 morph g_ [transform_ $ Lucid.translate 30 90] $ renderPath $ morphPath wave1 wave2 morph
line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"] line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"]
line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"] line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"]
where where
@ -66,7 +74,7 @@ morph_wave_circle = proc t -> do
idx <- signalOscillate 0 1 -< () idx <- signalOscillate 0 1 -< ()
emit -< do emit -< do
g_ [transform_ $ translate 30 90] $ g_ [transform_ $ Lucid.translate 30 90] $
renderPath $ morphPath circle wave1 idx renderPath $ morphPath circle wave1 idx
line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"] line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"]
line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"] line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"]
@ -79,9 +87,9 @@ morph_wave_circle = proc t -> do
progressMeters :: Ani () progressMeters :: Ani ()
progressMeters = proc () -> do progressMeters = proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
annotate' (adjustSpeed 1.0 progressMeter) -< g_ [transform_ $ translate 40 20] annotate' (adjustSpeed 1.0 progressMeter) -< g_ [transform_ $ Lucid.translate 40 20]
annotate' (adjustSpeed 2.0 progressMeter) -< g_ [transform_ $ translate 140 20] annotate' (adjustSpeed 2.0 progressMeter) -< g_ [transform_ $ Lucid.translate 140 20]
annotate' (adjustSpeed 0.5 progressMeter) -< g_ [transform_ $ translate 240 20] annotate' (adjustSpeed 0.5 progressMeter) -< g_ [transform_ $ Lucid.translate 240 20]
emit -< do emit -< do
text_ [x_ "55", y_ "150", font_size_ "20" text_ [x_ "55", y_ "150", font_size_ "20"
@ -164,10 +172,10 @@ clip_rect = proc () -> do
where where
paintStatic nth = proc () -> paintStatic nth = proc () ->
annotate' (obj "white" (20+nth*10) (20+nth*10)) annotate' (obj "white" (20+nth*10) (20+nth*10))
-< g_ [transform_ $ translate 160 90] -< g_ [transform_ $ Lucid.translate 160 90]
runAni color nth = defineAnimation $ proc () -> runAni color nth = defineAnimation $ proc () ->
annotate' (circle_clip (obj color (20+nth*10) (20+nth*10))) annotate' (circle_clip (obj color (20+nth*10) (20+nth*10)))
-< g_ [transform_ $ translate 160 90] -< g_ [transform_ $ Lucid.translate 160 90]
obj c width height = proc () -> do obj c width height = proc () -> do
duration 1 -< () duration 1 -< ()
emit -< rect_ [ num_ width_ width, num_ height_ height emit -< rect_ [ num_ width_ width, num_ height_ height
@ -195,7 +203,7 @@ circle_clip sub = proc () -> do
scaling :: Ani () scaling :: Ani ()
scaling = adjustSpeed 2 $ syncAll scaling = adjustSpeed 2 $ syncAll
[ defineAnimation $ proc () -> [ defineAnimation $ proc () ->
annotate' animation -< g_ [transform_ $ translate x y <> " " <> scale 0.5 0.5] annotate' animation -< g_ [transform_ $ Lucid.translate x y <> " " <> Lucid.scale 0.5 0.5]
| x <- [0,160] | x <- [0,160]
, y <- [0,90] , y <- [0,90]
| animation <- [sinewave, morph_wave, highlight, progressMeters]] | animation <- [sinewave, morph_wave, highlight, progressMeters]]
@ -210,7 +218,7 @@ heart :: Ani ()
heart = proc () -> do heart = proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "#FFFFFF"] emit -< rect_ [width_ "100%", height_ "100%", fill_ "#FFFFFF"]
-- duration 1 -< () -- duration 1 -< ()
-- annotate' drawHeart -< g_ [transform_ $ scale 0.5 0.5 <> " " <> translate 200 200] -- annotate' drawHeart -< g_ [transform_ $ Lucid.scale 0.5 0.5 <> " " <> translate 200 200]
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
follow follow
[ all_read [ all_read
@ -254,11 +262,11 @@ heart = proc () -> do
heart_ani = repeatAni 10 $ defineAnimation $ proc () -> do heart_ani = repeatAni 10 $ defineAnimation $ proc () -> do
duration 1 -< () duration 1 -< ()
n <- signalOscillateSCurve 2 0.9 1.1 -< () n <- signalOscillateSCurve 2 0.9 1.1 -< ()
annotate' drawHeart -< g_ [transform_ $ translate 160 110] . g_ [transform_ $ scale n n <> " "] annotate' drawHeart -< g_ [transform_ $ Lucid.translate 160 110] . g_ [transform_ $ Lucid.scale n n <> " "]
heart_disappear = defineAnimation $ proc () -> do heart_disappear = defineAnimation $ proc () -> do
duration 3 -< () duration 3 -< ()
n <- signal 0.9 10 -< () n <- signal 0.9 10 -< ()
annotate' drawHeart -< g_ [transform_ $ translate 160 110] . g_ [transform_ $ scale n n <> " "] annotate' drawHeart -< g_ [transform_ $ Lucid.translate 160 110] . g_ [transform_ $ Lucid.scale n n <> " "]
white = loop $ defineAnimation $ proc () -> do white = loop $ defineAnimation $ proc () -> do
duration 1 -< () duration 1 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "#FFFFFF"] emit -< rect_ [width_ "100%", height_ "100%", fill_ "#FFFFFF"]
@ -267,8 +275,8 @@ heart = proc () -> do
n <- signal 0 1 -< () n <- signal 0 1 -< ()
o <- signalOscillate (-1) 1 -< () o <- signalOscillate (-1) 1 -< ()
emit -< emit -<
g_ [transform_ $ translate (xPos*360) (210*n)] $ g_ [transform_ $ Lucid.translate (xPos*360) (210*n)] $
g_ [transform_ $ rotate (45*o)] $ g_ [transform_ $ Lucid.rotate (45*o)] $
text_ [font_size_ "18" text_ [font_size_ "18"
,text_anchor_ "middle" ,text_anchor_ "middle"
,fill_ "red"] "爱" ,fill_ "red"] "爱"
@ -277,16 +285,16 @@ heart = proc () -> do
o <- signalOscillate 0 1 -< () o <- signalOscillate 0 1 -< ()
n <- signalOscillateSCurve 2 0.9 1.1 -< () n <- signalOscillateSCurve 2 0.9 1.1 -< ()
emit -< emit -<
g_ [transform_ $ translate 160 110, num_ opacity_ o] $ g_ [transform_ $ Lucid.translate 160 110, num_ opacity_ o] $
g_ [transform_ $ scale n n ] $ g_ [transform_ $ Lucid.scale n n ] $
text_ [x_ "0", y_ "-12", font_size_ "24" text_ [x_ "0", y_ "-12", font_size_ "24"
, text_anchor_ "middle" , text_anchor_ "middle"
, fill_ "white"] txt , fill_ "white"] txt
drawHeart = proc () -> do drawHeart = proc () -> do
emit -< emit -<
g_ [transform_ $ translate (-170) (-260)] $ g_ [transform_ $ Lucid.translate (-170) (-260)] $
g_ [transform_ $ rotateAround 225 150 121 <> " " <> scale 0.4 0.4] $ g_ [transform_ $ Lucid.rotateAround 225 150 121 <> " " <> Lucid.scale 0.4 0.4] $
path_ ([stroke_ "red", fill_"red", d_ dat]) path_ ([stroke_ "red", fill_"red", d_ dat])
dat = "M0 200 v-200 h200 a100,100 90 0,1 0,200 a100,100 90 0,1 -200,0 z" dat = "M0 200 v-200 h200 a100,100 90 0,1 0,200 a100,100 90 0,1 -200,0 z"
hex n = if n < 0x10 then "0" ++ showHex (round n) "" hex n = if n < 0x10 then "0" ++ showHex (round n) ""
@ -318,14 +326,14 @@ frequencies = proc () -> do
duration 3 -< () duration 3 -< ()
n <- signal 0 1 -< () n <- signal 0 1 -< ()
emit -< do emit -< do
g_ [transform_ $ translate margin height] $ renderPath $ morphPath line1 (wave1 move) n g_ [transform_ $ Lucid.translate margin height] $ renderPath $ morphPath line1 (wave1 move) n
let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ]
circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY*n), num_ r_ 3, fill_ "red"] circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY*n), num_ r_ 3, fill_ "red"]
drawSecondWave = defineAnimation $ proc move -> do drawSecondWave = defineAnimation $ proc move -> do
label "drawSecondWave" -< () label "drawSecondWave" -< ()
duration 3 -< () duration 3 -< ()
emit -< do emit -< do
g_ [transform_ $ translate margin height] $ renderPath $ wave1 move g_ [transform_ $ Lucid.translate margin height] $ renderPath $ wave1 move
let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ]
circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"] circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"]
drawUpWave = defineAnimation $ proc move -> do drawUpWave = defineAnimation $ proc move -> do
@ -333,8 +341,8 @@ frequencies = proc () -> do
duration 2 -< () duration 2 -< ()
n <- signal 0 1 -< () n <- signal 0 1 -< ()
emit -< do emit -< do
g_ [transform_ $ scale 1 (1-0.5*n)] $ do g_ [transform_ $ Lucid.scale 1 (1-0.5*n)] $ do
g_ [transform_ $ translate margin height] $ renderPath $ wave1 move g_ [transform_ $ Lucid.translate margin height] $ renderPath $ wave1 move
let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ]
circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"] circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"]
line1 = approxFnData 1000 $ \idx -> line1 = approxFnData 1000 $ \idx ->
@ -349,7 +357,7 @@ latex_basic = proc () -> do
s <- signalOscillate 0 1 -< () s <- signalOscillate 0 1 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
emit -< emit -<
g_ [transform_ $ translate 20 15 <> " " <> scale 4 4] $ do g_ [transform_ $ Lucid.translate 20 15 <> " " <> Lucid.scale 4 4] $ do
g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] text g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] text
g_ [fill_ "white", num_ fill_opacity_ s] text g_ [fill_ "white", num_ fill_opacity_ s] text
where where
@ -422,7 +430,7 @@ latex_draw = pauseAtEnd 1 $ defineAnimation $ proc () -> do
drawText msg `andThen` fillText msg -< () drawText msg `andThen` fillText msg -< ()
where where
msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
placement = g_ [transform_ $ translate 20 15 <> " " <> scale 5 5] placement = g_ [transform_ $ Lucid.translate 20 15 <> " " <> Lucid.scale 5 5]
fillText txt = defineAnimation $ proc () -> do fillText txt = defineAnimation $ proc () -> do
duration 1 -< () duration 1 -< ()
s <- signal 0 1 -< () s <- signal 0 1 -< ()
@ -435,3 +443,49 @@ latex_draw = pauseAtEnd 1 $ defineAnimation $ proc () -> do
emit -< placement $ emit -< placement $
g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] $ g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] $
toHtml $ partialSvg s $ latexAlign txt toHtml $ partialSvg s $ latexAlign txt
bbox :: Ani ()
bbox = proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
annotate' bbox1 -< g_ [transform_ $ Lucid.translate (320/2-50) (180/2)]
annotate' bbox2 -< g_ [transform_ $ Lucid.translate (320/2+50) (180/2)]
bbox1 :: Ani ()
bbox1 = defineAnimation $ proc () -> do
duration 5 -< ()
s <- signal 0 1 -< ()
let rotated = rotate (360*s) svg
(x, y, w, h) = boundingBox rotated
emit -< do
g_ [transform_ $ Lucid.translate x y] $
rect_ [num_ width_ w, num_ height_ h, stroke_ "red", fill_opacity_ "0", stroke_width_ "1"]
g_ [fill_ "white"] $ toHtml rotated
where
msg = "\\sum_{k=1}^\\infty"
svg = scale 3 $ center $ latexAlign msg
bbox2 :: Ani ()
bbox2 = defineAnimation $ proc () -> do
duration 5 -< ()
s <- signalOscillate 0 1 -< ()
let rotated = partialSvg s heartShape
(x, y, w, h) = boundingBox rotated
emit -< do
g_ [transform_ $ Lucid.translate x y] $
rect_ [num_ width_ w, num_ height_ h, stroke_ "red", fill_opacity_ "0", stroke_width_ "1"]
g_ [fill_ "white", fill_opacity_ "0", stroke_width_ "4", stroke_ "white"] $
toHtml rotated
heartShape =
scale 0.15 $ rotate 225 $ center $ p
where
p = S.PathTree $ S.defaultSvg & S.pathDefinition .~ cmds
abs = S.OriginAbsolute
rel = S.OriginRelative
cmds =
[S.MoveTo abs [V2 0 200]
,S.VerticalTo rel [-200],S.HorizontalTo rel [200]
,S.EllipticalArc rel [(100,100,90,False,True, V2 0 200)]
,S.EllipticalArc rel [(100,100,90,False,True, V2 (-200) 0)]
,S.EndPath]

235
src/Reanimate/Svg.hs
View file

@ -10,6 +10,7 @@ import Graphics.Svg
import Linear.Metric import Linear.Metric
import Linear.V2 import Linear.V2
import Linear.Vector import Linear.Vector
import qualified Reanimate.Transform as Transform
import Debug.Trace import Debug.Trace
@ -101,10 +102,10 @@ adjustLineLength alpha from cmd =
lineLength :: LineCommand -> CmdM Double lineLength :: LineCommand -> CmdM Double
lineLength cmd = lineLength cmd =
case cmd of case cmd of
LineMove to -> pure 0 <* put to LineMove to -> pure 0 <* put to
LineDraw to -> gets (distance to) <* put to LineDraw to -> gets (distance to) <* put to
LineBezier points -> gets (distance (last points)) <* put (last points) LineBezier points -> gets (distance (last points)) <* put (last points)
toLineCommands :: [PathCommand] -> [LineCommand] toLineCommands :: [PathCommand] -> [LineCommand]
toLineCommands ps = evalState (worker zero Nothing ps) zero toLineCommands ps = evalState (worker zero Nothing ps) zero
@ -161,7 +162,10 @@ toLineCommand startPos mbPrevControlPt cmd = do
from <- get <* adjustPosition o to from <- get <* adjustPosition o to
let c1 = maybe from (mirrorPoint from) mbControl let c1 = maybe from (mirrorPoint from) mbControl
pure $ LineBezier [c1,makeAbsolute o from to] pure $ LineBezier [c1,makeAbsolute o from to]
EllipticalArc origin points -> undefined EllipticalArc o points -> concat <$>
(forM points $ \(rotX, rotY, angle, largeArc, sweepFlag, to) -> do
from <- get <* adjustPosition o to
return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to))
EndPath -> put startPos *> pure [LineDraw startPos] EndPath -> put startPos *> pure [LineDraw startPos]
where where
mirrorPoint c p = c*2-p mirrorPoint c p = c*2-p
@ -171,6 +175,82 @@ toLineCommand startPos mbPrevControlPt cmd = do
makeAbsolute OriginRelative from p = from+p makeAbsolute OriginRelative from p = from+p
calculateVectorAngle :: Double -> Double -> Double -> Double -> Double
calculateVectorAngle ux uy vx vy
| tb >= ta
= tb - ta
| otherwise
= pi * 2 - (ta - tb)
where
ta = atan2 uy ux
tb = atan2 vy vx
-- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs
convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand]
convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y)
| x0 == x && y0 == y
= []
| radiusX == 0.0 && radiusY == 0.0
= [LineDraw (V2 x y)]
| otherwise
= calcSegments x0 y0 theta1' segments'
where
sinPhi = sin (angle * pi/180)
cosPhi = cos (angle * pi/180)
x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0
y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0
numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash
s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY))
rx = if (numerator < 0.0) then (radiusX * s) else radiusX
ry = if (numerator < 0.0) then (radiusY * s) else radiusY
root = if (numerator < 0.0)
then (0.0)
else ((if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0) *
sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash)))
cxdash = root * rx * y1dash / ry
cydash = -root * ry * x1dash / rx
cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0
cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0
theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry)
dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry)
dtheta = if (not sweepFlag && dtheta' > 0)
then (dtheta' - 2 * pi)
else (if (sweepFlag && dtheta' < 0) then (dtheta' + 2 * pi) else dtheta')
segments' = ceiling (abs (dtheta / (pi / 2.0)))
delta = dtheta / fromInteger segments'
t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0)
calcSegments startX startY theta1 segments
| segments == 0
= []
| otherwise
= LineBezier [ V2 (startX + dx1) (startY + dy1)
, V2 (endpointX + dxe) (endpointY + dye)
, V2 endpointX endpointY ] : calcSegments endpointX endpointY theta2 (segments - 1)
where
cosTheta1 = cos theta1
sinTheta1 = sin theta1
theta2 = theta1 + delta
cosTheta2 = cos theta2
sinTheta2 = sin theta2
endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx
endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy
dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1)
dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1)
dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2)
dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2)
-- Algorithm taken from manim. It's magic. -- Algorithm taken from manim. It's magic.
bezier :: [RPoint] -> Double -> RPoint bezier :: [RPoint] -> Double -> RPoint
bezier points t = sum bezier points t = sum
@ -179,6 +259,8 @@ bezier points t = sum
where where
n = length points -1 n = length points -1
choose n k = product [n,n-1 .. n-k+1] `div` product [1..k] choose n k = product [n,n-1 .. n-k+1] `div` product [1..k]
partial_bezier_points :: [RPoint] -> Double -> Double -> [RPoint]
partial_bezier_points points a b partial_bezier_points points a b
| isNaN end_prop || isInfinite end_prop = replicate (length points) (last points) | isNaN end_prop || isInfinite end_prop = replicate (length points) (last points)
| otherwise = [ bezier (take (i+1) a_to_1) end_prop | i <- [0..length points-1] ] | otherwise = [ bezier (take (i+1) a_to_1) end_prop | i <- [0..length points-1] ]
@ -190,78 +272,6 @@ partial_bezier_points points a b
interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand] interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand]
interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands
-- evalState (worker 0 cmds) zero
-- where
-- worker d [] = pure []
-- worker d (x:xs) | d > minDistance = pure []
-- worker d (LineTo OriginAbsolute []:xs) = worker d xs
-- worker d (LineTo OriginAbsolute (to:tos):xs) = do
-- from <- get <* put to
-- let d' = distance from to
-- out = LineTo OriginAbsolute [lerp (min 1 ((minDistance-d)/d')) to from]
-- rest = LineTo OriginAbsolute tos
-- (out:) <$> worker (d+d') (rest:xs)
-- worker d (LineTo OriginRelative []:xs) = worker d xs
-- worker d (LineTo OriginRelative (to:tos):xs) = do
-- from <- get <* modify (+to)
-- let d' = distance zero to
-- out = LineTo OriginRelative [lerp (min 1 ((minDistance-d)/d')) to zero]
-- rest = LineTo OriginRelative tos
-- (out:) <$> worker (d+d') (rest:xs)
-- worker d (x:xs) = do
-- d' <- estimateCmdLength x
-- (x:) <$> worker (d+d') xs
-- minDistance = estimatePathLength cmds * alpha
--
-- splitPathCommands :: [PathCommand] -> [PathCommand]
-- splitPathCommands cmds = evalState (concat <$> mapM splitPathCommand cmds) zero
--
-- splitPathCommand :: PathCommand -> CmdM [PathCommand]
-- splitPathCommand cmd = do
-- case cmd of
-- MoveTo OriginAbsolute [] -> pure [cmd]
-- MoveTo OriginAbsolute lst -> put (last lst) *> pure [cmd]
-- MoveTo OriginRelative lst -> modify (+ sum lst) *> pure [cmd]
-- -- LineTo OriginAbsolute lst -> do
-- -- concat <$> forM lst (\to -> do
-- -- from <- get <* put (to :: RPoint)
-- -- let towardsTo = (to - from) / fromIntegral pieces :: RPoint
-- -- return $ replicate pieces (LineTo OriginRelative [towardsTo]))
-- -- LineTo OriginRelative lst -> do
-- -- concat <$> forM lst (\to -> do
-- -- from <- get <* modify (+to)
-- -- let towardsTo = to / fromIntegral pieces :: RPoint
-- -- return $ replicate pieces (LineTo OriginRelative [towardsTo]))
-- _ -> pure [cmd]
-- where
-- pieces = 100 :: Int
--
-- estimatePathLength :: [PathCommand] -> Double
-- estimatePathLength cmds = evalState (sum <$> mapM estimateCmdLength cmds) zero
--
-- estimateCmdLength :: PathCommand -> CmdM Double
-- estimateCmdLength cmd =
-- case cmd of
-- MoveTo OriginAbsolute [] -> pure 0
-- MoveTo OriginAbsolute lst -> put (last lst) *> pure 0
-- MoveTo OriginRelative lst -> modify (+ sum lst) *> pure 0
-- LineTo OriginAbsolute lst ->
-- sum <$> forM lst (\to -> gets (distance to) <* put to)
-- LineTo OriginRelative lst ->
-- sum <$> forM lst (\to -> modify (+to) *> pure (distance zero to))
-- HorizontalTo OriginAbsolute lst -> undefined
-- HorizontalTo OriginRelative lst -> undefined
-- VerticalTo OriginAbsolute lst -> undefined
-- VerticalTo OriginRelative lst -> undefined
-- CurveTo origin quads -> undefined
-- SmoothCurveTo origin lst -> undefined
-- QuadraticBezier origin pairs -> undefined
-- SmoothQuadraticBezierCurveTo origin points -> undefined
-- EllipticalArc origin points -> undefined
-- EndPath -> pure 0
-- lineToPath :: [LineCommand] -> [PathCommand]
-- partialLine :: Double -> [LineCommand] -> [LineCommand]
partialSvg :: Double -> Tree -> Tree partialSvg :: Double -> Tree -> Tree
partialSvg alpha = mapTree worker partialSvg alpha = mapTree worker
@ -269,3 +279,74 @@ partialSvg alpha = mapTree worker
worker (PathTree path) = worker (PathTree path) =
PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands
worker t = t worker t = t
-- (x,y,w,h)
boundingBox :: Tree -> (Double, Double, Double, Double)
boundingBox t =
case svgBoundingPoints t of
[] -> (0,0,0,0)
(V2 x y:rest) ->
let (minx, miny, maxx, maxy) = foldl' worker (x, y, x, y) rest
in (minx, miny, maxx-minx, maxy-miny)
where
worker (minx, miny, maxx, maxy) (V2 x y) =
(min minx x, min miny y, max maxx x, max maxy y)
linePoints :: [LineCommand] -> [RPoint]
linePoints = worker zero
where
worker from [] = []
worker from (x:xs) =
case x of
LineMove to -> worker to xs
LineDraw to -> from:to:worker to xs
LineBezier ctrl -> -- approximation
[ last (partial_bezier_points (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++
worker (last ctrl) xs
chunks = 10
svgBoundingPoints :: Tree -> [RPoint]
svgBoundingPoints t = map (Transform.transformPoint m) $
case t of
None -> []
UseTree{} -> []
GroupTree g -> concatMap svgBoundingPoints (g^.groupChildren)
SymbolTree (Symbol g) -> concatMap svgBoundingPoints (g^.groupChildren)
PathTree p -> linePoints $ toLineCommands (p^.pathDefinition)
CircleTree{} -> error "CircleTree"
PolyLineTree{} -> error "PolyLineTree"
EllipseTree{} -> error "EllipseTree"
LineTree{} -> error "LineTree"
RectangleTree{} -> error "RectangleTree"
TextTree{} -> []
ImageTree{} -> []
MeshGradientTree{} -> []
where
m = Transform.mkMatrix (t^.drawAttr.transform)
withTransformations :: [Transformation] -> Tree -> Tree
withTransformations transformations tree = GroupTree $ defaultSvg
& drawAttr .~ attr
& groupChildren .~ [tree]
where
attr = defaultSvg & transform .~ Just transformations
translate :: Double -> Double -> Tree -> Tree
translate x y = withTransformations [Translate x y]
rotate :: Double -> Tree -> Tree
rotate a = withTransformations [Rotate a Nothing]
rotateAround :: Double -> RPoint -> Tree -> Tree
rotateAround a (V2 x y) = withTransformations [Rotate a (Just (x,y))]
scale :: Double -> Tree -> Tree
scale a = withTransformations [Scale a Nothing]
scaleXY :: Double -> Double -> Tree -> Tree
scaleXY x y = withTransformations [Scale x (Just y)]
center :: Tree -> Tree
center t = translate (-x-w/2) (-y-h/2) t
where
(x, y, w, h) = boundingBox t

47
src/Reanimate/Transform.hs Normal file
View file

@ -0,0 +1,47 @@
module Reanimate.Transform
( identity
, transformPoint
, mkMatrix
) where
-- XXX: Use Linear.Matrix instead of Data.Matrix to drop the 'matrix' dependency.
import Data.List
import Data.Matrix (Matrix)
import qualified Data.Matrix as M
import Data.Maybe
import Graphics.Svg
import Linear.V2
type TMatrix = Matrix Coord
identity :: TMatrix
identity = M.identity 3
fromList :: [Coord] -> TMatrix
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
transformPoint m (V2 x y) = V2 (a*x +c*y + e) (b*x + d*y +f)
where
(a:c:e:b:d:f:_) = M.toList m
mkMatrix :: Maybe [Transformation] -> TMatrix
mkMatrix Nothing = identity
mkMatrix (Just ts) = foldl' (*) identity (map transformationMatrix ts)
transformationMatrix :: Transformation -> TMatrix
transformationMatrix transformation =
case transformation of
TransformMatrix a b c d e f -> fromList [a,b,c,d,e,f]
Translate x y -> translate x y
Scale sx mbSy -> fromList [sx,0,0,fromMaybe sx mbSy,0,0]
Rotate a Nothing -> rotate a
Rotate a (Just (x,y)) -> translate x y * rotate a * translate (-x) (-y)
SkewX a -> fromList [1,0,tan (a*pi/180),1,0,0]
SkewY a -> fromList [1,tan (a*pi/180),0,1,0,0]
TransformUnknown -> identity
where
translate x y = fromList [1,0,0,1,x,y]
rotate a = fromList [cos r,sin r,-sin r,cos r,0,0]
where r = a * pi / 180