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 -- > mkImage screenWidth screenHeight "../data/haskell.svg"
75 --
76 -- <<docs/gifs/doc_mkImage.gif>>
77 mkImage
78 :: Double -- ^ Desired image width.
79 -> Double -- ^ Desired image height.
80 -> FilePath -- ^ Path to external image file.
81 -> SVG
82 mkImage width height path | takeExtension path == ".svg" = unsafePerformIO $ do
83 svg_data <- B.readFile path
84 case parseSvgFile path svg_data of
85 Nothing -> error "Malformed svg"
86 Just svg ->
87 return
88 $ scaleXY (width / screenWidth) (height / screenHeight)
89 $ embedDocument svg
90 mkImage width height path | pRaster == RasterNone = unsafePerformIO $ do
91 inp <- LBS.readFile path
92 let imgData = LBS.unpack $ Base64.encode inp
93 return
94 $ flipYAxis
95 $ ImageTree
96 $ defaultSvg
97 & Svg.imageWidth
98 .~ Svg.Num width
99 & Svg.imageHeight
100 .~ Svg.Num height
101 & Svg.imageHref
102 .~ ("data:" ++ mimeType ++ ";base64," ++ imgData)
103 & Svg.imageCornerUpperLeft
104 .~ (Svg.Num (-width / 2), Svg.Num (-height / 2))
105 & Svg.imageAspectRatio
106 .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing
107 where
108 -- FIXME: Is there a better way to do this?
109 mimeType = case takeExtension path of
110 ".jpg" -> "image/jpeg"
111 ext -> "image/" ++ drop 1 ext
112 mkImage width height path = unsafePerformIO $ do
113 exists <- doesFileExist target
114 unless exists $ copyFile path target
115 return
116 $ flipYAxis
117 $ ImageTree
118 $ defaultSvg
119 & Svg.imageWidth
120 .~ Svg.Num width
121 & Svg.imageHeight
122 .~ Svg.Num height
123 & Svg.imageHref
124 .~ ("file://" ++ target)
125 & Svg.imageCornerUpperLeft
126 .~ (Svg.Num (-width / 2), Svg.Num (-height / 2))
127 & Svg.imageAspectRatio
128 .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing
129 where
130 target = pRootDirectory </> encodeInt hashPath <.> takeExtension path
131 hashPath = hash path
132
133 -- | Write in-memory image to cache file if (and only if) such cache file doesn't
134 -- already exist.
135 cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath
136 cacheImage key gen = unsafePerformIO $ cacheFile template $ \path ->
137 writePng path gen
138 where template = encodeInt (hash key) <.> "png"
139
140 -- Warning: Caching svg elements with links to external objects does
141 -- not work. 2020-06-01
142 -- | Same as 'prerenderSvg' but returns the location of the rendered image
143 -- as a FilePath.
144 prerenderSvgFile :: Hashable a => a -> Width -> Height -> SVG -> FilePath
145 prerenderSvgFile key width height svg =
146 unsafePerformIO $ cacheFile template $ \path -> do
147 let svgPath = replaceExtension path "svg"
148 writeFile svgPath rendered
149 engine <- requireRaster pRaster
150 applyRaster engine svgPath
151 where
152 template = encodeInt (hash (key, width, height)) <.> "png"
153 rendered = renderSvg (Just $ Px $ fromIntegral width)
154 (Just $ Px $ fromIntegral height)
155 svg
156
157 -- | Render SVG node to a PNG file and return a new node containing
158 -- that image. For static SVG nodes, this can hugely improve performance.
159 -- The first argument is the key that determines SVG uniqueness. It
160 -- is entirely your responsibility to ensure that all keys are unique.
161 -- If they are not, you will be served stale results from the cache.
162 prerenderSvg :: Hashable a => a -> SVG -> SVG
163 prerenderSvg key =
164 mkImage screenWidth screenHeight . prerenderSvgFile key pWidth pHeight
165
166
167 {-# INLINE embedImage #-}
168 -- | Embed an in-memory PNG image. Note, the pixel size of the image
169 -- is used as the dimensions. As such, embedding a 100x100 PNG will
170 -- result in an image 100 units wide and 100 units high. Consider
171 -- using with 'scaleToSize'.
172 embedImage :: PngSavable a => Image a -> SVG
173 embedImage img = embedPng width height (encodePng img)
174 where
175 width = fromIntegral $ imageWidth img
176 height = fromIntegral $ imageHeight img
177
178 -- | Embed in-memory PNG bytestring without parsing it.
179 embedPng
180 :: Double -- ^ Width
181 -> Double -- ^ Height
182 -> LBS.ByteString -- ^ Raw PNG data
183 -> SVG
184 -- embedPng w h png = unsafePerformIO $ do
185 -- LBS.writeFile path png
186 -- return $ ImageTree $ defaultSvg
187 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2))
188 -- & Svg.imageWidth .~ Svg.Num w
189 -- & Svg.imageHeight .~ Svg.Num h
190 -- & Svg.imageHref .~ ("file://"++path)
191 -- where
192 -- path = "/tmp" </> show (hash png) <.> "png"
193 embedPng w h png =
194 flipYAxis
195 $ ImageTree
196 $ defaultSvg
197 & Svg.imageCornerUpperLeft
198 .~ (Svg.Num (-w / 2), Svg.Num (-h / 2))
199 & Svg.imageWidth
200 .~ Svg.Num w
201 & Svg.imageHeight
202 .~ Svg.Num h
203 & Svg.imageHref
204 .~ ("data:image/png;base64," ++ imgData)
205 where imgData = LBS.unpack $ Base64.encode png
206
207
208 {-# INLINE embedDynamicImage #-}
209 -- | Embed an in-memory image. Note, the pixel size of the image
210 -- is used as the dimensions. As such, embedding a 100x100 image will
211 -- result in an image 100 units wide and 100 units high. Consider
212 -- using with 'scaleToSize'.
213 embedDynamicImage :: DynamicImage -> SVG
214 embedDynamicImage img = embedPng width height imgData
215 where
216 width = fromIntegral $ dynamicMap imageWidth img
217 height = fromIntegral $ dynamicMap imageHeight img
218 imgData = case encodeDynamicPng img of
219 Left err -> error err
220 Right dat -> dat
221
222 -- embedImageFile :: FilePath -> Tree
223 -- embedImageFile path = unsafePerformIO $ do
224 -- png <- B.readFile path
225 -- case decodePng png of
226 -- Left{} -> error "bad image"
227 -- Right img -> return $
228 -- let width = fromIntegral $ dynamicMap imageWidth img
229 -- height = fromIntegral $ dynamicMap imageHeight img in
230 -- ImageTree $ defaultSvg
231 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2))
232 -- & Svg.imageWidth .~ Svg.Num width
233 -- & Svg.imageHeight .~ Svg.Num height
234 -- & Svg.imageHref .~ ("file://" ++ path)
235
236
237 -- | Convert an SVG object to a pixel-based image. The default resolution
238 -- is 2560x1440. See also 'rasterSized'. Multiple raster engines are supported
239 -- and are selected using the '--raster' flag in the driver.
240 raster :: SVG -> DynamicImage
241 raster = rasterSized 2560 1440
242
243 -- | Convert an SVG object to a pixel-based image.
244 rasterSized
245 :: Width -- ^ X resolution in pixels
246 -> Height -- ^ Y resolution in pixels
247 -> SVG -- ^ SVG object
248 -> DynamicImage
249 rasterSized w h svg = unsafePerformIO $ do
250 png <- B.readFile (svgAsPngFile' w h svg)
251 case decodePng png of
252 Left{} -> error "bad image"
253 Right img -> return img
254
255 -- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons.
256 vectorize :: FilePath -> SVG
257 vectorize = vectorize_ []
258
259 -- | Same as 'vectorize' but takes a list of arguments for 'potrace'.
260 vectorize_ :: [String] -> FilePath -> SVG
261 vectorize_ _ path | pNoExternals = mkText $ T.pack path
262 vectorize_ args path = unsafePerformIO $ do
263 root <- getXdgDirectory XdgCache "reanimate"
264 createDirectoryIfMissing True root
265 let svgPath = root </> encodeInt key <.> "svg"
266 hit <- doesFileExist svgPath
267 unless hit $ withSystemTempFile "file.svg" $ \tmpSvgPath svgH ->
268 withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do
269 hClose svgH
270 hClose bmpH
271 potrace <- requireExecutable "potrace"
272 magick <- requireExecutable magickCmd
273 runCmd magick [path, "-flatten", tmpBmpPath]
274 runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath])
275 renameOrCopyFile tmpSvgPath svgPath
276 svg_data <- B.readFile svgPath
277 case parseSvgFile svgPath svg_data of
278 Nothing -> do
279 removeFile svgPath
280 error "Malformed svg"
281 Just svg -> return $ unbox $ replaceUses svg
282 where key = hash (path, args)
283
284 -- imageAsFile :: DynamicImage -> FilePath
285 -- imageAsFile img
286
287 -- | Convert an SVG object to a pixel-based image and save it to disk, returning
288 -- the filepath. The default resolution is 2560x1440. See also 'svgAsPngFile''.
289 -- Multiple raster engines are supported and are selected using the '--raster'
290 -- flag in the driver.
291 svgAsPngFile :: SVG -> FilePath
292 svgAsPngFile = svgAsPngFile' width height
293 where
294 width = 2560
295 height = width * 9 `div` 16
296
297 -- | Convert an SVG object to a pixel-based image and save it to disk, returning
298 -- the filepath.
299 svgAsPngFile'
300 :: Width -- ^ Width
301 -> Height -- ^ Height
302 -> SVG -- ^ SVG object
303 -> FilePath
304 svgAsPngFile' _ _ _ | pNoExternals = "/svgAsPngFile/has/been/disabled"
305 svgAsPngFile' width height svg =
306 unsafePerformIO $ cacheFile template $ \pngPath -> do
307 let svgPath = replaceExtension pngPath "svg"
308 writeFile svgPath rendered
309 engine <- requireRaster pRaster
310 applyRaster engine svgPath
311 where
312 template = encodeInt (hash rendered) <.> "png"
313 rendered = renderSvg (Just $ Px $ fromIntegral width)
314 (Just $ Px $ fromIntegral height)
315 svg