diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,10 @@ -*-change-log-*- +v0.9.0.0 April 2019 + + * Performance optimizations. + * Memo module and render cache. + v0.8.2.0 March 2019 * Export parser and serializer. diff --git a/reanimate-svg.cabal b/reanimate-svg.cabal --- a/reanimate-svg.cabal +++ b/reanimate-svg.cabal @@ -1,5 +1,5 @@ name: reanimate-svg -version: 0.8.2.0 +version: 0.9.0.0 synopsis: SVG file loader and serializer description: reanimate-svg provides types representing a SVG document, @@ -34,6 +34,8 @@ , Graphics.SvgTree.Types , Graphics.SvgTree.PathParser , Graphics.SvgTree.NamedColors + , Graphics.SvgTree.Memo + , Graphics.SvgTree.Printer other-modules: Graphics.SvgTree.XmlParser , Graphics.SvgTree.CssParser diff --git a/src/Graphics/SvgTree/Memo.hs b/src/Graphics/SvgTree/Memo.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Memo.hs @@ -0,0 +1,83 @@ +module Graphics.SvgTree.Memo + ( memo + , preRender + ) where + +import Control.Lens +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Typeable +import Graphics.SvgTree.Printer +import Graphics.SvgTree.Types (Tree, preRendered) +import System.IO.Unsafe + +{-# NOINLINE intCache #-} +intCache :: IORef (Map Int Tree) +intCache = unsafePerformIO (newIORef Map.empty) + +{-# NOINLINE doubleCache #-} +doubleCache :: IORef (Map Double Tree) +doubleCache = unsafePerformIO (newIORef Map.empty) + +{-# NOINLINE anyCache #-} +anyCache :: IORef (Map (TypeRep,String) Tree) +anyCache = unsafePerformIO (newIORef Map.empty) + +memo :: (Typeable a, Show a) => (a -> Tree) -> (a -> Tree) +memo fn = + case listToMaybe (catMaybes caches) of + Just ret -> ret + Nothing -> memoAny fn + where + caches = [try intCache, try doubleCache] + try cache = cast . memoUsing cache =<< cast fn + +memoUsing :: Ord a => IORef (Map a Tree) -> (a -> Tree) -> (a -> Tree) +memoUsing cache fn a = unsafePerformIO $ + atomicModifyIORef cache $ \m -> + let newVal = preRender $ fn a + notFound = + (Map.insert a newVal m, newVal) in + case Map.lookup a m of + Nothing -> notFound + Just t -> (m, t) + +memoAny :: (Typeable a, Show a) => (a -> Tree) -> (a -> Tree) +memoAny fn a = unsafePerformIO $ + atomicModifyIORef anyCache $ \m -> + let newVal = preRender $ fn a + notFound = + (Map.insert (typeOf a, show a) newVal m, newVal) in + case Map.lookup (typeOf a, show a) m of + Nothing -> notFound + Just t -> (m, t) + +preRender :: Tree -> Tree +preRender t = t & preRendered .~ Just (ppTree t) + +-- {-# INLINE memo #-} +-- memo :: (a -> b) -> (a -> b) +-- memo fn = unsafePerformIO $ do +-- ref <- newIORef Map.empty +-- return $ \a -> unsafePerformIO $ do +-- stableA <- makeStableName a +-- let key = hashStableName stableA +-- atomicModifyIORef ref $ \m -> +-- case Map.lookup key m of +-- -- Just (s,b) | s == stableA -> +-- -- (m, b) +-- _Nothing -> let !b = fn a in +-- (Map.insert key (stableA, b) m, b) +-- memo fn = unsafePerformIO $ do +-- ht <- HT.new :: IO (HT.BasicHashTable (StableName Any) Any) +-- return $ \a -> unsafePerformIO $ do +-- stableA <- makeStableName $ unsafeCoerce a +-- mbB <- HT.lookup ht stableA +-- case mbB of +-- Just b -> return (unsafeCoerce b) +-- Nothing -> do +-- let !b = fn a +-- HT.insert ht stableA (unsafeCoerce b) +-- return b diff --git a/src/Graphics/SvgTree/PathParser.hs b/src/Graphics/SvgTree/PathParser.hs --- a/src/Graphics/SvgTree/PathParser.hs +++ b/src/Graphics/SvgTree/PathParser.hs @@ -25,6 +25,9 @@ string) import Data.Scientific (toRealFloat) +import Numeric +import Text.Show +import Data.List import qualified Data.Text as T import Graphics.SvgTree.Types import Linear hiding (angle, point) @@ -101,58 +104,68 @@ <*> (fmap (/= 0) numComma) <*> point -serializePoint :: RPoint -> String -serializePoint (V2 x y) = printf "%g,%g" x y +unwordsS :: [ShowS] -> ShowS +unwordsS = foldr (.) id . intersperse (showChar ' ') -serializePoints :: [RPoint] -> String -serializePoints = unwords . fmap serializePoint +serializePoint :: RPoint -> ShowS +serializePoint (V2 x y) = showFFloat Nothing x . showChar ',' . showFFloat Nothing y -serializeCoords :: [Coord] -> String -serializeCoords = unwords . fmap (printf "%g") +serializePoints :: [RPoint] -> ShowS +serializePoints = unwordsS . map serializePoint -serializePointPair :: (RPoint, RPoint) -> String -serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b +serializeCoords :: [Coord] -> ShowS +serializeCoords = unwordsS . fmap (showFFloat Nothing) -serializePointPairs :: [(RPoint, RPoint)] -> String -serializePointPairs = unwords . fmap serializePointPair +serializePointPair :: (RPoint, RPoint) -> ShowS +serializePointPair (a, b) = serializePoint a . showChar ' ' . serializePoint b -serializePointTriplet :: (RPoint, RPoint, RPoint) -> String +serializePointPairs :: [(RPoint, RPoint)] -> ShowS +serializePointPairs = unwordsS . fmap serializePointPair + +serializePointTriplet :: (RPoint, RPoint, RPoint) -> ShowS serializePointTriplet (a, b, c) = - serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c + serializePoint a . showChar ' ' . serializePoint b . showChar ' ' . serializePoint c -serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String -serializePointTriplets = unwords . fmap serializePointTriplet +serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> ShowS +serializePointTriplets = unwordsS . fmap serializePointTriplet -serializeCommands :: [PathCommand] -> String -serializeCommands = unwords . fmap serializeCommand +serializeCommands :: [PathCommand] -> ShowS +serializeCommands = unwordsS . fmap serializeCommand -serializeCommand :: PathCommand -> String +serializeCommand :: PathCommand -> ShowS serializeCommand p = case p of - MoveTo OriginAbsolute points -> "M" ++ serializePoints points - MoveTo OriginRelative points -> "m" ++ serializePoints points - LineTo OriginAbsolute points -> "L" ++ serializePoints points - LineTo OriginRelative points -> "l" ++ serializePoints points + MoveTo OriginAbsolute points -> showChar 'M' . serializePoints points + MoveTo OriginRelative points -> showChar 'm' . serializePoints points + LineTo OriginAbsolute points -> showChar 'L' . serializePoints points + LineTo OriginRelative points -> showChar 'l' . serializePoints points - HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords - HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords - VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords - VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords + HorizontalTo OriginRelative coords -> showChar 'h' . serializeCoords coords + HorizontalTo OriginAbsolute coords -> showChar 'H' . serializeCoords coords + VerticalTo OriginAbsolute coords -> showChar 'V' . serializeCoords coords + VerticalTo OriginRelative coords -> showChar 'v' . serializeCoords coords - CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets - CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets - SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs - SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs - QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs - QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs - SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points - SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points - EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args - EllipticalArc OriginRelative args -> "a" ++ serializeArgs args - EndPath -> "Z" + CurveTo OriginAbsolute triplets -> showChar 'C' . serializePointTriplets triplets + CurveTo OriginRelative triplets -> showChar 'c' . serializePointTriplets triplets + SmoothCurveTo OriginAbsolute pointPairs -> showChar 'S' . serializePointPairs pointPairs + SmoothCurveTo OriginRelative pointPairs -> showChar 's' . serializePointPairs pointPairs + QuadraticBezier OriginAbsolute pointPairs -> showChar 'Q' . serializePointPairs pointPairs + QuadraticBezier OriginRelative pointPairs -> showChar 'q' . serializePointPairs pointPairs + SmoothQuadraticBezierCurveTo OriginAbsolute points -> showChar 'T' . serializePoints points + SmoothQuadraticBezierCurveTo OriginRelative points -> showChar 't' . serializePoints points + EllipticalArc OriginAbsolute args -> showChar 'A' . serializeArgs args + EllipticalArc OriginRelative args -> showChar 'a' . serializeArgs args + EndPath -> showChar 'Z' where serializeArg (a, b, c, d, e, V2 x y) = - printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y - serializeArgs = unwords . fmap serializeArg + showFFloat Nothing a . showChar ' ' . + showFFloat Nothing b . showChar ' ' . + showFFloat Nothing c . showChar ' ' . + shows (fromEnum d) . showChar ' ' . + shows (fromEnum e) . showChar ' ' . + showFFloat Nothing x . showChar ',' . + showFFloat Nothing y + -- printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y + serializeArgs = unwordsS . fmap serializeArg @@ -242,15 +255,15 @@ <*> (point <* commaWsp) <*> mayPoint -serializeGradientCommand :: GradientPathCommand -> String +serializeGradientCommand :: GradientPathCommand -> ShowS serializeGradientCommand p = case p of - GLine OriginAbsolute points -> "L" ++ smp points - GLine OriginRelative points -> "l" ++ smp points - GClose -> "Z" + GLine OriginAbsolute points -> showChar 'L' . smp points + GLine OriginRelative points -> showChar 'l' . smp points + GClose -> showChar 'Z' - GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c - GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c + GCurve OriginAbsolute a b c -> showChar 'C' . sp a . sp b . smp c + GCurve OriginRelative a b c -> showChar 'c' . sp a . sp b . smp c where sp = serializePoint - smp Nothing = "" + smp Nothing = id smp (Just pp) = serializePoint pp diff --git a/src/Graphics/SvgTree/Printer.hs b/src/Graphics/SvgTree/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Printer.hs @@ -0,0 +1,50 @@ +module Graphics.SvgTree.Printer + ( ppTree + , ppDocument + ) where + +import Control.Lens +import Data.Char +import Data.List +import Graphics.SvgTree.Types (DrawAttributes, Tree (..), + groupChildren, + preRendered, Document(..)) +import Graphics.SvgTree.XmlParser +import Text.XML.Light + +ppDocument :: Document -> String +ppDocument doc = + ppElementS_ (_elements doc) (xmlOfDocument doc) "" + +ppTree :: Tree -> String +ppTree t = ppTreeS t "" + +ppTreeS :: Tree -> ShowS +ppTreeS tree = + case tree ^. preRendered of + Nothing -> + case xmlOfTree tree of + Just x -> ppElementS_ (treeChildren tree) x + Nothing -> id + Just s -> showString s + +treeChildren :: Tree -> [Tree] +treeChildren (GroupTree g) = g^.groupChildren +treeChildren (SymbolTree g) = g^.groupChildren +treeChildren (DefinitionTree g) = g^.groupChildren +treeChildren _ = [] + +ppElementS_ :: [Tree] -> Element -> ShowS +ppElementS_ children e xs = tagStart name (elAttribs e) $ + case children of + [] | "?" `isPrefixOf` qName name -> showString " ?>" xs + | True -> showString " />" xs + _ -> showChar '>' (foldr ppTreeS (tagEnd name xs) children) + where name = elName e + +-------------------------------------------------------------------------------- +tagStart :: QName -> [Attr] -> ShowS +tagStart qn as rs = '<':showQName qn ++ as_str ++ rs + where as_str = if null as then "" else ' ' : unwords (map showAttr as) + showAttr :: Attr -> String + showAttr (Attr qn v) = showQName qn ++ '=' : '"' : v ++ "\"" diff --git a/src/Graphics/SvgTree/Types.hs b/src/Graphics/SvgTree/Types.hs --- a/src/Graphics/SvgTree/Types.hs +++ b/src/Graphics/SvgTree/Types.hs @@ -564,6 +564,7 @@ -- Correspond to the `marker-end` attribute. , _markerEnd :: !(Last ElementRef) , _filterRef :: !(Last ElementRef) + , _preRendered :: !(Maybe String) } deriving (Eq, Show) @@ -889,6 +890,9 @@ Symbol { _groupOfSymbol :: Group a } deriving (Eq, Show) +instance HasGroup (Symbol a) a where + group = groupOfSymbol + -- makeLenses ''Symbol -- | Lenses associated with the Symbol type. groupOfSymbol :: Lens (Symbol s) (Symbol t) (Group s) (Group t) @@ -907,6 +911,9 @@ Definitions { _groupOfDefinitions :: Group a } deriving (Eq, Show) +instance HasGroup (Definitions a) a where + group = groupOfDefinitions + -- makeLenses ''Definitions -- | Lenses associated with the Definitions type. groupOfDefinitions :: Lens (Definitions s) (Definitions t) (Group s) (Group t) @@ -2031,12 +2038,12 @@ ClipPathTree e -> e ^. drawAttributes setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree -setDrawAttrOfTree v attr = case v of +setDrawAttrOfTree v attr' = case v of None -> None UseTree e m -> UseTree (e & drawAttributes .~ attr) m GroupTree e -> GroupTree $ e & drawAttributes .~ attr SymbolTree e -> SymbolTree $ e & drawAttributes .~ attr - DefinitionTree e -> DefinitionTree e & drawAttributes .~ attr + DefinitionTree e -> DefinitionTree $ e & drawAttributes .~ attr FilterTree e -> FilterTree $ e & drawAttributes .~ attr PathTree e -> PathTree $ e & drawAttributes .~ attr CircleTree e -> CircleTree $ e & drawAttributes .~ attr @@ -2054,7 +2061,8 @@ MarkerTree e -> MarkerTree $ e & drawAttributes .~ attr MaskTree e -> MaskTree $ e & drawAttributes .~ attr ClipPathTree e -> ClipPathTree $ e & drawAttributes .~ attr - + where + attr = attr'{_preRendered = Nothing} instance HasDrawAttributes Tree where drawAttributes = lens drawAttrOfTree setDrawAttrOfTree @@ -2599,6 +2607,7 @@ , _markerMid = (mappend `on` _markerMid) a b , _markerEnd = (mappend `on` _markerEnd) a b , _filterRef = (mappend `on` _filterRef) a b + , _preRendered = Nothing } where opacityMappend Nothing Nothing = Nothing @@ -2636,6 +2645,7 @@ , _markerMid = Last Nothing , _markerEnd = Last Nothing , _filterRef = Last Nothing + , _preRendered = Nothing } instance WithDefaultSvg DrawAttributes where diff --git a/src/Graphics/SvgTree/XmlParser.hs b/src/Graphics/SvgTree/XmlParser.hs --- a/src/Graphics/SvgTree/XmlParser.hs +++ b/src/Graphics/SvgTree/XmlParser.hs @@ -99,15 +99,15 @@ instance ParseableAttribute [PathCommand] where aparse = parse pathParser - aserialize = Just . serializeCommands + aserialize v = Just $ serializeCommands v "" instance ParseableAttribute GradientPathCommand where aparse = parse gradientCommand - aserialize = Just . serializeGradientCommand + aserialize v = Just $ serializeGradientCommand v "" instance ParseableAttribute [RPoint] where aparse = parse pointData - aserialize = Just . serializePoints + aserialize v = Just $ serializePoints v "" instance ParseableAttribute Double where aparse = parseMayStartDot num