create/move/delete guides: drag from ruler area

MetaBrush.cabal

@@ -109,6 +109,7 @@ executable MetaBrush
       , MetaBrush.Context
       , MetaBrush.Document
       , MetaBrush.Document.Draw
+      , MetaBrush.Document.Guide
       , MetaBrush.Document.Selection
       , MetaBrush.Document.Serialise
       , MetaBrush.Event

app/Main.hs

@@ -13,6 +13,8 @@ module Main
 -- base
 import Control.Monad
   ( void )
+import Data.Foldable
+  ( for_ )
 import Data.Int
   ( Int32 )
 import System.Exit
@@ -61,6 +63,8 @@ import Math.Bezier.Stroke
   ( StrokePoint(..) )
 import Math.Vector2D
   ( Point2D(..) )
+import MetaBrush.Action
+  ( ActionOrigin(..) )
 import MetaBrush.Asset.Brushes
   ( ellipse, rect )
 import MetaBrush.Asset.Colours
@@ -74,26 +78,28 @@ import MetaBrush.Context
   , withCurrentDocument
   )
 import MetaBrush.Document
-  ( Document(..), Stroke(..)
-  , FocusState(..)
+  ( Document(..), emptyDocument
+  , Stroke(..), FocusState(..)
   , PointData(..), BrushPointData(..)
   )
 import MetaBrush.Event
   ( handleEvents )
 import MetaBrush.Render.Document
-  ( renderDocument, blankRender )
+  ( renderDocument, renderGuides, blankRender )
 import MetaBrush.UI.FileBar
   ( FileBar(..), createFileBar )
 import MetaBrush.UI.InfoBar
-  ( InfoBar(..), createInfoBar )
+  ( InfoBar(..), createInfoBar, updateInfoBar )
 import MetaBrush.UI.Menu
-  ( createMenuBar )
+  ( createMenuBar
+--, MenuItem(..), Menu(..), FileMenu(..), EditMenu(..), ViewMenu(..)
+  )
 import MetaBrush.UI.Panels
   ( createPanelBar )
 import MetaBrush.UI.ToolBar
   ( Tool(..), Mode(..), createToolBar )
 import MetaBrush.UI.Viewport
-  ( Viewport(..), createViewport )
+  ( Viewport(..), Ruler(..), createViewport )
 import MetaBrush.Unique
   ( newUniqueSupply
   , Unique, unsafeUnique
@@ -108,50 +114,35 @@ import qualified Paths_MetaBrush as Cabal
 
 testDocuments :: Map Unique Document
 testDocuments = uniqueMapFromList
-  [ Document
-    { displayName    = "Closed"
-    , mbFilePath     = Nothing
-    , unsavedChanges = False
-    , viewportCenter = Point2D 50 50
-    , zoomFactor     = 1
-    , documentUnique = unsafeUnique 0
-    , strokes        = [ Stroke
-                       { strokeName    = "Ellipse"
-                       , strokeVisible = True
-                       , strokeUnique  = unsafeUnique 10
-                       , strokePoints  = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
-                       }
-                       ]
+  [ ( emptyDocument "Closed" ( unsafeUnique 0 ) )
+    { strokes =
+      [ Stroke
+        { strokeName    = "Ellipse"
+        , strokeVisible = True
+        , strokeUnique  = unsafeUnique 10
+        , strokePoints  = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
+        }
+      ]
     }
-  , Document
-    { displayName    = "Line"
-    , mbFilePath     = Nothing
-    , unsavedChanges = False
-    , viewportCenter = Point2D 0 0
-    , zoomFactor     = 1
-    , documentUnique = unsafeUnique 1
-    , strokes        = [ Stroke
-                       { strokeName    = "Line"
-                       , strokeVisible = True
-                       , strokeUnique  = unsafeUnique 11
-                       , strokePoints  = linePts
-                       }
-                       ]
+  , ( emptyDocument "Line" ( unsafeUnique 1 ) )
+    { strokes =
+      [ Stroke
+        { strokeName    = "Line"
+        , strokeVisible = True
+        , strokeUnique  = unsafeUnique 11
+        , strokePoints  = linePts
+        }
+      ]
     }
-  , Document
-    { displayName    = "Short line"
-    , mbFilePath     = Nothing
-    , unsavedChanges = False
-    , viewportCenter = Point2D 0 0
-    , zoomFactor     = 1
-    , documentUnique = unsafeUnique 2
-    , strokes        = [ Stroke
-                       { strokeName    = "ShortLine"
-                       , strokeVisible = True
-                       , strokeUnique  = unsafeUnique 12
-                       , strokePoints  = linePts2
-                       }
-                       ]
+  , ( emptyDocument "Short line" ( unsafeUnique 2 ) )
+    { strokes =
+      [ Stroke
+        { strokeName    = "ShortLine"
+        , strokeVisible = True
+        , strokeUnique  = unsafeUnique 12
+        , strokePoints  = linePts2
+        }
+      ]
     }
   ]
   where
@@ -194,7 +185,7 @@ main = do
   -- Put all these stateful variables in a record for conciseness.
   let
     variables :: Variables
-    variables = Variables { .. }
+    variables = Variables {..}
 
   ---------------------------------------------------------
   -- Initialise GTK
@@ -292,7 +283,7 @@ main = do
   ---------------------------------------------------------
   -- Main viewport
 
-  Viewport { viewportDrawingArea } <- createViewport viewportGrid
+  viewport@( Viewport { .. } ) <- createViewport viewportGrid
 
   -----------------
   -- Viewport rendering
@@ -301,22 +292,47 @@ main = do
     -- Get the relevant document information
     viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
     viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
-    mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document { .. } ) -> do
+    mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do
       mbMousePos     <- STM.readTVar mousePosTVar
       mbHoldAction   <- STM.readTVar mouseHoldTVar
       mbPartialPath  <- STM.readTVar partialPathTVar
       mode           <- STM.readTVar modeTVar
-      pure $
+      pure do
         renderDocument
           colours mode ( viewportWidth, viewportHeight )
           mbMousePos mbHoldAction mbPartialPath
           doc
+        renderGuides
+          colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
+          mbMousePos mbHoldAction
+          doc
     case mbRender of
       Just render -> Cairo.renderWithContext render                  ctx
       Nothing     -> Cairo.renderWithContext ( blankRender colours ) ctx
 
     pure True
 
+  for_ [ ( rulerCornerDrawingArea, RulerCorner )
+       , ( topRulerDrawingArea, TopRuler )
+       , ( leftRulerDrawingArea, LeftRuler
+       ) ] \ ( rulerDrawingArea, ruler ) -> do
+    void $ GTK.onWidgetDraw rulerDrawingArea \ ctx -> do
+      viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
+      viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
+      width  <- GTK.widgetGetAllocatedWidth  rulerDrawingArea
+      height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
+      mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do
+        mbMousePos     <- STM.readTVar mousePosTVar
+        mbHoldAction   <- STM.readTVar mouseHoldTVar
+        pure do
+          renderGuides
+            colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height )
+            mbMousePos mbHoldAction
+            doc
+      for_ mbRender \ render -> Cairo.renderWithContext render ctx
+
+      pure True
+
   ---------------------------------------------------------
   -- Tool bar
 
@@ -329,12 +345,12 @@ main = do
 
   ---------------------------------------------------------
   -- File bar
-
+  
   fileBar@( FileBar { fileBarBox } ) <-
     createFileBar
       colours
       variables
-      window titleBar title viewportDrawingArea infoBar
+      window titleBar title viewport infoBar
 
   GTK.boxPackStart mainView fileBarBox   False False 0
   GTK.boxPackStart mainView viewportGrid True  True  0
@@ -342,12 +358,14 @@ main = do
 
   let
     uiElements :: UIElements
-    uiElements = UIElements { .. }
+    uiElements = UIElements {..}
 
   ------------
   -- Menu bar
 
-  _ <- createMenuBar uiElements variables colours
+  _menu <- createMenuBar uiElements variables colours
+
+  --GTK.widgetSetSensitive ( menuItem $ close $ menuItemSubmenu $ file menu ) False
 
   ---------------------------------------------------------
   -- Panels
@@ -363,6 +381,7 @@ main = do
   -- GTK main loop
 
   GTK.widgetShowAll window
+  updateInfoBar viewportDrawingArea infoBar variables -- need to update the info bar after widgets have been realized
   GTK.main
 
   exitSuccess

assets/theme.css

@@ -75,6 +75,9 @@
 .tabScrollbar {
   background-color: rgba(48, 45, 38, 0.66);
 }
+.guide {
+  color: rgba(28, 196, 79, 0.66)
+}
 .magnifier {
   color: rgb(236, 223, 210);
 }
@@ -419,3 +422,8 @@ tooltip {
   font-size:  10px;
   -GtkWidget-window-dragging: true;
 }
+
+.infoBarInfo {
+  margin-left: -4px;
+  padding-right: 16px;
+}

src/app/MetaBrush/Action.hs

@@ -52,12 +52,22 @@ import System.Directory
 import System.FilePath
   ( (</>), (<.>), takeExtension )
 
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- lens
+import Control.Lens
+  ( over, set )
+import Control.Lens.At
+  ( ix, at )
+
 -- stm
 import qualified Control.Concurrent.STM as STM
   ( atomically )
@@ -74,18 +84,20 @@ import Math.Vector2D
 import MetaBrush.Context
   ( UIElements(..), Variables(..)
   , Modifier(..), modifierKey
-  , HoldAction(..), PartialPath(..)
+  , HoldAction(..), GuideAction(..), PartialPath(..)
   , currentDocument, withCurrentDocument
   , PureDocModification(..), DocModification(..)
   , modifyingCurrentDocument
   , updateTitle
   )
 import MetaBrush.Document
-  ( Document(..)
+  ( Document(..), Guide(..)
   , PointData(..), FocusState(..)
   )
 import MetaBrush.Document.Draw
   ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
+import MetaBrush.Document.Guide
+  ( selectGuide, addGuide )
 import MetaBrush.Document.Selection
   ( SelectionMode(..), selectionMode
   , selectAt, selectRectangle
@@ -103,6 +115,8 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( TabLocation(..), newFileTab, removeFileTab )
 import MetaBrush.UI.ToolBar
   ( Tool(..) )
+import MetaBrush.UI.Viewport
+  ( Viewport(..), Ruler(..) )
 import MetaBrush.Unique
   ( Unique )
 import MetaBrush.Util
@@ -138,7 +152,7 @@ data OpenFile = OpenFile TabLocation
   deriving stock Show
 
 instance HandleAction OpenFile where
-  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFile tabLoc ) = do
+  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFile tabLoc ) = do
     fileChooser <-
       GTK.fileChooserNativeNew ( Just "Open MetaBrush document..." ) ( Just window )
         GTK.FileChooserActionOpen
@@ -167,7 +181,7 @@ data OpenFolder = OpenFolder TabLocation
   deriving stock Show
 
 instance HandleAction OpenFolder where
-  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFolder tabLoc ) = do
+  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFolder tabLoc ) = do
     fileChooser <-
       GTK.fileChooserNativeNew ( Just "Select folder..." ) ( Just window )
         GTK.FileChooserActionSelectFolder
@@ -197,7 +211,7 @@ data Save = Save
   deriving stock Show
 
 instance HandleAction Save where
-  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) _ =
+  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ =
     save uiElts vars True
 
 save :: UIElements -> Variables -> Bool -> IO ()
@@ -249,7 +263,7 @@ saveAs uiElts vars keepOpen = do
         pure $ UpdateDocToAndThen Nothing ( saveDocument savePath doc' )
 
 askForSavePath :: UIElements -> IO ( Maybe FilePath )
-askForSavePath ( UIElements { .. } ) = do
+askForSavePath ( UIElements {..} ) = do
   fileChooser <-
     GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
       GTK.FileChooserActionSave
@@ -287,44 +301,47 @@ pattern SaveAndClose = 2
 pattern CancelClose  = 3
 
 instance HandleAction Close where
-  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) close = do
-    mbDoc <- case close of
-      CloseActive      -> STM.atomically ( currentDocument vars )
-      CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
-    case mbDoc of
-      Nothing -> pure () -- could show a warning message
-      Just ( Document { displayName, documentUnique, unsavedChanges } )
-        | unsavedChanges
-        -> do
-          dialog <- GTK.new GTK.MessageDialog []
-          GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
-          GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
-          GTK.setWindowResizable dialog False
-          GTK.setWindowDecorated dialog False
-          GTK.windowSetTransientFor dialog ( Just window )
-          GTK.windowSetModal dialog True
-          widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
-          closeButton  <- GTK.dialogAddButton dialog "Close"          JustClose
-          saveButton   <- GTK.dialogAddButton dialog "Save and close" SaveAndClose
-          cancelButton <- GTK.dialogAddButton dialog "Cancel"         CancelClose
-          GTK.dialogSetDefaultResponse dialog 1
-          for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
-          choice <- GTK.dialogRun dialog
-          GTK.widgetDestroy dialog
-          case choice of
-            JustClose    -> closeDocument documentUnique
-            SaveAndClose -> save uiElts vars False
-            _            -> pure ()
-        | otherwise
-        -> closeDocument documentUnique
+  handleAction
+    uiElts@( UIElements { viewport = Viewport {..}, .. } )
+    vars@( Variables {..} )
+    close = do
+      mbDoc <- case close of
+        CloseActive      -> STM.atomically ( currentDocument vars )
+        CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
+      case mbDoc of
+        Nothing -> pure () -- could show a warning message
+        Just ( Document { displayName, documentUnique, unsavedChanges } )
+          | unsavedChanges
+          -> do
+            dialog <- GTK.new GTK.MessageDialog []
+            GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
+            GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
+            GTK.setWindowResizable dialog False
+            GTK.setWindowDecorated dialog False
+            GTK.windowSetTransientFor dialog ( Just window )
+            GTK.windowSetModal dialog True
+            widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
+            closeButton  <- GTK.dialogAddButton dialog "Close"          JustClose
+            saveButton   <- GTK.dialogAddButton dialog "Save and close" SaveAndClose
+            cancelButton <- GTK.dialogAddButton dialog "Cancel"         CancelClose
+            GTK.dialogSetDefaultResponse dialog 1
+            for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
+            choice <- GTK.dialogRun dialog
+            GTK.widgetDestroy dialog
+            case choice of
+              JustClose    -> closeDocument documentUnique
+              SaveAndClose -> save uiElts vars False
+              _            -> pure ()
+          | otherwise
+          -> closeDocument documentUnique
 
-    where
-      closeDocument :: Unique -> IO ()
-      closeDocument unique = do
-        removeFileTab vars unique
-        updateTitle window title Nothing
-        updateInfoBar viewportDrawingArea infoBar vars
-        GTK.widgetQueueDraw viewportDrawingArea
+      where
+        closeDocument :: Unique -> IO ()
+        closeDocument unique = do
+          removeFileTab vars unique
+          updateTitle window title Nothing
+          updateInfoBar viewportDrawingArea infoBar vars
+          GTK.widgetQueueDraw viewportDrawingArea
 
 ---------------------
 -- Switch document --
@@ -334,19 +351,22 @@ data SwitchTo = SwitchTo Unique
   deriving stock Show
 
 instance HandleAction SwitchTo where
-  handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( SwitchTo newUnique ) = do
-    mbNewDocAndTab <- STM.atomically do
-      STM.writeTVar activeDocumentTVar ( Just newUnique )
-      newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
-      newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar
-      pure ( (,) <$> newDoc <*> newTab )
-    case mbNewDocAndTab of
-      Nothing -> updateTitle window title Nothing
-      Just ( Document { .. }, tab ) -> do
-        updateTitle window title ( Just ( displayName, unsavedChanges ) )
-        updateInfoBar viewportDrawingArea infoBar vars
-        GTK.widgetQueueDraw tab
-    GTK.widgetQueueDraw viewportDrawingArea
+  handleAction
+    ( UIElements { viewport = Viewport {..}, .. } )
+    vars@( Variables {..} )
+    ( SwitchTo newUnique ) = do
+      mbNewDocAndTab <- STM.atomically do
+        STM.writeTVar activeDocumentTVar ( Just newUnique )
+        newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
+        newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar
+        pure ( (,) <$> newDoc <*> newTab )
+      case mbNewDocAndTab of
+        Nothing -> updateTitle window title Nothing
+        Just ( Document {..}, tab ) -> do
+          updateTitle window title ( Just ( displayName, unsavedChanges ) )
+          updateInfoBar viewportDrawingArea infoBar vars
+          GTK.widgetQueueDraw tab
+      GTK.widgetQueueDraw viewportDrawingArea
 
 --------------
 -- Quitting --
@@ -469,8 +489,8 @@ data Confirm = Confirm
 
 instance HandleAction Confirm where
   handleAction
-    ( UIElements { viewportDrawingArea } )
-    ( Variables { .. } )
+    ( UIElements { viewport = Viewport {..} } )
+    ( Variables {..} )
     _
     = do
         tool <- STM.readTVarIO toolTVar
@@ -504,13 +524,13 @@ data MouseMove = MouseMove ( Point2D Double )
 
 instance HandleAction MouseMove where
   handleAction
-    ( UIElements { viewportDrawingArea, infoBar } )
-    vars@( Variables { mousePosTVar, modifiersTVar, toolTVar, partialPathTVar } )
+    ( UIElements { viewport = Viewport {..}, .. } )
+    vars@( Variables {..} )
     ( MouseMove ( Point2D x y ) )
     = do
       viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
       viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
-      void . STM.atomically $ withCurrentDocument vars \ ( Document { .. } ) -> do
+      void . STM.atomically $ withCurrentDocument vars \ ( Document {..} ) -> do
         modifiers <- STM.readTVar modifiersTVar
         let
           toViewport :: Point2D Double -> Point2D Double
@@ -532,19 +552,26 @@ instance HandleAction MouseMove where
 
       updateInfoBar viewportDrawingArea infoBar vars
       GTK.widgetQueueDraw viewportDrawingArea
+      for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
+        GTK.widgetQueueDraw drawingArea
 
 -----------------
 -- Mouse click --
 -----------------
 
-data MouseClick = MouseClick Word32 ( Point2D Double )
+data ActionOrigin
+  = ViewportOrigin
+  | RulerOrigin Ruler
+  deriving stock Show
+
+data MouseClick = MouseClick ActionOrigin Word32 ( Point2D Double )
   deriving stock Show
 
 instance HandleAction MouseClick where
   handleAction
-    uiElts@( UIElements { viewportDrawingArea } )
-    vars@( Variables { .. } )
-    ( MouseClick button mouseClickCoords )
+    uiElts@( UIElements { viewport = Viewport {..} } )
+    vars@( Variables {..} )
+    ( MouseClick actionOrigin button mouseClickCoords )
     = case button of
 
       -- Left mouse button.
@@ -558,50 +585,66 @@ instance HandleAction MouseClick where
             pos :: Point2D Double
             pos = toViewport mouseClickCoords
           STM.writeTVar mousePosTVar ( Just pos )
-          modifiers <- STM.readTVar modifiersTVar
-          tool <- STM.readTVar toolTVar
-          mode <- STM.readTVar modeTVar
-          case tool of
-            -- 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.
-            Selection ->
-              case selectionMode modifiers of
-                -- Drag move: not holding shift or alt, click has selected something.
-                New
-                  | Just newDoc <- dragMoveSelect mode pos doc
-                  -> do
-                    STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
-                    pure ( UpdateDocTo $ Just newDoc )
-                -- Rectangular selection.
-                _ -> do
-                    STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
-                    pure Don'tModifyDoc
+          case actionOrigin of
 
-            -- Pen tool: start or continue a drawing operation.
-            Pen -> do
-              mbPartialPath <- STM.readTVar partialPathTVar
-              STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
-              case mbPartialPath of
-                -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
-                Nothing -> do
-                  ( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
-                  STM.writeTVar partialPathTVar
-                    ( Just $ PartialPath
-                      { partialStartPos     = anchorPt
-                      , partialControlPoint = Nothing
-                      , partialPathAnchor   = drawAnchor
-                      , firstPoint          = True
-                      }
-                    )
-                  pure ( UpdateDocTo $ Just newDoc )
-                -- Path already started: indicate that we are continuing a path.
-                Just pp -> do
-                  STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
-                  pure Don'tModifyDoc
+            ViewportOrigin -> do
+              modifiers <- STM.readTVar modifiersTVar
+              tool <- STM.readTVar toolTVar
+              mode <- STM.readTVar modeTVar
+              case tool of
+                -- 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.
+                Selection ->
+                  case selectionMode modifiers of
+                    -- Drag move: not holding shift or alt, click has selected something.
+                    New
+                      | Just newDoc <- dragMoveSelect mode pos doc
+                      -> do
+                        STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
+                        pure ( UpdateDocTo $ Just newDoc )
+                    -- Rectangular selection.
+                    _ -> do
+                        STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
+                        pure Don'tModifyDoc
+
+                -- Pen tool: start or continue a drawing operation.
+                Pen -> do
+                  mbPartialPath <- STM.readTVar partialPathTVar
+                  STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
+                  case mbPartialPath of
+                    -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
+                    Nothing -> do
+                      ( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
+                      STM.writeTVar partialPathTVar
+                        ( Just $ PartialPath
+                          { partialStartPos     = anchorPt
+                          , partialControlPoint = Nothing
+                          , partialPathAnchor   = drawAnchor
+                          , firstPoint          = True
+                          }
+                        )
+                      pure ( UpdateDocTo $ Just newDoc )
+                    -- Path already started: indicate that we are continuing a path.
+                    Just pp -> do
+                      STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
+                      pure Don'tModifyDoc
+
+            RulerOrigin ruler -> do
+              let
+                mbGuide :: Maybe Guide
+                mbGuide = selectGuide pos doc
+                guideAction :: GuideAction
+                guideAction
+                  | Just guide <- mbGuide
+                  = MoveGuide ( guideUnique guide )
+                  | otherwise
+                  = CreateGuide ruler
+              STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
+              pure Don'tModifyDoc
 
       -- Right mouse button: end partial path.
       3 -> do
@@ -621,8 +664,8 @@ data MouseRelease = MouseRelease Word32 ( Point2D Double )
 
 instance HandleAction MouseRelease where
   handleAction 
-    uiElts@( UIElements { viewportDrawingArea } )
-    vars@( Variables { .. } )
+    uiElts@( UIElements { viewport = Viewport {..} } )
+    vars@( Variables {..} )
     ( MouseRelease button ( Point2D x y ) )
     = case button of
 
@@ -639,101 +682,138 @@ instance HandleAction MouseRelease where
           STM.writeTVar mousePosTVar  ( Just pos )
           modifiers <- STM.readTVar modifiersTVar
           mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
-          tool      <- STM.readTVar toolTVar
-          mode      <- STM.readTVar modeTVar
 
-          case tool of
+          case mbHoldPos of
+            Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do
+              newDoc <- case guideAction of
+                CreateGuide ruler
+                  | createGuide
+                  -> addGuide uniqueSupply ruler pos doc
+                  | otherwise
+                  -> pure doc
+                  where
+                    createGuide :: Bool
+                    createGuide
+                      =  x >= 0
+                      && y >= 0
+                      && x <= viewportWidth
+                      && y <= viewportHeight
+                MoveGuide guideUnique
+                  | keepGuide
+                  -> pure $
+                        over
+                          ( field' @"guides" . ix guideUnique . field' @"guidePoint" )
+                          ( ( holdStartPos --> pos :: Vector2D Double ) • )
+                          doc
+                  | otherwise
+                  -> pure $ set ( field' @"guides" . at guideUnique ) Nothing doc
+                  where
+                    l, t :: Double
+                    Point2D l t = toViewport ( Point2D 0 0 )
+                    keepGuide :: Bool
+                    keepGuide
+                      =  ( x >= 0 || hx < l ) -- mouse hold position (hx,hy) is in document coordinates,
+                      && ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0)
+                      && x <= viewportWidth
+                      && y <= viewportHeight
+              pure ( UpdateDocTo ( Just newDoc ) )
+            _ -> do
 
-            Selection -> do
-              let
-                selMode :: SelectionMode
-                selMode = selectionMode modifiers
-              case mbHoldPos of
-                Just hold
-                  | DragMoveHold  pos0 <- hold
-                  , pos0 /= pos
-                  -> pure ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc )
-                  | SelectionHold pos0 <- hold
-                  , pos0 /= pos
-                  -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc )
-                _ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode pos doc )
+              tool      <- STM.readTVar toolTVar
+              mode      <- STM.readTVar modeTVar
 
