From 92efc4127cfce1c12439a52429aa7d9935b2cacf Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 15 Jul 2023 16:40:59 +0200 Subject: [PATCH] add teardrop shaped brush --- src/app/MetaBrush/Application.hs | 16 ++-- src/metabrushes/MetaBrush/Asset/Brushes.hs | 86 +++++++++++++++++++++- 2 files changed, 91 insertions(+), 11 deletions(-) diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index beb54d8..70fe67c 100644 --- a/src/app/MetaBrush/Application.hs +++ b/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 () ) diff --git a/src/metabrushes/MetaBrush/Asset/Brushes.hs b/src/metabrushes/MetaBrush/Asset/Brushes.hs index 70a052a..52cbeb9 100644 --- a/src/metabrushes/MetaBrush/Asset/Brushes.hs +++ b/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 #-}