hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

adjust spline wither framework/selection deletion

Browse source
This commit is contained in:
sheaf 2021-05-01 19:59:29 +02:00
parent a4bf83949a
commit f8b0ec2ab1
2 changed files with 172 additions and 97 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

184
src/app/MetaBrush/Document/Selection.hs
View file

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

85
src/lib/Math/Bezier/Spline.hs
View file

@ -56,7 +56,7 @@ import qualified Data.Sequence as Seq
-- deepseq -- deepseq
import Control.DeepSeq import Control.DeepSeq
( NFData, NFData1 ) ( NFData(..), NFData1, deepseq )
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
@ -323,6 +323,38 @@ dropCurveEnd ( LineTo _ dat ) = LineTo BackToStart dat
dropCurveEnd ( Bezier2To cp _ dat ) = Bezier2To cp BackToStart dat dropCurveEnd ( Bezier2To cp _ dat ) = Bezier2To cp BackToStart dat
dropCurveEnd ( Bezier3To cp1 cp2 _ dat ) = Bezier3To cp1 cp2 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 class SplineTypeI clo => KnownSplineType clo where
type TraversalCt clo ( clo' :: SplineType ) :: Constraint type TraversalCt clo ( clo' :: SplineType ) :: Constraint
@ -348,8 +380,8 @@ class SplineTypeI clo => KnownSplineType clo where
biwitherSpline biwitherSpline
:: forall f crvData ptData crvData' ptData' :: forall f crvData ptData crvData' ptData'
. Monad f . 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' ) ) -> ( ptData -> f ( Maybe ptData' ) )
-> Spline clo crvData ptData -> Spline clo crvData ptData
@ -436,8 +468,8 @@ instance KnownSplineType Open where
biwitherSpline biwitherSpline
:: forall f crvData ptData crvData' ptData' :: forall f crvData ptData crvData' ptData'
. Monad f . 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' ) ) -> ( ptData -> f ( Maybe ptData' ) )
-> Spline Open crvData ptData -> Spline Open crvData ptData
@ -452,15 +484,21 @@ instance KnownSplineType Open where
where where
go :: Maybe ptData' -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) ) go :: Maybe ptData' -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) )
go _ Empty = pure Empty 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 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 instance KnownSplineType Closed where
@ -502,23 +540,28 @@ instance KnownSplineType Closed where
mbSpline' <- biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves prevCurves } ) mbSpline' <- biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves prevCurves } )
case mbSpline' of case mbSpline' of
Nothing -> do 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' } ) -> Just ( Spline { splineStart = start', splineCurves = OpenCurves prevCurves' } ) ->
case prevCurves' of case prevCurves' of
Empty -> do Empty -> do
mbLastCurve' <- fc ( Just start' ) lastCurve mbLastCurve' <- fc ( CurrentStart start' ) lastCurve
case mbLastCurve' of case mbLastCurve' of
Nothing -> Dismiss ->
pure ( Just $ Spline { splineStart = start', splineCurves = NoCurves } ) pure ( Just $ Spline { splineStart = start', splineCurves = NoCurves } )
Just lastCurve' -> UseCurve lastCurve' ->
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves Empty lastCurve' } ) pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves Empty lastCurve' } )
( prevPrevCurves' :|> prevLastCurve' ) -> do ( prevPrevCurves' :|> prevLastCurve' ) -> do
let let
prevPt' = openCurveEnd prevLastCurve' prevPt' = openCurveEnd prevLastCurve'
mbLastCurve' <- fc ( Just prevPt' ) lastCurve mbLastCurve' <- fc ( CurrentStart prevPt' ) lastCurve
case mbLastCurve' of case mbLastCurve' of
Nothing -> Dismiss ->
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } ) pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } )
Just lastCurve' -> UseCurve lastCurve' ->
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } ) pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } )