add root solving code, coalesce event handling

.gitignore

@@ -3,6 +3,7 @@ cabal.project.local
 
 assets/*.svg
 assets/*/
+refs/
 
 *.txt
 *.md

MetaBrush.cabal

@@ -60,6 +60,7 @@ library
       , Math.Bezier.Stroke
       , Math.Bezier.Subdivision
       , Math.Module
+      , Math.RealRoots
       , Math.Vector2D
 
     build-depends:

app/Main.hs

@@ -61,11 +61,9 @@ import MetaBrush.Document
   , Stroke(..)
   )
 import MetaBrush.Event
-  ( handleKeyboardPressEvent, handleKeyboardReleaseEvent )
+  ( handleEvents )
 import MetaBrush.Render.Util
   ( widgetAddClass, widgetAddClasses )
-import MetaBrush.UI.Coordinates
-  ( keepViewportCoordinatesUpdated )
 import MetaBrush.UI.FileBar
   ( createFileBar )
 import MetaBrush.UI.InfoBar
@@ -140,6 +138,8 @@ main = do
   GTK.setWindowDecorated window False
   GTK.setWindowTitle window "MetaBrush"
   GTK.windowSetDefaultSize window 800 600
+  GTK.widgetAddEvents window
+    [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
 
   let
     baseMinWidth, baseMinHeight :: Int32
@@ -244,13 +244,6 @@ main = do
 
   infoBarElements <- createInfoBar colours infoBar
 
-  keepViewportCoordinatesUpdated
-    activeDocumentTVar
-    openDocumentsTVar
-    pressedKeysTVar
-    infoBarElements
-    viewportDrawingArea
-
   ---------------------------------------------------------
   -- File bar
 
@@ -261,6 +254,7 @@ main = do
       window
       title
       viewportDrawingArea
+      infoBarElements
       fileBar
 
   ---------------------------------------------------------
@@ -271,12 +265,9 @@ main = do
   ---------------------------------------------------------
   -- Actions
 
-  GTK.widgetAddEvents window
+  handleEvents
-    [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
+    activeDocumentTVar openDocumentsTVar pressedKeysTVar
-
+    window viewportDrawingArea infoBarElements
-  _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   pressedKeysTVar )
-  _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
-  _ <- GTK.onWidgetDestroy         window GTK.mainQuit
 
   ---------------------------------------------------------
   -- GTK main loop

src/app/MetaBrush/Event.hs

@@ -1,12 +1,33 @@
-{-# LANGUAGE BlockArguments  #-}
+{-# LANGUAGE BlockArguments   #-}
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE NamedFieldPuns   #-}
+{-# LANGUAGE PatternSynonyms  #-}
+{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE TypeApplications #-}
 
 module MetaBrush.Event where
 
 -- base
+import Control.Monad
+  ( unless )
+import Data.Foldable
+  ( for_ )
 import Data.Word
   ( Word32 )
 
+-- acts
+import Data.Act
+  ( Act
+    ( (•) )
+  , Torsor
+    ( (-->) )
+  )
+
+-- containers
+import Data.IntMap.Strict
+  ( IntMap )
+import qualified Data.IntMap.Strict as IntMap
+  ( insert, lookup )
+
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
@@ -17,10 +38,147 @@ import qualified GI.Gtk as GTK
 import qualified Control.Concurrent.STM      as STM
   ( atomically )
 import qualified Control.Concurrent.STM.TVar as STM
-  ( TVar, readTVar, writeTVar )
+  ( TVar, readTVar, readTVarIO, writeTVar )
+
+-- MetaBrush
+import Math.Module
+  ( (*^) )
+import Math.Vector2D
+  ( Point2D(..), Vector2D(..) )
+import MetaBrush.Document
+  ( Document(..), currentDocument )
+import MetaBrush.UI.Coordinates
+  ( toViewportCoordinates )
+import MetaBrush.UI.InfoBar
+  ( InfoBar, InfoData(..), updateInfoBar )
 
 --------------------------------------------------------------------------------
 
+handleEvents :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.Window -> GTK.DrawingArea -> InfoBar -> IO ()
+handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewportDrawingArea infoBar = do
+
+  -- Mouse events
+  _ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
+        ( handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar )
+  _ <- GTK.onWidgetScrollEvent       viewportDrawingArea
+        ( handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar )
+
+  -- Keyboard events
+  _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   pressedKeysTVar )
+  _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
+
+  -- Window quit
+  _ <- GTK.onWidgetDestroy         window GTK.mainQuit
+
+  pure ()
+
+--------------------------------------------------------------------------------
+-- Mouse events.
+
+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
+  for_ mbDoc \ ( Document { .. } ) -> do
+
+    ----------------------------------------------------------
+    -- Update mouse position in info bar on mouse move event.
+
+    x <- GDK.getEventMotionX eventMotion
+    y <- GDK.getEventMotionY eventMotion
+    viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
+    viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+    let
+      toViewport :: Point2D Double -> Point2D Double
+      toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
+      infoData :: InfoData
+      infoData =
+        InfoData
+          { zoom        = zoomFactor
+          , mousePos    = toViewport ( Point2D x y )
+          , topLeftPos  = toViewport ( Point2D 0 0 )
+          , botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
+          }
+    updateInfoBar infoBar infoData
+
+  pure False
+
+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
+
+  dx <- GDK.getEventScrollDeltaX scrollEvent
+  dy <- GDK.getEventScrollDeltaY scrollEvent
+  x  <- GDK.getEventScrollX scrollEvent
+  y  <- GDK.getEventScrollY scrollEvent
+  viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
+  viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+
+  unless ( dx == 0 && dy == 0 ) do
+    mbActiveDoc <- STM.readTVarIO activeDocumentTVar
+    for_ mbActiveDoc \ i -> do
+      docs <- STM.readTVarIO openDocumentsTVar
+      for_ ( IntMap.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
+        pressedKeys <- STM.readTVarIO pressedKeysTVar
+        let
+          toViewport :: Point2D Double -> Point2D Double
+          toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
+          -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
+          mousePos :: Point2D Double
+          mousePos = toViewport ( Point2D x y )
+          newDoc :: Document
+          newDoc
+            -- Zooming using 'Control'.
+            | any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
+            = let
+                newZoomFactor :: Double
+                newZoomFactor
+                  | dy > 0
+                  = max 0.0078125 ( oldZoomFactor / sqrt 2 )
+                  | otherwise
+                  = min 256 ( oldZoomFactor * sqrt 2 )
+                newCenter :: Point2D Double
+                newCenter
+                  = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
+                  • oldCenter
+              in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
+            -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
+            | dx == 0 && any ( \ key -> key == Shift_L || key == Shift_R ) pressedKeys
+            = let
+                newCenter :: Point2D Double
+                newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • oldCenter
+              in doc { viewportCenter = newCenter }
+            -- Vertical scrolling.
+            | otherwise
+            = let
+                newCenter :: Point2D Double
+                newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • oldCenter
+              in doc { viewportCenter = newCenter }
+          docs' :: IntMap Document
+          docs' = IntMap.insert i newDoc docs
+        STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
+        GTK.widgetQueueDraw viewportDrawingArea
+
+        let
+          newZoomFactor :: Double
+          newZoomFactor = zoomFactor     newDoc
+          newCenter :: Point2D Double
+          newCenter     = viewportCenter newDoc
+          toNewViewport :: Point2D Double -> Point2D Double
+          toNewViewport = toViewportCoordinates newZoomFactor ( viewportWidth, viewportHeight ) newCenter
+          infoData :: InfoData
+          infoData = InfoData
+            { zoom = zoomFactor newDoc
+            , mousePos
+            , topLeftPos  = toNewViewport ( Point2D 0 0 )
+            , botRightPos = toNewViewport ( Point2D viewportWidth viewportHeight )
+            }
+        updateInfoBar infoBar infoData
+
+  pure False
+
+--------------------------------------------------------------------------------
+-- Keyboard events.
+
 handleKeyboardPressEvent, handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool
 handleKeyboardPressEvent pressedKeysTVar evt = do
   keyCode <- GDK.getEventKeyKeyval evt
@@ -37,6 +195,9 @@ handleKeyboardReleaseEvent pressedKeysTVar evt = do
     STM.writeTVar pressedKeysTVar ( filter ( /= keyCode ) pressedKeys )
   pure True
 
+--------------------
+-- GDK keycodes.
+
 pattern Escape    :: Word32
 pattern Escape    = 0xff1b
 pattern Delete    :: Word32

src/app/MetaBrush/UI/Coordinates.hs

@@ -1,21 +1,7 @@
-{-# LANGUAGE BlockArguments   #-}
-{-# LANGUAGE NamedFieldPuns   #-}
-{-# LANGUAGE PatternSynonyms  #-}
-{-# LANGUAGE RecordWildCards  #-}
-{-# LANGUAGE TypeApplications #-}
-
 module MetaBrush.UI.Coordinates
-  ( keepViewportCoordinatesUpdated )
+  ( toViewportCoordinates )
   where
 
--- base
-import Control.Monad
-  ( unless, void )
-import Data.Foldable
-  ( for_ )
-import Data.Word
-  ( Word32 )
-
 -- acts
 import Data.Act
   ( Act
@@ -24,169 +10,14 @@ import Data.Act
     ( (-->) )
   )
 
--- containers
-import Data.IntMap.Strict
-  ( IntMap )
-import qualified Data.IntMap.Strict as IntMap
-  ( insert, lookup )
-
--- gi-gdk
-import qualified GI.Gdk as GDK
-
--- gi-gtk
-import qualified GI.Gtk as GTK
-
--- stm
-import qualified Control.Concurrent.STM      as STM
-  ( atomically )
-import qualified Control.Concurrent.STM.TVar as STM
-  ( TVar, readTVarIO, writeTVar )
-
 -- MetaBrush
 import Math.Module
   ( (*^) )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
-import MetaBrush.Document
-  ( Document(..), currentDocument )
-import MetaBrush.Event
-  ( pattern Control_L, pattern Control_R
-  , pattern Shift_L, pattern Shift_R
-  )
-import MetaBrush.UI.InfoBar
-  ( InfoBar, InfoData(..), updateInfoBar )
 
 --------------------------------------------------------------------------------
 
--- | Updates viewport coordinates on mouse motion / mouse scroll.
---
---   * On a scroll event, modifies the viewport coordinates as required.
---   * On a scroll event or a mouse motion event, updates the info bar coordinate display.
---
--- TODO: also update on change of document.
-keepViewportCoordinatesUpdated
-  :: STM.TVar ( Maybe Int )
-  -> STM.TVar ( IntMap Document )
-  -> STM.TVar [ Word32 ]
-  -> InfoBar
-  -> GTK.DrawingArea
-  -> IO ()
-keepViewportCoordinatesUpdated
-  activeDocumentTVar
-  openDocumentsTVar
-  pressedKeysTVar
-  infoBar
-  viewportDrawingArea = do
-
-    -----------------------------------------------------------------
-    -- Update mouse position on mouse move event.
-
-    void $ GTK.onWidgetMotionNotifyEvent viewportDrawingArea \ eventMotion -> do
-      mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
-      infoData <- case mbDoc of
-        Nothing ->
-          pure $ 
-            InfoData
-              { zoom        = 1
-              , mousePos    = Point2D 0 0
-              , topLeftPos  = Point2D 0 0
-              , botRightPos = Point2D 0 0
-              }
-        Just ( Document { .. } ) -> do
-          x <- GDK.getEventMotionX eventMotion
-          y <- GDK.getEventMotionY eventMotion
-          viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-          viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
-          let
-            toViewport :: Point2D Double -> Point2D Double
-            toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
-          pure $ 
-            InfoData
-              { zoom        = zoomFactor
-              , mousePos    = toViewport ( Point2D x y )
-              , topLeftPos  = toViewport ( Point2D 0 0 )
-              , botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
-              }
-
-      updateInfoBar infoBar infoData
-      pure False
-
-    -----------------------------------------------------------------
-    -- Update coordinates on scroll event.
-
-    void $ GTK.onWidgetScrollEvent viewportDrawingArea \ scrollEvent -> do
-
-      dx <- GDK.getEventScrollDeltaX scrollEvent
-      dy <- GDK.getEventScrollDeltaY scrollEvent
-      x <- GDK.getEventScrollX scrollEvent
-      y <- GDK.getEventScrollY scrollEvent
-      viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-      viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
-
-      unless ( dx == 0 && dy == 0 ) do
-        mbActiveDoc <- STM.readTVarIO activeDocumentTVar
-        for_ mbActiveDoc \ i -> do
-          docs <- STM.readTVarIO openDocumentsTVar
-          for_ ( IntMap.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
-            pressedKeys <- STM.readTVarIO pressedKeysTVar
-            let
-              toViewport :: Point2D Double -> Point2D Double
-              toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
-              -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
-              mousePos :: Point2D Double
-              mousePos = toViewport ( Point2D x y )
-              newDoc :: Document
-              newDoc
-                -- Zooming using 'Control'.
-                | any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
-                = let
-                    newZoomFactor :: Double
-                    newZoomFactor
-                      | dy > 0
-                      = max 0.0078125 ( oldZoomFactor / sqrt 2 )
-                      | otherwise
-                      = min 256 ( oldZoomFactor * sqrt 2 )
-                    newCenter :: Point2D Double
-                    newCenter
-                      = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
-                      • oldCenter
-                  in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
-                -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
-                | dx == 0 && any ( \ key -> key == Shift_L || key == Shift_R ) pressedKeys
-                = let
-                    newCenter :: Point2D Double
-                    newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • oldCenter
-                  in doc { viewportCenter = newCenter }
-                -- Vertical scrolling.
-                | otherwise
-                = let
-                    newCenter :: Point2D Double
-                    newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • oldCenter
-                  in doc { viewportCenter = newCenter }
-              docs' :: IntMap Document
-              docs' = IntMap.insert i newDoc docs
-            STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
-            GTK.widgetQueueDraw viewportDrawingArea
-
-            let
-              newZoomFactor :: Double
-              newZoomFactor = zoomFactor     newDoc
-              newCenter :: Point2D Double
-              newCenter     = viewportCenter newDoc
-              toNewViewport :: Point2D Double -> Point2D Double
-              toNewViewport = toViewportCoordinates newZoomFactor ( viewportWidth, viewportHeight ) newCenter
-              infoData :: InfoData
-              infoData = InfoData
-                { zoom = zoomFactor newDoc
-                , mousePos
-                , topLeftPos  = toNewViewport ( Point2D 0 0 )
-                , botRightPos = toNewViewport ( Point2D viewportWidth viewportHeight )
-                }
-            updateInfoBar infoBar infoData
-
-      pure True
-
-
 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 ) )

src/app/MetaBrush/UI/FileBar.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeApplications  #-}
 
 module MetaBrush.UI.FileBar
@@ -35,23 +36,32 @@ import Data.Text
   ( Text )
 
 -- MetaBrush
+import Math.Vector2D
+  ( Point2D(..) )
 import MetaBrush.Document
   ( Document(..) )
 import MetaBrush.Render.Util
   ( widgetAddClass, widgetAddClasses )
+import MetaBrush.UI.Coordinates
+  ( toViewportCoordinates )
+import MetaBrush.UI.InfoBar
+  ( InfoBar, InfoData(..), updateInfoBar )
 
 --------------------------------------------------------------------------------
 
 -- | Add the file bar: tabs allowing selection of the active document.
+--
+-- Updates the active document when buttons are clicked.
 createFileBar
   :: STM.TVar ( Maybe Int )
   -> STM.TVar ( IntMap Document )
   -> GTK.Window
   -> GTK.Label
   -> GTK.DrawingArea
+  -> InfoBar
   -> GTK.ScrolledWindow
   -> IO ( IntMap GTK.RadioButton )
-createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fileBar = do
+createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea infoBar fileBar = do
   
   widgetAddClass fileBar "fileBar"
 
@@ -64,9 +74,9 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fil
   -- TODO: currently using static list of documents.
   -- Need to dynamically update this widget as the user opens/closes documents.
   documents <- STM.readTVarIO openDocumentsTVar
-  fileButtons <- ( `IntMap.traverseWithKey` documents ) \ i ( Document { displayName, unsavedChanges } ) -> do
+  fileButtons <- ( `IntMap.traverseWithKey` documents ) \ i ( Document { displayName = currDisplayName } ) -> do
     -- File tab elements.
-    pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) displayName
+    pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) currDisplayName
     GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
     closeFileButton <- GTK.buttonNewWithLabel "x"
 
@@ -95,7 +105,7 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fil
           Nothing -> do
             GTK.labelSetText   title  "MetaBrush"
             GTK.setWindowTitle window "MetaBrush"
-          Just ( Document { displayName, unsavedChanges } ) -> do
+          Just ( Document { .. } ) -> do
             let
               titleText :: Text
               titleText
@@ -105,6 +115,20 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fil
                 = displayName <> " – MetaBrush"
             GTK.labelSetText   title  titleText
             GTK.setWindowTitle window titleText
+            viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportArea
+            viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportArea
+            let
+              toViewport :: Point2D Double -> Point2D Double
+              toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
+              infoData :: InfoData
+              infoData =
+                InfoData
+                  { zoom        = zoomFactor
+                  , mousePos    = Point2D 0 0
+                  , topLeftPos  = toViewport ( Point2D 0 0 )
+                  , botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
+                  }
+            updateInfoBar infoBar infoData
       else do
         GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
         GTK.labelSetText   title  "MetaBrush"

src/lib/Math/Bezier/Cubic.hs

@@ -13,10 +13,13 @@ module Math.Bezier.Cubic
   ( Bezier(..)
   , bezier, bezier'
   , subdivide
+  , closestPoint
   )
   where
 
 -- base
+import Data.List.NonEmpty
+  ( NonEmpty(..) )
 import GHC.Generics
   ( Generic )
 
@@ -27,12 +30,15 @@ import Data.Act
   )
 
 -- MetaBrush
+import qualified Math.Bezier.Quadratic as Quadratic
+  ( Bezier(Bezier), bezier )
 import Math.Module
   ( Module (..)
   , lerp
+  , Inner(..), squaredNorm
   )
-import qualified Math.Bezier.Quadratic as Quadratic
+import Math.RealRoots
-  ( Bezier(Bezier), bezier )
+  ( realRoots )
 
 --------------------------------------------------------------------------------
 
@@ -74,3 +80,41 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
     q2 = lerp @v t q1 s
     r1 = lerp @v t s  r2
     pt = lerp @v t q2 r1
+
+-- | Finds the closest point to a given point on a cubic Bézier curve.
+closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ( r, p )
+closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
+  where
+    roots :: [ r ]
+    roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots [ a0, a1, a2, a3, a4, a5 ] )
+
+    v, v', v'', v''' :: v
+    v    = c  --> p0
+    v'   = p0 --> p1
+    v''  = p1 --> p0 ^+^ p1 --> p2
+    v''' = p0 --> p3 ^+^ 3 *^ ( p2 --> p1 )
+
+    a0, a1, a2, a3, a4, a5 :: r
+    a0 = v ^.^ v'
+    a1 = 3 * squaredNorm v' + 2 * v ^.^ v''
+    a2 = 9 * v' ^.^ v'' + 3 * v ^.^ v'''
+    a3 = 6 * squaredNorm v'' + 4 * v' ^.^ v'''
+    a4 = 5 * v'' ^.^ v'''
+    a5 = squaredNorm v'''
+
+    pickClosest :: NonEmpty 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 ( t' : ts )
+          | nm' < nm  = go t' p' nm' ts
+          | otherwise = go t  p  nm  ts
+          where
+            p' :: p
+            p' = bezier @v pts t'
+            nm' :: r
+            nm' = squaredNorm ( c --> p' :: v )

src/lib/Math/Bezier/Quadratic.hs

@@ -13,10 +13,13 @@ module Math.Bezier.Quadratic
   ( Bezier(..)
   , bezier, bezier'
   , subdivide
+  , closestPoint
   )
   where
 
 -- base
+import Data.List.NonEmpty
+  ( NonEmpty(..) )
 import GHC.Generics
   ( Generic )
 
@@ -30,7 +33,10 @@ import Data.Act
 import Math.Module
   ( Module (..)
   , lerp
+  , Inner(..), squaredNorm
   )
+import Math.RealRoots
+  ( realRoots )
 
 --------------------------------------------------------------------------------
 
@@ -61,3 +67,38 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
     q1 = lerp @v t p0 p1
     r1 = lerp @v t p1 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 pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
+  where
+    roots :: [ r ]
+    roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots [ a0, a1, a2, a3 ] )
+
+    v, v', v'' :: v
+    v   = c  --> p0
+    v'  = p0 --> p1
+    v'' = p1 --> p0 ^+^ p1 --> p2
+
+    a0, a1, a2, a3 :: r
+    a0 = v ^.^ v'
+    a1 = v ^.^ v'' + 2 * squaredNorm v'
+    a2 = 3 * ( v' ^.^ v'' )
+    a3 = squaredNorm v''
+
+    pickClosest :: NonEmpty 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 ( t' : ts )
+          | nm' < nm  = go t' p' nm' ts
+          | otherwise = go t  p  nm  ts
+          where
+            p' :: p
+            p' = bezier @v pts t'
+            nm' :: r
+            nm' = squaredNorm ( c --> p' :: v )

src/lib/Math/Module.hs

@@ -4,8 +4,8 @@
 {-# LANGUAGE ScopedTypeVariables    #-}
 
 module Math.Module
-  ( Module(..)
+  ( Module(..), lerp
-  , lerp
+  , Inner(..), squaredNorm
   )
   where
 
@@ -20,7 +20,7 @@ import Data.Act
 --------------------------------------------------------------------------------
 
 infixl 6 ^+^, ^-^
-infix  8 ^*, *^
+infix  9 ^*, *^
 
 class Num r => Module r m | m -> r where
 
@@ -37,3 +37,12 @@ class Num r => Module r m | m -> r where
 
 lerp :: forall v r p. ( Module r v, Torsor v p ) => r -> p -> p -> p
 lerp t p0 p1 = ( t *^ ( p0 --> p1 :: v ) ) • p0
+
+infixl 8 ^.^
+
+class Module r m => Inner r m where
+  (^.^) :: m -> m -> r
+
+-- | Squared norm of a vector, computed using the inner product.
+squaredNorm :: Inner r m => m -> r
+squaredNorm v = v ^.^ v

src/lib/Math/RealRoots.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Math.RealRoots
+  ( realRoots )
+  where
+
+-- base
+import Data.Complex
+  ( Complex(..), magnitude )
+import Data.List.NonEmpty
+  ( NonEmpty(..), toList )
+import Data.Maybe
+  ( mapMaybe )
+
+--------------------------------------------------------------------------------
+
+-- | Find real roots of a polynomial.
+realRoots :: forall r. RealFloat r => [ r ] -> [ r ]
+realRoots p = mapMaybe isReal ( roots eps 10000 ( map (:+ 0) p ) )
+  where
+    isReal :: Complex r -> Maybe r
+    isReal ( a :+ b )
+      | abs b < eps = Just a
+      | otherwise   = Nothing
+    eps :: r
+    eps = encodeFloat 1 ( 5 - floatDigits ( 0 :: r ) )
+
+-- | Compute all roots of a polynomial using Laguerre's method and (forward) deflation.
+--
+-- Polynomial coefficients are given in order of ascending degree (e.g. constant coefficient first).
+--
+-- N.B. The forward deflation process is only guaranteed to be numerically stable
+-- if Laguerre's method finds roots in increasing order of magnitude.
+roots :: forall a. RealFloat a => a -> Int -> [ Complex a ] -> [ Complex a ]
+roots eps maxIters p = go p []
+  where
+    go :: [ Complex a ] -> [ Complex a ] -> [ Complex a ]
+    go q rs
+      | length q <= 2 = r : rs
+      | otherwise     = go ( deflate r q ) ( r : rs )
+      where
+        r :: Complex a
+        r = laguerre eps maxIters q 0
+        -- Start the iteration at 0 for best chance of numerical stability.
+
+-- | Deflate a polynomial: factor out a root of the polynomial.
+-- 
+-- The polynomial must have degree at least 2.
+deflate :: forall a. Num a => a -> [ a ] -> [ a ]
+deflate r ( _ : c : cs ) = toList $ go ( c :| cs )
+  where
+    go :: NonEmpty a -> NonEmpty a
+    go ( a :| [] ) = a :| []
+    go ( a :| a' : as ) = case go ( a' :| as ) of
+      ( b' :| bs ) -> ( a + r * b' ) :| ( b' : bs )
+deflate _ _ = error "deflate: polynomial of degree < 2"
+
+-- | Laguerre's method.
+laguerre
+  :: forall a. RealFloat a
+  => a             -- ^ error tolerance
+  -> Int           -- ^ max number of iterations
+  -> [ Complex a ] -- ^ polynomial
+  -> Complex a     -- ^ initial point
+  -> Complex a
+laguerre eps maxIters p x0 = go maxIters x0
+  where
+    p', p'' :: [ Complex a ]
+    p'  = derivative p
+    p'' = derivative p'
+    go :: Int -> Complex a -> Complex a
+    go iterationsLeft x
+      | iterationsLeft <= 0        = x
+      | magnitude ( x' - x ) < eps = x'
+      | otherwise                  = go ( iterationsLeft - 1 ) x'
+      where
+        x' :: Complex a
+        x' = laguerreStep eps p p' p'' x
+
+-- | Take a single step in Laguerre's method.
+laguerreStep
+  :: forall a. RealFloat a
+  => a             -- ^ error tolerance
+  -> [ Complex a ] -- ^ polynomial
+  -> [ Complex a ] -- ^ first derivative of polynomial
+  -> [ Complex a ] -- ^ second derivative of polynomial
+  -> Complex a     -- ^ initial point
+  -> Complex a
+laguerreStep eps p p' p'' x 
+  | magnitude px < eps = x
+  | otherwise          = x - n / denom
+  where
+    n     = fromIntegral ( length p )
+    px    = eval p   x
+    p'x   = eval p'  x
+    p''x  = eval p'' x
+    g     = p'x / px
+    g²    = g * g
+    h     = g² - p''x / px
+    delta = sqrt $ ( n - 1 ) * ( n * h - g² )
+    gp    = g + delta
+    gm    = g - delta
+    denom
+      | magnitude gm > magnitude gp
+      = gm
+      | otherwise
+      = gp
+
+-- | Evaluate a polynomial.
+eval :: Num a => [ a ] -> a -> a
+eval as x = foldr ( \ a b -> a + x * b ) 0 as
+
+-- | Derivative of a polynomial.
+derivative :: Num a => [ a ] -> [ a ]
+derivative as = zipWith ( \ i a -> fromIntegral i * a ) [ ( 1 :: Int ) .. ] ( tail as )

src/lib/Math/Vector2D.hs

@@ -32,7 +32,7 @@ import Data.Group.Generics
 
 -- MetaBrush
 import Math.Module
-  ( Module (..) )
+  ( Module(..), Inner(..) )
 
 --------------------------------------------------------------------------------
 
@@ -52,3 +52,7 @@ instance Num a => Module a ( Vector2D a ) where
 
   c *^ p = fmap ( c * ) p
   p ^* c = fmap ( * c ) p
+
+instance Num a => Inner a ( Vector2D a ) where
+  ( Vector2D ( Point2D x1 y1 ) ) ^.^ ( Vector2D ( Point2D x2 y2 ) )
+    = x1 * x2 + y1 * y2