From 8d50c92ca971aac0e86fbfef8c8a4f9a286eefc7 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 13 Aug 2020 19:05:19 +0200 Subject: [PATCH] highlight points for hover/selection --- .gitignore | 1 + app/Main.hs | 42 ++++-- assets/theme.css | 6 + src/app/MetaBrush/Asset/Colours.hs | 4 + src/app/MetaBrush/Document.hs | 23 +++- src/app/MetaBrush/Event.hs | 57 ++++---- src/app/MetaBrush/Render/Document.hs | 187 +++++++++++++++++++-------- src/app/MetaBrush/UI/Coordinates.hs | 30 ++++- src/app/MetaBrush/UI/Panels.hs | 9 -- src/lib/Math/Bezier/Quadratic.hs | 10 +- 10 files changed, 268 insertions(+), 101 deletions(-) diff --git a/.gitignore b/.gitignore index 7f51991..00d359b 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ refs/ *.txt *.md *.html +hie.yaml diff --git a/app/Main.hs b/app/Main.hs index 97a5da9..344ba9b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -56,9 +56,8 @@ import MetaBrush.Asset.Colours import MetaBrush.Asset.Logo ( drawLogo ) import MetaBrush.Document - ( Document(..) - , AABB(..) - , Stroke(..) + ( Document(..), AABB(..) + , Stroke(..), StrokePoint(..), PointType(..), FocusState(..) ) import MetaBrush.Event ( handleEvents ) @@ -88,12 +87,30 @@ testDocuments = IntMap.fromList { displayName = "Document 1" , filePath = Nothing , unsavedChanges = False - , strokes = [ Stroke [ Point2D 0 0 ] - , Stroke [ Point2D 100 0, Point2D 105 0, Point2D 110 0 ] - , Stroke [ Point2D 0 100 ] - , Stroke [ Point2D 100 100, Point2D 105 105, Point2D 110 100 ] + , strokes = [ Stroke + [ StrokePoint ( Point2D 0 0 ) PathPoint Normal ] + "Stroke1" + 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 ) + , bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 ) , viewportCenter = Point2D 50 50 , zoomFactor = 1 } @@ -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 diff --git a/assets/theme.css b/assets/theme.css index c5d37e1..0ace876 100644 --- a/assets/theme.css +++ b/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; diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index d08f610..538ee21 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/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 ] diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 9a031df..bb75cf6 100644 --- a/src/app/MetaBrush/Document.hs +++ b/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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index d126a73..cfc72eb 100644 --- a/src/app/MetaBrush/Event.hs +++ b/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,30 +81,34 @@ 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 - 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 + mbActiveDoc <- STM.readTVarIO activeDocumentTVar + 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. + + 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 + pos :: Point2D Double + pos = toViewport ( Point2D x y ) + infoData :: InfoData + infoData = + InfoData + { zoom = zoomFactor + , mousePos = pos + , topLeftPos = toViewport ( Point2D 0 0 ) + , botRightPos = toViewport ( Point2D viewportWidth viewportHeight ) + } + updateInfoBar infoBar infoData + + 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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index f8b87ff..4f02cc2 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -1,14 +1,19 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} module MetaBrush.Render.Document ( renderDocument ) where -- base -import Control.Monad - ( when ) +import Data.Foldable + ( 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 - renderPath + Renders { renderPoints, renderPaths } = traverse_ ( renderStroke cols zoomFactor ) strokes + renderPaths renderPoints Cairo.restore pure () -renderStrokes :: Colours -> Double -> [ Stroke ] -> ( Cairo.Render (), Cairo.Render () ) -renderStrokes _ _ [] = ( pure (), pure () ) -renderStrokes cols zoom ( s : ss ) = ( points1 *> points2, path1 *> path2 ) +renderStroke :: Colours -> Double -> Stroke -> Compose Renders Cairo.Render () +renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } ) + = go pt0 pts *> Renders { renderPoints = drawPoint cols zoom pt0, renderPaths = pure () } where - ( points1, path1 ) = renderStroke cols zoom s - ( points2, path2 ) = renderStrokes cols zoom ss - -renderStroke :: Colours -> Double -> Stroke -> ( Cairo.Render (), Cairo.Render () ) -renderStroke cols zoom ( Stroke strokePts ) = go True strokePts - where - go :: Bool -> [ Point2D Double ] -> ( Cairo.Render (), Cairo.Render () ) - go drawFirstPoint pts = case pts of - [] -> ( pure (), pure () ) - [p0] -> ( when drawFirstPoint ( drawPoint cols zoom p0 ), pure () ) - [_,_] -> error "'renderStroke': unexpected pair of points" - ( p0 : p1 : p2 : ps ) -> - let - drawPoints, drawNextPoints, drawPath, drawNextPath :: Cairo.Render () - ( drawNextPoints, drawNextPath ) = go False ( p2 : ps ) - drawPoints = do - drawControl cols zoom p1 - drawLine cols zoom p0 p1 - drawLine cols zoom p1 p2 - when drawFirstPoint ( drawPoint cols zoom p0 ) - drawPoint cols zoom p2 - drawNextPoints - drawPath = do - drawQuadraticBezier cols zoom ( Quadratic.Bezier p0 p1 p2 ) - drawNextPath - in ( drawPoints, drawPath ) - - -drawPoint, drawControl :: Colours -> Double -> Point2D Double -> Cairo.Render () -drawPoint ( Colours { pathPoint, pathPointOutline } ) zoom ( Point2D x y ) = do + go :: StrokePoint -> [ StrokePoint ] -> Compose Renders Cairo.Render () + go _ [] = pure () + -- Line. + go p0 ( p1 : ps ) + | PathPoint <- pointType p1 + = Renders + { renderPoints = drawPoint cols zoom p1 + , renderPaths = drawLine cols zoom p0 p1 + } + *> go p1 ps + -- Quadratic Bézier curve. + go p0 ( p1 : p2 : ps ) + | ControlPoint <- pointType p1 + , PathPoint <- pointType p2 + = Renders + { renderPoints + = drawLine cols zoom p0 p1 + *> drawLine cols zoom p1 p2 + *> drawPoint cols zoom p1 + *> drawPoint cols zoom p2 + , renderPaths = drawQuadraticBezier cols zoom ( fmap strokePoint $ Quadratic.Bezier { p0, p1, p2 } ) + } + *> go p2 ps + -- Cubic Bézier curve. + go p0 ( p1 : p2 : p3 : ps ) + | ControlPoint <- pointType p1 + , ControlPoint <- pointType p1 + , PathPoint <- pointType p3 + = Renders + { 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 - withRGBA pathPointOutline Cairo.setSourceRGBA + Cairo.setLineWidth 1.0 + 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,24 +161,40 @@ drawControl ( Colours { controlPoint, controlPointOutline } ) zoom ( Point2D x y Cairo.arc 0 0 1 0 ( 2 * pi ) - Cairo.setLineWidth 0.8 - withRGBA controlPointOutline Cairo.setSourceRGBA + Cairo.setLineWidth 1.0 + 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 { controlPoint } ) zoom ( Point2D x1 y1 ) ( Point2D x2 y2 ) = do +drawLine :: Colours -> Double -> StrokePoint -> StrokePoint -> Cairo.Render () +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 - Cairo.setLineWidth ( 3 / zoom ) - withRGBA controlPoint Cairo.setSourceRGBA + 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 Cairo.restore @@ -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 diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index 145221d..2520ca7 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/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) +-} \ No newline at end of file diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index 12ba853..5bf11db 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/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 ) diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index d1079ac..932122d 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/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