improve offset tangent calculation

app/Main.hs

@@ -214,8 +214,8 @@ main = do
   maxHistorySizeTVar <- STM.newTVarIO @Int                                         1000
   fitParametersTVar  <- STM.newTVarIO @FitParameters
     ( FitParameters
-      { maxSubdiv  = 3
+      { maxSubdiv  = 5
-      , nbSegments = 13
+      , nbSegments = 12
       , dist_tol   = 5e-3
       , t_tol      = 1e-4
       , maxIters   = 100

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 )

src/app/MetaBrush/Render/Document.hs

@@ -430,20 +430,30 @@ 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
+      case debug of
-      when debug do
+        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
+      case debug of
-      when debug do
+        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
 
@@ -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

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
+    { fitPoint   :: !( Point2D  Double )
-    , fitTangent :: Vector2D 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
+            | let
-            -> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split )
+                t_split_eff :: Double
-            <> go ( subdiv + 1 ) ( \ t -> curve $ t_split + t * ( 1 - t_split ) )
+                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' )

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 ) )
+            = ( off t
-              • lerp @( Vector2D Double ) t p0 p1
+              , if squaredNorm offTgt < epsilon then tgt else offTgt
-              , tgt -- wrong
               )
+            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 ) )
+            = ( off s
-              • lerp @( Vector2D Double ) s p0 p1
+              , if squaredNorm offTgt < epsilon then (-1) *^ tgt else offTgt
-              , (-1) *^ tgt -- wrong
               )
             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 ) )
+            = ( off t
-              • Quadratic.bezier @( Vector2D Double ) bez t
+              , if squaredNorm offTgt < epsilon then Quadratic.bezier' bez t else offTgt
-              , Quadratic.bezier' bez t -- wrong
               )
+            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 ) )
+            = ( off s
-              • Quadratic.bezier @( Vector2D Double ) bez s
+              , if squaredNorm offTgt < epsilon then (-1) *^ Quadratic.bezier' bez s else offTgt
-              , (-1) *^ Quadratic.bezier' bez s -- wrong
               )
             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 ) )
+            = ( off t
-              • Cubic.bezier @( Vector2D Double ) bez t
+              , if squaredNorm offTgt < epsilon then Cubic.bezier' bez t else offTgt
-              , Cubic.bezier' bez t -- wrong
               )
+            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 ) )
+            = ( off s
-              • Cubic.bezier @( Vector2D Double ) bez s
+              , if squaredNorm offTgt < epsilon then (-1) *^ Cubic.bezier' bez s else offTgt
-              , (-1) *^ Cubic.bezier' bez s -- wrong
               )
             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 )