Process svgs to remove needless view boxes.

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

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)
+                                        xmlOfDocument, Tree, elements, defaultSvg, Document)
-import           Text.XML.Light.Output (ppcElement, prettyConfigPP)
+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 =

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