diff --git a/src/metabrushes/MetaBrush/Action.hs b/src/metabrushes/MetaBrush/Action.hs index dfb6d0c..8db57bf 100644 --- a/src/metabrushes/MetaBrush/Action.hs +++ b/src/metabrushes/MetaBrush/Action.hs @@ -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