add teardrop shaped brush

src/app/MetaBrush/Application.hs

@@ -158,7 +158,7 @@ runApplication application = do
             { strokeName    = "Stroke 1"
             , strokeVisible = True
             , strokeUnique  = strokeUnique
-            , strokeBrush   = Just Asset.Brushes.ellipse
+            , strokeBrush   = Just Asset.Brushes.tearDrop
             , strokeSpline  =
 --              Spline
 --                { splineStart  = mkPoint ( ℝ2 -20 -20 ) 5
@@ -167,9 +167,9 @@ runApplication application = do
 --                  ]
 --                }
               Spline
-                { splineStart  = mkPoint ( ℝ2 0 0 ) 1 1 0
+                { splineStart  = mkPoint ( ℝ2 0 0 ) 10 25 0
                 , splineCurves = OpenCurves $ Seq.fromList
-                  [ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 100 0 ) 10 10 (pi / 2) ), curveData = invalidateCache undefined }
+                  [ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 100 0 ) 15 40 pi ), curveData = invalidateCache undefined }
                   --, LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10  10 )  8 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
                   --, LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined }
                   ]
@@ -179,10 +179,12 @@ runApplication application = do
         )
       ]
         where
-          mkPoint :: ℝ 2 -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields )
-          mkPoint pt a b phi = PointData pt Normal ( MkR $ ℝ3 a b phi )
---          mkPoint :: ℝ 2 -> Double -> PointData ( Record Asset.Brushes.CircleBrushFields )
---          mkPoint pt r = PointData pt Normal ( MkR $ ℝ1 r )
+          --mkPoint :: ℝ 2 -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields )
+          --mkPoint pt a b phi = PointData pt Normal ( MkR $ ℝ3 a b phi )
+          --mkPoint :: ℝ 2 -> Double -> PointData ( Record Asset.Brushes.CircleBrushFields )
+          --mkPoint pt r = PointData pt Normal ( MkR $ ℝ1 r )
+          mkPoint ::  ℝ 2 -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.TearDropBrushFields )
+          mkPoint pt w h phi = PointData pt Normal ( MkR $ ℝ3 w h phi )
 
   recomputeStrokesTVar <- STM.newTVarIO @Bool                                    False
   documentRenderTVar   <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )

src/metabrushes/MetaBrush/Asset/Brushes.hs

@@ -6,8 +6,9 @@
 
 module MetaBrush.Asset.Brushes
   ( lookupBrush, brushes
-  ,  CircleBrushFields,  circle
-  , EllipseBrushFields, ellipse
+  ,   CircleBrushFields, circle
+  ,  EllipseBrushFields, ellipse
+  , TearDropBrushFields, tearDrop
   ) where
 
 -- base
@@ -19,7 +20,7 @@ import GHC.Exts
 
 -- containers
 import qualified Data.Sequence as Seq
-  ( fromList )
+  ( fromList, empty )
 
 -- text
 import Data.Text
@@ -55,9 +56,11 @@ brushes :: HashMap Text SomeBrush
 brushes = HashMap.fromList
   [ ( nm, b )
   | b@( SomeBrush ( BrushData { brushName = nm } ) )
-    <- [ SomeBrush circle, SomeBrush ellipse ]
+    <- [ SomeBrush circle, SomeBrush ellipse, SomeBrush tearDrop ]
   ]
 
+--------------------------------------------------------------------------------
+
 -- | Root of @(Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]@.
 --
 -- Used to approximate circles and ellipses with Bézier curves.
@@ -65,6 +68,7 @@ brushes = HashMap.fromList
 κ = 0.5519150244935105707435627227925
 
 type CircleBrushFields = '[ "r" ]
+-- | A circular brush with the given radius.
 circle :: Brush CircleBrushFields
 circle = BrushData "circle" ( WithParams deflts circleBrush )
   where
@@ -73,6 +77,8 @@ circle = BrushData "circle" ( WithParams deflts circleBrush )
 {-# INLINE circle #-}
 
 type EllipseBrushFields = '[ "a", "b", "phi" ]
+-- | An elliptical brush with the given semi-major and semi-minor axes and
+-- angle of rotation.
 ellipse :: Brush EllipseBrushFields
 ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
   where
@@ -80,6 +86,31 @@ ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
     deflts = MkR ( ℝ3 1 1 0 )
 {-# INLINE ellipse #-}
 
+-- | y-coordinate of the center of mass of the cubic Bézier teardrop
+-- with control points at (0,0), (±0.5,√3/2).
+tearCenter :: Double
+tearCenter = 3 * sqrt 3 / 14
+
+-- | Width of the cubic Bézier teardrop with control points at (0,0), (±0.5,√3/2).
+tearWidth :: Double
+tearWidth = 1 / ( 2 * sqrt 3 )
+
+-- | Height of the cubic Bézier teardrop with control points at (0,0), (±0.5,√3/2).
+tearHeight :: Double
+tearHeight = 3 * sqrt 3 / 8
+
+sqrt3_over_2 :: Double
+sqrt3_over_2 = 0.5 * sqrt 3
+
+type TearDropBrushFields = '[ "w", "h", "phi" ]
+-- | A tear-drop shape with the given width, height and angle of rotation.
+tearDrop :: Brush TearDropBrushFields
+tearDrop = BrushData "tear-drop" ( WithParams deflts tearDropBrush )
+  where
+    deflts :: Record TearDropBrushFields
+    deflts = MkR ( ℝ3 1 2.25 0 )
+{-# INLINE tearDrop #-}
+
 --------------------------------------------------------------------------------
 -- Differentiable brushes.
 
@@ -187,3 +218,50 @@ ellipseBrush _ mkI =
 
     scaledBy d x = fmap ( mkI x * ) d
 {-# INLINEABLE ellipseBrush #-}
+
+tearDropBrush :: forall {t} (i :: t) k irec
+             . ( irec ~ I i ( Record TearDropBrushFields )
+               , Module
+                  ( D k irec ( I i Double ) )
+                  ( D k irec ( I i ( ℝ 2 ) ) )
+               , Module ( I i Double ) ( T ( I i Double ) )
+               , HasChainRule ( I i Double ) k irec
+               , Representable ( I i Double ) irec
+               , Applicative ( D k irec )
+               , Transcendental ( D k irec ( I i Double ) )
+               )
+              => Proxy# i
+              -> ( forall a. a -> I i a )
+              -> C k irec ( Spline 'Closed () ( I i ( ℝ 2 ) ) )
+tearDropBrush _ mkI =
+  D \ params ->
+    let w, h, phi :: D k irec ( I i Double )
+        w   = runD ( var @_ @k ( Fin 1 ) ) params
+        h   = runD ( var @_ @k ( Fin 2 ) ) params
+        phi = runD ( var @_ @k ( Fin 3 ) ) params
+
+        mkPt :: Double -> Double -> D k irec ( I i ( ℝ 2 ) )
+        mkPt x y
+          -- 1. translate the teardrop so that the center of mass is at the origin
+          -- 2. scale the teardrop so that it has the requested width/height
+          -- 3. rotate
+          = let !x' =   w `scaledBy` (x / tearWidth)
+                !y' = ( h `scaledBy` ( ( y - tearCenter ) / tearHeight) )
+            in
+                ( x' * cos phi - y' * sin phi ) *^ e_x
+            ^+^ ( y' * cos phi + x' * sin phi ) *^ e_y
+
+    in sequenceA $
+         Spline { splineStart  = mkPt 0 0
+                , splineCurves = ClosedCurves Seq.empty $
+                  Bezier3To
+                    ( mkPt  0.5 sqrt3_over_2 )
+                    ( mkPt -0.5 sqrt3_over_2 )
+                    BackToStart () }
+  where
+    e_x, e_y :: D k irec ( I i ( ℝ 2 ) )
+    e_x = pure $ mkI $ ℝ2 1 0
+    e_y = pure $ mkI $ ℝ2 0 1
+
+    scaledBy d x = fmap ( mkI x * ) d
+{-# INLINEABLE tearDropBrush #-}