mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
prefer point drag over curve drag
This commit is contained in:
sheaf
parent
7b1dcefd46
commit
bb237d99c8
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue