diff --git a/brush-strokes/src/lib/Math/Bezier/Stroke.hs b/brush-strokes/src/lib/Math/Bezier/Stroke.hs index 0050081..98c3795 100644 --- a/brush-strokes/src/lib/Math/Bezier/Stroke.hs +++ b/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 ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index cade1ac..191de7d 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/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 () ) ) diff --git a/src/metabrushes/MetaBrush/Action.hs b/src/metabrushes/MetaBrush/Action.hs index 54057cd..e2f079d 100644 --- a/src/metabrushes/MetaBrush/Action.hs +++ b/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: diff --git a/src/metabrushes/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs index 67b1049..6d6b6cd 100644 --- a/src/metabrushes/MetaBrush/Document/Serialise.hs +++ b/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 $ diff --git a/src/metabrushes/MetaBrush/Draw.hs b/src/metabrushes/MetaBrush/Draw.hs index b2ab83c..1fe8e5c 100644 --- a/src/metabrushes/MetaBrush/Draw.hs +++ b/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 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 - | otherwise - = assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique ) - prevSpline -- should never add to a closed spline - = UpdateStrokeTo $ overStrokeSpline updateSpline stroke + , 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 - = 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 diff --git a/src/metabrushes/MetaBrush/Stroke.hs b/src/metabrushes/MetaBrush/Stroke.hs index e42944c..258f6fb 100644 --- a/src/metabrushes/MetaBrush/Stroke.hs +++ b/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