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

Work on a high-level API. Rewrite examples.

Browse source
This commit is contained in:
David 2019-02-18 22:37:54 +01:00
commit 7f9b3f1da2
7 changed files with 148 additions and 131 deletions
Download patch file Download diff file Expand all files Collapse all files

93
README.md
View file

@ -21,23 +21,23 @@ The example gifs are displayed at 25 fps.
```haskell ```haskell
latex_draw :: Ani () latex_draw :: Ani ()
latex_draw = pauseAtEnd 1 $ defineAnimation $ proc () -> do latex_draw = pauseAtEnd 1 $ defineAnimation $ proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< toHtml $ mkBackground "black"
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 = translate (320/2) (180/2) . scale 5
fillText txt = defineAnimation $ proc () -> do fillText txt = defineAnimation $ proc () -> do
duration 1 -< () duration 1 -< ()
s <- signal 0 1 -< () s <- signal 0 1 -< ()
emit -< placement $ emit -< toHtml $ placement $
g_ [fill_ "white", num_ fill_opacity_ s] $ withFillColor "white" $ withFillOpacity s $
toHtml $ latexAlign txt center $ latexAlign txt
drawText txt = defineAnimation $ proc () -> do drawText txt = defineAnimation $ proc () -> do
duration 2 -< () duration 2 -< ()
s <- signal 0 1 -< () s <- signal 0 1 -< ()
emit -< placement $ emit -< toHtml $ placement $
g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] $ withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) $
toHtml $ partialSvg s $ latexAlign txt partialSvg s $ center $ latexAlign txt
``` ```
![Drawing LaTeX equations](gifs/latex_draw.gif) ![Drawing LaTeX equations](gifs/latex_draw.gif)
@ -54,27 +54,19 @@ bbox1 :: Ani ()
bbox1 = defineAnimation $ proc () -> do bbox1 = defineAnimation $ proc () -> do
duration 5 -< () duration 5 -< ()
s <- signal 0 1 -< () s <- signal 0 1 -< ()
let rotated = rotate (360*s) svg
(x, y, w, h) = boundingBox rotated
emit -< do emit -< do
g_ [transform_ $ Lucid.translate x y] $ toHtml $ mkBoundingBox $ rotate (360*s) svg
rect_ [num_ width_ w, num_ height_ h, stroke_ "red", fill_opacity_ "0"] toHtml $ withFillColor "white" $ rotate (360*s) svg
g_ [fill_ "white"] $ toHtml rotated
where where
msg = "\\sum_{k=1}^\\infty" svg = scale 3 $ center $ latexAlign "\\sum_{k=1}^\\infty"
svg = scale 3 $ center $ latexAlign msg
bbox2 :: Ani () bbox2 :: Ani ()
bbox2 = defineAnimation $ proc () -> do bbox2 = defineAnimation $ proc () -> do
duration 5 -< () duration 5 -< ()
s <- signalOscillate 0 1 -< () s <- signalOscillate 0 1 -< ()
let rotated = partialSvg s heartShape
(x, y, w, h) = boundingBox rotated
emit -< do emit -< do
g_ [transform_ $ Lucid.translate x y] $ toHtml $ mkBoundingBox $ partialSvg s heartShape
rect_ [num_ width_ w, num_ height_ h, stroke_ "red", fill_opacity_ "0"] toHtml $ withStrokeColor "white" $ withFillOpacity 0 $ partialSvg s heartShape
g_ [fill_ "white", fill_opacity_ "0", stroke_width_ "4", stroke_ "white"] $
toHtml rotated
``` ```
![Bounding boxes](gifs/bbox.gif) ![Bounding boxes](gifs/bbox.gif)
@ -88,21 +80,19 @@ bbox2 = defineAnimation $ proc () -> do
sinewave :: Ani () sinewave :: Ani ()
sinewave = proc () -> do sinewave = proc () -> do
duration 10 -< () duration 10 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< toHtml $ mkBackground "black"
idx <- signalOscillate 0 1 -< () idx <- signalOscillate 0 1 -< ()
emit -< do emit -< do
defs_ $ clipPath_ [id_ "clip"] $ defs_ $ clipPath_ [id_ "clip"] $ toHtml $
rect_ [x_ "0", num_ y_ (-height), num_ width_ (idx * width), height_ "100%"] mkRect (Num 0, Num (-height)) (Num $ idx*width) (Percent 100)
g_ [transform_ $ translate margin height, clip_path_ "url(#clip)"] $ toHtml $ translate margin height $ withStrokeColor "white" $
renderPath $ approxFnData 1000 wave withClipPathRef (Ref "clip") $ mkPathText $ renderPathText $ approxFnData 1000 wave
line_ [ num_ x1_ margin, num_ x2_ margin, y1_ "10", y2_ "170" toHtml $ withStrokeColor "white" $
, stroke_ "white"] mkLine (Num margin, Num 10) (Num margin, Num 170)
line_ [num_ x1_ margin, num_ x2_ (margin+width), num_ y1_ height, num_ y2_ height toHtml $ withStrokeColor "white" $
, stroke_ "white"] mkLine (Num margin, Num height) (Num (margin+width), Num height)
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
@ -114,22 +104,20 @@ sinewave = proc () -> do
## Morphing wave ## Morphing wave
```haskell ```haskell
morph_wave :: Ani () morph_wave_circle :: Ani ()
morph_wave = proc () -> do morph_wave_circle = proc t -> do
duration 5 -< () duration 5 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] idx <- signalOscillate 0 1 -< ()
emit -< toHtml $ withStrokeColor "white" $ mkGroup
morph <- signalOscillate 0 1 -< () [ mkBackground "black"
emit -< do , translate 30 90 $ mkPathText $ renderPathText $ morphPath circle wave1 idx
g_ [transform_ $ translate 30 50] $ renderPath wave1 , mkLine (Num 30, Num 10) (Num 30, Num 170)
g_ [transform_ $ translate 30 130] $ renderPath wave2 , mkLine (Num 30, Num 90) (Num 290, Num 90) ]
g_ [transform_ $ translate 30 90] $ renderPath $ morphPath wave1 wave2 morph
line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"]
line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"]
where where
freq = 3; width = 260 freq = 5; width = 260; radius = 50
wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20)
wave2 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*(freq*3)) * 20) circle = approxFnData 1000 $ \idx ->
(cos (idx*pi*2+pi/2)*radius + width/2, sin (idx*pi*2+pi/2)*radius)
``` ```
![Morphing wave](gifs/morphwave.gif) ![Morphing wave](gifs/morphwave.gif)
@ -239,12 +227,13 @@ latex_basic :: Ani ()
latex_basic = proc () -> do latex_basic = proc () -> do
duration 2 -< () duration 2 -< ()
s <- signalOscillate 0 1 -< () s <- signalOscillate 0 1 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< toHtml $ mkGroup
emit -< [ mkBackground "black"
g_ [transform_ $ translate 20 15 <> " " <> scale 4 4] $ do , translate (320/2) (180/2) $ mkGroup
g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] text [ withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) text
g_ [fill_ "white", num_ fill_opacity_ s] text , withFillColor "white" $ withFillOpacity s text] ]
where where
text = latex "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" text = scale 4 $ center $ latexAlign
"\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
``` ```
![Basic LaTeX](gifs/latex_basic.gif) ![Basic LaTeX](gifs/latex_basic.gif)

