diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index a71c1cb..3752188 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -1034,50 +1034,53 @@ instance HandleAction MouseClick where _ -> do STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) pure Don'tModifyDoc - Pen -> do - -- Pen tool in path mode: start or continue a drawing operation. - mbPartialPath <- STM.readTVar partialPathTVar - mbSelBrush <- STM.readTVar selectedBrushTVar - STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) - case mbPartialPath of - -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). - Nothing -> do - ( newDocument, drawAnchor ) <- - getOrCreateDrawAnchor uniqueSupply mbSelBrush pos doc - let firstPos = anchorPos drawAnchor newDocument - STM.writeTVar partialPathTVar - ( Just $ PartialPath - { partialPathAnchor = drawAnchor - , partialControlPoint = Nothing - , firstPoint = Just firstPos - } - ) - if anchorIsNew drawAnchor - then do - let - diff :: Diff - diff = HistoryDiff $ HierarchyDiff - $ NewLayer - { newUnique = anchorStroke drawAnchor - , newPosition = WithinParent Root 0 - -- TODO: add the stroke above the selected layer - -- or something of the sort. - , newIsGroup = False - } - pure ( UpdateDoc $ UpdateDocumentTo newDocument diff ) - else + Pen -> case mode of + BrushMode -> pure Don'tModifyDoc + MetaMode -> pure Don'tModifyDoc + PathMode -> do + -- Pen tool in path mode: start or continue a drawing operation. + mbPartialPath <- STM.readTVar partialPathTVar + mbSelBrush <- STM.readTVar selectedBrushTVar + STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) + case mbPartialPath of + -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). + Nothing -> do + ( newDocument, drawAnchor ) <- + getOrCreateDrawAnchor uniqueSupply mbSelBrush pos doc + let firstPos = anchorPos drawAnchor newDocument + STM.writeTVar partialPathTVar + ( Just $ PartialPath + { partialPathAnchor = drawAnchor + , partialControlPoint = Nothing + , firstPoint = Just firstPos + } + ) + if anchorIsNew drawAnchor + then do + let + diff :: Diff + diff = HistoryDiff $ HierarchyDiff + $ NewLayer + { newUnique = anchorStroke drawAnchor + , newPosition = WithinParent Root 0 + -- TODO: add the stroke above the selected layer + -- or something of the sort. + , newIsGroup = False + } + pure ( UpdateDoc $ UpdateDocumentTo newDocument diff ) + else + pure Don'tModifyDoc + -- Path already started: indicate that we are continuing a path. + 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 - -- Path already started: indicate that we are continuing a path. - 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 DoubleClick -> do tool <- STM.readTVar toolTVar diff --git a/src/metabrushes/MetaBrush/Action.hs b/src/metabrushes/MetaBrush/Action.hs index 5f71741..dfb6d0c 100644 --- a/src/metabrushes/MetaBrush/Action.hs +++ b/src/metabrushes/MetaBrush/Action.hs @@ -119,10 +119,6 @@ import MetaBrush.Stroke import MetaBrush.Unique ( Unique ) - -import Debug.Utils - ( trace ) - -------------------------------------------------------------------------------- -- Subdivision.