mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
add teardrop shaped brush
This commit is contained in:
parent
7eb16b4782
commit
92efc4127c
|
@ -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 () )
|
||||
|
|
|
@ -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 #-}
|
||||
|
|
Loading…
Reference in a new issue