add selection UI

MetaBrush.cabal

@@ -30,6 +30,8 @@ common common
           >= 4.13 && < 4.16
       , acts
           ^>= 0.3.1.0
+      , groups
+          ^>= 0.4.1.0
 
     default-language:
         Haskell2010
@@ -66,8 +68,6 @@ library
     build-depends:
         generic-data
           >= 0.8.0.0 && < 0.8.4.0
-      , groups
-          ^>= 0.4.1.0
       , groups-generic
           ^>= 0.1.0.0
 
@@ -92,9 +92,11 @@ executable MetaBrush
       , MetaBrush.Asset.Tools
       , MetaBrush.Asset.WindowIcons
       , MetaBrush.Document
+      , MetaBrush.Document.Selection
       , MetaBrush.Event
       , MetaBrush.Render.Document
       , MetaBrush.Render.Util
+      , MetaBrush.Time
       , MetaBrush.UI.Coordinates
       , MetaBrush.UI.FileBar
       , MetaBrush.UI.InfoBar

app/Main.hs

@@ -58,11 +58,14 @@ import MetaBrush.Asset.Logo
 import MetaBrush.Document
   ( Document(..), AABB(..)
   , Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
+  , Overlay
   )
 import MetaBrush.Event
   ( handleEvents )
 import MetaBrush.Render.Util
   ( widgetAddClass, widgetAddClasses )
+import MetaBrush.Time
+  ( Time )
 import MetaBrush.UI.FileBar
   ( createFileBar )
 import MetaBrush.UI.InfoBar
@@ -72,7 +75,7 @@ import MetaBrush.UI.Menu
 import MetaBrush.UI.Panels
   ( createPanelBar )
 import MetaBrush.UI.ToolBar
-  ( createToolBar )
+  ( Tool(..), Mode(..), createToolBar )
 import MetaBrush.UI.Viewport
   ( Viewport(..), createViewport )
 import qualified Paths_MetaBrush as Cabal
@@ -142,7 +145,12 @@ main = do
 
   activeDocumentTVar <- STM.newTVarIO @( Maybe Int       )                Nothing
   openDocumentsTVar  <- STM.newTVarIO @( IntMap Document )                testDocuments
+  mousePosTVar       <- STM.newTVarIO @( Maybe ( Point2D Double ) )       Nothing
+  mouseHoldTVar      <- STM.newTVarIO @( Maybe ( Point2D Double, Time ) ) Nothing
   pressedKeysTVar    <- STM.newTVarIO @[ Word32 ]                         []
+  toolTVar           <- STM.newTVarIO @Tool                               Selection
+  modeTVar           <- STM.newTVarIO @Mode                               Path
+  overlayTVar        <- STM.newTVarIO @( Maybe Overlay )                  Nothing
 
   ---------------------------------------------------------
   -- Initialise GTK
@@ -251,7 +259,7 @@ main = do
   ---------------------------------------------------------
   -- Tool bar
 
-  _ <- createToolBar colours toolBar
+  _ <- createToolBar toolTVar modeTVar colours toolBar
 
   ---------------------------------------------------------
   -- Main viewport
@@ -261,6 +269,7 @@ main = do
       colours
       activeDocumentTVar
       openDocumentsTVar
+      overlayTVar
       viewportGrid
 
   ---------------------------------------------------------
@@ -290,7 +299,10 @@ main = do
   -- Actions
 
   handleEvents
-    activeDocumentTVar openDocumentsTVar pressedKeysTVar
+    activeDocumentTVar openDocumentsTVar
+    mousePosTVar mouseHoldTVar pressedKeysTVar
+    toolTVar modeTVar
+    overlayTVar
     window viewportDrawingArea infoBarElements
 
   ---------------------------------------------------------

assets/theme.css

@@ -72,7 +72,12 @@
 .glass {
   color: rgba(156, 231, 255, 0.5);
 }
-
+.selection {
+  color: rgba(161,201,236,0.5)
+}
+.selectionOutline {
+  color: rgb(74,150,218);
+}
 
 
 /* Proper CSS styling */

src/app/MetaBrush/Asset/Colours.hs

