add hover indicator for points and guides

MetaBrush.cabal

@@ -114,7 +114,6 @@ executable MetaBrush
       , MetaBrush.Context
       , MetaBrush.Document
       , MetaBrush.Document.Draw
-      , MetaBrush.Document.Guide
       , MetaBrush.Document.Selection
       , MetaBrush.Document.Serialise
       , MetaBrush.Document.SubdivideStroke

assets/theme.css

@@ -58,7 +58,7 @@
   color: rgb(0,0,0);
 }
 .pointHover {
-  color: rgb(225,225,225);
+  color: rgb(231, 172, 83);
 }
 .pointSelected {
   color: rgb(252,237,120);

src/app/MetaBrush/Action.hs

@@ -95,13 +95,11 @@ import MetaBrush.Context
   , updateTitle
   )
 import MetaBrush.Document
-  ( Document(..), Guide(..)
+  ( Document(..), PointData(..), FocusState(..) )
-  , PointData(..), FocusState(..)
-  )
 import MetaBrush.Document.Draw
   ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
-import MetaBrush.Document.Guide
+import MetaBrush.Document
-  ( selectGuide, addGuide )
+  ( Guide(..), selectedGuide, addGuide )
 import MetaBrush.Document.Selection
   ( SelectionMode(..), selectionMode
   , selectAt, selectRectangle
@@ -695,7 +693,7 @@ instance HandleAction MouseClick where
               when showGuides do
                 let
                   mbGuide :: Maybe Guide
-                  mbGuide = selectGuide pos doc
+                  mbGuide = selectedGuide pos doc
                   guideAction :: GuideAction
                   guideAction
                     | Just guide <- mbGuide

src/app/MetaBrush/Document.hs

@@ -3,26 +3,43 @@
 {-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE TypeApplications      #-}
 
 module MetaBrush.Document
-  ( AABB(..)
+  ( AABB(..), mkAABB
   , Document(..), emptyDocument
-  , Stroke(..), Guide(..)
+  , Stroke(..)
   , PointData(..), BrushPointData(..)
-  , FocusState(..)
+  , FocusState(..), Hoverable(..), HoverContext(..)
   , _selection, _brush
+  , Guide(..)
+  , addGuide, selectedGuide
   )
   where
 
 -- base
+import Data.Semigroup
+  ( Arg(..), Min(..), ArgMin )
 import GHC.Generics
   ( Generic )
 
+-- acts
+import Data.Act
+  ( Act
+    ( (•) )
+  , Torsor
+    ( (-->) )
+  )
+
 -- containers
 import Data.Map.Strict
   ( Map )
+import qualified Data.Map.Strict as Map
+  ( insert )
 import qualified Data.Map.Strict as Map
   ( empty )
 import Data.Sequence
@@ -38,6 +55,10 @@ import Data.Generics.Product.Typed
 import Control.Lens
   ( Lens' )
 
+-- stm
+import Control.Concurrent.STM
+  ( STM )
+
 -- text
 import Data.Text
   ( Text )
@@ -45,10 +66,14 @@ import Data.Text
 -- MetaBrush
 import Math.Bezier.Stroke
   ( StrokePoint(..) )
+import Math.Module
+  ( Inner((^.^)), squaredNorm, quadrance )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
+import MetaBrush.UI.Viewport
+  ( Ruler(..) )
 import MetaBrush.Unique
-  ( Unique )
+  ( UniqueSupply, Unique, freshUnique )
 
 --------------------------------------------------------------------------------
 
@@ -57,6 +82,16 @@ data AABB
   { topLeft, botRight :: !( Point2D Double ) }
   deriving stock Show
 
+mkAABB :: Point2D Double -> Point2D Double -> AABB
+mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2D xmax ymax )
+  where
+    ( xmin, xmax )
+      | x1 > x2   = ( x2, x1 )
+      | otherwise = ( x1, x2 )
+    ( ymin, ymax )
+      | y1 > y2   = ( y2, y1 )
+      | otherwise = ( y1, y2 )
+
 data Document
   = Document
     { displayName    :: !Text
@@ -79,14 +114,6 @@ 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
@@ -105,6 +132,15 @@ data FocusState
   | Selected
   deriving stock ( Show, Eq )
 
+instance Semigroup FocusState where
+  Selected <> _        = Selected
+  Normal   <> s        = s
+  _        <> Selected = Selected
+  s        <> Normal   = s
+  _        <> _        = Hover
+instance Monoid FocusState where
+  mempty = Normal
+
 _selection :: HasType FocusState pt => Lens' ( StrokePoint pt ) FocusState
 _selection = field' @"pointData" . typed @FocusState
 
@@ -123,3 +159,100 @@ emptyDocument docName unique =
     , strokes        = []
     , guides         = Map.empty
     }
+
+--------------------------------------------------------------------------------
+
+data HoverContext
+  = MouseHover     !( Point2D Double )
+  | RectangleHover !AABB
+  deriving stock Show
+
+instance Act ( Vector2D Double ) HoverContext where
+  v • MouseHover p = MouseHover ( v • p )
+  v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) )
+
+instance Act ( Vector2D Double ) ( Maybe HoverContext ) where
+  (•) v = fmap ( v • )
+
+class Hoverable a where
+  hovered :: Maybe HoverContext -> Double -> a -> FocusState
+
+instance Hoverable ( Point2D Double ) where
+  hovered Nothing _ _ = Normal
+  hovered ( Just ( MouseHover p ) ) zoom q
+    | quadrance @( Vector2D Double ) p q * zoom ^ ( 2 :: Int ) < 16
+    = Hover
+    | otherwise
+    = Normal
+  hovered ( Just ( RectangleHover ( AABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) ) ) ) _ ( Point2D x y )
+    | x >= x1 && x <= x2 && y >= y1 && y <= y2
+    = Hover
+    | otherwise
+    = Normal
+
+--------------------------------------------------------------------------------
+-- Guides.
+
+data Guide
+  = Guide
+  { guidePoint  :: !( Point2D  Double ) -- ^ point on the guide line
+  , guideNormal :: !( Vector2D Double ) -- ^ /normalised/ normal vector of the guide
+  , guideFocus  :: !FocusState
+  , guideUnique :: Unique
+  }
+  deriving stock ( Show, Generic )
+
+-- | Try to select a guide at the given document coordinates.
+selectedGuide :: Point2D Double -> Document -> Maybe Guide
+selectedGuide c ( Document { zoomFactor, guides } ) =
+  \case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) guides
+
+selectGuide_maybe :: Point2D Double -> Double -> Guide -> Maybe ( ArgMin Double Guide )
+selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
+  | sqDist * zoom ^ ( 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, guideFocus = Normal, guideUnique = uniq1 }
+            guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, 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, guideFocus = Normal, guideUnique = uniq1 }
+          pure ( Map.insert uniq1 guide1 gs )
+      LeftRuler
+        -> do
+          uniq2 <- freshUnique uniqueSupply
+          let
+            guide2 :: Guide
+            guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 }
+          pure ( Map.insert uniq2 guide2 gs )
+
+instance Hoverable Guide where
+  hovered ( Just ( MouseHover c ) ) zoom guide
+    | Just _ <- selectGuide_maybe c zoom guide
+    = Hover
+    | otherwise
+    = Normal
+  hovered _ _ _ = Normal

src/app/MetaBrush/Document/Guide.hs

@@ -1,91 +0,0 @@
-{-# 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

@@ -120,8 +120,8 @@ import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Document
   ( Document(..)
-  , Stroke(..)
   , Guide(..)
+  , Stroke(..)
   , PointData(..)
   , BrushPointData(..)
   , FocusState(..)
@@ -336,16 +336,18 @@ decodeStroke uniqueSupply = do
 
 
 encodeGuide :: Applicative f => JSON.Encoder f Guide
-encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
+encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal, guideFocus } ) ->
     JSON.Encoder.atKey' "point"  ( encodePoint2D  encodeDouble ) guidePoint
   . JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal
+  . JSON.Encoder.atKey' "focus"  encodeFocusState guideFocus
 
 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 )
+  guideFocus  <- JSON.Decoder.atKey "focus" decodeFocusState
   guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
-  pure ( Guide { guidePoint, guideNormal, guideUnique } )
+  pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } )
 
 
 

src/app/MetaBrush/Render/Document.hs

@@ -1,15 +1,16 @@
-{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE BlockArguments        #-}
-{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveTraversable   #-}
+{-# LANGUAGE DeriveTraversable     #-}
-{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE DerivingVia         #-}
+{-# LANGUAGE DerivingVia           #-}
-{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NegativeLiterals    #-}
+{-# LANGUAGE NamedFieldPuns        #-}
-{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE NegativeLiterals      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
 
 module MetaBrush.Render.Document
   ( renderDocument, blankRender )
@@ -74,8 +75,9 @@ import MetaBrush.Asset.Colours
 import MetaBrush.Context
   ( HoldAction(..), PartialPath(..) )
 import MetaBrush.Document
-  ( Document(..)
+  ( Document(..), mkAABB
   , Stroke(..), FocusState(..)
+  , HoverContext(..), Hoverable(..)
   , PointData(..), BrushPointData(..)
   , _selection
   )
@@ -91,7 +93,7 @@ import MetaBrush.Util
 data Renders a
   = Renders
   { renderPath, renderStrokes, renderBrushes
-  , renderCPts, renderCLines, renderPPts :: a
+  , renderCLines, renderCPts, renderPPts :: a
   }
   deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
   deriving Applicative
@@ -129,12 +131,13 @@ renderDocument
   
     let
       renderSelectionRect :: Cairo.Render ()
-      renderSelectionRect
+      mbHoverContext :: Maybe HoverContext
+      ( renderSelectionRect, mbHoverContext )
         | Just ( SelectionHold p0 ) <- mbHoldEvent
         , Just p1 <- mbMousePos
-        = drawSelectionRectangle cols zoomFactor p0 p1
+        = ( drawSelectionRectangle cols zoomFactor p0 p1, Just $ RectangleHover ( mkAABB p0 p1 ) )
         | otherwise
-        = pure ()
+        = ( pure (), MouseHover <$> mbMousePos )
 
       modifiedStrokes :: [ Stroke ]
       modifiedStrokes
@@ -173,18 +176,18 @@ renderDocument
         | otherwise
         = strokes doc
     
-    for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols params mode zoomFactor )
+    for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode zoomFactor )
     renderSelectionRect
 
     Cairo.restore
   
     pure ()
 
-renderStroke :: Colours -> FitParameters -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render ()
+renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render ()
-renderStroke cols@( Colours { brush } ) params mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
+renderStroke cols@( Colours { brush } ) mbHoverContext params mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
   | strokeVisible
-  = renderStrokePoints cols mode zoom
+  = renderStrokePoints cols mode mbHoverContext zoom
-      ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) ( 1.5 * zoom ) )
+      ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) )
       pts
   *> Compose blank { renderStrokes = drawStroke cols ( stroke params pts ) }
   | otherwise
@@ -197,13 +200,13 @@ renderStroke cols@( Colours { brush } ) params mode zoom ( Stroke { strokePoints
 renderStrokePoints
   :: forall d
   .  ( Show d, HasType FocusState d )
-  => Colours -> Mode -> Double
+  => Colours -> Mode -> Maybe HoverContext -> Double
   -> ( StrokePoint d -> Compose Renders Cairo.Render () )
   -> Seq ( StrokePoint d )
   -> Compose Renders Cairo.Render ()
-renderStrokePoints _ _ _ _ Empty = pure ()
+renderStrokePoints _ _ _ _ _ Empty = pure ()
-renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) =
+renderStrokePoints cols mode mbHover zoom renderSubcontent ( pt0 :<| pts ) =
-  Compose blank { renderPPts = when ( mode == Path ) $ drawPoint cols zoom pt0 }
+  Compose blank { renderPPts = when ( mode == Path ) $ drawPoint cols mbHover zoom pt0 }
   *> renderSubcontent pt0
   *> go pt0 pts
     where
@@ -215,7 +218,7 @@ renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) =
         | PathPoint {} <- p1
         = Compose blank
             { renderPPts
-              = when   ( mode == Path ) $ drawPoint cols zoom p1
+              = when   ( mode == Path ) $ drawPoint cols mbHover zoom p1
             , renderPath
               = unless ( mode == Meta ) $ drawLine cols zoom p0 p1
              }
@@ -231,9 +234,9 @@ renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) =
                 drawLine cols zoom p0 p1
                 drawLine cols zoom p1 p2
             , renderCPts
-              = when   ( mode == Path ) $ drawPoint cols zoom p1
+              = when   ( mode == Path ) $ drawPoint cols mbHover zoom p1
             , renderPPts
-              = when   ( mode == Path ) $ drawPoint cols zoom p2
+              = when   ( mode == Path ) $ drawPoint cols mbHover zoom p2
             , renderPath
               = unless ( mode == Meta ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } )
             }
