hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-30 10:54:07 +00:00
Code Issues Actions Projects Releases Wiki Activity

start modularising cusp finding code

Browse source
This commit is contained in:
sheaf 2024-04-05 17:48:53 +02:00
parent 55470d1f0e
commit bd468fcf82
2 changed files with 141 additions and 237 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
brush-strokes/src/cusps/bench/Main.hs
View file

@ -118,7 +118,9 @@ benchTestCase ( TestCase { testName, testBrushStroke, testCuspOptions, testStart
, "Test case " ++ testName ] , "Test case " ++ testName ]
before <- getMonotonicTime before <- getMonotonicTime
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
( _newtTrees, ( dunno, sols ) ) = computeCusps testCuspOptions testStrokeFnI testStartBoxes ( dunno, sols ) =
foldMap ( \ ( i, ( _trees, ( mbCusps, defCusps ) ) ) -> ( map ( i , ) mbCusps, map ( i, ) defCusps ) ) $
computeCusps testCuspOptions testStrokeFnI testStartBoxes
rnf dunno `seq` rnf sols `seq` return () rnf dunno `seq` rnf sols `seq` return ()
after <- getMonotonicTime after <- getMonotonicTime
let dt = after - before let dt = after - before
@ -192,7 +194,7 @@ data TestCase =
{ testName :: String { testName :: String
, testBrushStroke :: BrushStroke , testBrushStroke :: BrushStroke
, testCuspOptions :: CuspFindingOptions , testCuspOptions :: CuspFindingOptions
, testStartBoxes :: [ Box ] , testStartBoxes :: [ ( Int, Box ) ]
} }
brushStrokeFunctions brushStrokeFunctions
@ -216,9 +218,9 @@ mkVal t i s = ( ℝ1 t, i, ℝ1 s )
mkI :: ( Double, Double ) -> 𝕀 Double mkI :: ( Double, Double ) -> 𝕀 Double
mkI ( lo, hi ) = 𝕀 lo hi mkI ( lo, hi ) = 𝕀 lo hi
mkBox :: ( Double, Double ) -> Int -> ( Double, Double ) -> Box mkBox :: ( Double, Double ) -> ( Double, Double ) -> Box
mkBox ( t_min, t_max ) i ( s_min, s_max ) = mkBox ( t_min, t_max ) ( s_min, s_max ) =
( 𝕀 ( ℝ1 t_min ) ( ℝ1 t_max ) , i, 𝕀 ( ℝ1 s_min ) ( ℝ1 s_max ) ) ( 𝕀 ( ℝ2 t_min s_min ) ( ℝ2 t_max s_max ) )
zero, one :: Double zero, one :: Double
zero = 1e-6 zero = 1e-6
@ -480,7 +482,7 @@ showD float = showFFloat (Just 6) float ""
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
ellipseTestCase :: CuspFindingOptions -> String -> ( Double, Double ) -> Double -> [ Box ] -> TestCase ellipseTestCase :: CuspFindingOptions -> String -> ( Double, Double ) -> Double -> [ ( Int, Box ) ] -> TestCase
ellipseTestCase opts str k0k1 rot startBoxes = ellipseTestCase opts str k0k1 rot startBoxes =
TestCase TestCase
{ testName = "ellipse (" ++ str ++ ")" { testName = "ellipse (" ++ str ++ ")"
@ -602,14 +604,19 @@ getStrokeFunctions brush sp0 crv =
computeCusps computeCusps
:: CuspFindingOptions :: CuspFindingOptions
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
-> [ Box ] -> [ ( Int, Box ) ]
-> ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) ) -> [ ( Int, ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) ) ) ]
computeCusps cuspOpts eqs startBoxes = computeCusps cuspOpts eqs startBoxes =
foldMap ( findCuspsFrom cuspOpts eqs ) startBoxes map ( \ ( i, box ) -> ( i , ) $ findCuspsFrom cuspOpts ( mkEqn i ) box ) startBoxes
where
mkEqn i ( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) ) =
let t = 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi )
s = 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi )
in ( eqs t `Seq.index` i ) s
defaultStartBoxes :: [ Int ] -> [ Box ] defaultStartBoxes :: [ Int ] -> [ ( Int, Box ) ]
defaultStartBoxes is = defaultStartBoxes is =
[ mkBox (zero, one) i (zero, one) | i <- is ] [ ( i, mkBox (zero, one) (zero, one) ) | i <- is ]
getR1 (ℝ1 u) = u getR1 (ℝ1 u) = u

347
brush-strokes/src/lib/Math/Bezier/Stroke.hs
View file

