highlight points for hover/selection

.gitignore

@@ -8,3 +8,4 @@ refs/
 *.txt
 *.md
 *.html
+hie.yaml

app/Main.hs

@@ -56,9 +56,8 @@ import MetaBrush.Asset.Colours
 import MetaBrush.Asset.Logo
   ( drawLogo )
 import MetaBrush.Document
-  ( Document(..)
+  ( Document(..), AABB(..)
-  , AABB(..)
+  , Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
-  , Stroke(..)
   )
 import MetaBrush.Event
   ( handleEvents )
@@ -88,10 +87,28 @@ testDocuments = IntMap.fromList
       { displayName    = "Document 1"
       , filePath       = Nothing
       , unsavedChanges = False
-      , strokes        = [ Stroke [ Point2D 0 0 ]
+      , strokes        = [ Stroke
-                         , Stroke [ Point2D 100 0, Point2D 105 0, Point2D 110 0 ]
+                            [ StrokePoint ( Point2D 0 0 ) PathPoint Normal ]
-                         , Stroke [ Point2D 0 100 ]
+                            "Stroke1"
-                         , Stroke [ Point2D 100 100, Point2D 105 105, Point2D 110 100 ]
+                            False
+                         , Stroke
+                            [ StrokePoint ( Point2D 100 0 )    PathPoint Hover
+                            , StrokePoint ( Point2D 105 0 ) ControlPoint Normal
+                            , StrokePoint ( Point2D 110 0 )    PathPoint Selected
+                            ]
+                            "Stroke2"
+                            True
+                         , Stroke
+                            [ StrokePoint ( Point2D 0 100 ) PathPoint Normal ]
+                            "Stroke3"
+                            True
+                         , Stroke
+                            [ StrokePoint ( Point2D 100 100 )    PathPoint Normal
+                            , StrokePoint ( Point2D 105 105 ) ControlPoint Selected
+                            , StrokePoint ( Point2D 110 100 )    PathPoint Normal
+                            ]
+                            "Stroke4"
+                            True
                          ]
       , bounds         = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
       , viewportCenter = Point2D 50 50
@@ -101,7 +118,14 @@ testDocuments = IntMap.fromList
       { displayName    = "Document 2"
       , filePath       = Nothing
       , unsavedChanges = True
-      , strokes        = [ Stroke [ Point2D 0 0, Point2D 10 10, Point2D 20 20 ] ]
+      , strokes        = [ Stroke
+                            [ StrokePoint ( Point2D 0   0 )    PathPoint Normal
+                            , StrokePoint ( Point2D 10 10 ) ControlPoint Normal
+                            , StrokePoint ( Point2D 20 20 )    PathPoint Normal
+                            ]
+                            "Stroke1"
+                            True
+                         ]
       , bounds         = AABB ( Point2D  0  0 ) ( Point2D 50 50 )
       , viewportCenter = Point2D 10 10
       , zoomFactor     = 0.25

assets/theme.css

@@ -45,6 +45,12 @@
 .brushStroke {
   color: rgb(235,118,219);
 }
+.pointHover {
+  color: rgb(225,225,225);
+}
+.pointSelected {
+  color: rgb(252,237,120);
+}
 .viewport {
   background-color: rgb(236, 223, 210);
   -GtkWidget-window-dragging: false;

src/app/MetaBrush/Asset/Colours.hs

@@ -44,6 +44,8 @@ data ColourRecord a
   , controlPointOutline :: !a
   , path                :: !a
   , brushStroke         :: !a
+  , pointHover          :: !a
+  , pointSelected       :: !a
   , viewport            :: !a
   , viewportScrollbar   :: !a
   , tabScrollbar        :: !a
@@ -81,6 +83,8 @@ colourNames = Colours
   , controlPointOutline = ColourName "controlPointStroke"          Colour [ GTK.StateFlagsNormal ]
   , path                = ColourName "path"                        Colour [ GTK.StateFlagsNormal ]
   , brushStroke         = ColourName "brushStroke"                 Colour [ GTK.StateFlagsNormal ]
+  , pointHover          = ColourName "pointHover"                  Colour [ GTK.StateFlagsNormal ]
+  , pointSelected       = ColourName "pointSelected"               Colour [ GTK.StateFlagsNormal ]
   , viewport            = ColourName "viewport"          BackgroundColour [ GTK.StateFlagsNormal ]
   , viewportScrollbar   = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
   , tabScrollbar        = ColourName "tabScrollbar"      BackgroundColour [ GTK.StateFlagsNormal ]

src/app/MetaBrush/Document.hs

@@ -47,9 +47,30 @@ data Document
 
 data Stroke
   = Stroke
-  { strokePoints :: ![ Point2D Double ] }
+  { strokePoints  :: ![ StrokePoint ]
+  , strokeName    :: !Text
+  , strokeVisible :: !Bool
+  }
   deriving stock Show
 
+data StrokePoint
+  = StrokePoint
+  { strokePoint :: !( Point2D Double )
+  , pointType   :: !PointType
+  , pointState  :: !FocusState
+  }
+  deriving stock Show
+
+data PointType
+  = PathPoint
+  | ControlPoint
+  deriving stock Show
+
+data FocusState
+  = Normal
+  | Hover
+  | Selected
+  deriving stock Show
 
 currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
 currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do

src/app/MetaBrush/Event.hs

@@ -11,6 +11,9 @@ import Control.Monad
   ( unless )
 import Data.Foldable
   ( for_ )
+-- base
+import Data.Semigroup
+  ( Arg(..), Min(..) )
 import Data.Word
   ( Word32 )
 
@@ -48,7 +51,7 @@ import Math.Vector2D
 import MetaBrush.Document
   ( Document(..), currentDocument )
 import MetaBrush.UI.Coordinates
-  ( toViewportCoordinates )
+  ( closestPoint, toViewportCoordinates )
 import MetaBrush.UI.InfoBar
   ( InfoBar, InfoData(..), updateInfoBar )
 
@@ -78,8 +81,10 @@ handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewpor
 handleMotionEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> GTK.DrawingArea -> InfoBar -> GDK.EventMotion -> IO Bool
 handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar eventMotion = do
   
-  mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
+  mbActiveDoc <- STM.readTVarIO activeDocumentTVar
-  for_ mbDoc \ ( Document { .. } ) -> do
+  for_ mbActiveDoc \ i -> do
+    docs <- STM.readTVarIO openDocumentsTVar
+    for_ ( IntMap.lookup i docs ) \ doc@( Document { .. } ) -> do
   
       ----------------------------------------------------------
       -- Update mouse position in info bar on mouse move event.
@@ -91,17 +96,19 @@ handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoB
       let
         toViewport :: Point2D Double -> Point2D Double
         toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
+        pos :: Point2D Double
+        pos = toViewport ( Point2D x y )
         infoData :: InfoData
         infoData =
           InfoData
             { zoom        = zoomFactor
-          , mousePos    = toViewport ( Point2D x y )
+            , mousePos    = pos
             , topLeftPos  = toViewport ( Point2D 0 0 )
             , botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
             }
       updateInfoBar infoBar infoData
   
-  pure False
+  pure True
 
 handleScrollEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.DrawingArea -> InfoBar -> GDK.EventScroll -> IO Bool
 handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar scrollEvent = do

src/app/MetaBrush/Render/Document.hs

@@ -1,5 +1,8 @@
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE NamedFieldPuns     #-}
 {-# LANGUAGE NegativeLiterals   #-}
+{-# LANGUAGE PatternSynonyms    #-}
 {-# LANGUAGE RecordWildCards    #-}
 
 module MetaBrush.Render.Document
@@ -7,8 +10,10 @@ module MetaBrush.Render.Document
   where
 
 -- base
-import Control.Monad
+import Data.Foldable
-  ( when )
+  ( traverse_ )
+import Data.Functor.Compose
+  ( Compose(..) )
 import Data.Int
   ( Int32 )
 
@@ -16,6 +21,8 @@ import Data.Int
 import qualified GI.Cairo.Render as Cairo
 
 -- MetaBrush
+import qualified Math.Bezier.Cubic     as Cubic
+  ( Bezier(..) )
 import qualified Math.Bezier.Quadratic as Quadratic
   ( Bezier(..) )
 import Math.Vector2D
@@ -23,12 +30,31 @@ import Math.Vector2D
 import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
 import MetaBrush.Document
-  ( Document(..), Stroke(..) )
+  ( Document(..)
+  , Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
+  )
 import MetaBrush.Render.Util
   ( withRGBA )
 
 --------------------------------------------------------------------------------
 
+data Renders a
+  = MkRenders
+  { mkRenderPoints :: a
+  , mkRenderPaths  :: a
+  }
+  deriving stock ( Show, Functor )
+
+instance Applicative Renders where
+  pure a = MkRenders a a
+  MkRenders f1 f2 <*> MkRenders a1 a2 = MkRenders ( f1 a1 ) ( f2 a2 )
+
+{-# COMPLETE Renders #-}
+pattern Renders :: Cairo.Render a -> Cairo.Render a -> Compose Renders Cairo.Render a
+pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints renderPaths )
+
+--------------------------------------------------------------------------------
+
 renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render ()
 renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do
 
@@ -38,49 +64,63 @@ renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCente
   Cairo.translate ( -cx ) ( -cy )
 
   let
-    ( renderPoints, renderPath ) = renderStrokes cols zoomFactor strokes
+    Renders { renderPoints, renderPaths } = traverse_ ( renderStroke cols zoomFactor ) strokes
-  renderPath
+  renderPaths
   renderPoints
 
   Cairo.restore
 
   pure ()
 
-renderStrokes :: Colours -> Double -> [ Stroke ] -> ( Cairo.Render (), Cairo.Render () )
+renderStroke :: Colours -> Double -> Stroke -> Compose Renders Cairo.Render ()
-renderStrokes _    _    []         = ( pure (), pure () )
+renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } )
-renderStrokes cols zoom ( s : ss ) = ( points1 *> points2, path1 *> path2 )
+  = go pt0 pts *> Renders { renderPoints = drawPoint cols zoom pt0, renderPaths = pure () }
   where
-    ( points1, path1 ) = renderStroke  cols zoom s
+    go :: StrokePoint -> [ StrokePoint ] -> Compose Renders Cairo.Render ()
-    ( points2, path2 ) = renderStrokes cols zoom ss
+    go _  [] = pure ()
-
+    -- Line.
-renderStroke :: Colours -> Double -> Stroke -> ( Cairo.Render (), Cairo.Render () )
+    go p0 ( p1 : ps )
-renderStroke cols zoom ( Stroke strokePts ) = go True strokePts
+      | PathPoint <- pointType p1
-  where
+      = Renders
-    go :: Bool -> [ Point2D Double ] -> ( Cairo.Render (), Cairo.Render () )
+          { renderPoints = drawPoint cols zoom p1
-    go drawFirstPoint pts = case pts of
+          , renderPaths  = drawLine  cols zoom p0 p1
-      []  -> ( pure (), pure () )
+          }
-      [p0] -> ( when drawFirstPoint ( drawPoint cols zoom p0 ), pure () )
+        *> go p1 ps
-      [_,_] -> error "'renderStroke': unexpected pair of points"
+    -- Quadratic Bézier curve.
-      ( p0 : p1 : p2 : ps ) ->
+    go p0 ( p1 : p2 : ps )
-        let
+      | ControlPoint <- pointType p1
-          drawPoints, drawNextPoints, drawPath, drawNextPath :: Cairo.Render ()
+      , PathPoint    <- pointType p2
-          ( drawNextPoints, drawNextPath ) = go False ( p2 : ps )
+      = Renders
-          drawPoints = do
+          { renderPoints
-            drawControl cols zoom p1
+            =  drawLine  cols zoom p0 p1
-            drawLine    cols zoom p0 p1
+            *> drawLine  cols zoom p1 p2
-            drawLine    cols zoom p1 p2
+            *> drawPoint cols zoom p1
-            when drawFirstPoint ( drawPoint cols zoom p0 )
+            *> drawPoint cols zoom p2
-            drawPoint   cols zoom p2
+          , renderPaths = drawQuadraticBezier cols zoom ( fmap strokePoint $ Quadratic.Bezier { p0, p1, p2 } )
-            drawNextPoints
+          }
-          drawPath = do
+      *> go p2 ps
-            drawQuadraticBezier cols zoom ( Quadratic.Bezier p0 p1 p2 )
+    -- Cubic Bézier curve.
-            drawNextPath
+    go p0 ( p1 : p2 : p3 : ps )
-        in ( drawPoints, drawPath )
+      | ControlPoint <- pointType p1
-          
+      , ControlPoint <- pointType p1
-
+      , PathPoint    <- pointType p3
-drawPoint, drawControl :: Colours -> Double -> Point2D Double -> Cairo.Render ()
+      = Renders
-drawPoint ( Colours { pathPoint, pathPointOutline } ) zoom ( Point2D x y ) = do
+          { renderPoints
+            =  drawLine  cols zoom p0 p1
+            *> drawLine  cols zoom p2 p3
+            *> drawPoint cols zoom p1
+            *> drawPoint cols zoom p2
+            *> drawPoint cols zoom p3
+          , renderPaths = drawCubicBezier cols zoom ( fmap strokePoint $ Cubic.Bezier { p0, p1, p2, p3 } )
+          }
+      *> go p2 ps
+    go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 : ps )
+renderStroke _ _ _ = pure ()
 
+drawPoint :: Colours -> Double -> StrokePoint -> Cairo.Render ()
+drawPoint ( Colours { .. } ) zoom
+  ( StrokePoint { strokePoint = Point2D x y, pointType = PathPoint, pointState } )
+  = do
   let
     hsqrt3 :: Double
     hsqrt3 = sqrt 0.75
@@ -97,16 +137,23 @@ drawPoint ( Colours { pathPoint, pathPointOutline } ) zoom ( Point2D x y ) = do
   Cairo.lineTo  0.5 (-hsqrt3)
   Cairo.closePath
 
-  Cairo.setLineWidth 0.8
+  Cairo.setLineWidth 1.0
-  withRGBA pathPointOutline Cairo.setSourceRGBA
+  case pointState of
+    Normal   -> withRGBA pathPointOutline Cairo.setSourceRGBA
+    _        -> withRGBA pathPoint        Cairo.setSourceRGBA
   Cairo.strokePreserve
 
-  withRGBA pathPoint Cairo.setSourceRGBA
+  case pointState of
+    Normal   -> withRGBA pathPoint     Cairo.setSourceRGBA
+    Hover    -> withRGBA pointHover    Cairo.setSourceRGBA
+    Selected -> withRGBA pointSelected Cairo.setSourceRGBA
   Cairo.fill
 
   Cairo.restore
 
-drawControl ( Colours { controlPoint, controlPointOutline } ) zoom ( Point2D x y ) = do
+drawPoint ( Colours { .. } ) zoom
+  ( StrokePoint { strokePoint = Point2D x y, pointType = ControlPoint, pointState } )
+  = do
 
   Cairo.save
   Cairo.translate x y
@@ -114,22 +161,38 @@ drawControl ( Colours { controlPoint, controlPointOutline } ) zoom ( Point2D x y
 
   Cairo.arc 0 0 1 0 ( 2 * pi )
 
-  Cairo.setLineWidth 0.8
+  Cairo.setLineWidth 1.0
-  withRGBA controlPointOutline Cairo.setSourceRGBA
+  case pointState of
+    Normal   -> withRGBA controlPointOutline Cairo.setSourceRGBA
+    _        -> withRGBA controlPoint        Cairo.setSourceRGBA
   Cairo.strokePreserve
 
+  case pointState of
+    Normal   -> withRGBA controlPoint  Cairo.setSourceRGBA
+    Hover    -> withRGBA pointHover    Cairo.setSourceRGBA
+    Selected -> withRGBA pointSelected Cairo.setSourceRGBA
+  Cairo.fill
+
   withRGBA controlPoint Cairo.setSourceRGBA
   Cairo.fill
 
   Cairo.restore
 
-drawLine :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
+drawLine :: Colours -> Double -> StrokePoint -> StrokePoint -> Cairo.Render ()
-drawLine ( Colours { controlPoint } ) zoom ( Point2D x1 y1 ) ( Point2D x2 y2 ) = do
+drawLine ( Colours { path, controlPoint } ) zoom
+  ( StrokePoint { strokePoint = Point2D x1 y1, pointType = ty1 } )
+  ( StrokePoint { strokePoint = Point2D x2 y2, pointType = ty2 } )
+  = do
 
   Cairo.save
   Cairo.moveTo x1 y1
   Cairo.lineTo x2 y2
 
+  case ( ty1, ty2 ) of
+    ( PathPoint, PathPoint ) -> do
+      Cairo.setLineWidth ( 6 / zoom )
+      withRGBA path Cairo.setSourceRGBA
+    _ -> do
       Cairo.setLineWidth ( 3 / zoom )
       withRGBA controlPoint Cairo.setSourceRGBA
   Cairo.stroke
@@ -159,3 +222,25 @@ drawQuadraticBezier ( Colours { path } ) zoom
   Cairo.stroke
 
   Cairo.restore
+
+drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render ()
+drawCubicBezier ( Colours { path } ) zoom
+  ( Cubic.Bezier
+    { p0 = Point2D x0 y0
+    , p1 = Point2D x1 y1
+    , p2 = Point2D x2 y2
+    , p3 = Point2D x3 y3
+    }
+  )
+  = do
+
+  Cairo.save
+
+  Cairo.moveTo x0 y0
+  Cairo.curveTo x1 y1 x2 y2 x3 y3
+
+  Cairo.setLineWidth ( 6 / zoom )
+  withRGBA path Cairo.setSourceRGBA
+  Cairo.stroke
+
+  Cairo.restore

src/app/MetaBrush/UI/Coordinates.hs

@@ -1,7 +1,14 @@
+{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE TypeApplications #-}
+
 module MetaBrush.UI.Coordinates
-  ( toViewportCoordinates )
+  ( toViewportCoordinates, closestPoint )
   where
 
+-- base
+import Data.Semigroup
+  ( ArgMin, Arg(..), Min(..) )
+
 -- acts
 import Data.Act
   ( Act
@@ -11,14 +18,33 @@ import Data.Act
   )
 
 -- MetaBrush
+import qualified Math.Bezier.Quadratic as Quadratic
+  ( Bezier(..), closestPoint )
 import Math.Module
-  ( (*^) )
+  ( (*^), squaredNorm )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
+import MetaBrush.Document
+  ( Stroke(..) )
 
 --------------------------------------------------------------------------------
 
+-- | Convert a position relative to the drawing area into viewport coordinates.
 toViewportCoordinates :: Double -> ( Double, Double ) -> Point2D Double -> Point2D Double -> Point2D Double
 toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( Point2D x y )
   = ( recip zoomFactor *^ ( Point2D ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> Point2D x y :: Vector2D Double ) )
   • viewportCenter
+
+-- | Find the closest point in a set of strokes.
+closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Point2D Double )
+closestPoint = undefined
+{-
+closestPoint c ( Stroke pts ) = go pts
+  where
+    go :: [ Point2D Double ] -> ArgMin Double ( Point2D Double )
+    go []  = error "'closestPoint': empty stroke"
+    go [p] = Min ( Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) p )
+    go (p0:p1:p2:ps)
+      =  fmap ( fmap snd ) ( Quadratic.closestPoint @(Vector2D Double) ( Quadratic.Bezier { .. } ) c )
+      <> go (p2:ps)
+-}

src/app/MetaBrush/UI/Panels.hs

@@ -11,19 +11,10 @@ import Control.Monad
 import Data.Foldable
   ( for_ )
 
--- gi-cairo-connector
-import qualified GI.Cairo.Render.Connector as Cairo
-  ( renderWithContext )
-
--- gi-cairo-render
-import qualified GI.Cairo.Render as Cairo
-
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
 -- MetaBrush
-import MetaBrush.Asset.Colours
-  ( Colours )
 import MetaBrush.Render.Util
   ( widgetAddClass, widgetAddClasses )
 

src/lib/Math/Bezier/Quadratic.hs

@@ -20,6 +20,8 @@ module Math.Bezier.Quadratic
 -- base
 import Data.List.NonEmpty
   ( NonEmpty(..) )
+import Data.Semigroup
+  ( ArgMin, Min(..), Arg(..) )
 import GHC.Generics
   ( Generic )
 
@@ -69,7 +71,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
     pt = lerp @v t q1 r1
 
 -- | 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 -> ( r, p )
+closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ArgMin r ( r, p )
 closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
   where
     roots :: [ r ]
@@ -83,17 +85,17 @@ closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
     a0, a1, a2, a3 :: r
     a0 = v ^.^ v'
     a1 = v ^.^ v'' + 2 * squaredNorm v'
-    a2 = 3 * ( v' ^.^ v'' )
+    a2 = 3 * v' ^.^ v''
     a3 = squaredNorm v''
 
-    pickClosest :: NonEmpty r -> ( r, p )
+    pickClosest :: NonEmpty r -> ArgMin r ( r, p )
     pickClosest ( s :| ss ) = go s q nm0 ss
       where
         q :: p
         q  = bezier @v pts s
         nm0 :: r
         nm0 = squaredNorm ( c --> q :: v )
-        go t p _  []  = ( t, p )
+        go t p nm  [] = Min ( Arg nm ( t, p ) )
         go t p nm ( t' : ts )
           | nm' < nm  = go t' p' nm' ts
           | otherwise = go t  p  nm  ts