mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
fix incorrect brush join computation
* also add some curvature calculations (unused at the moment)
This commit is contained in:
parent
1c6f751a2b
commit
2e9c437bd4
|
@ -214,7 +214,7 @@ main = do
|
||||||
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
||||||
fitParametersTVar <- STM.newTVarIO @FitParameters
|
fitParametersTVar <- STM.newTVarIO @FitParameters
|
||||||
( FitParameters
|
( FitParameters
|
||||||
{ maxSubdiv = 5
|
{ maxSubdiv = 10
|
||||||
, nbSegments = 12
|
, nbSegments = 12
|
||||||
, dist_tol = 5e-3
|
, dist_tol = 5e-3
|
||||||
, t_tol = 1e-4
|
, t_tol = 1e-4
|
||||||
|
|
|
@ -440,7 +440,7 @@ drawStroke cols@( Colours {..} ) debug zoom strokeData = do
|
||||||
False -> Cairo.fill
|
False -> Cairo.fill
|
||||||
True -> do
|
True -> do
|
||||||
Cairo.fillPreserve
|
Cairo.fillPreserve
|
||||||
withRGBA brushCenter Cairo.setSourceRGBA
|
Cairo.setSourceRGBA 0 0 0 0.75
|
||||||
Cairo.setLineWidth ( 2 / zoom )
|
Cairo.setLineWidth ( 2 / zoom )
|
||||||
Cairo.stroke
|
Cairo.stroke
|
||||||
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
|
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
|
||||||
|
@ -451,7 +451,7 @@ drawStroke cols@( Colours {..} ) debug zoom strokeData = do
|
||||||
False -> Cairo.fill
|
False -> Cairo.fill
|
||||||
True -> do
|
True -> do
|
||||||
Cairo.fillPreserve
|
Cairo.fillPreserve
|
||||||
withRGBA brushCenter Cairo.setSourceRGBA
|
Cairo.setSourceRGBA 0 0 0 0.75
|
||||||
Cairo.setLineWidth ( 2 / zoom )
|
Cairo.setLineWidth ( 2 / zoom )
|
||||||
Cairo.stroke
|
Cairo.stroke
|
||||||
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
|
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
|
||||||
|
@ -488,7 +488,7 @@ drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render ()
|
||||||
drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do
|
drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do
|
||||||
|
|
||||||
hue <- get
|
hue <- get
|
||||||
put ( hue + 0.002 )
|
put ( hue + 0.01 )
|
||||||
let
|
let
|
||||||
r, g, b :: Double
|
r, g, b :: Double
|
||||||
( r, g, b ) = hsl2rgb hue 0.9 0.4
|
( r, g, b ) = hsl2rgb hue 0.9 0.4
|
||||||
|
@ -496,14 +496,14 @@ drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do
|
||||||
Cairo.save
|
Cairo.save
|
||||||
Cairo.translate x y
|
Cairo.translate x y
|
||||||
Cairo.arc 0 0 ( 2 / zoom ) 0 ( 2 * pi )
|
Cairo.arc 0 0 ( 2 / zoom ) 0 ( 2 * pi )
|
||||||
Cairo.setSourceRGBA r g b 1
|
Cairo.setSourceRGBA r g b 0.8
|
||||||
Cairo.fill
|
Cairo.fill
|
||||||
Cairo.restore
|
Cairo.restore
|
||||||
|
|
||||||
drawFitPoint ( Colours {..} ) zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do
|
drawFitPoint ( Colours {..} ) zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do
|
||||||
|
|
||||||
hue <- get
|
hue <- get
|
||||||
put ( hue + 0.002 )
|
put ( hue + 0.01 )
|
||||||
let
|
let
|
||||||
r, g, b :: Double
|
r, g, b :: Double
|
||||||
( r, g, b ) = hsl2rgb hue 0.9 0.4
|
( r, g, b ) = hsl2rgb hue 0.9 0.4
|
||||||
|
@ -513,7 +513,7 @@ drawFitPoint ( Colours {..} ) zoom ( FitTangent { fitPoint = Point2D x y, fitTan
|
||||||
Cairo.moveTo 0 0
|
Cairo.moveTo 0 0
|
||||||
Cairo.lineTo ( 0.05 * tx ) ( 0.05 * ty )
|
Cairo.lineTo ( 0.05 * tx ) ( 0.05 * ty )
|
||||||
Cairo.setLineWidth ( 1 / zoom )
|
Cairo.setLineWidth ( 1 / zoom )
|
||||||
Cairo.setSourceRGBA r g b 1
|
Cairo.setSourceRGBA r g b 0.8
|
||||||
Cairo.stroke
|
Cairo.stroke
|
||||||
Cairo.arc 0 0 ( 2 / zoom ) 0 ( 2 * pi )
|
Cairo.arc 0 0 ( 2 / zoom ) 0 ( 2 * pi )
|
||||||
Cairo.fill
|
Cairo.fill
|
||||||
|
|
|
@ -13,7 +13,8 @@
|
||||||
|
|
||||||
module Math.Bezier.Cubic
|
module Math.Bezier.Cubic
|
||||||
( Bezier(..)
|
( Bezier(..)
|
||||||
, bezier, bezier'
|
, bezier, bezier', bezier''
|
||||||
|
, curvature, squaredCurvature
|
||||||
, subdivide
|
, subdivide
|
||||||
, ddist, closestPoint
|
, ddist, closestPoint
|
||||||
)
|
)
|
||||||
|
@ -55,6 +56,8 @@ import Data.Group.Generics
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import qualified Math.Bezier.Quadratic as Quadratic
|
import qualified Math.Bezier.Quadratic as Quadratic
|
||||||
( Bezier(Bezier), bezier )
|
( Bezier(Bezier), bezier )
|
||||||
|
import Math.Epsilon
|
||||||
|
( epsilon )
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( Module (..)
|
( Module (..)
|
||||||
, lerp
|
, lerp
|
||||||
|
@ -97,6 +100,34 @@ bezier' ( Bezier {..} ) t
|
||||||
( lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) )
|
( lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) )
|
||||||
( lerp @v t ( p1 --> p2 ) ( p2 --> p3 ) )
|
( lerp @v t ( p1 --> p2 ) ( p2 --> p3 ) )
|
||||||
|
|
||||||
|
-- | Second derivative of a cubic Bézier curve.
|
||||||
|
bezier'' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
|
||||||
|
bezier'' ( Bezier {..} ) t
|
||||||
|
= ( 6 *^ )
|
||||||
|
$ lerp @v t
|
||||||
|
( p1 --> p0 ^+^ p1 --> p2 )
|
||||||
|
( p2 --> p1 ^+^ p2 --> p3 )
|
||||||
|
|
||||||
|
-- | Curvature of a quadratic Bézier curve.
|
||||||
|
curvature :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> r -> r
|
||||||
|
curvature bez t = sqrt $ squaredCurvature @v bez t
|
||||||
|
|
||||||
|
-- | Square of curvature of a quadratic Bézier curve.
|
||||||
|
squaredCurvature :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> r -> r
|
||||||
|
squaredCurvature bez t
|
||||||
|
| sq_nm_g' < epsilon
|
||||||
|
= 1 / 0
|
||||||
|
| otherwise
|
||||||
|
= ( sq_nm_g' * squaredNorm @v g'' - ( g' ^.^ g'' ) ^ ( 2 :: Int ) )
|
||||||
|
/ ( sq_nm_g' ^ ( 3 :: Int ) )
|
||||||
|
where
|
||||||
|
g', g'' :: v
|
||||||
|
g' = bezier' @v bez t
|
||||||
|
g'' = bezier'' @v bez t
|
||||||
|
sq_nm_g' :: r
|
||||||
|
sq_nm_g' = squaredNorm @v g'
|
||||||
|
|
||||||
|
|
||||||
-- | Subdivide a cubic Bézier curve into two parts.
|
-- | Subdivide a cubic Bézier curve into two parts.
|
||||||
subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
|
subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
|
||||||
subdivide ( Bezier {..} ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
|
subdivide ( Bezier {..} ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
|
||||||
|
|
|
@ -134,16 +134,13 @@ fitSpline ( FitParameters {..} ) = go 0
|
||||||
qs = [ fst $ curve ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
|
qs = [ fst $ curve ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
|
||||||
in
|
in
|
||||||
case fitPiece dist_tol t_tol maxIters p tp qs r tr of
|
case fitPiece dist_tol t_tol maxIters p tp qs r tr of
|
||||||
( bez, Max ( Arg sq_d t_split ) )
|
( bez, Max ( Arg max_sq_error t_split ) )
|
||||||
| subdiv >= maxSubdiv
|
| subdiv >= maxSubdiv
|
||||||
|| sq_d <= dist_tol ^ ( 2 :: Int )
|
|| max_sq_error <= dist_tol ^ ( 2 :: Int )
|
||||||
-> ( Seq.singleton bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr )
|
-> ( Seq.singleton bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr )
|
||||||
| let
|
| let
|
||||||
t_split_eff :: Double
|
t_split_eff :: Double
|
||||||
t_split_eff
|
t_split_eff = min ( 1 - dt ) $ max dt t_split
|
||||||
| t_split < 0.2 = 0.2
|
|
||||||
| t_split > 0.8 = 0.8
|
|
||||||
| otherwise = t_split
|
|
||||||
-> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split_eff )
|
-> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split_eff )
|
||||||
<> go ( subdiv + 1 ) ( \ t -> curve $ t_split_eff + t * ( 1 - t_split_eff ) )
|
<> go ( subdiv + 1 ) ( \ t -> curve $ t_split_eff + t * ( 1 - t_split_eff ) )
|
||||||
|
|
||||||
|
|
|
@ -13,7 +13,8 @@
|
||||||
|
|
||||||
module Math.Bezier.Quadratic
|
module Math.Bezier.Quadratic
|
||||||
( Bezier(..)
|
( Bezier(..)
|
||||||
, bezier, bezier'
|
, bezier, bezier', bezier''
|
||||||
|
, curvature, squaredCurvature
|
||||||
, subdivide
|
, subdivide
|
||||||
, ddist, closestPoint
|
, ddist, closestPoint
|
||||||
)
|
)
|
||||||
|
@ -53,6 +54,8 @@ import Data.Group.Generics
|
||||||
()
|
()
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
|
import Math.Epsilon
|
||||||
|
( epsilon )
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( Module (..)
|
( Module (..)
|
||||||
, lerp
|
, lerp
|
||||||
|
@ -87,6 +90,29 @@ bezier ( Bezier {..} ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
|
||||||
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
|
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
|
||||||
bezier' ( Bezier {..} ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 )
|
bezier' ( Bezier {..} ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 )
|
||||||
|
|
||||||
|
-- | Second derivative of a quadratic Bézier curve.
|
||||||
|
bezier'' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> v
|
||||||
|
bezier'' ( Bezier {..} ) = 2 *^ ( p1 --> p0 ^+^ p1 --> p2 )
|
||||||
|
|
||||||
|
-- | Curvature of a quadratic Bézier curve.
|
||||||
|
curvature :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> r -> r
|
||||||
|
curvature bez t = sqrt $ squaredCurvature @v bez t
|
||||||
|
|
||||||
|
-- | Square of curvature of a quadratic Bézier curve.
|
||||||
|
squaredCurvature :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> r -> r
|
||||||
|
squaredCurvature bez t
|
||||||
|
| sq_nm_g' < epsilon
|
||||||
|
= 1 / 0
|
||||||
|
| otherwise
|
||||||
|
= ( sq_nm_g' * squaredNorm @v g'' - ( g' ^.^ g'' ) ^ ( 2 :: Int ) )
|
||||||
|
/ ( sq_nm_g' ^ ( 3 :: Int ) )
|
||||||
|
where
|
||||||
|
g', g'' :: v
|
||||||
|
g' = bezier' @v bez t
|
||||||
|
g'' = bezier'' @v bez
|
||||||
|
sq_nm_g' :: r
|
||||||
|
sq_nm_g' = squaredNorm @v g'
|
||||||
|
|
||||||
-- | Subdivide a quadratic Bézier curve into two parts.
|
-- | Subdivide a quadratic Bézier curve into two parts.
|
||||||
subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
|
subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
|
||||||
subdivide ( Bezier {..} ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
|
subdivide ( Bezier {..} ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
|
||||||
|
|
|
@ -205,14 +205,14 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
|
||||||
-- Open curve.
|
-- Open curve.
|
||||||
| otherwise
|
| otherwise
|
||||||
= pure
|
= pure
|
||||||
( ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end, Empty )
|
( ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end, Empty )
|
||||||
, ( Empty, Empty ) -- handled separately: see 'startingCap' below
|
, ( Empty, Empty ) -- handled separately: see 'startingCap' below
|
||||||
)
|
)
|
||||||
|
|
||||||
-- Final cap for an open curve. Handled separately for correct stroke order.
|
-- Final cap for an open curve. Handled separately for correct stroke order.
|
||||||
startingCap :: Seq ( StrokePoint () )
|
startingCap :: Seq ( StrokePoint () )
|
||||||
startingCap
|
startingCap
|
||||||
= startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start
|
= startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start
|
||||||
|
|
||||||
go :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
|
go :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
|
||||||
go _ Empty = pure mempty
|
go _ Empty = pure mempty
|
||||||
|
@ -466,7 +466,7 @@ joinWithBrush
|
||||||
start, middle, end :: Seq ( StrokePoint d )
|
start, middle, end :: Seq ( StrokePoint d )
|
||||||
( ( middle, end ), start ) = first ( Seq.splitAt i2 ) $ Seq.splitAt i1 pts
|
( ( middle, end ), start ) = first ( Seq.splitAt i2 ) $ Seq.splitAt i1 pts
|
||||||
in
|
in
|
||||||
snd ( splitFirstPiece t1 start ) <> removePointData middle <> fst ( splitFirstPiece t2 end )
|
snd ( splitFirstPiece t1 start ) <> dropFirstPiece start <> removePointData middle <> fst ( splitFirstPiece t2 end )
|
||||||
where
|
where
|
||||||
t1, t2 :: Double
|
t1, t2 :: Double
|
||||||
t1 = fromMaybe 0.5 mb_t1
|
t1 = fromMaybe 0.5 mb_t1
|
||||||
|
|
Loading…
Reference in a new issue