@ -33,8 +33,6 @@ module Math.Bezier.Stroke
-- base -- base
import Control.Arrow import Control.Arrow
( first, (***) ) ( first, (***) )
import Control.Concurrent.MVar
( MVar, newMVar )
import Control.Monad import Control.Monad
( unless, when ) ( unless, when )
import Control.Monad.ST import Control.Monad.ST
@ -50,7 +48,7 @@ import Data.Foldable
import Data.Functor.Identity import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.List import Data.List
( intercalate, nub, partition, sort ) ( nub, partition, sort )
import Data.List.NonEmpty import Data.List.NonEmpty
( NonEmpty ) ( NonEmpty )
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
@ -71,8 +69,6 @@ import GHC.TypeNats
( type (-) ) ( type (-) )
import Numeric import Numeric
( showFFloat ) ( showFFloat )
import System.IO.Unsafe
( unsafePerformIO )
-- acts -- acts
import Data.Act import Data.Act
@ -83,12 +79,16 @@ import Data.Act
) )
-- containers -- containers
import Data.IntMap.Strict
( IntMap )
import qualified Data.IntMap.Strict as IntMap
( fromList, toList )
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( empty, index, length, reverse, singleton, zipWith ) ( empty, index, length, reverse, singleton, zipWith )
import Data.Tree import Data.Tree
( Tree(..), foldTree ) ( Tree(..) )
-- deepseq -- deepseq
import Control.DeepSeq import Control.DeepSeq
@ -114,10 +114,6 @@ import Control.Monad.Trans.State.Strict as State
import Control.Monad.Trans.Writer.CPS import Control.Monad.Trans.Writer.CPS
( Writer, WriterT, execWriterT, runWriter, tell ) ( Writer, WriterT, execWriterT, runWriter, tell )
-- tree-view
import Data.Tree.View
( showTree )
-- MetaBrush -- MetaBrush
import Math.Algebra.Dual import Math.Algebra.Dual
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
@ -154,7 +150,7 @@ import Math.Orientation
import qualified Math.Ring as Ring import qualified Math.Ring as Ring
import Math.Roots import Math.Roots
import Debug.Utils --import Debug.Utils
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -604,56 +600,24 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brushFromParams =
$ runD ( brushFromParams @2 @() proxy# id ) $ runD ( brushFromParams @2 @() proxy# id )
$ toBrushParams params_t $ toBrushParams params_t
( newtTrees, ( newtDunno, newtSols ) ) = ( potentialCusps, definiteCusps ) =
case mbCuspOptions of case mbCuspOptions of
Just cuspOptions -> Just cuspOptions ->
findCusps cuspOptions curvesI foldMap
( \ ( i, ( _trees, ( potCusps, defCusps ) ) ) ->
( map ( i , ) potCusps, map ( i , ) defCusps )
)
( IntMap.toList $ findCusps cuspOptions curvesI )
Nothing -> Nothing ->
( [], ( [], [] ) ) ( [], [] )
showD :: Double -> String in OutlineInfo
showD float = showFFloat (Just 6) float ""
functionDataLines =
[ "E, dE/ds, dE/ds * dc/dt:"
, "{" ++
(intercalate ","
[ "{" ++ showD t ++ "," ++ showD (s + fromIntegral i) ++ ",{" ++ intercalate "," vals ++ "}}"
| t <- [0.001, 0.01.. 0.999]
, i <- [0 .. (fromIntegral $ length $ curves (ℝ1 0.5)) - 1]
, s <- [0.001, 0.01.. 0.999]
, let StrokeDatum
{ ee = D12 (ℝ1 e) _dEdt (T (ℝ1 dEds))
, 𝛿E𝛿sdcdt = D0 (T (ℝ2 vx vy))
} = (curves (ℝ1 t) `Seq.index` i) (ℝ1 s)
vals = [showD e, showD dEds, "{" ++ showD vx ++ "," ++ showD vy ++ "}"]
]
) ++ "}"
]
showedTrees = map ( uncurry showRootFindingTree ) newtTrees
solLines =
[ " #sols: " ++ show (length newtSols)
, "#dunno: " ++ show (length newtDunno)
, "Tree size: " ++ show (sum @_ @Int $ map (foldTree ( \ _ bs -> 1 + sum bs )) showedTrees)
]
treeLines =
solLines ++ map showTree showedTrees
logContents = unlines $ functionDataLines ++ treeLines
in --trace (unlines solLines) $
--logToFile cuspFindingMVar logContents `seq`
OutlineInfo
{ outlineFn = fwdBwd { outlineFn = fwdBwd
, outlineDefiniteCusps = map ( cuspCoords curves ) newtSols , outlineDefiniteCusps = map ( cuspCoords curves ) definiteCusps
, outlinePotentialCusps = map ( cuspCoords curves ) newtDunno , outlinePotentialCusps = map ( cuspCoords curves ) potentialCusps
} }
{-# INLINEABLE outlineFunction #-} {-# INLINEABLE outlineFunction #-}
cuspFindingMVar :: MVar FilePath
cuspFindingMVar = unsafePerformIO
$ newMVar "logs/cusps.txt"
{-# NOINLINE cuspFindingMVar #-}
pathAndUsedParams :: forall k i arr crvData ptData usedParams pathAndUsedParams :: forall k i arr crvData ptData usedParams
. ( HasType ( ℝ 2 ) ptData . ( HasType ( ℝ 2 ) ptData
, HasBézier k i , HasBézier k i
@ -1015,11 +979,6 @@ data RootSolvingAlgorithm
-- | Use the modified Halley M2 method. -- | Use the modified Halley M2 method.
| HalleyM2 { maxIters :: Word, precision :: Int } | HalleyM2 { maxIters :: Word, precision :: Int }
rootSolvingMVar :: MVar FilePath
rootSolvingMVar = unsafePerformIO
$ newMVar "logs/envelope.txt"
{-# NOINLINE rootSolvingMVar #-}
-- | Solve the envelope equations at a given point \( t = t_0 \), to find -- | Solve the envelope equations at a given point \( t = t_0 \), to find
-- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke. -- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke.
solveEnvelopeEquations :: RootSolvingAlgorithm solveEnvelopeEquations :: RootSolvingAlgorithm
@ -1055,68 +1014,21 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
plausibleTangent tgt = path'_t ^.^ tgt > 0 plausibleTangent tgt = path'_t ^.^ tgt > 0
sol :: String -> Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) ) sol :: String -> Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) )
sol desc f is0 = sol _desc f is0 =
let (solRes, solSteps) = runSolveMethod ( eqn f ) is0 let (solRes, _solSteps) = runSolveMethod ( eqn f ) is0
( good, is ) = ( good, is ) =
case solRes of case solRes of
Nothing -> ( False, is0 ) Nothing -> ( False, is0 )
Just is1 -> ( True , is1 ) Just is1 -> ( True , is1 )
( ds, dcdt ) = finish f is ( ds, dcdt ) = finish f is
showD :: Double -> String
showD float = showFFloat (Just 6) float ""
(x_min, x_max) = domain
logContents = unlines
[ "method = " <> methodName
, desc
, "t = " ++ show _t
, "start (n,s) = " <> show (fromDomain is0)
, "steps = {"
, unlines $ map (\ (x, y, y') -> show (x, (y, y'))) solSteps
, "},"
, "E:"
, "{" ++
(intercalate ","
[ "{" ++ showD x ++ "," ++ showD y ++ "}"
| x <- [x_min, x_min + 0.01 .. x_max]
, let (# y, _y' #) = eqn f x
]
) ++ "}"
, "𝛿E𝛿s:"
, "{" ++
(intercalate ","
[ "{" ++ showD x ++ "," ++ showD y' ++ "}"
| x <- [x_min, x_min + 0.01 .. x_max]
, let (# _y, y' #) = eqn f x
]
) ++ "}"
, "𝛿E𝛿sdcdt (x):"
, "{" ++
(intercalate ","
[ "{" ++ showD x ++ "," ++ showD 𝛿E𝛿sdcdt_x ++ "}"
| x <- [x_min, x_min + 0.01 .. x_max]
, let StrokeDatum { 𝛿E𝛿sdcdt = D0 (T (ℝ2 𝛿E𝛿sdcdt_x _)) } = evalStrokeDatum f x
]
)
++ "}"
, "𝛿E𝛿sdcdt (y):"
, "{" ++
(intercalate ","
[ "{" ++ showD x ++ "," ++ showD 𝛿E𝛿sdcdt_y ++ "}"
| x <- [x_min, x_min + 0.01 .. x_max]
, let StrokeDatum { 𝛿E𝛿sdcdt = D0 (T (ℝ2 _ 𝛿E𝛿sdcdt_y)) } = evalStrokeDatum f x
]
)
++ "}"
]
in --logToFile rootSolvingMVar logContents `seq` in ( good, ds, dcdt )
( good, ds, dcdt )
(runSolveMethod, methodName) = case rootAlgo of runSolveMethod = case rootAlgo of
HalleyM2 { maxIters, precision } -> HalleyM2 { maxIters, precision } ->
(halleyM2 maxIters precision, "HalleyM2") halleyM2 maxIters precision
NewtonRaphson { maxIters, precision } -> NewtonRaphson { maxIters, precision } ->
(newtonRaphson maxIters precision domain, "NewtonRaphson") newtonRaphson maxIters precision domain
finish :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( ℝ 2, T ( ℝ 2 ) ) finish :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( ℝ 2, T ( ℝ 2 ) )
finish fs is = finish fs is =
@ -1244,13 +1156,13 @@ brushStrokeData co1 co2 path params brush =
-- The boolean indicates whether the Gauss–Seidel step was a contraction. -- The boolean indicates whether the Gauss–Seidel step was a contraction.
gaussSeidel :: ( 𝕀ℝ 2, 𝕀ℝ 2 ) -- ^ columns of \( A \) gaussSeidel :: ( 𝕀ℝ 2, 𝕀ℝ 2 ) -- ^ columns of \( A \)
-> 𝕀ℝ 2 -- ^ \( B \) -> 𝕀ℝ 2 -- ^ \( B \)
-> ( 𝕀ℝ 1, 𝕀ℝ 1 ) -- ^ initial box \( X \) -> 𝕀ℝ 2 -- ^ initial box \( X \)
-> [ ( ( 𝕀ℝ 1, 𝕀ℝ 1 ), Bool ) ] -> [ ( 𝕀ℝ 2, Bool ) ]
gaussSeidel gaussSeidel
( 𝕀 ( ℝ2 a11_lo a21_lo ) ( ℝ2 a11_hi a21_hi ) ( 𝕀 ( ℝ2 a11_lo a21_lo ) ( ℝ2 a11_hi a21_hi )
, 𝕀 ( ℝ2 a12_lo a22_lo ) ( ℝ2 a12_hi a22_hi ) ) , 𝕀 ( ℝ2 a12_lo a22_lo ) ( ℝ2 a12_hi a22_hi ) )
( 𝕀 ( ℝ2 b1_lo b2_lo ) ( ℝ2 b1_hi b2_hi ) ) ( 𝕀 ( ℝ2 b1_lo b2_lo ) ( ℝ2 b1_hi b2_hi ) )
( 𝕀 ( ℝ1 x1_lo ) ( ℝ1 x1_hi ), 𝕀 ( ℝ1 x2_lo ) ( ℝ1 x2_hi ) ) ( 𝕀 ( ℝ2 x1_lo x2_lo ) ( ℝ2 x1_hi x2_hi ) )
= let !a11 = 𝕀 a11_lo a11_hi = let !a11 = 𝕀 a11_lo a11_hi
!a12 = 𝕀 a12_lo a12_hi !a12 = 𝕀 a12_lo a12_hi
!a21 = 𝕀 a21_lo a21_hi !a21 = 𝕀 a21_lo a21_hi
@ -1268,7 +1180,7 @@ gaussSeidel
x2'_0 <- ( b2 - a21 * x1' ) `extendedDivide` a22 x2'_0 <- ( b2 - a21 * x1' ) `extendedDivide` a22
( 𝕀 x2'_lo x2'_hi, sub_x2 ) <- x2'_0 `intersect` x2 ( 𝕀 x2'_lo x2'_hi, sub_x2 ) <- x2'_0 `intersect` x2
return ( ( 𝕀 ( ℝ1 x1'_lo ) ( ℝ1 x1'_hi ), 𝕀 ( ℝ1 x2'_lo ) ( ℝ1 x2'_hi ) ) return ( ( 𝕀 ( ℝ2 x1'_lo x2'_lo) ( ℝ2 x1'_hi x2'_hi ) )
, sub_x1 && sub_x2 ) , sub_x1 && sub_x2 )
-- TODO: try implementing the complete interval union Gauss–Seidel algorithm. -- TODO: try implementing the complete interval union Gauss–Seidel algorithm.
-- See "Algorithm 2" in -- See "Algorithm 2" in
@ -1294,9 +1206,9 @@ intersect ( 𝕀 lo1 hi1 ) ( 𝕀 lo2 hi2 )
-- TODO: use Newton's method starting at the midpoint of the box, -- TODO: use Newton's method starting at the midpoint of the box,
-- instead of just taking the midpoint of the box. -- instead of just taking the midpoint of the box.
cuspCoords :: ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 () ) ) cuspCoords :: ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 () ) )
-> Box -> ( Int, Box )
-> Cusp -> Cusp
cuspCoords eqs ( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ), i, 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) ) cuspCoords eqs ( i, 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
| StrokeDatum | StrokeDatum
{ dpath { dpath
, dstroke = D22 { _D22_v = stroke } } , dstroke = D22 { _D22_v = stroke } }
@ -1342,7 +1254,6 @@ instance Show RootFindingStep where
data RootFindingLeaf d data RootFindingLeaf d
= TooSmall d = TooSmall d
| NoSolution String d
deriving stock Show deriving stock Show
showRootFindingTree :: Box -> RootFindingTree Box -> Tree String showRootFindingTree :: Box -> RootFindingTree Box -> Tree String
@ -1351,13 +1262,13 @@ showRootFindingTree cand (RootFindingStep s ts)
= Node (show cand ++ " abc " ++ showArea (boxArea cand) ++ " " ++ show s) $ map (\ (c,t) -> showRootFindingTree c t) ts = Node (show cand ++ " abc " ++ showArea (boxArea cand) ++ " " ++ show s) $ map (\ (c,t) -> showRootFindingTree c t) ts
boxArea :: Box -> Double boxArea :: Box -> Double
boxArea ( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ), _, 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) ) boxArea ( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
= abs ( t_hi - t_lo ) * abs ( s_hi - s_lo ) = abs ( t_hi - t_lo ) * abs ( s_hi - s_lo )
showArea :: Double -> [Char] showArea :: Double -> [Char]
showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")" showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
type Box = ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) type Box = 𝕀ℝ 2
type BoxHistory = [ NE.NonEmpty ( RootFindingStep, Box ) ] type BoxHistory = [ NE.NonEmpty ( RootFindingStep, Box ) ]
-- | Options for the cusp-finding methods in 'findCusps' and 'findCuspsFrom'. -- | Options for the cusp-finding methods in 'findCusps' and 'findCuspsFrom'.
@ -1371,17 +1282,24 @@ data CuspFindingOptions
} }
data RootFindingAlgorithm data RootFindingAlgorithm
-- | Gauss–Seidel step with the given preconditioning method.
= GaussSeidel GaussSeidelOptions
-- | @box(1)@-consistency.
| Box1 Box1Options
-- | @box(2)@-consistency.
| Box2 Box2Options
-- | Bisection step. -- | Bisection step.
| Bisection BisectionOptions = Bisection !BisectionOptions
-- | Gauss–Seidel step with the given preconditioning method.
| GaussSeidel !GaussSeidelOptions
-- | @box(1)@-consistency.
| Box1 !Box1Options
-- | @box(2)@-consistency.
| Box2 !Box2Options
-- | Options for the bisection method.
data BisectionOptions =
BisectionOptions
{ canHaveSols :: !( ( 𝕀ℝ 2 -> StrokeDatum 3 𝕀 ) -> Box -> Bool )
, fallbackBisectionDim :: !( [ ( RootFindingStep, Box ) ] -> BoxHistory -> ( 𝕀ℝ 2 -> StrokeDatum 3 𝕀 ) -> ( Int, String ) )
}
-- | Options for the interval Gauss–Seidel method. -- | Options for the interval Gauss–Seidel method.
data GaussSeidelOptions = GaussSeidelOptions { gsPreconditioner :: Preconditioner } data GaussSeidelOptions = GaussSeidelOptions { gsPreconditioner :: !Preconditioner }
-- | Options for the @box(1)@-consistency method. -- | Options for the @box(1)@-consistency method.
data Box1Options = Box1Options { box1EpsEq :: !Double } data Box1Options = Box1Options { box1EpsEq :: !Double }
@ -1389,21 +1307,15 @@ data Box1Options = Box1Options { box1EpsEq :: !Double }
-- | Options for the @box(2)@-consistency method. -- | Options for the @box(2)@-consistency method.
data Box2Options = Box2Options { box2EpsEq :: !Double, box2LambdaMin :: !Double } data Box2Options = Box2Options { box2EpsEq :: !Double, box2LambdaMin :: !Double }
-- | Options for the bisection method.
data BisectionOptions =
BisectionOptions
{ canHaveSols :: !( ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) -> Box -> Bool )
, fallbackBisectionDim :: !( [ ( RootFindingStep, Box ) ] -> BoxHistory -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) -> (Int, String) )
}
defaultCuspFindingOptions :: CuspFindingOptions defaultCuspFindingOptions :: CuspFindingOptions
defaultCuspFindingOptions = defaultCuspFindingOptions =
CuspFindingOptions CuspFindingOptions
{ minWidth { minWidth
, cuspFindingAlgorithms = defaultCuspFindingAlgorithms minWidth 5e-3 , cuspFindingAlgorithms = defaultCuspFindingAlgorithms minWidth narrowAbs
} }
where where
minWidth = 1e-5 minWidth = 1e-5
narrowAbs = 5e-3
defaultCuspFindingAlgorithms :: Double -> Double -> Box -> BoxHistory -> NonEmpty RootFindingAlgorithm defaultCuspFindingAlgorithms :: Double -> Double -> Box -> BoxHistory -> NonEmpty RootFindingAlgorithm
defaultCuspFindingAlgorithms minWidth narrowAbs box history = defaultCuspFindingAlgorithms minWidth narrowAbs box history =
@ -1417,17 +1329,18 @@ defaultCuspFindingAlgorithms minWidth narrowAbs box history =
-- ...then try bisecting the box. -- ...then try bisecting the box.
-> Bisection ( defaultBisectionOptions minWidth narrowAbs box ) NE.:| [] -> Bisection ( defaultBisectionOptions minWidth narrowAbs box ) NE.:| []
-- Otherwise, do a normal round: try an interval Gauss–Seidel step followed by box(1)-consistency. -- Otherwise, do a normal round.
-- Currently: we try an interval Gauss–Seidel step followed by box(1)-consistency.
_ -> GaussSeidel defaultGaussSeidelOptions _ -> GaussSeidel defaultGaussSeidelOptions
NE.:| [ Box1 ( Box1Options { box1EpsEq = narrowAbs } ) ] NE.:| [ Box1 ( Box1Options { box1EpsEq = narrowAbs } ) ]
where where
sufficientlySmallerThan :: Box -> Box -> Bool sufficientlySmallerThan :: Box -> Box -> Bool
sufficientlySmallerThan ( t1, _, s1 ) ( t2, _, s2 ) = sufficientlySmallerThan
( wd t1 - wd t2 > narrowAbs ) ( 𝕀 ( ℝ2 t1_lo s1_lo ) ( ℝ2 t1_hi s1_hi ) )
( 𝕀 ( ℝ2 t2_lo s2_lo ) ( ℝ2 t2_hi s2_hi ) ) =
( ( t1_hi - t1_lo ) - ( t2_hi - t2_lo ) > narrowAbs )
|| ||
( wd s1 - wd s2 > narrowAbs ) ( ( s1_hi - s1_lo ) - ( s2_hi - s2_lo ) > narrowAbs )
wd :: 𝕀ℝ 1 -> Double
wd ( 𝕀 ( ℝ1 lo ) ( ℝ1 hi ) ) = hi - lo
defaultGaussSeidelOptions :: GaussSeidelOptions defaultGaussSeidelOptions :: GaussSeidelOptions
defaultGaussSeidelOptions = GaussSeidelOptions { gsPreconditioner = InverseMidJacobian } defaultGaussSeidelOptions = GaussSeidelOptions { gsPreconditioner = InverseMidJacobian }
@ -1436,15 +1349,12 @@ defaultBisectionOptions :: Double -> Double -> Box -> BisectionOptions
defaultBisectionOptions defaultBisectionOptions
_minWidth _minWidth
_narrowAbs _narrowAbs
( t@( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) ) box@( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
, i
, s@( 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
)
= BisectionOptions = BisectionOptions
{ canHaveSols = { canHaveSols =
\ eqs _box'@( _t', _i', _s' ) -> \ eqs box' ->
-- box(0)-consistency -- box(0)-consistency
let dat' = ( eqs _t' `Seq.index` _i' ) _s' let dat' = eqs box'
in ee_potential_zero dat' && 𝛿E𝛿sdcdt_potential_zero dat' in ee_potential_zero dat' && 𝛿E𝛿sdcdt_potential_zero dat'
-- box(1)-consistency -- box(1)-consistency
@ -1458,7 +1368,7 @@ defaultBisectionOptions
\ _roundHist _prevRoundsHist eqs -> \ _roundHist _prevRoundsHist eqs ->
let StrokeDatum { ee = D22 _ ( T ee_t ) (T ee_s ) _ _ _ let StrokeDatum { ee = D22 _ ( T ee_t ) (T ee_s ) _ _ _
, 𝛿E𝛿sdcdt = D12 _ ( T ( T f_t ) ) ( T ( T f_s ) ) } , 𝛿E𝛿sdcdt = D12 _ ( T ( T f_t ) ) ( T ( T f_s ) ) }
= ( eqs t `Seq.index` i ) s = eqs box
wd_t = t_hi - t_lo wd_t = t_hi - t_lo
wd_s = s_hi - s_lo wd_s = s_hi - s_lo
tJWidth = wd_t * normVI3 ee_t f_t tJWidth = wd_t * normVI3 ee_t f_t
@ -1479,15 +1389,19 @@ defaultBisectionOptions
findCusps findCusps
:: CuspFindingOptions :: CuspFindingOptions
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
-> ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) ) -> IntMap ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) )
findCusps opts eqs = foldMap ( findCuspsFrom opts eqs ) initBoxes findCusps opts eqs =
where IntMap.fromList
initBoxes = [ ( i, findCuspsFrom opts eqnPiece initBox )
[ ( 𝕀 ( ℝ1 zero ) ( ℝ1 one ), i, 𝕀 ( ℝ1 zero ) ( ℝ1 one ) )
| i <- [ 0 .. length ( eqs ( 𝕀 ( ℝ1 zero ) ( ℝ1 one ) ) ) - 1 ] | i <- [ 0 .. length ( eqs ( 𝕀 ( ℝ1 zero ) ( ℝ1 one ) ) ) - 1 ]
, let initBox = 𝕀 ( ℝ2 zero zero ) ( ℝ2 one one )
eqnPiece ( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) ) =
let t = 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi )
s = 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi )
in ( eqs t `Seq.index` i ) s
] ]
-- | Use the following algorithms using interal arithmetic in order -- | Use the following algorithms using interval arithmetic in order
-- to find cusps in the envelope: -- to find cusps in the envelope:
-- --
-- - interval Newton method with Gauss–Seidel step for inversion -- - interval Newton method with Gauss–Seidel step for inversion
@ -1502,7 +1416,7 @@ findCusps opts eqs = foldMap ( findCuspsFrom opts eqs ) initBoxes
-- boxes which might or might not contain solutions. -- boxes which might or might not contain solutions.
findCuspsFrom findCuspsFrom
:: CuspFindingOptions :: CuspFindingOptions
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) -> ( 𝕀ℝ 2 -> StrokeDatum 3 𝕀 )
-> Box -> Box
-> ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) ) -> ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) )
findCuspsFrom findCuspsFrom
@ -1520,26 +1434,23 @@ findCuspsFrom
-> Writer ( [ Box ], [ Box ] ) -> Writer ( [ Box ], [ Box ] )
[ RootFindingTree Box ] [ RootFindingTree Box ]
go history go history
cand@( t@( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) ) cand@( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
, i | -- Check the envelope equation interval contains zero.
, s@( 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) ) not ( ee_potential_zero sd)
) ||
-- Check the 𝛿E𝛿sdcdt interval contains zero.
not ( 𝛿E𝛿sdcdt_potential_zero sd )
-- Box doesn't contain a solution: discard it.
= return []
-- Box is small: stop processing it. -- Box is small: stop processing it.
| t_hi - t_lo < minWidth && s_hi - s_lo < minWidth | t_hi - t_lo < minWidth && s_hi - s_lo < minWidth
= do let res = TooSmall cand = do let res = TooSmall cand
tell ( [ cand ], [] ) tell ( [ cand ], [] )
return [ RootFindingLeaf res ] return [ RootFindingLeaf res ]
| -- Check the envelope equation interval contains zero.
ee_potential_zero sd
-- Check the 𝛿E𝛿sdcdt interval contains zero.
, 𝛿E𝛿sdcdt_potential_zero sd
= doStrategies history ( cuspFindingAlgorithms cand history ) cand
-- Box doesn't contain a solution: discard it.
| otherwise | otherwise
, let whyNoSol = if ee_potential_zero sd then "dc/dt" else "ee" = doStrategies history ( cuspFindingAlgorithms cand history ) cand
= return [ RootFindingLeaf $ NoSolution whyNoSol cand ]
where where
sd = ( eqs t `Seq.index` i ) s sd = eqs $ 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi )
-- Run a round of cusp finding strategies, then recur. -- Run a round of cusp finding strategies, then recur.
doStrategies doStrategies
@ -1548,26 +1459,26 @@ findCuspsFrom
-> Box -> Box
-> Writer ( [ Box ], [ Box ] ) -> Writer ( [ Box ], [ Box ] )
[ RootFindingTree Box ] [ RootFindingTree Box ]
doStrategies hist0 = do_strats [] doStrategies prevRoundsHist = do_strats []
where where
do_strats :: [ ( RootFindingStep, Box ) ] do_strats :: [ ( RootFindingStep, Box ) ]
-> NE.NonEmpty RootFindingAlgorithm -> NE.NonEmpty RootFindingAlgorithm
-> Box -> Box
-> Writer ( [ Box ], [ Box ] ) -> Writer ( [ Box ], [ Box ] )
[ RootFindingTree Box ] [ RootFindingTree Box ]
do_strats stratsHist ( algo NE.:| algos ) box = do do_strats thisRoundHist ( algo NE.:| algos ) box = do
-- Run one strategy in the round. -- Run one strategy in the round.
( step, boxes ) <- doStrategy stratsHist hist0 eqs minWidth algo box ( step, boxes ) <- doStrategy thisRoundHist prevRoundsHist eqs minWidth algo box
case algos of case algos of
-- If there are other algorithms to run in this round, run them next. -- If there are other algorithms to run in this round, run them next.
nextAlgo : otherAlgos -> nextAlgo : otherAlgos ->
let stratsHist' = ( step, box ) : stratsHist let thisRoundHist' = ( step, box ) : thisRoundHist
in recur step ( do_strats stratsHist' ( nextAlgo NE.:| otherAlgos ) ) boxes in recur step ( do_strats thisRoundHist' ( nextAlgo NE.:| otherAlgos ) ) boxes
-- Otherwise, we have done one full round of strategies. -- Otherwise, we have done one full round of strategies.
-- Recur back to the top (calling 'go'). -- Recur back to the top (calling 'go').
[] -> [] ->
let stratsHist' = ( step, box ) NE.:| stratsHist let thisRoundHist' = ( step, box ) NE.:| thisRoundHist
history = stratsHist' : hist0 history = thisRoundHist' : prevRoundsHist
in recur step ( go history ) boxes in recur step ( go history ) boxes
recur :: RootFindingStep recur :: RootFindingStep
@ -1583,7 +1494,7 @@ findCuspsFrom
-- (hopefully smaller) output boxes. -- (hopefully smaller) output boxes.
doStrategy :: [ ( RootFindingStep, Box ) ] doStrategy :: [ ( RootFindingStep, Box ) ]
-> BoxHistory -> BoxHistory
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) -> ( 𝕀ℝ 2 -> StrokeDatum 3 𝕀 )
-> Double -> Double
-> RootFindingAlgorithm -> RootFindingAlgorithm
-> Box -> Box
@ -1612,24 +1523,17 @@ bisect :: ( Box -> Bool )
-> Box -> Box
-> ( [ Box ], ( String, Double ) ) -> ( [ Box ], ( String, Double ) )
bisect canHaveSols ( dim, why ) bisect canHaveSols ( dim, why )
( t@( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) ) ( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
, i
, s@( 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
)
-- We try to bisect along a dimension which eliminates zeros from one of the -- We try to bisect along a dimension which eliminates zeros from one of the
-- sub-regions. -- sub-regions.
-- --
-- If this fails, we fall-back to the provided dimension choice. -- If this fails, we fall-back to the provided dimension choice.
= let t_mid = 0.5 * ( t_lo + t_hi ) = let t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi ) s_mid = 0.5 * ( s_lo + s_hi )
l_t = 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_mid ) l = 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_mid s_hi )
r_t = 𝕀 ( ℝ1 t_mid ) ( ℝ1 t_hi ) r = 𝕀 ( ℝ2 t_mid s_lo ) ( ℝ2 t_hi s_hi )
d_s = 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_mid ) d = 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_mid )
u_s = 𝕀 ( ℝ1 s_mid ) ( ℝ1 s_hi ) u = 𝕀 ( ℝ2 t_lo s_mid ) ( ℝ2 t_hi s_hi )
l = ( l_t, i, s )
r = ( r_t, i, s )
d = ( t , i, d_s )
u = ( t , i, u_s )
l_skip = not $ canHaveSols l l_skip = not $ canHaveSols l
r_skip = not $ canHaveSols r r_skip = not $ canHaveSols r
d_skip = not $ canHaveSols d d_skip = not $ canHaveSols d
@ -1660,24 +1564,21 @@ bisect canHaveSols ( dim, why )
-- | Interval Newton method with Gauss–Seidel step. -- | Interval Newton method with Gauss–Seidel step.
intervalGaussSeidel intervalGaussSeidel
:: ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) :: ( 𝕀ℝ 2 -> StrokeDatum 3 𝕀 )
-- ^ equations -- ^ equations
-> Preconditioner -> Preconditioner
-- ^ preconditioner to use for the Gauss–Seidel step -- ^ preconditioner to use for the Gauss–Seidel step
-> Box -> 𝕀ℝ 2
-> Writer ( [ Box ], [ Box ] ) [ Box ] -> Writer ( [ 𝕀ℝ 2 ], [ 𝕀ℝ 2 ] ) [ 𝕀ℝ 2 ]
intervalGaussSeidel intervalGaussSeidel
eqs eqs
precondMethod precondMethod
( t@( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) ) ts@( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
, i
, s@( 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
)
| StrokeDatum { 𝛿E𝛿sdcdt = D12 _ ( T ( T f_t ) ) ( T ( T f_s ) ) } | StrokeDatum { 𝛿E𝛿sdcdt = D12 _ ( T ( T f_t ) ) ( T ( T f_s ) ) }
<- ( eqs t `Seq.index` i ) s <- eqs ts
, StrokeDatum { ee = D22 _ee_mid _ _ _ _ _ , StrokeDatum { ee = D22 _ee_mid _ _ _ _ _
, 𝛿E𝛿sdcdt = D12 ( T f_mid ) ( T ( T _f_t_mid ) ) ( T ( T _f_s_mid ) ) } , 𝛿E𝛿sdcdt = D12 ( T f_mid ) ( T ( T _f_t_mid ) ) ( T ( T _f_s_mid ) ) }
<- ( eqs i_t_mid `Seq.index` i ) i_s_mid <- eqs ts_mid
= let -- Interval Newton method: take one Gauss–Seidel step = let -- Interval Newton method: take one Gauss–Seidel step
-- for the equation f'(x) v = - f(x_mid), -- for the equation f'(x) v = - f(x_mid),
-- where f = 𝛿E/𝛿s * dc/dt -- where f = 𝛿E/𝛿s * dc/dt
@ -1697,9 +1598,7 @@ intervalGaussSeidel
-- , neg $ 𝕀 (ℝ2 fx_lo ee_lo) (ℝ2 fx_hi ee_hi) -- , neg $ 𝕀 (ℝ2 fx_lo ee_lo) (ℝ2 fx_hi ee_hi)
-- ) -- )
gsGuesses = gaussSeidel a b gsGuesses = gaussSeidel a b ( unT $ T ts ^-^ T ts_mid )
( coerce ( (-) @( 𝕀 Double ) ) t i_t_mid
, coerce ( (-) @( 𝕀 Double ) ) s i_s_mid )
in in
-- If the Gauss–Seidel step was a contraction, then the box -- If the Gauss–Seidel step was a contraction, then the box
-- contains a unique solution (by the Banach fixed point theorem). -- contains a unique solution (by the Banach fixed point theorem).
@ -1713,11 +1612,8 @@ intervalGaussSeidel
where where
t_mid = 0.5 * ( t_lo + t_hi ) t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi ) s_mid = 0.5 * ( s_lo + s_hi )
i_t_mid = singleton ( ℝ1 t_mid ) ts_mid = singleton ( ℝ2 t_mid s_mid )
i_s_mid = singleton ( ℝ1 s_mid ) mkGuess ts_g = unT $ T ts_g ^+^ T ts_mid
mkGuess ( t0, s0 ) = ( coerce ( (+) @( 𝕀 Double ) ) t0 i_t_mid
, i
, coerce ( (+) @( 𝕀 Double ) ) s0 i_s_mid )
neg ( 𝕀 ( ℝ2 x_lo y_lo ) ( ℝ2 x_hi y_hi ) ) neg ( 𝕀 ( ℝ2 x_lo y_lo ) ( ℝ2 x_hi y_hi ) )
= let !( 𝕀 x'_lo x'_hi ) = negate $ 𝕀 x_lo x_hi = let !( 𝕀 x'_lo x'_hi ) = negate $ 𝕀 x_lo x_hi
!( 𝕀 y'_lo y'_hi ) = negate $ 𝕀 y_lo y_hi !( 𝕀 y'_lo y'_hi ) = negate $ 𝕀 y_lo y_hi
@ -1729,7 +1625,7 @@ intervalGaussSeidel
-- See also -- See also
-- "Presentation of a highly tuned multithreaded interval solver for underdetermined and well-determined nonlinear systems" -- "Presentation of a highly tuned multithreaded interval solver for underdetermined and well-determined nonlinear systems"
makeBox1Consistent makeBox1Consistent
:: ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) :: ( 𝕀ℝ 2 -> StrokeDatum 3 𝕀 )
-> Double -> Double -> Double -> Double
-> Box -> [ Box ] -> Box -> [ Box ]
makeBox1Consistent eqs minWidth epsEq x = makeBox1Consistent eqs minWidth epsEq x =
@ -1739,7 +1635,7 @@ makeBox1Consistent eqs minWidth epsEq x =
-- | An implementation of "bound-consistency" from the paper -- | An implementation of "bound-consistency" from the paper
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems" -- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
makeBox2Consistent makeBox2Consistent
:: ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) :: ( 𝕀ℝ 2 -> StrokeDatum 3 𝕀 )
-> Double -> Double -> Double -> Double -> Double -> Double
-> Box -> Box -> Box -> Box
makeBox2Consistent eqs minWidth epsEq lambdaMin x0 = ( `State.evalState` False ) $ doLoop 0.25 x0 makeBox2Consistent eqs minWidth epsEq lambdaMin x0 = ( `State.evalState` False ) $ doLoop 0.25 x0
@ -1951,7 +1847,7 @@ pipeFunctionsWhileTrue fns = go fns
allNarrowingOperators allNarrowingOperators
:: Double :: Double
-> Double -> Double
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) -> ( 𝕀ℝ 2 -> StrokeDatum 3 𝕀 )
-> [ Box -> State Bool [ Box ] ] -> [ Box -> State Bool [ Box ] ]
allNarrowingOperators eps_eq eps_bis eqs = allNarrowingOperators eps_eq eps_bis eqs =
[ \ cand -> [ \ cand ->
@ -1968,41 +1864,42 @@ allNarrowingOperators eps_eq eps_bis eqs =
[ ( ( get_s, set_s ), ff' ) | ff' <- [ ff'_s, g1g1'_s, g2g2'_s ] ] [ ( ( get_s, set_s ), ff' ) | ff' <- [ ff'_s, g1g1'_s, g2g2'_s ] ]
] ]
where where
ff'_t (t, i, s) = ff'_t ts =
let D22 { _D22_v = 𝕀 ( ℝ1 ee_inf ) ( ℝ1 ee_sup ) let D22 { _D22_v = 𝕀 ( ℝ1 ee_inf ) ( ℝ1 ee_sup )
, _D22_dx = T ( 𝕀 ( ℝ1 ee'_inf ) ( ℝ1 ee'_sup ) ) , _D22_dx = T ( 𝕀 ( ℝ1 ee'_inf ) ( ℝ1 ee'_sup ) )
} = ee $ ( eqs t `Seq.index` i ) s } = ee $ eqs ts
in ( 𝕀 ee_inf ee_sup, 𝕀 ee'_inf ee'_sup ) in ( 𝕀 ee_inf ee_sup, 𝕀 ee'_inf ee'_sup )
ff'_s (t, i, s) = ff'_s ts =
let D22 { _D22_v = 𝕀 ( ℝ1 ee_inf ) ( ℝ1 ee_sup ) let D22 { _D22_v = 𝕀 ( ℝ1 ee_inf ) ( ℝ1 ee_sup )
, _D22_dy = T ( 𝕀 ( ℝ1 ee'_inf ) ( ℝ1 ee'_sup ) ) , _D22_dy = T ( 𝕀 ( ℝ1 ee'_inf ) ( ℝ1 ee'_sup ) )
} = ee $ ( eqs t `Seq.index` i ) s } = ee $ eqs ts
in ( 𝕀 ee_inf ee_sup, 𝕀 ee'_inf ee'_sup ) in ( 𝕀 ee_inf ee_sup, 𝕀 ee'_inf ee'_sup )
g1g1'_t (t, i, s) = g1g1'_t ts =
let D12 { _D12_v = T ( 𝕀 ( ℝ2 x_inf _ ) ( ℝ2 x_sup _ ) ) let D12 { _D12_v = T ( 𝕀 ( ℝ2 x_inf _ ) ( ℝ2 x_sup _ ) )
, _D12_dx = T ( T ( 𝕀 ( ℝ2 x'_inf _ ) ( ℝ2 x'_sup _ ) ) ) , _D12_dx = T ( T ( 𝕀 ( ℝ2 x'_inf _ ) ( ℝ2 x'_sup _ ) ) )
} = 𝛿E𝛿sdcdt $ ( eqs t `Seq.index` i ) s } = 𝛿E𝛿sdcdt $ eqs ts
in ( 𝕀 x_inf x_sup, 𝕀 x'_inf x'_sup ) in ( 𝕀 x_inf x_sup, 𝕀 x'_inf x'_sup )
g1g1'_s (t, i, s) = g1g1'_s ts =
let D12 { _D12_v = T ( 𝕀 ( ℝ2 x_inf _ ) ( ℝ2 x_sup _ ) ) let D12 { _D12_v = T ( 𝕀 ( ℝ2 x_inf _ ) ( ℝ2 x_sup _ ) )
, _D12_dy = T ( T ( 𝕀 ( ℝ2 x'_inf _ ) ( ℝ2 x'_sup _ ) ) ) , _D12_dy = T ( T ( 𝕀 ( ℝ2 x'_inf _ ) ( ℝ2 x'_sup _ ) ) )
} = 𝛿E𝛿sdcdt $ ( eqs t `Seq.index` i ) s } = 𝛿E𝛿sdcdt $ eqs ts
in ( 𝕀 x_inf x_sup, 𝕀 x'_inf x'_sup ) in ( 𝕀 x_inf x_sup, 𝕀 x'_inf x'_sup )
g2g2'_t (t, i, s) = g2g2'_t ts =
let D12 { _D12_v = T ( 𝕀 ( ℝ2 _ y_inf ) ( ℝ2 _ y_sup ) ) let D12 { _D12_v = T ( 𝕀 ( ℝ2 _ y_inf ) ( ℝ2 _ y_sup ) )
, _D12_dx = T ( T ( 𝕀 ( ℝ2 _ y'_inf ) ( ℝ2 _ y'_sup ) ) ) , _D12_dx = T ( T ( 𝕀 ( ℝ2 _ y'_inf ) ( ℝ2 _ y'_sup ) ) )
} = 𝛿E𝛿sdcdt $ ( eqs t `Seq.index` i ) s } = 𝛿E𝛿sdcdt $ eqs ts
in ( 𝕀 y_inf y_sup, 𝕀 y'_inf y'_sup ) in ( 𝕀 y_inf y_sup, 𝕀 y'_inf y'_sup )
g2g2'_s (t, i, s) = g2g2'_s ts =
let D12 { _D12_v = T ( 𝕀 ( ℝ2 _ y_inf ) ( ℝ2 _ y_sup ) ) let D12 { _D12_v = T ( 𝕀 ( ℝ2 _ y_inf ) ( ℝ2 _ y_sup ) )
, _D12_dy = T ( T ( 𝕀 ( ℝ2 _ y'_inf ) ( ℝ2 _ y'_sup ) ) ) , _D12_dy = T ( T ( 𝕀 ( ℝ2 _ y'_inf ) ( ℝ2 _ y'_sup ) ) )
} = 𝛿E𝛿sdcdt $ ( eqs t `Seq.index` i ) s } = 𝛿E𝛿sdcdt $ eqs ts
in ( 𝕀 y_inf y_sup, 𝕀 y'_inf y'_sup ) in ( 𝕀 y_inf y_sup, 𝕀 y'_inf y'_sup )
-- TODO: replace this with Fin n and representable please
get_t, get_s :: Box -> 𝕀 Double get_t, get_s :: Box -> 𝕀 Double
get_t ( 𝕀 ( ℝ1 t_inf ) ( ℝ1 t_sup ), _, _ ) = 𝕀 t_inf t_sup get_t ( 𝕀 ( ℝ2 t_inf _ ) ( ℝ2 t_sup _ ) ) = 𝕀 t_inf t_sup
get_s ( 𝕀 ( ℝ2 _ s_inf ) ( ℝ2 _ s_sup ) ) = 𝕀 s_inf s_sup
set_t, set_s :: 𝕀 Double -> Box -> Box set_t, set_s :: 𝕀 Double -> Box -> Box
set_t ( 𝕀 t_inf t_sup ) ( _, i, s ) = ( 𝕀 ( ℝ1 t_inf ) ( ℝ1 t_sup ), i, s ) set_t ( 𝕀 t_inf t_sup ) ( 𝕀 ( ℝ2 _ s_inf ) ( ℝ2 _ s_sup ) ) = 𝕀 ( ℝ2 t_inf s_inf ) ( ℝ2 t_sup s_sup )
get_s ( _ , _, 𝕀 ( ℝ1 s_inf ) ( ℝ1 s_sup ) ) = 𝕀 s_inf s_sup set_s ( 𝕀 s_inf s_sup ) ( 𝕀 ( ℝ2 t_inf _ ) ( ℝ2 t_sup _ ) ) = 𝕀 ( ℝ2 t_inf s_inf ) ( ℝ2 t_sup s_sup )
set_s ( 𝕀 s_inf s_sup ) ( t, i, _ ) = ( t, i, 𝕀 ( ℝ1 s_inf ) ( ℝ1 s_sup ) )