diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Main (main) where import CsgExample (csgExample) @@ -11,23 +12,56 @@ import TextExample (textExample) import BoundingBoxExample (boundingBoxExample) import ReadSolidExpressionExample (readSolidExpressionExample) +import SVG.PathExample (pathExample) +import SVG.ReadFileExample (readFileExample) +import Waterfall.SVG (writeDiagramSVG) +import DarkModeSVG (writeDarkModeSVG) import Waterfall.IO (writeSTL, writeSTEP, writeGLTF, writeGLB, writeOBJ) +import qualified Waterfall.Diagram as Diagram import qualified Waterfall.Solids as Solids +import qualified Waterfall.TwoD.Transforms as TwoD.Transforms import qualified Options.Applicative as OA -import Control.Applicative ((<|>), liftA2) +import Linear (V2 (..), V3 (..), _x, _y) +import Control.Lens ((^.)) +import Control.Applicative ((<|>)) import Control.Monad (join) +normalizeSize :: (V2 Double -> Double, Double) -> Diagram.Diagram -> Diagram.Diagram +normalizeSize (getter, target) d = + case Diagram.diagramBoundingBox d of + Just (lo, hi) -> + let s = getter (hi - lo) + in TwoD.Transforms.uScale2D (target / s) d + Nothing -> d + outputOption :: OA.Parser (Solids.Solid -> IO ()) outputOption = let stlOption = (flip writeSTL) <$> OA.strOption (OA.long "stl" <> OA.metavar "Stl file to write results to") gltfOption = (flip writeGLTF) <$> OA.strOption (OA.long "gltf" <> OA.metavar "GLTF file to write results to") glbOption = (flip writeGLB) <$> OA.strOption (OA.long "glb" <> OA.metavar "GLB file to write results to") objOption = (flip writeOBJ) <$> OA.strOption (OA.long "obj" <> OA.metavar "OBJ file to write results to") + svgWriterOptions :: OA.Parser (Diagram.Diagram -> IO ()) + svgWriterOptions = + (writeDiagramSVG <$> OA.strOption (OA.long "svg" <> OA.metavar "SVG file to write results to")) + <|> (writeDarkModeSVG <$> OA.strOption (OA.long "dark-mode-svg" <> OA.metavar "SVG file to write results to (with the style modified to support dark mode)")) + imageSizeOptions = + (((^. _x),) <$> OA.option OA.auto (OA.long "width" <> OA.help "image target width")) + <|> (((^. _y),) <$> OA.option OA.auto (OA.long "height" <> OA.help "image target height")) + <|> pure ((^. _x), 800) + viewDirectionOption = + (OA.option OA.auto (OA.long "view-direction" <> OA.help "image view direction")) + <|> pure (V3 2 3 1) + svgOptions = + (\writer size direction solid -> writer . normalizeSize size . Diagram.solidDiagram direction $ solid) + <$> svgWriterOptions + <*> imageSizeOptions + <*> viewDirectionOption + meshOptionsNoResolution = stlOption <|> gltfOption <|> glbOption <|> objOption meshOptions = meshOptionsNoResolution <*> (OA.option OA.auto (OA.long "resolution" <> OA.help "linear tolerance for mesh file formats") <|> pure 0.001) stepOption = writeSTEP <$> OA.strOption (OA.long "step" <> OA.metavar "Stl file to write results to") - in meshOptions <|> stepOption + in meshOptions <|> stepOption <|> svgOptions exampleOption :: OA.Parser (IO Solids.Solid) exampleOption = @@ -60,7 +94,12 @@ (OA.option OA.auto (OA.long "size" <> OA.help "font size") <|> pure 12.0) <*> (OA.strOption (OA.long "content" <> OA.help "text to render") <|> pure "Waterfall CAD") <*> (OA.option OA.auto (OA.long "depth" <> OA.help "depth to extrude the text to") <|> pure 10.0) - ) + ) <|> + (OA.flag' (either error pure . pathExample) (OA.long "svg-path" <> OA.help "parse an SVG path string and use it to generate a prism") <*> + (OA.strOption (OA.long "path-string" <> OA.help "the SVG path string")) + ) <|> + (OA.flag' (readFileExample) (OA.long "svg-read" <> OA.help "read an SVG file and use it to generate a prism") <*> + (OA.strOption (OA.long "svg" <> OA.help "path to the svg"))) main :: IO () main = join (OA.execParser opts) diff --git a/src/BoundingBoxExample.hs b/src/BoundingBoxExample.hs --- a/src/BoundingBoxExample.hs +++ b/src/BoundingBoxExample.hs @@ -1,5 +1,5 @@ module BoundingBoxExample -(boundingBoxExample +( boundingBoxExample ) where import Data.Function ((&)) diff --git a/src/DarkModeSVG.hs b/src/DarkModeSVG.hs new file mode 100644 --- /dev/null +++ b/src/DarkModeSVG.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE QuasiQuotes #-} +module DarkModeSVG +( writeDarkModeSVG +) where + +import qualified Waterfall.SVG +import qualified Waterfall +import qualified Graphics.Svg as Svg +import qualified Text.XML.Light.Types as XML +import qualified Text.XML.Light.Proc as XML.Proc +import qualified Text.XML.Light.Cursor as XML.Cursor +import qualified Text.XML.Light.Output as XML.Output +import Text.RawString.QQ +import Data.Function ((&)) +import Data.Foldable (toList) +import Data.Maybe (listToMaybe, fromMaybe) +import Control.Monad (join) +styles :: String +styles = [r| +.edge { + fill: None; +} +.edge.visible { + stroke: #000000; +} +.edge.hidden { + stroke: #C8C8FF; +} +@media (prefers-color-scheme: dark) { + .edge.visible { + stroke: #FFFFFF; + } + .edge.hidden { + stroke: #A00000; + } +} +|] + +writeDarkModeSVG :: FilePath -> Waterfall.Diagram -> IO () +writeDarkModeSVG path diagram = + let svgAsXML = + diagram + & Waterfall.SVG.diagramToSvg + & Svg.xmlOfDocument + nameIsStyle (XML.Elem e) = (== "style") . XML.qName . XML.elName $ e + nameIsStyle _ = False + in svgAsXML + & XML.Cursor.fromElement + & XML.Cursor.findChild (nameIsStyle . XML.Cursor.current) + & fmap XML.Cursor.firstChild + & join + & fmap (XML.Cursor.setContent (XML.Text (XML.CData XML.CDataText styles Nothing))) + & fmap (XML.Cursor.root) + & fmap XML.Cursor.current + & toList + & XML.Proc.onlyElems + & listToMaybe + & fromMaybe svgAsXML + & XML.Output.ppTopElement + & writeFile path + diff --git a/src/GearExample.hs b/src/GearExample.hs --- a/src/GearExample.hs +++ b/src/GearExample.hs @@ -144,4 +144,4 @@ let segment = genGearToothData moduleLength nGears pressureAngle path = Path2D.repeatLooping segment --path = mconcat [rotate2D (-fromIntegral n * pi * 2 / fromIntegral nGears) segment | n <- [0..nGears]] - in Solids.prism thickness . Shape.fromPath $ path + in Solids.prism thickness . Shape.makeShape $ path diff --git a/src/LoftExample.hs b/src/LoftExample.hs --- a/src/LoftExample.hs +++ b/src/LoftExample.hs @@ -1,8 +1,3 @@ -{-| -Module: Waterfall.Loft - --} - module LoftExample ( loftExample ) where @@ -26,8 +21,7 @@ -- This example demonstrates the `Loft` module, by generating a boat, with the profile of the boat specified by a series of bezier curves. loftExample :: Solids.Solid loftExample = - let precision = 1e-6 - paths = + let paths = [ let p x z = V3 x 0 z -- the curve at the rear of the boat is tilted _slightly_ back in Transforms.rotate (V3 1 0 0) 0.2 $ @@ -44,7 +38,6 @@ symetricPaths = makeSymetric <$> paths body = Loft.pointedLoft - precision Nothing (Path.closeLoop <$> symetricPaths) (Just (V3 0 20 5)) diff --git a/src/OffsetExample.hs b/src/OffsetExample.hs --- a/src/OffsetExample.hs +++ b/src/OffsetExample.hs @@ -11,8 +11,7 @@ offsetExample = let beam axis = rotate axis (pi/2) (scale (V3 2 2 4) Solids.centeredCube) cross = foldMap beam [unit _x, unit _y, unit _z] - tolerance = 1e-6 - offsetCross amount = offset amount tolerance cross + offsetCross amount = offset amount cross offsetCrosses = offsetCross <$> [- 0.5, - 0.25, 0, 0.25, 0.5] position = (unit _x ^* 5 ^*) <$> [0..] in mconcat $ zipWith translate position offsetCrosses diff --git a/src/PrismExample.hs b/src/PrismExample.hs --- a/src/PrismExample.hs +++ b/src/PrismExample.hs @@ -8,7 +8,7 @@ import Linear (V2 (..)) prismExample :: Solids.Solid -prismExample = Solids.prism 1 . Shape.fromPath $ +prismExample = Solids.prism 1 . Shape.makeShape $ Path2D.pathFrom (V2 (-1) (-1)) [ Path2D.arcViaTo (V2 (-1.5) 0) (V2 (-1) 1) , Path2D.lineTo (V2 1 1) diff --git a/src/ReadSolidExpressionExample.hs b/src/ReadSolidExpressionExample.hs --- a/src/ReadSolidExpressionExample.hs +++ b/src/ReadSolidExpressionExample.hs @@ -5,7 +5,6 @@ import qualified Waterfall.Solids as Solids import qualified Waterfall.Booleans as Booleans import qualified Waterfall.IO -import Control.Applicative (liftA2) import Text.Parsec import Control.Monad.Combinators.Expr diff --git a/src/SVG/PathExample.hs b/src/SVG/PathExample.hs new file mode 100644 --- /dev/null +++ b/src/SVG/PathExample.hs @@ -0,0 +1,13 @@ +module SVG.PathExample +( pathExample +) where + +import qualified Waterfall.SVG +import qualified Waterfall.Solids as Solids +import qualified Waterfall.TwoD.Shape as Shape +import Data.Bifunctor (Bifunctor(bimap)) + +pathExample :: String -> Either String Solids.Solid +pathExample pathStr = + let solidify = mconcat . fmap (Solids.prism 1 . Shape.makeShape) + in bimap show solidify $ Waterfall.SVG.parsePath pathStr diff --git a/src/SVG/ReadFileExample.hs b/src/SVG/ReadFileExample.hs new file mode 100644 --- /dev/null +++ b/src/SVG/ReadFileExample.hs @@ -0,0 +1,17 @@ +module SVG.ReadFileExample +( readFileExample +) where + +import qualified Waterfall.SVG +import qualified Waterfall.Solids as Solids +import qualified Waterfall.TwoD.Shape as Shape +import qualified Waterfall.Transforms as Transforms +import qualified Waterfall.Booleans as Booleans +import Linear (V3 (..)) + +readFileExample :: FilePath -> IO Solids.Solid +readFileExample filepath = + let expandVertically = Transforms.translate (V3 0 0 (-0.5)) . Transforms.scale (V3 1 1 2) + xor a b = (a `Booleans.difference` expandVertically b) <> (b `Booleans.difference` expandVertically a) + solidify = foldr xor Solids.nowhere . fmap (Solids.prism 1 . Shape.makeShape) + in either (error . show) solidify <$> Waterfall.SVG.readSVG filepath diff --git a/src/SweepExample.hs b/src/SweepExample.hs --- a/src/SweepExample.hs +++ b/src/SweepExample.hs @@ -18,7 +18,7 @@ , Path.arcViaRelative (V3 0 1 1) (V3 0 2 0) , Path.lineTo (V3 0 2 0) ] - sweepProfile = Shape.fromPath $ + sweepProfile = Shape.makeShape $ Path2D.repeatLooping $ Path2D.bezier (0.25 *^ unit _x) (0.5 *^ unit _x) (0.5 *^ angle (pi/6)) (0.25 *^ angle (pi/6)) in sweep sweepPath sweepProfile diff --git a/src/TextExample.hs b/src/TextExample.hs --- a/src/TextExample.hs +++ b/src/TextExample.hs @@ -3,8 +3,8 @@ ) where import qualified Waterfall - +import Linear (unit, _x) textExample :: FilePath -> Double -> String -> Double -> IO Waterfall.Solid textExample fontpath fontSize content depth = do font <- Waterfall.fontFromPath fontpath fontSize - return . Waterfall.prism depth $ Waterfall.text font content + return . Waterfall.rotate (unit _x) (pi/2) . Waterfall.prism depth $ Waterfall.text font content diff --git a/waterfall-cad-examples.cabal b/waterfall-cad-examples.cabal --- a/waterfall-cad-examples.cabal +++ b/waterfall-cad-examples.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: waterfall-cad-examples -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Examples for Waterfall CAD, a Declarative CAD/Solid Modeling Library description: Please see the README on GitHub at category: Graphics @@ -30,6 +30,7 @@ exposed-modules: BoundingBoxExample CsgExample + DarkModeSVG FilletExample GearExample LoftExample @@ -37,6 +38,8 @@ PrismExample ReadSolidExpressionExample RevolutionExample + SVG.PathExample + SVG.ReadFileExample SweepExample TextExample other-modules: @@ -48,11 +51,15 @@ base >=4.7 && <5 , lens ==5.* , linear >=1.21 && <2 - , opencascade-hs >=0.4.0.0 && <0.5 + , opencascade-hs >=0.5.0.0 && <0.6 , optparse-applicative >=0.17 && <0.19 , parsec ==3.1.* , parser-combinators >=1.2 && <1.4 - , waterfall-cad >=0.4.0.0 && <0.5 + , raw-strings-qq >=1.1 && <2 + , svg-tree >=0.6 && <1.0 + , waterfall-cad >=0.5.0.0 && <0.6 + , waterfall-cad-svg >=0.5.0.0 && <0.6 + , xml ==1.* default-language: Haskell2010 executable waterfall-cad-examples @@ -66,10 +73,14 @@ base >=4.7 && <5 , lens ==5.* , linear >=1.21 && <2 - , opencascade-hs >=0.4.0.0 && <0.5 + , opencascade-hs >=0.5.0.0 && <0.6 , optparse-applicative >=0.17 && <0.19 , parsec ==3.1.* , parser-combinators >=1.2 && <1.4 - , waterfall-cad >=0.4.0.0 && <0.5 + , raw-strings-qq >=1.1 && <2 + , svg-tree >=0.6 && <1.0 + , waterfall-cad >=0.5.0.0 && <0.6 , waterfall-cad-examples + , waterfall-cad-svg >=0.5.0.0 && <0.6 + , xml ==1.* default-language: Haskell2010