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(..)
+  ( Document(..), emptyDocument
-  , FocusState(..)
+  , 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,14 +114,9 @@ import qualified Paths_MetaBrush as Cabal
 
 testDocuments :: Map Unique Document
 testDocuments = uniqueMapFromList
-  [ Document
+  [ ( emptyDocument "Closed" ( unsafeUnique 0 ) )
-    { displayName    = "Closed"
+    { strokes =
-    , mbFilePath     = Nothing
+      [ Stroke
-    , unsavedChanges = False
-    , viewportCenter = Point2D 50 50
-    , zoomFactor     = 1
-    , documentUnique = unsafeUnique 0
-    , strokes        = [ Stroke
         { strokeName    = "Ellipse"
         , strokeVisible = True
         , strokeUnique  = unsafeUnique 10
@@ -123,14 +124,9 @@ testDocuments = uniqueMapFromList
         }
       ]
     }
-  , Document
+  , ( emptyDocument "Line" ( unsafeUnique 1 ) )
-    { displayName    = "Line"
+    { strokes =
-    , mbFilePath     = Nothing
+      [ Stroke
-    , unsavedChanges = False
-    , viewportCenter = Point2D 0 0
-    , zoomFactor     = 1
-    , documentUnique = unsafeUnique 1
-    , strokes        = [ Stroke
         { strokeName    = "Line"
         , strokeVisible = True
         , strokeUnique  = unsafeUnique 11
@@ -138,14 +134,9 @@ testDocuments = uniqueMapFromList
         }
       ]
     }
-  , Document
+  , ( emptyDocument "Short line" ( unsafeUnique 2 ) )
-    { displayName    = "Short line"
+    { strokes =
-    , mbFilePath     = Nothing
+      [ Stroke
-    , unsavedChanges = False
-    , viewportCenter = Point2D 0 0
-    , zoomFactor     = 1
-    , documentUnique = unsafeUnique 2
-    , strokes        = [ Stroke
         { strokeName    = "ShortLine"
         , strokeVisible = True
         , strokeUnique  = unsafeUnique 12
@@ -292,7 +283,7 @@ main = do
   ---------------------------------------------------------
   -- Main viewport
 
-  Viewport { viewportDrawingArea } <- createViewport viewportGrid
+  viewport@( Viewport { .. } ) <- createViewport viewportGrid
 
   -----------------
   -- Viewport rendering
@@ -306,17 +297,42 @@ main = do
       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
 
@@ -334,7 +350,7 @@ main = do
     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
@@ -347,7 +363,9 @@ main = do
   ------------
   -- 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
@@ -287,7 +301,10 @@ pattern SaveAndClose = 2
 pattern CancelClose  = 3
 
 instance HandleAction Close where
-  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) close = do
+  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
@@ -334,7 +351,10 @@ data SwitchTo = SwitchTo Unique
   deriving stock Show
 
 instance HandleAction SwitchTo where
-  handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( SwitchTo newUnique ) = do
+  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
@@ -469,7 +489,7 @@ data Confirm = Confirm
 
 instance HandleAction Confirm where
   handleAction
-    ( UIElements { viewportDrawingArea } )
+    ( UIElements { viewport = Viewport {..} } )
     ( Variables {..} )
     _
     = do
@@ -504,8 +524,8 @@ data MouseMove = MouseMove ( Point2D Double )
 
 instance HandleAction MouseMove where
   handleAction
-    ( UIElements { viewportDrawingArea, infoBar } )
+    ( UIElements { viewport = Viewport {..}, .. } )
-    vars@( Variables { mousePosTVar, modifiersTVar, toolTVar, partialPathTVar } )
+    vars@( Variables {..} )
     ( MouseMove ( Point2D x y ) )
     = do
       viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
@@ -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 } )
+    uiElts@( UIElements { viewport = Viewport {..} } )
     vars@( Variables {..} )
-    ( MouseClick button mouseClickCoords )
+    ( MouseClick actionOrigin button mouseClickCoords )
     = case button of
 
       -- Left mouse button.
@@ -558,6 +585,9 @@ instance HandleAction MouseClick where
             pos :: Point2D Double
             pos = toViewport mouseClickCoords
           STM.writeTVar mousePosTVar ( Just pos )
+          case actionOrigin of
+
+            ViewportOrigin -> do
               modifiers <- STM.readTVar modifiersTVar
               tool <- STM.readTVar toolTVar
               mode <- STM.readTVar modeTVar
@@ -603,6 +633,19 @@ instance HandleAction MouseClick where
                       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
         STM.atomically $ STM.writeTVar partialPathTVar Nothing
@@ -621,7 +664,7 @@ data MouseRelease = MouseRelease Word32 ( Point2D Double )
 
 instance HandleAction MouseRelease where
   handleAction 
-    uiElts@( UIElements { viewportDrawingArea } )
+    uiElts@( UIElements { viewport = Viewport {..} } )
     vars@( Variables {..} )
     ( MouseRelease button ( Point2D x y ) )
     = case button of
@@ -639,6 +682,43 @@ instance HandleAction MouseRelease where
           STM.writeTVar mousePosTVar  ( Just pos )
           modifiers <- STM.readTVar modifiersTVar
           mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
+
+          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
+
               tool      <- STM.readTVar toolTVar
               mode      <- STM.readTVar modeTVar
 
@@ -746,7 +826,10 @@ 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
@@ -808,7 +891,10 @@ 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

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 ]

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
@@ -89,7 +91,7 @@ data UIElements
   , title    :: !GTK.Label
   , titleBar :: !GTK.Box
   , fileBar  :: !FileBar
-  , viewportDrawingArea :: !GTK.DrawingArea
+  , viewport :: !Viewport
   , infoBar  :: !InfoBar
   , colours  :: !Colours
   }
@@ -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 )
+  onWidgetMouseEvent    viewportDrawingArea ViewportOrigin
-  _ <- GTK.onWidgetScrollEvent        viewportDrawingArea ( handleScrollEvent        elts vars )
+  onWidgetMouseEvent rulerCornerDrawingArea ( RulerOrigin RulerCorner )
-  _ <- GTK.onWidgetButtonPressEvent   viewportDrawingArea ( handleMouseButtonEvent   elts vars )
+  onWidgetMouseEvent   leftRulerDrawingArea ( RulerOrigin LeftRuler   )
-  _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease elts vars )
+  onWidgetMouseEvent    topRulerDrawingArea ( RulerOrigin TopRuler    )
 
   -- Keyboard events
-  _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   elts vars )
+  void $ GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   elts vars )
-  _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent 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 :: UIElements -> Variables -> ActionOrigin -> GDK.EventMotion -> IO Bool
-handleMotionEvent elts vars eventMotion = do
+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 :: UIElements -> Variables -> ActionOrigin -> GDK.EventScroll -> IO Bool
-handleScrollEvent elts vars scrollEvent = do
+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 :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
-handleMouseButtonEvent elts vars mouseClickEvent = do
+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 :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
-handleMouseButtonRelease elts vars mouseReleaseEvent = do
+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 )
 
@@ -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,6 +353,22 @@ 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 } )
   = do

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,7 +55,7 @@ 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 } )

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,7 +80,7 @@ newFileTab
   -> TabLocation
   -> IO ()
 newFileTab
-  uiElts@( UIElements { fileBar = FileBar {..}, .. } )
+  uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } )
   vars@( Variables {..} )
   mbDoc
   newTabLoc
@@ -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.

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
@@ -167,9 +167,6 @@ updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePos
     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/Viewport.hs

@@ -1,11 +1,19 @@
+{-# 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
+  rulerCornerDrawingArea <- GTK.drawingAreaNew
-  GTK.boxPackStart rulerCorner rulerCornerArea True True 0
+  GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0
 
-  leftRulerArea   <- GTK.drawingAreaNew
+  leftRulerDrawingArea   <- GTK.drawingAreaNew
-  GTK.boxPackStart leftRuler   leftRulerArea   True True 0
+  GTK.boxPackStart leftRuler   leftRulerDrawingArea   True True 0
   
-  topRulerArea    <- GTK.drawingAreaNew
+  topRulerDrawingArea    <- GTK.drawingAreaNew
-  GTK.boxPackStart topRuler    topRulerArea    True True 0
+  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
+
+  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 {..} )
+
+--------------------------------------------------------------------------------
+
+data Ruler
+  = RulerCorner
+  | LeftRuler
+  | TopRuler
+  deriving stock Show

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