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

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

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

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

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

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