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

Fix issues in withTangent & strictlyParallel function

Browse source
This commit is contained in:
sheaf 2024-04-29 19:35:53 +02:00
parent 63b9703faf
commit 2a21980ffc
4 changed files with 56 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
MetaBrush.cabal
View file

@ -230,7 +230,8 @@ executable MetaBrush
, MetaBrush.Time , MetaBrush.Time
ghc-options: ghc-options:
-threaded -rtsopts -threaded
-rtsopts
build-depends: build-depends:
metabrushes metabrushes

4
brush-strokes/brush-strokes.cabal
View file

@ -283,3 +283,7 @@ benchmark cusps
default-language: default-language:
Haskell2010 Haskell2010
ghc-options:
-threaded
-rtsopts

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

@ -56,8 +56,7 @@ import Data.Proxy
import Data.Semigroup import Data.Semigroup
( sconcat ) ( sconcat )
import GHC.Exts import GHC.Exts
( newMutVar#, runRW#, inline ( newMutVar#, runRW# )
)
import GHC.STRef import GHC.STRef
( STRef(..), readSTRef, writeSTRef ) ( STRef(..), readSTRef, writeSTRef )
import GHC.Generics import GHC.Generics
@ -145,8 +144,6 @@ import Math.Orientation
import Math.Roots import Math.Roots
import Math.Root.Isolation import Math.Root.Isolation
--import Debug.Utils
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Offset data Offset
@ -278,8 +275,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 0 ( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ ℝ1 1e-4
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 1 ( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 (1 - 1e-4)
startBrush, endBrush :: SplinePts Closed startBrush, endBrush :: SplinePts Closed
startBrush = brushShape spt0 startBrush = brushShape spt0
endBrush = brushShape endPt endBrush = brushShape endPt
@ -342,8 +339,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 0 ( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ ℝ1 1e-9
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 1 ( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 (1 - 1e-9)
fwdStartCap, bwdStartCap :: SplinePts Open fwdStartCap, bwdStartCap :: SplinePts Open
OutlineData ( fmap fst -> TwoSided fwdStartCap bwdStartCap ) _ OutlineData ( fmap fst -> TwoSided fwdStartCap bwdStartCap ) _
= snd . runWriter = snd . runWriter
@ -368,7 +365,7 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
where where
outlineInfo :: ptData -> Curve Open crvData ptData -> OutlineInfo outlineInfo :: ptData -> Curve Open crvData ptData -> OutlineInfo
outlineInfo = inline ( outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brush ) outlineInfo = outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brush
outlineFns :: Seq OutlineInfo outlineFns :: Seq OutlineInfo
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) ) outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
@ -407,8 +404,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 0 ( ( _, tgtFwd ), ( _, tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 1e-9
( ( _, next_tgtFwd ), ( _, next_tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 1 ( ( _, next_tgtFwd ), ( _, next_tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 (1 - 1e-9)
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 )
@ -857,7 +854,8 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
-- 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 -> off Left off ->
off
Right _ -> Right _ ->
error $ error $
"withTangent: could not find any point with given tangent vector\n\ "withTangent: could not find any point with given tangent vector\n\
@ -910,12 +908,12 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
let let
tgt1 :: T ( ℝ 2 ) tgt1 :: T ( ℝ 2 )
tgt1 = p1 --> p2 tgt1 = p1 --> p2
in for_ ( convexCombination tgt0 tgt1 tgt_wanted ) \ t -> in for_ ( convexCombination tgt0 tgt1 tgt_wanted ) \ s ->
throwE $ throwE $
Offset Offset
{ offsetIndex = i { offsetIndex = i
, offsetParameter = Just t , offsetParameter = Just s
, offset = T $ Quadratic.bezier @( T ( ℝ 2 ) ) ( Quadratic.Bezier {..} ) t , offset = T $ Quadratic.bezier @( T ( ℝ 2 ) ) ( Quadratic.Bezier {..} ) s
} }
handleSegment i p0 ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) tgt0 = handleSegment i p0 ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) tgt0 =
let let
@ -929,10 +927,10 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
c12 = tgt_wanted × tgt1 c12 = tgt_wanted × tgt1
c23 = tgt_wanted × tgt2 c23 = tgt_wanted × tgt2
correctTangentParam :: Double -> Maybe Double correctTangentParam :: Double -> Maybe Double
correctTangentParam t correctTangentParam s
| t > -epsilon && t < 1 + epsilon | s > -epsilon && s < 1 + epsilon
, tgt_wanted ^.^ Cubic.bezier' bez t > epsilon , tgt_wanted ^.^ Cubic.bezier' bez s > epsilon
= Just ( max 0 ( min 1 t ) ) = Just ( max 0 ( min 1 s ) )
| otherwise | otherwise
= Nothing = Nothing
in in
@ -941,12 +939,12 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
mbParam = listToMaybe mbParam = listToMaybe
. mapMaybe correctTangentParam . mapMaybe correctTangentParam
$ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 ) $ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 )
in for_ mbParam \ t -> in for_ mbParam \ s ->
throwE $ throwE $
Offset Offset
{ offsetIndex = i { offsetIndex = i
, offsetParameter = Just t , offsetParameter = Just s
, offset = T $ Cubic.bezier @( T ( ℝ 2 ) ) bez t , offset = T $ Cubic.bezier @( T ( ℝ 2 ) ) bez s
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -1101,7 +1099,7 @@ solveEnvelopeEquations :: RootSolvingAlgorithm
-> ( Offset, Offset ) -> ( Offset, Offset )
-> Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Seq ( ℝ 1 -> StrokeDatum 2 () )
-> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) ) -> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) )
solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strokeData solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffset ) strokeData
= ( fwdSol, ( bwdPt, -1 *^ bwdTgt ) ) = ( fwdSol, ( bwdPt, -1 *^ bwdTgt ) )
where where
@ -1118,23 +1116,23 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
go is0 = go is0 =
case sol desc strokeData is0 of case sol desc strokeData is0 of
( goodSoln, pt, tgt ) ( goodSoln, pt, tgt )
| goodSoln && plausibleTangent tgt | goodSoln
-> ( pt, tgt ) -> ( pt, tgt )
| otherwise | otherwise
-> ( off • path_t, path'_t ) -> ( off • path_t, path'_t )
plausibleTangent :: T ( ℝ 2 ) -> Bool
plausibleTangent tgt = path'_t ^.^ tgt > 0
sol :: String -> Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) ) sol :: String -> Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) )
sol _desc f is0 = sol desc f is0 =
let (solRes, _solSteps) = runSolveMethod ( eqn f ) is0 let ( solRes, _solSteps ) = runSolveMethod ( eqn f ) is0
( good, is ) = ( good, is ) =
case solRes of case solRes of
Nothing -> ( False, is0 ) Nothing -> ( False, is0 )
Just is1 -> ( True , is1 ) Just is1 -> ( if desc == "fwd"
( ds, dcdt ) = finish f is then sgn >= 0
else sgn <= 0
, is1
)
( sgn, ds, dcdt ) = finish f is
in ( good, ds, dcdt ) in ( good, ds, dcdt )
runSolveMethod = case rootAlgo of runSolveMethod = case rootAlgo of
@ -1143,18 +1141,21 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
NewtonRaphson { maxIters, precision } -> NewtonRaphson { maxIters, precision } ->
newtonRaphson maxIters precision domain newtonRaphson maxIters precision domain
finish :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( ℝ 2, T ( ℝ 2 ) ) finish :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Double, ℝ 2, T ( ℝ 2 ) )
finish fs is = finish 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
{ stroke { stroke
, mbRotation
, ee = D12 ( ℝ1 _ee ) _ ( T ( ℝ1 𝛿E𝛿s ) ) , ee = D12 ( ℝ1 _ee ) _ ( T ( ℝ1 𝛿E𝛿s ) )
, du = D12 u _ _
, dv = D12 v _ _
, 𝛿E𝛿sdcdt = D0 𝛿E𝛿sdcdt , 𝛿E𝛿sdcdt = D0 𝛿E𝛿sdcdt
} -> } ->
-- The total derivative dc/dt is computed by dividing by ∂E/∂s, -- The total derivative dc/dt is computed by dividing by ∂E/∂s,
-- 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 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-6 else s + 1e-6
= case ( fs `Seq.index` i ) ( ℝ1 s' ) of = case ( fs `Seq.index` i ) ( ℝ1 s' ) of
@ -1162,7 +1163,16 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
-> recip 𝛿E𝛿s' *^ 𝛿E𝛿sdcdt' -> recip 𝛿E𝛿s' *^ 𝛿E𝛿sdcdt'
| otherwise | otherwise
= recip 𝛿E𝛿s *^ 𝛿E𝛿sdcdt = recip 𝛿E𝛿s *^ 𝛿E𝛿sdcdt
in ( stroke, dcdt ) dcdt = case mbRotation of
Nothing -> unrot_dcdt
Just ( D21 θ _ _ ) ->
let cosθ = cos θ
sinθ = sin θ
in rotate cosθ sinθ $ unrot_dcdt
in ( T u ^.^ T v, stroke, dcdt )
-- Compute the dot product of u and v (which are rotated versions of ∂c/∂t and ∂c/∂s).
-- The sign of this quantity determines which side of the envelope
-- we are on.
evalStrokeDatum :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> ( Double -> StrokeDatum 2 () ) evalStrokeDatum :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> ( Double -> StrokeDatum 2 () )
evalStrokeDatum fs is = evalStrokeDatum fs is =

