fix stroke cache issues

This commit is contained in:
sheaf 2024-09-28 13:07:56 +02:00
parent 3886dca483
commit f7a4b02e90
6 changed files with 111 additions and 76 deletions

View file

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

View file

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

View file

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

View file

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

View file

@ -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 strokeUnique stroke
updateStroke :: forall s. Unique -> Stroke -> ST s UpdateStroke
updateStroke strokeUnique stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
| strokeUnique == anchorStroke anchor
, let
updateSpline
:: forall clo brushData
. SplineTypeI clo
=> StrokeSpline clo brushData -> StrokeSpline clo brushData
updateSpline prevSpline
| SOpen <- ssplineType @clo
= if anchorIsAtEnd anchor
then
let
i0 = case splineCurves prevSpline of
OpenCurves ( _ :|> lastCurve ) ->
curveIndex ( curveData lastCurve ) + 1
_ -> 0
setBrushData :: PointData () -> PointData brushData
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
setData = bimapSpline ( \ _ -> bimapCurve ( \ s -> CurveData i0 ( invalidateCache $ undefined s ) ) ( \ _ -> setBrushData ) ) setBrushData
in prevSpline <> setData newSpline
else
let
i0 = case splineCurves prevSpline of
OpenCurves ( firstCurve :<| _ ) ->
curveIndex ( curveData firstCurve ) - 1
_ -> 0
setBrushData :: PointData () -> PointData brushData
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
setData = bimapSpline ( \ _ -> bimapCurve ( \ s -> CurveData i0 ( invalidateCache $ undefined s ) ) ( \ _ -> setBrushData ) ) setBrushData
in setData ( reverseSpline newSpline ) <> prevSpline
, SOpen <- ssplineType @clo
, let prevSpline0 = co @RealWorld @s oldSpline
= do
finalSpline <-
if anchorIsAtEnd anchor
then do
( i0, prevSpline ) <-
case splineCurves prevSpline0 of
OpenCurves ( prevCurves :|> lastCurve ) -> do
cache <- newCache
-- Invalidate the point we are connecting to (stroke endpoint).
let lastCurve' = set ( field' @"curveData" . field' @"cachedStroke" ) cache lastCurve
return
( curveIndex ( curveData lastCurve ) + 1
, prevSpline0 { splineCurves =
OpenCurves ( prevCurves :|> lastCurve' ) }
)
OpenCurves _ ->
return ( 0, prevSpline0 )
newSpline' <- newCaches ( \ i -> i0 + fromIntegral i ) ( brushParams ( splineEnd prevSpline ) ) newSpline
return $ prevSpline <> newSpline'
else do
( i0, prevSpline ) <-
case splineCurves prevSpline0 of
OpenCurves ( firstCurve :<| nextCurves ) -> do
cache <- newCache
-- Invalidate the point we are connecting to (stroke endpoint).
let firstCurve' = set ( field' @"curveData" . field' @"cachedStroke" ) cache firstCurve
return
( curveIndex ( curveData firstCurve ) - 1
-- 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
= assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
prevSpline -- should never add to a closed spline
= UpdateStrokeTo $ overStrokeSpline updateSpline stroke
| 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

View file

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