implement selection & drag-move in brush mode

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

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

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 )