add teardrop shaped brush

This commit is contained in:
sheaf 2023-07-15 16:40:59 +02:00
parent 7eb16b4782
commit 92efc4127c
2 changed files with 91 additions and 11 deletions

View file

@ -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 () )

View file

@ -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 #-}