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

prefer point drag over curve drag

Browse source
This commit is contained in:
sheaf 2024-10-25 13:44:01 +02:00
parent 7b1dcefd46
commit bb237d99c8
1 changed files with 100 additions and 84 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

184
src/metabrushes/MetaBrush/Action.hs
View file

@ -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