fix brush join orientations

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

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