adjust spline wither framework/selection deletion

src/app/MetaBrush/Document/Selection.hs

@@ -104,6 +104,7 @@ import Math.Bezier.Spline
   , Curve(..), Curves(..), PointType(..)
   , splitSplineAt
   , SplineTypeI(ssplineType)
+  , CurrentStart(..), WitherResult(..)
   , KnownSplineType
     ( lastPoint, adjustSplineType, biwitherSpline, ibitraverseSpline, bitraverseSpline )
   , fromNextPoint
@@ -584,15 +585,15 @@ deleteSelected doc =
                   pure ( Just pt )
 
               updateSplineCurve
-                :: forall clo'. SplineTypeI clo'
+                :: forall clo' hasStart. SplineTypeI clo'
                 => Unique
-                -> Maybe ( PointData brushParams )
+                -> CurrentStart hasStart ( PointData brushParams )
                 -> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams )
                 -> State UpdateInfo
-                    ( Maybe ( Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) ) )
+                    ( WitherResult hasStart clo' ( CachedStroke RealWorld ) ( PointData brushParams ) )
-              updateSplineCurve uniq mbPrevPt crv =
+              updateSplineCurve uniq mbPrevPt crv = case crv of
-                case crv of
+
-                  LineTo p1 dat ->
+                LineTo p1 _ ->
                   case ssplineType @clo' of
                     SOpen
                       | NextPoint pt <- p1
@@ -602,13 +603,16 @@ deleteSelected doc =
                           ( over ( field' @"pathPointsAffected" ) ( <> 1 )
                           . over ( field' @"strokesAffected"    ) ( Set.insert uniq )
                           )
-                            pure Nothing
+                        pure Dismiss
-                      _ ->
+                      | NextPoint pt <- p1
-                        case mbPrevPt of
+                      , NoStartFound <- mbPrevPt
-                          Nothing ->
+                      -> pure ( UseStartPoint pt Nothing ) -- no need to update "strokesAffected"
-                            pure ( Just $ LineTo p1 ( invalidateCache dat ) ) -- no need to update "strokesAffected"
+                    SClosed
-                          Just _  ->
+                      | NoStartFound <- mbPrevPt
-                            pure ( Just crv )
+                      -> pure Dismiss
+                    _ | CurrentStart _ <- mbPrevPt
+                      -> pure ( UseCurve crv )
+
                 Bezier2To cp1 p2 dat ->
                   case ssplineType @clo' of
                     SOpen
@@ -620,17 +624,33 @@ deleteSelected doc =
                           . over ( field' @"controlPointsAffected" ) ( <> 1 )
                           . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
                           )
-                          pure Nothing
+                        pure Dismiss
-                      _ ->
+                      | NextPoint pt <- p2
-                        case mbPrevPt of
+                      , NoStartFound <- mbPrevPt
-                          Just _ | Normal <- view _selection cp1
+                      -> do
-                            -> pure ( Just crv )
+                        modify'
+                          ( over ( field' @"controlPointsAffected" ) ( <> 1 )
+                          . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                          )
+                        pure ( UseStartPoint pt Nothing )
+                    SClosed
+                      | NoStartFound <- mbPrevPt
+                      -> do
+                      modify'
+                        ( over ( field' @"controlPointsAffected" ) ( <> 1 )
+                        . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                        )
+                      pure Dismiss
+                    _ | CurrentStart _ <- mbPrevPt
+                      -> case view _selection cp1 of
+                        Normal -> pure ( UseCurve crv )
                         _      -> do
                           modify'
                             ( over ( field' @"controlPointsAffected" ) ( <> 1 )
                             . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
                             )
-                            pure ( Just $ LineTo p2 ( invalidateCache dat ) )
+                          pure ( UseCurve ( LineTo p2 ( invalidateCache dat ) ) )
+                          
                 Bezier3To cp1 cp2 p3 dat ->
                   case ssplineType @clo' of
                     SOpen
@@ -642,33 +662,45 @@ deleteSelected doc =
                           . over ( field' @"controlPointsAffected" ) ( <> 2 )
                           . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
                           )
-                          pure Nothing
+                        pure Dismiss
-                      _ ->
+                      | NextPoint pt <- p3
-                        case mbPrevPt of
+                      , NoStartFound <- mbPrevPt
-                          Just _
-                            | Normal <- view _selection cp1
-                            , Normal <- view _selection cp2
-                            -> pure ( Just crv )
-                            | Normal <- view _selection cp1
                       -> do
+                        modify'
+                          ( over ( field' @"controlPointsAffected" ) ( <> 2 )
+                          . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                          )
+                        pure ( UseStartPoint pt Nothing )
+                    SClosed
+                      | NoStartFound <- mbPrevPt
+                      -> do
+                        modify'
+                          ( over ( field' @"controlPointsAffected" ) ( <> 2 )
+                          . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                          )
+                        pure Dismiss
+                    _ | CurrentStart _ <- mbPrevPt
+                      -> case ( view _selection cp1, view _selection cp2 ) of
+                        ( Normal, Normal ) ->
+                          pure ( UseCurve crv )
+                        ( Normal, _ ) -> do
                           modify'
                             ( over ( field' @"controlPointsAffected" ) ( <> 1 )
                             . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
                             )
-                              pure ( Just $ Bezier2To cp1 p3 ( invalidateCache dat ) )
+                          pure ( UseCurve $ Bezier2To cp1 p3 ( invalidateCache dat ) )
-                            | Normal <- view _selection cp2
+                        ( _, Normal ) -> do
-                            -> do
                           modify'
                             ( over ( field' @"controlPointsAffected" ) ( <> 1 )
                             . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
                             )
-                              pure ( Just $ Bezier2To cp2 p3 ( invalidateCache dat ) )
+                          pure ( UseCurve $ Bezier2To cp2 p3 ( invalidateCache dat ) )
                         _ -> do
                           modify'
                             ( over ( field' @"controlPointsAffected" ) ( <> 2 )
                             . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
                             )
-                            pure ( Just $ LineTo p3 ( invalidateCache dat ) )
+                          pure ( UseCurve $ LineTo p3 ( invalidateCache dat ) )
 
 
 -- | Perform a drag move action on a document.

src/lib/Math/Bezier/Spline.hs

@@ -56,7 +56,7 @@ import qualified Data.Sequence as Seq
 
 -- deepseq
 import Control.DeepSeq
-  ( NFData, NFData1 )
+  ( NFData(..), NFData1, deepseq )
 
 -- generic-lens
 import Data.Generics.Product.Fields
@@ -323,6 +323,38 @@ dropCurveEnd ( LineTo            _ dat ) = LineTo            BackToStart dat
 dropCurveEnd ( Bezier2To cp      _ dat ) = Bezier2To cp      BackToStart dat
 dropCurveEnd ( Bezier3To cp1 cp2 _ dat ) = Bezier3To cp1 cp2 BackToStart dat
 
+-- | A 'Maybe' value which keeps track of whether it is 'Nothing' or 'Just' with a type-level boolean.
+--
+-- This is used to enable writing 'biwitherSpline' with a dependent type signature,
+-- as the result type depends on whether a starting point has been found yet or not.
+data CurrentStart ( hasStart :: Bool ) ptData where
+  NoStartFound :: CurrentStart False ptData
+  CurrentStart :: !ptData -> CurrentStart True ptData
+
+deriving stock    instance Show ptData => Show ( CurrentStart hasStart ptData )
+deriving stock    instance Functor     ( CurrentStart hasStart )
+deriving stock    instance Foldable    ( CurrentStart hasStart )
+deriving stock    instance Traversable ( CurrentStart hasStart )
+instance NFData ptData => NFData ( CurrentStart hasStart ptData ) where
+  rnf NoStartFound             = ()
+  rnf ( CurrentStart ptData ) = rnf ptData
+
+-- | The result of a wither operation on a spline.
+--
+--   - When a starting point has been found, we can choose whether to keep the current segment or not.
+--   - When a starting point has not yet been found, we first need to determine a new start point,
+--     before we can consider keeping or dismissing the curve.
+data WitherResult ( hasStart :: Bool ) ( clo' :: SplineType ) crvData' ptData' where
+  Dismiss       :: WitherResult hasStart clo' crvData' ptData'
+  UseStartPoint :: ptData' -> Maybe ( Curve clo' crvData' ptData' ) -> WitherResult False clo' crvData' ptData'
+  UseCurve      :: Curve clo' crvData' ptData' -> WitherResult True clo' crvData' ptData'
+
+deriving stock instance ( Show ptData', Show crvData', SplineTypeI clo' ) => Show ( WitherResult hasStart clo' crvData' ptData' )
+instance ( NFData ptData', NFData crvData', SplineTypeI clo' ) => NFData ( WitherResult hasStart clo' crvData' ptData' ) where
+  rnf Dismiss = ()
+  rnf ( UseStartPoint ptData mbCurve ) = ptData `deepseq` mbCurve `deepseq` ()
+  rnf ( UseCurve curve ) = rnf curve
+
 class SplineTypeI clo => KnownSplineType clo where
 
   type TraversalCt clo ( clo' :: SplineType ) :: Constraint
@@ -348,8 +380,8 @@ class SplineTypeI clo => KnownSplineType clo where
   biwitherSpline
     :: forall f crvData ptData crvData' ptData'
     .  Monad f
-    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
+    => ( forall clo' hasStart. ( TraversalCt clo clo', SplineTypeI clo' )
-       => Maybe ptData' -> Curve clo' crvData ptData -> f ( Maybe ( Curve clo' crvData' ptData' ) )
+       => CurrentStart hasStart ptData' -> Curve clo' crvData ptData -> f ( WitherResult hasStart clo' crvData' ptData' )
        )
     -> ( ptData -> f ( Maybe ptData' ) )
     -> Spline clo crvData ptData
@@ -436,8 +468,8 @@ instance KnownSplineType Open where
   biwitherSpline
     :: forall f crvData ptData crvData' ptData'
     .  Monad f
-    => (  forall clo'. ( clo' ~ Open, SplineTypeI clo' )
+    => (  forall clo' hasStart. ( clo' ~ Open, SplineTypeI clo' )
-       => Maybe ptData' -> Curve clo' crvData ptData -> f ( Maybe ( Curve clo' crvData' ptData' ) )
+       => CurrentStart hasStart ptData' -> Curve clo' crvData ptData -> f ( WitherResult hasStart clo' crvData' ptData' )
        )
     -> ( ptData -> f ( Maybe ptData' ) )
     -> Spline Open crvData ptData
@@ -452,15 +484,21 @@ instance KnownSplineType Open where
       where
         go :: Maybe ptData' -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) )
         go _       Empty            = pure Empty
-        go mbStart ( crv :<| crvs ) = do
+        go Nothing ( crv :<| crvs ) = do
-          mbCrv' <- lift $ fc mbStart crv
+          mbCrv' <- lift $ fc NoStartFound crv
           case mbCrv' of
-            Nothing   -> go mbStart crvs
+            Dismiss -> go Nothing crvs
-            Just crv' -> do
+            UseStartPoint ptData'' mbCrv'' -> do
-              let
+              modify' ( <> Just ( First ptData'' ) )
-                endpoint = openCurveEnd crv'
+              case mbCrv'' of
-              modify' ( <> Just ( First endpoint ) )
+                Nothing    ->                   go ( Just ptData'' ) crvs
-              ( crv' :<| ) <$> go ( Just endpoint ) crvs
+                Just crv'' -> ( crv'' :<| ) <$> go ( Just ptData'' ) crvs
+        go ( Just ptData' ) ( crv :<| crvs ) = do
+          mbCrv' <- lift $ fc ( CurrentStart ptData' ) crv
+          case mbCrv' of
+            Dismiss -> go ( Just ptData' ) crvs
+            UseCurve crv'' ->
+              ( crv'' :<| ) <$> go ( Just $ openCurveEnd crv'' ) crvs
 
 instance KnownSplineType Closed where
 
@@ -502,23 +540,28 @@ instance KnownSplineType Closed where
     mbSpline' <- biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves prevCurves } )
     case mbSpline' of
       Nothing -> do
-        _ <- fc Nothing lastCurve
+        mbCrv' <- fc NoStartFound lastCurve
-        pure Nothing
+        case mbCrv' of
+          Dismiss -> pure Nothing
+          UseStartPoint ptData'' mbCrv'' ->
+            case mbCrv'' of
+              Nothing    -> pure $ Just ( Spline { splineStart = ptData'', splineCurves = NoCurves } )
+              Just crv'' -> pure $ Just ( Spline { splineStart = ptData'', splineCurves = ClosedCurves Empty crv'' } )
       Just ( Spline { splineStart = start', splineCurves = OpenCurves prevCurves' } ) ->
         case prevCurves' of
           Empty -> do
-            mbLastCurve' <- fc ( Just start' ) lastCurve
+            mbLastCurve' <- fc ( CurrentStart start' ) lastCurve
             case mbLastCurve' of
-              Nothing ->
+              Dismiss ->
                 pure ( Just $ Spline { splineStart = start', splineCurves = NoCurves } )
-              Just lastCurve' ->
+              UseCurve lastCurve' ->
                 pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves Empty lastCurve' } )
           ( prevPrevCurves' :|> prevLastCurve' ) -> do
             let
               prevPt' = openCurveEnd prevLastCurve'
-            mbLastCurve' <- fc ( Just prevPt' ) lastCurve
+            mbLastCurve' <- fc ( CurrentStart prevPt' ) lastCurve
             case mbLastCurve' of
-              Nothing ->
+              Dismiss ->
                 pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } )
-              Just lastCurve' ->
+              UseCurve lastCurve' ->
                 pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } )