prefer point drag over curve drag

This commit is contained in:
sheaf 2024-10-25 13:44:01 +02:00
parent 7b1dcefd46
commit bb237d99c8

View file

@ -34,7 +34,7 @@ import Data.Kind
( Type )
import qualified Data.List.NonEmpty as NE
import Data.Maybe
( fromMaybe, isNothing, listToMaybe )
( fromMaybe, isJust, isNothing, listToMaybe )
import Data.Ratio
import Data.Semigroup
( Arg(..), Min(..) )
@ -319,8 +319,7 @@ selectAt selMode c doc@( Document { documentContent, documentMetadata } ) =
-- | Checks whether a mouse click can initiate a drag move event.
dragMoveSelect :: 2 -> Document -> Maybe DragMoveSelect
dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
( \case { Left drag -> Just drag; Right {} -> Nothing } ) $
Except.runExcept $
( `State.execState` Nothing ) $
forStrokeHierarchy
( layerMetadata documentMetadata )
( strokeHierarchy documentContent )
@ -333,7 +332,7 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
inSelectionRange p =
squaredNorm ( c --> p :: T ( 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
dragSelect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
dragSelect :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe DragMoveSelect ) UpdateStroke
dragSelect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
when ( strokeVisible && not strokeLocked ) $
ibifoldSpline
@ -349,14 +348,25 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
-> PointData brushParams
-> Int
-> PointData brushParams -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
-> Except DragMoveSelect ()
dragSelectSplineCurve uniq start i sp0 = \case
-> State ( Maybe DragMoveSelect ) ()
dragSelectSplineCurve uniq start i sp0 crv = do
mbPrevDrag <- State.get
case mbPrevDrag of
-- If we've clicked on a point, don't try anything further.
Just ( ClickedOnPoint {} ) -> return ()
_notPointDrag -> do
-- If we've already initiated a curve drag, don't try
-- another curve drag. However, we allow overridding a curve drag
-- by a point drag.
let clickedOnCurve = isJust mbPrevDrag
case crv of
LineTo sp1 ( CurveData { curveIndex } ) -> do
-- Check endpoints first.
traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp1
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
guard ( not clickedOnCurve )
let
t :: Double
p :: 2
@ -372,7 +382,7 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
, dragCurveIndex = i
, dragCurveParameter = t
}
for_ mbCurveDrag Except.throwE
for_ mbCurveDrag $ State.put . Just
Bezier2To sp1 sp2 ( CurveData { curveIndex } ) -> do
-- Check endpoints first.
dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) sp1
@ -380,6 +390,7 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
guard ( not clickedOnCurve )
let
bez :: Quadratic.Bezier ( 2 )
bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 )
@ -395,7 +406,7 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
, dragCurveIndex = i
, dragCurveParameter = t
}
for_ mbCurveDrag Except.throwE
for_ mbCurveDrag $ State.put . Just
Bezier3To sp1 sp2 sp3 ( CurveData { curveIndex } ) -> do
-- Check endpoints first.
dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) sp1
@ -404,6 +415,7 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
guard ( not clickedOnCurve )
let
bez :: Cubic.Bezier ( 2 )
bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 )
@ -419,11 +431,15 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
, dragCurveIndex = i
, dragCurveParameter = t
}
for_ mbCurveDrag Except.throwE
for_ mbCurveDrag $ State.put . Just
dragSelectSplinePoint :: Unique -> PointIndex -> PointData brushParams -> Except DragMoveSelect ()
dragSelectSplinePoint :: Unique -> PointIndex -> PointData brushParams -> State ( Maybe DragMoveSelect ) ()
dragSelectSplinePoint u ptIx pt =
when ( inSelectionRange ( coords pt ) ) do
mbPrevDrag <- State.get
case mbPrevDrag of
Just ( ClickedOnPoint {} ) -> return ()
_ -> do
let
drag :: DragMoveSelect
drag = ClickedOnPoint
@ -431,7 +447,7 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
, dragPointWasSelected =
elemStrokePoint u ptIx ( selectedPoints documentMetadata )
}
Except.throwE drag
State.put $ Just drag
addOrRemove :: SelectionMode