fix stroke cache issues

brush-strokes/src/lib/Math/Bezier/Stroke.hs

@@ -4,7 +4,7 @@
 
 module Math.Bezier.Stroke
   ( Offset(..), Cusp(..)
-  , CachedStroke(..), discardCache, invalidateCache
+  , CachedStroke(..), discardCache, newCache, invalidateCache
   , computeStrokeOutline, joinWithBrush
   , withTangent
 
@@ -58,7 +58,7 @@ import Data.Semigroup
 import GHC.Exts
   ( newMutVar#, runRW# )
 import GHC.STRef
-  ( STRef(..), readSTRef, writeSTRef )
+  ( STRef(..), readSTRef, newSTRef, writeSTRef )
 import GHC.Generics
   ( Generic, Generic1, Generically(..) )
 import GHC.TypeNats
@@ -201,6 +201,9 @@ invalidateCache = runRW# \ s ->
       Lens.set ( typed @( CachedStroke RealWorld ) )
         ( CachedStroke $ STRef mutVar )
 
+newCache :: forall s. ST s ( CachedStroke s )
+newCache = CachedStroke <$> newSTRef Nothing
+
 coords :: forall ptData. HasType ( ℝ 2 ) ptData => ptData -> ℝ 2
 coords = Lens.view typed
 
@@ -250,7 +253,7 @@ computeStrokeOutline ::
      , Module 𝕀 (T ( 𝕀ℝ nbUsedParams ) )
 
      -- Debugging.
-     , Show ptData, Show ( ℝ nbBrushParams )
+     , Show ptData, Show crvData, Show ( ℝ nbBrushParams )
 
      )
   => RootSolvingAlgorithm
@@ -536,7 +539,7 @@ outlineFunction
      , Representable 𝕀 ( 𝕀ℝ nbUsedParams )
 
      -- Debugging.
-     , Show ptData, Show ( ℝ nbBrushParams )
+     , Show ptData, Show crvData, Show ( ℝ nbBrushParams )
      )
   => RootSolvingAlgorithm
   -> Maybe ( RootIsolationOptions N 3 )

src/app/MetaBrush/Render/Document.hs

@@ -399,7 +399,7 @@ renderStrokeSpline
   => Colours -> Mode -> RenderMode
   -> Set PointIndex -> Maybe HoverContext -> Zoom
   -> ( PointData pointData -> Compose Renders Cairo.Render () )
-  -> Spline clo CurveData ( PointData pointData )
+  -> Spline clo ( CurveData RealWorld ) ( PointData pointData )
   -> Compose Renders Cairo.Render ()
 renderStrokeSpline cols mode rdrMode selPts mbHover zoom renderSubcontent spline =
   bifoldSpline ( renderSplineCurve ( splineStart spline ) ) ( renderSplinePoint FirstPoint ) spline
@@ -416,7 +416,7 @@ renderStrokeSpline cols mode rdrMode selPts mbHover zoom renderSubcontent spline
     renderSplineCurve
       :: forall clo'
       .  SplineTypeI clo'
