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 cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath
123 cacheImage key gen = unsafePerformIO $ cacheFile template $ \path ->
124 writePng path gen
125 where template = encodeInt (hash key) <.> "png"
126
127 -- Warning: Caching svg elements with links to external objects does
128 -- not work. 2020-06-01
129 prerenderSvgFile :: Hashable a => a -> Width -> Height -> SVG -> FilePath
130 prerenderSvgFile key width height svg =
131 unsafePerformIO $ cacheFile template $ \path -> do
132 let svgPath = replaceExtension path "svg"
133 writeFile svgPath rendered
134 engine <- requireRaster pRaster
135 applyRaster engine svgPath
136 where
137 template = encodeInt (hash (key, width, height)) <.> "png"
138 rendered = renderSvg (Just $ Px $ fromIntegral width)
139 (Just $ Px $ fromIntegral height)
140 svg
141
142 prerenderSvg :: Hashable a => a -> SVG -> SVG
143 prerenderSvg key =
144 mkImage screenWidth screenHeight . prerenderSvgFile key pWidth pHeight
145
146
147 {-# INLINE embedImage #-}
148 -- | Embed an in-memory PNG image. Note, the pixel size of the image
149 -- is used as the dimensions. As such, embedding a 100x100 PNG will
150 -- result in an image 100 units wide and 100 units high. Consider
151 -- using with 'scaleToSize'.
152 embedImage :: PngSavable a => Image a -> SVG
153 embedImage img = embedPng width height (encodePng img)
154 where
155 width = fromIntegral $ imageWidth img
156 height = fromIntegral $ imageHeight img
157
158 -- | Embed in-memory PNG bytestring without parsing it.
159 embedPng
160 :: Double -- ^ Width
161 -> Double -- ^ Height
162 -> LBS.ByteString -- ^ Raw PNG data
163 -> SVG
164 -- embedPng w h png = unsafePerformIO $ do
165 -- LBS.writeFile path png
166 -- return $ ImageTree $ defaultSvg
167 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2))
168 -- & Svg.imageWidth .~ Svg.Num w
169 -- & Svg.imageHeight .~ Svg.Num h
170 -- & Svg.imageHref .~ ("file://"++path)
171 -- where
172 -- path = "/tmp" </> show (hash png) <.> "png"
173 embedPng w h png =
174 flipYAxis
175 $ ImageTree
176 $ defaultSvg
177 & Svg.imageCornerUpperLeft
178 .~ (Svg.Num (-w / 2), Svg.Num (-h / 2))
179 & Svg.imageWidth
180 .~ Svg.Num w
181 & Svg.imageHeight
182 .~ Svg.Num h
183 & Svg.imageHref
184 .~ ("data:image/png;base64," ++ imgData)
185 where imgData = LBS.unpack $ Base64.encode png
186
187
188 {-# INLINE embedDynamicImage #-}
189 -- | Embed an in-memory image. Note, the pixel size of the image
190 -- is used as the dimensions. As such, embedding a 100x100 image will
191 -- result in an image 100 units wide and 100 units high. Consider
192 -- using with 'scaleToSize'.
193 embedDynamicImage :: DynamicImage -> SVG
194 embedDynamicImage img = embedPng width height imgData
195 where
196 width = fromIntegral $ dynamicMap imageWidth img
197 height = fromIntegral $ dynamicMap imageHeight img
198 imgData = case encodeDynamicPng img of
199 Left err -> error err
200 Right dat -> dat
201
202 -- embedImageFile :: FilePath -> Tree
203 -- embedImageFile path = unsafePerformIO $ do
204 -- png <- B.readFile path
205 -- case decodePng png of
206 -- Left{} -> error "bad image"
207 -- Right img -> return $
208 -- let width = fromIntegral $ dynamicMap imageWidth img
209 -- height = fromIntegral $ dynamicMap imageHeight img in
210 -- ImageTree $ defaultSvg
211 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2))
212 -- & Svg.imageWidth .~ Svg.Num width
213 -- & Svg.imageHeight .~ Svg.Num height
214 -- & Svg.imageHref .~ ("file://" ++ path)
215
216
217 -- | Convert an SVG object to a pixel-based image. The default resolution
218 -- is 2560x1440. See also 'rasterSized'. Multiple raster engines are supported
219 -- and are selected using the '--raster' flag in the driver.
220 raster :: SVG -> DynamicImage
221 raster = rasterSized 2560 1440
222
223 -- | Convert an SVG object to a pixel-based image.
224 rasterSized
225 :: Width -- ^ X resolution in pixels
226 -> Height -- ^ Y resolution in pixels
227 -> SVG -- ^ SVG object
228 -> DynamicImage
229 rasterSized w h svg = unsafePerformIO $ do
230 png <- B.readFile (svgAsPngFile' w h svg)
231 case decodePng png of
232 Left{} -> error "bad image"
233 Right img -> return img
234
235 -- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons.
236 vectorize :: FilePath -> SVG
237 vectorize = vectorize_ []
238
239 -- | Same as 'vectorize' but takes a list of arguments for 'potrace'.
240 vectorize_ :: [String] -> FilePath -> SVG
241 vectorize_ _ path | pNoExternals = mkText $ T.pack path
242 vectorize_ args path = unsafePerformIO $ do
243 root <- getXdgDirectory XdgCache "reanimate"
244 createDirectoryIfMissing True root
245 let svgPath = root </> encodeInt key <.> "svg"
246 hit <- doesFileExist svgPath
247 unless hit $ withSystemTempFile "file.svg" $ \tmpSvgPath svgH ->
248 withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do
249 hClose svgH
250 hClose bmpH
251 potrace <- requireExecutable "potrace"
252 magick <- requireExecutable magickCmd
253 runCmd magick [path, "-flatten", tmpBmpPath]
254 runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath])
255 renameOrCopyFile tmpSvgPath svgPath
256 svg_data <- B.readFile svgPath
257 case parseSvgFile svgPath svg_data of
258 Nothing -> do
259 removeFile svgPath
260 error "Malformed svg"
261 Just svg -> return $ unbox $ replaceUses svg
262 where key = hash (path, args)
263
264 -- imageAsFile :: DynamicImage -> FilePath
265 -- imageAsFile img
266
267 -- | Convert an SVG object to a pixel-based image and save it to disk, returning
268 -- the filepath. The default resolution is 2560x1440. See also 'svgAsPngFile''.
269 -- Multiple raster engines are supported and are selected using the '--raster'
270 -- flag in the driver.
271 svgAsPngFile :: SVG -> FilePath
272 svgAsPngFile = svgAsPngFile' width height
273 where
274 width = 2560
275 height = width * 9 `div` 16
276
277 -- | Convert an SVG object to a pixel-based image and save it to disk, returning
278 -- the filepath.
279 svgAsPngFile'
280 :: Width -- ^ Width
281 -> Height -- ^ Height
282 -> SVG -- ^ SVG object
283 -> FilePath
284 svgAsPngFile' _ _ _ | pNoExternals = "/svgAsPngFile/has/been/disabled"
285 svgAsPngFile' width height svg =
286 unsafePerformIO $ cacheFile template $ \pngPath -> do
287 let svgPath = replaceExtension pngPath "svg"
288 writeFile svgPath rendered
289 engine <- requireRaster pRaster
290 applyRaster engine svgPath
291 where
292 template = encodeInt (hash rendered) <.> "png"
293 rendered = renderSvg (Just $ Px $ fromIntegral width)
294 (Just $ Px $ fromIntegral height)
295 svg