From 9e73da9fffe0a16d1780620fe3a598575256d910 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 29 Aug 2020 22:19:51 +0200 Subject: [PATCH] implement selection & drag-move in brush mode --- src/app/MetaBrush/Document/Selection.hs | 170 ++++++++++++++++-------- src/app/MetaBrush/Event.hs | 42 +++--- src/app/MetaBrush/Render/Document.hs | 2 +- 3 files changed, 136 insertions(+), 78 deletions(-) diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 52dd052..dd3a34a 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index e5e2889..5df023f 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 0ce50a3..7a719bf 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 )