-      => PointData pointData -> PointData pointData -> Curve clo' CurveData ( PointData pointData ) -> Compose Renders Cairo.Render ()
+      => PointData pointData -> PointData pointData -> Curve clo' ( CurveData RealWorld ) ( PointData pointData ) -> Compose Renders Cairo.Render ()
     renderSplineCurve start p0 ( LineTo np1 ( CurveData { curveIndex } ) )
       = Compose blank
           { renderPPts = when ( rdrMode == RenderingPath ) do
@@ -491,7 +491,7 @@ renderBrushShape cols mbHoverContext zoom brushFn brushWidgetElts pt =
     *> renderBrushWidgetElements cols zoom mbHoverContext' brushWidgetElts
     *> toAll Cairo.restore
   where
-    noCurveData :: Spline Closed () ( ℝ 2 ) -> Spline Closed CurveData ( PointData () )
+    noCurveData :: Spline Closed () ( ℝ 2 ) -> Spline Closed ( CurveData RealWorld ) ( PointData () )
     noCurveData =
       bimapSpline
         ( \ _ -> bimapCurve ( \ _ -> CurveData 987654321 ( invalidateCache undefined ) ) ( \ _ p -> PointData p () ) )

src/metabrushes/MetaBrush/Action.hs

@@ -22,6 +22,8 @@ import Control.Arrow
   ( second )
 import Control.Monad
   ( guard, when )
+import Control.Monad.ST
+  ( RealWorld )
 import Data.Foldable
   ( for_, traverse_ )
 import Data.Functor
@@ -153,9 +155,9 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
         subdivideCurve
           :: T ( ℝ 2 )
           -> PointData brushParams
-          -> Curve Open CurveData ( PointData brushParams )
+          -> Curve Open ( CurveData RealWorld ) ( PointData brushParams )
           -> Writer [ ( Curve Open () (), Double ) ]
-              ( Seq ( Curve Open CurveData ( PointData brushParams ) ) )
+              ( Seq ( Curve Open ( CurveData RealWorld ) ( PointData brushParams ) ) )
         subdivideCurve offset sp0 crv =
           case crv of
             LineTo ( NextPoint sp1 ) dat -> do
@@ -193,7 +195,7 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
                   ( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
                     Writer.tell [ ( stripData crv, t ) ]
                     let
-                      bez_start, bez_end :: Curve Open CurveData ( PointData brushParams )
+                      bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
                       bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat )
                       bez_end   = Bezier2To r1 ( NextPoint sp2    ) ( invalidateCache dat )
                     return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
@@ -213,7 +215,7 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
                   ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
                     Writer.tell [ ( stripData crv, t ) ]
                     let
-                      bez_start, bez_end :: Curve Open CurveData ( PointData brushParams )
+                      bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
                       bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat )
                       bez_end   = Bezier3To r1 r2 ( NextPoint sp3    ) ( invalidateCache dat )
                     return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
@@ -257,7 +259,7 @@ selectAt selMode c doc@( Document { documentContent, documentMetadata } ) =
       return PreserveStroke
 
     selectSplineCurve :: SplineTypeI clo
-                      => Curve clo CurveData ( PointData ptData )
+                      => Curve clo ( CurveData RealWorld ) ( PointData ptData )
                       -> Except PointIndex ()
     selectSplineCurve = \case
       LineTo p1 ( CurveData { curveIndex } ) ->
@@ -311,7 +313,7 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
       => Unique
       -> PointData brushParams
       -> Int
-      -> PointData brushParams -> Curve clo' CurveData ( PointData brushParams )
+      -> PointData brushParams -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
       -> Except DragMoveSelect ()
     dragSelectSplineCurve uniq start i sp0 = \case
       LineTo sp1 ( CurveData { curveIndex } ) -> do