@@ -51,6 +51,8 @@ data ColourRecord a
   , tabScrollbar        :: !a
   , magnifier           :: !a
   , glass               :: !a
+  , selection           :: !a
+  , selectionOutline    :: !a
   }
   deriving stock ( Show, Functor, Foldable, Traversable )
 
@@ -90,6 +92,8 @@ colourNames = Colours
   , tabScrollbar        = ColourName "tabScrollbar"      BackgroundColour [ GTK.StateFlagsNormal ]
   , magnifier           = ColourName "magnifier"                   Colour [ GTK.StateFlagsNormal ]
   , glass               = ColourName "glass"                       Colour [ GTK.StateFlagsNormal ]
+  , selection           = ColourName "selection"                   Colour [ GTK.StateFlagsNormal ]
+  , selectionOutline    = ColourName "selectionOutline"            Colour [ GTK.StateFlagsNormal ]
   }
 
 type Colours = ColourRecord GDK.RGBA

src/app/MetaBrush/Document.hs

@@ -72,6 +72,10 @@ data FocusState
   | Selected
   deriving stock Show
 
+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

@@ -0,0 +1,21 @@
+module MetaBrush.Document.Selection
+  ( selectAt, selectRectangle )
+  where
+
+-- base
+import Data.Word
+  ( Word32 )
+
+-- MetaBrush
+import Math.Vector2D
+  ( Point2D(..) )
+import MetaBrush.Document
+  ( Document(..) )
+
+--------------------------------------------------------------------------------
+
+selectAt :: [ Word32 ] -> Point2D Double -> Document -> Document
+selectAt _ _ doc = doc
+
+selectRectangle :: [ Word32 ] -> Point2D Double -> Point2D Double -> Document -> Document
+selectRectangle _ _ _ doc = doc

src/app/MetaBrush/Event.hs

@@ -11,9 +11,6 @@ import Control.Monad
   ( unless )
 import Data.Foldable
   ( for_ )
--- base
-import Data.Semigroup
-  ( Arg(..), Min(..) )
 import Data.Word
   ( Word32 )
 
@@ -38,10 +35,12 @@ 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
-  ( TVar, readTVar, readTVarIO, writeTVar )
+  ( TVar, readTVar, readTVarIO, writeTVar, swapTVar )
 
 -- MetaBrush
 import Math.Module
@@ -49,22 +48,43 @@ import Math.Module
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Document
-  ( Document(..), currentDocument )
+  ( Document(..), Overlay(..) )
+import MetaBrush.Document.Selection
+  ( selectAt, selectRectangle )
+import MetaBrush.Time
+  ( Time, monotonicTime, DTime(DSeconds) )
 import MetaBrush.UI.Coordinates
-  ( closestPoint, toViewportCoordinates )
+  ( toViewportCoordinates )
 import MetaBrush.UI.InfoBar
   ( InfoBar, InfoData(..), updateInfoBar )
+import MetaBrush.UI.ToolBar
+  ( Tool(..), Mode )
 
 --------------------------------------------------------------------------------
 
-handleEvents :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.Window -> GTK.DrawingArea -> InfoBar -> IO ()
+handleEvents
-handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewportDrawingArea infoBar = do
+  :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> 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 viewportDrawingArea infoBar )
+          ( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar overlayTVar viewportDrawingArea infoBar )
     _ <- GTK.onWidgetScrollEvent        viewportDrawingArea
-        ( handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar )
+          ( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea infoBar )
+    _ <- GTK.onWidgetButtonPressEvent   viewportDrawingArea
+          ( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea )
+    _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
+          ( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea )
 
     -- Keyboard events
     _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   pressedKeysTVar )
@@ -78,13 +98,27 @@ handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewpor
 --------------------------------------------------------------------------------
 -- Mouse events.
 
-handleMotionEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> GTK.DrawingArea -> InfoBar -> GDK.EventMotion -> IO Bool
+handleMotionEvent
-handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar eventMotion = do
+  :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) )
+  -> STM.TVar Tool
+  -> STM.TVar ( Maybe Overlay )
+  -> GTK.DrawingArea -> InfoBar
+  -> GDK.EventMotion
+  -> IO Bool
+handleMotionEvent
+  activeDocumentTVar openDocumentsTVar
+  mousePosTVar mouseHoldTVar
+  toolTVar
+  overlayTVar
+  viewportDrawingArea infoBar
+  eventMotion
+  = do
 
     mbActiveDoc <- STM.readTVarIO activeDocumentTVar
     for_ mbActiveDoc \ i -> do
       docs <- STM.readTVarIO openDocumentsTVar
-    for_ ( IntMap.lookup i docs ) \ doc@( Document { .. } ) -> do
+      for_ ( IntMap.lookup i docs ) \ ( Document { .. } ) -> do
 
         ----------------------------------------------------------
         -- Update mouse position in info bar on mouse move event.
@@ -107,11 +141,32 @@ handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoB
               , botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
               }
         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 [ Word32 ] -> GTK.DrawingArea -> InfoBar -> GDK.EventScroll -> IO Bool
+handleScrollEvent
-handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar scrollEvent = do
+  :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
+  -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) )  -> STM.TVar [ Word32 ]
+  -> STM.TVar Tool -> STM.TVar ( Maybe Overlay )
+  -> GTK.DrawingArea -> InfoBar
+  -> GDK.EventScroll
+  -> IO Bool
+handleScrollEvent
+  activeDocumentTVar openDocumentsTVar
+  mousePosTVar mouseHoldTVar pressedKeysTVar
+  toolTVar overlayTVar
+  viewportDrawingArea infoBar
+  scrollEvent
+  = do
 
     dx <- GDK.getEventScrollDeltaX scrollEvent
     dy <- GDK.getEventScrollDeltaY scrollEvent
@@ -162,27 +217,143 @@ handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportD
                 in doc { viewportCenter = newCenter }
             docs' :: IntMap Document
             docs' = IntMap.insert i newDoc docs
-        STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
+            finalZoomFactor :: Double
-        GTK.widgetQueueDraw viewportDrawingArea
+            finalZoomFactor = zoomFactor     newDoc
-
+            finalCenter :: Point2D Double
-        let
+            finalCenter     = viewportCenter newDoc
-          newZoomFactor :: Double
+            toFinalViewport :: Point2D Double -> Point2D Double
-          newZoomFactor = zoomFactor     newDoc
+            toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
-          newCenter :: Point2D Double
+            finalMousePos :: Point2D Double
-          newCenter     = viewportCenter newDoc
+            finalMousePos = toFinalViewport ( Point2D x y )
-          toNewViewport :: Point2D Double -> Point2D Double
-          toNewViewport = toViewportCoordinates newZoomFactor ( viewportWidth, viewportHeight ) newCenter
             infoData :: InfoData
             infoData = InfoData
-            { zoom = zoomFactor newDoc
+              { zoom = finalZoomFactor
-            , mousePos
+              , mousePos = finalMousePos
-            , topLeftPos  = toNewViewport ( Point2D 0 0 )
+              , topLeftPos  = toFinalViewport ( Point2D 0 0 )
-            , botRightPos = toNewViewport ( Point2D viewportWidth viewportHeight )
+              , botRightPos = toFinalViewport ( Point2D viewportWidth viewportHeight )
               }
           updateInfoBar infoBar infoData
+          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 ]
+  -> GTK.DrawingArea
+  -> GDK.EventButton
+  -> IO Bool
+handleMouseButtonEvent
+  activeDocumentTVar openDocumentsTVar
+  mousePosTVar mouseHoldTVar _pressedKeysTVar
+  viewportDrawingArea
+  mouseClickEvent
+  = do
+
+    button <- GDK.getEventButtonButton mouseClickEvent
+    case button of
+      -- left mouse button
+      1 -> do
+        mbActiveDoc <- STM.readTVarIO activeDocumentTVar
+        for_ mbActiveDoc \ i -> do
+          docs <- STM.readTVarIO openDocumentsTVar
+          for_ ( IntMap.lookup i docs ) \ ( Document { zoomFactor, viewportCenter } ) -> do
+            x <- GDK.getEventButtonX mouseClickEvent
+            y <- GDK.getEventButtonY mouseClickEvent
+            viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
+            viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+            let
+              toViewport :: Point2D Double -> Point2D Double
+              toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
+              pos :: Point2D Double
+              pos = toViewport ( Point2D x y )
+            time <- monotonicTime
+            STM.atomically do
+              STM.writeTVar mousePosTVar  ( Just pos )
+              STM.writeTVar mouseHoldTVar ( Just ( pos, time ) )
+      _ -> 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 Tool
+  -> STM.TVar ( Maybe Overlay )
+  -> GTK.DrawingArea
+  -> GDK.EventButton
+  -> IO Bool
+handleMouseButtonRelease
+  activeDocumentTVar openDocumentsTVar
+  mousePosTVar mouseHoldTVar pressedKeysTVar
+  toolTVar
+  overlayTVar
+  viewportDrawingArea
+  mouseReleaseEvent
+  = do
+
+    button <- GDK.getEventButtonButton mouseReleaseEvent
+    case button of
+      -- left mouse button
+      1 -> do
+        mbActiveDoc <- STM.readTVarIO activeDocumentTVar
+        for_ mbActiveDoc \ i -> do
+          docs <- STM.readTVarIO openDocumentsTVar
+          for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
+            x <- GDK.getEventButtonX mouseReleaseEvent
+            y <- GDK.getEventButtonY mouseReleaseEvent
+            viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
+            viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+            let
+              toViewport :: Point2D Double -> Point2D Double
+              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
+                newDoc :: Document
+                newDoc = case tool of
+                  Selection
+                    | Just ( pos0, t0 ) <- mbHoldPos
+                    , pos0 /= pos
+                    , ( t0 --> t ) > DSeconds 0.3
+                    -> selectRectangle pressedKeys pos0 pos doc
+                    | otherwise
+                    -> selectAt pressedKeys pos doc
+                  Pen -> doc -- TODO
+                newDocs :: IntMap Document
+                newDocs = IntMap.insert i newDoc docs
+              STM.writeTVar openDocumentsTVar newDocs
+              STM.writeTVar mousePosTVar  ( Just pos )
+            GTK.widgetQueueDraw viewportDrawingArea
+
+      -- any other mouse button: no action (for the moment)
+      _ -> pure ()
+
+    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,7 +11,7 @@ module MetaBrush.Render.Document
 
 -- base
 import Data.Foldable
-  ( traverse_ )
+  ( for_, traverse_ )
 import Data.Functor.Compose
   ( Compose(..) )
 import Data.Int
@@ -32,6 +32,7 @@ import MetaBrush.Asset.Colours
 import MetaBrush.Document
   ( Document(..)
   , Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
+  , Overlay(..)
   )
 import MetaBrush.Render.Util
   ( withRGBA )
@@ -55,8 +56,8 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
 
 --------------------------------------------------------------------------------
 
-renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render ()
+renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Maybe Overlay -> Cairo.Render ()
-renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do
+renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) mbOverlay = do
 
   Cairo.save
   Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
@@ -64,9 +65,10 @@ renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCente
   Cairo.translate ( -cx ) ( -cy )
 
   let
-    Renders { renderPoints, renderPaths } = traverse_ ( renderStroke cols zoomFactor ) strokes
+    Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) strokes
-  renderPaths
+  rdrPaths
-  renderPoints
+  rdrPoints
+  for_ mbOverlay ( renderOverlay cols zoomFactor )
 
   Cairo.restore
 
@@ -244,3 +246,24 @@ drawCubicBezier ( Colours { path } ) zoom
   Cairo.stroke
 
   Cairo.restore
+
+
+renderOverlay :: Colours -> Double -> Overlay -> Cairo.Render ()
+renderOverlay ( Colours { .. } ) zoom ( SelectionRectangle ( Point2D x0 y0 ) ( Point2D x1 y1 ) ) = do
+
+  Cairo.save
+
+  Cairo.moveTo x0 y0
+  Cairo.lineTo x1 y0
+  Cairo.lineTo x1 y1
+  Cairo.lineTo x0 y1
+  Cairo.closePath
+
+  Cairo.setLineWidth ( 1 / zoom )
+  withRGBA selection Cairo.setSourceRGBA
+  Cairo.fillPreserve
+
+  withRGBA selectionOutline Cairo.setSourceRGBA
+  Cairo.stroke
+
+  Cairo.restore

