add parallelism for brush outline computation

* also enable varying the fitting parameters (UI todo)

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
 

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

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                )
   }
 
 --------------------------------------------------------------------------------

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 :: Colours -> FitParameters -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render ()
-renderStroke cols@( Colours { brush } ) mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
+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 ()
 

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 )

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
+  :: FitParameters
-  -> 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)
   -> ( 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 )

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 )

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 )
@@ -81,6 +92,7 @@ data StrokePoint d
   , pointData :: d
   }
   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 _ Empty = Left Empty
-stroke ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0
+stroke _ ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0
-stroke allPts@( spt0 :<| spt1 :<| spts )
+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
+      = do
+        let
+          brushJoin =
+            ( ptOffset • joinWithBrush ( withTangent           tgt    brush0 ) ( withTangent           tgt'  brush0 ) brush0
             , ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0
             )
-      <~> go sp0 ( sp1 :<| sps )
+        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 :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
-    go _ Empty = ( Empty, Empty )
+    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 )
+      = do
-      <~> joinAndContinue tgt sp1 sps
+        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 )
+      = do
-      <~> joinAndContinue tgt2 sp2 sps
+        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 )
+      = do
-      <~> joinAndContinue tgt3 sp3 sps
+        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

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 )