allow selection in brush mode

This commit is contained in:
sheaf 2024-10-19 11:50:25 +02:00
parent 53243621b5
commit 0223c92a85

View file

@ -954,10 +954,38 @@ instance HandleAction MouseClick where
SingleClick -> do
modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar
case mode of
PathMode ->
case tool of
Selection ->
case tool of
Selection -> do
-- First, check if we can initiate a brush parameter
-- modification action through a brush widget.
mbBrushWidgetActionUpdDoc <-
case mode of
MetaMode -> return Nothing
PathMode -> return Nothing
BrushMode -> do
-- Brush mode: modify brush parameters through brush widget.
mbAction <- STM.readTVar mouseHoldTVar
let mbPrevWidgetAction = case mbAction of
Just ( BrushWidgetAction { brushWidgetAction } )
-> Just brushWidgetAction
_ -> Nothing
case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
Just ( newDocument, actionState@( BrushWidgetActionState { brushWidgetAction = act } ) ) -> do
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
let diff = HistoryDiff $ ContentDiff
$ UpdateBrushParameters
{ updateBrushStroke = brushWidgetStrokeUnique actionState
, updateBrushPoint = brushWidgetPointIndex actionState
, updateBrushAction = act
}
return ( Just $ UpdateDoc $ UpdateDocumentTo newDocument diff )
Nothing ->
return Nothing
-- If we are doing a brush widget action, don't attempt anything else.
-- Otherwise, move on to selection.
case mbBrushWidgetActionUpdDoc of
Just updDoc -> return updDoc
Nothing ->
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
@ -967,7 +995,8 @@ instance HandleAction MouseClick where
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just dragMove <- dragMoveSelect pos doc
| PathMode <- mode -- Only allow dragging points in PathMode
, Just dragMove <- dragMoveSelect pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
case dragMove of
@ -988,72 +1017,51 @@ 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
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
BrushMode -> do
-- Brush mode: modify brush parameters through brush widget.
mbAction <- STM.readTVar mouseHoldTVar
let mbPrevWidgetAction = case mbAction of
Just ( BrushWidgetAction { brushWidgetAction } )
-> Just brushWidgetAction
_ -> Nothing
case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
Just ( newDocument, actionState@( BrushWidgetActionState { brushWidgetAction = act } ) ) -> do
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
let diff = HistoryDiff $ ContentDiff
$ UpdateBrushParameters
{ updateBrushStroke = brushWidgetStrokeUnique actionState
, updateBrushPoint = brushWidgetPointIndex actionState
, updateBrushAction = act
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 )
_ ->
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
_ -> pure Don'tModifyDoc
DoubleClick -> do
tool <- STM.readTVar toolTVar
modifs <- STM.readTVar modifiersTVar