@@ -442,7 +444,7 @@ selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) doc@( Document { documentC
       return PreserveStroke
 
     selectRectSplineCurve :: SplineTypeI clo
-                          => Curve clo CurveData ( PointData ptData )
+                          => Curve clo ( CurveData RealWorld ) ( PointData ptData )
                           -> Writer ( Set PointIndex ) ()
     selectRectSplineCurve = \case
       LineTo p1 ( CurveData { curveIndex } ) ->
@@ -495,7 +497,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
           firstPointSel = FirstPoint `Set.member` strokeSelPts
           ( spline', ( modPts, _ ) ) =
              ( `State.runState` ( mempty, False ) ) $
-               bitraverseSpline @_ @_ @CurveData @( PointData _ )
+               bitraverseSpline @_ @_ @( CurveData RealWorld ) @( PointData _ )
                 ( \ _ -> updateSplineCurve firstPointSel strokeSelPts )
                 ( \ pt -> do { ( NextPoint pt', _ ) <- updatePoint firstPointSel strokeSelPts FirstPoint ( NextPoint pt ) ; return pt' } )
                 strokeSpline
@@ -511,15 +513,15 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
       .  SplineTypeI clo'
       => Bool
       -> Set PointIndex
-      -> Curve clo' CurveData ( PointData brushParams )
+      -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
       -> State ( Set PointIndex, Bool )
-          ( Curve clo' CurveData ( PointData brushParams ) )
+          ( Curve clo' ( CurveData RealWorld ) ( PointData brushParams ) )
     updateSplineCurve startPtSel strokeSelPts = \case
       LineTo p1 dat@( CurveData { curveIndex } ) -> do
         ( _, sel0 ) <- State.get
         ( p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint ) p1
         let
-          dat' :: CurveData
+          dat' :: ( CurveData RealWorld )
           dat'
             | sel0 || sel1
             = invalidateCache dat
@@ -532,7 +534,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
         ( NextPoint p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez2Cp )) ( NextPoint p1 )
         (           p2', sel2 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint )                          p2
         let
-          dat' :: CurveData
+          dat' :: ( CurveData RealWorld )
           dat'
             | sel0 || sel1 || sel2
             = invalidateCache dat
@@ -546,7 +548,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
         ( NextPoint p2', sel2 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez3Cp2 )) ( NextPoint p2 )
         (           p3', sel3 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint )                           p3
         let
-          dat' :: CurveData
+          dat' :: ( CurveData RealWorld )
           dat'
             | sel0 || sel1 || sel2 || sel3
             = invalidateCache dat
@@ -644,9 +646,9 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
         updateSplineCurve
           :: forall clo' hasStart. SplineTypeI clo'
           => CurrentStart hasStart ( PointData brushParams )
-          -> Curve clo' CurveData ( PointData brushParams )
+          -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
           -> Writer ( Set PointIndex )
-              ( WitherResult hasStart clo' CurveData ( PointData brushParams ) )
+              ( WitherResult hasStart clo' ( CurveData RealWorld ) ( PointData brushParams ) )
         updateSplineCurve mbPrevPt crv = case crv of
 
           LineTo p1 ( CurveData { curveIndex } ) ->
@@ -789,9 +791,9 @@ dragUpdate _  p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
 
         updateCurve
           :: PointData pointParams
-          -> Curve Open CurveData ( PointData pointParams )
+          -> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
           -> Writer ( Set PointIndex )
-           ( Curve Open CurveData ( PointData pointParams ) )
+           ( Curve Open ( CurveData RealWorld ) ( PointData pointParams ) )
         updateCurve sp0 curve = case curve of
           LineTo ( NextPoint sp1 ) dat@( CurveData { curveIndex } ) -> do
             let
@@ -852,9 +854,9 @@ dragUpdate _  p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
               pure $ cubicDragCurve dat bez3
           where
             quadraticDragCurve
-              :: CurveData
+              :: ( CurveData RealWorld )
               -> Quadratic.Bezier ( PointData pointParams )
-              -> Curve Open CurveData ( PointData pointParams )
+              -> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
             quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
               let
                 cp :: ℝ 2
@@ -862,9 +864,9 @@ dragUpdate _  p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
                   Quadratic.interpolate @( T ( ℝ 2 ) ) ( coords sp0 ) ( coords sp2 ) dragCurveParameter p
               in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat )
             cubicDragCurve
-              :: CurveData
+              :: ( CurveData RealWorld )
               -> Cubic.Bezier ( PointData pointParams )
-              -> Curve Open CurveData ( PointData pointParams )
+              -> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
             cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
               let
                 cp1, cp2 :: ℝ 2
@@ -939,9 +941,9 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
       -> ( pointParams -> Record brushFields )
       -> ( Record brushFields -> pointParams -> pointParams )
       -> Unique
-      -> PointData pointParams -> Curve clo' CurveData ( PointData pointParams )
+      -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
       -> State ( Maybe BrushWidgetActionState, Bool )
-            ( Curve clo' CurveData ( PointData pointParams ) )
+            ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) )
     updateSplineCurve _start brush toBrushParams updatePointParams uniq _sp0 curve = do
       ( mbAct, prevCurveAct ) <- State.get
       -- We can only perform a brush widget update if:

src/metabrushes/MetaBrush/Document/Serialise.hs

@@ -12,7 +12,7 @@ module MetaBrush.Document.Serialise
 import Control.Monad
   ( unless )
 import Control.Monad.ST
-  ( stToIO )
+  ( RealWorld, stToIO )
 import qualified Data.Bifunctor as Bifunctor
   ( first )
 import Data.Functor.Identity
@@ -259,7 +259,7 @@ encodeStroke = JSON.Encoder.mapLikeObj
     . mbEncodeBrush
     . JSON.Encoder.atKey' "spline"      ( encodeSpline encodePointData ) strokeSpline
 
-newCurveData :: MonadIO m => ( Integer -> m CurveData )
+newCurveData :: MonadIO m => ( Integer -> m ( CurveData RealWorld ) )
 newCurveData i = do
   noCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
   return $

src/metabrushes/MetaBrush/Draw.hs

@@ -11,6 +11,8 @@ module MetaBrush.Draw
 -- base
 import Control.Monad
   ( when )
+import Control.Monad.ST
+  ( RealWorld, ST, runST )
 import Data.Foldable
   ( for_ )
 import Data.Functor.Identity
@@ -52,7 +54,7 @@ import Control.Monad.Trans.Reader
 -- brush-strokes
 import Math.Bezier.Spline
 import Math.Bezier.Stroke
-  ( invalidateCache )
+  ( newCache )
 import Math.Linear
   ( ℝ(..) )
 
@@ -70,6 +72,9 @@ import MetaBrush.Stroke
 import MetaBrush.Unique
   ( Unique, UniqueSupply, freshUnique )
 
+import Unsafe.Coerce
+  ( unsafeCoerce )
+
 --------------------------------------------------------------------------------
 
 -- | A draw anchor, to continue drawing from one end of an existing stroke.
@@ -216,48 +221,73 @@ addToAnchor :: DrawAnchor -> Spline Open () ( PointData () ) -> Document -> Docu
 addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = oldContent } ) =
   let
     strokes' =
-      runIdentity $
+      runST $
         forStrokeHierarchy
           ( layerMetadata documentMetadata )
           ( strokeHierarchy oldContent )
-          ( \ u s _ -> Identity $ updateStroke u s )
+          ( \ u s _ -> updateStroke u s )
   in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
   where
 
-    updateStroke :: Unique -> Stroke -> UpdateStroke
+    updateStroke :: forall s. Unique -> Stroke -> ST s UpdateStroke
-    updateStroke strokeUnique stroke
+    updateStroke strokeUnique stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
       | strokeUnique == anchorStroke anchor
-      , let
+      , SOpen <- ssplineType @clo
-          updateSpline
+      , let prevSpline0 = co @RealWorld @s oldSpline
-            :: forall clo brushData
+      = do
-            .  SplineTypeI clo
+        finalSpline <-
-            => StrokeSpline clo brushData -> StrokeSpline clo brushData
+          if anchorIsAtEnd anchor
-          updateSpline prevSpline
+          then do
-            | SOpen <- ssplineType @clo
+            ( i0, prevSpline ) <-
-            = if anchorIsAtEnd anchor
+              case splineCurves prevSpline0 of
-              then
+                OpenCurves ( prevCurves :|> lastCurve ) -> do
-                let
+                  cache <- newCache
-                  i0 = case splineCurves prevSpline of
+                  -- Invalidate the point we are connecting to (stroke endpoint).
-                    OpenCurves ( _ :|> lastCurve ) ->
+                  let lastCurve' = set ( field' @"curveData" . field' @"cachedStroke" ) cache lastCurve
-                      curveIndex ( curveData lastCurve ) + 1
+                  return
-                    _ -> 0
+                    ( curveIndex ( curveData lastCurve ) + 1
-                  setBrushData :: PointData () -> PointData brushData
+
-                  setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
+                    , prevSpline0 { splineCurves =
-                  setData = bimapSpline ( \ _ -> bimapCurve ( \ s -> CurveData i0 ( invalidateCache $ undefined s ) ) ( \ _ -> setBrushData ) ) setBrushData
+                        OpenCurves ( prevCurves :|> lastCurve' ) }
-                in prevSpline <> setData newSpline
+                    )
-              else
+                OpenCurves _ ->
-                let
+                  return ( 0, prevSpline0 )
-                  i0 = case splineCurves prevSpline of
+            newSpline' <- newCaches ( \ i -> i0 + fromIntegral i ) ( brushParams ( splineEnd prevSpline ) ) newSpline
-                    OpenCurves ( firstCurve :<| _ ) ->
+            return $ prevSpline <> newSpline'
-                      curveIndex ( curveData firstCurve ) - 1
+          else do
-                    _ -> 0
+            ( i0, prevSpline ) <-
-                  setBrushData :: PointData () -> PointData brushData
+              case splineCurves prevSpline0 of
-                  setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
+                OpenCurves ( firstCurve :<| nextCurves ) -> do
-                  setData = bimapSpline ( \ _ -> bimapCurve ( \ s -> CurveData i0 ( invalidateCache $ undefined s ) ) ( \ _ -> setBrushData ) ) setBrushData
+                  cache <- newCache
-                in setData ( reverseSpline newSpline ) <> prevSpline
+                  -- Invalidate the point we are connecting to (stroke endpoint).
-            | otherwise
+                  let firstCurve' = set ( field' @"curveData" . field' @"cachedStroke" ) cache firstCurve
-            = assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
+                  return
-                prevSpline -- should never add to a closed spline
+                    ( curveIndex ( curveData firstCurve ) - 1
-      = UpdateStrokeTo $ overStrokeSpline updateSpline stroke
+                    -- Invalidate the point we are connecting to (stroke endpoint).
+                    , prevSpline0 { splineCurves = OpenCurves ( firstCurve' :<| nextCurves ) }
+                    )
+                OpenCurves _ ->
+                  return ( 0, prevSpline0 )
+            newSpline' <- newCaches ( \ i -> i0 - fromIntegral i - 1 ) ( brushParams ( splineStart prevSpline ) ) ( reverseSpline newSpline )
+            return $ newSpline' <> prevSpline
+        return $ UpdateStrokeTo ( stroke { strokeSpline = co @s @RealWorld finalSpline } )
       | otherwise
-      = PreserveStroke
+      = return PreserveStroke
+
+{-# NOINLINE co #-}
+co :: forall s t brushParams. Spline Open ( CurveData s ) ( PointData brushParams ) -> Spline Open ( CurveData t ) ( PointData brushParams )
+co = unsafeCoerce
+
+newCaches :: ( Int -> Rational )
+          -> brushParams
+          -> Spline Open () ( PointData () )
+          -> ST s ( Spline Open ( CurveData s ) ( PointData brushParams ) )
+newCaches mkCrvIx brushParams =
+  ibitraverseSpline
+    ( \ i _ -> bitraverseCurve
+                  ( \ _ -> CurveData ( mkCrvIx i ) <$> newCache )
+                  ( \ _ -> return . setBrushData )
+    )
+    ( return . setBrushData )
+  where
+    setBrushData = set ( field @"brushParams" ) brushParams

src/metabrushes/MetaBrush/Stroke.hs

@@ -99,20 +99,20 @@ data PointData params
   deriving anyclass NFData
 
 -- | Data attached to each curve in a spline.
-data CurveData =
+data CurveData s =
   CurveData
     { curveIndex   :: !Rational
-    , cachedStroke :: !( CachedStroke RealWorld )
+    , cachedStroke :: !( CachedStroke s )
     }
   deriving stock Generic
   deriving anyclass NFData
 
-instance Show CurveData where
+instance Show ( CurveData s ) where
   show ( CurveData { curveIndex } ) = show curveIndex
-instance Eq CurveData where
+instance Eq  ( CurveData s ) where
   ( CurveData { curveIndex = i1 } ) == ( CurveData { curveIndex = i2 } )
     = i1 == i2
-instance Ord CurveData where
+instance Ord  ( CurveData s ) where
   compare ( CurveData { curveIndex = i1 } ) ( CurveData { curveIndex = i2 } )
     = compare i1 i2
 
@@ -135,7 +135,7 @@ coords :: PointData brushParams -> ℝ 2
 coords = view _coords
 
 type StrokeSpline clo brushParams =
-  Spline clo CurveData ( PointData brushParams )
+  Spline clo ( CurveData RealWorld ) ( PointData brushParams )
 
 data Stroke where
   Stroke