hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

improve corner initial guess for Newton iteration

Browse source 
This commit improves the initial guess we use for the Newton iteration
to solve the envelope equation when the best tangent we found arises
from a corner: instead of starting at (i = i0, s = 0), i.e. at the start
of the current curve in the spline, we might instead start at
(i = i0 - 1, s = 1).

This commit also improves the debug output to make it clearer which part
of the path goes forwards (little white dot above, inside fit points)
or backwards (little black dot below, inside fit points).
This commit is contained in:
sheaf 2024-11-17 15:34:55 +01:00
parent aeb7a425f2
commit 13cc649319
6 changed files with 111 additions and 78 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
brush-strokes/src/cusps/bench/Bench/Cases.hs
View file

@ -69,10 +69,4 @@ trickyCusp2BrushStroke =
defaultStartBoxes :: [ Int ] -> [ ( Int, [ Box 2 ] ) ] defaultStartBoxes :: [ Int ] -> [ ( Int, [ Box 2 ] ) ]
defaultStartBoxes is = defaultStartBoxes is =
[ ( i, [ 𝕀ℝ2 ( 𝕀 zero one ) ( 𝕀 zero one ) ] ) | i <- is ] [ ( i, [ 𝕀ℝ2 ( 𝕀 0 1 ) ( 𝕀 0 1 ) ] ) | i <- is ]
zero, one :: Double
zero = 1e-6
one = 1 - zero
{-# INLINE zero #-}
{-# INLINE one #-}

25
brush-strokes/src/lib/Math/Bezier/Cubic/Fit.hs
View file

@ -1,7 +1,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Math.Bezier.Cubic.Fit module Math.Bezier.Cubic.Fit
( FitParameters(..), FitPoint(..) ( FitParameters(..), FitPoint(..), FwdBwd(..)
, fitSpline, fitPiece , fitSpline, fitPiece
) )
where where
@ -92,11 +92,19 @@ data FitParameters
} }
deriving stock Show deriving stock Show
data FwdBwd
= Fwd
| Bwd
deriving stock ( Eq, Show, Generic )
deriving anyclass NFData
data FitPoint data FitPoint
= FitPoint = FitPoint
{ fitPoint :: !( ℝ 2 ) } { fitDir :: !FwdBwd
, fitPoint :: !( ℝ 2 )
}
| FitTangent | FitTangent
{ fitPoint :: !( ℝ 2 ) { fitDir :: !FwdBwd
, fitPoint :: !( ℝ 2 )
, fitTangent :: !( T ( ℝ 2 ) ) , fitTangent :: !( T ( ℝ 2 ) )
} }
| JoinPoint | JoinPoint
@ -118,11 +126,12 @@ data FitPoint
-- See 'fitPiece' for more information on the fitting process, -- See 'fitPiece' for more information on the fitting process,
-- including the meaning of \( \texttt{t_tol} \) and \( \texttt{maxIters} \). -- including the meaning of \( \texttt{t_tol} \) and \( \texttt{maxIters} \).
fitSpline fitSpline
:: FitParameters :: FwdBwd
-> FitParameters
-> ( ℝ 1 -> ( ℝ 2, T ( ℝ 2 ) ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit -> ( ℝ 1 -> ( ℝ 2, T ( ℝ 2 ) ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit
-> ( ℝ 1, ℝ 1 ) -- ^ interval \( [t_min, t_max] \) -> ( ℝ 1, ℝ 1 ) -- ^ interval \( [t_min, t_max] \)
-> ( SplinePts Open, Seq FitPoint ) -> ( SplinePts Open, Seq FitPoint )
fitSpline ( FitParameters {..} ) curveFn = go 0 fitSpline fwdOrBwd ( FitParameters {..} ) curveFn = go 0
where where
dt :: Double dt :: Double
dt = recip ( fromIntegral nbSegments ) dt = recip ( fromIntegral nbSegments )
@ -135,8 +144,8 @@ fitSpline ( FitParameters {..} ) curveFn = go 0
p, r :: ℝ 2 p, r :: ℝ 2
tp, tr :: T ( ℝ 2 ) tp, tr :: T ( ℝ 2 )
qs :: [ ℝ 2 ] qs :: [ ℝ 2 ]
(p, tp) = curveFn $ T ( ℝ1 0.0001 ) • t_min (p, tp) = curveFn t_min
(r, tr) = curveFn $ T ( ℝ1 -0.0001 ) • t_max (r, tr) = curveFn t_max
qs = [ fst $ curveFn ( lerp @( T ( ℝ 1 ) ) ( dt * fromIntegral j ) t_min t_max ) qs = [ fst $ curveFn ( lerp @( T ( ℝ 1 ) ) ( dt * fromIntegral j ) t_min t_max )
| j <- [ 1 .. nbSegments - 1 ] ] | j <- [ 1 .. nbSegments - 1 ] ]
in in
@ -145,7 +154,7 @@ fitSpline ( FitParameters {..} ) curveFn = go 0
| subdiv >= maxSubdiv | subdiv >= maxSubdiv
|| max_sq_error <= dist_tol ^ ( 2 :: Int ) || max_sq_error <= dist_tol ^ ( 2 :: Int )
-> -- trace ( unlines [ "fitSpline: piece is OK", "t_min = " ++ show t_min, "start = " ++ show p, "start tgt = " ++ show tp, "t_max = " ++ show t_max, "end = " ++ show r, "end tgt = " ++ show tr ] ) $ -> -- trace ( unlines [ "fitSpline: piece is OK", "t_min = " ++ show t_min, "start = " ++ show p, "start tgt = " ++ show tp, "t_max = " ++ show t_max, "end = " ++ show r, "end tgt = " ++ show tr ] ) $
( openCubicBezierCurveSpline () bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr ) ( openCubicBezierCurveSpline () bez, ( FitTangent fwdOrBwd p tp :<| Seq.fromList ( map ( FitPoint fwdOrBwd ) qs ) ) :|> FitTangent fwdOrBwd r tr )
| let | let
t_split :: ℝ 1 t_split :: ℝ 1
t_split = ℝ1 $ min ( 1 - dt ) $ max dt t_split_0 t_split = ℝ1 $ min ( 1 - dt ) $ max dt t_split_0

6
brush-strokes/src/lib/Math/Bezier/Spline.hs
View file

@ -36,7 +36,7 @@ import qualified Data.Bifunctor.Tannen as Biff
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( singleton, drop, splitAt ) ( drop, length, singleton, splitAt )
-- deepseq -- deepseq
import Control.DeepSeq import Control.DeepSeq
@ -196,6 +196,10 @@ data instance Curves Closed crvData ptData
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving anyclass NFData deriving anyclass NFData
nbCurves :: Curves Closed crvData ptData -> Int
nbCurves NoCurves = 0
nbCurves ( ClosedCurves { prevOpenCurves } ) = 1 + Seq.length prevOpenCurves
instance Bifunctor ( Curves Closed ) where instance Bifunctor ( Curves Closed ) where
bimap _ _ NoCurves = NoCurves bimap _ _ NoCurves = NoCurves
bimap f g ( ClosedCurves p l ) = ClosedCurves ( fmap ( bimap f g ) p ) ( bimap f g l ) bimap f g ( ClosedCurves p l ) = ClosedCurves ( fmap ( bimap f g ) p ) ( bimap f g l )

112
brush-strokes/src/lib/Math/Bezier/Stroke.hs
View file

@ -113,7 +113,9 @@ import Calligraphy.Brushes
import Math.Algebra.Dual import Math.Algebra.Dual
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
import Math.Bezier.Cubic.Fit import Math.Bezier.Cubic.Fit
( FitPoint (..), FitParameters, fitSpline ) ( FwdBwd(..), FitPoint (..)
, FitParameters, fitSpline
)
import Math.Bezier.Spline import Math.Bezier.Spline
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
import Math.Bezier.Stroke.EnvelopeEquation import Math.Bezier.Stroke.EnvelopeEquation
@ -136,6 +138,8 @@ import Math.Orientation
import Math.Roots import Math.Roots
import Math.Root.Isolation import Math.Root.Isolation
import Debug.Trace
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Offset data Offset
@ -273,8 +277,8 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
endPt :: ptData endPt :: ptData
endPt = openCurveEnd lastCurve endPt = openCurveEnd lastCurve
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: T ( ℝ 2 ) startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: T ( ℝ 2 )
( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ ℝ1 1e-4 ( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ ℝ1 0
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 (1 - 1e-4) ( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 1
startBrush, endBrush :: SplinePts Closed startBrush, endBrush :: SplinePts Closed
startBrush = brushShape spt0 startBrush = brushShape spt0
endBrush = brushShape endPt endBrush = brushShape endPt
@ -351,8 +355,8 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
endTgt = case prevCurves of endTgt = case prevCurves of
Empty -> endTangent spt0 spt0 lastCurve Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ ℝ1 1e-9 ( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ ℝ1 0
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 (1 - 1e-9) ( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 1
fwdStartCap, bwdStartCap :: SplinePts Open fwdStartCap, bwdStartCap :: SplinePts Open
OutlineData ( fmap fst -> TwoSided fwdStartCap bwdStartCap ) _ OutlineData ( fmap fst -> TwoSided fwdStartCap bwdStartCap ) _
= snd . runWriter = snd . runWriter
@ -416,8 +420,8 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: T ( ℝ 2 ) tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: T ( ℝ 2 )
tgt = startTangent spt0 ptData curve tgt = startTangent spt0 ptData curve
next_tgt = endTangent spt0 ptData curve next_tgt = endTangent spt0 ptData curve
( ( _, tgtFwd ), ( _, tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 1e-9 ( ( _, tgtFwd ), ( _, tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 0
( ( _, next_tgtFwd ), ( _, next_tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 (1 - 1e-9) ( ( _, next_tgtFwd ), ( _, next_tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 1
lift $ tellBrushJoin ( prevTgt, prev_tgtFwd, tgtBwd ) ptData ( tgt, tgtFwd, prev_tgtBwd ) lift $ tellBrushJoin ( prevTgt, prev_tgtFwd, tgtBwd ) ptData ( tgt, tgtFwd, prev_tgtBwd )
lift $ updateCurveData ( curveData curve ) fwdBwd lift $ updateCurveData ( curveData curve ) fwdBwd
put ( next_tgt, next_tgtFwd, next_tgtBwd ) put ( next_tgt, next_tgtFwd, next_tgtBwd )
@ -447,8 +451,9 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
fwdData, bwdData :: ( SplinePts Open, Seq FitPoint ) fwdData, bwdData :: ( SplinePts Open, Seq FitPoint )
( fwdData, bwdData ) = ( fwdData, bwdData ) =
( sconcat $ fmap ( fitSpline fitParams ( fst . outlineFn fwdBwd ) ) intervals ( sconcat $ fmap ( fitSpline Fwd fitParams ( fst . outlineFn fwdBwd ) ) intervals
, sconcat $ fmap ( fitSpline fitParams ( snd . outlineFn fwdBwd ) ) intervals ) , sconcat $ fmap ( fitSpline Bwd fitParams ( snd . outlineFn fwdBwd ) ) intervals
)
-- TODO: use foldMap1 once that's in base. -- TODO: use foldMap1 once that's in base.
`Strats.using` `Strats.using`
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq ) ( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
@ -899,7 +904,7 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
-- only allow non-empty splines -- only allow non-empty splines
| Just tgt_last <- lastTangent spline | Just tgt_last <- lastTangent spline
-- only allow well-defined query tangent vectors -- only allow well-defined query tangent vectors
, not (badTangent tgt_wanted) , not $ badTangent tgt_wanted
= case runExcept . ( `runStateT` tgt_last ) $ ibifoldSpline go ( \ _ -> pure () ) $ adjustSplineType @Open spline of = case runExcept . ( `runStateT` tgt_last ) $ ibifoldSpline go ( \ _ -> pure () ) $ adjustSplineType @Open spline of
Left off -> Left off ->
off off
@ -931,13 +936,31 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
tgt_end = endTangent splineStart cp cseg tgt_end = endTangent splineStart cp cseg
-- Handle corner. -- Handle corner.
unless ( tgt_prev `strictlyParallel` tgt_start ) do unless ( tgt_prev `strictlyParallel` tgt_start ) do
for_ ( between ori tgt_prev tgt_start tgt_wanted ) \ _ -> for_ ( between ori tgt_prev tgt_start tgt_wanted ) \ a -> do
lift . throwE $ let
Offset -- Decide whether the offset should be at the start of this
-- segment or at the end of the previous segment, depending
-- on which tangent is closer.
--
-- This is important to get the best initial guess possible
-- for Newton's method when solving the envelope equation.
off
| a < 0.5
= Offset
{ offsetIndex =
if i == 0
then nbCurves ( splineCurves spline ) - 1
else i - 1
, offsetParameter = Just 1
, offset = T p
}
| otherwise
= Offset
{ offsetIndex = i { offsetIndex = i
, offsetParameter = Just 0 , offsetParameter = Just 0
, offset = T p , offset = T p
} }
lift $ throwE $ off
-- Handle segment. -- Handle segment.
lift $ handleSegment i p seg tgt_start lift $ handleSegment i p seg tgt_start
put tgt_end put tgt_end
@ -1215,11 +1238,6 @@ data RootSolvingAlgorithm
-- | Use the modified Halley M2 method. -- | Use the modified Halley M2 method.
| HalleyM2 { maxIters :: Word, precision :: Int } | HalleyM2 { maxIters :: Word, precision :: Int }
data FwdBwd
= Fwd
| Bwd
deriving stock ( Eq, Show )
-- | Solve the envelope equations at a given point \( t = t_0 \), to find -- | Solve the envelope equations at a given point \( t = t_0 \), to find
-- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke. -- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke.
solveEnvelopeEquations :: RootSolvingAlgorithm solveEnvelopeEquations :: RootSolvingAlgorithm
@ -1243,8 +1261,10 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse
mbBwdCornerSol = getFirst $ foldMap ( First . cornerSol Bwd ) corners mbBwdCornerSol = getFirst $ foldMap ( First . cornerSol Bwd ) corners
findSolFrom :: FwdBwd -> Offset -> ( ℝ 2, T ( ℝ 2 ) ) findSolFrom :: FwdBwd -> Offset -> ( ℝ 2, T ( ℝ 2 ) )
findSolFrom fwdOrBwd ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } ) findSolFrom fwdOrBwd ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } ) =
= go ( fromIntegral i00 + fromMaybe 0.5 s00 ) go ( fromIntegral i00 + maybe 0.5 ( min 0.99999999999999989 ) s00 )
-- NB: the 'fromDomain' function requires values in the
-- half-open interval [0,1[, hence the @min 0.99999999999999989@ above.
where where
go :: Double -> ( ℝ 2, T ( ℝ 2 ) ) go :: Double -> ( ℝ 2, T ( ℝ 2 ) )
@ -1254,7 +1274,20 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse
| goodSoln | goodSoln
-> ( pt, tgt ) -> ( pt, tgt )
| otherwise | otherwise
-> ( off • path_t, path'_t ) -> trace
( unlines
[ "solveEnvelopeEquations: bad solution"
, "falling back to naive guess; this will lead to inaccurate fitting"
, " t: " ++ show _t
, " dir: " ++ show fwdOrBwd
, " p: " ++ show path_t
, " p': " ++ show path'_t
, " is0: " ++ show is0
, " BAD pt: " ++ show pt
, " BAD tgt: " ++ show tgt
]
)
( off • path_t, path'_t )
sol :: FwdBwd -> Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) ) sol :: FwdBwd -> Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) )
sol fwdOrBwd f is0 = sol fwdOrBwd f is0 =
@ -1267,8 +1300,8 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse
Bwd -> sgn <= 0 Bwd -> sgn <= 0
, is1 , is1
) )
( sgn, ds, dcdt ) = finish f is ( sgn, c, dcdt ) = finish fwdOrBwd f is
in ( good, ds, dcdt ) in ( good, c, dcdt )
runSolveMethod = case rootAlgo of runSolveMethod = case rootAlgo of
HalleyM2 { maxIters, precision } -> HalleyM2 { maxIters, precision } ->
@ -1276,8 +1309,8 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse
NewtonRaphson { maxIters, precision } -> NewtonRaphson { maxIters, precision } ->
newtonRaphson maxIters precision domain newtonRaphson maxIters precision domain
finish :: Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> Double -> ( Double, ℝ 2, T ( ℝ 2 ) ) finish :: FwdBwd -> Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> Double -> ( Double, ℝ 2, T ( ℝ 2 ) )
finish fs is = finish _fwdOrBwd fs is =
let (i, s) = fromDomain is in let (i, s) = fromDomain is in
case evalStrokeDatum fs is of -- TODO: a bit redundant to have to compute this again... case evalStrokeDatum fs is of -- TODO: a bit redundant to have to compute this again...
StrokeDatum StrokeDatum
@ -1292,7 +1325,7 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse
-- so check it isn't zero first. This corresponds to cusps in the envelope. -- so check it isn't zero first. This corresponds to cusps in the envelope.
let unrot_dcdt let unrot_dcdt
| abs 𝛿E𝛿s < epsilon | abs 𝛿E𝛿s < epsilon
, let s' = if s >= 0.5 then s - 1e-6 else s + 1e-6 , let s' = if s >= 0.5 then s - 1e-7 else s + 1e-7
= case ( fs `Seq.index` i ) ( ℝ1 s' ) of = case ( fs `Seq.index` i ) ( ℝ1 s' ) of
StrokeDatum { ee = D12 _ _ ( T ( ℝ1 𝛿E𝛿s' ) ), 𝛿E𝛿sdcdt = D0 𝛿E𝛿sdcdt' } StrokeDatum { ee = D12 _ _ ( T ( ℝ1 𝛿E𝛿s' ) ), 𝛿E𝛿sdcdt = D0 𝛿E𝛿sdcdt' }
-> recip 𝛿E𝛿s' *^ 𝛿E𝛿sdcdt' -> recip 𝛿E𝛿s' *^ 𝛿E𝛿sdcdt'
@ -1313,7 +1346,7 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse
evalStrokeDatum :: Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> ( Double -> StrokeDatum 2 NonIV ) evalStrokeDatum :: Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> ( Double -> StrokeDatum 2 NonIV )
evalStrokeDatum fs is = evalStrokeDatum fs is =
let (i, s) = fromDomain is let (i, s) = fromDomain is
in ( fs `Seq.index` i ) ( ℝ1 $ max 1e-6 $ min (1 - 1e-6) $ s ) in ( fs `Seq.index` i ) ( ℝ1 $ max 0 $ min 1 $ s )
eqn :: Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> ( Double -> (# Double, Double #) ) eqn :: Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> ( Double -> (# Double, Double #) )
eqn fs is = eqn fs is =
@ -1336,7 +1369,6 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse
Fwd -> id Fwd -> id
Bwd -> ( -1 *^ ) Bwd -> ( -1 *^ )
b_s = flipWhenBwd ( T u ) b_s = flipWhenBwd ( T u )
ori = CCW --case fwdOrBwd of { Fwd -> CCW ; Bwd -> CW }
res@( _pt, _tgt ) = case mbRotation of res@( _pt, _tgt ) = case mbRotation of
Nothing -> ( unT $ T p ^+^ T b Nothing -> ( unT $ T p ^+^ T b
, T u ) , T u )
@ -1346,22 +1378,7 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse
in ( unT $ T p ^+^ rotate cosθ sinθ ( T b ) in ( unT $ T p ^+^ rotate cosθ sinθ ( T b )
, rotate cosθ sinθ ( T u ) ) , rotate cosθ sinθ ( T u ) )
in in
{- if isNothing $ between CCW startTgt endTgt b_s
trace (unlines
[ "cornerSol"
, "fwdOrBwd: " ++ show fwdOrBwd
, "ori: " ++ show ori
, "dp: " ++ show _dp
, "startTgt: " ++ show startTgt
, "endTgt: " ++ show endTgt
, "u: " ++ show u
, "b_s: " ++ show b_s
, "ok: " ++ show ( between ori startTgt endTgt b_s )
, "pt: " ++ show _pt
, "tgt: " ++ show _tgt
]) $
-}
if isNothing $ between ori startTgt endTgt b_s
then Nothing then Nothing
else Just res else Just res
@ -1441,13 +1458,8 @@ findCusps ( opts1, opts2 ) boxStrokeData =
) )
where where
unit :: 𝕀 unit :: 𝕀
unit = 𝕀 zero one unit = 𝕀 0 1
{-# INLINE unit #-} {-# INLINE unit #-}
zero, one :: Double
zero = 1e-6
one = 1 - zero
{-# INLINE zero #-}
{-# INLINE one #-}
-- | Like 'findCusps', but parametrised over the initial boxes for the -- | Like 'findCusps', but parametrised over the initial boxes for the
-- root isolation method. -- root isolation method.

2
src/app/MetaBrush/Application.hs
View file

@ -221,7 +221,7 @@ runApplication application = do
maxHistorySizeTVar <- STM.newTVarIO 1000 maxHistorySizeTVar <- STM.newTVarIO 1000
fitParametersTVar <- STM.newTVarIO $ fitParametersTVar <- STM.newTVarIO $
FitParameters FitParameters
{ maxSubdiv = 2 --5 --2 --3 -- 6 { maxSubdiv = 1 --2 --5 --2 --3 -- 6
, nbSegments = 3 , nbSegments = 3
, dist_tol = 5e-3 , dist_tol = 5e-3
, t_tol = 1e-4 , t_tol = 1e-4

34
src/app/MetaBrush/Render/Document.hs
View file

@ -66,7 +66,7 @@ import Math.Algebra.Dual
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), fromQuadratic ) ( Bezier(..), fromQuadratic )
import Math.Bezier.Cubic.Fit import Math.Bezier.Cubic.Fit
( FitPoint(..), FitParameters ) ( FitPoint(..), FitParameters, FwdBwd(..) )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) ) ( Bezier(..) )
import Math.Bezier.Spline import Math.Bezier.Spline
@ -691,7 +691,7 @@ drawDebugInfo cols zoom@( Zoom { zoomFactor } ) ( fitPts, cusps ) = do
for_ cusps ( drawCusp cols zoom ) for_ cusps ( drawCusp cols zoom )
drawFitPoint :: Colours -> Zoom -> FitPoint -> StateT Double Cairo.Render () drawFitPoint :: Colours -> Zoom -> FitPoint -> StateT Double Cairo.Render ()
drawFitPoint _ ( Zoom { zoomFactor } ) ( FitPoint { fitPoint = ℝ2 x y } ) = do drawFitPoint _ zoom ( FitPoint { fitDir = fwdOrBwd, fitPoint = ℝ2 x y } ) = do
hue <- get hue <- get
put ( hue + 0.01 ) put ( hue + 0.01 )
@ -701,9 +701,7 @@ drawFitPoint _ ( Zoom { zoomFactor } ) ( FitPoint { fitPoint = ℝ2 x y } ) = do
lift do lift do
Cairo.save Cairo.save
Cairo.translate x y Cairo.translate x y
Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi ) drawFitPointHelper zoom fwdOrBwd r g b
Cairo.setSourceRGBA r g b 0.8
Cairo.fill
Cairo.restore Cairo.restore
drawFitPoint _ ( Zoom { zoomFactor } ) ( JoinPoint { joinPoint = ℝ2 x y } ) = lift do drawFitPoint _ ( Zoom { zoomFactor } ) ( JoinPoint { joinPoint = ℝ2 x y } ) = lift do
@ -717,7 +715,7 @@ drawFitPoint _ ( Zoom { zoomFactor } ) ( JoinPoint { joinPoint = ℝ2 x y } ) =
Cairo.stroke Cairo.stroke
Cairo.restore Cairo.restore
drawFitPoint _ ( Zoom { zoomFactor } ) ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty } ) = do drawFitPoint _ zoom@( Zoom { zoomFactor } ) ( FitTangent { fitDir = fwdOrBwd, fitPoint = ℝ2 x y, fitTangent = V2 tx ty } ) = do
hue <- get hue <- get
put ( hue + 0.01 ) put ( hue + 0.01 )
@ -728,14 +726,30 @@ drawFitPoint _ ( Zoom { zoomFactor } ) ( FitTangent { fitPoint = ℝ2 x y, fitT
Cairo.save Cairo.save
Cairo.translate x y Cairo.translate x y
Cairo.moveTo 0 0 Cairo.moveTo 0 0
Cairo.lineTo ( 0.05 * tx ) ( 0.05 * ty ) Cairo.lineTo ( min 0.05 ( 1 / zoomFactor ) * tx ) ( min 0.05 ( 1 / zoomFactor ) * ty )
Cairo.setLineWidth ( 4 / zoomFactor ) Cairo.setLineWidth ( 4 / zoomFactor )
Cairo.setSourceRGBA r g b 1.0 Cairo.setSourceRGBA r g b 0.8
Cairo.stroke Cairo.stroke
Cairo.arc 0 0 ( 2 / zoomFactor ) 0 ( 2 * pi ) drawFitPointHelper zoom fwdOrBwd r g b
Cairo.fill
Cairo.restore Cairo.restore
drawFitPointHelper :: Zoom -> FwdBwd -> Double -> Double -> Double -> Cairo.Render ()
drawFitPointHelper ( Zoom { zoomFactor } ) fwdOrBwd r g b = do
Cairo.moveTo 0 0
Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
Cairo.setSourceRGBA r g b 0.8
Cairo.fill
Cairo.moveTo 0 0
case fwdOrBwd of
Fwd -> do
Cairo.arc 0 ( -1 / zoomFactor ) ( 1 / zoomFactor ) 0 ( 2 * pi )
Cairo.setSourceRGBA 255 255 255 0.8
Cairo.fill
Bwd -> do
Cairo.arc 0 ( 1 / zoomFactor ) ( 1 / zoomFactor ) 0 ( 2 * pi )
Cairo.setSourceRGBA 0 0 0 0.8
Cairo.fill
drawCusp :: Colours -> Zoom -> Cusp -> Cairo.Render () drawCusp :: Colours -> Zoom -> Cusp -> Cairo.Render ()
drawCusp _ ( Zoom { zoomFactor } ) drawCusp _ ( Zoom { zoomFactor } )
( Cusp { cuspPathCoords = D21 { _D21_v = ℝ2 px py ( Cusp { cuspPathCoords = D21 { _D21_v = ℝ2 px py