mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
curve fitting: implement recursive subdivision
This commit is contained in:
parent
d4561ad549
commit
62bb1451c5
|
@ -3,7 +3,9 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module Math.Bezier.Cubic.Fit where
|
module Math.Bezier.Cubic.Fit
|
||||||
|
( fitSpline, fitPiece )
|
||||||
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Control.Arrow
|
import Control.Arrow
|
||||||
|
@ -27,6 +29,12 @@ import Data.Act
|
||||||
( (•) )
|
( (•) )
|
||||||
)
|
)
|
||||||
|
|
||||||
|
-- containers
|
||||||
|
import Data.Sequence
|
||||||
|
( Seq )
|
||||||
|
import qualified Data.Sequence as Seq
|
||||||
|
( singleton )
|
||||||
|
|
||||||
-- transformers
|
-- transformers
|
||||||
import Control.Monad.Trans.State.Strict
|
import Control.Monad.Trans.State.Strict
|
||||||
( execStateT, modify' )
|
( execStateT, modify' )
|
||||||
|
@ -42,7 +50,7 @@ import qualified Data.Vector.Unboxed as Unboxed.Vector
|
||||||
( unsafeThaw, generate )
|
( unsafeThaw, generate )
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import Math.Bezier.Cubic
|
import qualified Math.Bezier.Cubic as Cubic
|
||||||
( Bezier(..), bezier, ddist )
|
( Bezier(..), bezier, ddist )
|
||||||
import Math.Epsilon
|
import Math.Epsilon
|
||||||
( epsilon )
|
( epsilon )
|
||||||
|
@ -57,8 +65,55 @@ import Math.Roots
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
( Mat22(..), Point2D(..), Vector2D(..) )
|
( Mat22(..), Point2D(..), Vector2D(..) )
|
||||||
|
|
||||||
|
import Debug.Trace
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Fits a cubic Bézier spline to the given curve \( t \mapsto C(t), 0 \leqslant t \leqslant 1 \),
|
||||||
|
-- assumed to be G1-continuous.
|
||||||
|
--
|
||||||
|
-- Subdivides the given curve into the specified number of segments \( \texttt{nbSegments} \),
|
||||||
|
-- and tries to fit the resulting points with a cubic Bézier curve using 'fitPiece'.
|
||||||
|
--
|
||||||
|
-- When the fit is too poor: subdivide at the worst fitting point, and recurse.
|
||||||
|
-- \( \texttt{maxSubdiv} \) controls the maximum recursion depth for subdivision.
|
||||||
|
--
|
||||||
|
-- See 'fitPiece' for more information on the fitting process,
|
||||||
|
-- including the meaning of \( \texttt{t_tol} \) and \( \texttt{maxIters} \).
|
||||||
|
fitSpline
|
||||||
|
:: Int -- ^ \( \texttt{maxSubdiv} \), the maximum subdivision recursion number
|
||||||
|
-> Int -- ^ \( \texttt{nbSegments} \), number of segments to split the curve into for fitting,
|
||||||
|
-> Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance
|
||||||
|
-> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter (for the fitting process)
|
||||||
|
-> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations (for the fitting process)
|
||||||
|
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit
|
||||||
|
-> Seq ( Cubic.Bezier ( Point2D Double ) )
|
||||||
|
fitSpline maxSubdiv nbSegments dist_tol t_tol maxIters = go 0
|
||||||
|
where
|
||||||
|
dt :: Double
|
||||||
|
dt = recip ( fromIntegral nbSegments )
|
||||||
|
go
|
||||||
|
:: Int
|
||||||
|
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||||
|
-> Seq ( Cubic.Bezier ( Point2D Double ) )
|
||||||
|
go subdiv curve =
|
||||||
|
let
|
||||||
|
p, r :: Point2D Double
|
||||||
|
tp, tr :: Vector2D Double
|
||||||
|
qs :: [ Point2D Double ]
|
||||||
|
(p, tp) = curve 0
|
||||||
|
(r, tr) = curve 1
|
||||||
|
qs = map ( fst . curve ) [ dt * fromIntegral j | j <- [ 1 .. nbSegments - 1 ] ]
|
||||||
|
in
|
||||||
|
case fitPiece dist_tol t_tol maxIters p tp qs r tr of
|
||||||
|
( bez, Max ( Arg t_split sq_d ) )
|
||||||
|
| subdiv >= maxSubdiv
|
||||||
|
|| sq_d <= dist_tol ^ ( 2 :: Int )
|
||||||
|
-> Seq.singleton bez
|
||||||
|
| otherwise
|
||||||
|
-> go ( subdiv + 1 ) ( \ t -> curve ( t * t_split ) )
|
||||||
|
<> go ( subdiv + 1 ) ( \ t -> curve ( t_split + t * ( 1 - t_split ) ) )
|
||||||
|
|
||||||
-- | Fits a single cubic Bézier curve to the given data.
|
-- | Fits a single cubic Bézier curve to the given data.
|
||||||
--
|
--
|
||||||
-- This will consist of a cubic Bézier curve which:
|
-- This will consist of a cubic Bézier curve which:
|
||||||
|
@ -80,7 +135,7 @@ import Math.Vector2D
|
||||||
-- \[ \sum_{i=1}^n \Big \| B(t_i) - q_i \Big \|^2. \]
|
-- \[ \sum_{i=1}^n \Big \| B(t_i) - q_i \Big \|^2. \]
|
||||||
--
|
--
|
||||||
-- The values of the parameters \( \left ( t_i \right )_{i=1}^n \) are recursively estimated,
|
-- The values of the parameters \( \left ( t_i \right )_{i=1}^n \) are recursively estimated,
|
||||||
-- starting from uniform parametrisation (this will be the fit if `maxIters` is 0).
|
-- starting from uniform parametrisation (this will be the fit when \( \texttt{maxIters} = 0 \)).
|
||||||
--
|
--
|
||||||
-- The iteration ends when any of the following conditions are satisfied:
|
-- The iteration ends when any of the following conditions are satisfied:
|
||||||
--
|
--
|
||||||
|
@ -90,16 +145,16 @@ import Math.Vector2D
|
||||||
-- of its corresponding point to fit \( q_i \),
|
-- of its corresponding point to fit \( q_i \),
|
||||||
-- * the maximum iteration limit \( \texttt{maxIters} \) has been reached.
|
-- * the maximum iteration limit \( \texttt{maxIters} \) has been reached.
|
||||||
fitPiece
|
fitPiece
|
||||||
:: Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter
|
:: Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance
|
||||||
-> Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance
|
-> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter
|
||||||
-> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations
|
-> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations
|
||||||
-> Point2D Double -- ^ \( p \), start point
|
-> Point2D Double -- ^ \( p \), start point
|
||||||
-> Vector2D Double -- ^ \( \textrm{t}_p \), start tangent vector (length is ignored)
|
-> Vector2D Double -- ^ \( \textrm{t}_p \), start tangent vector (length is ignored)
|
||||||
-> [ Point2D Double ] -- ^ \( \left ( q_i \right )_{i=1}^n \), points to fit
|
-> [ Point2D Double ] -- ^ \( \left ( q_i \right )_{i=1}^n \), points to fit
|
||||||
-> Point2D Double -- ^ \( r \), end point
|
-> Point2D Double -- ^ \( r \), end point
|
||||||
-> Vector2D Double -- ^ \( \textrm{t}_r \), end tangent vector (length is ignored)
|
-> Vector2D Double -- ^ \( \textrm{t}_r \), end tangent vector (length is ignored)
|
||||||
-> ( Bezier ( Point2D Double ), ArgMax Double Double )
|
-> ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double )
|
||||||
fitPiece t_tol dist_tol maxIters p tp qs r tr =
|
fitPiece dist_tol t_tol maxIters p tp qs r tr =
|
||||||
runST do
|
runST do
|
||||||
-- Initialise the parameter values to a uniform subdivision.
|
-- Initialise the parameter values to a uniform subdivision.
|
||||||
ts <- Unboxed.Vector.unsafeThaw ( Unboxed.Vector.generate n uniform )
|
ts <- Unboxed.Vector.unsafeThaw ( Unboxed.Vector.generate n uniform )
|
||||||
|
@ -116,7 +171,7 @@ fitPiece t_tol dist_tol maxIters p tp qs r tr =
|
||||||
f2 t = h0 t *^ ( MkVector2D p )
|
f2 t = h0 t *^ ( MkVector2D p )
|
||||||
f3 t = h3 t *^ ( MkVector2D r )
|
f3 t = h3 t *^ ( MkVector2D r )
|
||||||
|
|
||||||
loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Bezier ( Point2D Double ), ArgMax Double Double )
|
loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double )
|
||||||
loop ts count = do
|
loop ts count = do
|
||||||
let
|
let
|
||||||
hermiteParameters :: Mat22 Double -> Vector2D Double -> Int -> [ Point2D Double ] -> ST s ( Vector2D Double )
|
hermiteParameters :: Mat22 Double -> Vector2D Double -> Int -> [ Point2D Double ] -> ST s ( Vector2D Double )
|
||||||
|
@ -147,8 +202,8 @@ fitPiece t_tol dist_tol maxIters p tp qs r tr =
|
||||||
cp1 = ( ( s1 / 3 ) *^ tp ) • p
|
cp1 = ( ( s1 / 3 ) *^ tp ) • p
|
||||||
cp2 = ( ( (-s2) / 3 ) *^ tr ) • r
|
cp2 = ( ( (-s2) / 3 ) *^ tr ) • r
|
||||||
|
|
||||||
bez :: Bezier ( Point2D Double )
|
bez :: Cubic.Bezier ( Point2D Double )
|
||||||
bez = Bezier p cp1 cp2 r
|
bez = Cubic.Bezier p cp1 cp2 r
|
||||||
|
|
||||||
-- Run one iteration of Laguerre's method to improve the parameter values t_i,
|
-- Run one iteration of Laguerre's method to improve the parameter values t_i,
|
||||||
-- so that t_i' is a better approximation of the parameter
|
-- so that t_i' is a better approximation of the parameter
|
||||||
|
@ -157,7 +212,7 @@ fitPiece t_tol dist_tol maxIters p tp qs r tr =
|
||||||
ti <- lift ( Unboxed.MVector.unsafeRead ts i )
|
ti <- lift ( Unboxed.MVector.unsafeRead ts i )
|
||||||
let
|
let
|
||||||
poly :: [ Complex Double ]
|
poly :: [ Complex Double ]
|
||||||
poly = map (:+ 0) $ ddist @( Vector2D Double ) bez q
|
poly = map (:+ 0) $ Cubic.ddist @( Vector2D Double ) bez q
|
||||||
ti' <- case laguerre epsilon 1 poly ( ti :+ 0 ) of
|
ti' <- case laguerre epsilon 1 poly ( ti :+ 0 ) of
|
||||||
x :+ y
|
x :+ y
|
||||||
| isNaN x
|
| isNaN x
|
||||||
|
@ -170,7 +225,7 @@ fitPiece t_tol dist_tol maxIters p tp qs r tr =
|
||||||
$> x
|
$> x
|
||||||
let
|
let
|
||||||
sq_dist :: Double
|
sq_dist :: Double
|
||||||
sq_dist = quadrance @( Vector2D Double ) q ( bezier @( Vector2D Double ) bez ti' )
|
sq_dist = quadrance @( Vector2D Double ) q ( Cubic.bezier @( Vector2D Double ) bez ti' )
|
||||||
modify' ( second ( <> Max ( Arg ti' sq_dist ) ) )
|
modify' ( second ( <> Max ( Arg ti' sq_dist ) ) )
|
||||||
lift ( Unboxed.MVector.unsafeWrite ts i ti' )
|
lift ( Unboxed.MVector.unsafeWrite ts i ti' )
|
||||||
|
|
||||||
|
|
|
@ -58,7 +58,7 @@ import Data.GenericLens.Internal
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import qualified Math.Bezier.Cubic as Cubic
|
import qualified Math.Bezier.Cubic as Cubic
|
||||||
import Math.Bezier.Cubic.Fit
|
import Math.Bezier.Cubic.Fit
|
||||||
( fitPiece )
|
( fitSpline )
|
||||||
import qualified Math.Bezier.Quadratic as Quadratic
|
import qualified Math.Bezier.Quadratic as Quadratic
|
||||||
import Math.Epsilon
|
import Math.Epsilon
|
||||||
( epsilon )
|
( epsilon )
|
||||||
|
@ -113,9 +113,9 @@ stroke Empty = Left Empty
|
||||||
stroke ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0
|
stroke ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0
|
||||||
stroke allPts@( spt0 :<| spt1 :<| spts )
|
stroke allPts@( spt0 :<| spt1 :<| spts )
|
||||||
| isClosed
|
| isClosed
|
||||||
= Right ( fwd, bwd )
|
= Right ( fwdPts, bwdPts )
|
||||||
| otherwise
|
| otherwise
|
||||||
= Left ( fwd <> bwd )
|
= Left ( fwdPts <> bwdPts )
|
||||||
where
|
where
|
||||||
|
|
||||||
startOffset, endOffset :: Vector2D Double
|
startOffset, endOffset :: Vector2D Double
|
||||||
|
@ -136,8 +136,8 @@ stroke allPts@( spt0 :<| spt1 :<| spts )
|
||||||
-> True
|
-> True
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
fwd, bwd :: Seq ( StrokePoint () )
|
fwdPts, bwdPts :: Seq ( StrokePoint () )
|
||||||
( fwd, bwd ) = go spt0 ( spt1 :<| spts )
|
( fwdPts, bwdPts ) = go spt0 ( spt1 :<| spts )
|
||||||
|
|
||||||
(<~>)
|
(<~>)
|
||||||
:: ( Monoid a, Monoid b )
|
:: ( Monoid a, Monoid b )
|
||||||
|
@ -149,7 +149,6 @@ stroke allPts@( spt0 :<| spt1 :<| spts )
|
||||||
-- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity).
|
-- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity).
|
||||||
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
|
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
|
||||||
joinAndContinue :: Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
|
joinAndContinue :: Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
|
||||||
--joinAndContinue tgt sp sps = go sp sps
|
|
||||||
joinAndContinue _ _ Empty
|
joinAndContinue _ _ Empty
|
||||||
-- Closed curve.
|
-- Closed curve.
|
||||||
| isClosed
|
| isClosed
|
||||||
|
@ -185,63 +184,60 @@ stroke allPts@( spt0 :<| spt1 :<| spts )
|
||||||
go sp0 ( sp1 :<| sps )
|
go sp0 ( sp1 :<| sps )
|
||||||
| PathPoint {} <- sp1
|
| PathPoint {} <- sp1
|
||||||
, let
|
, let
|
||||||
p0, p1, fop0, fop1, bop0, bop1 :: Point2D Double
|
p0, p1 :: Point2D Double
|
||||||
p0 = coords sp0
|
p0 = coords sp0
|
||||||
p1 = coords sp1
|
p1 = coords sp1
|
||||||
fop0 = offset ( withTangent tgt ( brushShape @x sp0 ) ) • p0
|
|
||||||
fop1 = offset ( withTangent tgt ( brushShape @x sp1 ) ) • p1
|
|
||||||
bop0 = offset ( withTangent ( (-1) *^ tgt ) ( brushShape @x sp0 ) ) • p0
|
|
||||||
bop1 = offset ( withTangent ( (-1) *^ tgt ) ( brushShape @x sp1 ) ) • p1
|
|
||||||
tgt :: Vector2D Double
|
tgt :: Vector2D Double
|
||||||
tgt = p0 --> p1
|
tgt = p0 --> p1
|
||||||
brush :: Double -> Seq ( StrokePoint () )
|
brush :: Double -> Seq ( StrokePoint () )
|
||||||
brush t = lerpBrush t ( brushShape @x sp0 ) ( brushShape @x sp1 )
|
brush t = lerpBrush t ( brushShape @x sp0 ) ( brushShape @x sp1 )
|
||||||
fwdPts, bwdPts :: [ Point2D Double ]
|
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
||||||
fwdPts
|
fwd t
|
||||||
= [ ( offset $ withTangent tgt $ brush t )
|
= ( offset ( withTangent tgt ( brush t ) )
|
||||||
• ( lerp @( Vector2D Double ) t p0 p1 )
|
• lerp @( Vector2D Double ) t p0 p1
|
||||||
| t <- [0.1,0.2..0.9]
|
, tgt -- wrong
|
||||||
]
|
)
|
||||||
bwdPts
|
bwd t
|
||||||
= [ ( offset $ withTangent ( (-1) *^ tgt ) $ brush t ) •
|
= ( offset ( withTangent ( (-1) *^ tgt ) ( brush s ) )
|
||||||
( lerp @( Vector2D Double ) t p0 p1 )
|
• lerp @( Vector2D Double ) s p0 p1
|
||||||
| t <- [0.9,0.8..0.1]
|
, (-1) *^ tgt -- wrong
|
||||||
]
|
)
|
||||||
= ( fitCurve fop0 tgt fwdPts fop1 tgt, fitCurve bop1 ( (-1) *^ tgt ) bwdPts bop0 ( (-1) *^ tgt ) )
|
where
|
||||||
|
s :: Double
|
||||||
|
s = 1 - t
|
||||||
|
= ( fitCurve fwd, fitCurve bwd )
|
||||||
<~> joinAndContinue tgt sp1 sps
|
<~> joinAndContinue tgt sp1 sps
|
||||||
-- Quadratic Bézier curve.
|
-- Quadratic Bézier curve.
|
||||||
go sp0 ( sp1 :<| sp2 :<| sps )
|
go sp0 ( sp1 :<| sp2 :<| sps )
|
||||||
| ControlPoint {} <- sp1
|
| ControlPoint {} <- sp1
|
||||||
, PathPoint {} <- sp2
|
, PathPoint {} <- sp2
|
||||||
, let
|
, let
|
||||||
p0, p1, p2, fop0, fop2, bop0, bop2 :: Point2D Double
|
p0, p1, p2 :: Point2D Double
|
||||||
p0 = coords sp0
|
p0 = coords sp0
|
||||||
p1 = coords sp1
|
p1 = coords sp1
|
||||||
p2 = coords sp2
|
p2 = coords sp2
|
||||||
fop0 = offset ( withTangent tgt0 ( brushShape @x sp0 ) ) • p0
|
tgt2 :: Vector2D Double
|
||||||
fop2 = offset ( withTangent tgt2 ( brushShape @x sp2 ) ) • p2
|
|
||||||
bop0 = offset ( withTangent ( (-1) *^ tgt0 ) ( brushShape @x sp0 ) ) • p0
|
|
||||||
bop2 = offset ( withTangent ( (-1) *^ tgt2 ) ( brushShape @x sp2 ) ) • p2
|
|
||||||
tgt0, tgt2 :: Vector2D Double
|
|
||||||
tgt0 = p0 --> p1
|
|
||||||
tgt2 = p1 --> p2
|
tgt2 = p1 --> p2
|
||||||
bez :: Quadratic.Bezier ( Point2D Double )
|
bez :: Quadratic.Bezier ( Point2D Double )
|
||||||
bez = Quadratic.Bezier { .. }
|
bez = Quadratic.Bezier { .. }
|
||||||
brush :: Double -> Seq ( StrokePoint () )
|
brush :: Double -> Seq ( StrokePoint () )
|
||||||
brush t = quadraticBezierBrush t
|
brush t = quadraticBezierBrush t
|
||||||
( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) )
|
( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) )
|
||||||
fwdPts, bwdPts :: [ Point2D Double ]
|
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
||||||
fwdPts
|
fwd t
|
||||||
= [ ( offset $ withTangent ( Quadratic.bezier' bez t ) $ brush t ) •
|
= ( offset ( withTangent ( Quadratic.bezier' bez t ) ( brush t ) )
|
||||||
( Quadratic.bezier @( Vector2D Double ) bez t )
|
• Quadratic.bezier @( Vector2D Double ) bez t
|
||||||
| t <- [0.1,0.2..0.9]
|
, Quadratic.bezier' bez t -- wrong
|
||||||
]
|
)
|
||||||
bwdPts
|
bwd t
|
||||||
= [ ( offset $ withTangent ( (-1) *^ Quadratic.bezier' bez t ) $ brush t ) •
|
= ( offset ( withTangent ( (-1) *^ Quadratic.bezier' bez s ) ( brush s ) )
|
||||||
( Quadratic.bezier @( Vector2D Double ) bez t )
|
• Quadratic.bezier @( Vector2D Double ) bez s
|
||||||
| t <- [0.9,0.8..0.1]
|
, (-1) *^ Quadratic.bezier' bez s -- wrong
|
||||||
]
|
)
|
||||||
= ( fitCurve fop0 tgt0 fwdPts fop2 tgt2, fitCurve bop2 ( (-1) *^ tgt2 ) bwdPts bop0 ( (-1) *^ tgt0 ) )
|
where
|
||||||
|
s :: Double
|
||||||
|
s = 1 - t
|
||||||
|
= ( fitCurve fwd, fitCurve bwd )
|
||||||
<~> joinAndContinue tgt2 sp2 sps
|
<~> joinAndContinue tgt2 sp2 sps
|
||||||
-- Cubic Bézier curve.
|
-- Cubic Bézier curve.
|
||||||
go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
|
go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
|
||||||
|
@ -249,35 +245,33 @@ stroke allPts@( spt0 :<| spt1 :<| spts )
|
||||||
, ControlPoint {} <- sp2
|
, ControlPoint {} <- sp2
|
||||||
, PathPoint {} <- sp3
|
, PathPoint {} <- sp3
|
||||||
, let
|
, let
|
||||||
p0, p1, p2, p3, fop0, fop3, bop0, bop3 :: Point2D Double
|
p0, p1, p2, p3 :: Point2D Double
|
||||||
p0 = coords sp0
|
p0 = coords sp0
|
||||||
p1 = coords sp1
|
p1 = coords sp1
|
||||||
p2 = coords sp2
|
p2 = coords sp2
|
||||||
p3 = coords sp3
|
p3 = coords sp3
|
||||||
fop0 = offset ( withTangent tgt0 ( brushShape @x sp0 ) ) • p0
|
tgt3 :: Vector2D Double
|
||||||
fop3 = offset ( withTangent tgt3 ( brushShape @x sp3 ) ) • p3
|
|
||||||
bop0 = offset ( withTangent ( (-1) *^ tgt0 ) ( brushShape @x sp0 ) ) • p0
|
|
||||||
bop3 = offset ( withTangent ( (-1) *^ tgt3 ) ( brushShape @x sp3 ) ) • p3
|
|
||||||
tgt0, tgt3 :: Vector2D Double
|
|
||||||
tgt0 = p0 --> p1
|
|
||||||
tgt3 = p2 --> p3
|
tgt3 = p2 --> p3
|
||||||
bez :: Cubic.Bezier ( Point2D Double )
|
bez :: Cubic.Bezier ( Point2D Double )
|
||||||
bez = Cubic.Bezier { .. }
|
bez = Cubic.Bezier { .. }
|
||||||
brush :: Double -> Seq ( StrokePoint () )
|
brush :: Double -> Seq ( StrokePoint () )
|
||||||
brush t = cubicBezierBrush t
|
brush t = cubicBezierBrush t
|
||||||
( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) )
|
( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) )
|
||||||
fwdPts, bwdPts :: [ Point2D Double ]
|
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
||||||
fwdPts
|
fwd t
|
||||||
= [ ( offset $ withTangent ( Cubic.bezier' bez t ) $ brush t ) •
|
= ( offset ( withTangent ( Cubic.bezier' bez t ) ( brush t ) )
|
||||||
( Cubic.bezier @( Vector2D Double ) bez t )
|
• Cubic.bezier @( Vector2D Double ) bez t
|
||||||
| t <- [0.1,0.2..0.9]
|
, Cubic.bezier' bez t -- wrong
|
||||||
]
|
)
|
||||||
bwdPts
|
bwd t
|
||||||
= [ ( offset $ withTangent ( (-1) *^ Cubic.bezier' bez t ) $ brush t ) •
|
= ( offset ( withTangent ( (-1) *^ Cubic.bezier' bez s ) ( brush s ) )
|
||||||
( Cubic.bezier @( Vector2D Double ) bez t )
|
• Cubic.bezier @( Vector2D Double ) bez s
|
||||||
| t <- [0.9,0.8..0.1]
|
, (-1) *^ Cubic.bezier' bez s -- wrong
|
||||||
]
|
)
|
||||||
= ( fitCurve fop0 tgt0 fwdPts fop3 tgt3, fitCurve bop3 ( (-1) *^ tgt3 ) bwdPts bop0 ( (-1) *^ tgt0 ) )
|
where
|
||||||
|
s :: Double
|
||||||
|
s = 1 - t
|
||||||
|
= ( fitCurve fwd, fitCurve bwd ) -- fitCurve bwd )
|
||||||
<~> joinAndContinue tgt3 sp3 sps
|
<~> joinAndContinue tgt3 sp3 sps
|
||||||
go p0 ps = error $ "stroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
|
go p0 ps = error $ "stroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
|
||||||
|
|
||||||
|
@ -292,7 +286,7 @@ brushShape = view typed . pointData
|
||||||
removePointData :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
|
removePointData :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
|
||||||
removePointData = fmap ( set ( field @"pointData" ) () )
|
removePointData = fmap ( set ( field @"pointData" ) () )
|
||||||
|
|
||||||
lerpBrush :: forall d. Double -> Seq ( StrokePoint d ) -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
|
lerpBrush :: forall d. Show d => Double -> Seq ( StrokePoint d ) -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
|
||||||
lerpBrush t p0s p1s = f <$> p0s <*> p1s
|
lerpBrush t p0s p1s = f <$> p0s <*> p1s
|
||||||
where
|
where
|
||||||
f :: StrokePoint d -> StrokePoint d -> StrokePoint ()
|
f :: StrokePoint d -> StrokePoint d -> StrokePoint ()
|
||||||
|
@ -302,9 +296,9 @@ lerpBrush t p0s p1s = f <$> p0s <*> p1s
|
||||||
f ( ControlPoint { coords = p0 } )
|
f ( ControlPoint { coords = p0 } )
|
||||||
( ControlPoint { coords = p1 } )
|
( ControlPoint { coords = p1 } )
|
||||||
= CP $ lerp @( Vector2D Double ) t p0 p1
|
= CP $ lerp @( Vector2D Double ) t p0 p1
|
||||||
f _ _ = error "stroke: incompatible brushes"
|
f p1 p2 = error $ "stroke: incompatible brushes " <> show [ p1, p2 ]
|
||||||
|
|
||||||
quadraticBezierBrush :: forall d. Double -> Quadratic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
|
quadraticBezierBrush :: forall d. Show d => Double -> Quadratic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
|
||||||
quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s p2s
|
quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s p2s
|
||||||
where
|
where
|
||||||
f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint ()
|
f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint ()
|
||||||
|
@ -316,7 +310,7 @@ quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s
|
||||||
( ControlPoint { coords = p1 } )
|
( ControlPoint { coords = p1 } )
|
||||||
( ControlPoint { coords = p2 } )
|
( ControlPoint { coords = p2 } )
|
||||||
= CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t
|
= CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t
|
||||||
f _ _ _ = error "stroke: incompatible brushes"
|
f p1 p2 p3 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3 ]
|
||||||
|
|
||||||
cubicBezierBrush :: forall d. Show d => Double -> Cubic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
|
cubicBezierBrush :: forall d. Show d => Double -> Cubic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
|
||||||
cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s p3s
|
cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s p3s
|
||||||
|
@ -335,13 +329,17 @@ cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s
|
||||||
f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ]
|
f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ]
|
||||||
|
|
||||||
fitCurve
|
fitCurve
|
||||||
:: Point2D Double -> Vector2D Double -> [ Point2D Double ] -> Point2D Double -> Vector2D Double
|
:: ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||||
-> Seq ( StrokePoint () )
|
-> Seq ( StrokePoint () )
|
||||||
fitCurve p tp qs r tr = case fitPiece 1e-4 1e-3 100 p tp qs r tr of
|
fitCurve curve = splinePoints $ fitSpline 2 10 1e-4 1e-5 80 curve
|
||||||
( Cubic.Bezier p0 p1 p2 p3, _ ) ->
|
|
||||||
-- TODO: don't duplicate endpoints
|
|
||||||
PP p0 :<| CP p1 :<| CP p2 :<| PP p3 :<| Empty
|
|
||||||
|
|
||||||
|
splinePoints :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () )
|
||||||
|
splinePoints Empty = Empty
|
||||||
|
splinePoints ps@( Cubic.Bezier p0 _ _ _ :<| _ ) = PP p0 :<| go ps
|
||||||
|
where
|
||||||
|
go :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () )
|
||||||
|
go Empty = Empty
|
||||||
|
go ( Cubic.Bezier _ p1 p2 p3 :<| pts ) = CP p1 :<| CP p2 :<| PP p3 :<| go pts
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue