fix brush join orientations

This commit is contained in:
sheaf 2021-05-13 22:07:49 +02:00
parent 570a593f4f
commit 9f16cff978
2 changed files with 90 additions and 40 deletions

View file

@ -59,6 +59,26 @@ circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code
\ -- (-r ,-r*c) -- (-r*c,-r ) -> ( 0,-r)\n\
\ -- ( r*c,-r ) -- ( r ,-r*c) -> . ]"
circleCW
:: forall circleBrushFields
. ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] )
=> UniqueSupply -> IO ( Brush circleBrushFields )
circleCW uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code
where
name, code :: Text
name = "Circle CW"
code =
"with\n\
\ r = 1\n\
\satisfying\n\
\ r > 0\n\
\define\n\
\ let c = kappa in\n\
\ [ (r,0) -- ( r ,-r*c) -- ( r*c,-r ) -> ( 0,-r)\n\
\ -- (-r*c,-r ) -- (-r ,-r*c) -> (-r, 0)\n\
\ -- (-r , r*c) -- (-r*c, r ) -> ( 0, r)\n\
\ -- ( r*c, r ) -- ( r , r*c) -> . ]"
{-
rounded
:: forall roundedBrushFields

View file

@ -108,12 +108,12 @@ import qualified Math.Bezier.Quadratic as Quadratic
import Math.Epsilon
( epsilon )
import Math.Module
( Module((*^)), Inner((^.^))
( Module(..), Inner((^.^))
, lerp, squaredNorm, cross
, convexCombination, strictlyParallel
)
import Math.Orientation
( Orientation(..), convexOrientation, splineOrientation
( Orientation(..), splineOrientation
, between
)
import Math.Roots
@ -198,10 +198,10 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
-- Open brush path with at least one segment.
-- Need to add caps at both ends of the path.
SOpen
| ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
, firstCurve :<| _ <- openCurves $ splineCurves spline
| firstCurve :<| _ <- openCurves $ splineCurves spline
, prevCurves :|> lastCurve <- openCurves $ splineCurves spline
, ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
, let
endPt :: ptData
endPt = openCurveEnd lastCurve
@ -221,18 +221,18 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
startTestTgt, endTestTgt :: Vector2D Double
( startTestTgt, endTestTgt ) =
case brushOrientation of
CCW -> ( Vector2D sty (-stx), Vector2D ety (-etx) )
CW -> ( Vector2D (-sty) stx , Vector2D (-ety) etx )
startTestTgt = Vector2D sty (-stx)
where
stx, sty, etx, ety :: Double
stx, sty :: Double
Vector2D stx sty = startTgt
endTestTgt = Vector2D ety (-etx)
where
etx, ety :: Double
Vector2D etx ety = endTgt
startCap, endCap :: SplinePts Open
startCap
| isJust $ between brushOrientation startTgtBwd startTgtFwd startTestTgt
| isJust $ between CCW startTgtBwd startTgtFwd startTestTgt
= fmap ( MkVector2D ( coords spt0 ) )
$ joinWithBrush startBrush startTgtBwd startTgtFwd
| otherwise
@ -240,15 +240,16 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
. reverseSpline
$ joinWithBrush startBrush startTgtFwd startTgtBwd
endCap
| not . isJust $ between brushOrientation endTgtBwd endTgtFwd endTestTgt
| isJust $ between CCW endTgtBwd endTgtFwd endTestTgt
= fmap ( MkVector2D ( coords endPt ) )
$ joinWithBrush endBrush endTgtFwd endTgtBwd
| otherwise
= fmap ( MkVector2D ( coords endPt ) )
. reverseSpline
$ joinWithBrush endBrush endTgtBwd endTgtFwd
| otherwise
= fmap ( MkVector2D ( coords endPt ) )
$ joinWithBrush endBrush endTgtFwd endTgtBwd
-> do
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( startTgtFwd, startTgtBwd )
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( startTgt, startTgtFwd, startTgtBwd )
pure
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
, fwdFits <> bwdFits
@ -256,10 +257,17 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
-- Closed brush path with at least one segment.
-- Add forward and backward caps at the start.
SClosed
| ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
| ClosedCurves prevCurves lastCurve <- splineCurves spline
, ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
, let
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
startTgt, endTgt, startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
startTgt = case prevCurves of
Empty -> startTangent spt0 spt0 lastCurve
firstCrv :<| _ -> startTangent spt0 spt0 firstCrv
endTgt = case prevCurves of
Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
startTgtFwd = snd ( firstOutlineFwd 0 )
startTgtBwd = (-1) *^ snd ( firstOutlineBwd 1 )
endTgtFwd = snd ( lastOutlineFwd 1 )
@ -267,9 +275,9 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
fwdStartCap, bwdStartCap :: SplinePts Open
TwoSided fwdStartCap bwdStartCap
= fmap fst . snd . runWriter
$ tellBrushJoin ( endTgtFwd, endTgtBwd ) spt0 ( startTgtFwd, startTgtBwd )
$ tellBrushJoin ( endTgt, endTgtFwd, endTgtBwd ) spt0 ( startTgt, startTgtFwd, startTgtBwd )
-> do
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( endTgtFwd, endTgtBwd )
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( endTgt, endTgtFwd, endTgtBwd )
pure
( Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
, fwdFits <> bwdFits
@ -282,9 +290,6 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
)
where
brushOrientation :: Orientation
brushOrientation = splineOrientation @Double ( brushShape spt0 )
outlineFns
:: Seq
( Double -> ( Point2D Double, Vector2D Double )
@ -306,24 +311,26 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
brushShape :: ptData -> SplinePts Closed
brushShape pt = brushFn ( ptParams pt )
updateSpline :: ( Vector2D Double, Vector2D Double ) -> ST s OutlineData
updateSpline ( lastTgtFwd, lastTgtBwd )
updateSpline :: ( Vector2D Double, Vector2D Double, Vector2D Double ) -> ST s OutlineData
updateSpline ( lastTgt, lastTgtFwd, lastTgtBwd )
= execWriterT
. ( `evalStateT` ( lastTgtFwd, lastTgtBwd ) )
. ( `evalStateT` ( lastTgt, lastTgtFwd, lastTgtBwd ) )
$ bifoldSpline
( \ ptData curve -> do
( prev_tgtFwd, prev_tgtBwd ) <- get
( prevTgt, prev_tgtFwd, prev_tgtBwd ) <- get
let
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
( fwd, bwd ) = outlineFunctions @diffParams ptParams brushFn ptData curve
tgtFwd, tgtBwd, next_tgtFwd, next_tgtBwd :: Vector2D Double
tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: Vector2D Double
tgt = startTangent spt0 ptData curve
next_tgt = endTangent spt0 ptData curve
tgtFwd = snd ( fwd 0 )
tgtBwd = (-1) *^ snd ( bwd 1 )
next_tgtFwd = snd ( fwd 1 )
tgtBwd = (-1) *^ snd ( bwd 1 )
next_tgtBwd = (-1) *^ snd ( bwd 0 )
lift $ tellBrushJoin ( prev_tgtFwd, prev_tgtBwd ) ptData ( tgtFwd, tgtBwd )
lift $ tellBrushJoin ( prevTgt, prev_tgtFwd, tgtBwd ) ptData ( tgt, tgtFwd, prev_tgtBwd )
lift $ updateCurveData ( curveData curve ) fwd bwd
put ( next_tgtFwd, next_tgtBwd )
put ( next_tgt, next_tgtFwd, next_tgtBwd )
)
( const ( pure () ) )
( adjustSplineType @Open spline )
@ -357,21 +364,46 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
tellBrushJoin
:: Monad m
=> ( Vector2D Double, Vector2D Double )
=> ( Vector2D Double, Vector2D Double, Vector2D Double )
-> ptData
-> ( Vector2D Double, Vector2D Double )
-> ( Vector2D Double, Vector2D Double, Vector2D Double )
-> WriterT OutlineData m ()
tellBrushJoin ( prevTgtFwd, prevTgtBwd ) sp0 ( tgtFwd, tgtBwd ) = tell brushJoin
tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) =
tell $ TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
where
ptOffset :: Vector2D Double
ptOffset = Point2D 0 0 --> coords sp0
brush0 :: SplinePts Closed
brush0 = brushShape sp0
-- Figure out which part of the brush to use for the join.
ori :: Orientation
ori = splineOrientation @Double brush0
fwdCond, bwdCond :: Bool
( fwdCond, bwdCond )
| prevTgt `cross` tgt < 0 && prevTgt ^.^ tgt < 0
= ( isJust $ between ori prevTgtFwd tgtFwd testTgt1
, isJust $ between ori prevTgtBwd tgtBwd ( (-1) *^ testTgt1 )
)
| otherwise
= ( not . isJust $ between ori prevTgtFwd tgtFwd testTgt2
, not . isJust $ between ori prevTgtBwd tgtBwd ( (-1) *^ testTgt2 )
)
testTgt1, testTgt2 :: Vector2D Double
testTgt1 = Vector2D (-ty) tx
where
tx, ty :: Double
Vector2D tx ty = tgt ^-^ prevTgt
testTgt2
| prevTgt ^.^ tgt < 0
= testTgt1
| otherwise
= (-1) *^ ( tgt ^+^ prevTgt )
fwdJoin, bwdJoin :: SplinePts Open
fwdJoin
| tgtFwd `strictlyParallel` prevTgtFwd
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
| brushOrientation == convexOrientation [ prevTgtFwd, tgtFwd ]
| fwdCond
= fmap ( ptOffset )
$ joinWithBrush brush0 prevTgtFwd tgtFwd
| otherwise
@ -381,15 +413,13 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
bwdJoin
| tgtBwd `strictlyParallel` prevTgtBwd
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
| brushOrientation == convexOrientation [ tgtBwd, prevTgtBwd ]
| bwdCond
= fmap ( ptOffset )
$ joinWithBrush brush0 tgtBwd prevTgtBwd
$ joinWithBrush brush0 prevTgtBwd tgtBwd
| otherwise
= fmap ( ptOffset )
. reverseSpline
$ joinWithBrush brush0 prevTgtBwd tgtBwd
brushJoin :: OutlineData
brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
$ joinWithBrush brush0 tgtBwd prevTgtBwd
-- | Computes the forward and backward stroke outline functions for a single curve.
outlineFunctions