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