From 2bd6847e78123ff24a2817d3f1a1c50ee4f5287f Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 12 Aug 2020 22:43:47 +0200 Subject: [PATCH] add root solving code, coalesce event handling --- .gitignore | 1 + MetaBrush.cabal | 1 + app/Main.hs | 23 ++-- src/app/MetaBrush/Event.hs | 167 ++++++++++++++++++++++++++- src/app/MetaBrush/UI/Coordinates.hs | 171 +--------------------------- src/app/MetaBrush/UI/FileBar.hs | 32 +++++- src/lib/Math/Bezier/Cubic.hs | 48 +++++++- src/lib/Math/Bezier/Quadratic.hs | 41 +++++++ src/lib/Math/Module.hs | 15 ++- src/lib/Math/RealRoots.hs | 115 +++++++++++++++++++ src/lib/Math/Vector2D.hs | 6 +- 11 files changed, 421 insertions(+), 199 deletions(-) create mode 100644 src/lib/Math/RealRoots.hs diff --git a/.gitignore b/.gitignore index e095b87..7f51991 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,7 @@ cabal.project.local assets/*.svg assets/*/ +refs/ *.txt *.md diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 26fad70..4d0ea3c 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -60,6 +60,7 @@ library , Math.Bezier.Stroke , Math.Bezier.Subdivision , Math.Module + , Math.RealRoots , Math.Vector2D build-depends: diff --git a/app/Main.hs b/app/Main.hs index 0e02bac..97a5da9 100644 --- a/app/Main.hs +++ b/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 - [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ] - - _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar ) - _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) - _ <- GTK.onWidgetDestroy window GTK.mainQuit + handleEvents + activeDocumentTVar openDocumentsTVar pressedKeysTVar + window viewportDrawingArea infoBarElements --------------------------------------------------------- -- GTK main loop diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 4a61d37..d126a73 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -1,12 +1,33 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BlockArguments #-} +{-# 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 diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index 7bd6f16..145221d 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/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 ) ) diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index daf4361..19e274c 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/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" diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index 503f816..6c3f14f 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/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 - ( Bezier(Bezier), bezier ) +import Math.RealRoots + ( 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 ) diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index 735145a..d1079ac 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/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 ) diff --git a/src/lib/Math/Module.hs b/src/lib/Math/Module.hs index f0c3cac..96c8ca1 100644 --- a/src/lib/Math/Module.hs +++ b/src/lib/Math/Module.hs @@ -4,8 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Math.Module - ( Module(..) - , lerp + ( Module(..), 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 diff --git a/src/lib/Math/RealRoots.hs b/src/lib/Math/RealRoots.hs new file mode 100644 index 0000000..f638776 --- /dev/null +++ b/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 ) diff --git a/src/lib/Math/Vector2D.hs b/src/lib/Math/Vector2D.hs index d82c0ce..13fed86 100644 --- a/src/lib/Math/Vector2D.hs +++ b/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