-            Pen -> do
-              mbPartialPath <- STM.readTVar partialPathTVar
-              case mbPartialPath of
-                -- Normal pen mode mouse click should have created an anchor.
-                -- If no anchor exists, then just ignore the mouse release event.
-                Nothing -> pure Don'tModifyDoc
-                -- Mouse click release possibilities:
-                --
-                --  - click was on complementary draw stroke draw anchor to close the path,
-                --  - release at same point as click: finish current segment,
-                --  - release at different point as click: finish current segment, adding a control point.
-                Just
-                  ( PartialPath
-                    { partialStartPos     = p1
-                    , partialControlPoint = mbCp2
-                    , partialPathAnchor   = anchor
-                    , firstPoint
-                    }
-                  ) -> do
+              case tool of
+
+                Selection -> do
                   let
-                    pathPoint :: Point2D Double
-                    mbControlPoint :: Maybe ( Point2D Double )
-                    partialControlPoint :: Maybe ( Point2D Double )
-                    ( pathPoint, mbControlPoint, partialControlPoint )
-                      | Just ( DrawHold holdPos ) <- mbHoldPos
-                      = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
-                      | otherwise
-                      = ( pos, Nothing, Nothing )
-                  ( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
-                  if not firstPoint && anchorsAreComplementary anchor otherAnchor
-                  -- Close path.
-                  then do
-                    STM.writeTVar partialPathTVar Nothing
-                    let 
-                      newSegment :: Seq ( StrokePoint PointData )
-                      newSegment
-                        = Seq.fromList
-                        $ catMaybes
-                        [ Just ( PathPoint p1 ( PointData Normal Empty ) )
-                        , do
-                            cp <- mbCp2
-                            guard ( cp /= p1 )
-                            pure $ ControlPoint cp ( PointData Normal Empty )
-                        , do
-                            cp <- mbControlPoint
-                            guard ( cp /= otherAnchorPt )
-                            pure $ ControlPoint cp ( PointData Normal Empty )
-                        , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
-                        ]
-                    pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
-                  else
-                    if firstPoint
-                    -- Continue current partial path.
-                    then do
-                      STM.writeTVar partialPathTVar ( Just $ PartialPath p1        partialControlPoint anchor False )
-                      pure Don'tModifyDoc
-                    -- Finish current partial path.
-                    else do
-                      STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
-                      let 
-                        newSegment :: Seq ( StrokePoint PointData )
-                        newSegment
-                          = Seq.fromList
-                          $ catMaybes
-                          [ Just ( PathPoint p1 ( PointData Normal Empty ) )
-                          , do
-                              cp <- mbCp2
-                              guard ( cp /= p1 )
-                              pure $ ControlPoint cp ( PointData Normal Empty )
-                          , do
-                              cp <- mbControlPoint
-                              guard ( cp /= pathPoint )
-                              pure $ ControlPoint cp ( PointData Normal Empty )
-                          , Just ( PathPoint pathPoint ( PointData Normal Empty ) )
-                          ]
-                      pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
+                    selMode :: SelectionMode
+                    selMode = selectionMode modifiers
+                  case mbHoldPos of
+                    Just hold
+                      | DragMoveHold  pos0 <- hold
+                      , pos0 /= pos
+                      -> pure ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc )
+                      | SelectionHold pos0 <- hold
+                      , pos0 /= pos
+                      -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc )
+                    _ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode pos doc )
+
+                Pen -> do
+                  mbPartialPath <- STM.readTVar partialPathTVar
+                  case mbPartialPath of
+                    -- Normal pen mode mouse click should have created an anchor.
+                    -- If no anchor exists, then just ignore the mouse release event.
+                    Nothing -> pure Don'tModifyDoc
+                    -- Mouse click release possibilities:
+                    --
+                    --  - click was on complementary draw stroke draw anchor to close the path,
+                    --  - release at same point as click: finish current segment,
+                    --  - release at different point as click: finish current segment, adding a control point.
+                    Just
+                      ( PartialPath
+                        { partialStartPos     = p1
+                        , partialControlPoint = mbCp2
+                        , partialPathAnchor   = anchor
+                        , firstPoint
+                        }
+                      ) -> do
+                      let
+                        pathPoint :: Point2D Double
+                        mbControlPoint :: Maybe ( Point2D Double )
+                        partialControlPoint :: Maybe ( Point2D Double )
+                        ( pathPoint, mbControlPoint, partialControlPoint )
+                          | Just ( DrawHold holdPos ) <- mbHoldPos
+                          = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
+                          | otherwise
+                          = ( pos, Nothing, Nothing )
+                      ( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
+                      if not firstPoint && anchorsAreComplementary anchor otherAnchor
+                      -- Close path.
+                      then do
+                        STM.writeTVar partialPathTVar Nothing
+                        let
+                          newSegment :: Seq ( StrokePoint PointData )
+                          newSegment
+                            = Seq.fromList
+                            $ catMaybes
+                            [ Just ( PathPoint p1 ( PointData Normal Empty ) )
+                            , do
+                                cp <- mbCp2
+                                guard ( cp /= p1 )
+                                pure $ ControlPoint cp ( PointData Normal Empty )
+                            , do
+                                cp <- mbControlPoint
+                                guard ( cp /= otherAnchorPt )
+                                pure $ ControlPoint cp ( PointData Normal Empty )
+                            , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
+                            ]
+                        pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
+                      else
+                        if firstPoint
+                        -- Continue current partial path.
+                        then do
+                          STM.writeTVar partialPathTVar ( Just $ PartialPath p1        partialControlPoint anchor False )
+                          pure Don'tModifyDoc
+                        -- Finish current partial path.
+                        else do
+                          STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
+                          let
+                            newSegment :: Seq ( StrokePoint PointData )
+                            newSegment
+                              = Seq.fromList
+                              $ catMaybes
+                              [ Just ( PathPoint p1 ( PointData Normal Empty ) )
+                              , do
+                                  cp <- mbCp2
+                                  guard ( cp /= p1 )
+                                  pure $ ControlPoint cp ( PointData Normal Empty )
+                              , do
+                                  cp <- mbControlPoint
+                                  guard ( cp /= pathPoint )
+                                  pure $ ControlPoint cp ( PointData Normal Empty )
+                              , Just ( PathPoint pathPoint ( PointData Normal Empty ) )
+                              ]
+                          pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
 
       -- Other mouse buttons: ignored (for the moment at least).
       _ -> pure ()
@@ -746,59 +826,62 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
   deriving stock Show
 
 instance HandleAction Scroll where
-  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
+  handleAction
+    uiElts@( UIElements { viewport = Viewport {..}, .. } )
+    vars@( Variables {..} )
+    ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
 
-    viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-    viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+      viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
+      viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
 
-    unless ( dx == 0 && dy == 0 ) do
-      modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
-        modifiers <- STM.readTVar modifiersTVar
-        let
-          toViewport :: Point2D Double -> Point2D Double
-          toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
-          -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
-          mousePos :: Point2D Double
-          mousePos = toViewport ( Point2D x y )
-          newDoc :: Document
-          newDoc
-            -- Zooming using 'Control'.
-            | any ( \ case { Control _ -> True; _ -> False } ) modifiers
-            = let
-                newZoomFactor :: Double
-                newZoomFactor
-                  | dy > 0
-                  = max 0.0078125 ( oldZoomFactor / sqrt 2 )
-                  | otherwise
-                  = min 256 ( oldZoomFactor * sqrt 2 )
-                newCenter :: Point2D Double
-                newCenter
-                  = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
-                  • oldCenter
-              in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
-            -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
-            | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
-            = let
-                newCenter :: Point2D Double
-                newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
-              in doc { viewportCenter = newCenter }
-            -- Vertical scrolling.
-            | otherwise
-            = let
-                newCenter :: Point2D Double
-                newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
-              in doc { viewportCenter = newCenter }
-          finalZoomFactor :: Double
-          finalZoomFactor = zoomFactor     newDoc
-          finalCenter :: Point2D Double
-          finalCenter     = viewportCenter newDoc
-          toFinalViewport :: Point2D Double -> Point2D Double
-          toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
-          finalMousePos :: Point2D Double
-          finalMousePos = toFinalViewport ( Point2D x y )
-        STM.writeTVar mousePosTVar ( Just finalMousePos )
-        pure ( UpdateDocTo $ Just newDoc )
-      updateInfoBar viewportDrawingArea infoBar vars
+      unless ( dx == 0 && dy == 0 ) do
+        modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
+          modifiers <- STM.readTVar modifiersTVar
+          let
+            toViewport :: Point2D Double -> Point2D Double
+            toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
+            -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
+            mousePos :: Point2D Double
+            mousePos = toViewport ( Point2D x y )
+            newDoc :: Document
+            newDoc
+              -- Zooming using 'Control'.
+              | any ( \ case { Control _ -> True; _ -> False } ) modifiers
+              = let
+                  newZoomFactor :: Double
+                  newZoomFactor
+                    | dy > 0
+                    = max 0.0078125 ( oldZoomFactor / sqrt 2 )
+                    | otherwise
+                    = min 256 ( oldZoomFactor * sqrt 2 )
+                  newCenter :: Point2D Double
+                  newCenter
+                    = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
+                    • oldCenter
+                in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
+              -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
+              | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
+              = let
+                  newCenter :: Point2D Double
+                  newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
+                in doc { viewportCenter = newCenter }
+              -- Vertical scrolling.
+              | otherwise
+              = let
+                  newCenter :: Point2D Double
+                  newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
+                in doc { viewportCenter = newCenter }
+            finalZoomFactor :: Double
+            finalZoomFactor = zoomFactor     newDoc
+            finalCenter :: Point2D Double
+            finalCenter     = viewportCenter newDoc
+            toFinalViewport :: Point2D Double -> Point2D Double
+            toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
+            finalMousePos :: Point2D Double
+            finalMousePos = toFinalViewport ( Point2D x y )
+          STM.writeTVar mousePosTVar ( Just finalMousePos )
+          pure ( UpdateDocTo $ Just newDoc )
+        updateInfoBar viewportDrawingArea infoBar vars
 
 --------------------
 -- Keyboard press --
@@ -808,47 +891,50 @@ data KeyboardPress = KeyboardPress Word32
   deriving stock Show
 
 instance HandleAction KeyboardPress where
-  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do
+  handleAction
+    uiElts@( UIElements { viewport = Viewport {..}, .. } )
+    vars@( Variables {..} )
+    ( KeyboardPress keyCode ) = do
 
-    modifiers <- STM.atomically do
-      !modifiers <- STM.readTVar modifiersTVar
-      for_ ( modifierKey keyCode ) \ modifier ->
-        ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
-      pure modifiers
+      modifiers <- STM.atomically do
+        !modifiers <- STM.readTVar modifiersTVar
+        for_ ( modifierKey keyCode ) \ modifier ->
+          ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
+        pure modifiers
 
-    case keyCode of
+      case keyCode of
 
-      GDK.KEY_Escape -> handleAction uiElts vars Quit
+        GDK.KEY_Escape -> handleAction uiElts vars Quit
 
-      GDK.KEY_Return -> handleAction uiElts vars Confirm
+        GDK.KEY_Return -> handleAction uiElts vars Confirm
 
-      ctrl
-        | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
-        -> do
-          ----------------------------------------------------------
-          -- With the pen tool, pressing control moves
-          -- the partial point control point to the mouse position.
-          tool <- STM.readTVarIO toolTVar
-          mbMousePos <- STM.readTVarIO mousePosTVar
-          mbPartialPath <- STM.readTVarIO partialPathTVar
-          case tool of
-            Pen
-              | Just mp <- mbMousePos
-              , Just pp <- mbPartialPath
-              -> do
-                  STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
-                  GTK.widgetQueueDraw viewportDrawingArea
-            _ -> pure ()
+        ctrl
+          | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
+          -> do
+            ----------------------------------------------------------
+            -- With the pen tool, pressing control moves
+            -- the partial point control point to the mouse position.
+            tool <- STM.readTVarIO toolTVar
+            mbMousePos <- STM.readTVarIO mousePosTVar
+            mbPartialPath <- STM.readTVarIO partialPathTVar
+            case tool of
+              Pen
+                | Just mp <- mbMousePos
+                , Just pp <- mbPartialPath
+                -> do
+                    STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
+                    GTK.widgetQueueDraw viewportDrawingArea
+              _ -> pure ()
 
-      -- todo: these should be handled by accelerator,
-      -- but those are not working currently
-      GDK.KEY_Delete -> handleAction uiElts vars Delete
+        -- todo: these should be handled by accelerator,
+        -- but those are not working currently
+        GDK.KEY_Delete -> handleAction uiElts vars Delete
 
-      GDK.KEY_s
-        | any ( \case { Control _ -> True; _ -> False } ) modifiers
-        -> handleAction uiElts vars Save
+        GDK.KEY_s
+          | any ( \case { Control _ -> True; _ -> False } ) modifiers
+          -> handleAction uiElts vars Save
 
-      _ -> pure ()
+        _ -> pure ()
 
 ----------------------
 -- Keyboard release --

src/app/MetaBrush/Asset/CloseTabButton.hs

@@ -22,7 +22,7 @@ import MetaBrush.Util
 
 -- | "Close tab" button.
 drawCloseTabButton :: Colours -> Bool -> [ GTK.StateFlags ] -> Cairo.Render Bool
-drawCloseTabButton ( Colours { .. } ) unsavedChanges flags = do
+drawCloseTabButton ( Colours {..} ) unsavedChanges flags = do
 
   Cairo.setLineCap  Cairo.LineCapRound
   Cairo.setLineJoin Cairo.LineJoinMiter

src/app/MetaBrush/Asset/Colours.hs

@@ -36,7 +36,7 @@ data ColourRecord a
   , path, brush, brushStroke, brushCenter        
   , pointHover, pointSelected      
   , viewport, viewportScrollbar, tabScrollbar       
-  , magnifier, glass
+  , guide, magnifier, glass
   , selected, selectedOutline :: !a
   }
   deriving stock ( Show, Functor, Foldable, Traversable )
