From a459467ed0819b31320153d8b4ecf58694e006ec Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 7 Sep 2020 17:38:22 +0200 Subject: [PATCH] add parallelism for brush outline computation * also enable varying the fitting parameters (UI todo) --- MetaBrush.cabal | 6 +- app/Main.hs | 28 ++++++++- src/app/MetaBrush/Context.hs | 3 + src/app/MetaBrush/Render/Document.hs | 14 +++-- src/lib/Math/Bezier/Cubic.hs | 6 ++ src/lib/Math/Bezier/Cubic/Fit.hs | 24 ++++--- src/lib/Math/Bezier/Quadratic.hs | 6 ++ src/lib/Math/Bezier/Stroke.hs | 93 ++++++++++++++++++++-------- src/lib/Math/Vector2D.hs | 9 ++- 9 files changed, 145 insertions(+), 44 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index f6f7c7a..a998c38 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -76,10 +76,14 @@ library , Math.Vector2D build-depends: - groups-generic + deepseq + ^>= 1.4.4.0 + , groups-generic ^>= 0.1.0.0 , hmatrix ^>= 0.20.0.0 + , monad-par + ^>= 0.3.5 , vector ^>= 0.12.1.2 diff --git a/app/Main.hs b/app/Main.hs index de8fa6d..cb6cbd9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -20,6 +20,8 @@ import Data.Int ( Int32 ) import System.Exit ( exitSuccess ) +import GHC.Conc + ( getNumProcessors, setNumCapabilities ) -- containers import Data.Map.Strict @@ -60,6 +62,8 @@ import qualified Data.Text as Text ( pack ) -- MetaBrush +import Math.Bezier.Cubic.Fit + ( FitParameters(..) ) import Math.Bezier.Stroke ( StrokePoint(..) ) import Math.Vector2D @@ -169,6 +173,18 @@ testDocuments = uniqueMapFromList main :: IO () main = do + procs <- getNumProcessors + let + caps :: Int + caps + | procs >= 6 + = procs - 2 + | procs >= 2 + = procs - 1 + | otherwise + = procs + setNumCapabilities caps + --------------------------------------------------------- -- Initialise state @@ -183,6 +199,15 @@ main = do partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing fileBarTabsTVar <- STM.newTVarIO @( Map Unique GTK.Box ) Map.empty showGuidesTVar <- STM.newTVarIO @Bool True + fitParametersTVar <- STM.newTVarIO @FitParameters + ( FitParameters + { maxSubdiv = 2 + , nbSegments = 13 + , dist_tol = 2e-3 + , t_tol = 5e-4 + , maxIters = 500 + } + ) -- Put all these stateful variables in a record for conciseness. let @@ -300,9 +325,10 @@ main = do mbPartialPath <- STM.readTVar partialPathTVar mode <- STM.readTVar modeTVar showGuides <- STM.readTVar showGuidesTVar + fitParameters <- STM.readTVar fitParametersTVar pure do renderDocument - colours mode ( viewportWidth, viewportHeight ) + colours fitParameters mode ( viewportWidth, viewportHeight ) mbMousePos mbHoldAction mbPartialPath doc renderRuler diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index f5880bd..0648dc3 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -62,6 +62,8 @@ import Control.Monad.Trans.Maybe ( MaybeT(..) ) -- MetaBrush +import Math.Bezier.Cubic.Fit + ( FitParameters ) import Math.Vector2D ( Point2D ) import MetaBrush.Asset.Colours @@ -112,6 +114,7 @@ data Variables , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) , fileBarTabsTVar :: !( STM.TVar ( Map Unique GTK.Box ) ) , showGuidesTVar :: !( STM.TVar Bool ) + , fitParametersTVar :: !( STM.TVar FitParameters ) } -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 0664e6d..bec0632 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -61,6 +61,8 @@ import Control.Lens -- MetaBrush import qualified Math.Bezier.Cubic as Cubic ( Bezier(..) ) +import Math.Bezier.Cubic.Fit + ( FitParameters ) import qualified Math.Bezier.Quadratic as Quadratic ( Bezier(..) ) import Math.Bezier.Stroke @@ -110,12 +112,12 @@ blankRender :: Colours -> Cairo.Render () blankRender ( Colours {..} ) = pure () renderDocument - :: Colours -> Mode -> ( Int32, Int32 ) + :: Colours -> FitParameters -> Mode -> ( Int32, Int32 ) -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Document -> Cairo.Render () renderDocument - cols mode ( viewportWidth, viewportHeight ) + cols params mode ( viewportWidth, viewportHeight ) mbMousePos mbHoldEvent mbPartialPath doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } ) = do @@ -171,20 +173,20 @@ renderDocument | otherwise = strokes doc - for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mode zoomFactor ) + for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols params mode zoomFactor ) renderSelectionRect Cairo.restore pure () -renderStroke :: Colours -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render () -renderStroke cols@( Colours { brush } ) mode zoom ( Stroke { strokePoints = pts, strokeVisible } ) +renderStroke :: Colours -> FitParameters -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render () +renderStroke cols@( Colours { brush } ) params mode zoom ( Stroke { strokePoints = pts, strokeVisible } ) | strokeVisible = renderStrokePoints cols mode zoom ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) ( 1.5 * zoom ) ) pts - *> Compose blank { renderStrokes = drawStroke cols ( stroke pts ) } + *> Compose blank { renderStrokes = drawStroke cols ( stroke params pts ) } | otherwise = pure () diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index 0774a60..155fd40 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/src/lib/Math/Bezier/Cubic.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingVia #-} @@ -35,6 +36,10 @@ import Data.Act ( (-->) ) ) +-- deepseq +import Control.DeepSeq + ( NFData, NFData1 ) + -- generic-data import Generic.Data ( GenericProduct(..), Generically1(..) ) @@ -71,6 +76,7 @@ data Bezier p via GenericProduct ( Bezier p ) deriving Applicative via Generically1 Bezier + deriving anyclass ( NFData, NFData1 ) deriving via Ap Bezier p instance Act v p => Act v ( Bezier p ) diff --git a/src/lib/Math/Bezier/Cubic/Fit.hs b/src/lib/Math/Bezier/Cubic/Fit.hs index 08bec6f..3c98fc2 100644 --- a/src/lib/Math/Bezier/Cubic/Fit.hs +++ b/src/lib/Math/Bezier/Cubic/Fit.hs @@ -1,10 +1,12 @@ {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Math.Bezier.Cubic.Fit - ( fitSpline, fitPiece ) + ( FitParameters(..) + , fitSpline, fitPiece + ) where -- base @@ -67,6 +69,16 @@ import Math.Vector2D -------------------------------------------------------------------------------- +-- | Parameters to the curve fitting algorithm. +data FitParameters + = FitParameters + { maxSubdiv :: !Int -- ^ maximum subdivision recursion number + , nbSegments :: !Int -- ^ number of segments to split the curve into for fitting, + , dist_tol :: !Double -- ^ tolerance for the distance + , t_tol :: !Double -- ^ the tolerance for the Bézier parameter (for the fitting process) + , maxIters :: !Int -- ^ maximum number of iterations (for the fitting process) + } + -- | Fits a cubic Bézier spline to the given curve \( t \mapsto C(t), 0 \leqslant t \leqslant 1 \), -- assumed to be G1-continuous. -- @@ -79,14 +91,10 @@ import Math.Vector2D -- See 'fitPiece' for more information on the fitting process, -- including the meaning of \( \texttt{t_tol} \) and \( \texttt{maxIters} \). fitSpline - :: Int -- ^ \( \texttt{maxSubdiv} \), the maximum subdivision recursion number - -> Int -- ^ \( \texttt{nbSegments} \), number of segments to split the curve into for fitting, - -> Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance - -> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter (for the fitting process) - -> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations (for the fitting process) + :: FitParameters -> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit -> Seq ( Cubic.Bezier ( Point2D Double ) ) -fitSpline maxSubdiv nbSegments dist_tol t_tol maxIters = go 0 +fitSpline ( FitParameters {..} ) = go 0 where dt :: Double dt = recip ( fromIntegral nbSegments ) diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index 4e7b197..282963f 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/src/lib/Math/Bezier/Quadratic.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingVia #-} @@ -35,6 +36,10 @@ import Data.Act ( (-->) ) ) +-- deepseq +import Control.DeepSeq + ( NFData, NFData1 ) + -- generic-data import Generic.Data ( GenericProduct(..), Generically1(..) ) @@ -69,6 +74,7 @@ data Bezier p via GenericProduct ( Bezier p ) deriving Applicative via Generically1 Bezier + deriving anyclass ( NFData, NFData1 ) deriving via Ap Bezier p instance Act v p => Act v ( Bezier p ) diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index 4681791..28fc68e 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} @@ -47,6 +48,10 @@ import qualified Data.Sequence as Seq , zipWith, zipWith3, zipWith4 ) +-- deepseq +import Control.DeepSeq + ( NFData ) + -- generic-lens import Data.Generics.Product.Fields ( field, field' ) @@ -55,10 +60,16 @@ import Data.Generics.Product.Typed import Data.GenericLens.Internal ( set, over, view ) +-- monad-par +import Control.Monad.Par + ( Par ) +import qualified Control.Monad.Par as Par + ( get, runPar, spawn, spawnP ) + -- MetaBrush import qualified Math.Bezier.Cubic as Cubic import Math.Bezier.Cubic.Fit - ( fitSpline ) + ( FitParameters, fitSpline ) import qualified Math.Bezier.Quadratic as Quadratic import Math.Epsilon ( epsilon ) @@ -80,7 +91,8 @@ data StrokePoint d { coords :: !( Point2D Double ) , pointData :: d } - deriving stock ( Show, Generic ) + deriving stock ( Show, Generic ) + deriving anyclass NFData instance Act ( Vector2D Double ) ( StrokePoint d ) where (•) v = over ( field' @"coords" ) ( v • ) @@ -98,7 +110,8 @@ data Offset , offset :: !( Vector2D Double ) --, curvature :: !Double } - deriving stock Show + deriving stock ( Show, Generic ) + deriving anyclass NFData -------------------------------------------------------------------------------- @@ -107,11 +120,12 @@ stroke . ( Show x, Show d , HasType ( Seq ( StrokePoint x ) ) d ) - => Seq ( StrokePoint d ) + => FitParameters + -> Seq ( StrokePoint d ) -> Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) -stroke Empty = Left Empty -stroke ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0 -stroke allPts@( spt0 :<| spt1 :<| spts ) +stroke _ Empty = Left Empty +stroke _ ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0 +stroke params allPts@( spt0 :<| spt1 :<| spts ) | isClosed = if null ( brushShape @x spt0 ) then Right ( Empty, Empty ) @@ -140,7 +154,7 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) _ -> False fwdPts, bwdPts :: Seq ( StrokePoint () ) - ( fwdPts, bwdPts ) = go spt0 ( spt1 :<| spts ) + ( fwdPts, bwdPts ) = Par.runPar $ go spt0 ( spt1 :<| spts ) (<~>) :: ( Monoid a, Monoid b ) @@ -151,17 +165,21 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) -- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity). -- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction). - joinAndContinue :: Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) + joinAndContinue :: Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> Par ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) joinAndContinue tgt sp0 ( sp1 :<| sps ) | tgt' `parallel` tgt = go sp0 ( sp1 :<| sps ) | let ptOffset :: Vector2D Double ptOffset = Point2D 0 0 --> coords sp0 - = ( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0 - , ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0 - ) - <~> go sp0 ( sp1 :<| sps ) + = do + let + brushJoin = + ( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0 + , ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0 + ) + next <- go sp0 ( sp1 :<| sps ) + pure ( brushJoin <~> next ) where tgt' :: Vector2D Double tgt' = coords sp0 --> coords sp1 @@ -170,14 +188,16 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) joinAndContinue _ _ Empty -- Closed curve. | isClosed - = if parallel tgt_start tgt_end + = pure $ + if parallel tgt_start tgt_end then ( Empty, Empty ) else ( startOffset • joinWithBrush ( withTangent tgt_start brush_start ) ( withTangent tgt_end brush_start ) brush_start , startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start ) -- Open curve. | otherwise - = ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end + = pure + ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end , Empty -- handled separately: see 'startingCap' below ) @@ -186,8 +206,8 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) startingCap = startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start - go :: StrokePoint d -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) - go _ Empty = ( Empty, Empty ) + go :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) + go _ Empty = pure ( Empty, Empty ) -- Line. go sp0 ( sp1 :<| sps ) | PathPoint {} <- sp1 @@ -213,8 +233,14 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) where s :: Double s = 1 - t - = ( fitCurve fwd, fitCurve bwd ) - <~> joinAndContinue tgt sp1 sps + = do + fwdIVar <- Par.spawnP ( fitCurve fwd ) + bwdIVar <- Par.spawnP ( fitCurve bwd ) + nextIVar <- Par.spawn ( joinAndContinue tgt sp1 sps ) + fwdCurve <- Par.get fwdIVar + bwdCurve <- Par.get bwdIVar + next <- Par.get nextIVar + pure $ ( fwdCurve, bwdCurve ) <~> next -- Quadratic Bézier curve. go sp0 ( sp1 :<| sp2 :<| sps ) | ControlPoint {} <- sp1 @@ -245,8 +271,14 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) where s :: Double s = 1 - t - = ( fitCurve fwd, fitCurve bwd ) - <~> joinAndContinue tgt2 sp2 sps + = do + fwdIVar <- Par.spawnP ( fitCurve fwd ) + bwdIVar <- Par.spawnP ( fitCurve bwd ) + nextIVar <- Par.spawn ( joinAndContinue tgt2 sp2 sps ) + fwdCurve <- Par.get fwdIVar + bwdCurve <- Par.get bwdIVar + next <- Par.get nextIVar + pure $ ( fwdCurve, bwdCurve ) <~> next -- Cubic Bézier curve. go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) | ControlPoint {} <- sp1 @@ -279,10 +311,21 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) where s :: Double s = 1 - t - = ( fitCurve fwd, fitCurve bwd ) - <~> joinAndContinue tgt3 sp3 sps + = do + fwdIVar <- Par.spawnP ( fitCurve fwd ) + bwdIVar <- Par.spawnP ( fitCurve bwd ) + nextIVar <- Par.spawn ( joinAndContinue tgt3 sp3 sps ) + fwdCurve <- Par.get fwdIVar + bwdCurve <- Par.get bwdIVar + next <- Par.get nextIVar + pure $ ( fwdCurve, bwdCurve ) <~> next go p0 ps = error $ "stroke: unrecognised stroke type\n" <> show ( p0 :<| ps ) + fitCurve + :: ( Double -> ( Point2D Double, Vector2D Double ) ) + -> Seq ( StrokePoint () ) + fitCurve = splinePoints . fitSpline params + ----------------------------------- -- Various utility functions -- used in the "stroke" function. @@ -336,10 +379,6 @@ cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s = CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ] -fitCurve - :: ( Double -> ( Point2D Double, Vector2D Double ) ) - -> Seq ( StrokePoint () ) -fitCurve curve = splinePoints $ fitSpline 1 13 1e-4 1e-5 100 curve splinePoints :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () ) splinePoints Empty = Empty diff --git a/src/lib/Math/Vector2D.hs b/src/lib/Math/Vector2D.hs index 55ba685..4719d44 100644 --- a/src/lib/Math/Vector2D.hs +++ b/src/lib/Math/Vector2D.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingVia #-} @@ -22,6 +23,10 @@ import GHC.Generics import Data.Act ( Act, Torsor ) +-- deepseq +import Control.DeepSeq + ( NFData, NFData1 ) + -- generic-data import Generic.Data ( Generically1(..), GenericProduct(..) ) @@ -46,10 +51,11 @@ data Point2D a = Point2D !a !a via Vector2D a deriving Applicative via Generically1 Point2D + deriving anyclass ( NFData, NFData1 ) newtype Vector2D a = MkVector2D { tip :: Point2D a } deriving stock ( Show, Generic, Generic1, Foldable, Traversable ) - deriving newtype ( Eq, Functor, Applicative ) + deriving newtype ( Eq, Functor, Applicative, NFData, NFData1 ) deriving ( Semigroup, Monoid, Group ) via GenericProduct ( Point2D ( Sum a ) ) @@ -77,3 +83,4 @@ data Mat22 a deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable ) deriving Applicative via Generically1 Mat22 + deriving anyclass ( NFData, NFData1 )