@@ -252,10 +255,10 @@ renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) =
                 drawLine cols zoom p2 p3
             , renderCPts
               = when   ( mode == Path ) do
-                drawPoint cols zoom p1
+                drawPoint cols mbHover zoom p1
-                drawPoint cols zoom p2
+                drawPoint cols mbHover zoom p2
             , renderPPts
-              = when   ( mode == Path ) $ drawPoint cols zoom p3
+              = when   ( mode == Path ) $ drawPoint cols mbHover zoom p3
             , renderPath
               = unless ( mode == Meta ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } )
             }
@@ -265,29 +268,31 @@ renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) =
         *> go p3 ps
       go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
 
-renderBrushShape :: Colours -> Double -> StrokePoint PointData -> Compose Renders Cairo.Render ()
+renderBrushShape :: Colours -> Maybe HoverContext -> Double -> StrokePoint PointData -> Compose Renders Cairo.Render ()
-renderBrushShape cols zoom pt =
+renderBrushShape cols mbHoverContext zoom pt =
   let
     x, y :: Double
     Point2D x y = coords pt
     brushPts :: Seq ( StrokePoint BrushPointData )
     brushPts = brushShape ( pointData pt )
+    mbHoverContext' :: Maybe HoverContext
+    mbHoverContext' = Vector2D (-x) (-y) • mbHoverContext
   in
     toAll do
       Cairo.save
       Cairo.translate x y
