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