diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/src/Waterfall/SVG/FromSVG.hs b/src/Waterfall/SVG/FromSVG.hs --- a/src/Waterfall/SVG/FromSVG.hs +++ b/src/Waterfall/SVG/FromSVG.hs @@ -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 diff --git a/src/Waterfall/SVG/ToSVG.hs b/src/Waterfall/SVG/ToSVG.hs --- a/src/Waterfall/SVG/ToSVG.hs +++ b/src/Waterfall/SVG/ToSVG.hs @@ -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 diff --git a/waterfall-cad-svg.cabal b/waterfall-cad-svg.cabal --- a/waterfall-cad-svg.cabal +++ b/waterfall-cad-svg.cabal @@ -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 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