hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

allow selection in brush mode

Browse source
This commit is contained in:
sheaf 2024-10-19 11:50:25 +02:00
parent 53243621b5
commit 0223c92a85
1 changed files with 76 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

144
src/app/MetaBrush/Application/Action.hs
View file

@ -954,10 +954,38 @@ instance HandleAction MouseClick where
SingleClick -> do SingleClick -> do
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
case mode of case tool of
PathMode -> Selection -> do
case tool of -- First, check if we can initiate a brush parameter
Selection -> -- 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: -- Selection mode mouse hold:
-- --
-- - If holding shift or alt, mouse hold initiates a rectangular selection. -- - If holding shift or alt, mouse hold initiates a rectangular selection.
@ -967,7 +995,8 @@ instance HandleAction MouseClick where
case selectionMode modifiers of case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something. -- Drag move: not holding shift or alt, click has selected something.
New New
| Just dragMove <- dragMoveSelect pos doc | PathMode <- mode -- Only allow dragging points in PathMode
, Just dragMove <- dragMoveSelect pos doc
-> do -> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove ) STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
case dragMove of case dragMove of
@ -988,72 +1017,51 @@ instance HandleAction MouseClick where
_ -> do _ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc pure Don'tModifyDoc
Pen -> do Pen -> do
-- Pen tool in path mode: start or continue a drawing operation. -- Pen tool in path mode: start or continue a drawing operation.
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
mbSelBrush <- STM.readTVar selectedBrushTVar mbSelBrush <- STM.readTVar selectedBrushTVar
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
case mbPartialPath of case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do Nothing -> do
( newDocument, drawAnchor ) <- ( newDocument, drawAnchor ) <-
getOrCreateDrawAnchor uniqueSupply mbSelBrush pos doc getOrCreateDrawAnchor uniqueSupply mbSelBrush pos doc
let firstPos = anchorPos drawAnchor newDocument let firstPos = anchorPos drawAnchor newDocument
STM.writeTVar partialPathTVar STM.writeTVar partialPathTVar
( Just $ PartialPath ( Just $ PartialPath
{ partialPathAnchor = drawAnchor { partialPathAnchor = drawAnchor
, partialControlPoint = Nothing , partialControlPoint = Nothing
, firstPoint = Just firstPos , firstPoint = Just firstPos
} }
) )
if anchorIsNew drawAnchor if anchorIsNew drawAnchor
then do then do
let let
diff :: Diff diff :: Diff
diff = HistoryDiff $ HierarchyDiff diff = HistoryDiff $ HierarchyDiff
$ NewLayer $ NewLayer
{ newUnique = anchorStroke drawAnchor { newUnique = anchorStroke drawAnchor
, newPosition = WithinParent Root 0 , newPosition = WithinParent Root 0
-- TODO: add the stroke above the selected layer -- TODO: add the stroke above the selected layer
-- or something of the sort. -- or something of the sort.
, newIsGroup = False , 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
} }
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
_ -> pure Don'tModifyDoc
DoubleClick -> do DoubleClick -> do
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
modifs <- STM.readTVar modifiersTVar modifs <- STM.readTVar modifiersTVar