diff --git a/app/Main.hs b/app/Main.hs index 6b7daf4..1708980 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -200,7 +200,7 @@ main = do -- Initialise state uniqueSupply <- newUniqueSupply - activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing + activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing @@ -214,8 +214,8 @@ main = do maxHistorySizeTVar <- STM.newTVarIO @Int 1000 fitParametersTVar <- STM.newTVarIO @FitParameters ( FitParameters - { maxSubdiv = 3 - , nbSegments = 13 + { maxSubdiv = 5 + , nbSegments = 12 , dist_tol = 5e-3 , t_tol = 1e-4 , maxIters = 100 diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Document/Update.hs index c90be69..d9c4e94 100644 --- a/src/app/MetaBrush/Document/Update.hs +++ b/src/app/MetaBrush/Document/Update.hs @@ -157,7 +157,7 @@ modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } ) coerce ( updateUIAction uiElts vars ) SaveDocument Nothing -> do STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresent unique ) - pure ( pure () ) + coerce ( updateUIAction uiElts vars ) SaveDocument ( Just newFilePath ) -> do STM.modifyTVar' openDocumentsTVar ( Map.adjust @@ -167,7 +167,7 @@ modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } ) ) unique ) - pure ( pure () ) + coerce ( updateUIAction uiElts vars ) UpdateDocumentTo ( TrivialChange { newDocument } ) -> do STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDocument ) unique ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 71658d5..2ae1410 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -430,21 +430,31 @@ drawStroke :: Colours -> Bool -> Double -> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint ) -> Cairo.Render () -drawStroke cols@( Colours { brushStroke } ) debug zoom strokeData = do +drawStroke cols@( Colours {..} ) debug zoom strokeData = do Cairo.save withRGBA brushStroke Cairo.setSourceRGBA case strokeData of ( Left outline, fitPts ) -> do go outline - Cairo.fill - when debug do - ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts + case debug of + False -> Cairo.fill + True -> do + Cairo.fillPreserve + withRGBA brushCenter Cairo.setSourceRGBA + Cairo.setLineWidth ( 2 / zoom ) + Cairo.stroke + ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts ( Right ( fwd, bwd ), fitPts ) -> do go fwd go bwd - Cairo.fill - when debug do - ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts + case debug of + False -> Cairo.fill + True -> do + Cairo.fillPreserve + withRGBA brushCenter Cairo.setSourceRGBA + Cairo.setLineWidth ( 2 / zoom ) + Cairo.stroke + ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts Cairo.restore where @@ -478,7 +488,7 @@ drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render () drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do hue <- get - put ( hue + 0.01 ) + put ( hue + 0.002 ) let r, g, b :: Double ( r, g, b ) = hsl2rgb hue 0.9 0.4 @@ -493,7 +503,7 @@ drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do drawFitPoint ( Colours {..} ) zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do hue <- get - put ( hue + 0.01 ) + put ( hue + 0.002 ) let r, g, b :: Double ( r, g, b ) = hsl2rgb hue 0.9 0.4 diff --git a/src/lib/Math/Bezier/Cubic/Fit.hs b/src/lib/Math/Bezier/Cubic/Fit.hs index 7316e62..a024cac 100644 --- a/src/lib/Math/Bezier/Cubic/Fit.hs +++ b/src/lib/Math/Bezier/Cubic/Fit.hs @@ -91,10 +91,10 @@ data FitParameters data FitPoint = FitPoint - { fitPoint :: Point2D Double } + { fitPoint :: !( Point2D Double ) } | FitTangent - { fitPoint :: Point2D Double - , fitTangent :: Vector2D Double + { fitPoint :: !( Point2D Double ) + , fitTangent :: !( Vector2D Double ) } deriving stock ( Show, Generic ) deriving anyclass NFData @@ -138,9 +138,14 @@ fitSpline ( FitParameters {..} ) = go 0 | subdiv >= maxSubdiv || sq_d <= dist_tol ^ ( 2 :: Int ) -> ( Seq.singleton bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr ) - | otherwise - -> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split ) - <> go ( subdiv + 1 ) ( \ t -> curve $ t_split + t * ( 1 - t_split ) ) + | let + t_split_eff :: Double + t_split_eff + | t_split < 0.2 = 0.2 + | t_split > 0.8 = 0.8 + | otherwise = t_split + -> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split_eff ) + <> go ( subdiv + 1 ) ( \ t -> curve $ t_split_eff + t * ( 1 - t_split_eff ) ) -- | Fits a single cubic Bézier curve to the given data. -- @@ -246,11 +251,13 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr = | isNaN x || isNaN y || abs y > epsilon + || x < -epsilon + || x > 1 + epsilon -> modify' ( first ( const True ) ) $> ti | otherwise -> when ( abs ( x - ti ) > t_tol ) ( modify' ( first ( const True ) ) ) - $> x + $> ( min 1 $ max 0 x ) let sq_dist :: Double sq_dist = quadrance @( Vector2D Double ) q ( Cubic.bezier @( Vector2D Double ) bez ti' ) diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index e0c477c..60017d8 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -74,7 +74,9 @@ import qualified Math.Bezier.Quadratic as Quadratic import Math.Epsilon ( epsilon ) import Math.Module - ( Module((^-^), (*^)), Inner((^.^)), lerp ) + ( Module((^-^), (*^)), Inner((^.^)) + , lerp, squaredNorm + ) import Math.Roots ( realRoots ) import Math.Vector2D @@ -227,18 +229,33 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) brush t = lerpBrush t ( brushShape @x sp0 ) ( brushShape @x sp1 ) fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) fwd t - = ( offset ( withTangent tgt ( brush t ) ) - • lerp @( Vector2D Double ) t p0 p1 - , tgt -- wrong + = ( off t + , if squaredNorm offTgt < epsilon then tgt else offTgt ) + where + off :: Double -> Point2D Double + off x = offset ( withTangent tgt ( brush x ) ) • lerp @( Vector2D Double ) x p0 p1 + offTgt :: Vector2D Double + offTgt + | t < 0.5 + = 1e9 *^ ( off t --> off (t + 1e-9) ) + | otherwise + = 1e9 *^ ( off (t - 1e-9) --> off t ) bwd t - = ( offset ( withTangent ( (-1) *^ tgt ) ( brush s ) ) - • lerp @( Vector2D Double ) s p0 p1 - , (-1) *^ tgt -- wrong + = ( off s + , if squaredNorm offTgt < epsilon then (-1) *^ tgt else offTgt ) where s :: Double s = 1 - t + off :: Double -> Point2D Double + off x = offset ( withTangent ( (-1) *^ tgt ) ( brush x ) ) • lerp @( Vector2D Double ) x p0 p1 + offTgt :: Vector2D Double + offTgt + | s < 0.5 + = 1e9 *^ ( off s --> off (s + 1e-9) ) + | otherwise + = 1e9 *^ ( off (s - 1e-9) --> off s ) = do fwdIVar <- Par.spawnP ( fitCurve fwd ) bwdIVar <- Par.spawnP ( fitCurve bwd ) @@ -265,18 +282,33 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) ( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ) fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) fwd t - = ( offset ( withTangent ( Quadratic.bezier' bez t ) ( brush t ) ) - • Quadratic.bezier @( Vector2D Double ) bez t - , Quadratic.bezier' bez t -- wrong + = ( off t + , if squaredNorm offTgt < epsilon then Quadratic.bezier' bez t else offTgt ) + where + off :: Double -> Point2D Double + off x = offset ( withTangent ( Quadratic.bezier' bez x ) ( brush x ) ) • Quadratic.bezier @( Vector2D Double ) bez x + offTgt :: Vector2D Double + offTgt + | t < 0.5 + = 1e9 *^ ( off t --> off (t + 1e-9) ) + | otherwise + = 1e9 *^ ( off (t - 1e-9) --> off t ) bwd t - = ( offset ( withTangent ( (-1) *^ Quadratic.bezier' bez s ) ( brush s ) ) - • Quadratic.bezier @( Vector2D Double ) bez s - , (-1) *^ Quadratic.bezier' bez s -- wrong + = ( off s + , if squaredNorm offTgt < epsilon then (-1) *^ Quadratic.bezier' bez s else offTgt ) where s :: Double s = 1 - t + off :: Double -> Point2D Double + off x = offset ( withTangent ( (-1) *^ Quadratic.bezier' bez x ) ( brush x ) ) • Quadratic.bezier @( Vector2D Double ) bez x + offTgt :: Vector2D Double + offTgt + | s < 0.5 + = 1e9 *^ ( off s --> off (s + 1e-9) ) + | otherwise + = 1e9 *^ ( off (s - 1e-9) --> off s ) = do fwdIVar <- Par.spawnP ( fitCurve fwd ) bwdIVar <- Par.spawnP ( fitCurve bwd ) @@ -305,18 +337,33 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) ( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) ) fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) fwd t - = ( offset ( withTangent ( Cubic.bezier' bez t ) ( brush t ) ) - • Cubic.bezier @( Vector2D Double ) bez t - , Cubic.bezier' bez t -- wrong + = ( off t + , if squaredNorm offTgt < epsilon then Cubic.bezier' bez t else offTgt ) + where + off :: Double -> Point2D Double + off x = offset ( withTangent ( Cubic.bezier' bez x ) ( brush x ) ) • Cubic.bezier @( Vector2D Double ) bez x + offTgt :: Vector2D Double + offTgt + | t < 0.5 + = 1e9 *^ ( off t --> off (t + 1e-9) ) + | otherwise + = 1e9 *^ ( off (t - 1e-9) --> off t ) bwd t - = ( offset ( withTangent ( (-1) *^ Cubic.bezier' bez s ) ( brush s ) ) - • Cubic.bezier @( Vector2D Double ) bez s - , (-1) *^ Cubic.bezier' bez s -- wrong + = ( off s + , if squaredNorm offTgt < epsilon then (-1) *^ Cubic.bezier' bez s else offTgt ) where s :: Double s = 1 - t + off :: Double -> Point2D Double + off x = offset ( withTangent ( (-1) *^ Cubic.bezier' bez x ) ( brush x ) ) • Cubic.bezier @( Vector2D Double ) bez x + offTgt :: Vector2D Double + offTgt + | s < 0.5 + = 1e9 *^ ( off s --> off (s + 1e-9) ) + | otherwise + = 1e9 *^ ( off (s - 1e-9) --> off s ) = do fwdIVar <- Par.spawnP ( fitCurve fwd ) bwdIVar <- Par.spawnP ( fitCurve bwd )