@@ -78,6 +78,7 @@ colourNames = Colours
   , viewport            = ColourName "viewport"          BackgroundColour [ GTK.StateFlagsNormal ]
   , viewportScrollbar   = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
   , tabScrollbar        = ColourName "tabScrollbar"      BackgroundColour [ GTK.StateFlagsNormal ]
+  , guide               = ColourName "guide"                       Colour [ GTK.StateFlagsNormal ]
   , magnifier           = ColourName "magnifier"                   Colour [ GTK.StateFlagsNormal ]
   , glass               = ColourName "glass"                       Colour [ GTK.StateFlagsNormal ]
   , selected            = ColourName "selected"                    Colour [ GTK.StateFlagsNormal ]
@@ -88,7 +89,7 @@ type Colours = ColourRecord GDK.RGBA
 
 getColours :: GTK.WidgetPath -> IO Colours
 getColours windowWidgetPath =
-  for colourNames \ ( ColourName { .. } ) -> do
+  for colourNames \ ( ColourName {..} ) -> do
     style <- GTK.styleContextNew
     GTK.styleContextSetPath  style windowWidgetPath
     GTK.styleContextAddClass style colourName

src/app/MetaBrush/Asset/Tools.hs

@@ -100,7 +100,7 @@ drawMeta ( Colours { splash } )  = do
 
 -- | Path icon. Width = 40 height = 40.
 drawPath :: Colours -> Cairo.Render Bool