BIN
gifs/latex_basic.gif
View file

Binary file not shown.
Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 170 KiB

After

Width:  |  Height:  |  Size: 128 KiB

Before After
Before After

BIN
gifs/latex_draw.gif
View file

Binary file not shown.
Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 110 KiB

After

Width:  |  Height:  |  Size: 111 KiB

Before After
Before After

8
reanimate.cabal
View file

@ -27,8 +27,8 @@ library
Reanimate.Svg.NamedColors Reanimate.Svg.NamedColors
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, matrix, containers, svg-tree >= 0.6.2.3, xml, bytestring, lens, linear, mtl, matrix,
JuicyPixels JuicyPixels, attoparsec
Flag gtk-viewer Flag gtk-viewer
Description: Enable gtk-based viewer Description: Enable gtk-based viewer
@ -52,7 +52,7 @@ executable reanimate-viewer
Reanimate.Svg.NamedColors Reanimate.Svg.NamedColors
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 >= 0.6.2.3, xml,
bytestring, lens, linear, mtl, matrix,JuicyPixels bytestring, lens, linear, mtl, matrix,JuicyPixels, attoparsec
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

123
src/Reanimate/Examples.hs
View file

@ -10,7 +10,7 @@ import Codec.Picture.Types
import Data.Monoid import Data.Monoid
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text, pack) import Data.Text (Text, pack)
import qualified Graphics.Svg as S import Graphics.Svg as S
import Linear.V2 import Linear.V2
import Lucid.Svg (Svg, circle_, clip_path_, cx_, cy_, d_, id_, defs_, clipPath_, import Lucid.Svg (Svg, circle_, clip_path_, cx_, cy_, d_, id_, defs_, clipPath_,
fill_, fill_opacity_, font_size_, g_, fill_, fill_opacity_, font_size_, g_,
@ -32,19 +32,17 @@ import Debug.Trace
sinewave :: Ani () sinewave :: Ani ()
sinewave = proc () -> do sinewave = proc () -> do
duration 10 -< () duration 10 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< toHtml $ mkBackground "black"
idx <- signalOscillate 0 1 -< () idx <- signalOscillate 0 1 -< ()
emit -< do emit -< do
defs_ $ clipPath_ [id_ "clip"] $ defs_ $ clipPath_ [id_ "clip"] $ toHtml $
rect_ [x_ "0", num_ y_ (-height), num_ width_ (idx * width), height_ "100%"] mkRect (Num 0, Num (-height)) (Num $ idx*width) (Percent 100)
g_ [transform_ $ Lucid.translate margin height, clip_path_ "url(#clip)"] $ toHtml $ translate margin height $ withStrokeColor "white" $
renderPath $ approxFnData 1000 wave withClipPathRef (Ref "clip") $ mkPathText $ renderPathText $ approxFnData 1000 wave
line_ [ num_ x1_ margin, num_ x2_ margin, y1_ "10", y2_ "170" toHtml $ withStrokeColor "white" $
, stroke_ "white"] mkLine (Num margin, Num 10) (Num margin, Num 170)
line_ [num_ x1_ margin, num_ x2_ (margin+width), num_ y1_ height, num_ y2_ height toHtml $ withStrokeColor "white" $
, stroke_ "white"] mkLine (Num margin, Num height) (Num (margin+width), Num height)
let (circX, circY) = wave idx let (circX, circY) = wave idx
emit -< g_ [transform_ $ Lucid.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"]
@ -55,15 +53,14 @@ sinewave = proc () -> do
morph_wave :: Ani () morph_wave :: Ani ()
morph_wave = proc () -> do morph_wave = proc () -> do
duration 5 -< () duration 5 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
morph <- signalOscillate 0 1 -< () morph <- signalOscillate 0 1 -< ()
emit -< do emit -< toHtml $ withStrokeColor "white" $ mkGroup
g_ [transform_ $ Lucid.translate 30 50] $ renderPath wave1 [ mkBackground "black"
g_ [transform_ $ Lucid.translate 30 130] $ renderPath wave2 , translate 30 50 $ mkPathText $ renderPathText wave1
g_ [transform_ $ Lucid.translate 30 90] $ renderPath $ morphPath wave1 wave2 morph , translate 30 130 $ mkPathText $ renderPathText wave2
line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"] , translate 30 90 $ mkPathText $ renderPathText $ morphPath wave1 wave2 morph
line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"] , mkLine (Num 30, Num 10) (Num 30, Num 170)
, mkLine (Num 30, Num 90) (Num 290, Num 90) ]
where where
freq = 3; width = 260 freq = 3; width = 260
wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20)
@ -71,15 +68,13 @@ morph_wave = proc () -> do
morph_wave_circle :: Ani () morph_wave_circle :: Ani ()
morph_wave_circle = proc t -> do morph_wave_circle = proc t -> do
duration 5 -< () duration 5 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] idx <- signalOscillate 0 1 -< ()
emit -< toHtml $ withStrokeColor "white" $ mkGroup
idx <- signalOscillate 0 1 -< () [ mkBackground "black"
emit -< do , translate 30 90 $ mkPathText $ renderPathText $ morphPath circle wave1 idx
g_ [transform_ $ Lucid.translate 30 90] $ , mkLine (Num 30, Num 10) (Num 30, Num 170)
renderPath $ morphPath circle wave1 idx , mkLine (Num 30, Num 90) (Num 290, Num 90) ]
line_ [x1_ "30", x2_ "30", y1_ "10", y2_ "170", stroke_ "white"]
line_ [x1_ "30", x2_ "290", y1_ "90", y2_ "90", stroke_ "white"]
where where
freq = 5; width = 260; radius = 50 freq = 5; width = 260; radius = 50
wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20)
@ -357,13 +352,14 @@ latex_basic :: Ani ()
latex_basic = proc () -> do latex_basic = proc () -> do
duration 2 -< () duration 2 -< ()
s <- signalOscillate 0 1 -< () s <- signalOscillate 0 1 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< toHtml $ mkGroup
emit -< [ mkBackground "black"
g_ [transform_ $ Lucid.translate 20 15 <> " " <> Lucid.scale 4 4] $ do , translate (320/2) (180/2) $ mkGroup
g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] text [ withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) text
g_ [fill_ "white", num_ fill_opacity_ s] text , withFillColor "white" $ withFillOpacity s text] ]
where where
text = toHtml $ latexAlign "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" text = scale 4 $ center $ latexAlign
"\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
bezier :: Ani () bezier :: Ani ()
bezier = adjustSpeed 0.4 $ proc () -> do bezier = adjustSpeed 0.4 $ proc () -> do
@ -428,28 +424,28 @@ pathSquare = proc () -> do
latex_draw :: Ani () latex_draw :: Ani ()
latex_draw = pauseAtEnd 1 $ defineAnimation $ proc () -> do latex_draw = pauseAtEnd 1 $ defineAnimation $ proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< toHtml $ mkBackground "black"
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_ $ Lucid.translate 20 15 <> " " <> Lucid.scale 5 5] placement = translate (320/2) (180/2) . scale 5
fillText txt = defineAnimation $ proc () -> do fillText txt = defineAnimation $ proc () -> do
duration 1 -< () duration 1 -< ()
s <- signal 0 1 -< () s <- signal 0 1 -< ()
emit -< placement $ emit -< toHtml $ placement $
g_ [fill_ "white", num_ fill_opacity_ s] $ withFillColor "white" $ withFillOpacity s $
toHtml $ latexAlign txt center $ latexAlign txt
drawText txt = defineAnimation $ proc () -> do drawText txt = defineAnimation $ proc () -> do
duration 2 -< () duration 2 -< ()
s <- signal 0 1 -< () s <- signal 0 1 -< ()
emit -< placement $ emit -< toHtml $ placement $
g_ [stroke_ "white", fill_opacity_ "0", stroke_width_ "0.1"] $ withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) $
toHtml $ partialSvg s $ latexAlign txt partialSvg s $ center $ latexAlign txt
bbox :: Ani () bbox :: Ani ()
bbox = proc () -> do bbox = proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] emit -< toHtml $ mkBackground "black"
annotate' bbox1 -< g_ [transform_ $ Lucid.translate (320/2-50) (180/2)] annotate' bbox1 -< g_ [transform_ $ Lucid.translate (320/2-50) (180/2)]
annotate' bbox2 -< g_ [transform_ $ Lucid.translate (320/2+50) (180/2)] annotate' bbox2 -< g_ [transform_ $ Lucid.translate (320/2+50) (180/2)]
@ -457,37 +453,28 @@ bbox1 :: Ani ()
bbox1 = defineAnimation $ proc () -> do bbox1 = defineAnimation $ proc () -> do
duration 5 -< () duration 5 -< ()
s <- signal 0 1 -< () s <- signal 0 1 -< ()
let rotated = rotate (360*s) svg
(x, y, w, h) = boundingBox rotated
emit -< do emit -< do
g_ [transform_ $ Lucid.translate x y] $ toHtml $ mkBoundingBox $ rotate (360*s) svg
rect_ [num_ width_ w, num_ height_ h, stroke_ "red", fill_opacity_ "0"] toHtml $ withFillColor "white" $ rotate (360*s) svg
g_ [fill_ "white"] $ toHtml rotated
where where
msg = "\\sum_{k=1}^\\infty" svg = scale 3 $ center $ latexAlign "\\sum_{k=1}^\\infty"
svg = scale 3 $ center $ latexAlign msg
bbox2 :: Ani () bbox2 :: Ani ()
bbox2 = defineAnimation $ proc () -> do bbox2 = defineAnimation $ proc () -> do
duration 5 -< () duration 5 -< ()
s <- signalOscillate 0 1 -< () s <- signalOscillate 0 1 -< ()
let rotated = partialSvg s heartShape
(x, y, w, h) = boundingBox rotated
emit -< do emit -< do
toHtml $ withStrokeColor "red" $ withFillOpacity 0 $ toHtml $ mkBoundingBox $ partialSvg s heartShape
mkRect (S.Num x, S.Num y) (S.Num w) (S.Num h) toHtml $ withStrokeColor "white" $ withFillOpacity 0 $ partialSvg s heartShape
toHtml $ withStrokeColor "white" $ withFillOpacity 0 $
rotated mkBoundingBox :: Tree -> Tree
mkBoundingBox svg = withStrokeColor "red" $ withFillOpacity 0 $
mkRect (S.Num x, S.Num y) (S.Num w) (S.Num h)
where
(x, y, w, h) = boundingBox svg
heartShape = heartShape =
rotate 225 $ center $ p rotate 225 $ center $ mkPathString
where "M0.0,40.0 v-40.0 h40.0\
p = S.PathTree $ S.defaultSvg & S.pathDefinition .~ cmds \a20.0 20.0 90.0 0 1 0.0,40.0\
abs = S.OriginAbsolute \a20.0 20.0 90.0 0 1 -40.0,0.0 Z"
rel = S.OriginRelative
cmds =
[S.MoveTo abs [V2 0 40]
,S.VerticalTo rel [-40],S.HorizontalTo rel [40]
,S.EllipticalArc rel [(20,20,90,False,True, V2 0 40)]
,S.EllipticalArc rel [(20,20,90,False,True, V2 (-40) 0)]
,S.EndPath]

