packages feed

svgone (empty) → 0.1.0.0

raw patch · 7 files changed

+385/−0 lines, 7 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, directory, extra, filepath, generic-lens, lens, linear, mtl, pretty-simple, process, reanimate-svg, safe, svgone, text

Files

+ app/Main.hs view
@@ -0,0 +1,13 @@+module Main (main) where++import qualified Data.Text.IO as T+import Svgone+import System.Environment++main :: IO ()+main =+    getArgs >>= \case+        [inF, outF] -> do+            in' <- T.readFile inF+            run allPluginsWithDefaults inF in' outF+        _ -> error "bad args"
+ src/Svgone.hs view
@@ -0,0 +1,34 @@+module Svgone where++import Data.Text (Text)+import Graphics.SvgTree (Document, parseSvgFile, saveXmlFile)+import Svgone.Plugin+import qualified Svgone.Plugin.CollapseGroups as CollapseGroups+import qualified Svgone.Plugin.MergePaths as MergePaths++data SomePlugin where+    SomePlugin :: Plugin a => PluginOptions a -> SomePlugin++run ::+    -- | Operations to perform, left to right.+    [SomePlugin] ->+    -- | Source path/URL of the document, used to resolve relative links.+    FilePath ->+    -- | Contents+    Text ->+    -- | Output file+    FilePath ->+    IO ()+run ps in' t out = do+    Just d <- pure $ parseSvgFile in' t+    let d' = runDoc ps d+    saveXmlFile out d'++runDoc :: [SomePlugin] -> Document -> Document+runDoc = flip foldr id \(SomePlugin opts) -> (. plugin opts)++allPluginsWithDefaults :: [SomePlugin]+allPluginsWithDefaults =+    [ SomePlugin $ defaultOpts @CollapseGroups.P+    , SomePlugin $ defaultOpts @MergePaths.P+    ]
+ src/Svgone/Plugin.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Svgone.Plugin where++import Data.Text (Text)+import Graphics.SvgTree (Document)++class Plugin a where+    data PluginOptions a+    defaultOpts :: PluginOptions a+    plugin :: PluginOptions a -> Document -> Document+    pluginName :: Text
+ src/Svgone/Plugin/CollapseGroups.hs view
@@ -0,0 +1,29 @@+module Svgone.Plugin.CollapseGroups (P, PluginOptions (..)) where++import Control.Lens+import Control.Monad+import Data.Maybe+import Graphics.SvgTree+import Svgone.Plugin++data P+type Opts = PluginOptions P++instance Plugin P where+    data PluginOptions P = Opts+    defaultOpts = Opts+    plugin :: Opts -> Document -> Document+    plugin Opts = documentElements %~ trees+    pluginName = "collapse-groups"++trees :: [Tree] -> [Tree]+trees = map $ branch . (^. treeBranch)++branch :: TreeBranch -> Tree+branch t = case t of+    GroupNode g -> fromMaybe (Tree $ GroupNode $ g & groupChildren %~ trees) do+        [Tree (PathNode p)] <- pure $ g ^. groupChildren+        guard $ isNothing $ g ^. groupViewBox+        guard $ g ^. groupAspectRatio == defaultSvg+        pure $ Tree $ PathNode p & drawAttributes %~ ((g ^. groupDrawAttributes) <>)+    x -> Tree x
+ src/Svgone/Plugin/MergePaths.hs view
@@ -0,0 +1,116 @@+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Svgone.Plugin.MergePaths (P, PluginOptions (..)) where++import Control.Lens+import Control.Monad+import Data.Either+import Data.Either.Extra+import Data.Generics.Labels ()+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Tuple+import GHC.Generics+import Graphics.SvgTree hiding (Text)+import Linear+import Svgone.Plugin+import Util++data P+type Opts = PluginOptions P++instance Plugin P where+    data PluginOptions P = Opts+        { -- | For floating-point equality.+          optsTolerance :: Double+        }+    defaultOpts = Opts 1+    plugin :: Opts -> Document -> Document+    plugin opts = documentElements %~ map Tree . branches opts . map (^. treeBranch)+    pluginName = "merge-paths"++branches :: Opts -> [TreeBranch] -> [TreeBranch]+branches opts bs = polygons' ++ nonPolygons+  where+    (nonPolygons, polygons) = partitionEithers $ map (\b -> maybeToEither b $ toPolygonPath =<< pathBranch b) bs+    polygons' = do+        (attrs, paths) <- snd <<<$>>> classifyOn fst polygons+        merged <- mergePaths opts $ NE.toList paths+        pure $ PathNode $ fromPolygonPath merged attrs++mergePaths :: Opts -> [PolygonPath] -> [PolygonPath]+mergePaths opts = \case+    [] -> []+    p : ps -> case mapMaybe (traverse (mergePaths2 opts p) . swap) $ select ps of+        -- p can't be merged with any shape in ps+        [] -> p : mergePaths opts ps+        -- p' is p merged with whichever path is missing from ps' - run again+        (ps', p') : _ -> mergePaths opts $ p' : ps'++mergePaths2 :: Opts -> PolygonPath -> PolygonPath -> Maybe PolygonPath+mergePaths2 Opts{..} us vs =+    listToMaybe . catMaybes $+        mergeOne+            <$> #unPolygonPath equivalentCycles us+            <*> #unPolygonPath equivalentCycles vs+  where+    a ~= b = distance a b < optsTolerance+    mergeOne (PolygonPath (u0 :| us0)) (PolygonPath (v0 :| vs0)) = do+        guard $ u0 ~= v0+        u1 : _us1 <- pure us0+        v1 : vs1 <- pure vs0++        -- we don't care about intersections at the points we're merging+        let here :: V2 Double -> Bool+            here w = w ~= u0 || w ~= u1++        let a = distance u0 u1+            b = distance u0 v1+            c = distance u1 v1+            d = ((a ^ 2) + (b ^ 2) - (c ^ 2)) / (2 * a)+            r = sqrt $ (b ^ 2) - (d ^ 2) -- distance from v1 to the closest point on (u0,u1)++        -- avoid exceptions in calculating r+        guard $ a /= 0 -- would mean 'us' contains adjacent duplicates+        -- d is one side of a triangle of which b is the hypotenuse:+        -- this can only fail if v1 is right on the line and we get rounding errors+        guard $ d <= b++        -- v1 is on the line+        guard $ r < optsTolerance++        -- the shapes have no other intersections+        guard $ all here $ catMaybes $ intersectLines <$> pairAdjacent (us0 ++ [u0]) <*> pairAdjacent (vs0 ++ [v0])++        pure $ PolygonPath $ u0 :| reverse us0 ++ [v1 | not $ u1 ~= v1] ++ vs1++newtype PolygonPath = PolygonPath {unPolygonPath :: NonEmpty (V2 Double)}+    deriving (Eq, Show, Generic)++toPolygonPath :: Path -> Maybe (DrawAttributes, PolygonPath)+toPolygonPath (Path attrs pcs) = case pcs of+    MoveTo OriginAbsolute [v] : xs -> (attrs,) . PolygonPath . (v :|) <$> f v xs+    _ -> Nothing+  where+    f :: V2 Double -> [PathCommand] -> Maybe [V2 Double]+    f v0@(V2 x0 y0) = \case+        c : cs -> case c of+            LineTo OriginRelative [v] -> g $ v0 + v+            LineTo OriginAbsolute [v] -> g v+            HorizontalTo OriginAbsolute [x] -> g $ V2 x y0+            HorizontalTo OriginRelative [x] -> g $ V2 (x0 + x) y0+            VerticalTo OriginAbsolute [y] -> g $ V2 x0 y+            VerticalTo OriginRelative [y] -> g $ V2 x0 (y0 + y)+            EndPath -> Just []+            _ -> Nothing+          where+            g v = (v :) <$> f v cs+        [] -> Nothing -- should end with 'EndPath'++fromPolygonPath :: PolygonPath -> DrawAttributes -> Path+fromPolygonPath (PolygonPath (v0 :| p)) =+    flip Path $+        [MoveTo OriginAbsolute [v0]]+            ++ map (LineTo OriginAbsolute . pure) p+            ++ [EndPath]
+ src/Util.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Util where++import Control.Monad+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import Data.Tuple.Extra+import Graphics.SvgTree+import Linear++--TODO upstream to svg-tree, extra, linear etc.++infixl 5 <<$>>+(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+(<<$>>) = fmap . fmap++infixl 5 <<<$>>>+(<<<$>>>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))+(<<<$>>>) = fmap . fmap . fmap++(++|) :: NonEmpty a -> [a] -> NonEmpty a+(++|) (x :| xs) ys = x :| xs ++ ys++pairAdjacent :: [a] -> [(a, a)]+pairAdjacent xs = zip xs $ tail xs++classifyOn :: Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]+classifyOn f = Map.toList . Map.fromListWith (<>) . map (f &&& pure)++select :: [a] -> [(a, [a])]+select [] = []+select (x : xs) = (x, xs) : ((x :) <<$>> select xs)++{- | Rotate and reflect. Same coordinates in same order.++>>> equivalentCycles $ 1 :| [2,3,4]+[ 1 :| [2, 3, 4, 5]+, 5 :| [4, 3, 2, 1]+, 2 :| [3, 4, 5, 1]+, 1 :| [5, 4, 3, 2]+, 3 :| [4, 5, 1, 2]+, 2 :| [1, 5, 4, 3]+, 4 :| [5, 1, 2, 3]+, 3 :| [2, 1, 5, 4]+, 5 :| [1, 2, 3, 4]+, 4 :| [3, 2, 1, 5]+]+-}+equivalentCycles :: NonEmpty a -> [NonEmpty a]+equivalentCycles = concatMap refls . rots+ where+  refls xs = [xs, NE.reverse xs]+  rots = go []+  go ys = \case+    x :| xs -> (x :| xs ++ ys) : maybe [] (go $ ys ++ [x]) (NE.nonEmpty xs)++-- | Based on wikipedia: https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection#Given_two_points_on_each_line+intersectLines :: (Eq a, Ord a, Fractional a, Show a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)+intersectLines (V2 x1 y1, V2 x2 y2) (V2 x3 y3, V2 x4 y4) = do+  guard $ den /= 0 -- lines are not parallel or coincident+  guard $ t >= 0 && t <= 1 -- intersection is on first line segment+  guard $ u >= 0 && u <= 1 -- intersection is on second line segment+  pure $ V2 x y+ where+  dx12 = x1 - x2+  dx13 = x1 - x3+  dx34 = x3 - x4++  dy12 = y1 - y2+  dy13 = y1 - y3+  dy34 = y3 - y4++  den = dx12 * dy34 - dy12 * dx34++  u = (dy12 * dx13 - dx12 * dy13) / den+  t = (dx13 * dy34 - dy13 * dx34) / den++  x = x1 - t * dx12+  y = y1 - t * dy12++pathBranch :: TreeBranch -> Maybe Path+pathBranch = \case+  PathNode p -> Just p+  _ -> Nothing++deriving instance Ord Cap+deriving instance Ord DrawAttributes+deriving instance Ord ElementRef+deriving instance Ord FillRule+deriving instance Ord FontStyle+deriving instance Ord LineJoin+deriving instance Ord Number+deriving instance Ord TextAnchor+deriving instance Ord Texture+deriving instance Ord Transformation
+ svgone.cabal view
@@ -0,0 +1,84 @@+cabal-version:       3.0+name:                svgone+version:             0.1.0.0+license:             BSD-3-Clause+maintainer:          George Thomas <georgefsthomas@gmail.com>+homepage:            https://github.com/georgefst/svgone+synopsis:            Optimise SVGs+category:            graphics, svg++source-repository head+    type:     git+    location: git://github.com/georgefst/svgone.git++common common+    build-depends:+        base ^>= 4.14.1,+        bytestring ^>= 0.10.12,+        containers ^>= 0.6.2,+        directory ^>= 1.3.6,+        extra ^>= 1.7.9,+        filepath ^>= 1.4.2,+        generic-lens ^>= 2.0,+        lens ^>= 4.19.2,+        linear ^>= 1.21.3,+        mtl ^>= 2.2.2,+        pretty-simple ^>= 4.0.0,+        process ^>= 1.6.9,+        reanimate-svg ^>= 0.13.0,+        safe ^>= 0.3.19,+        text ^>= 1.2.4,+    ghc-options:+        -Wall+        -fdefer-typed-holes+    default-language: Haskell2010+    default-extensions:+        BlockArguments+        ConstraintKinds+        DeriveFoldable+        DeriveFunctor+        DeriveGeneric+        DeriveTraversable+        DerivingStrategies+        FlexibleContexts+        FlexibleInstances+        FunctionalDependencies+        GADTs+        GeneralisedNewtypeDeriving+        InstanceSigs+        LambdaCase+        MultiParamTypeClasses+        OverloadedLabels+        OverloadedStrings+        PartialTypeSignatures+        PatternSynonyms+        RankNTypes+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        TypeFamilies+        TypeFamilyDependencies+        TypeOperators+        ViewPatterns++executable svgone+    import: common+    hs-source-dirs: app+    main-is: Main.hs+    build-depends:+        svgone+    ghc-options:+        -threaded++library+    import: common+    hs-source-dirs: src+    exposed-modules:+        Svgone+        Svgone.Plugin+        Svgone.Plugin.MergePaths+        Svgone.Plugin.CollapseGroups+    other-modules:+        Util