-drawPath ( Colours { .. } ) = do
+drawPath ( Colours {..} ) = do
 
   Cairo.setLineCap  Cairo.LineCapRound
   Cairo.setLineJoin Cairo.LineJoinMiter

src/app/MetaBrush/Context.hs

@@ -11,7 +11,7 @@
 module MetaBrush.Context
   ( UIElements(..), Variables(..)
   , LR(..), Modifier(..), modifierKey, modifierType
-  , HoldAction(..), PartialPath(..)
+  , HoldAction(..), GuideAction(..), PartialPath(..)
   , currentDocument, withCurrentDocument
   , PureDocModification(..), DocModification(..)
   , modifyingCurrentDocument
@@ -76,6 +76,8 @@ import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar, updateInfoBar )
 import MetaBrush.UI.ToolBar
   ( Tool, Mode )
+import MetaBrush.UI.Viewport
+  ( Viewport(..), Ruler(..) )
 import MetaBrush.Unique
   ( UniqueSupply, Unique )
 import MetaBrush.Util
@@ -85,13 +87,13 @@ import MetaBrush.Util
 
 data UIElements
   = UIElements
-  { window              :: !GTK.Window
-  , title               :: !GTK.Label
-  , titleBar            :: !GTK.Box
-  , fileBar             :: !FileBar
-  , viewportDrawingArea :: !GTK.DrawingArea
-  , infoBar             :: !InfoBar
-  , colours             :: !Colours
+  { window   :: !GTK.Window
+  , title    :: !GTK.Label
+  , titleBar :: !GTK.Box
+  , fileBar  :: !FileBar
+  , viewport :: !Viewport
+  , infoBar  :: !InfoBar
+  , colours  :: !Colours
   }
 
 data Variables
@@ -133,15 +135,25 @@ modifierType ( Control _ ) = GDK.ModifierTypeControlMask
 modifierType ( Alt     _ ) = GDK.ModifierTypeMod1Mask
 modifierType ( Shift   _ ) = GDK.ModifierTypeShiftMask
 
+
+data GuideAction
+  = CreateGuide !Ruler
+  | MoveGuide   !Unique
+  deriving stock Show
+
 -- | Keep track of a mouse hold action:
 --
 --  - start a rectangular selection,
 --  - move objects by dragging,
---  - drawing a control point.
+--  - drawing a control point,
+--  - create/modify a guide.
 data HoldAction
   = SelectionHold { holdStartPos :: !( Point2D Double ) }
   | DragMoveHold  { holdStartPos :: !( Point2D Double ) }
   | DrawHold      { holdStartPos :: !( Point2D Double ) }
+  | GuideAction   { holdStartPos :: !( Point2D Double )
+                  , guideAction  :: !GuideAction        
+                  }
   deriving stock Show
 
 -- | Keep track of a path that is in the middle of being drawn.
@@ -197,7 +209,7 @@ instance DocumentModification DocModification where
 --
 -- Does nothing if no document is currently active.
 modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
-modifyingCurrentDocument ( UIElements { .. } ) vars@( Variables { .. } ) f = do
+modifyingCurrentDocument ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do
   mbAction <- STM.atomically . runMaybeT $ do
     unique <- MaybeT ( STM.readTVar activeDocumentTVar )
     oldDoc <- MaybeT ( Map.lookup unique <$> STM.readTVar openDocumentsTVar )
@@ -219,6 +231,8 @@ modifyingCurrentDocument ( UIElements { .. } ) vars@( Variables { .. } ) f = do
             Just ( Document { displayName, unsavedChanges } ) -> do
               updateTitle window title ( Just ( displayName, unsavedChanges ) )
           GTK.widgetQueueDraw viewportDrawingArea
+          for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
+            GTK.widgetQueueDraw drawingArea
         for_ mbActiveTab GTK.widgetQueueDraw
         sequenceAOf_ actionFold modif
   sequenceA_ mbAction

src/app/MetaBrush/Document.hs

@@ -9,7 +9,7 @@
 module MetaBrush.Document
   ( AABB(..)
   , Document(..), emptyDocument
-  , Stroke(..)
+  , Stroke(..), Guide(..)
   , PointData(..), BrushPointData(..)
   , FocusState(..)
   , _selection, _brush
@@ -21,6 +21,10 @@ import GHC.Generics
   ( Generic )
 
 -- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( empty )
 import Data.Sequence
   ( Seq )
 
@@ -42,7 +46,7 @@ import Data.Text
 import Math.Bezier.Stroke
   ( StrokePoint(..) )
 import Math.Vector2D
-  ( Point2D(..) )
+  ( Point2D(..), Vector2D(..) )
 import MetaBrush.Unique
   ( Unique )
 
@@ -62,6 +66,7 @@ data Document
     , zoomFactor     :: !Double
     , documentUnique :: Unique
     , strokes        :: ![ Stroke ]
+    , guides         :: !( Map Unique Guide )
     }
   deriving stock ( Show, Generic )
 
@@ -74,6 +79,14 @@ data Stroke
   }
   deriving stock ( Show, Generic )
 
+data Guide
+  = Guide
+  { guidePoint  :: !( Point2D  Double ) -- ^ point on the guide line
+  , guideNormal :: !( Vector2D Double ) -- ^ /normalised/ normal vector of the guide
+  , guideUnique :: Unique
+  }
+  deriving stock ( Show, Generic )
+
 data PointData
   = PointData
   { pointState :: FocusState
@@ -108,4 +121,5 @@ emptyDocument docName unique =
     , zoomFactor     = 1
     , documentUnique = unique
     , strokes        = []
+    , guides         = Map.empty
     }

src/app/MetaBrush/Document/Guide.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module MetaBrush.Document.Guide
+  ( selectGuide, addGuide )
+  where
+
+-- base
+import Data.Semigroup
+  ( Arg(..), Min(..), ArgMin )
+
+-- acts
+import Data.Act
+  ( Torsor((-->)) )
+
+-- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( insert )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
+-- stm
+import Control.Concurrent.STM
+  ( STM )
+
+-- MetaBrush
+import Math.Module
+  ( Inner((^.^)), squaredNorm )
+import Math.Vector2D
+  ( Point2D(..), Vector2D(..) )
+import MetaBrush.Document
+  ( Document(..), Guide(..)
+  )
+import MetaBrush.UI.Viewport
+  ( Ruler(..) )
+import MetaBrush.Unique
+  ( UniqueSupply, Unique, freshUnique )
+
+--------------------------------------------------------------------------------
+
+-- | Try to select a guide at the given document coordinates.
+selectGuide :: Point2D Double -> Document -> Maybe Guide
+selectGuide c ( Document { zoomFactor, guides } ) = \case { Min ( Arg _ g ) -> g } <$> foldMap f guides
+  where
+    f :: Guide -> Maybe ( ArgMin Double Guide )
+    f guide@( Guide { guidePoint = p, guideNormal = n } )
+      | sqDist * zoomFactor ^ ( 2 :: Int ) < 4
+      = Just ( Min ( Arg sqDist guide ) )
+      | otherwise
+      = Nothing
+      where
+        t :: Double
+        t = ( c --> p ) ^.^ n
+        sqDist :: Double
+        sqDist = t ^ ( 2 :: Int ) / squaredNorm n
+
+-- | Add new guide after a mouse drag from a ruler area.
+addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document
+addGuide uniqueSupply ruler p = ( field' @"guides" ) insertNewGuides
+  where
+    insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide )
+    insertNewGuides gs = case ruler of
+      RulerCorner
+        -> do
+          uniq1 <- freshUnique uniqueSupply
+          uniq2 <- freshUnique uniqueSupply
+          let
+            guide1, guide2 :: Guide
+            guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideUnique = uniq1 }
+            guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideUnique = uniq2 }
+          pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
+      TopRuler
+        -> do
+          uniq1 <- freshUnique uniqueSupply
+          let
+            guide1 :: Guide
+            guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideUnique = uniq1 }
+          pure ( Map.insert uniq1 guide1 gs )
+      LeftRuler
+        -> do
+          uniq2 <- freshUnique uniqueSupply
+          let
+            guide2 :: Guide
+            guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideUnique = uniq2 }
+          pure ( Map.insert uniq2 guide2 gs )

src/app/MetaBrush/Document/Serialise.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings   #-}
@@ -11,6 +12,8 @@ module MetaBrush.Document.Serialise
   where
 
 -- base
+import Control.Arrow
+  ( (&&&) )
 import Control.Monad
   ( unless )
 import qualified Data.Bifunctor as Bifunctor
@@ -39,6 +42,10 @@ import qualified Data.ByteString.Lazy.Builder as Lazy.ByteString.Builder
   ( toLazyByteString )
 
 -- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( fromList, elems )
 import Data.Sequence
   ( Seq )
 import qualified Data.Sequence as Seq
@@ -52,6 +59,14 @@ import System.Directory
 import System.FilePath
   ( takeDirectory )
 
+-- generic-lens
+import Data.Generics.Product.Typed
+  ( HasType(typed) )
+
+-- lens
+import Control.Lens
+  ( view )
+
 -- scientific
 import qualified Data.Scientific as Scientific
   ( fromFloatDigits, toRealFloat )
@@ -102,16 +117,17 @@ import qualified Waargonaut.Prettier as TonyMorris
 import Math.Bezier.Stroke
   ( StrokePoint(..) )
 import Math.Vector2D
-  ( Point2D(..) )
+  ( Point2D(..), Vector2D(..) )
 import MetaBrush.Document
   ( Document(..)
   , Stroke(..)
+  , Guide(..)
   , PointData(..)
   , BrushPointData(..)
   , FocusState(..)
   )
 import MetaBrush.Unique
-  ( UniqueSupply, freshUnique )
+  ( Unique, UniqueSupply, freshUnique )
 
 --------------------------------------------------------------------------------
 
@@ -176,7 +192,7 @@ decodePoint2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Point2D a )
 decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
 
 
-{-
+
 encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a )
 encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
     JSON.Encoder.atKey' "x" enc x
@@ -186,7 +202,7 @@ decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a )
 decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
 
 
-
+{-
 encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
 encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
     JSON.Encoder.atKey' "m00" enc m00
@@ -282,6 +298,14 @@ decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
 
 
 
+encodeUniqueMap :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Map Unique a )
+encodeUniqueMap enc = contramap Map.elems ( JSON.Encoder.list enc )
+
+decodeUniqueMap :: ( Monad m, HasType Unique a ) => JSON.Decoder m a -> JSON.Decoder m ( Map Unique a )
+decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.list dec
+
+
+
 encodePointData :: Applicative f => JSON.Encoder f PointData
 encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) ->
     JSON.Encoder.atKey' "focus" encodeFocusState pointState
@@ -311,12 +335,27 @@ decodeStroke uniqueSupply = do
 
 
 
+encodeGuide :: Applicative f => JSON.Encoder f Guide
+encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
+    JSON.Encoder.atKey' "point"  ( encodePoint2D  encodeDouble ) guidePoint
+  . JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal
+
+decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
+decodeGuide uniqueSupply = do
+  guidePoint  <- JSON.Decoder.atKey "point"  ( decodePoint2D  decodeDouble )
+  guideNormal <- JSON.Decoder.atKey "normal" ( decodeVector2D decodeDouble )
+  guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
+  pure ( Guide { guidePoint, guideNormal, guideUnique } )
+
+
+
 encodeDocument :: Applicative f => JSON.Encoder f Document
-encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes } ) ->
+encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes, guides } ) ->
     JSON.Encoder.atKey' "name"     JSON.Encoder.text                  displayName
   . JSON.Encoder.atKey' "center"   ( encodePoint2D encodeDouble )     viewportCenter
   . JSON.Encoder.atKey' "zoom"     encodeDouble                       zoomFactor
   . JSON.Encoder.atKey' "strokes"  ( JSON.Encoder.list encodeStroke ) strokes
+  . JSON.Encoder.atKey' "strokes"  ( encodeUniqueMap encodeGuide )    guides
 
 decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
 decodeDocument uniqueSupply mbFilePath = do
@@ -328,4 +367,5 @@ decodeDocument uniqueSupply mbFilePath = do
   zoomFactor     <- JSON.Decoder.atKey "zoom"   decodeDouble
   documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
   strokes        <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
-  pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, strokes } )
+  guides         <- JSON.Decoder.atKey "guides"  ( decodeUniqueMap   ( decodeGuide  uniqueSupply ) )
+  pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, strokes, guides } )

src/app/MetaBrush/Event.hs

@@ -1,9 +1,15 @@
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.Event
   ( handleEvents )
   where
 
+-- base
+import Control.Monad
+  ( void )
+
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
@@ -15,68 +21,96 @@ import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Action
   ( HandleAction(..)
+  , ActionOrigin(..)
   , MouseMove(..), MouseClick(..), MouseRelease(..)
   , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
   , quitEverything
   )
 import MetaBrush.Context
   ( UIElements(..), Variables(..) )
+import MetaBrush.UI.Viewport
+  ( Viewport(..), Ruler(..) )
 
 --------------------------------------------------------------------------------
 
 handleEvents :: UIElements -> Variables -> IO ()
-handleEvents elts@( UIElements { window, viewportDrawingArea } ) vars = do
+handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
 
   -- Mouse events
-  _ <- GTK.onWidgetMotionNotifyEvent  viewportDrawingArea ( handleMotionEvent        elts vars )
-  _ <- GTK.onWidgetScrollEvent        viewportDrawingArea ( handleScrollEvent        elts vars )
-  _ <- GTK.onWidgetButtonPressEvent   viewportDrawingArea ( handleMouseButtonEvent   elts vars )
-  _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease elts vars )
+  onWidgetMouseEvent    viewportDrawingArea ViewportOrigin
+  onWidgetMouseEvent rulerCornerDrawingArea ( RulerOrigin RulerCorner )
+  onWidgetMouseEvent   leftRulerDrawingArea ( RulerOrigin LeftRuler   )
+  onWidgetMouseEvent    topRulerDrawingArea ( RulerOrigin TopRuler    )
 
   -- Keyboard events
-  _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   elts vars )
-  _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
+  void $ GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   elts vars )
+  void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
 
   -- Window quit
-  _ <- GTK.onWidgetDestroy window ( quitEverything window )
+  void $ GTK.onWidgetDestroy window ( quitEverything window )
 
-  pure ()
+    where
+      onWidgetMouseEvent :: GTK.DrawingArea -> ActionOrigin -> IO ()
+      onWidgetMouseEvent drawingArea eventOrigin = do
+        void $ GTK.onWidgetMotionNotifyEvent  drawingArea ( handleMotionEvent        elts vars eventOrigin )
+        void $ GTK.onWidgetScrollEvent        drawingArea ( handleScrollEvent        elts vars eventOrigin )
+        void $ GTK.onWidgetButtonPressEvent   drawingArea ( handleMouseButtonEvent   elts vars eventOrigin )
+        void $ GTK.onWidgetButtonReleaseEvent drawingArea ( handleMouseButtonRelease elts vars eventOrigin )
 
 --------------------------------------------------------------------------------
 -- Mouse events.
 
-handleMotionEvent :: UIElements -> Variables -> GDK.EventMotion -> IO Bool
-handleMotionEvent elts vars eventMotion = do
+handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventMotion -> IO Bool
+handleMotionEvent elts vars eventOrigin eventMotion = do
   x <- GDK.getEventMotionX eventMotion
   y <- GDK.getEventMotionY eventMotion
-  handleAction elts vars ( MouseMove ( Point2D x y ) )
+  mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
+  handleAction elts vars ( MouseMove mousePos )
   pure True
 
-handleScrollEvent :: UIElements -> Variables -> GDK.EventScroll -> IO Bool
-handleScrollEvent elts vars scrollEvent = do
+handleScrollEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventScroll -> IO Bool
+handleScrollEvent elts vars eventOrigin scrollEvent = do
   dx <- GDK.getEventScrollDeltaX scrollEvent
   dy <- GDK.getEventScrollDeltaY scrollEvent
   x  <- GDK.getEventScrollX scrollEvent
   y  <- GDK.getEventScrollY scrollEvent
-  handleAction elts vars ( Scroll ( Point2D x y ) ( Vector2D dx dy ) )
+  mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
+  handleAction elts vars ( Scroll mousePos ( Vector2D dx dy ) )
   pure False
 
-handleMouseButtonEvent :: UIElements -> Variables -> GDK.EventButton -> IO Bool
-handleMouseButtonEvent elts vars mouseClickEvent = do
+handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
+handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do
   button <- GDK.getEventButtonButton mouseClickEvent
   x <- GDK.getEventButtonX mouseClickEvent
   y <- GDK.getEventButtonY mouseClickEvent
-  handleAction elts vars ( MouseClick button ( Point2D x y ) )
+  mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
+  handleAction elts vars ( MouseClick eventOrigin button mousePos )
   pure False
 
-handleMouseButtonRelease :: UIElements -> Variables -> GDK.EventButton -> IO Bool
-handleMouseButtonRelease elts vars mouseReleaseEvent = do
+handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
+handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do
   button <- GDK.getEventButtonButton mouseReleaseEvent
   x <- GDK.getEventButtonX mouseReleaseEvent
   y <- GDK.getEventButtonY mouseReleaseEvent
-  handleAction elts vars ( MouseRelease button ( Point2D x y ) )
+  mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
+  handleAction elts vars ( MouseRelease button mousePos )
   pure False
 
+adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double )
+adjustMousePosition   _                   ViewportOrigin        pt            = pure pt
+adjustMousePosition ( Viewport { .. } ) ( RulerOrigin ruler ) ( Point2D x y ) =
+  case ruler of
+    RulerCorner -> do
+      dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  rulerCornerDrawingArea
+      dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight rulerCornerDrawingArea
+      pure ( Point2D ( x - dx ) ( y - dy ) )
+    LeftRuler -> do
+      dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth    leftRulerDrawingArea
+      pure ( Point2D ( x - dx ) y )
+    TopRuler -> do
+      dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight    topRulerDrawingArea
+      pure ( Point2D x ( y - dy ) )
+
 --------------------------------------------------------------------------------
 -- Keyboard events.
 

src/app/MetaBrush/Render/Document.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DeriveTraversable   #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE DerivingVia         #-}
@@ -8,16 +9,17 @@
 {-# LANGUAGE NegativeLiterals    #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 
 module MetaBrush.Render.Document
-  ( renderDocument, blankRender )
+  ( renderDocument, renderGuides, blankRender )
   where
 
 -- base
 import Control.Monad
   ( guard, when, unless )
 import Data.Foldable
-  ( for_, sequenceA_ )
+  ( for_, sequenceA_, toList )
 import Data.Functor.Compose
   ( Compose(..) )
 import Data.Int
@@ -36,6 +38,8 @@ import Data.Act
   )
 
 -- containers
+import qualified Data.Map as Map
+  ( adjust )
 import Data.Sequence
   ( Seq(..) )
 import qualified Data.Sequence as Seq
@@ -46,6 +50,8 @@ import Generic.Data
   ( Generically1(..) )
 
 -- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
 import Data.Generics.Product.Typed
   ( HasType )
 
@@ -54,7 +60,7 @@ import qualified GI.Cairo.Render as Cairo
 
 -- lens
 import Control.Lens
-  ( view )
+  ( view, over )
 
 -- MetaBrush
 import qualified Math.Bezier.Cubic     as Cubic
@@ -65,13 +71,15 @@ import Math.Bezier.Stroke
   ( StrokePoint(..), stroke )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
+import MetaBrush.Action
+  ( ActionOrigin(..) )
 import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
 import MetaBrush.Context
-  ( HoldAction(..), PartialPath(..) )
+  ( HoldAction(..), GuideAction(..), PartialPath(..) )
 import MetaBrush.Document
   ( Document(..)
-  , Stroke(..), FocusState(..)
+  , Stroke(..), Guide(..), FocusState(..)
   , PointData(..), BrushPointData(..)
   , _selection
   )
@@ -79,6 +87,8 @@ import MetaBrush.Document.Selection
   ( translateSelection )
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
+import MetaBrush.UI.Viewport
+  ( Ruler(..) )
 import MetaBrush.Util
   ( withRGBA )
 
@@ -105,7 +115,7 @@ toAll action = Compose ( pure action )
 --------------------------------------------------------------------------------
 
 blankRender :: Colours -> Cairo.Render ()
-blankRender ( Colours { .. } ) = pure ()
+blankRender ( Colours {..} ) = pure ()
 
 renderDocument
   :: Colours -> Mode -> ( Int32, Int32 )
@@ -176,6 +186,73 @@ renderDocument
   
     pure ()
 
+renderGuides
+  :: Colours -> ( Int32, Int32 ) -> ActionOrigin -> ( Int32, Int32 )
+  -> Maybe ( Point2D Double ) -> Maybe HoldAction
+  -> Document 
+  -> Cairo.Render ()
+renderGuides
+  cols ( viewportWidth, viewportHeight ) actionOrigin ( width, height )
+  mbMousePos mbHoldEvent
+  ( Document { viewportCenter = Point2D cx cy, zoomFactor, guides } ) = do
+
+    let
+      modifiedGuides :: [ Guide ]
+      modifiedGuides
+        | Just ( GuideAction { holdStartPos = mousePos0, guideAction = act } ) <- mbHoldEvent
+        , Just mousePos <- mbMousePos
+        = case act of
+            MoveGuide guideUnique
+              -> 
+                let
+                  translate :: Point2D Double -> Point2D Double
+                  translate = ( ( mousePos0 --> mousePos :: Vector2D Double ) • )
+                in toList ( Map.adjust ( over ( field' @"guidePoint" ) translate ) guideUnique guides )
+            CreateGuide ruler
+              -> let
+                  addNewGuides :: [ Guide ] -> [ Guide ]
+                  addNewGuides gs = case ruler of
+                    RulerCorner
+                      -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideUnique = undefined }
+                       : Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideUnique = undefined }
+                       : gs
+                    LeftRuler
+                      -> Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideUnique = undefined }
+                       : gs
+                    TopRuler
+                      -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideUnique = undefined }
+                       : gs
+                 in addNewGuides ( toList guides )
+        | otherwise
+        = toList guides
+
+    Cairo.save
+    Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
+    additionalAdjustment
+    Cairo.scale zoomFactor zoomFactor
+    Cairo.translate ( -cx ) ( -cy )
+
+    for_ modifiedGuides ( renderGuide cols zoomFactor )
+
+    Cairo.restore
+  
+    pure ()
+
+  where
+    dx, dy :: Double
+    dx = fromIntegral width
+    dy = fromIntegral height
+    additionalAdjustment :: Cairo.Render ()
+    additionalAdjustment = case actionOrigin of
+      ViewportOrigin -> pure ()
+      RulerOrigin ruler -> case ruler of
+        RulerCorner -> do
+          Cairo.translate dx dy
+        LeftRuler -> do
+          Cairo.translate dx 0
+        TopRuler -> do
+          Cairo.translate 0 dy
+
 renderStroke :: Colours -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render ()
 renderStroke cols@( Colours { brush } ) mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
   | strokeVisible
@@ -276,8 +353,24 @@ renderBrushShape cols zoom pt =
     *> Compose blank { renderPPts = drawCross cols zoom }
     *> toAll Cairo.restore
 
+renderGuide :: Colours -> Double -> Guide -> Cairo.Render ()
+renderGuide ( Colours {..} ) zoom ( Guide { guidePoint = Point2D x y , guideNormal = Vector2D nx ny } ) = do
+
+  Cairo.save
+  Cairo.translate x y
+  Cairo.scale ( 1 / zoom ) ( 1 / zoom )
+
+  Cairo.setLineWidth 2.0
+  withRGBA guide Cairo.setSourceRGBA
+
+  Cairo.moveTo (  1e5 * ny ) ( -1e5 * nx )
+  Cairo.lineTo ( -1e5 * ny ) (  1e5 * nx )
+  Cairo.stroke
+
+  Cairo.restore
+
 drawPoint :: HasType FocusState d => Colours -> Double -> StrokePoint d -> Cairo.Render ()
-drawPoint ( Colours { .. } ) zoom pt@( PathPoint { coords = Point2D x y } )
+drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } )
   = do
   let
     hsqrt3 :: Double
@@ -311,7 +404,7 @@ drawPoint ( Colours { .. } ) zoom pt@( PathPoint { coords = Point2D x y } )
 
   Cairo.restore
 
-drawPoint ( Colours { .. } ) zoom pt@( ControlPoint { coords = Point2D x y } )
+drawPoint ( Colours {..} ) zoom pt@( ControlPoint { coords = Point2D x y } )
   = do
   let
     selectionState :: FocusState
@@ -450,7 +543,7 @@ drawStroke ( Colours { brushStroke } ) strokeData = do
     go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
 
 drawSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
-drawSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
+drawSelectionRectangle ( Colours {..} ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
 
   Cairo.save
 
@@ -470,7 +563,7 @@ drawSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1
   Cairo.restore
 
 drawCross :: Colours -> Double -> Cairo.Render ()
-drawCross ( Colours { .. } ) zoom = do
+drawCross ( Colours {..} ) zoom = do
   Cairo.save
 
   Cairo.setLineWidth 1.5

src/app/MetaBrush/UI/Coordinates.hs

@@ -29,7 +29,7 @@ import qualified Math.Bezier.Quadratic as Quadratic
 import Math.Bezier.Stroke
   ( StrokePoint(..) )
 import Math.Module
-  ( (*^), squaredNorm, closestPointToLine )
+  ( (*^), squaredNorm, closestPointToSegment )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Document
@@ -55,19 +55,19 @@ closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) =
     -- Line.
     go ( PathPoint { coords = p0 } )
       ( sp1@( PathPoint { coords = p1 } ) :<| ps )
-      = res ( closestPointToLine @( Vector2D Double ) c p0 p1 )
+      = res ( closestPointToSegment @( Vector2D Double ) c p0 p1 )
       <> go sp1 ps
     -- Quadratic Bézier curve.
     go ( PathPoint { coords = p0 } )
       ( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps )
       = fmap ( fmap ( Just . snd ) )
-        ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier { .. } ) c )
+        ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) c )
       <> go sp2 ps
     -- Cubic Bézier curve.
     go ( PathPoint { coords = p0 } )
       ( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps )
       = fmap ( fmap ( Just . snd ) )
-        ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier { .. } ) c )
+        ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) c )
       <> go sp3 ps
     go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps )
 closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing

src/app/MetaBrush/UI/FileBar.hs

@@ -49,7 +49,9 @@ import MetaBrush.Context
 import MetaBrush.Document
   ( Document(..), emptyDocument )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
-  ( InfoBar )
+  ( InfoBar, updateInfoBar )
+import MetaBrush.UI.Viewport
+  ( Viewport(..) )
 import MetaBrush.Unique
   ( Unique, freshUnique, uniqueText )
 import MetaBrush.Util
@@ -78,8 +80,8 @@ newFileTab
   -> TabLocation
   -> IO ()
 newFileTab
-  uiElts@( UIElements { fileBar = FileBar {..}, .. } )
-  vars@( Variables { .. } )
+  uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } )
+  vars@( Variables {..} )
   mbDoc
   newTabLoc
   = do
@@ -157,6 +159,7 @@ newFileTab
       STM.writeTVar   activeDocumentTVar ( Just newUnique )
 
     GTK.widgetQueueDraw viewportDrawingArea
+    updateInfoBar viewportDrawingArea infoBar vars
 
     void $ GTK.onButtonClicked pgButton do
       isActive <- GTK.toggleButtonGetActive pgButton
@@ -181,12 +184,12 @@ newFileTab
 -- Updates the active document when buttons are clicked.
 createFileBar
   :: Colours -> Variables
-  -> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar
+  -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar
   -> IO FileBar
 createFileBar
   colours
   vars@( Variables { openDocumentsTVar } )
-  window titleBar title viewportDrawingArea infoBar
+  window titleBar title viewport infoBar
   = do
 
     -- Create file bar: box containing scrollable tabs, and a "+" button after it.
@@ -212,9 +215,9 @@ createFileBar
 
     let
       fileBar :: FileBar
-      fileBar = FileBar { .. }
+      fileBar = FileBar {..}
       uiElements :: UIElements
-      uiElements = UIElements { .. }
+      uiElements = UIElements {..}
 
     documents <- STM.readTVarIO openDocumentsTVar
     for_ documents \ doc ->
@@ -233,7 +236,7 @@ createFileBar
 
 -- | Close a document: remove the corresponding file tab from the file bar.
 removeFileTab :: Variables -> Unique -> IO ()
-removeFileTab ( Variables { .. } ) docUnique = do
+removeFileTab ( Variables {..} ) docUnique = do
 
   cleanupAction <- STM.atomically do
     -- Remove the tab.

src/app/MetaBrush/UI/FileBar.hs-boot

@@ -17,6 +17,8 @@ import MetaBrush.Document
   ( Document )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar )
+import MetaBrush.UI.Viewport
+  ( Viewport )
 import MetaBrush.Unique
   ( Unique )
 
@@ -37,7 +39,7 @@ instance Show TabLocation
 
 createFileBar
   :: Colours -> Variables
-  -> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar
+  -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar
   -> IO FileBar
 
 newFileTab

src/app/MetaBrush/UI/InfoBar.hs

@@ -96,7 +96,7 @@ createInfoBar colours = do
   -- Magnifier
 
   magnifierArea <- GTK.drawingAreaNew
-  zoomText <- GTK.labelNew ( Just "  100.00%" )
+  zoomText <- GTK.labelNew ( Just na )
 
   GTK.boxPackStart zoomBox magnifierArea True True 0
   GTK.boxPackStart zoomBox zoomText      True True 0
@@ -111,7 +111,7 @@ createInfoBar colours = do
   -- Cursor position
 
   cursorPosArea <- GTK.drawingAreaNew
-  cursorPosText <- GTK.labelNew ( Just "x:      0.00\ny:      0.00" )
+  cursorPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
 
   GTK.boxPackStart cursorPosBox cursorPosArea False False 0
   GTK.boxPackStart cursorPosBox cursorPosText False False 0
@@ -126,7 +126,7 @@ createInfoBar colours = do
   -- Top left position
 
   topLeftPosArea <- GTK.drawingAreaNew
-  topLeftPosText <- GTK.labelNew ( Just "x:      0.00\ny:      0.00" )
+  topLeftPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
 
   GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0
   GTK.boxPackStart topLeftPosBox topLeftPosText False False 0
@@ -139,7 +139,7 @@ createInfoBar colours = do
   -- Bottom right position
 
   botRightPosArea <- GTK.drawingAreaNew
-  botRightPosText <- GTK.labelNew ( Just "x:      0.000\ny:      0.00" )
+  botRightPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
 
   GTK.boxPackStart botRightPosBox botRightPosArea False False 0
   GTK.boxPackStart botRightPosBox botRightPosText False False 0
@@ -159,17 +159,14 @@ createInfoBar colours = do
   for_ [ zoomText, cursorPosText, topLeftPosText, botRightPosText ] \ info -> do
     widgetAddClass info "infoBarInfo"
 
-  pure ( InfoBar { .. } )
+  pure ( InfoBar {..} )
 
 updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO ()
-updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePosTVar } )
+updateInfoBar viewportDrawingArea ( InfoBar {..} ) vars@( Variables { mousePosTVar } )
   = do
     viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
     viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
     mbDoc <- STM.atomically $ currentDocument vars
-    let
-      na :: IsString a => a
-      na = "      n/a"
     case mbDoc of
       Nothing -> do
         GTK.labelSetText        zoomText $ na
@@ -182,7 +179,7 @@ updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePos
           toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
           Point2D l t = toViewport ( Point2D 0 0 )
           Point2D r b = toViewport ( Point2D viewportWidth viewportHeight )
-        mbMousePos <- fmap toViewport <$> STM.readTVarIO mousePosTVar
+        mbMousePos <- STM.readTVarIO mousePosTVar
         GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoomFactor ) <> "%" )
         case mbMousePos of
           Just ( Point2D mx my ) ->
@@ -201,3 +198,6 @@ fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFl
       r = length bs
     in
       replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0'
+
+na :: IsString a => a
+na = "      n/a"

src/app/MetaBrush/UI/Menu.hs

@@ -233,7 +233,7 @@ newMenuItem
   -> GTK.AccelGroup
   -> MenuItem action submenu Description
   -> m GTK.MenuItem
-newMenuItem uiElts vars accelGroup ( MenuItemDescription { .. } ) = do
+newMenuItem uiElts vars accelGroup ( MenuItemDescription {..} ) = do
   menuItem <- GTK.menuItemNewWithLabel menuItemLabel
   for_ menuItemAccel \ ( key, modifiers ) -> do
     GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ]
@@ -279,7 +279,7 @@ instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Descript
       , menuItemSubmenu = submenuItems
       }
 instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
-  createMenuItem _ _ _ attachToParent ( SeparatorDescription { .. } ) = do
+  createMenuItem _ _ _ attachToParent ( SeparatorDescription {..} ) = do
     separator <- GTK.separatorMenuItemNew
     unless ( null separatorClasses ) do
       widgetAddClasses separator separatorClasses

