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,89 +348,106 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
-> PointData brushParams
-> Int
-> PointData brushParams -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
-> Except DragMoveSelect ()
dragSelectSplineCurve uniq start i sp0 = \case
LineTo sp1 ( CurveData { curveIndex } ) -> do
-- Check endpoints first.
traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp1
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
let
t :: Double
p :: 2
( t, p ) =
closestPointOnSegment @( T ( 2 ) )
c
( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) )
guard ( inSelectionRange p )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragCurve = curveIndex
, dragCurveIndex = i
, dragCurveParameter = t
}
for_ mbCurveDrag Except.throwE
Bezier2To sp1 sp2 ( CurveData { curveIndex } ) -> do
-- Check endpoints first.
dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) sp1
traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp2
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
let
bez :: Quadratic.Bezier ( 2 )
bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 )
sq_d :: Double
t :: Double
Min ( Arg sq_d (t, _) ) =
Quadratic.closestPoint @( T ( 2 ) ) bez c
guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragCurve = curveIndex
, dragCurveIndex = i
, dragCurveParameter = t
}
for_ mbCurveDrag Except.throwE
Bezier3To sp1 sp2 sp3 ( CurveData { curveIndex } ) -> do
-- Check endpoints first.
dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) sp1
dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp2 ) ) sp2
traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp3
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
let
bez :: Cubic.Bezier ( 2 )
bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 )
sq_d :: Double
t :: Double
Min ( Arg sq_d (t, _) ) =
Cubic.closestPoint @( T ( 2 ) ) bez c
guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragCurve = curveIndex
, dragCurveIndex = i
, dragCurveParameter = t
}
for_ mbCurveDrag Except.throwE
-> 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
( t, p ) =
closestPointOnSegment @( T ( 2 ) )
c
( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) )
guard ( inSelectionRange p )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragCurve = curveIndex
, dragCurveIndex = i
, dragCurveParameter = t
}
for_ mbCurveDrag $ State.put . Just
Bezier2To sp1 sp2 ( CurveData { curveIndex } ) -> do
-- Check endpoints first.
dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) sp1
traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp2
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 )
sq_d :: Double
t :: Double
Min ( Arg sq_d (t, _) ) =
Quadratic.closestPoint @( T ( 2 ) ) bez c
guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragCurve = curveIndex
, dragCurveIndex = i
, dragCurveParameter = t
}
for_ mbCurveDrag $ State.put . Just
Bezier3To sp1 sp2 sp3 ( CurveData { curveIndex } ) -> do
-- Check endpoints first.
dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) sp1
dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp2 ) ) sp2
traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp3
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 )
sq_d :: Double
t :: Double
Min ( Arg sq_d (t, _) ) =
Cubic.closestPoint @( T ( 2 ) ) bez c
guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragCurve = curveIndex
, dragCurveIndex = i
, dragCurveParameter = t
}
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
let
drag :: DragMoveSelect
drag = ClickedOnPoint
{ dragPoint = ( u, ptIx )
, dragPointWasSelected =
elemStrokePoint u ptIx ( selectedPoints documentMetadata )
}
Except.throwE drag
mbPrevDrag <- State.get
case mbPrevDrag of
Just ( ClickedOnPoint {} ) -> return ()
_ -> do
let
drag :: DragMoveSelect
drag = ClickedOnPoint
{ dragPoint = ( u, ptIx )
, dragPointWasSelected =
elemStrokePoint u ptIx ( selectedPoints documentMetadata )
}
State.put $ Just drag
addOrRemove :: SelectionMode