svgone 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+151/−41 lines, 5 filesdep ~basedep ~bytestringdep ~processPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bytestring, process

API changes (from Hackage documentation)

Files

• src/Svgone.hs +15/−0
• src/Svgone/Plugin/MergePaths.hs +29/−12
• src/Svgone/Plugin/RemoveAttributes.hs +61/−0
• src/Util.hs +39/−23
• svgone.cabal +7/−6

@@ -1,14 +1,28 @@ module Svgone where  import Data.Text (Text)+import qualified Data.Text.IO as T import Graphics.SvgTree (Document, parseSvgFile, saveXmlFile) import Svgone.Plugin import qualified Svgone.Plugin.CollapseGroups as CollapseGroups import qualified Svgone.Plugin.MergePaths as MergePaths+import qualified Svgone.Plugin.RemoveAttributes as RemoveAttributes  data SomePlugin where     SomePlugin :: Plugin a => PluginOptions a -> SomePlugin +runFile ::+    -- | Operations to perform, left to right.+    [SomePlugin] ->+    -- | Input file.+    FilePath ->+    -- | Output file+    FilePath ->+    IO ()+runFile ps in' out = do+    t <- T.readFile in'+    run ps in' t out+ run ::     -- | Operations to perform, left to right.     [SomePlugin] ->@@ -30,5 +44,6 @@ allPluginsWithDefaults :: [SomePlugin] allPluginsWithDefaults =     [ SomePlugin $ defaultOpts @CollapseGroups.P+    , SomePlugin $ defaultOpts @RemoveAttributes.P     , SomePlugin $ defaultOpts @MergePaths.P     ]

@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-type-defaults #-} -module Svgone.Plugin.MergePaths (P, PluginOptions (..)) where+module Svgone.Plugin.MergePaths (P, PluginOptions (..), PathStyle (..)) where  import Control.Lens import Control.Monad@@ -10,6 +10,7 @@ import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Maybe+import Data.Monoid import Data.Tuple import GHC.Generics import Graphics.SvgTree hiding (Text)@@ -20,12 +21,19 @@ data P type Opts = PluginOptions P +data PathStyle+    = -- | Just use absolute coordinates.+      AbsolutePath+    | -- | Use relative offsets and horizontal/vertical lines where possible.+      SmartPath+ instance Plugin P where     data PluginOptions P = Opts         { -- | For floating-point equality.           optsTolerance :: Double+        , pathStyle :: PathStyle         }-    defaultOpts = Opts 1+    defaultOpts = Opts 1 SmartPath     plugin :: Opts -> Document -> Document     plugin opts = documentElements %~ map Tree . branches opts . map (^. treeBranch)     pluginName = "merge-paths"@@ -37,7 +45,7 @@     polygons' = do         (attrs, paths) <- snd <<<$>>> classifyOn fst polygons         merged <- mergePaths opts $ NE.toList paths-        pure $ PathNode $ fromPolygonPath merged attrs+        pure $ PathNode $ fromPolygonPath opts merged attrs  mergePaths :: Opts -> [PolygonPath] -> [PolygonPath] mergePaths opts = \case@@ -89,9 +97,12 @@     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+toPolygonPath (Path attrs pcs) = do+    guard $ -- only proceed if there is no visible stroke+        maybe True nearZeroNumber (getLast $ attrs ^. strokeWidth)+            || maybe False nearZero (attrs ^. strokeOpacity)+    MoveTo OriginAbsolute [v] : xs <- pure pcs+    (attrs,) . PolygonPath . (v :|) <$> f v xs   where     f :: V2 Double -> [PathCommand] -> Maybe [V2 Double]     f v0@(V2 x0 y0) = \case@@ -108,9 +119,15 @@             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]+fromPolygonPath :: Opts -> PolygonPath -> DrawAttributes -> Path+fromPolygonPath Opts{..} (PolygonPath p@(v0 :| p')) =+    flip Path . (MoveTo OriginAbsolute [v0] :) $ (++ [EndPath]) case pathStyle of+        AbsolutePath -> map (LineTo OriginAbsolute . pure) p'+        SmartPath -> map (uncurry fromTo) . pairAdjacent $ NE.toList p+  where+    fromTo a b+        | abs (d ^. _y) < optsTolerance = HorizontalTo OriginRelative [d ^. _x]+        | abs (d ^. _x) < optsTolerance = VerticalTo OriginRelative [d ^. _y]+        | otherwise = LineTo OriginRelative [b - a]+      where+        d = b - a

