add mouse drag-move operation

MetaBrush.cabal

@@ -139,5 +139,7 @@ executable MetaBrush
           ^>= 0.24
       , stm
           ^>= 2.5.0.0
+      , tardis
+          ^>= 0.4.1.0
       , text
           ^>= 1.2.3.1 && < 1.2.5

app/Main.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms   #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TupleSections     #-}
 {-# LANGUAGE TypeApplications  #-}
 
 module Main
@@ -13,6 +14,8 @@ module Main
 -- base
 import Control.Monad
   ( void )
+import Data.Foldable
+  ( for_ )
 import Data.Int
   ( Int32 )
 import Data.Word
@@ -42,7 +45,7 @@ import qualified GI.Gtk as GTK
 
 -- stm
 import qualified Control.Concurrent.STM.TVar as STM
-  ( newTVarIO )
+  ( newTVarIO, readTVarIO )
 
 -- text
 import qualified Data.Text as Text
@@ -58,14 +61,14 @@ import MetaBrush.Asset.Logo
 import MetaBrush.Document
   ( Document(..), AABB(..)
   , Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
-  , Overlay
+  , currentDocument
   )
 import MetaBrush.Event
-  ( handleEvents )
+  ( HoldEvent, handleEvents )
+import MetaBrush.Render.Document
+  ( renderDocument )
 import MetaBrush.Render.Util
   ( widgetAddClass, widgetAddClasses )
-import MetaBrush.Time
-  ( Time )
 import MetaBrush.UI.FileBar
   ( createFileBar )
 import MetaBrush.UI.InfoBar
@@ -143,14 +146,13 @@ main = do
   ---------------------------------------------------------
   -- Initialise state
 
-  activeDocumentTVar <- STM.newTVarIO @( Maybe Int       )                Nothing
+  activeDocumentTVar <- STM.newTVarIO @( Maybe Int       )          Nothing
-  openDocumentsTVar  <- STM.newTVarIO @( IntMap Document )                testDocuments
+  openDocumentsTVar  <- STM.newTVarIO @( IntMap Document )          testDocuments
-  mousePosTVar       <- STM.newTVarIO @( Maybe ( Point2D Double ) )       Nothing
+  mousePosTVar       <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
-  mouseHoldTVar      <- STM.newTVarIO @( Maybe ( Point2D Double, Time ) ) Nothing
+  mouseHoldTVar      <- STM.newTVarIO @( Maybe HoldEvent )          Nothing
-  pressedKeysTVar    <- STM.newTVarIO @[ Word32 ]                         []
+  pressedKeysTVar    <- STM.newTVarIO @[ Word32 ]                   []
-  toolTVar           <- STM.newTVarIO @Tool                               Selection
+  toolTVar           <- STM.newTVarIO @Tool                         Selection
-  modeTVar           <- STM.newTVarIO @Mode                               Path
+  modeTVar           <- STM.newTVarIO @Mode                         Path
-  overlayTVar        <- STM.newTVarIO @( Maybe Overlay )                  Nothing
 
   ---------------------------------------------------------
   -- Initialise GTK
@@ -264,13 +266,25 @@ main = do
   ---------------------------------------------------------
   -- Main viewport
 
-  Viewport { viewportDrawingArea } <-
+  Viewport { viewportDrawingArea } <- createViewport viewportGrid
-    createViewport
+
-      colours
+  -----------------
-      activeDocumentTVar
+  -- Viewport rendering
-      openDocumentsTVar
+
-      overlayTVar
+  void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
-      viewportGrid
+    -- Get the relevant document information
+    mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
+    for_ mbDoc \ doc -> do
+      mousePos  <- STM.readTVarIO mousePosTVar
+      holdEvent <- STM.readTVarIO mouseHoldTVar
+      let
+        mbHoldEvent :: Maybe ( HoldEvent, Point2D Double )
+        mbHoldEvent = (,) <$> holdEvent <*> mousePos
+      viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
+      viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
+      ( `Cairo.renderWithContext` ctx ) $
+        renderDocument colours ( viewportWidth, viewportHeight ) mbHoldEvent doc
+    pure True
 
   ---------------------------------------------------------
   -- Info bar
@@ -302,7 +316,6 @@ main = do
     activeDocumentTVar openDocumentsTVar
     mousePosTVar mouseHoldTVar pressedKeysTVar
     toolTVar modeTVar
-    overlayTVar
     window viewportDrawingArea infoBarElements
 
   ---------------------------------------------------------

src/app/MetaBrush/Document.hs

@@ -8,7 +8,6 @@ module MetaBrush.Document
   , Document(..), currentDocument
   , Stroke(..), StrokePoint(..), PointType(..)
   , FocusState(..), switchFocusState
-  , Overlay(..)
   )
   where
 
