mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
adjust spline wither framework/selection deletion
This commit is contained in:
sheaf
parent
a4bf83949a
commit
f8b0ec2ab1
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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' } )
|
||||
|
|
|
|||
Loading…
Reference in a new issue