@@ -0,0 +1,61 @@+module Svgone.Plugin.RemoveAttributes (P, PluginOptions (..)) where++import Control.Lens+import Data.Monoid+import Graphics.SvgTree+import Linear.Epsilon+import Svgone.Plugin+import Util++data P+type Opts = PluginOptions P++instance Plugin P where+    data PluginOptions P = Opts+        { defaultAttributes :: Bool+        , -- | Remove all stroke attributes if the stroke isn't visible.+          invisiblePathStroke :: Bool+        }+    defaultOpts = Opts True True+    plugin :: Opts -> Document -> Document+    plugin Opts{..} =+        documentElements+            %~ map+                ( Tree+                    . ( \x ->+                            maybe+                                x+                                ( PathNode+                                    . over+                                        drawAttributes+                                        ( applyWhen invisiblePathStroke removeInvisibleStroke+                                            . applyWhen defaultAttributes removeDefaultAttributes+                                        )+                                )+                                $ pathBranch x+                      )+                    . (^. treeBranch)+                )+    pluginName = "remove-attributes"++removeDefaultAttributes :: HasDrawAttributes p => p -> p+removeDefaultAttributes attrs+    | Just x <- attrs ^. fillOpacity, nearZero $ abs $ x - 1 = attrs & fillOpacity .~ Nothing+    | otherwise = attrs++removeInvisibleStroke :: DrawAttributes -> DrawAttributes+removeInvisibleStroke attrs+    | Last (Just x) <- attrs ^. strokeWidth, nearZeroNumber x = remove+    | Just x <- attrs ^. strokeOpacity, nearZero x = remove+    | otherwise = attrs+  where+    remove =+        attrs+            & strokeWidth .~ Last Nothing+            & strokeColor .~ Last Nothing+            & strokeOpacity .~ Nothing+            & strokeLineCap .~ Last Nothing+            & strokeLineJoin .~ Last Nothing+            & strokeMiterLimit .~ Last Nothing+            & strokeOffset .~ Last Nothing+            & strokeDashArray .~ Last Nothing

@@ -3,6 +3,7 @@ module Util where  import Control.Monad+import Data.Bool import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map@@ -12,6 +13,9 @@  --TODO upstream to svg-tree, extra, linear etc. +applyWhen :: Bool -> (a -> a) -> a -> a+applyWhen = flip $ bool id+ infixl 5 <<$>> (<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) (<<$>>) = fmap . fmap@@ -50,40 +54,40 @@ -} 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)+  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+    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+    dy12 = y1 - y2+    dy13 = y1 - y3+    dy34 = y3 - y4 -  den = dx12 * dy34 - dy12 * dx34+    den = dx12 * dy34 - dy12 * dx34 -  u = (dy12 * dx13 - dx12 * dy13) / den-  t = (dx13 * dy34 - dy13 * dx34) / den+    u = (dy12 * dx13 - dx12 * dy13) / den+    t = (dx13 * dy34 - dy13 * dx34) / den -  x = x1 - t * dx12-  y = y1 - t * dy12+    x = x1 - t * dx12+    y = y1 - t * dy12  pathBranch :: TreeBranch -> Maybe Path pathBranch = \case-  PathNode p -> Just p-  _ -> Nothing+    PathNode p -> Just p+    _ -> Nothing  deriving instance Ord Cap deriving instance Ord DrawAttributes@@ -95,3 +99,15 @@ deriving instance Ord TextAnchor deriving instance Ord Texture deriving instance Ord Transformation++nearZeroNumber :: Number -> Bool+nearZeroNumber = \case+    Num d -> nearZero d+    Px d -> nearZero d+    Em d -> nearZero d+    Percent d -> nearZero d+    Pc d -> nearZero d+    Mm d -> nearZero d+    Cm d -> nearZero d+    Point d -> nearZero d+    Inches d -> nearZero d

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                svgone-version:             0.1.0.0+version:             0.2.0.0 license:             BSD-3-Clause maintainer:          George Thomas <georgefsthomas@gmail.com> homepage:            https://github.com/georgefst/svgone@@ -13,8 +13,8 @@  common common     build-depends:-        base ^>= 4.14.1,-        bytestring ^>= 0.10.12,+        base ^>= { 4.13, 4.14 },+        bytestring ^>= 0.10.10,         containers ^>= 0.6.2,         directory ^>= 1.3.6,         extra ^>= 1.7.9,@@ -24,10 +24,10 @@         linear ^>= 1.21.3,         mtl ^>= 2.2.2,         pretty-simple ^>= 4.0.0,-        process ^>= 1.6.9,+        process ^>= 1.6.8,         reanimate-svg ^>= 0.13.0,         safe ^>= 0.3.19,-        text ^>= 1.2.4,+        text ^>= 1.2.3,     ghc-options:         -Wall         -fdefer-typed-holes@@ -78,7 +78,8 @@     exposed-modules:         Svgone         Svgone.Plugin-        Svgone.Plugin.MergePaths         Svgone.Plugin.CollapseGroups+        Svgone.Plugin.MergePaths+        Svgone.Plugin.RemoveAttributes     other-modules:         Util