waterfall-cad-svg 0.6.3.2 → 0.7.0.0

raw patch · 4 files changed

+212/−55 lines, 4 filesdep +deepseqdep ~opencascade-hsdep ~waterfall-cadPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: opencascade-hs, waterfall-cad

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• src/Waterfall/SVG/FromSVG.hs +9/−2
• src/Waterfall/SVG/ToSVG.hs +176/−48
• waterfall-cad-svg.cabal +7/−5

@@ -8,6 +8,26 @@  ## Unreleased +## 0.7.0.0++### Added++- Added paths for painted regions of a `Diagram`, with class `fill`+- Added `Waterfall.SVG.ToSVG.LineStyle`, `Waterfall.SVG.ToSVG.lineStyleCss` and `Waterfall.SVG.ToSVG.diagramToSvgWithLineStyle`+- Added `Generic` and [`NFData`](https://hackage-content.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData) instances for the following+  - `Waterfall.SVG.ToSVG.LineStyle`+  - `Waterfall.SVG.FromSVG.SVGError`+  - `Waterfall.SVG.FromSVG.SVGErrorKind`++### Changed++- Edge paths carry only the class `edge`: `visible`/`hidden` and `sharp`/`outline` are now classes on the enclosing groups+- The default hidden-line colour and opacity changed from light blue at full opacity to black at 0.4 opacity++### Fixed++- `path2DToPathCommands` generated extraneous `MoveTo` commands, and incorrectly omitted the `MoveTo` command before the first segment of loops with two edges+ ## 0.6.3.2  ## 0.6.3.1

@@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DeriveGeneric #-} {-| Load [SVG Data](https://developer.mozilla.org/en-US/docs/Web/SVG) into `Waterfall.Path2D` -}@@ -29,6 +30,8 @@ import Data.Bifunctor (first) import Data.Maybe (catMaybes) import Data.Function ((&))+import GHC.Generics (Generic)+import Control.DeepSeq (NFData)  -- | Categories of error that may occur when processing an SVG data SVGErrorKind@@ -38,11 +41,15 @@     | SVGPathError     | SVGTransformError     | SVGNumberError-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Generic) +instance NFData SVGErrorKind+ -- | Type representing an error that occured when processing an SVG data SVGError = SVGError SVGErrorKind String-        deriving (Eq, Ord, Show)+        deriving (Eq, Ord, Show, Generic)++instance NFData SVGError  uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g uncurry6 fn (a, b, c, d, e, f) = fn a b c d e f