-    *> renderStrokePoints cols Path zoom ( const $ pure () ) brushPts
+    *> renderStrokePoints cols Path mbHoverContext' zoom ( const $ pure () ) brushPts
     *> Compose blank { renderPPts = drawCross cols zoom }
     *> toAll Cairo.restore
 
-drawPoint :: HasType FocusState d => Colours -> Double -> StrokePoint d -> Cairo.Render ()
+drawPoint :: HasType FocusState d => Colours -> Maybe HoverContext -> Double -> StrokePoint d -> Cairo.Render ()
-drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } )
+drawPoint ( Colours {..} ) mbHover zoom pt@( PathPoint { coords = Point2D x y } )
   = do
   let
     hsqrt3 :: Double
     hsqrt3 = sqrt 0.75
     selectionState :: FocusState
-    selectionState = view _selection pt
+    selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y )
 
   Cairo.save
   Cairo.translate x y
@@ -303,8 +308,8 @@ drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } )
 
   Cairo.setLineWidth 1.0
   case selectionState of
-    Normal   -> withRGBA pathPointOutline Cairo.setSourceRGBA
+    Selected -> withRGBA pathPoint        Cairo.setSourceRGBA
-    _        -> withRGBA pathPoint        Cairo.setSourceRGBA
+    _        -> withRGBA pathPointOutline Cairo.setSourceRGBA
   Cairo.strokePreserve
 
   case selectionState of
@@ -315,11 +320,11 @@ drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } )
 
   Cairo.restore
 
-drawPoint ( Colours {..} ) zoom pt@( ControlPoint { coords = Point2D x y } )
+drawPoint ( Colours {..} ) mbHover zoom pt@( ControlPoint { coords = Point2D x y } )
   = do
   let
     selectionState :: FocusState
-    selectionState = view _selection pt
+    selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y )
 
   Cairo.save
   Cairo.translate x y
@@ -329,8 +334,8 @@ drawPoint ( Colours {..} ) zoom pt@( ControlPoint { coords = Point2D x y } )
 
   Cairo.setLineWidth 1.0
   case selectionState of
-    Normal   -> withRGBA controlPointOutline Cairo.setSourceRGBA
+    Selected -> withRGBA controlPoint        Cairo.setSourceRGBA
-    _        -> withRGBA controlPoint        Cairo.setSourceRGBA
+    _        -> withRGBA controlPointOutline Cairo.setSourceRGBA
   Cairo.strokePreserve
 
   case selectionState of

src/app/MetaBrush/Render/Rulers.hs

@@ -48,7 +48,7 @@ import qualified GI.Cairo.Render as Cairo
 
 -- lens
 import Control.Lens
-  ( over )
+  ( set, over )
 
 -- MetaBrush
 import Math.Vector2D
@@ -60,11 +60,15 @@ import MetaBrush.Asset.Colours
 import MetaBrush.Context
   ( HoldAction(..), GuideAction(..) )
 import MetaBrush.Document
-  ( Document(..), Guide(..) )
+  ( Document(..), FocusState(..), Hoverable(..), HoverContext(..)
+  , Guide(..)
+  )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.UI.Viewport
   ( Ruler(..) )
+import MetaBrush.Unique
+  ( unsafeUnique )
 import MetaBrush.Util
   ( withRGBA )
 
@@ -91,25 +95,37 @@ renderRuler
                 let
                   translate :: Point2D Double -> Point2D Double
                   translate = ( ( mousePos0 --> mousePos :: Vector2D Double ) • )
-                in toList ( Map.adjust ( over ( field' @"guidePoint" ) translate ) guideUnique guides )
+                in toList 
+                 $ Map.adjust 
+                   ( over ( field' @"guidePoint" ) translate . set ( field' @"guideFocus" ) Selected )
+                   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 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 }
-                       : Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideUnique = undefined }
+                       : Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 }
                        : gs
                     LeftRuler
-                      -> Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideUnique = undefined }
+                      -> Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 2 }
                        : gs
                     TopRuler
-                      -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideUnique = undefined }
+                      -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideFocus = Selected, guideUnique = unsafeUnique 3 }
                        : gs
                  in addNewGuides ( toList guides )
         | otherwise
         = toList guides
 
+      mbHoverContext :: Maybe HoverContext
+      mbHoverContext
+        | Just mp@( Point2D x y ) <- mbMousePos
+        , x <= left || y <= top -- only hover guides from within ruler area
+        = Just ( MouseHover mp )
+        | otherwise
+        = Nothing
+
     Cairo.save
     Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
     additionalAdjustment
@@ -119,7 +135,7 @@ renderRuler
     -- Render tick marks.
     renderTicks
     -- Render guides.
-    when showGuides ( for_ modifiedGuides ( renderGuide cols zoomFactor ) )
+    when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoomFactor ) )
     -- Render mouse cursor indicator.
     for_ mbMousePos \ ( Point2D mx my ) ->
       case actionOrigin of
@@ -254,8 +270,8 @@ renderRuler
       Cairo.stroke
       when tickHasLabel do
         if tickPosition < 0
-        then Cairo.translate -14 8
+        then Cairo.translate -14.5  6.5
-        else Cairo.translate -14 12
+        else Cairo.translate -14.5 10.5
         for_ ( show $ round @_ @Int tickPosition ) \ char -> do
           Cairo.moveTo 0 0
           Cairo.showText [char]
@@ -270,21 +286,25 @@ data Tick
   }
   deriving stock Show
 
-renderGuide :: Colours -> Double -> Guide -> Cairo.Render ()
+renderGuide :: Colours -> Maybe HoverContext -> Double -> Guide -> Cairo.Render ()
-renderGuide ( Colours {..} ) zoom ( Guide { guidePoint = Point2D x y, guideNormal = Vector2D nx ny } ) = do
+renderGuide ( Colours {..} ) mbHoverContext zoom
+  gd@( Guide { guidePoint = Point2D x y, guideNormal = Vector2D nx ny, guideFocus } )
+  = do
 
-  Cairo.save
+    Cairo.save
-  Cairo.translate x y
+    Cairo.translate x y
-  Cairo.scale ( 1 / zoom ) ( 1 / zoom )
+    Cairo.scale ( 1 / zoom ) ( 1 / zoom )
 
-  Cairo.setLineWidth 1
+    Cairo.setLineWidth 1
-  withRGBA guide Cairo.setSourceRGBA
+    case guideFocus <> hovered mbHoverContext zoom gd of
+      Normal -> withRGBA guide      Cairo.setSourceRGBA
+      _      -> withRGBA pointHover Cairo.setSourceRGBA
 
-  Cairo.moveTo (  1e5 * ny ) ( -1e5 * nx )
+    Cairo.moveTo (  1e5 * ny ) ( -1e5 * nx )
-  Cairo.lineTo ( -1e5 * ny ) (  1e5 * nx )
+    Cairo.lineTo ( -1e5 * ny ) (  1e5 * nx )
-  Cairo.stroke
+    Cairo.stroke
 
-  Cairo.restore
+    Cairo.restore
 
 tickSpacing :: Double -> ( Double, [ Int ] )
 tickSpacing d