src/app/MetaBrush/UI/ToolBar.hs

@@ -140,4 +140,4 @@ createToolBar toolTVar modeTVar colours drawingArea toolBar = do
     $ Cairo.renderWithContext
       ( drawMeta colours )
 
-  pure ( ToolBar { .. } )
+  pure ( ToolBar {..} )

src/app/MetaBrush/UI/Viewport.hs

@@ -1,11 +1,19 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE BlockArguments     #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.UI.Viewport
-  ( Viewport(..), createViewport )
+  ( Viewport(..), createViewport
+  , Ruler(..)
+  )
   where
 
+-- base
+import Data.Foldable
+  ( for_ )
+
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
@@ -20,7 +28,11 @@ import MetaBrush.Util
 
 data Viewport
   = Viewport
-  { viewportDrawingArea :: !GTK.DrawingArea
+  {    viewportDrawingArea
+  , rulerCornerDrawingArea
+  ,   leftRulerDrawingArea
+  ,    topRulerDrawingArea
+    :: !GTK.DrawingArea
   }
 
 createViewport :: GTK.Grid -> IO Viewport
@@ -61,14 +73,14 @@ createViewport viewportGrid = do
   GTK.revealerSetTransitionType rvLeftRuler   GTK.RevealerTransitionTypeSlideLeft
   GTK.revealerSetTransitionType rvTopRuler    GTK.RevealerTransitionTypeSlideUp
 
-  rulerCornerArea <- GTK.drawingAreaNew
-  GTK.boxPackStart rulerCorner rulerCornerArea True True 0
+  rulerCornerDrawingArea <- GTK.drawingAreaNew
+  GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0
 
-  leftRulerArea   <- GTK.drawingAreaNew
-  GTK.boxPackStart leftRuler   leftRulerArea   True True 0
+  leftRulerDrawingArea   <- GTK.drawingAreaNew
+  GTK.boxPackStart leftRuler   leftRulerDrawingArea   True True 0
   
-  topRulerArea    <- GTK.drawingAreaNew
-  GTK.boxPackStart topRuler    topRulerArea    True True 0
+  topRulerDrawingArea    <- GTK.drawingAreaNew
+  GTK.boxPackStart topRuler    topRulerDrawingArea    True True 0
 
   GTK.widgetSetHexpand rulerCorner     False
   GTK.widgetSetVexpand rulerCorner     False
@@ -81,12 +93,15 @@ createViewport viewportGrid = do
 
   viewportDrawingArea <- GTK.drawingAreaNew
   GTK.setContainerChild viewportOverlay viewportDrawingArea
-  GTK.widgetAddEvents viewportDrawingArea
-    [ GDK.EventMaskPointerMotionMask
-    , GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask
-    , GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask
-    ]
 
+  for_ [ rulerCornerDrawingArea, leftRulerDrawingArea, topRulerDrawingArea, viewportDrawingArea ] \ drawingArea -> do
+    GTK.widgetAddEvents drawingArea
+      [ GDK.EventMaskPointerMotionMask
+      , GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask
+      , GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask
+      ]
+
+  {-
   -----------------
   -- Viewport scrolling
 
@@ -105,4 +120,14 @@ createViewport viewportGrid = do
   widgetAddClass viewportHScrollbar "viewportScrollbar"
   widgetAddClass viewportVScrollbar "viewportScrollbar"
 
-  pure ( Viewport { .. } )
+  -}
+
+  pure ( Viewport {..} )
+
+--------------------------------------------------------------------------------
+
+data Ruler
+  = RulerCorner
+  | LeftRuler
+  | TopRuler
+  deriving stock Show

src/lib/Math/Bezier/Cubic.hs

@@ -77,7 +77,7 @@ deriving via Ap Bezier p
 
 -- | Cubic Bézier curve.
 bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
-bezier ( Bezier { .. } ) t =
+bezier ( Bezier {..} ) t =
   lerp @v t
     ( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t )
     ( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t )
@@ -85,7 +85,7 @@ bezier ( Bezier { .. } ) t =
 
 -- | Derivative of cubic Bézier curve.
 bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
-bezier' ( Bezier { .. } ) t
+bezier' ( Bezier {..} ) t
   = ( 3 *^ )
   $ lerp @v t
       ( lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) )
@@ -93,7 +93,7 @@ bezier' ( Bezier { .. } ) t
 
 -- | Subdivide a cubic Bézier curve into two parts.
 subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
-subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
+subdivide ( Bezier {..} ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
   where
     pt, s, q1, q2, r1, r2 :: p
     q1 = lerp @v t p0 p1
@@ -105,7 +105,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
 
 -- | Polynomial coefficients of the derivative of the distance to a cubic Bézier curve.
 ddist :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> [ r ]
-ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3, a4, a5 ]
+ddist ( Bezier {..} ) c = [ a0, a1, a2, a3, a4, a5 ]
   where
     v, v', v'', v''' :: v
     v    = c  --> p0
@@ -123,7 +123,7 @@ ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3, a4, a5 ]
 
 -- | 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 -> ArgMin r ( r, p )
-closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists
+closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists
   where
     roots :: [ r ]
     roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c )

src/lib/Math/Bezier/Quadratic.hs

@@ -75,15 +75,15 @@ deriving via Ap Bezier p
 
 -- | Quadratic Bézier curve.
 bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
-bezier ( Bezier { .. } ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
+bezier ( Bezier {..} ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
 
 -- | Derivative of quadratic Bézier curve.
 bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
-bezier' ( Bezier { .. } ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 )
+bezier' ( Bezier {..} ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 )
 
 -- | Subdivide a quadratic Bézier curve into two parts.
 subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
-subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
+subdivide ( Bezier {..} ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
   where
     pt, q1, r1 :: p
     q1 = lerp @v t p0 p1
@@ -92,7 +92,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
 
 -- | Polynomial coefficients of the derivative of the distance to a quadratic Bézier curve.
 ddist :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> [ r ]
-ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3 ]
+ddist ( Bezier {..} ) c = [ a0, a1, a2, a3 ]
   where
     v, v', v'' :: v
     v   = c  --> p0
@@ -107,7 +107,7 @@ ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3 ]
 
 -- | Finds the closest point to a given point on a quadratic Bézier curve.
 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 )
+closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots )
   where
     roots :: [ r ]
     roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c ) 

src/lib/Math/Bezier/Stroke.hs

@@ -227,7 +227,7 @@ stroke allPts@( spt0 :<| spt1 :<| spts )
           tgt2 :: Vector2D Double
           tgt2 = p1 --> p2
           bez :: Quadratic.Bezier ( Point2D Double )
-          bez = Quadratic.Bezier { .. }
+          bez = Quadratic.Bezier {..}
           brush :: Double -> Seq ( StrokePoint () )
           brush t = quadraticBezierBrush t
             ( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) )
@@ -261,7 +261,7 @@ stroke allPts@( spt0 :<| spt1 :<| spts )
           tgt3 :: Vector2D Double
           tgt3 = p2 --> p3
           bez :: Cubic.Bezier ( Point2D Double )
-          bez = Cubic.Bezier { .. }
+          bez = Cubic.Bezier {..}
           brush :: Double -> Seq ( StrokePoint () )
           brush t = cubicBezierBrush t
             ( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) )
@@ -313,11 +313,11 @@ quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s
     f ( PathPoint { coords = p0 } )
       ( PathPoint { coords = p1 } )
       ( PathPoint { coords = p2 } )
-        = PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t
+        = PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
     f ( ControlPoint { coords = p0 } )
       ( ControlPoint { coords = p1 } )
       ( ControlPoint { coords = p2 } )
-        = CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t
+        = CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
     f p1 p2 p3 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3 ]
 
 cubicBezierBrush :: forall d. Show d => Double -> Cubic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
@@ -328,12 +328,12 @@ cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s
       ( PathPoint { coords = p1 } )
       ( PathPoint { coords = p2 } )
       ( PathPoint { coords = p3 } )
-         = PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier { .. } ) t
+         = PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t
     f ( ControlPoint { coords = p0 } )
       ( ControlPoint { coords = p1 } )
       ( ControlPoint { coords = p2 } )
       ( ControlPoint { coords = p3 } )
-        = CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier { .. } ) t
+        = CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t
     f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ]
 
 fitCurve
@@ -407,7 +407,7 @@ splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| _ )
   , let
       q1, p, r1 :: Point2D Double
       ( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ )
-        = Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t
+        = Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
   = ( PP p0 :<| CP q1 :<| PP p  :<| Empty
     , PP p  :<| CP r1 :<| PP p2 :<| Empty
     )
@@ -420,7 +420,7 @@ splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| _ )
   , let
       q1, q2, p, r1, r2 :: Point2D Double
       ( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ )
-        = Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier { .. } ) t
+        = Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier {..} ) t
   = ( PP p0 :<| CP q1 :<| CP q2 :<| PP p  :<| Empty
     , PP p  :<| CP r1 :<| CP r2 :<| PP p3 :<| Empty
     )
@@ -463,7 +463,7 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
         tgt1 :: Vector2D Double
         tgt1 = p1 --> p2
       in case between tgt tgt0 tgt1 of
-          Just t  -> Offset i ( Just t ) ( MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t )
+          Just t  -> Offset i ( Just t ) ( MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t )
           Nothing -> continue ( i + 2 ) tgt1 sp2 ps
     -- Cubic Bézier curve.
     go i tgt0
@@ -475,7 +475,7 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
         tgt1 = p1 --> p2
         tgt2 = p2 --> p3
         bez :: Cubic.Bezier ( Point2D Double )
-        bez = Cubic.Bezier { .. }
+        bez = Cubic.Bezier {..}
         c01, c12, c23 :: Double
         c01 = tgt `cross` tgt0
         c12 = tgt `cross` tgt1

src/lib/Math/Module.hs

@@ -10,7 +10,7 @@ module Math.Module
   ( Module(..), lerp
   , Inner(..)
   , squaredNorm, quadrance, distance
-  , proj, projC, closestPointToLine
+  , proj, projC, closestPointToSegment
   )
   where
 
@@ -79,11 +79,11 @@ proj x y = projC x y *^ y
 projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r
 projC x y = x ^.^ y / squaredNorm y
 
-closestPointToLine
+closestPointToSegment
   :: forall v r p
   . ( Inner r v, Torsor v p, Fractional r, Ord r )
   => p -> p -> p -> p
-closestPointToLine c p0 p1
+closestPointToSegment c p0 p1
   | t <= 0
   = p0
   | t >= 1