diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 775f02e..2fa8970 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/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,91 +585,122 @@ 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 ) ) ) - updateSplineCurve uniq mbPrevPt crv = - case crv of - LineTo p1 dat -> - case ssplineType @clo' of - SOpen - | NextPoint pt <- p1 - , Selected <- view _selection pt - -> do - modify' - ( over ( field' @"pathPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure Nothing - _ -> - case mbPrevPt of - Nothing -> - pure ( Just $ LineTo p1 ( invalidateCache dat ) ) -- no need to update "strokesAffected" - Just _ -> - pure ( Just crv ) - Bezier2To cp1 p2 dat -> - case ssplineType @clo' of - SOpen - | NextPoint pt <- p2 - , Selected <- view _selection pt - -> do + ( WitherResult hasStart clo' ( CachedStroke RealWorld ) ( PointData brushParams ) ) + updateSplineCurve uniq mbPrevPt crv = case crv of + + LineTo p1 _ -> + case ssplineType @clo' of + SOpen + | NextPoint pt <- p1 + , Selected <- view _selection pt + -> do + modify' + ( over ( field' @"pathPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure Dismiss + | NextPoint pt <- p1 + , NoStartFound <- mbPrevPt + -> pure ( UseStartPoint pt Nothing ) -- no need to update "strokesAffected" + SClosed + | NoStartFound <- mbPrevPt + -> pure Dismiss + _ | CurrentStart _ <- mbPrevPt + -> pure ( UseCurve crv ) + + Bezier2To cp1 p2 dat -> + case ssplineType @clo' of + SOpen + | NextPoint pt <- p2 + , Selected <- view _selection pt + -> do + modify' + ( over ( field' @"pathPointsAffected" ) ( <> 1 ) + . over ( field' @"controlPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure Dismiss + | NextPoint pt <- p2 + , NoStartFound <- mbPrevPt + -> do + 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' @"pathPointsAffected" ) ( <> 1 ) - . over ( field' @"controlPointsAffected" ) ( <> 1 ) + ( over ( field' @"controlPointsAffected" ) ( <> 1 ) . over ( field' @"strokesAffected" ) ( Set.insert uniq ) ) - pure Nothing - _ -> - case mbPrevPt of - Just _ | Normal <- view _selection cp1 - -> pure ( Just crv ) - _ -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( Just $ LineTo p2 ( invalidateCache dat ) ) - Bezier3To cp1 cp2 p3 dat -> - case ssplineType @clo' of - SOpen - | NextPoint pt <- p3 - , Selected <- view _selection pt - -> do + pure ( UseCurve ( LineTo p2 ( invalidateCache dat ) ) ) + + Bezier3To cp1 cp2 p3 dat -> + case ssplineType @clo' of + SOpen + | NextPoint pt <- p3 + , Selected <- view _selection pt + -> do + modify' + ( over ( field' @"pathPointsAffected" ) ( <> 1 ) + . over ( field' @"controlPointsAffected" ) ( <> 2 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure Dismiss + | NextPoint pt <- p3 + , NoStartFound <- mbPrevPt + -> 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' @"pathPointsAffected" ) ( <> 1 ) - . over ( field' @"controlPointsAffected" ) ( <> 2 ) + ( over ( field' @"controlPointsAffected" ) ( <> 1 ) . over ( field' @"strokesAffected" ) ( Set.insert uniq ) ) - pure Nothing - _ -> - case mbPrevPt of - Just _ - | Normal <- view _selection cp1 - , Normal <- view _selection cp2 - -> pure ( Just crv ) - | Normal <- view _selection cp1 - -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( Just $ Bezier2To cp1 p3 ( invalidateCache dat ) ) - | Normal <- view _selection cp2 - -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( Just $ 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 $ Bezier2To cp1 p3 ( invalidateCache dat ) ) + ( _, Normal ) -> do + modify' + ( over ( field' @"controlPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure ( UseCurve $ Bezier2To cp2 p3 ( invalidateCache dat ) ) + _ -> do + modify' + ( over ( field' @"controlPointsAffected" ) ( <> 2 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure ( UseCurve $ LineTo p3 ( invalidateCache dat ) ) -- | Perform a drag move action on a document. diff --git a/src/lib/Math/Bezier/Spline.hs b/src/lib/Math/Bezier/Spline.hs index 8aee20c..516733b 100644 --- a/src/lib/Math/Bezier/Spline.hs +++ b/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' ) - => Maybe ptData' -> Curve clo' crvData ptData -> f ( Maybe ( Curve clo' crvData' ptData' ) ) + => ( forall clo' hasStart. ( TraversalCt clo clo', SplineTypeI clo' ) + => 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' ) - => Maybe ptData' -> Curve clo' crvData ptData -> f ( Maybe ( Curve clo' crvData' ptData' ) ) + => ( forall clo' hasStart. ( clo' ~ Open, SplineTypeI clo' ) + => 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 - mbCrv' <- lift $ fc mbStart crv + go Nothing ( crv :<| crvs ) = do + mbCrv' <- lift $ fc NoStartFound crv case mbCrv' of - Nothing -> go mbStart crvs - Just crv' -> do - let - endpoint = openCurveEnd crv' - modify' ( <> Just ( First endpoint ) ) - ( crv' :<| ) <$> go ( Just endpoint ) crvs + Dismiss -> go Nothing crvs + UseStartPoint ptData'' mbCrv'' -> do + modify' ( <> Just ( First ptData'' ) ) + case mbCrv'' of + Nothing -> go ( Just ptData'' ) 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 - pure Nothing + mbCrv' <- fc NoStartFound lastCurve + 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' } )