src/app/MetaBrush/Time.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PatternSynonyms            #-}
+
+module MetaBrush.Time
+  ( Time(..), DTime(DSeconds, ..), dSeconds 
+  , pprSeconds
+  , monotonicTime
+  )
+  where
+
+-- base
+import Data.Int
+  ( Int64 )
+import Data.Semigroup
+  ( Sum(..) )
+
+-- acts
+import Data.Act
+  ( Act, Torsor )
+
+-- gi-glib
+import qualified GI.GLib.Functions as GLib
+  ( getMonotonicTime )
+
+-- groups
+import Data.Group
+  ( Group )
+
+-- transformers
+import Control.Monad.IO.Class
+  ( MonadIO )
+
+--------------------------------------------------------------------------------
+
+newtype Time = Seconds { seconds :: Double }
+  deriving newtype ( Eq, Ord )
+  deriving stock   Show
+  deriving ( Act DTime, Torsor DTime )
+    via DTime
+
+newtype DTime = DTime { dTime :: Time }
+  deriving stock   Show
+  deriving newtype ( Eq, Ord )
+  deriving ( Semigroup, Monoid, Group )
+     via ( Sum Double )
+
+{-# COMPLETE DSeconds #-}
+pattern DSeconds :: Double -> DTime
+pattern DSeconds secs = DTime ( Seconds secs )
+
+dSeconds :: DTime -> Double
+dSeconds ( DSeconds secs ) = secs
+
+pprSeconds :: ( String, String, String ) -> Time -> String
+pprSeconds ( h_name, m_name, s_name ) ( Seconds secs ) = pm <> absolute
+  where
+    pm :: String
+    pm
+      | secs <= (-1) = "-"
+      | otherwise    = ""
+    h, r, m, s :: Int64
+    (h,r) = ( round $ abs secs ) `divMod` 3600
+    (m,s) = r                    `divMod` 60
+    fixed2 :: String -> String
+    fixed2 []  = "00"
+    fixed2 [x] = ['0', x]
+    fixed2 xs  = xs
+    absolute
+      | h > 0     = show h <> h_name <> fixed2 (show m) <> m_name <> fixed2 (show s) <> s_name
+      | m > 0     =                             show m  <> m_name <> fixed2 (show s) <> s_name
+      | otherwise =                                                          show s  <> s_name
+
+monotonicTime :: MonadIO m => m Time
+monotonicTime = Seconds . ( * 1e-6 ) . fromIntegral <$> GLib.getMonotonicTime

src/app/MetaBrush/UI/Coordinates.hs

@@ -18,14 +18,16 @@ import Data.Act
   )
 
 -- MetaBrush
+import qualified Math.Bezier.Cubic     as Cubic
+  ( Bezier(..), closestPoint )
 import qualified Math.Bezier.Quadratic as Quadratic
   ( Bezier(..), closestPoint )
 import Math.Module
-  ( (*^), squaredNorm )
+  ( (*^), squaredNorm, closestPointToLine )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Document
-  ( Stroke(..) )
+  ( Stroke(..), StrokePoint(..), PointType(..) )
 
 --------------------------------------------------------------------------------
 
@@ -36,15 +38,32 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente
   • viewportCenter
 
 -- | Find the closest point in a set of strokes.
-closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Point2D Double )
+closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) )
-closestPoint = undefined
+closestPoint c ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } ) = go pt0 pts
-{-
-closestPoint c ( Stroke pts ) = go pts
   where
-    go :: [ Point2D Double ] -> ArgMin Double ( Point2D Double )
+    res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
-    go []  = error "'closestPoint': empty stroke"
+    res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
-    go [p] = Min ( Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) p )
+    go :: StrokePoint -> [ StrokePoint ] -> ArgMin Double ( Maybe ( Point2D Double ) )
-    go (p0:p1:p2:ps)
+    go p0 [] = res ( strokePoint p0 )
-      =  fmap ( fmap snd ) ( Quadratic.closestPoint @(Vector2D Double) ( Quadratic.Bezier { .. } ) c )
+    -- Line.
-      <> go (p2:ps)
+    go p0 ( p1 : ps )
--}
+      | PathPoint <- pointType p1
+      = res ( closestPointToLine @( Vector2D Double ) c ( strokePoint p0 ) ( strokePoint p1 ) )
+      <> go p1 ps
+    -- Quadratic Bézier curve.
+    go p0 ( p1 : p2 : ps )
+      | ControlPoint <- pointType p1
+      , PathPoint    <- pointType p2
+      = fmap ( fmap ( Just . snd ) )
+        ( Quadratic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Quadratic.Bezier { .. } ) c )
+      <> go p2 ps
+    -- Cubic Bézier curve.
+    go p0 ( p1 : p2 : p3 : ps )
+      | ControlPoint <- pointType p1
+      , ControlPoint <- pointType p1
+      , PathPoint    <- pointType p3
+      = fmap ( fmap ( Just . snd ) )
+        ( Cubic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Cubic.Bezier { .. } ) c )
+      <> go p3 ps
+    go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 : ps )
+closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing

src/app/MetaBrush/UI/ToolBar.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE BlockArguments     #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.UI.ToolBar
-  ( ToolBar(..), createToolBar )
+  ( Tool(..), Mode(..)
+  , ToolBar(..), createToolBar
+  )
   where
 
 -- base
@@ -20,6 +23,12 @@ import qualified GI.Cairo.Render.Connector as Cairo
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- stm
+import qualified Control.Concurrent.STM      as STM
+  ( atomically )
+import qualified Control.Concurrent.STM.TVar as STM
+  ( TVar, writeTVar )
+
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( Colours )
@@ -32,6 +41,17 @@ import MetaBrush.Render.Util
 
 --------------------------------------------------------------------------------
 
+data Tool
+  = Selection
+  | Pen
+  deriving stock Show
+
+data Mode
+  = Path
+  | Brush
+  | Meta
+  deriving stock Show
+
 data ToolBar
   = ToolBar
   { selectionTool :: !GTK.RadioButton
@@ -41,8 +61,8 @@ data ToolBar
   , metaTool      :: !GTK.RadioButton
   }
 
-createToolBar :: Colours -> GTK.Box -> IO ToolBar
+createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.Box -> IO ToolBar
-createToolBar colours toolBar = do
+createToolBar toolTVar modeTVar colours toolBar = do
   
   widgetAddClass toolBar "toolBar"
 
@@ -52,11 +72,23 @@ createToolBar colours toolBar = do
   selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
   penTool       <- GTK.radioButtonNewFromWidget ( Just selectionTool )
 
+  _ <- GTK.onButtonClicked selectionTool
+    ( STM.atomically $ STM.writeTVar toolTVar Selection )
+  _ <- GTK.onButtonClicked penTool
+    ( STM.atomically $ STM.writeTVar toolTVar Pen )
+
+  toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
+
   pathTool  <- GTK.radioButtonNew ( [] @GTK.RadioButton )
   brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
   metaTool  <- GTK.radioButtonNewFromWidget ( Just pathTool )
 
-  toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
+  _ <- GTK.onButtonClicked pathTool
+    ( STM.atomically $ STM.writeTVar modeTVar Path )
+  _ <- GTK.onButtonClicked brushTool
+    ( STM.atomically $ STM.writeTVar modeTVar Brush )
+  _ <- GTK.onButtonClicked metaTool
+    ( STM.atomically $ STM.writeTVar modeTVar Meta )
 
   GTK.boxPackStart toolBar selectionTool True True 0
   GTK.boxPackStart toolBar       penTool True True 0

src/app/MetaBrush/UI/Viewport.hs

@@ -30,13 +30,15 @@ import qualified GI.Gtk as GTK
 
 -- stm
 import qualified Control.Concurrent.STM.TVar as STM
-  ( TVar )
+  ( TVar, readTVarIO )
 
 -- MetaBrush
 import MetaBrush.Asset.Colours
   ( Colours )
 import MetaBrush.Document