8
brush-strokes/src/lib/Math/Module.hs
View file

@ -129,11 +129,13 @@ instance Cross Double ( T ( ℝ 2 ) ) where
-- | Compute whether two vectors point in the same direction, -- | Compute whether two vectors point in the same direction,
-- that is, whether each vector is a (strictly) positive multiple of the other. -- that is, whether each vector is a (strictly) positive multiple of the other.
-- --
-- Returns @False@ if either of the vectors is zero. -- Returns @False@ if either of the vectors is zero (or very close to zero).
strictlyParallel :: T ( ℝ 2 ) -> T ( ℝ 2 ) -> Bool strictlyParallel :: T ( ℝ 2 ) -> T ( ℝ 2 ) -> Bool
strictlyParallel u v strictlyParallel u v
= abs ( u × v ) < epsilon -- vectors are collinear = abs ( u × v ) < tol -- vectors are collinear
&& u ^.^ v > epsilon -- vectors point in the same direction (parallel and not anti-parallel) && u ^.^ v > tol -- vectors point in the same direction (parallel and not anti-parallel)
where
tol = norm u * norm v * epsilon
-- | Finds whether the query vector @ u @ is a convex combination of the two provided vectors @ v0 @, @ v1 @. -- | Finds whether the query vector @ u @ is a convex combination of the two provided vectors @ v0 @, @ v1 @.
-- --