From 816c1d8d7e2d0f847fee0ee5b16ba5fafcfd9b91 Mon Sep 17 00:00:00 2001 From: David Date: Sat, 16 Feb 2019 16:18:35 +0100 Subject: [PATCH] Process svgs to remove needless view boxes. --- reanimate.cabal | 6 +++-- src/Reanimate/LaTeX.hs | 21 +++++++++++++--- src/Reanimate/Svg.hs | 57 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 78 insertions(+), 6 deletions(-) create mode 100644 src/Reanimate/Svg.hs diff --git a/reanimate.cabal b/reanimate.cabal index 40daa6a..6c52683 100644 --- a/reanimate.cabal +++ b/reanimate.cabal @@ -21,10 +21,11 @@ library Reanimate.Examples Reanimate.Combinators Reanimate.LaTeX + Reanimate.Svg other-modules: Reanimate.Misc build-depends: base >=4.12 && <4.13, lucid-svg, time, text, unix, lucid, filepath, process, directory, - containers, svg-tree, xml, bytestring + containers, svg-tree, xml, bytestring, lens executable reanimate-viewer main-is: SvgViewer.hs @@ -34,10 +35,11 @@ executable reanimate-viewer Reanimate.Examples Reanimate.Combinators Reanimate.LaTeX + Reanimate.Svg Reanimate.Misc build-depends: base >=4.12 && <4.13, cairo >=0.13 && <0.14, gtk, svgcairo, lucid-svg, time, text, unix, lucid, reanimate, filepath, process, directory, containers, svg-tree, xml, - bytestring + bytestring, lens hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Reanimate/LaTeX.hs b/src/Reanimate/LaTeX.hs index e458ff4..7cf3879 100644 --- a/src/Reanimate/LaTeX.hs +++ b/src/Reanimate/LaTeX.hs @@ -10,12 +10,25 @@ import qualified Data.Map as Map import Lucid (ToHtml (..)) import Lucid.Svg (Svg, fill_, font_size_, text_) import Reanimate.Misc +import Reanimate.Svg import System.FilePath (replaceExtension, takeFileName, ()) import System.IO.Unsafe (unsafePerformIO) import Graphics.Svg (loadSvgFile, parseSvgFile, - xmlOfDocument) -import Text.XML.Light.Output (ppcElement, prettyConfigPP) + xmlOfDocument, Tree, elements, defaultSvg, Document) +import Text.XML.Light.Output (ppcElement, ppcContent, prettyConfigPP) +import Text.XML.Light (elContent) +import Control.Lens (over, (^.),set, (.~), (&), (%~) ) + +-- instance ToHtml Document where +-- toHtml = toHtmlRaw +-- toHtmlRaw = toHtmlRaw . ppcElement prettyConfigPP . xmlOfDocument + +instance ToHtml Document where + toHtml = toHtmlRaw + toHtmlRaw doc = toHtmlRaw $ unlines $ map (ppcContent prettyConfigPP) (elContent elt) + where + elt = xmlOfDocument doc {-# NOINLINE cache #-} cache :: IORef (Map String (Svg ())) @@ -43,13 +56,13 @@ latexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do runCmd latex ["-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file] runCmd dvisvgm [ dvi_file , "--exact" -- better bboxes. - , "--bbox=1,1" -- increase bbox size. + -- , "--bbox=1,1" -- increase bbox size. , "--no-fonts" -- use glyphs instead of fonts. ,"--verbosity=0", "-o",svg_file] svg_data <- B.readFile svg_file case parseSvgFile svg_file svg_data of Nothing -> error "Malformed svg" - Just svg -> return $ toHtmlRaw $ ppcElement prettyConfigPP (xmlOfDocument svg) + Just svg -> return $ toHtmlRaw $ unbox $ replaceUses svg failedSvg :: String -> Svg () failedSvg tex = diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs new file mode 100644 index 0000000..ba100ed --- /dev/null +++ b/src/Reanimate/Svg.hs @@ -0,0 +1,57 @@ +module Reanimate.Svg where + +import Data.Maybe +import qualified Data.Map as Map +import Control.Lens (over, (^.),set, (.~), (&), (%~) ) +import Graphics.Svg + +replaceUses :: Document -> Document +replaceUses doc = doc & elements %~ map (mapTree replace) + & definitions .~ Map.empty + where + replace (UseTree _ Just{}) = error "replaceUses: subtree in use?" + replace (UseTree use Nothing) = + case Map.lookup (use^.useName) idMap of + Nothing -> error $ "Unknown id: " ++ (use^.useName) + Just tree -> + GroupTree $ + defaultSvg & groupChildren .~ [tree] + & drawAttr .~ (defaultSvg & transform .~ Just [baseToTransformation (use^.useBase)]) + replace x = x + baseToTransformation (x,y) = + case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of + (Num a, Num b) -> Translate a b + _ -> TransformUnknown + defaultDPI = 96 + docTree = GroupTree $ set groupChildren (doc^.elements) defaultSvg + idMap = foldTree updMap Map.empty docTree `Map.union` + Map.mapMaybe elementToTree (doc^.definitions) + updMap m tree = + case tree^.drawAttr.attrId of + Nothing -> m + Just tid -> Map.insert tid tree m + elementToTree (ElementGeometry t) = Just t + elementToTree _ = Nothing + +docIds :: Document -> [String] +docIds doc = Map.keys idMap ++ Map.keys (doc^.definitions) + where + docTree = GroupTree $ set groupChildren (doc^.elements) defaultSvg + idMap = foldTree updMap Map.empty docTree + updMap m tree = + case tree^.drawAttr.attrId of + Nothing -> m + Just tid -> Map.insert tid tree m + + +-- Transform out viewbox. defs and CSS rules are discarded. +unbox :: Document -> Document +unbox doc@Document{_viewBox = Just (minx, minw, _width, _height)} = + doc & viewBox .~ Nothing + & width .~ Nothing + & height .~ Nothing + & elements .~ + [ GroupTree $ defaultSvg + & groupChildren .~ doc^.elements + & drawAttr .~ (defaultSvg & transform .~ Just [Translate (-minx) (-minw)]) ] +unbox doc = doc