From 33a3cbfaa1923c5cba2bd4b837c74d07330aff4b Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Wed, 11 Jan 2023 20:05:56 +0100
Subject: [PATCH] find solutions on nearby curves

---
 src/splines/Math/Bezier/Stroke.hs | 32 +++++++++++++++----------------
 1 file changed, 15 insertions(+), 17 deletions(-)

diff --git a/src/splines/Math/Bezier/Stroke.hs b/src/splines/Math/Bezier/Stroke.hs
index 6fd5020..bcc367e 100644
--- a/src/splines/Math/Bezier/Stroke.hs
+++ b/src/splines/Math/Bezier/Stroke.hs
@@ -29,6 +29,8 @@ import Control.Monad.ST
   ( RealWorld, ST )
 import Data.Bifunctor
   ( Bifunctor(bimap) )
+import Data.Coerce
+  ( coerce )
 import Data.Foldable
   ( for_ )
 import Data.Functor.Identity
@@ -60,7 +62,7 @@ import qualified Data.Sequence as Seq
 import Data.Set
   ( Set )
 import qualified Data.Set as Set
-  ( singleton )
+  ( insert, member, singleton )
 
 -- deepseq
 import Control.DeepSeq
@@ -853,33 +855,29 @@ solveEnvelopeEquations path_t path'_t ( fwdOffset, bwdOffset ) strokeData
     --        , "  bwdOffset: " ++ show bwdOffset ]
     --      ) True
 
-    fwdSol = findSolFrom False fwdOffset
-    ( bwdPt, bwdTgt ) = findSolFrom True  bwdOffset
+    fwdSol            = findSolFrom fwdOffset
+    ( bwdPt, bwdTgt ) = findSolFrom bwdOffset
 
     n :: Int
     n = length strokeData
 
-    findSolFrom :: Bool -> Offset -> ( ℝ 2, T ( ℝ 2 ) )
-    findSolFrom goingBwds ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } )
+    findSolFrom :: Offset -> ( ℝ 2, T ( ℝ 2 ) )
+    findSolFrom ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } )
       = go ( Set.singleton i00 ) i00 ( fromMaybe 0.5 s00 )
       where
 
         plausibleTangent :: T ( ℝ 2 ) -> Bool
-        plausibleTangent tgt
-          | goingBwds
-          = path'_t ^.^ tgt < 0
-          | otherwise
-          = path'_t ^.^ tgt > 0
+        plausibleTangent tgt = path'_t ^.^ tgt > 0
 
         go :: Set Int -> Int -> Double -> ( ℝ 2, T ( ℝ 2 ) )
         go seen i0 s0 =
           case sol s0 ( strokeData `Seq.index` i0 ) of
-            ( good, s, pt, tgt )
-              | True --good && plausibleTangent tgt
+            ( goodSoln, s, pt, tgt )
+              | goodSoln && plausibleTangent tgt
               -> ( pt, tgt )
-          --    | let ( i', s0' ) = mbNextPoint i0 ( unℝ1 s )
-          --    , not ( i' `Set.member` seen )
-          --    -> go ( Set.insert i' seen ) i' s0'
+              | let ( i', s0' ) = mbNextPoint i0 ( unℝ1 s )
+              , not ( i' `Set.member` seen )
+              -> go ( Set.insert i' seen ) i' s0'
               | otherwise
               -> ( off • path_t, path'_t )
 
@@ -928,7 +926,7 @@ solveEnvelopeEquations path_t path'_t ( fwdOffset, bwdOffset ) strokeData
 newtype ZipSeq a = ZipSeq { getZipSeq :: Seq a }
   deriving stock Functor
 instance Applicative ZipSeq where
-  pure _ = error "no pure for ZipSeq"
+  pure _ = error "only use Applicative ZipSeq with non-empty Traversable functors"
   liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys )
 
 brushStrokeData :: forall brushParams
@@ -947,7 +945,7 @@ brushStrokeData path params brush =
         dbrush_params :: D brushParams ( SplinePts Closed )
         !dbrush_params = runD brush params_t
         splines :: Seq ( D brushParams ( ℝ 1 ~> ℝ 2 ) )
-        !splines = getZipSeq $ traverse @_ @ZipSeq ( ZipSeq . splineCurveFns ) dbrush_params
+        !splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns ) dbrush_params
         dbrushes_t :: Seq ( ℝ 1 -> D ( ℝ 2 ) ( ℝ 2 ) )
         !dbrushes_t = force $ fmap ( uncurryD' . ( dparams_t `chain` ) ) splines