@@ -1,9 +1,14 @@ {-# Language OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-} {-| Convert "Waterfall" data into [SVG](https://developer.mozilla.org/en-US/docs/Web/SVG) -} module Waterfall.SVG.ToSVG ( path2DToPathCommands+, LineStyle (..)+, lineStyleCss+, diagramToSvgWithLineStyle , diagramToSvg , writeDiagramSVG ) where@@ -13,7 +18,7 @@ import qualified Graphics.Svg.CssTypes as Svg.Css import Waterfall.Internal.NearZero (nearZero) import Linear (_xy, _x, _y, V2 (..))-import Control.Lens ((^.), (&), (.~))+import Control.Lens ((^.), (&), (.~), (<&>)) import Foreign.Ptr (Ptr) import Control.Monad ((<=<))  import Control.Monad.IO.Class (liftIO)@@ -37,7 +42,32 @@ import OpenCascade.Inheritance (upcast) import Data.Acquire (Acquire) import Codec.Picture.Types (PixelRGBA8 (..))+import Data.Traversable (mapAccumM)+import Data.Maybe (fromMaybe)+import Control.Applicative ((<|>))+import Control.Arrow ((>>>))+import Control.DeepSeq (NFData (rnf))+import GHC.Generics (Generic) +-- SVG.PathCommand doesn't have an NFData instance+-- which is needed for it to be the target of an `unsafeFromAcquire`+newtype ForceablePathCommand = ForceablePathCommand +    { getForceablePathCommand :: Svg.PathCommand+    }++instance NFData ForceablePathCommand where+    rnf (ForceablePathCommand (Svg.MoveTo o ps)) = (o `seq` ()) `seq` rnf ps+    rnf (ForceablePathCommand (Svg.LineTo o ps)) = (o `seq` ()) `seq` rnf ps+    rnf (ForceablePathCommand (Svg.HorizontalTo o cs)) = (o `seq` ()) `seq` rnf cs+    rnf (ForceablePathCommand (Svg.VerticalTo o cs)) = (o `seq` ()) `seq` rnf cs+    rnf (ForceablePathCommand (Svg.CurveTo o ps)) = (o `seq` ()) `seq` rnf ps+    rnf (ForceablePathCommand (Svg.SmoothCurveTo o ps)) = (o `seq` ()) `seq` rnf ps+    rnf (ForceablePathCommand (Svg.QuadraticBezier o ps)) = (o `seq` ()) `seq` rnf ps+    rnf (ForceablePathCommand (Svg.SmoothQuadraticBezierCurveTo o ps)) = (o `seq` ()) `seq` rnf ps+    rnf (ForceablePathCommand (Svg.EllipticalArc o as)) = (o `seq` ()) `seq` rnf as+    rnf (ForceablePathCommand Svg.EndPath) = ()++ lineToPathCommand :: Ptr TopoDS.Edge -> IO [Svg.PathCommand] lineToPathCommand edge = do     (_s, e) <- Internal.Edges.edgeEndpoints edge@@ -108,42 +138,118 @@     return . pure .         Svg.LineTo Svg.OriginAbsolute $ (^. _xy) <$> ps -edgeToPathCommand :: Maybe (V2 Double) -> Ptr TopoDS.Edge -> (Maybe (V2 Double), [Svg.PathCommand])-edgeToPathCommand curPos edge = Internal.Finalizers.unsafeFromAcquire $ do-    startPos <- liftIO $ (^. _xy) <$> Internal.Edges.edgeValue edge 0-    endPos <- liftIO $ (^. _xy) <$> Internal.Edges.edgeValue edge 1-    let hasntMoved = all nearZero . (startPos -) <$> curPos-    let addMoveCommand = -            case hasntMoved of -                Just True -> id-                _ -> ((Svg.MoveTo Svg.OriginAbsolute . pure $ startPos) :)-    adaptor <- BRepAdaptor.Curve.fromEdge edge-    curveType <- liftIO $ BRepAdaptor.Curve.curveType adaptor-    thisSegment <--        case curveType of -            GeomAbs.CurveType.Line -> liftIO $ lineToPathCommand edge-            GeomAbs.CurveType.BezierCurve -> bezierToPathCommand edge adaptor-            -- GeomAbs.CurveType.BSplineCurve -> There's some argument for special casing this, but we don't need to-            _ -> approximateCurveToPathCommand edge-    return (Just endPos, addMoveCommand thisSegment)+edgeToPathCommand ::  Maybe (V2 Double) -> Ptr TopoDS.Edge -> Acquire (Maybe (V2 Double), [Svg.PathCommand])+edgeToPathCommand curPos edge = do +        startPos <- liftIO $ (^. _xy) <$> Internal.Edges.edgeValue edge 0+        endPos <- liftIO $ (^. _xy) <$> Internal.Edges.edgeValue edge 1+        let hasntMoved = all nearZero . (startPos -) <$> curPos+        let addMoveCommand = +                case hasntMoved of +                    Just True -> id+                    _ -> ((Svg.MoveTo Svg.OriginAbsolute . pure $ startPos) :)+        adaptor <- BRepAdaptor.Curve.fromEdge edge+        curveType <- liftIO $ BRepAdaptor.Curve.curveType adaptor+        thisSegment <-+            case curveType of +                GeomAbs.CurveType.Line -> liftIO $ lineToPathCommand edge+                GeomAbs.CurveType.BezierCurve -> bezierToPathCommand edge adaptor+                -- GeomAbs.CurveType.BSplineCurve -> There's some argument for special casing this, but we don't need to+                _ -> approximateCurveToPathCommand edge+        return (Just endPos, addMoveCommand thisSegment) +shapeToPathCommands :: Waterfall.Shape -> [Svg.PathCommand]+shapeToPathCommands = +    let stripMoveTo = take 1 <> filter (not . isMoveTo) . drop 1+        isMoveTo (Svg.MoveTo _ _) = True+        isMoveTo _ = False+    in concatMap (stripMoveTo. path2DToPathCommands)+        . Waterfall.shapePaths +    +colourToPixel :: Waterfall.Colour -> PixelRGBA8+colourToPixel (Waterfall.Colour r g b) =+    let conv = round . (* 255) . min 1 . max 0+     in PixelRGBA8 (conv r) (conv g) (conv b) 255++fillToPath :: (Waterfall.Paint, Waterfall.Shape) -> Svg.Path+fillToPath (paint, shape) =+    let colour = fromMaybe (Waterfall.Colour 1 1 1) (paint ^. Waterfall.paintColour <|> Waterfall.defaultPaint ^. Waterfall.paintColour)+        opacity = fromMaybe (1.0)  (paint ^. Waterfall.paintOpacity <|> Waterfall.defaultPaint ^. Waterfall.paintOpacity)+        setOpacity = if opacity == 1.0 +            then id +            else Svg.drawAttr . Svg.fillOpacity .~ (pure . realToFrac $ opacity)++    in Svg.defaultSvg+        & Svg.pathDefinition .~ shapeToPathCommands shape+        & Svg.drawAttr . Svg.fillColor .~ (pure . Svg.ColorRef . colourToPixel $ colour)+        & setOpacity+         -- | Convert a `Waterfall.Path2D` into a list of `Svg.PathCommands` path2DToPathCommands :: Waterfall.Path2D -> [Svg.PathCommand] path2DToPathCommands (Path2D theRawPath) = case theRawPath of       Internal.Path.Common.EmptyRawPath -> []     Internal.Path.Common.SinglePointRawPath _ -> []     Internal.Path.Common.ComplexRawPath wire -> -        Internal.Finalizers.unsafeFromAcquireT $-            mconcat -                . fmap snd-                . scanr (flip (edgeToPathCommand . fst)) (Nothing, []) -                <$> Internal.Edges.wireEdges wire+        fmap getForceablePathCommand +            . Internal.Finalizers.unsafeFromAcquire $+                fmap (+                fmap ForceablePathCommand +                . concat +                . snd ) +                . mapAccumM edgeToPathCommand Nothing +                =<< (Internal.Edges.wireEdges +                    =<< Internal.Finalizers.acquireForeignPtr wire) ++-- | How lines should appear+-- +-- These values are used to generate inline CSS+data LineStyle = LineStyle+    { visibleLineColour :: Waterfall.Colour+    , hiddenLineColour :: Waterfall.Colour+    , hiddenLineOpacity :: Double+    } deriving (Eq, Ord, Show, Generic)++instance NFData LineStyle++++defaultLineStyle :: LineStyle+defaultLineStyle = LineStyle+    { visibleLineColour = Waterfall.Colour 0 0 0+    , hiddenLineColour = Waterfall.Colour 0 0 0+    , hiddenLineOpacity = 0.4+    }++-- | The inline CSS used to style an SVG diagram+lineStyleCss :: LineStyle -> [Svg.Css.CssRule]+lineStyleCss (LineStyle {..}) = +    [ Svg.Css.CssRule +        [[Svg.Css.AllOf [Svg.Css.OfClass "edge"]]]+        [ Svg.Css.CssDeclaration "fill" [[Svg.Css.CssIdent "None"]]+        , Svg.Css.CssDeclaration "fill-opacity" [[Svg.Css.CssNumber (Svg.Num 0)]]+        , Svg.Css.CssDeclaration "stroke-linecap" [[Svg.Css.CssIdent "round"]]+        ]+    , Svg.Css.CssRule+        [[Svg.Css.AllOf [Svg.Css.OfClass "visible"], Svg.Css.AllOf[Svg.Css.OfClass "edge"]]]+        [Svg.Css.CssDeclaration "stroke" [[Svg.Css.CssColor . colourToPixel $ visibleLineColour]]]+    , Svg.Css.CssRule+        [[Svg.Css.AllOf [Svg.Css.OfClass "hidden"], Svg.Css.AllOf [Svg.Css.OfClass "edge"]]]+        [ Svg.Css.CssDeclaration "stroke" [[Svg.Css.CssColor . colourToPixel $ hiddenLineColour]]+        , Svg.Css.CssDeclaration "stroke-opacity" [[Svg.Css.CssNumber . Svg.Num $ hiddenLineOpacity]]+        ]+    , Svg.Css.CssRule+        [[Svg.Css.AllOf [Svg.Css.OfClass "fill"]]]+        [ Svg.Css.CssDeclaration "fill-rule" [[Svg.Css.CssIdent "evenodd"]]]+    ]+ -- | Convert a `Waterfall.Diagram` into an SVG document -- --- The diagram paths have the classes "edge", "visible"\/"hidden" and "sharp"\/"outline"-diagramToSvg :: Waterfall.Diagram -> Svg.Document-diagramToSvg diagram = +-- The diagram paths have the class "edge"+-- and are grouped within elements with class "sharp"\/"outline" and "visible"\/"hidden"+-- +-- The diagram fills have the class "fill"+diagramToSvgWithLineStyle :: LineStyle -> Waterfall.Diagram -> Svg.Document+diagramToSvgWithLineStyle lineStyle diagram =      case Waterfall.diagramBoundingBox diagram of          Nothing -> Svg.Document Nothing Nothing Nothing [] mempty mempty mempty mempty         Just (lo, hi) -> @@ -153,30 +259,52 @@                 paths lt visibility =                     path2DToPathCommands =<<                         Waterfall.diagramLines lt visibility d'-                styles = -                    [ Svg.Css.CssRule -                        [[Svg.Css.AllOf [Svg.Css.OfClass "edge"]]]-                        [ Svg.Css.CssDeclaration "fill" [[Svg.Css.CssIdent "None"]]-                        , Svg.Css.CssDeclaration "fill-opacity" [[Svg.Css.CssNumber (Svg.Num 0)]]-                        ]-                    , Svg.Css.CssRule-                        [[Svg.Css.AllOf [Svg.Css.OfClass "edge", Svg.Css.OfClass "visible"]]]-                        [Svg.Css.CssDeclaration "stroke" [[Svg.Css.CssColor $ PixelRGBA8 0 0 0 255]]]-                    , Svg.Css.CssRule-                        [[Svg.Css.AllOf [Svg.Css.OfClass "edge", Svg.Css.OfClass "hidden"]]]-                        [Svg.Css.CssDeclaration "stroke" [[Svg.Css.CssColor $ PixelRGBA8 200 200 255 255]]]-                    ]+                styles = lineStyleCss lineStyle                 document e = Svg.Document Nothing w h [e] mempty mempty styles mempty-                drawAttrs classes = mempty -                    & Svg.attrClass .~ classes-                pathOf lt visibility classes = Svg.PathTree $ Svg.Path (drawAttrs classes) (paths lt visibility)-                group children = Svg.GroupTree $ Svg.Group mempty children Nothing Svg.defaultSvg-            in document . group $-                    [ pathOf lineType visibility ["edge", ltClass, vClass]-                        | (visibility, vClass) <- [(Waterfall.Hidden, "hidden"), (Waterfall.Visible, "visible")]-                        , (lineType, ltClass) <- [(Waterfall.SharpLine, "sharp"), (Waterfall.OutLine, "outline")]+                pathOf lt visibility = +                        Svg.defaultSvg +                            & Svg.pathDefinition .~ paths lt visibility+                            & Svg.drawAttr . Svg.attrClass .~ ["edge"]+                            & Svg.PathTree+                    +                fills = +                    Svg.defaultSvg +                        & Svg.groupChildren .~ +                            (Waterfall.getDiagramFills d' +                                <&> (fillToPath+                                    >>> Svg.drawAttr . Svg.attrClass .~ ["fill"]+                                    >>> Svg.PathTree+                                )+                            )+                        & Svg.GroupTree+                    +                group children+                     = Svg.defaultSvg+                        & Svg.groupChildren .~ children+                        & Svg.GroupTree +            in document . group . (fills :) $+                    [ Svg.defaultSvg +                        & Svg.groupChildren .~+                            [ Svg.defaultSvg +                                & Svg.groupChildren .~ [ pathOf lineType visibility ]+                                & Svg.drawAttr . Svg.attrClass .~ [ltClass]+                                & Svg.GroupTree+                            | (lineType, ltClass) <- [(Waterfall.SharpLine, "sharp"), (Waterfall.OutLine, "outline")]+                            ]  +                        & Svg.drawAttr . Svg.attrClass .~ [vClass]+                        & Svg.GroupTree+                    | (visibility, vClass) <- [(Waterfall.Hidden, "hidden"), (Waterfall.Visible, "visible")]                     ]                     +-- | Convert a `Waterfall.Diagram` into an SVG document+-- +-- The diagram paths have the class "edge"+-- and are grouped within elements with class "sharp"\/"outline" and "visible"\/"hidden"+-- +-- The diagram fills have the class "fill"+diagramToSvg :: Waterfall.Diagram -> Svg.Document+diagramToSvg = diagramToSvgWithLineStyle defaultLineStyle+ -- | Write a `Waterfall.Diagram`, to an SVG file at the specified location  writeDiagramSVG :: FilePath -> Waterfall.Diagram -> IO () writeDiagramSVG path = Svg.saveXmlFile path . diagramToSvg

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           waterfall-cad-svg-version:        0.6.3.2+version:        0.7.0.0 synopsis:       Declarative CAD/Solid Modeling Library, SVG Support description:    Please see the README on GitHub at <https://github.com/joe-warren/opencascade-hs#readme> category:       Graphics@@ -43,13 +43,14 @@       JuicyPixels ==3.*     , attoparsec >=0.14 && <1     , base >=4.7 && <5+    , deepseq >=1.4 && <2     , lens ==5.*     , linear >=1.0 && <2-    , opencascade-hs >=0.6.3.2 && <0.7+    , opencascade-hs >=0.7.0.0 && <0.8     , resourcet >=1.2 && <1.4     , svg-tree >=0.6 && <1     , text >=1.2 && <3-    , waterfall-cad >=0.6.3.2 && <0.7+    , waterfall-cad >=0.7.0.0 && <0.8   default-language: Haskell2010  test-suite tests@@ -64,14 +65,15 @@       JuicyPixels ==3.*     , attoparsec >=0.14 && <1     , base >=4.7 && <5+    , deepseq >=1.4 && <2     , lens ==5.*     , linear >=1.0 && <2-    , opencascade-hs >=0.6.3.2 && <0.7+    , opencascade-hs >=0.7.0.0 && <0.8     , resourcet >=1.2 && <1.4     , svg-tree >=0.6 && <1     , tasty     , tasty-hunit     , text >=1.2 && <3-    , waterfall-cad >=0.6.3.2 && <0.7+    , waterfall-cad >=0.7.0.0 && <0.8     , waterfall-cad-svg   default-language: Haskell2010