hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-27 09:24:08 +00:00
Code Issues Actions Projects Releases Wiki Activity

implement selection & drag-move in brush mode

Browse source
This commit is contained in:
sheaf 2020-08-29 22:19:51 +02:00
parent dfa446254a
commit 9e73da9fff
3 changed files with 136 additions and 78 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

170
src/app/MetaBrush/Document/Selection.hs
View file

@ -1,11 +1,13 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Selection module MetaBrush.Document.Selection
( SelectionMode(..), selectionMode ( SelectionMode(..), selectionMode
@ -37,6 +39,8 @@ import Data.Sequence
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
( field' ) ( field' )
import Data.Generics.Product.Typed
( HasType )
-- lens -- lens
import Control.Lens import Control.Lens
@ -63,13 +67,14 @@ import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), Stroke(..) ( Document(..), Stroke(..)
, PointData(..), FocusState(..) , FocusState(..), _selection
, _selection
) )
import MetaBrush.Event.KeyCodes import MetaBrush.Event.KeyCodes
( pattern Alt_L , pattern Alt_R ( pattern Alt_L , pattern Alt_R
, pattern Shift_L, pattern Shift_R , pattern Shift_L, pattern Shift_R
) )
import MetaBrush.UI.ToolBar
( Mode(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -98,34 +103,45 @@ selectionMode = foldMap \case
_ -> New _ -> New
-- | Updates the selected objects on a single click selection event. -- | Updates the selected objects on a single click selection event.
selectAt :: SelectionMode -> Point2D Double -> Document -> Document selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document
selectAt mode c doc@( Document { zoomFactor } ) = selectAt mode selMode c doc@( Document { zoomFactor } ) =
( `evalState` False ) $ field' @"strokes" ( traverse updateStroke ) doc ( `evalState` False ) $ field' @"strokes" ( traverse updateStroke ) doc
where where
updateStroke :: Stroke -> State Bool Stroke updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } ) = updateStroke stroke@( Stroke { strokeVisible } )
( field' @"strokePoints" ) | Brush <- mode
( traverse ( updatePoint strokeVisible ) = ( field' @"strokePoints" . traverse )
>>> fmap matchEndpoints ( \ spt ->
) ( field' @"pointData" . field' @"brushShape" )
stroke ( traverse ( updatePoint strokeVisible ( MkVector2D $ coords spt ) )
updatePoint :: Bool -> StrokePoint PointData -> State Bool ( StrokePoint PointData ) >>> fmap matchEndpoints
updatePoint isVisible pt = do )
spt
)
stroke
| otherwise
= ( field' @"strokePoints" )
( traverse ( updatePoint strokeVisible ( Vector2D 0 0 ) )
>>> fmap matchEndpoints
)
stroke
updatePoint :: HasType FocusState pt => Bool -> Vector2D Double -> StrokePoint pt -> State Bool ( StrokePoint pt )
updatePoint isVisible offset pt = do
anotherPointHasAlreadyBeenSelected <- get anotherPointHasAlreadyBeenSelected <- get
if selected && not anotherPointHasAlreadyBeenSelected if selected && not anotherPointHasAlreadyBeenSelected
then put True $> case mode of then put True $> case selMode of
Subtract -> set _selection Normal pt Subtract -> set _selection Normal pt
_ -> set _selection Selected pt _ -> set _selection Selected pt
else pure $ case mode of else pure $ case selMode of
New -> set _selection Normal pt New -> set _selection Normal pt
_ -> pt _ -> pt
where where
selected :: Bool selected :: Bool
selected selected
| not isVisible = False | not isVisible = False
| otherwise = squaredNorm ( c --> coords pt :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) | otherwise = squaredNorm ( c --> ( offset • coords pt ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
-- Ensure consistency of selection at endpoints for closed loops. -- Ensure consistency of selection at endpoints for closed loops.
matchEndpoints :: Seq ( StrokePoint PointData ) -> Seq ( StrokePoint PointData ) matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt )
matchEndpoints ( p0 :<| ( ps :|> pn ) ) matchEndpoints ( p0 :<| ( ps :|> pn ) )
| coords p0 == coords pn | coords p0 == coords pn
= p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn ) = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
@ -142,8 +158,8 @@ data DragMoveSelect
-- | Checks whether a mouse click can initiate a drag move event, -- | Checks whether a mouse click can initiate a drag move event,
-- and if so returns an updated document with the selection modified from the start of the drag move. -- and if so returns an updated document with the selection modified from the start of the drag move.
dragMoveSelect :: Point2D Double -> Document -> Maybe Document dragMoveSelect :: Mode -> Point2D Double -> Document -> Maybe Document
dragMoveSelect c doc@( Document { zoomFactor } ) = dragMoveSelect mode c doc@( Document { zoomFactor } ) =
let let
res :: Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Document res :: Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Document
res = do res = do
@ -156,14 +172,30 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
where where
updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke
updateStroke stroke@( Stroke { strokeVisible } ) = updateStroke stroke@( Stroke { strokeVisible } )
( field' @"strokePoints" ) | Brush <- mode
( traverse ( updatePoint strokeVisible ) = ( field' @"strokePoints" . traverse )
>>> fmap matchEndpoints ( \ spt ->
) ( field' @"pointData" . field' @"brushShape" )
stroke ( traverse ( updatePoint strokeVisible ( MkVector2D $ coords spt ) )
updatePoint :: Bool -> StrokePoint PointData -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ( StrokePoint PointData ) >>> fmap matchEndpoints
updatePoint isVisible pt )
spt
)
stroke
| otherwise
= ( field' @"strokePoints" )
( traverse ( updatePoint strokeVisible ( Vector2D 0 0 ) )
>>> fmap matchEndpoints
)
stroke
updatePoint
:: HasType FocusState pt
=> Bool
-> Vector2D Double
-> StrokePoint pt
-> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ( StrokePoint pt )
updatePoint isVisible offset pt
| selected | selected
= do = do
mbPreviousSelect <- Tardis.getPast mbPreviousSelect <- Tardis.getPast
@ -172,7 +204,7 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
Just _ -> pure pt Just _ -> pure pt
-- First click on a point: record this. -- First click on a point: record this.
Nothing -> do Nothing -> do
case pointState ( pointData pt ) of case view _selection pt of
Selected -> Tardis.sendFuture ( Just ClickedOnSelected ) Selected -> Tardis.sendFuture ( Just ClickedOnSelected )
_ -> Tardis.sendFuture ( Just ClickedOnUnselected ) _ -> Tardis.sendFuture ( Just ClickedOnUnselected )
-- Select this point (whether it was previously selected or not). -- Select this point (whether it was previously selected or not).
@ -195,47 +227,62 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
selected :: Bool selected :: Bool
selected selected
| not isVisible = False | not isVisible = False
| otherwise = squaredNorm ( c --> coords pt :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) | otherwise = squaredNorm ( c --> ( offset • coords pt ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
-- Ensure consistency of selection at endpoints for closed loops. -- Ensure consistency of selection at endpoints for closed loops.
matchEndpoints :: Seq ( StrokePoint PointData ) -> Seq ( StrokePoint PointData ) matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt )
matchEndpoints ( p0 :<| ( ps :|> pn ) ) matchEndpoints ( p0 :<| ( ps :|> pn ) )
| coords p0 == coords pn | coords p0 == coords pn
= p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn ) = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
matchEndpoints ps = ps matchEndpoints ps = ps
-- | Updates the selected objects on a rectangular selection event. -- | Updates the selected objects on a rectangular selection event.
selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document selectRectangle :: Mode -> SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
selectRectangle mode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" . mapped ) updateStroke selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" . mapped ) updateStroke
where where
xMin, xMax, yMin, yMax :: Double xMin, xMax, yMin, yMax :: Double
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 ) ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 ) ( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
updateStroke :: Stroke -> Stroke updateStroke :: Stroke -> Stroke
updateStroke stroke@( Stroke { strokeVisible } ) = updateStroke stroke@( Stroke { strokeVisible } )
over ( field' @"strokePoints" . mapped ) | Brush <- mode
( updatePoint strokeVisible ) = over ( field' @"strokePoints" . mapped )
stroke ( \ spt ->
updatePoint :: Bool -> StrokePoint PointData -> StrokePoint PointData over ( field' @"pointData" . field' @"brushShape" . mapped )
updatePoint isVisible pt ( updatePoint strokeVisible ( MkVector2D $ coords spt ) )
| selected = case mode of spt
)
stroke
| otherwise
= over ( field' @"strokePoints" . mapped )
( updatePoint strokeVisible ( Vector2D 0 0 ) )
stroke
updatePoint :: HasType FocusState pt => Bool -> Vector2D Double -> StrokePoint pt -> StrokePoint pt
updatePoint isVisible offset pt
| selected = case selMode of
Subtract -> set _selection Normal pt Subtract -> set _selection Normal pt
_ -> set _selection Selected pt _ -> set _selection Selected pt
| otherwise = case mode of | otherwise = case selMode of
New -> set _selection Normal pt New -> set _selection Normal pt
_ -> pt _ -> pt
where where
x, y :: Double x, y :: Double
Point2D x y = coords pt Point2D x y = offset • coords pt
selected :: Bool selected :: Bool
selected selected
| not isVisible = False | not isVisible = False
| otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax | otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax
-- | Translate all selected points by the given vector. -- | Translate all selected points by the given vector.
translateSelection :: Vector2D Double -> Document -> Document translateSelection :: Mode -> Vector2D Double -> Document -> Document
translateSelection t = over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped ) updateStrokePoint translateSelection mode t
| Brush <- mode
= over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped . field' @"pointData" . field' @"brushShape" . mapped )
updateStrokePoint
| otherwise
= over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped )
updateStrokePoint
where where
updateStrokePoint :: StrokePoint PointData -> StrokePoint PointData updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> StrokePoint pt
updateStrokePoint pt updateStrokePoint pt
| Selected <- view _selection pt | Selected <- view _selection pt
= pt { coords = t • coords pt } = pt { coords = t • coords pt }
@ -243,13 +290,22 @@ translateSelection t = over ( field' @"strokes" . mapped . field' @"strokePoints
= pt = pt
-- | Delete the selected points. -- | Delete the selected points.
deleteSelected :: Document -> Document deleteSelected :: Mode -> Document -> Document
deleteSelected deleteSelected mode doc = fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) $ case mode of
= fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) Brush ->
. ( field' @"strokes" . traverse . field' @"strokePoints" ) ( field' @"strokes" . traverse . field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" )
updateStroke updateStroke
doc
_ ->
( field' @"strokes" . traverse . field' @"strokePoints" )
updateStroke
doc
where where
updateStroke :: Seq ( StrokePoint PointData ) -> Tardis Bool Bool ( Seq ( StrokePoint PointData ) ) updateStroke
:: forall pt
. HasType FocusState pt
=> Seq ( StrokePoint pt )
-> Tardis Bool Bool ( Seq ( StrokePoint pt ) )
updateStroke Empty = pure Empty updateStroke Empty = pure Empty
updateStroke ( p :<| ps ) = case p of updateStroke ( p :<| ps ) = case p of
PathPoint {} PathPoint {}
@ -274,7 +330,7 @@ deleteSelected
-- - if the next path point is going to be deleted. -- - if the next path point is going to be deleted.
-- --
-- Need to be lazy in "nextPathPointDeleted" to avoid looping. -- Need to be lazy in "nextPathPointDeleted" to avoid looping.
res :: Seq ( StrokePoint PointData ) res :: Seq ( StrokePoint pt )
res = if selectionState == Selected || prevPathPointDeleted || nextPathPointDeleted res = if selectionState == Selected || prevPathPointDeleted || nextPathPointDeleted
then rest then rest
else p :<| rest else p :<| rest

42
src/app/MetaBrush/Event.hs
View file

@ -96,7 +96,7 @@ handleEvents
uniqueSupply uniqueSupply
activeDocumentTVar openDocumentsTVar activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar _modeTVar partialPathTVar toolTVar modeTVar partialPathTVar
window viewportDrawingArea infoBar = do window viewportDrawingArea infoBar = do
-- Mouse events -- Mouse events
@ -105,12 +105,12 @@ handleEvents
_ <- GTK.onWidgetScrollEvent viewportDrawingArea _ <- GTK.onWidgetScrollEvent viewportDrawingArea
( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar ) ( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea _ <- GTK.onWidgetButtonPressEvent viewportDrawingArea
( handleMouseButtonEvent uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea ) ( handleMouseButtonEvent uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
( handleMouseButtonRelease uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea ) ( handleMouseButtonRelease uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea )
-- Keyboard events -- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent activeDocumentTVar openDocumentsTVar mousePosTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea ) _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent activeDocumentTVar openDocumentsTVar mousePosTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea )
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
-- Window quit -- Window quit
@ -294,7 +294,7 @@ handleMouseButtonEvent
:: UniqueSupply :: UniqueSupply
-> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar ( Maybe PartialPath ) -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> GTK.DrawingArea
-> GDK.EventButton -> GDK.EventButton
-> IO Bool -> IO Bool
@ -302,7 +302,7 @@ handleMouseButtonEvent
uniqueSupply uniqueSupply
activeDocumentTVar openDocumentsTVar activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar partialPathTVar toolTVar modeTVar partialPathTVar
viewportDrawingArea viewportDrawingArea
mouseClickEvent mouseClickEvent
= do = do
@ -330,6 +330,7 @@ handleMouseButtonEvent
STM.writeTVar mousePosTVar ( Just pos ) STM.writeTVar mousePosTVar ( Just pos )
pressedKeys <- STM.readTVar pressedKeysTVar pressedKeys <- STM.readTVar pressedKeysTVar
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of case tool of
-- Selection mode mouse hold: -- Selection mode mouse hold:
@ -342,7 +343,7 @@ handleMouseButtonEvent
case selectionMode pressedKeys of case selectionMode pressedKeys 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 newDoc <- dragMoveSelect pos doc | Just newDoc <- dragMoveSelect mode pos doc
-> do -> do
let let
newDocs :: IntMap Document newDocs :: IntMap Document
@ -392,7 +393,7 @@ handleMouseButtonRelease
:: UniqueSupply :: UniqueSupply
-> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar ( Maybe PartialPath ) -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> GTK.DrawingArea
-> GDK.EventButton -> GDK.EventButton
-> IO Bool -> IO Bool
@ -400,7 +401,7 @@ handleMouseButtonRelease
uniqueSupply uniqueSupply
activeDocumentTVar openDocumentsTVar activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar partialPathTVar toolTVar modeTVar partialPathTVar
viewportDrawingArea viewportDrawingArea
mouseReleaseEvent mouseReleaseEvent
= do = do
@ -428,22 +429,22 @@ handleMouseButtonRelease
pressedKeys <- STM.readTVar pressedKeysTVar pressedKeys <- STM.readTVar pressedKeysTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
newDoc <- case tool of newDoc <- case tool of
Selection -> do Selection -> do
let let
mode :: SelectionMode selMode :: SelectionMode
mode = selectionMode pressedKeys selMode = selectionMode pressedKeys
case mbHoldPos of case mbHoldPos of
Just hold Just hold
| DragMoveHold pos0 <- hold | DragMoveHold pos0 <- hold
, pos0 /= pos , pos0 /= pos
-> pure $ translateSelection ( pos0 --> pos ) doc -> pure $ translateSelection mode ( pos0 --> pos ) doc
| SelectionHold pos0 <- hold | SelectionHold pos0 <- hold
, pos0 /= pos , pos0 /= pos
-> pure $ selectRectangle mode pos0 pos doc -> pure $ selectRectangle mode selMode pos0 pos doc
_ -> pure $ selectAt mode pos doc _ -> pure $ selectAt mode selMode pos doc
Pen -> do Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
@ -539,14 +540,14 @@ handleMouseButtonRelease
handleKeyboardPressEvent handleKeyboardPressEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar ( Maybe PartialPath ) -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> GTK.DrawingArea
-> GDK.EventKey -> GDK.EventKey
-> IO Bool -> IO Bool
handleKeyboardPressEvent handleKeyboardPressEvent
activeDocumentTVar openDocumentsTVar activeDocumentTVar openDocumentsTVar
mousePosTVar pressedKeysTVar mousePosTVar pressedKeysTVar
toolTVar partialPathTVar toolTVar modeTVar partialPathTVar
viewportDrawingArea viewportDrawingArea
evt = do evt = do
keyCode <- GDK.getEventKeyKeyval evt keyCode <- GDK.getEventKeyKeyval evt
@ -556,7 +557,7 @@ handleKeyboardPressEvent
case keyCode of case keyCode of
Escape -> GTK.mainQuit Escape -> GTK.mainQuit
Return -> do Return -> do
tool <- STM.atomically $ STM.readTVar toolTVar tool <- STM.readTVarIO toolTVar
case tool of case tool of
-- End ongoing drawing on pressing enter key. -- End ongoing drawing on pressing enter key.
Pen -> do Pen -> do
@ -564,7 +565,8 @@ handleKeyboardPressEvent
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
_ -> pure () _ -> pure ()
Delete -> do Delete -> do
tool <- STM.atomically $ STM.readTVar toolTVar tool <- STM.readTVarIO toolTVar
mode <- STM.readTVarIO modeTVar
case tool of case tool of
-- Delete selected points on pressing 'Delete'. -- Delete selected points on pressing 'Delete'.
Selection -> do Selection -> do
@ -574,7 +576,7 @@ handleKeyboardPressEvent
for_ ( IntMap.lookup i docs ) \ doc -> do for_ ( IntMap.lookup i docs ) \ doc -> do
let let
newDoc :: Document newDoc :: Document
newDoc = deleteSelected doc newDoc = deleteSelected mode doc
newDocs :: IntMap Document newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs newDocs = IntMap.insert i newDoc docs
STM.atomically $ STM.writeTVar openDocumentsTVar newDocs STM.atomically $ STM.writeTVar openDocumentsTVar newDocs

2
src/app/MetaBrush/Render/Document.hs
View file

@ -133,7 +133,7 @@ renderDocument
modifiedStrokes modifiedStrokes
| Just ( DragMoveHold p0 ) <- mbHoldEvent | Just ( DragMoveHold p0 ) <- mbHoldEvent
, Just p1 <- mbMousePos , Just p1 <- mbMousePos
= strokes $ translateSelection ( p0 --> p1 ) doc = strokes $ translateSelection mode ( p0 --> p1 ) doc
| Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
, let , let
mbFinalPoint :: Maybe ( Point2D Double ) mbFinalPoint :: Maybe ( Point2D Double )