hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

add parallelism for brush outline computation

Browse source 
* also enable varying the fitting parameters (UI todo)
This commit is contained in:
sheaf 2020-09-07 17:38:22 +02:00
parent 44c41d49e0
commit a459467ed0
9 changed files with 145 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
MetaBrush.cabal
View file

@ -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

28
app/Main.hs
View file

@ -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

3
src/app/MetaBrush/Context.hs
View file

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

14
src/app/MetaBrush/Render/Document.hs
View file

@ -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 ()

6
src/lib/Math/Bezier/Cubic.hs
View file

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

24
src/lib/Math/Bezier/Cubic/Fit.hs
View file

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

6
src/lib/Math/Bezier/Quadratic.hs
View file

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

93
src/lib/Math/Bezier/Stroke.hs
View file

@ -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

9
src/lib/Math/Vector2D.hs
View file

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