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