53
src/Reanimate/Svg.hs
View file

@ -4,10 +4,14 @@ import Codec.Picture (PixelRGBA8 (..))
import Control.Lens (over, set, (%~), (&), (.~), (^.)) import Control.Lens (over, set, (%~), (&), (.~), (^.))
import Control.Monad.Fix import Control.Monad.Fix
import Control.Monad.State import Control.Monad.State
import Control.Arrow
import Data.Attoparsec.Text (parseOnly)
import Data.List import Data.List
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import qualified Data.Text as T
import Graphics.Svg import Graphics.Svg
import Graphics.Svg.PathParser
import Linear.Metric import Linear.Metric
import Linear.V2 import Linear.V2
import Linear.Vector import Linear.Vector
@ -16,6 +20,9 @@ import qualified Reanimate.Transform as Transform
import Debug.Trace import Debug.Trace
defaultDPI :: Dpi
defaultDPI = 96
replaceUses :: Document -> Document replaceUses :: Document -> Document
replaceUses doc = doc & elements %~ map (mapTree replace) replaceUses doc = doc & elements %~ map (mapTree replace)
& definitions .~ Map.empty & definitions .~ Map.empty
@ -33,7 +40,6 @@ replaceUses doc = doc & elements %~ map (mapTree replace)
case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of
(Num a, Num b) -> Translate a b (Num a, Num b) -> Translate a b
_ -> TransformUnknown _ -> TransformUnknown
defaultDPI = 96
docTree = GroupTree $ set groupChildren (doc^.elements) defaultSvg docTree = GroupTree $ set groupChildren (doc^.elements) defaultSvg
idMap = foldTree updMap Map.empty docTree `Map.union` idMap = foldTree updMap Map.empty docTree `Map.union`
Map.mapMaybe elementToTree (doc^.definitions) Map.mapMaybe elementToTree (doc^.definitions)
@ -319,12 +325,20 @@ svgBoundingPoints t = map (Transform.transformPoint m) $
PolyLineTree{} -> error "PolyLineTree" PolyLineTree{} -> error "PolyLineTree"
EllipseTree{} -> error "EllipseTree" EllipseTree{} -> error "EllipseTree"
LineTree{} -> error "LineTree" LineTree{} -> error "LineTree"
RectangleTree{} -> error "RectangleTree" RectangleTree rect ->
-- toUserUnit defaultDPI x
case mapTuple (toUserUnit defaultDPI) (rect^.rectUpperLeftCorner) of
(Num x, Num y) -> [V2 x y] ++
case mapTuple (toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of
(Num w, Num h) -> [V2 (x+w) (y+h)]
_ -> []
_ -> []
TextTree{} -> [] TextTree{} -> []
ImageTree{} -> [] ImageTree{} -> []
MeshGradientTree{} -> [] MeshGradientTree{} -> []
where where
m = Transform.mkMatrix (t^.drawAttr.transform) m = Transform.mkMatrix (t^.drawAttr.transform)
mapTuple f = f *** f
withTransformations :: [Transformation] -> Tree -> Tree withTransformations :: [Transformation] -> Tree -> Tree
withTransformations transformations = withDrawAttributes (transform .~ Just transformations) withTransformations transformations = withDrawAttributes (transform .~ Just transformations)
@ -365,14 +379,41 @@ mkColor name =
withStrokeColor :: String -> Tree -> Tree withStrokeColor :: String -> Tree -> Tree
withStrokeColor color = withDrawAttributes (strokeColor .~ pure (mkColor color)) withStrokeColor color = withDrawAttributes (strokeColor .~ pure (mkColor color))
withFillColor :: String -> Tree -> Tree
withFillColor color = withDrawAttributes (fillColor .~ pure (mkColor color))
withFillOpacity :: Double -> Tree -> Tree withFillOpacity :: Double -> Tree -> Tree
withFillOpacity opacity = withDrawAttributes (fillOpacity .~ Just (realToFrac opacity)) withFillOpacity opacity = withDrawAttributes (fillOpacity .~ Just (realToFrac opacity))
withStrokeWidth :: Number -> Tree -> Tree withStrokeWidth :: Number -> Tree -> Tree
withStrokeWidth width = withDrawAttributes (strokeWidth .~ pure width) withStrokeWidth width = withDrawAttributes (strokeWidth .~ pure width)
withClipPathRef :: ElementRef -> Tree -> Tree
withClipPathRef ref = withDrawAttributes (clipPathRef .~ pure ref)
mkRect :: Point -> Number -> Number -> Tree mkRect :: Point -> Number -> Number -> Tree
mkRect corner width height = RectangleTree $ mkRect corner width height = RectangleTree $ defaultSvg
defaultSvg & rectUpperLeftCorner .~ corner & rectUpperLeftCorner .~ corner
& rectWidth .~ width & rectWidth .~ width
& rectHeight .~ height & rectHeight .~ height
mkLine :: Point -> Point -> Tree
mkLine point1 point2 = LineTree $ defaultSvg
& linePoint1 .~ point1
& linePoint2 .~ point2
mkGroup :: [Tree] -> Tree
mkGroup forest = GroupTree $ defaultSvg
& groupChildren .~ forest
mkPathString :: String -> Tree
mkPathString = mkPathText . T.pack
mkPathText :: T.Text -> Tree
mkPathText str =
case parseOnly pathParser str of
Left err -> error err
Right cmds -> PathTree $ defaultSvg & pathDefinition .~ cmds
mkBackground :: String -> Tree
mkBackground color = withFillColor color $ mkRect (Num 0, Num 0) (Percent 100) (Percent 100)

2
stack.yaml
View file

@ -7,4 +7,4 @@ extra-deps:
- gtk-0.15.0@sha256:a76d280dbeefbe08cf021c31bcd51c09cda97ebee7934debbfc14e1da4220b78 - gtk-0.15.0@sha256:a76d280dbeefbe08cf021c31bcd51c09cda97ebee7934debbfc14e1da4220b78
- svgcairo-0.13.1.1@sha256:145b6acce7306e84652376efb3f00e9194ccd8787a62d3f93fb539c4a3382a2e - svgcairo-0.13.1.1@sha256:145b6acce7306e84652376efb3f00e9194ccd8787a62d3f93fb539c4a3382a2e
- lucid-svg-0.7.0.0@sha256:2a2d0fe51329e8b89f723a8e86e6ab8d150d7b205591fffe4c09d8d11e022f98 - lucid-svg-0.7.0.0@sha256:2a2d0fe51329e8b89f723a8e86e6ab8d150d7b205591fffe4c09d8d11e022f98
- svg-tree-0.6.2.3