From fea6667114a85b60aa222947258000063f04c809 Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Sat, 12 Oct 2024 16:48:48 +0200
Subject: [PATCH] hacky fix to cusp computation timeout

---
 brush-strokes/src/lib/Math/Bezier/Stroke.hs   | 20 +++++++++++++++++--
 .../Math/Bezier/Stroke/EnvelopeEquation.hs    |  2 ++
 src/app/MetaBrush/Application.hs              |  2 +-
 src/app/MetaBrush/UI/StrokeTreeView.hs        |  3 ++-
 src/metabrushes/MetaBrush/Records.hs          |  3 ++-
 5 files changed, 25 insertions(+), 5 deletions(-)

diff --git a/brush-strokes/src/lib/Math/Bezier/Stroke.hs b/brush-strokes/src/lib/Math/Bezier/Stroke.hs
index 92a8fb5..bca2619 100644
--- a/brush-strokes/src/lib/Math/Bezier/Stroke.hs
+++ b/brush-strokes/src/lib/Math/Bezier/Stroke.hs
@@ -611,13 +611,21 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams
 
     ( potentialCusps, definiteCusps ) =
       case mbCuspOptions of
-        Just cuspOptions ->
+        Just cuspOptions
+          -- Don't try to compute cusps for a trivial curve
+          -- (e.g. a line segment with identical start- and end-points),
+          -- as the root isolation code chokes on this.
+          | not ( trivialCurve sp0 crv )
+          -- TODO: introduce a maximum time budget for the cusp computation,
+          -- and bail out if the computation exceeds the budget.
+          -- (Record such bailing out and warn the user if this happens often.)
+          ->
           foldMap
             ( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = potCusps } ) ) ->
               ( map ( ( i , ) . fst ) potCusps, map ( i , ) defCusps )
             )
             ( IntMap.toList $ findCusps cuspOptions curvesI )
-        Nothing ->
+        _ ->
           ( [], [] )
 
   in OutlineInfo
@@ -627,6 +635,13 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams
        }
 {-# INLINEABLE outlineFunction #-}
 
+-- TODO: move this out
+trivialCurve :: HasType ( ℝ 2 ) ptData => ptData -> Curve Open crvData ptData -> Bool
+trivialCurve p0 = \case
+  LineTo ( NextPoint p1 ) _ -> coords p0 == coords p1
+  Bezier2To cp1 ( NextPoint p2 ) _ -> all ( ( == coords p0 ) . coords ) [ cp1, p2 ]
+  Bezier3To cp1 cp2 ( NextPoint p3 ) _ -> all ( ( == coords p0 ) . coords ) [ cp1, cp2, p3 ]
+
 pathAndUsedParams :: forall k i (nbUsedParams :: Nat) arr crvData ptData
                   .  ( HasType ( ℝ 2 ) ptData
                      , HasBézier k i
@@ -1007,6 +1022,7 @@ brushStrokeData :: forall {kd} (k :: Nat) (nbBrushParams :: Nat) (i :: kd) arr
                    , Cross ( I i Double ) ( T ( I i 2 ) )
                    , Torsor ( T ( I i 2 ) ) ( I i 2 )
                    , Show ( ℝ nbBrushParams )
+                   , Show ( StrokeDatum k i )
                    , Representable ( I i Double ) ( I i 2 ), RepDim ( I i 2 ) ~ 2
                    )
                 => ( I i Double -> I i 1 )
diff --git a/brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs b/brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs
index 1eaca13..52cca6f 100644
--- a/brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs
+++ b/brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs
@@ -132,6 +132,8 @@ class HasEnvelopeEquation k where
                       , Transcendental ( I i Double )
                       , Representable ( I i Double ) ( I i 2 )
                       , RepDim ( I i 2 ) ~ 2
+
+                      , Show ( StrokeDatum k i )
                       )
                    => Proxy i
                    -> ( I i Double -> I i 1 )
diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs
index ce73565..7ca628d 100644
--- a/src/app/MetaBrush/Application.hs
+++ b/src/app/MetaBrush/Application.hs
@@ -364,7 +364,7 @@ runApplication application = do
                 mbCuspOptions  <- STM.readTVar cuspFindingOptionsTVar
                 STM.writeTVar redrawStrokesTVar False
                 let
-                  addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () ) 
+                  addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
                   addRulers newRender viewportSize = do
                     newRender viewportSize
                     renderRuler
diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs
index 801f14a..e1d8776 100644
--- a/src/app/MetaBrush/UI/StrokeTreeView.hs
+++ b/src/app/MetaBrush/UI/StrokeTreeView.hs
@@ -1016,8 +1016,9 @@ updateLayerHierarchy
                 [] ->
                   return ( Nothing, Nothing )
 
-      for_ mbNewHist $ \ ( activeDoc, hist ) ->
+      for_ mbNewHist $ \ ( activeDoc, hist ) -> do
         STM.modifyTVar' ( openDocumentsTVar vars ) ( Map.insert activeDoc hist )
+        STM.writeTVar ( redrawStrokesTVar vars ) True
       return $ ( , ) <$> ( fst <$> mbNewHist ) <*> mbDiff
 
     for_ mbDiff $ \ ( docUnique, diff ) ->
diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs
index b4f921a..71ed4cd 100644
--- a/src/metabrushes/MetaBrush/Records.hs
+++ b/src/metabrushes/MetaBrush/Records.hs
@@ -265,7 +265,8 @@ doIntersection k =
            ( Vec [ Fin r1_i1, Fin r1_i2, Fin r1_i3, Fin r1_i4 ] )
            ( Vec [ Fin r2_i1, Fin r2_i2, Fin r2_i3, Fin r2_i4 ] )
 
-    other -> error $ "Intersection not defined in dimension " ++ show ( length other )
+    other ->
+      error $ "Intersection not defined in dimension " ++ show ( length other )
 
 ------
 -- Functions for intersection.