add backend implementation of curve dragging

src/app/MetaBrush/Render/Document.hs

@@ -69,7 +69,7 @@ import Control.Monad.Trans.State.Strict
 
 -- MetaBrush
 import qualified Math.Bezier.Cubic     as Cubic
-  ( Bezier(..) )
+  ( Bezier(..), fromQuadratic )
 import Math.Bezier.Cubic.Fit
   ( FitPoint(..), FitParameters )
 import qualified Math.Bezier.Quadratic as Quadratic
@@ -381,28 +381,9 @@ drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
   Cairo.restore
 
 drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render ()
-drawQuadraticBezier ( Colours { path } ) zoom
-  ( Quadratic.Bezier
-    { p0 = Point2D x0 y0
-    , p1 = Point2D x1 y1
-    , p2 = Point2D x2 y2
-    }
-  )
-  = do
-
-  Cairo.save
-
-  Cairo.moveTo x0 y0
-  Cairo.curveTo
-    ( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 )
-    ( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 )
-    x2 y2
-
-  Cairo.setLineWidth ( 6 / zoom )
-  withRGBA path Cairo.setSourceRGBA
-  Cairo.stroke
-
-  Cairo.restore
+drawQuadraticBezier cols zoom bez =
+  drawCubicBezier cols zoom
+    ( Cubic.fromQuadratic @( Vector2D Double ) bez )
 
 drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render ()
 drawCubicBezier ( Colours { path } ) zoom

src/lib/Math/Bezier/Cubic.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE NegativeLiterals      #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE StandaloneDeriving    #-}
@@ -13,10 +15,12 @@
 
 module Math.Bezier.Cubic
   ( Bezier(..)
+  , fromQuadratic
   , bezier, bezier', bezier''
   , curvature, squaredCurvature
   , subdivide
   , ddist, closestPoint
+  , drag
   )
   where
 
@@ -55,7 +59,7 @@ import Data.Group.Generics
 
 -- MetaBrush
 import qualified Math.Bezier.Quadratic as Quadratic
-  ( Bezier(Bezier), bezier )
+  ( Bezier(..), bezier )
 import Math.Epsilon
   ( epsilon )
 import Math.Module
@@ -82,7 +86,16 @@ data Bezier p
   deriving anyclass ( NFData, NFData1 )
 
 deriving via Ap Bezier p
-  instance Act v p => Act v ( Bezier p )
+  instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p )
+
+-- | Degree raising: convert a quadratic Bézier curve to a cubic Bézier curve.
+fromQuadratic :: forall v r p. ( Torsor v p, Module r v, Fractional r ) => Quadratic.Bezier p -> Bezier p
+fromQuadratic ( Quadratic.Bezier { p0 = q0, p1 = q1, p2 = q2 } ) = Bezier {..}
+  where
+    p0 = q0
+    p1 = lerp @v (2/3) q0 q1
+    p2 = lerp @v (1/3) q1 q2
+    p3 = q2
 
 -- | Cubic Bézier curve.
 bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
@@ -91,7 +104,6 @@ bezier ( Bezier {..} ) t =
     ( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t )
     ( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t )
 
-
 -- | Derivative of cubic Bézier curve.
 bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
 bezier' ( Bezier {..} ) t
@@ -181,3 +193,25 @@ closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) -- todo: als
             p' = bezier @v pts t'
             nm' :: r
             nm' = squaredNorm ( c --> p' :: v )
+
+-- | Drag a cubic Bézier curve to pass through a given point.
+--
+-- Given a cubic Bézier curve, a time \( 0 < t < 1 \) and a point `q`,
+-- modifies the control points to make the curve pass through `q` at time `t`.
+--
+-- Affects the two control points depending on how far along the dragged point is.
+-- For instance, dragging near the middle moves both control points equally,
+-- while dragging near an endpoint will mostly affect the control point associated with that endpoint.
+drag :: forall v r p. ( Torsor v p, Module r v, Fractional r ) => Bezier p -> r -> p -> Bezier p
+drag ( Bezier {..} ) t q = Bezier { p0, p1 = p1', p2 = p2', p3 }
+  where
+    v0, v1, v2, v3, delta :: v
+    v0 = q --> p0
+    v1 = q --> p1
+    v2 = q --> p2
+    v3 = q --> p3
+    delta = ( recip $ t * ( -3 + t * ( 9 + t * ( -12 + 6 * t ) ) ) )
+          *^ bezier @v ( Bezier v0 v1 v2 v3 ) t
+    p1', p2' :: p
+    p1' = ( ( 1 - t ) *^ delta ) • p1
+    p2' = (     t     *^ delta ) • p2

src/lib/Math/Bezier/Quadratic.hs

@@ -17,6 +17,7 @@ module Math.Bezier.Quadratic
   , curvature, squaredCurvature
   , subdivide
   , ddist, closestPoint
+  , interpolate
   )
   where
 
@@ -80,7 +81,7 @@ data Bezier p
   deriving anyclass ( NFData, NFData1 )
 
 deriving via Ap Bezier p
-  instance Act v p => Act v ( Bezier p )
+  instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p )
 
 -- | Quadratic Bézier curve.
 bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
@@ -160,3 +161,17 @@ closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots )
             p' = bezier @v pts t'
             nm' :: r
             nm' = squaredNorm ( c --> p' :: v )
+
+-- | Interpolation of a quadratic Bézier control point, given path points and Bézier parameter.
+--
+-- That is, given points `p0`, `p2`, and `q`, and parameter \( 0 < t < 1 \),
+-- this function finds the unique control point `p1` such that
+-- the quadratic Bézier curve with parameters `p0`, `p1`, `p2` passes through
+-- the point `q` at time `t`.
+interpolate :: forall v r p. ( Torsor v p, Module r v, Fractional r ) => p -> p -> r -> p -> Bezier p
+interpolate p0 p2 t q = Bezier {..}
+  where
+    p1 :: p
+    p1 = (   ( 0.5 * ( t - 1 ) / t ) *^ ( q --> p0 :: v )
+         ^+^ ( 0.5 * t / ( t - 1 ) ) *^ ( q --> p2 :: v )
+         ) • q