-  ( Document(..), currentDocument )
+  ( Document(..), currentDocument
+  , Overlay
+  )
 import MetaBrush.Render.Document
   ( renderDocument )
 import MetaBrush.Render.Util
@@ -53,9 +55,10 @@ createViewport
   :: Colours
   -> STM.TVar ( Maybe Int )
   -> STM.TVar ( IntMap Document )
+  -> STM.TVar ( Maybe Overlay )
   -> GTK.Grid
   -> IO Viewport
-createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do
+createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do
   
   widgetAddClass viewportGrid "viewport"
   
@@ -142,11 +145,12 @@ createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do
   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
+        renderDocument colours ( viewportWidth, viewportHeight ) doc mbOverlay
     pure True
 
   pure ( Viewport { .. } )

src/lib/Math/Bezier/Cubic.hs

@@ -20,6 +20,8 @@ module Math.Bezier.Cubic
 -- base
 import Data.List.NonEmpty
   ( NonEmpty(..) )
+import Data.Semigroup
+  ( ArgMin, Min(..), Arg(..) )
 import GHC.Generics
   ( Generic )
 
@@ -82,7 +84,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
     pt = lerp @v t q2 r1
 
 -- | Finds the closest point to a given point on a cubic Bézier curve.
-closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ( r, p )
+closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ArgMin r ( r, p )
 closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
   where
     roots :: [ r ]
@@ -102,14 +104,14 @@ closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
     a4 = 5 * v'' ^.^ v'''
     a5 = squaredNorm v'''
 
-    pickClosest :: NonEmpty r -> ( r, p )
+    pickClosest :: NonEmpty r -> ArgMin r ( r, p )
     pickClosest ( s :| ss ) = go s q nm0 ss
       where
         q :: p
         q  = bezier @v pts s
         nm0 :: r
         nm0 = squaredNorm ( c --> q :: v )
-        go t p _  []  = ( t, p )
+        go t p nm []  = Min ( Arg nm ( t, p ) )
         go t p nm ( t' : ts )
           | nm' < nm  = go t' p' nm' ts
           | otherwise = go t  p  nm  ts

src/lib/Math/Module.hs

@@ -6,6 +6,7 @@
 module Math.Module
   ( Module(..), lerp
   , Inner(..), squaredNorm
+  , proj, projC, closestPointToLine
   )
   where
 
@@ -44,5 +45,30 @@ class Module r m => Inner r m where
   (^.^) :: m -> m -> r
 
 -- | Squared norm of a vector, computed using the inner product.
-squaredNorm :: Inner r m => m -> r
+squaredNorm :: forall m r. Inner r m => m -> r
 squaredNorm v = v ^.^ v
+
+-- | Projects the first argument onto the second.
+proj :: forall m r. ( Inner r m, Fractional r ) => m -> m -> m
+proj x y = projC x y *^ y
+
+-- | Projection constant: how far along the projection of the first vector lands along the second vector.
+projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r
+projC x y = x ^.^ y / squaredNorm y
+
+closestPointToLine
+  :: forall v r p
+  . ( Inner r v, Torsor v p, Fractional r, Ord r )
+  => p -> p -> p -> p
+closestPointToLine c p0 p1
+  | t <= 0
+  = p0
+  | t >= 1
+  = p1
+  | otherwise
+  = ( t *^ v01 ) • p0
+  where
+    v01 :: v
+    v01 = p0 --> p1
+    t :: r
+    t = projC ( p0 --> c ) v01

src/lib/Math/Vector2D.hs

@@ -37,12 +37,12 @@ import Math.Module
 --------------------------------------------------------------------------------
 
 data Point2D a = Point2D !a !a
-  deriving stock ( Show, Generic, Functor, Foldable, Traversable )
+  deriving stock ( Show, Eq, Generic, Functor, Foldable, Traversable )
   deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
     via Vector2D a
 
 newtype Vector2D a = Vector2D { tip :: Point2D a }
-  deriving stock ( Show, Functor, Foldable, Traversable )
+  deriving stock ( Show, Eq, Functor, Foldable, Traversable )
   deriving ( Semigroup, Monoid, Group )
     via GenericProduct ( Point2D ( Sum a ) )