@@ -67,7 +66,7 @@ data StrokePoint
   = StrokePoint
   { strokePoint :: !( Point2D Double )
   , pointType   :: !PointType
-  , pointState  :: !FocusState
+  , pointState  :: FocusState -- needs to be lazy for drag selection code
   }
   deriving stock ( Show, Generic )
 
@@ -87,10 +86,6 @@ switchFocusState Normal   = Selected
 switchFocusState Hover    = Hover
 switchFocusState Selected = Normal
 
-data Overlay
-  = SelectionRectangle !( Point2D Double ) !( Point2D Double )
-  deriving stock Show
-
 currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
 currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
   mbActive <- STM.readTVar activeDocumentTVar

src/app/MetaBrush/Document/Selection.hs

@@ -1,23 +1,31 @@
 {-# LANGUAGE BlockArguments     #-}
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE LambdaCase         #-}
 {-# LANGUAGE NamedFieldPuns     #-}
 {-# LANGUAGE PatternSynonyms    #-}
 {-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE RecursiveDo        #-}
 {-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.Document.Selection
-  ( selectAt, selectRectangle )
+  ( SelectionMode(..), selectionMode
+  , selectAt, selectRectangle
+  , DragMoveSelect(..), dragMoveSelect
+  , translateSelection
+  )
   where
 
 -- base
+import Data.Functor.Identity
+  ( runIdentity )
 import Data.Word
   ( Word32 )
 
 -- acts
 import Data.Act
-  ( Torsor((-->)) )
+  ( Act((•)), Torsor((-->)) )
 
 -- generic-lens
 import Data.GenericLens.Internal
@@ -25,6 +33,14 @@ import Data.GenericLens.Internal
 import Data.Generics.Product.Fields
   ( field' )
 
+-- tardis
+import Control.Monad.Trans.Tardis
+  ( Tardis )
+import qualified Control.Monad.Trans.Tardis as Tardis
+  ( TardisT(..)
+  , getPast, getFuture, sendPast, modifyForwards
+  )
+
 -- MetaBrush
 import Math.Module
   ( squaredNorm )
@@ -69,12 +85,10 @@ selectionMode = foldMap \case
 --
 -- TODO: currently selects points regardless of layers,
 -- e.g. it will simultaneously select points with equal coordinates.
-selectAt :: [ Word32 ] -> Point2D Double -> Document -> Document
+selectAt :: SelectionMode -> Point2D Double -> Document -> Document
-selectAt pressedKeys c doc@( Document { zoomFactor } ) =
+selectAt mode c doc@( Document { zoomFactor } ) =
   over ( field' @"strokes" ) ( fmap updateStroke ) doc
     where
-      mode :: SelectionMode
-      mode = selectionMode pressedKeys
       updateStroke :: Stroke -> Stroke
       updateStroke stroke@( Stroke { strokeVisible } ) =
         over ( field' @"strokePoints" )
@@ -95,15 +109,78 @@ selectAt pressedKeys c doc@( Document { zoomFactor } ) =
             | not isVisible = False
             | otherwise     = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
 
+-- | Type of a drag move selection:
+--
+-- - user initiated drag by clicking on an already selected item: selection is preserved;
+-- - user initiated drag by clicking on an unselected item: select this item and deselect the previous selection.
+data DragMoveSelect
+  = ClickedOnSelected
+  | ClickedOnUnselected
+  deriving stock Show
+
+instance {-# OVERLAPPING #-} Semigroup ( Maybe DragMoveSelect ) where
+  Just ( ClickedOnSelected ) <> _ = Just ( ClickedOnSelected )
+  Nothing <> r = r
+  _ <> Just ( ClickedOnSelected ) = Just ( ClickedOnSelected )
+  l <> Nothing = l
+  _ <> _ = Just ClickedOnUnselected
+
+instance {-# OVERLAPPING #-} Monoid ( Maybe DragMoveSelect ) where
+  mempty = Nothing
+
+-- | 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 } ) =
+  let
+    res :: Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Document
+    res = do
+      newDoc <- field' @"strokes" ( traverse updateStroke ) doc
+      Tardis.getPast >>= Tardis.sendPast
+      pure newDoc
+  in case runIdentity $ Tardis.runTardisT res ( Nothing, Nothing ) of
+    ( newDoc, ( _, Just _  ) ) -> Just newDoc
+    ( _     , ( _, Nothing ) ) -> Nothing
+
+  where
+    updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke
+    updateStroke stroke@( Stroke { strokeVisible } ) =
+      field' @"strokePoints"
+        ( traverse ( updatePoint strokeVisible ) )
+        stroke
+    updatePoint :: Bool -> StrokePoint -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) StrokePoint
+    updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
+      | selected
+      = do
+          case oldFocusState of
+            Selected -> Tardis.modifyForwards ( const $ Just ClickedOnSelected )
+            _        -> Tardis.modifyForwards ( <> Just ClickedOnUnselected )
+          pure $ pt { pointState = Selected }
+      | otherwise
+      = do
+        mbDragClick <- Tardis.getFuture
+        let
+          -- needs to be lazy
+          newPointState :: FocusState
+          newPointState
+            | Just ClickedOnSelected <- mbDragClick
+            = pointState pt
+            | otherwise
+            = Normal
+        pure ( pt { pointState = newPointState } )
+      where
+        selected :: Bool
+        selected
+          | not isVisible = False
+          | otherwise     = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
+
 -- | Updates the selected objects on a rectangular selection event.
-selectRectangle :: [ Word32 ] -> Point2D Double -> Point2D Double -> Document -> Document
+selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
-selectRectangle pressedKeys ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" ) ( fmap updateStroke )
+selectRectangle mode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" ) ( fmap 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 )
-      mode :: SelectionMode
-      mode = selectionMode pressedKeys
       updateStroke :: Stroke -> Stroke
       updateStroke stroke@( Stroke { strokeVisible } ) =
         over ( field' @"strokePoints" )
@@ -122,3 +199,16 @@ selectRectangle pressedKeys ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field'
           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" ) ( fmap updateStroke )
+  where
+    updateStroke :: Stroke -> Stroke
+    updateStroke = over ( field' @"strokePoints" ) ( fmap updateStrokePoint )
+    updateStrokePoint :: StrokePoint -> StrokePoint
+    updateStrokePoint pt@( StrokePoint { strokePoint = p, pointState } )
+      | Selected <- pointState
+      = pt { strokePoint = t • p }
+      | otherwise
+      = pt

src/app/MetaBrush/Event.hs

@@ -1,11 +1,14 @@
-{-# LANGUAGE BlockArguments   #-}
+{-# LANGUAGE BlockArguments     #-}
-{-# LANGUAGE NamedFieldPuns   #-}
+{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE PatternSynonyms  #-}
+{-# LANGUAGE NamedFieldPuns     #-}
-{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE PatternSynonyms    #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.Event
-  ( handleEvents )
+  ( handleEvents
+  , HoldEvent(..)
+  )
   where
 
 -- base
@@ -37,8 +40,6 @@ import qualified GI.Gdk as GDK
 import qualified GI.Gtk as GTK
 
 -- stm
-import Control.Concurrent.STM
-  ( STM )
 import qualified Control.Concurrent.STM      as STM
   ( atomically )
 import qualified Control.Concurrent.STM.TVar as STM
@@ -50,16 +51,17 @@ import Math.Module
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Document
-  ( Document(..), Overlay(..) )
+  ( Document(..) )
 import MetaBrush.Document.Selection
-  ( selectAt, selectRectangle )
+  ( SelectionMode(..), selectionMode
+  , selectAt, selectRectangle
+  , dragMoveSelect, translateSelection
+  )
 import MetaBrush.Event.KeyCodes
   ( pattern Escape
   , pattern Control_L, pattern Control_R
   , pattern Shift_L  , pattern Shift_R
   )
-import MetaBrush.Time
-  ( Time, monotonicTime, DTime(DSeconds) )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.UI.InfoBar
@@ -71,27 +73,25 @@ import MetaBrush.UI.ToolBar
 
 handleEvents
   :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
+  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
   -> STM.TVar Tool -> STM.TVar Mode
-  -> STM.TVar ( Maybe Overlay )
   -> GTK.Window -> GTK.DrawingArea -> InfoBar
   -> IO ()
 handleEvents
   activeDocumentTVar openDocumentsTVar
   mousePosTVar mouseHoldTVar pressedKeysTVar
   toolTVar _modeTVar
-  overlayTVar
   window viewportDrawingArea infoBar = do
 
     -- Mouse events
     _ <- GTK.onWidgetMotionNotifyEvent  viewportDrawingArea
-          ( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar overlayTVar viewportDrawingArea infoBar )
+          ( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar viewportDrawingArea infoBar )
     _ <- GTK.onWidgetScrollEvent        viewportDrawingArea
-          ( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea infoBar )
+          ( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar )
     _ <- GTK.onWidgetButtonPressEvent   viewportDrawingArea
           ( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea )
     _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
-          ( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea )
+          ( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea )
 
     -- Keyboard events
     _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   pressedKeysTVar )
@@ -102,22 +102,29 @@ handleEvents
 
     pure ()
 
+-- | Keep track of a mouse hold event:
+--
+--  - start a rectangular selection,
+--  - move objects by dragging.
+data HoldEvent
+  = SelectionHold { holdStartPos :: !( Point2D Double ) }
+  | DragMoveHold  { holdStartPos :: !( Point2D Double ) }
+  deriving stock Show
+
 --------------------------------------------------------------------------------
 -- Mouse events.
 
 handleMotionEvent
   :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) )
+  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent )
   -> STM.TVar Tool
-  -> STM.TVar ( Maybe Overlay )
   -> GTK.DrawingArea -> InfoBar
   -> GDK.EventMotion
   -> IO Bool
 handleMotionEvent
   activeDocumentTVar openDocumentsTVar
-  mousePosTVar mouseHoldTVar
+  mousePosTVar _mouseHoldTVar
-  toolTVar
+  _toolTVar
-  overlayTVar
   viewportDrawingArea infoBar
   eventMotion
   = do
@@ -150,27 +157,21 @@ handleMotionEvent
         updateInfoBar infoBar infoData
         STM.atomically do
           STM.writeTVar mousePosTVar ( Just pos )
-
-        ----------------------------------------------------------
-        -- Tool dependent updating.
-          updateOverlay mouseHoldTVar toolTVar overlayTVar pos
-
-
         GTK.widgetQueueDraw viewportDrawingArea
 
     pure True
 
 handleScrollEvent
   :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) )  -> STM.TVar [ Word32 ]
+  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-  -> STM.TVar Tool -> STM.TVar ( Maybe Overlay )
+  -> STM.TVar Tool
   -> GTK.DrawingArea -> InfoBar
   -> GDK.EventScroll
   -> IO Bool
 handleScrollEvent
   activeDocumentTVar openDocumentsTVar
-  mousePosTVar mouseHoldTVar pressedKeysTVar
+  mousePosTVar _mouseHoldTVar pressedKeysTVar
-  toolTVar overlayTVar
+  _toolTVar
   viewportDrawingArea infoBar
   scrollEvent
   = do
@@ -243,20 +244,19 @@ handleScrollEvent
           STM.atomically do
             STM.writeTVar openDocumentsTVar docs'
             STM.writeTVar mousePosTVar ( Just finalMousePos )
-            updateOverlay mouseHoldTVar toolTVar overlayTVar finalMousePos
           GTK.widgetQueueDraw viewportDrawingArea
 
     pure False
 
 handleMouseButtonEvent
   :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
+  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
   -> GTK.DrawingArea
   -> GDK.EventButton
   -> IO Bool
 handleMouseButtonEvent
   activeDocumentTVar openDocumentsTVar
-  mousePosTVar mouseHoldTVar _pressedKeysTVar
+  mousePosTVar mouseHoldTVar pressedKeysTVar
   viewportDrawingArea
   mouseClickEvent
   = do
@@ -268,7 +268,7 @@ handleMouseButtonEvent
         mbActiveDoc <- STM.readTVarIO activeDocumentTVar
         for_ mbActiveDoc \ i -> do
           docs <- STM.readTVarIO openDocumentsTVar
-          for_ ( IntMap.lookup i docs ) \ ( Document { zoomFactor, viewportCenter } ) -> do
+          for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
             x <- GDK.getEventButtonX mouseClickEvent
             y <- GDK.getEventButtonY mouseClickEvent
             viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
@@ -278,19 +278,41 @@ handleMouseButtonEvent
               toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
               pos :: Point2D Double
               pos = toViewport ( Point2D x y )
-            time <- monotonicTime
+            -- Selection mode mouse hold:
+            --
+            -- - If holding shift or alt, mouse hold initiates a rectangular selection.
+            -- - If not holding shift or alt:
+            --    - if mouse click selected an object, initiate a drag move,
+            --    - otherwise, initiate a rectangular selection.
             STM.atomically do
               STM.writeTVar mousePosTVar  ( Just pos )
-              STM.writeTVar mouseHoldTVar ( Just ( pos, time ) )
+              pressedKeys <- STM.readTVar pressedKeysTVar
+              let
+                mode :: SelectionMode
+                mode = selectionMode pressedKeys
+              case mode of
+                -- Drag move: not holding shift or alt, click has selected something.
+                New
+                  | Just newDoc <- dragMoveSelect pos doc
+                  -> do
+                    let
+                      newDocs :: IntMap Document
+                      newDocs = IntMap.insert i newDoc docs
+                    STM.writeTVar openDocumentsTVar newDocs
+                    STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
+                -- Rectangular selection.
+                _ ->
+                    STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
+
+              
       _ -> pure ()
 
     pure False
 
 handleMouseButtonRelease
   :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-  -> STM.TVar ( Maybe ( Point2D Double ) ) ->  STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
+  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
   -> STM.TVar Tool
-  -> STM.TVar ( Maybe Overlay )
   -> GTK.DrawingArea
   -> GDK.EventButton
   -> IO Bool
@@ -298,7 +320,6 @@ handleMouseButtonRelease
   activeDocumentTVar openDocumentsTVar
   mousePosTVar mouseHoldTVar pressedKeysTVar
   toolTVar
-  overlayTVar
   viewportDrawingArea
   mouseReleaseEvent
   = do
@@ -320,22 +341,23 @@ handleMouseButtonRelease
               toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
               pos :: Point2D Double
               pos = toViewport ( Point2D x y )
-            t <- monotonicTime
             STM.atomically do
               pressedKeys <- STM.readTVar pressedKeysTVar
               mbHoldPos   <- STM.swapTVar mouseHoldTVar Nothing
-              STM.writeTVar overlayTVar Nothing
               tool        <- STM.readTVar toolTVar
               let
+                mode :: SelectionMode
+                mode = selectionMode pressedKeys
                 newDoc :: Document
                 newDoc = case tool of
                   Selection
-                    | Just ( pos0, t0 ) <- mbHoldPos
+                    | Just ( SelectionHold pos0 ) <- mbHoldPos
                     , pos0 /= pos
-                    , ( t0 --> t ) > DSeconds 0.01
+                    -> selectRectangle mode pos0 pos doc
-                    -> selectRectangle pressedKeys pos0 pos doc
+                    | Just ( DragMoveHold pos0 ) <- mbHoldPos
+                    -> translateSelection ( pos0 --> pos ) doc
                     | otherwise
-                    -> selectAt pressedKeys pos doc
+                    -> selectAt mode pos doc
                   Pen -> doc -- TODO
                 newDocs :: IntMap Document
                 newDocs = IntMap.insert i newDoc docs
@@ -348,19 +370,6 @@ handleMouseButtonRelease
 
     pure False
 
-updateOverlay :: STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar Tool -> STM.TVar ( Maybe Overlay ) -> Point2D Double -> STM ()
-updateOverlay mouseHoldTVar toolTVar overlayTVar p = do
-  tool <- STM.readTVar toolTVar
-  case tool of
-    -- Draw selection rectangle if performing a selection.
-    Selection -> do
-      mbHold <-  STM.readTVar mouseHoldTVar
-      case mbHold of
-        Just ( p0, _ ) -> STM.writeTVar overlayTVar ( Just ( SelectionRectangle p0 p ) )
-        Nothing        -> STM.writeTVar overlayTVar Nothing
-    -- Pen tool: show preview (TODO).
-    Pen    -> STM.writeTVar overlayTVar Nothing
-
 --------------------------------------------------------------------------------
 -- Keyboard events.
 

src/app/MetaBrush/Render/Document.hs

@@ -11,12 +11,16 @@ module MetaBrush.Render.Document
 
 -- base
 import Data.Foldable
-  ( for_, traverse_ )
+  ( traverse_ )
 import Data.Functor.Compose
   ( Compose(..) )
 import Data.Int
   ( Int32 )
 
+-- acts
+import Data.Act
+  ( Torsor((-->)) )
+
 -- gi-cairo-render
 import qualified GI.Cairo.Render as Cairo
 
@@ -32,8 +36,11 @@ import MetaBrush.Asset.Colours
 import MetaBrush.Document
   ( Document(..)
   , Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
-  , Overlay(..)
   )
+import MetaBrush.Document.Selection
+  ( translateSelection )
+import MetaBrush.Event
+  ( HoldEvent(..) )
 import MetaBrush.Render.Util
   ( withRGBA )
 
@@ -56,23 +63,35 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
 
 --------------------------------------------------------------------------------
 
-renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Maybe Overlay -> Cairo.Render ()
+renderDocument :: Colours -> ( Int32, Int32 ) -> Maybe ( HoldEvent, Point2D Double ) -> Document -> Cairo.Render ()
-renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) mbOverlay = do
+renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
+  doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } )
+  = do
 
-  Cairo.save
+    Cairo.save
-  Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
+    Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
-  Cairo.scale zoomFactor zoomFactor
+    Cairo.scale zoomFactor zoomFactor
-  Cairo.translate ( -cx ) ( -cy )
+    Cairo.translate ( -cx ) ( -cy )
   
-  let
+    let
-    Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) strokes
+      translatedStrokes :: [ Stroke ]
-  rdrPaths
+      renderSelectionRect :: Cairo.Render ()
-  rdrPoints
+      ( translatedStrokes, renderSelectionRect )
-  for_ mbOverlay ( renderOverlay cols zoomFactor )
+        = case mbHoldEvent of
+            Nothing
+              -> ( strokes doc, pure () )
+            Just ( SelectionHold p0, p1 )
+              -> ( strokes doc, renderSelectionRectangle cols zoomFactor p0 p1 )
+            Just ( DragMoveHold  p0, p1 )
+              -> ( strokes $ translateSelection ( p0 --> p1 ) doc, pure () )
+      Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) translatedStrokes
+    rdrPaths
+    rdrPoints
+    renderSelectionRect
 
-  Cairo.restore
+    Cairo.restore
   
-  pure ()
+    pure ()
 
 renderStroke :: Colours -> Double -> Stroke -> Compose Renders Cairo.Render ()
 renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } )
@@ -248,8 +267,8 @@ drawCubicBezier ( Colours { path } ) zoom
   Cairo.restore
 
 
-renderOverlay :: Colours -> Double -> Overlay -> Cairo.Render ()
+renderSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
-renderOverlay ( Colours { .. } ) zoom ( SelectionRectangle ( Point2D x0 y0 ) ( Point2D x1 y1 ) ) = do
+renderSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
 
   Cairo.save
 

src/app/MetaBrush/UI/Viewport.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE BlockArguments    #-}
-{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeApplications  #-}
@@ -8,39 +6,13 @@ module MetaBrush.UI.Viewport
   ( Viewport(..), createViewport )
   where
 
--- base
-import Control.Monad
-  ( void )
-import Data.Foldable
-  ( for_ )
-
--- containers
-import Data.IntMap.Strict
-  ( IntMap )
-
--- gi-cairo-connector
-import qualified GI.Cairo.Render.Connector as Cairo
-  ( renderWithContext )
-
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
--- stm
-import qualified Control.Concurrent.STM.TVar as STM
-  ( TVar, readTVarIO )
-
 -- MetaBrush
-import MetaBrush.Asset.Colours
-  ( Colours )
-import MetaBrush.Document
-  ( Document(..), currentDocument
-  , Overlay
-  )
-import MetaBrush.Render.Document
-  ( renderDocument )
 import MetaBrush.Render.Util
   ( widgetAddClass )
 
@@ -51,14 +23,8 @@ data Viewport
   { viewportDrawingArea :: !GTK.DrawingArea
   }
 
-createViewport
+createViewport :: GTK.Grid -> IO Viewport
-  :: Colours
+createViewport viewportGrid = do
-  -> STM.TVar ( Maybe Int )
-  -> STM.TVar ( IntMap Document )
-  -> STM.TVar ( Maybe Overlay )
-  -> GTK.Grid
-  -> IO Viewport
-createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do
   
   widgetAddClass viewportGrid "viewport"
   
@@ -139,18 +105,4 @@ createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewport
   widgetAddClass viewportHScrollbar "viewportScrollbar"
   widgetAddClass viewportVScrollbar "viewportScrollbar"
 
-  -----------------
-  -- Rendering
-
-  void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do
-    -- Get the relevant document information
-    mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
-    mbOverlay <- STM.readTVarIO overlayTVar
-    for_ mbDoc \ doc -> do
-      ( `Cairo.renderWithContext` ctx ) $ do
-        viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
-        viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
-        renderDocument colours ( viewportWidth, viewportHeight ) doc mbOverlay
-    pure True
-
   pure ( Viewport { .. } )