diff --git a/src/app/MetaBrush/Asset/Brushes.hs b/src/app/MetaBrush/Asset/Brushes.hs index 76c604a..679178d 100644 --- a/src/app/MetaBrush/Asset/Brushes.hs +++ b/src/app/MetaBrush/Asset/Brushes.hs @@ -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 diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index 068649f..b5448b3 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -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