never executed always true always false
1 module Reanimate.Raster
2 ( mkImage -- :: Double -> Double -> FilePath -> SVG
3 , cacheImage -- :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath
4 , prerenderSvg -- :: Hashable a => a -> SVG -> SVG
5 , prerenderSvgFile -- :: Hashable a => a -> Width -> Height -> SVG -> FilePath
6 , embedImage -- :: PngSavable a => Image a -> SVG
7 , embedDynamicImage -- :: DynamicImage -> SVG
8 , embedPng -- :: Double -> Double -> LBS.ByteString -> SVG
9 , raster -- :: SVG -> DynamicImage
10 , rasterSized -- :: Width -> Height -> SVG -> DynamicImage
11 , vectorize -- :: FilePath -> SVG
12 , vectorize_ -- :: [String] -> FilePath -> SVG
13 , svgAsPngFile -- :: SVG -> FilePath
14 , svgAsPngFile' -- :: Width -> Height -> SVG -> FilePath
15 )
16 where
17
18 import Codec.Picture
19 import Control.Lens ( (&)
20 , (.~)
21 )
22 import Control.Monad
23 import qualified Data.ByteString as B
24 import qualified Data.ByteString.Base64.Lazy as Base64
25 import qualified Data.ByteString.Lazy.Char8 as LBS
26 import Data.Hashable
27 import qualified Data.Text as T
28 import Graphics.SvgTree ( Number(..)
29 , Tree(..)
30 , defaultSvg
31 , parseSvgFile
32 )
33 import qualified Graphics.SvgTree as Svg
34 import Reanimate.Animation
35 import Reanimate.Cache
36 import Reanimate.Driver.Magick
37 import Reanimate.Misc
38 import Reanimate.Render
39 import Reanimate.Parameters
40 import Reanimate.Constants
41 import Reanimate.Svg.Constructors
42 import Reanimate.Svg.Unuse
43 import System.Directory
44 import System.FilePath
45 import System.IO
46 import System.IO.Temp
47 import System.IO.Unsafe
48
49 -- | Load an external image. Width and height must be specified,
50 -- ignoring the image's aspect ratio. The center of the image is
51 -- placed at position (0,0).
52 --
53 -- For security reasons, must SVG renderer do not allow arbitrary
54 -- image links. For some renderers, we can get around this by placing
55 -- the images in the same root directory as the parent SVG file. Other
56 -- renderers (like Chrome and ffmpeg) requires that the image is inlined
57 -- as base64 data. External SVG files are an exception, though, as must
58 -- always be inlined directly. `mkImage` attempts to hide all the complexity
59 -- but edge-cases may exist.
60 --
61 -- Example:
62 --
63 -- > mkImage screenWidth screenHeight "../data/haskell.svg"
64 --
65 -- <<docs/gifs/doc_mkImage.gif>>
66 mkImage
67 :: Double -- ^ Desired image width.
68 -> Double -- ^ Desired image height.
69 -> FilePath -- ^ Path to external image file.
70 -> SVG
71 mkImage width height path | takeExtension path == ".svg" = unsafePerformIO $ do
72 svg_data <- B.readFile path
73 case parseSvgFile path svg_data of
74 Nothing -> error "Malformed svg"
75 Just svg ->
76 return
77 $ scaleXY (width / screenWidth) (height / screenHeight)
78 $ embedDocument svg
79 mkImage width height path | pRaster == RasterNone = unsafePerformIO $ do
80 inp <- LBS.readFile path
81 let imgData = LBS.unpack $ Base64.encode inp
82 return
83 $ flipYAxis
84 $ ImageTree
85 $ defaultSvg
86 & Svg.imageWidth
87 .~ Svg.Num width
88 & Svg.imageHeight
89 .~ Svg.Num height
90 & Svg.imageHref
91 .~ ("data:" ++ mimeType ++ ";base64," ++ imgData)
92 & Svg.imageCornerUpperLeft
93 .~ (Svg.Num (-width / 2), Svg.Num (-height / 2))
94 & Svg.imageAspectRatio
95 .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing
96 where
97 -- FIXME: Is there a better way to do this?
98 mimeType = case takeExtension path of
99 ".jpg" -> "image/jpeg"
100 ext -> "image/" ++ drop 1 ext
101 mkImage width height path = unsafePerformIO $ do
102 exists <- doesFileExist target
103 unless exists $ copyFile path target
104 return
105 $ flipYAxis
106 $ ImageTree
107 $ defaultSvg
108 & Svg.imageWidth
109 .~ Svg.Num width
110 & Svg.imageHeight
111 .~ Svg.Num height
112 & Svg.imageHref
113 .~ ("file://" ++ target)
114 & Svg.imageCornerUpperLeft
115 .~ (Svg.Num (-width / 2), Svg.Num (-height / 2))
116 & Svg.imageAspectRatio
117 .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing
118 where
119 target = pRootDirectory </> encodeInt hashPath <.> takeExtension path
120 hashPath = hash path
121
122 -- | Write in-memory image to cache file if (and only if) such cache file doesn't
123 -- already exist.
124 cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath
125 cacheImage key gen = unsafePerformIO $ cacheFile template $ \path ->
126 writePng path gen
127 where template = encodeInt (hash key) <.> "png"
128
129 -- Warning: Caching svg elements with links to external objects does
130 -- not work. 2020-06-01
131 -- | Same as 'prerenderSvg' but returns the location of the rendered image
132 -- as a FilePath.
133 prerenderSvgFile :: Hashable a => a -> Width -> Height -> SVG -> FilePath
134 prerenderSvgFile key width height svg =
135 unsafePerformIO $ cacheFile template $ \path -> do
136 let svgPath = replaceExtension path "svg"
137 writeFile svgPath rendered
138 engine <- requireRaster pRaster
139 applyRaster engine svgPath
140 where
141 template = encodeInt (hash (key, width, height)) <.> "png"
142 rendered = renderSvg (Just $ Px $ fromIntegral width)
143 (Just $ Px $ fromIntegral height)
144 svg
145
146 -- | Render SVG node to a PNG file and return a new node containing
147 -- that image. For static SVG nodes, this can hugely improve performance.
148 -- The first argument is the key that determines SVG uniqueness. It
149 -- is entirely your responsibility to ensure that all keys are unique.
150 -- If they are not, you will be served stale results from the cache.
151 prerenderSvg :: Hashable a => a -> SVG -> SVG
152 prerenderSvg key =
153 mkImage screenWidth screenHeight . prerenderSvgFile key pWidth pHeight
154
155
156 {-# INLINE embedImage #-}
157 -- | Embed an in-memory PNG image. Note, the pixel size of the image
158 -- is used as the dimensions. As such, embedding a 100x100 PNG will
159 -- result in an image 100 units wide and 100 units high. Consider
160 -- using with 'scaleToSize'.
161 embedImage :: PngSavable a => Image a -> SVG
162 embedImage img = embedPng width height (encodePng img)
163 where
164 width = fromIntegral $ imageWidth img
165 height = fromIntegral $ imageHeight img
166
167 -- | Embed in-memory PNG bytestring without parsing it.
168 embedPng
169 :: Double -- ^ Width
170 -> Double -- ^ Height
171 -> LBS.ByteString -- ^ Raw PNG data
172 -> SVG
173 -- embedPng w h png = unsafePerformIO $ do
174 -- LBS.writeFile path png
175 -- return $ ImageTree $ defaultSvg
176 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2))
177 -- & Svg.imageWidth .~ Svg.Num w
178 -- & Svg.imageHeight .~ Svg.Num h
179 -- & Svg.imageHref .~ ("file://"++path)
180 -- where
181 -- path = "/tmp" </> show (hash png) <.> "png"
182 embedPng w h png =
183 flipYAxis
184 $ ImageTree
185 $ defaultSvg
186 & Svg.imageCornerUpperLeft
187 .~ (Svg.Num (-w / 2), Svg.Num (-h / 2))
188 & Svg.imageWidth
189 .~ Svg.Num w
190 & Svg.imageHeight
191 .~ Svg.Num h
192 & Svg.imageHref
193 .~ ("data:image/png;base64," ++ imgData)
194 where imgData = LBS.unpack $ Base64.encode png
195
196
197 {-# INLINE embedDynamicImage #-}
198 -- | Embed an in-memory image. Note, the pixel size of the image
199 -- is used as the dimensions. As such, embedding a 100x100 image will
200 -- result in an image 100 units wide and 100 units high. Consider
201 -- using with 'scaleToSize'.
202 embedDynamicImage :: DynamicImage -> SVG
203 embedDynamicImage img = embedPng width height imgData
204 where
205 width = fromIntegral $ dynamicMap imageWidth img
206 height = fromIntegral $ dynamicMap imageHeight img
207 imgData = case encodeDynamicPng img of
208 Left err -> error err
209 Right dat -> dat
210
211 -- embedImageFile :: FilePath -> Tree
212 -- embedImageFile path = unsafePerformIO $ do
213 -- png <- B.readFile path
214 -- case decodePng png of
215 -- Left{} -> error "bad image"
216 -- Right img -> return $
217 -- let width = fromIntegral $ dynamicMap imageWidth img
218 -- height = fromIntegral $ dynamicMap imageHeight img in
219 -- ImageTree $ defaultSvg
220 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2))
221 -- & Svg.imageWidth .~ Svg.Num width
222 -- & Svg.imageHeight .~ Svg.Num height
223 -- & Svg.imageHref .~ ("file://" ++ path)
224
225
226 -- | Convert an SVG object to a pixel-based image. The default resolution
227 -- is 2560x1440. See also 'rasterSized'. Multiple raster engines are supported
228 -- and are selected using the '--raster' flag in the driver.
229 raster :: SVG -> DynamicImage
230 raster = rasterSized 2560 1440
231
232 -- | Convert an SVG object to a pixel-based image.
233 rasterSized
234 :: Width -- ^ X resolution in pixels
235 -> Height -- ^ Y resolution in pixels
236 -> SVG -- ^ SVG object
237 -> DynamicImage
238 rasterSized w h svg = unsafePerformIO $ do
239 png <- B.readFile (svgAsPngFile' w h svg)
240 case decodePng png of
241 Left{} -> error "bad image"
242 Right img -> return img
243
244 -- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons.
245 vectorize :: FilePath -> SVG
246 vectorize = vectorize_ []
247
248 -- | Same as 'vectorize' but takes a list of arguments for 'potrace'.
249 vectorize_ :: [String] -> FilePath -> SVG
250 vectorize_ _ path | pNoExternals = mkText $ T.pack path
251 vectorize_ args path = unsafePerformIO $ do
252 root <- getXdgDirectory XdgCache "reanimate"
253 createDirectoryIfMissing True root
254 let svgPath = root </> encodeInt key <.> "svg"
255 hit <- doesFileExist svgPath
256 unless hit $ withSystemTempFile "file.svg" $ \tmpSvgPath svgH ->
257 withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do
258 hClose svgH
259 hClose bmpH
260 potrace <- requireExecutable "potrace"
261 magick <- requireExecutable magickCmd
262 runCmd magick [path, "-flatten", tmpBmpPath]
263 runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath])
264 renameOrCopyFile tmpSvgPath svgPath
265 svg_data <- B.readFile svgPath
266 case parseSvgFile svgPath svg_data of
267 Nothing -> do
268 removeFile svgPath
269 error "Malformed svg"
270 Just svg -> return $ unbox $ replaceUses svg
271 where key = hash (path, args)
272
273 -- imageAsFile :: DynamicImage -> FilePath
274 -- imageAsFile img
275
276 -- | Convert an SVG object to a pixel-based image and save it to disk, returning
277 -- the filepath. The default resolution is 2560x1440. See also 'svgAsPngFile''.
278 -- Multiple raster engines are supported and are selected using the '--raster'
279 -- flag in the driver.
280 svgAsPngFile :: SVG -> FilePath
281 svgAsPngFile = svgAsPngFile' width height
282 where
283 width = 2560
284 height = width * 9 `div` 16
285
286 -- | Convert an SVG object to a pixel-based image and save it to disk, returning
287 -- the filepath.
288 svgAsPngFile'
289 :: Width -- ^ Width
290 -> Height -- ^ Height
291 -> SVG -- ^ SVG object
292 -> FilePath
293 svgAsPngFile' _ _ _ | pNoExternals = "/svgAsPngFile/has/been/disabled"
294 svgAsPngFile' width height svg =
295 unsafePerformIO $ cacheFile template $ \pngPath -> do
296 let svgPath = replaceExtension pngPath "svg"
297 writeFile svgPath rendered
298 engine <- requireRaster pRaster
299 applyRaster engine svgPath
300 where
301 template = encodeInt (hash rendered) <.> "png"
302 rendered = renderSvg (Just $ Px $ fromIntegral width)
303 (Just $ Px $ fromIntegral height)
304 svg