diff --git a/brush-strokes/src/lib/Math/Bezier/Spline.hs b/brush-strokes/src/lib/Math/Bezier/Spline.hs index 331aa61..3715e43 100644 --- a/brush-strokes/src/lib/Math/Bezier/Spline.hs +++ b/brush-strokes/src/lib/Math/Bezier/Spline.hs @@ -5,6 +5,8 @@ module Math.Bezier.Spline where -- base +import Control.Monad + ( guard ) import Data.Bifoldable ( Bifoldable(..) ) import Data.Bifunctor @@ -290,11 +292,19 @@ splineEnd ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case cu Empty -> splineStart _ :|> lastCurve -> openCurveEnd lastCurve -catMaybesSpline :: crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData -catMaybesSpline dat p0 Nothing Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( LineTo ( NextPoint p3 ) dat ) } -catMaybesSpline dat p0 ( Just p1 ) Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p1 ( NextPoint p3 ) dat ) } -catMaybesSpline dat p0 Nothing ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p2 ( NextPoint p3 ) dat ) } -catMaybesSpline dat p0 ( Just p1 ) ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) } +catMaybesSpline :: ( ptData -> ptData -> Bool ) -> crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData +catMaybesSpline eq dat p0 mbCp1 mbCp2 p3 = + let + mbCp1' = do { cp1 <- mbCp1; guard ( not $ eq cp1 p0 ); return cp1 } + mbCp2' = do { cp2 <- mbCp2; guard ( not $ eq cp2 p3 ); return cp2 } + mbCp1'' = do { cp1 <- mbCp1'; guard ( case mbCp2' of { Just {} -> True ; Nothing -> not ( eq cp1 p3 ) } ); return cp1 } + mbCp2'' = do { cp2 <- mbCp2'; guard ( case mbCp1' of { Just {} -> True ; Nothing -> not ( eq cp2 p0 ) } ); return cp2 } + in go mbCp1'' mbCp2'' + where + go Nothing Nothing = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( LineTo ( NextPoint p3 ) dat ) } + go ( Just p1 ) Nothing = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p1 ( NextPoint p3 ) dat ) } + go Nothing ( Just p2 ) = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p2 ( NextPoint p3 ) dat ) } + go ( Just p1 ) ( Just p2 ) = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) } -- | Connect two open curves. -- diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index 741a00c..cac9fc1 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -7,13 +7,15 @@ module MetaBrush.Application.Action where import Control.Arrow ( second ) import Control.Monad - ( guard, when, unless, void ) + ( when, unless, void ) import Data.Foldable ( for_ ) +import Data.Function + ( on ) import Data.List ( uncons ) import Data.Maybe - ( catMaybes, fromMaybe ) + ( catMaybes, fromMaybe, isNothing ) import Data.String ( IsString ) import Data.Traversable @@ -943,11 +945,12 @@ instance HandleAction MouseClick where Nothing -> do ( newDocument, drawAnchor ) <- getOrCreateDrawAnchor uniqueSupply pos doc + let firstPos = anchorPos drawAnchor doc STM.writeTVar partialPathTVar ( Just $ PartialPath { partialPathAnchor = drawAnchor , partialControlPoint = Nothing - , firstPoint = True + , firstPoint = Just firstPos } ) if anchorIsNew drawAnchor @@ -966,8 +969,15 @@ instance HandleAction MouseClick where else pure Don'tModifyDoc -- Path already started: indicate that we are continuing a path. - Just pp -> do - STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) + Just pp@( PartialPath { firstPoint = mbFirst } ) -> do + let stillAtFirstPoint = case mbFirst of + Nothing -> Nothing + Just p -> + if inPointClickRange zoom p pos + then Just p + else Nothing + STM.writeTVar partialPathTVar + ( Just $ pp { firstPoint = stillAtFirstPoint } ) pure Don'tModifyDoc BrushMode -> do -- Brush mode: modify brush parameters through brush widget. @@ -1177,22 +1187,20 @@ instance HandleAction MouseRelease where | otherwise = ( pos, Nothing, Nothing ) ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc - if not firstPoint && anchorsAreComplementary anchor otherAnchor + if isNothing firstPoint && anchorsAreComplementary anchor otherAnchor -- Close path. then do STM.writeTVar partialPathTVar Nothing let newSegment :: Spline Open () ( PointData () ) - newSegment = catMaybesSpline () + newSegment = catMaybesSpline ( inPointClickRange zoom `on` coords ) () ( PointData p1 () ) ( do cp <- mbCp2 - guard ( cp /= p1 ) pure ( PointData cp () ) ) ( do cp <- mbControlPoint - guard ( cp /= anchorPos otherAnchor doc ) pure ( PointData cp () ) ) ( PointData ( anchorPos otherAnchor doc ) () ) @@ -1202,37 +1210,35 @@ instance HandleAction MouseRelease where $ CloseStroke { closedStroke = anchorStroke anchor } pure ( UpdateDoc $ UpdateDocumentTo newDocument diff ) else - if firstPoint + case firstPoint of -- Continue current partial path. - then do - STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint False ) - pure Don'tModifyDoc + Just {} -> do + STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint firstPoint ) + pure Don'tModifyDoc -- Finish current partial path. - else do - STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint False ) - let - newSegment :: Spline Open () ( PointData () ) - newSegment = catMaybesSpline () - ( PointData p1 () ) - ( do - cp <- mbCp2 - guard ( cp /= p1 ) - pure ( PointData cp () ) - ) - ( do - cp <- mbControlPoint - guard ( cp /= pathPoint ) - pure ( PointData cp () ) - ) - ( PointData pathPoint () ) - newDocument :: Document - newDocument = addToAnchor anchor newSegment doc - diff = HistoryDiff $ ContentDiff - $ ContinueStroke - { continuedStroke = anchorStroke anchor - , newSegment - } - pure ( UpdateDoc $ UpdateDocumentTo newDocument diff ) + Nothing -> do + STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint Nothing ) + let + newSegment :: Spline Open () ( PointData () ) + newSegment = catMaybesSpline ( inPointClickRange zoom `on` coords ) () + ( PointData p1 () ) + ( do + cp <- mbCp2 + pure ( PointData cp () ) + ) + ( do + cp <- mbControlPoint + pure ( PointData cp () ) + ) + ( PointData pathPoint () ) + newDocument :: Document + newDocument = addToAnchor anchor newSegment doc + diff = HistoryDiff $ ContentDiff + $ ContinueStroke + { continuedStroke = anchorStroke anchor + , newSegment + } + pure ( UpdateDoc $ UpdateDocumentTo newDocument diff ) BrushMode -> do STM.writeTVar mouseHoldTVar Nothing pure Don'tModifyDoc diff --git a/src/app/MetaBrush/Application/Context.hs b/src/app/MetaBrush/Application/Context.hs index 9dd0da3..ab6a829 100644 --- a/src/app/MetaBrush/Application/Context.hs +++ b/src/app/MetaBrush/Application/Context.hs @@ -185,7 +185,7 @@ data PartialPath = PartialPath { partialPathAnchor :: !DrawAnchor , partialControlPoint :: !( Maybe ( ℝ 2 ) ) - , firstPoint :: !Bool + , firstPoint :: !( Maybe ( ℝ 2 ) ) } deriving stock Show diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 59114c7..cade1ac 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -8,7 +8,7 @@ module MetaBrush.Render.Document -- base import Control.Monad - ( guard, when, unless ) + ( when, unless ) import Control.Monad.ST ( RealWorld, ST ) import Data.Coerce @@ -17,6 +17,8 @@ import Data.Fixed ( mod' ) import Data.Foldable ( for_, sequenceA_, traverse_ ) +import Data.Function + ( on ) import Data.Functor.Compose ( Compose(..) ) import Data.Int @@ -100,7 +102,9 @@ import MetaBrush.Document.Serialise ( ) -- 'Serialisable' instances import MetaBrush.Draw import MetaBrush.Hover - ( mkAABB, HoverContext(..), Hoverable(..) ) + ( HoverContext(..), Hoverable(..) + , inPointClickRange, mkAABB + ) import MetaBrush.Records import MetaBrush.Stroke import MetaBrush.UI.ToolBar @@ -183,24 +187,26 @@ getDocumentRender mbControlPoint :: Maybe ( ℝ 2 ) ( mbFinalPoint, mbControlPoint ) | Just ( DrawHold holdPos ) <- mbHoldEvent - = if firstPoint - then ( mbMousePos , Just holdPos ) - else ( Just holdPos, ( \ cp -> ( cp --> holdPos :: T ( ℝ 2 ) ) • holdPos ) <$> mbMousePos ) + = case firstPoint of + Just {} -> ( mbMousePos , Nothing ) + Nothing -> ( Just holdPos + , do { cp <- mbMousePos + ; return $ ( cp --> holdPos :: T ( ℝ 2 ) ) • holdPos + } + ) | otherwise = ( mbMousePos, Nothing ) , Just finalPoint <- mbFinalPoint , let previewSpline :: Spline Open () ( PointData () ) - previewSpline = catMaybesSpline () + previewSpline = catMaybesSpline ( inPointClickRange zoom `on` coords ) () ( PointData p0 () ) ( do cp <- cp0 - guard ( cp /= p0 ) pure ( PointData cp () ) ) ( do cp <- mbControlPoint - guard ( cp /= finalPoint ) pure ( PointData cp () ) ) ( PointData finalPoint () )