make cusp-finding algorithm choice more configurable

This commit is contained in:
sheaf 2024-04-03 18:46:08 +02:00
parent a183475985
commit 55470d1f0e
5 changed files with 554 additions and 429 deletions

View file

@ -250,7 +250,8 @@ benchmark cusps
Main.hs
build-depends:
brush-strokes
brush-strokes
, deepseq
type:
exitcode-stdio-1.0

View file

@ -25,7 +25,11 @@ import Data.Coerce
import Data.Foldable
( for_ )
import Data.List
( intercalate )
( intercalate, sortOn )
import Data.Traversable
( for )
import GHC.Clock
( getMonotonicTime )
import GHC.Exts
( Proxy#, proxy# )
import GHC.Generics
@ -43,6 +47,13 @@ import qualified Data.Sequence as Seq
import Data.Tree
( foldTree )
-- deepseq
import Control.DeepSeq
( rnf )
-- gauge
--import qualified Gauge
-- tree-view
import Data.Tree.View
( showTree )
@ -64,11 +75,66 @@ import Math.Ring
--------------------------------------------------------------------------------
{-
main :: IO ()
main = Gauge.defaultMainWith benchConfig
[ Gauge.bgroup "Cusp finding"
[ Gauge.bench testName $ Gauge.nf benchTest benchCase
| benchCase@( TestCase { testName } ) <- benchCases
]
]
benchConfig :: Gauge.Config
benchConfig = Gauge.defaultConfig
{ Gauge.timeLimit = Just 0
, Gauge.minSamples = Nothing
, Gauge.minDuration = 0
}
benchTest :: TestCase -> ()
benchTest ( TestCase { testBrushStroke, testCuspOptions, testStartBoxes } ) =
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
( _, ( dunno, sols ) ) = computeCusps testCuspOptions testStrokeFnI testStartBoxes
in dunno `seq` sols `seq` ()
-}
main :: IO ()
main = do
for_ testCases $ \ testCase@( TestCase { testName, testBrushStroke, testAlgorithmParams, testStartBoxes } ) -> do
putStrLn "Running cusp-finding benchmarks."
testsWithTime <-
for testCases $ \ tst -> do { dt <- benchTestCase tst; return ( tst, dt ) }
let (bestTest, bestTime) = head $ sortOn snd testsWithTime
putStrLn $ unlines
[ replicate 40 '='
, "Best time: " ++ show bestTime ++ "s"
, "Best parameters:"
--, show (testCuspOptions bestTest)
]
benchTestCase :: TestCase -> IO Double
benchTestCase ( TestCase { testName, testBrushStroke, testCuspOptions, testStartBoxes } ) = do
putStrLn $ unlines
[ replicate 40 '='
, "Test case " ++ testName ]
before <- getMonotonicTime
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
( _newtTrees, ( dunno, sols ) ) = computeCusps testCuspOptions testStrokeFnI testStartBoxes
rnf dunno `seq` rnf sols `seq` return ()
after <- getMonotonicTime
let dt = after - before
putStrLn $ unlines
[ " - #sols: " ++ show (length sols)
, " - #dunno: " ++ show (length dunno)
, " - Time elapsed: " ++ show dt ++ "s"
, "" ]
return dt
{-
main :: IO ()
main =
for_ testCases $ \ testCase@( TestCase { testName, testBrushStroke, testCuspOptions, testStartBoxes } ) -> do
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
( newtTrees, ( dunno, sols ) ) = computeCusps testAlgorithmParams testStrokeFnI testStartBoxes
( newtTrees, ( dunno, sols ) ) = computeCusps testCuspOptions testStrokeFnI testStartBoxes
showedTrees = map ( uncurry showIntervalNewtonTree ) newtTrees
testHeader =
[ "", "Test case '" ++ testName ++ "':" ]
@ -84,6 +150,7 @@ main = do
-- logFileMVar <- newMVar "logs/fnData.log"
-- logToFile logFileMVar (unlines logLines)
-- `seq` return ()
-}
testCases :: [ TestCase ]
testCases = benchCases
@ -103,7 +170,12 @@ testCases = benchCases
-}
benchCases :: [ TestCase ]
benchCases = [ ellipseTestCase "full" ( 0, 1 ) pi $ defaultStartBoxes [ 0 .. 3 ] ]
benchCases =
[ ellipseTestCase opts "full" ( 0, 1 ) pi $ defaultStartBoxes [ 0 .. 3 ] ]
where
opts = defaultCuspFindingOptions
--------------------------------------------------------------------------------
@ -117,10 +189,10 @@ data BrushStroke =
data TestCase =
TestCase
{ testName :: String
, testBrushStroke :: BrushStroke
, testAlgorithmParams :: CuspAlgorithmParams
, testStartBoxes :: [ Box ]
{ testName :: String
, testBrushStroke :: BrushStroke
, testCuspOptions :: CuspFindingOptions
, testStartBoxes :: [ Box ]
}
brushStrokeFunctions
@ -176,7 +248,7 @@ take 10 $ Data.List.sortOn ( \ ( _, 1 e, v) -> abs e + norm v ) [ let { v = m
potentialCusp $ eval fI $ mkBox (0.5798, 0.5799) 3 (0.26798, 0.26799)
> True
let nbPotentialSols b = let ( _newtTrees, ( dunno, sols ) ) = intervalNewtonGSFrom NoPreconditioning 1e-7 fI b in length dunno + length sols
let nbPotentialSols b = let ( _newtTrees, ( dunno, sols ) ) = findCuspsFrom NoPreconditioning 1e-7 fI b in length dunno + length sols
nbPotentialSols $ mkBox (0.5798, 0.5799) 3 (0.26798, 0.26799)
1
@ -184,7 +256,7 @@ nbPotentialSols $ mkBox (0.5798, 0.5799) 3 (0.26798, 0.26799)
nbPotentialSols $ mkBox (0.5798, 0.675) 3 (0.26798, 0.26799)
0
let showTrees b = map ( uncurry showIntervalNewtonTree ) $ fst $ intervalNewtonGSFrom NoPreconditioning 1e-7 fI b
let showTrees b = map ( uncurry showIntervalNewtonTree ) $ fst $ findCuspsFrom NoPreconditioning 1e-7 fI b
putStrLn $ unlines $ map Data.Tree.View.showTree $ showTrees $ mkBox (0.5798, 0.675) 3 (0.26798, 0.26799)
@ -390,7 +462,7 @@ maximum [ _y $ sup $ unT $ _D12_v $ dEdsdcdt $ eval fI $ mkBox (t, t) 2 (s, s) |
let showTrees b = map ( uncurry showIntervalNewtonTree ) $ fst $ intervalNewtonGSFrom NoPreconditioning 1e-7 fI b
let showTrees b = map ( uncurry showIntervalNewtonTree ) $ fst $ findCuspsFrom NoPreconditioning 1e-7 fI b
putStrLn $ unlines $ map Data.Tree.View.showTree $ showTrees $ mkBox (0.5486101933245248, 0.5486102071493622) 2 (0.548095036738487, 0.5480952)
@ -408,16 +480,12 @@ showD float = showFFloat (Just 6) float ""
--------------------------------------------------------------------------------
ellipseTestCase :: String -> ( Double, Double ) -> Double -> [ Box ] -> TestCase
ellipseTestCase str k0k1 rot startBoxes =
ellipseTestCase :: CuspFindingOptions -> String -> ( Double, Double ) -> Double -> [ Box ] -> TestCase
ellipseTestCase opts str k0k1 rot startBoxes =
TestCase
{ testName = "ellipse (" ++ str ++ ")"
, testBrushStroke = ellipseBrushStroke k0k1 rot
, testAlgorithmParams =
CuspAlgorithmParams
{ preconditioning = InverseMidJacobian
, maxWidth = 1e-7
}
, testCuspOptions = opts
, testStartBoxes = startBoxes
}
@ -442,11 +510,7 @@ trickyCusp2TestCase =
TestCase
{ testName = "trickyCusp2"
, testBrushStroke = trickyCusp2BrushStroke
, testAlgorithmParams =
CuspAlgorithmParams
{ preconditioning = InverseMidJacobian
, maxWidth = 1e-7
}
, testCuspOptions = defaultCuspFindingOptions
, testStartBoxes = defaultStartBoxes [ 0 .. 3 ]
}
@ -496,13 +560,6 @@ data Point nbParams =
deriving stock Generic
deriving stock instance Show ( nbParams ) => Show ( Point nbParams )
data CuspAlgorithmParams =
CuspAlgorithmParams
{ preconditioning :: !Preconditioner
, maxWidth :: !Double
}
deriving stock Show
type Brush nbParams
= forall {t} k (i :: t)
. DiffInterp k i ( nbParams )
@ -543,14 +600,12 @@ getStrokeFunctions brush sp0 crv =
{-# INLINEABLE getStrokeFunctions #-}
computeCusps
:: CuspAlgorithmParams
:: CuspFindingOptions
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) )
-> [ Box ]
-> ( [ ( Box, IntervalNewtonTree Box ) ], ( [ Box ], [ Box ] ) )
computeCusps params eqs startBoxes =
foldMap
( intervalNewtonGSFrom ( preconditioning params ) ( maxWidth params ) eqs )
startBoxes
-> ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) )
computeCusps cuspOpts eqs startBoxes =
foldMap ( findCuspsFrom cuspOpts eqs ) startBoxes
defaultStartBoxes :: [ Int ] -> [ Box ]
defaultStartBoxes is =
@ -561,8 +616,8 @@ getR1 (1 u) = u
{-
(f, fI) = brushStrokeFunctions $ ellipseBrushStroke (0,1) pi
nbPotentialSols box = let ( _newtTrees, ( dunno, sols ) ) = intervalNewtonGSFrom NoPreconditioning 1e-7 fI box in length dunno + length sols
showTrees box = putStrLn $ unlines $ map Data.Tree.View.showTree $ map ( uncurry showIntervalNewtonTree ) $ fst $ intervalNewtonGSFrom NoPreconditioning 1e-7 fI box
nbPotentialSols box = let ( _newtTrees, ( dunno, sols ) ) = findCuspsFrom NoPreconditioning 1e-7 fI box in length dunno + length sols
showTrees box = putStrLn $ unlines $ map Data.Tree.View.showTree $ map ( uncurry showIntervalNewtonTree ) $ fst $ findCuspsFrom NoPreconditioning 1e-7 fI box
sol_t = 0.5486100729150693796677845183880669025324233347060776339185 :: Double
sol_s = 0.5480950141859386853197594577293968665598143630958601978245 :: Double

View file

@ -19,13 +19,14 @@ module Math.Bezier.Stroke
, brushStrokeData, pathAndUsedParams
-- ** Cusp finding
, Preconditioner(..)
, IntervalNewtonTree(..), showIntervalNewtonTree
, IntervalNewtonStep(..)
, IntervalNewtonLeaf(..)
, RootFindingTree(..), showRootFindingTree
, RootFindingStep(..)
, RootFindingLeaf(..)
, Box
, intervalNewtonGS, intervalNewtonGSFrom, gaussSeidel
, CuspFindingOptions(..), defaultCuspFindingOptions
, RootFindingAlgorithm(..), defaultCuspFindingAlgorithms
, Preconditioner(..)
, findCusps, findCuspsFrom, gaussSeidel
)
where
@ -53,13 +54,11 @@ import Data.List
import Data.List.NonEmpty
( NonEmpty )
import qualified Data.List.NonEmpty as NE
( cons, singleton, unzip )
( NonEmpty(..), cons, last, singleton, unzip )
import Data.Maybe
( fromMaybe, isJust, listToMaybe, mapMaybe )
import Data.Semigroup
( sconcat )
import Data.Traversable
( for )
import GHC.Exts
( newMutVar#, runRW#, inline
, Proxy#, proxy#
@ -263,6 +262,7 @@ computeStrokeOutline ::
)
=> RootSolvingAlgorithm
-> Maybe CuspFindingOptions
-> FitParameters
-> ( ptData -> usedParams )
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
@ -279,7 +279,7 @@ computeStrokeOutline ::
, Seq FitPoint
, [ Cusp ]
)
computeStrokeOutline rootAlgo fitParams ptParams toBrushParams brushFn spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of
computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams brushFn spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of
-- Open brush path with at least one segment.
-- Need to add caps at both ends of the path.
SOpen
@ -381,7 +381,7 @@ computeStrokeOutline rootAlgo fitParams ptParams toBrushParams brushFn spline@(
where
outlineInfo :: ptData -> Curve Open crvData ptData -> OutlineInfo
outlineInfo = inline ( outlineFunction rootAlgo ptParams toBrushParams brushFn )
outlineInfo = inline ( outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brushFn )
outlineFns :: Seq OutlineInfo
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
@ -541,6 +541,7 @@ outlineFunction
, Show ptData, Show brushParams
)
=> RootSolvingAlgorithm
-> Maybe CuspFindingOptions
-> ( ptData -> usedParams )
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
-> ( forall {t} k (i :: t)
@ -553,7 +554,7 @@ outlineFunction
-> ptData
-> Curve Open crvData ptData
-> OutlineInfo
outlineFunction rootAlgo ptParams toBrushParams brushFromParams = \ sp0 crv ->
outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brushFromParams = \ sp0 crv ->
let
usedParams :: C 2 ( 1 ) usedParams
@ -604,10 +605,11 @@ outlineFunction rootAlgo ptParams toBrushParams brushFromParams = \ sp0 crv ->
$ toBrushParams params_t
( newtTrees, ( newtDunno, newtSols ) ) =
intervalNewtonGS
InverseMidJacobian
1e-7
curvesI
case mbCuspOptions of
Just cuspOptions ->
findCusps cuspOptions curvesI
Nothing ->
( [], ( [], [] ) )
showD :: Double -> String
showD float = showFFloat (Just 6) float ""
@ -627,7 +629,7 @@ outlineFunction rootAlgo ptParams toBrushParams brushFromParams = \ sp0 crv ->
]
) ++ "}"
]
showedTrees = map ( uncurry showIntervalNewtonTree ) newtTrees
showedTrees = map ( uncurry showRootFindingTree ) newtTrees
solLines =
[ " #sols: " ++ show (length newtSols)
, "#dunno: " ++ show (length newtDunno)
@ -638,7 +640,7 @@ outlineFunction rootAlgo ptParams toBrushParams brushFromParams = \ sp0 crv ->
logContents = unlines $ functionDataLines ++ treeLines
in trace (unlines solLines) $
in --trace (unlines solLines) $
--logToFile cuspFindingMVar logContents `seq`
OutlineInfo
{ outlineFn = fwdBwd
@ -1032,16 +1034,6 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
where
-- !_ = trace
-- ( unlines
-- [ "solveEnvelopeEquation"
-- , " t: " ++ show _t
-- , " pt: " ++ show path_t
-- , " tgt: " ++ show path'_t
-- , " fwdOffset: " ++ show fwdOffset
-- , " bwdOffset: " ++ show bwdOffset ]
-- ) True
fwdSol = findSolFrom "fwd" fwdOffset
( bwdPt, bwdTgt ) = findSolFrom "bwd" bwdOffset
@ -1278,115 +1270,9 @@ gaussSeidel
return ( ( 𝕀 ( 1 x1'_lo ) ( 1 x1'_hi ), 𝕀 ( 1 x2'_lo ) ( 1 x2'_hi ) )
, sub_x1 && sub_x2 )
{-
gaussSeidel2 :: Int
-> Double
-> Double
-> ( 𝕀 2, 𝕀 2 ) -- ^ columns of \( A \)
-> 𝕀 2 -- ^ \( B \)
-> ( 𝕀 1, 𝕀 1 ) -- ^ initial box \( X \)
-> [ ( ( 𝕀 1, 𝕀 1 ), Bool ) ]
gaussSeidel2 maxIters eps_abs eps_rel
( 𝕀 ( 2 a11_lo a21_lo ) ( 2 a11_hi a21_hi )
, 𝕀 ( 2 a12_lo a22_lo ) ( 2 a12_hi a22_hi ) )
( 𝕀 ( 2 b1_lo b2_lo ) ( 2 b1_hi b2_hi ) )
x0
= let !a11 = 𝕀 a11_lo a11_hi
!a12 = 𝕀 a12_lo a12_hi
!a21 = 𝕀 a21_lo a21_hi
!a22 = 𝕀 a22_lo a22_hi
!b1 = 𝕀 b1_lo b1_hi
!b2 = 𝕀 b2_lo b2_hi
-- See "Algorithm 2" in
-- "Using interval unions to solve linear systems of equations with uncertainties"
iter ( 𝕀 ( 1 x1_lo ) ( 1 x1_hi ), 𝕀 ( 1 x2_lo ) ( 1 x2_hi ) ) = do
let
!x1 = 𝕀 x1_lo x1_hi
!x2 = 𝕀 x2_lo x2_hi
blah1 = do
let s = b1 - a12 * x2
let s1 = s `monus` ( a11 * x1 )
y1 <-
if not $ containsZero ( s1 - a11 * x1 )
then []
else
if containsZero s1 && containsZero a11
then [ ( x1, False ) ]
else do
x1'' <- s1 `extendedDivide` a11
x1'' `intersect` x1
let s2 = s `monus` ( a12 * x2 )
y2 <-
if not $ containsZero ( s2 - a11 * x1 )
then []
else
if containsZero s2 && containsZero a11
then [ ( x1, False ) ]
else do
x1'' <- s2 `extendedDivide` a12
x1'' `intersect` x1
return ( y1 `cart` y2 )
blah2 = do
let s = b2 - a21 * x1
let s1 = s `monus` ( a21 * x1 )
y1 <-
if not $ containsZero ( s1 - a22 * x2 )
then []
else
if containsZero s1 && containsZero a22
then [ ( x1, False ) ]
else do
x1'' <- s1 `extendedDivide` a21
x1'' `intersect` x1
let s2 = s `monus` ( a12 * x2 )
y2 <-
if not $ containsZero ( s2 - a22 * x2 )
then []
else
if containsZero s2 && containsZero a22
then [ ( x1, False ) ]
else do
x1'' <- s2 `extendedDivide` a22
x1'' `intersect` x1
return ( y1 `cart` y2 )
blah1 ++ blah2
go :: Int -> ( 𝕀 1, 𝕀 1 ) -> [ ( ( 𝕀 1, 𝕀 1 ), Bool ) ]
go !i x
= do { nxt@( x', sub ) <- iter x
; let dw_abs = maxWidth x - maxWidth x'
dw_rel = 1 - ( maxWidth x' / maxWidth x )
; if sub
|| i >= maxIters
|| dw_abs < eps_abs
|| dw_rel < eps_rel
then return nxt
else go ( i + 1 ) x'
}
in go 1 x0
where
maxWidth :: ( 𝕀 1, 𝕀 1 ) -> Double
maxWidth ( 𝕀 ( 1 x1_lo ) ( 1 x1_hi ), 𝕀 ( 1 x2_lo ) ( 1 x2_hi ) )
= max ( x1_hi - x1_lo ) ( x2_hi - x2_lo )
containsZero :: 𝕀 Double -> Bool
containsZero ( 𝕀 lo hi ) = lo <= 0 && hi >= 0
monus :: 𝕀 Double -> 𝕀 Double -> 𝕀 Double
monus ( 𝕀 lo1 hi1 ) ( 𝕀 lo2 hi2 )
| hi1 - lo1 >= hi2 - lo2
= 𝕀 ( lo1 - lo2 ) ( hi1 - hi2 )
| otherwise
= 𝕀 ( hi1 - hi2 ) ( lo1 - lo2 )
cart :: ( 𝕀 Double, Bool ) -> ( 𝕀 Double, Bool ) -> ( ( 𝕀 1, 𝕀 1 ), Bool )
cart ( 𝕀 lo1 hi1, sub1 ) ( 𝕀 lo2 hi2, sub2 ) =
( ( 𝕀 ( 1 lo1 ) ( 1 hi1 ), 𝕀 ( 1 lo2 ) ( 1 hi2 ) ), sub1 && sub2 )
-}
-- TODO: try implementing the complete interval union GaussSeidel algorithm.
-- See "Algorithm 2" in
-- "Using interval unions to solve linear systems of equations with uncertainties"
-- | Compute the intersection of two intervals.
--
@ -1404,6 +1290,9 @@ intersect ( 𝕀 lo1 hi1 ) ( 𝕀 lo2 hi2 )
-- | Computes the brush stroke coordinates of a cusp from
-- the @(t,s)@ parameter values.
--
-- TODO: use Newton's method starting at the midpoint of the box,
-- instead of just taking the midpoint of the box.
cuspCoords :: ( 1 -> Seq ( 1 -> StrokeDatum 2 () ) )
-> Box
-> Cusp
@ -1421,42 +1310,45 @@ cuspCoords eqs ( 𝕀 ( 1 t_lo ) ( 1 t_hi ), i, 𝕀 ( 1 s_lo ) ( 1
t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi )
-- | Preconditioner to use with the interval GaussSeidel method.
data Preconditioner
= NoPreconditioning
| InverseMidJacobian
deriving stock Show
-- | A tree recording the steps taken with the interval Newton method.
data IntervalNewtonTree d
= IntervalNewtonLeaf (IntervalNewtonLeaf d)
| IntervalNewtonStep (IntervalNewtonStep d) [(d, IntervalNewtonTree d)]
-- | A tree recording the steps taken when doing cusp finding.
data RootFindingTree d
= RootFindingLeaf (RootFindingLeaf d)
| RootFindingStep RootFindingStep [(d, RootFindingTree d)]
data IntervalNewtonStep d
= IntervalNewtonContraction [d]
| IntervalNewtonBisection (String, Double)
-- | A description of a step taken in cusp-finding.
data RootFindingStep
= GaussSeidelStep
| BisectionStep (String, Double)
| Box1Step
| Box2Step
instance Show d => Show (IntervalNewtonStep d) where
showsPrec _ ( IntervalNewtonContraction v )
= showString "N "
. showsPrec 0 v
showsPrec _ ( IntervalNewtonBisection (coord, w) )
= showString "B "
instance Show RootFindingStep where
showsPrec _ GaussSeidelStep = showString "GS"
showsPrec _ ( BisectionStep (coord, w) )
= showString "bis "
. showParen True
( showString coord
. showString " = "
. showsPrec 0 w
)
showsPrec _ Box1Step = showString "box(1)"
showsPrec _ Box2Step = showString "box(2)"
data IntervalNewtonLeaf d
data RootFindingLeaf d
= TooSmall d
| NoSolution String d
deriving stock Show
showIntervalNewtonTree :: Box -> IntervalNewtonTree Box -> Tree String
showIntervalNewtonTree cand (IntervalNewtonLeaf l) = Node (show cand ++ " " ++ showArea (boxArea cand) ++ " " ++ show l) []
showIntervalNewtonTree cand (IntervalNewtonStep s ts)
= Node (show cand ++ " abc " ++ showArea (boxArea cand) ++ " " ++ show s) $ map (\ (c,t) -> showIntervalNewtonTree c t) ts
showRootFindingTree :: Box -> RootFindingTree Box -> Tree String
showRootFindingTree cand (RootFindingLeaf l) = Node (show cand ++ " " ++ showArea (boxArea cand) ++ " " ++ show l) []
showRootFindingTree cand (RootFindingStep s ts)
= Node (show cand ++ " abc " ++ showArea (boxArea cand) ++ " " ++ show s) $ map (\ (c,t) -> showRootFindingTree c t) ts
boxArea :: Box -> Double
boxArea ( 𝕀 ( 1 t_lo ) ( 1 t_hi ), _, 𝕀 ( 1 s_lo ) ( 1 s_hi ) )
@ -1466,53 +1358,169 @@ showArea :: Double -> [Char]
showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
type Box = ( 𝕀 1, Int, 𝕀 1 )
type BoxHistory = [ NE.NonEmpty ( RootFindingStep, Box ) ]
intervalNewtonGS
:: Preconditioner
-> Double
-- | Options for the cusp-finding methods in 'findCusps' and 'findCuspsFrom'.
data CuspFindingOptions
= CuspFindingOptions
{ -- | Minimum width of a box.
minWidth :: !Double
-- | Given a box and its history, return a round of cusp-finding strategies
-- to run, in sequence, on this box.
, cuspFindingAlgorithms :: !( Box -> BoxHistory -> NonEmpty RootFindingAlgorithm )
}
data RootFindingAlgorithm
-- | GaussSeidel step with the given preconditioning method.
= GaussSeidel GaussSeidelOptions
-- | @box(1)@-consistency.
| Box1 Box1Options
-- | @box(2)@-consistency.
| Box2 Box2Options
-- | Bisection step.
| Bisection BisectionOptions
-- | Options for the interval GaussSeidel method.
data GaussSeidelOptions = GaussSeidelOptions { gsPreconditioner :: Preconditioner }
-- | Options for the @box(1)@-consistency method.
data Box1Options = Box1Options { box1EpsEq :: !Double }
-- | Options for the @box(2)@-consistency method.
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
{ minWidth
, cuspFindingAlgorithms = defaultCuspFindingAlgorithms minWidth 5e-3
}
where
minWidth = 1e-5
defaultCuspFindingAlgorithms :: Double -> Double -> Box -> BoxHistory -> NonEmpty RootFindingAlgorithm
defaultCuspFindingAlgorithms minWidth narrowAbs box history =
case history of
lastRoundBoxes : _
-- If, in the last round of strategies, we didn't try bisection...
| any ( \case { BisectionStep {} -> False; _ -> True } . fst ) lastRoundBoxes
, (_, lastRoundFirstBox ) <- NE.last lastRoundBoxes
-- ...and the last round didn't sufficiently reduce the size of the box...
, not $ box `sufficientlySmallerThan` lastRoundFirstBox
-- ...then try bisecting the box.
-> Bisection ( defaultBisectionOptions minWidth narrowAbs box ) NE.:| []
-- Otherwise, do a normal round: try an interval GaussSeidel step followed by box(1)-consistency.
_ -> GaussSeidel defaultGaussSeidelOptions
NE.:| [ Box1 ( Box1Options { box1EpsEq = narrowAbs } ) ]
where
sufficientlySmallerThan :: Box -> Box -> Bool
sufficientlySmallerThan ( t1, _, s1 ) ( t2, _, s2 ) =
( wd t1 - wd t2 > narrowAbs )
||
( wd s1 - wd s2 > narrowAbs )
wd :: 𝕀 1 -> Double
wd ( 𝕀 ( 1 lo ) ( 1 hi ) ) = hi - lo
defaultGaussSeidelOptions :: GaussSeidelOptions
defaultGaussSeidelOptions = GaussSeidelOptions { gsPreconditioner = InverseMidJacobian }
defaultBisectionOptions :: Double -> Double -> Box -> BisectionOptions
defaultBisectionOptions
_minWidth
_narrowAbs
( t@( 𝕀 ( 1 t_lo ) ( 1 t_hi ) )
, i
, s@( 𝕀 ( 1 s_lo ) ( 1 s_hi ) )
)
= BisectionOptions
{ canHaveSols =
\ eqs _box'@( _t', _i', _s' ) ->
-- box(0)-consistency
let dat' = ( eqs _t' `Seq.index` _i' ) _s'
in ee_potential_zero dat' && 𝛿E𝛿sdcdt_potential_zero dat'
-- box(1)-consistency
--not $ null $ makeBox1Consistent eqs _minWidth _narrowAbs _box'
-- box(2)-consistency
--let ( t'', i'', s'') = makeBox2Consistent eqs _minWidth _narrowAbs 0.2 _box'
-- dat'' = ( eqs t'' `Seq.index` i'' ) s''
--in ee_potential_zero dat'' && 𝛿E𝛿sdcdt_potential_zero dat''
, fallbackBisectionDim =
\ _roundHist _prevRoundsHist eqs ->
let StrokeDatum { ee = D22 _ ( T ee_t ) (T ee_s ) _ _ _
, 𝛿E𝛿sdcdt = D12 _ ( T ( T f_t ) ) ( T ( T f_s ) ) }
= ( eqs t `Seq.index` i ) s
wd_t = t_hi - t_lo
wd_s = s_hi - s_lo
tJWidth = wd_t * normVI3 ee_t f_t
sJWidth = wd_s * normVI3 ee_s f_s
in if tJWidth >= sJWidth
-- bisect along dimension that maximises width(x_j) * || J_j || ...
-- ... but don't allow thin boxes
|| ( wd_t >= 10 * wd_s )
&& not ( wd_s >= 10 * wd_t )
then (0, "")
else (1, "")
}
-- | Find cusps in the envelope for values of the parameters in
-- \( 0 \leqslant t, s \leqslant 1 \), using interval arithmetic.
--
-- See 'findCuspsFrom' for details.
findCusps
:: CuspFindingOptions
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) )
-> ( [ ( Box, IntervalNewtonTree Box ) ], ( [ Box ], [ Box ] ) )
intervalNewtonGS precondMethod minWidth eqs =
foldMap
( intervalNewtonGSFrom precondMethod minWidth eqs )
initBoxes
-> ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) )
findCusps opts eqs = foldMap ( findCuspsFrom opts eqs ) initBoxes
where
initBoxes =
[ ( 𝕀 ( 1 zero ) ( 1 one ), i, 𝕀 ( 1 zero ) ( 1 one ) )
| i <- [ 0 .. length ( eqs ( 𝕀 ( 1 zero ) ( 1 one ) ) ) - 1 ]
]
-- | Interval Newton method with GaussSeidel step for inversion
-- of the interval Jacobian.
-- | Use the following algorithms using interal arithmetic in order
-- to find cusps in the envelope:
--
-- - interval Newton method with GaussSeidel step for inversion
-- of the interval Jacobian,
-- - coordinate-wise Newton method (@box(1)@-consistency algorithm),
-- - @box(2)@-consistency algorithm,
-- - bisection.
--
-- Returns @(tree, (dunno, sols))@ where @tree@ is the full tree (useful for debugging),
-- @sols@ are boxes that contain a unique solution (and to which Newton's method
-- will converge starting from anywhere inside the box), and @dunno@ are small
-- boxes which might or might not contain solutions.
intervalNewtonGSFrom
:: Preconditioner
-> Double
findCuspsFrom
:: CuspFindingOptions
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) )
-> Box
-> ( [ ( Box, IntervalNewtonTree Box ) ], ( [ Box ], [ Box ] ) )
intervalNewtonGSFrom precondMethod minWidth eqs initBox =
runWriter $
map ( initBox , ) <$> go initBox
-> ( [ ( Box, RootFindingTree Box ) ], ( [ Box ], [ Box ] ) )
findCuspsFrom
( CuspFindingOptions
{ minWidth
, cuspFindingAlgorithms
}
)
eqs initBox = runWriter $ map ( initBox , ) <$> go [] initBox
where
recur :: ( cand -> Writer ( [ Box ], [ Box ] ) [ IntervalNewtonTree Box ] )
-> ( [ ( cand, IntervalNewtonTree Box ) ] -> IntervalNewtonTree Box )
-> [ cand ]
-> Writer ( [Box], [Box] ) [ IntervalNewtonTree Box ]
recur r f cands = do
rest <- traverse ( \ c -> do { trees <- r c; return [ (c, tree) | tree <- trees ] } ) cands
return [ f $ concat rest ]
go :: Box -- box to work on
go :: BoxHistory
-> Box -- box to work on
-> Writer ( [ Box ], [ Box ] )
[ IntervalNewtonTree Box ]
go cand@( t@( 𝕀 ( 1 t_lo ) ( 1 t_hi ) )
[ RootFindingTree Box ]
go history
cand@( t@( 𝕀 ( 1 t_lo ) ( 1 t_hi ) )
, i
, s@( 𝕀 ( 1 s_lo ) ( 1 s_hi ) )
)
@ -1520,212 +1528,251 @@ intervalNewtonGSFrom precondMethod minWidth eqs initBox =
| t_hi - t_lo < minWidth && s_hi - s_lo < minWidth
= do let res = TooSmall cand
tell ( [ cand ], [] )
return [ IntervalNewtonLeaf 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
= continue cand
= doStrategies history ( cuspFindingAlgorithms cand history ) cand
-- Box doesn't contain a solution: discard it.
| otherwise
= return [ IntervalNewtonLeaf $ NoSolution ( if ee_potential_zero sd then "dc/dt" else "ee" ) cand ]
, let whyNoSol = if ee_potential_zero sd then "dc/dt" else "ee"
= return [ RootFindingLeaf $ NoSolution whyNoSol cand ]
where
sd = ( eqs t `Seq.index` i ) s
continue :: Box
-> Writer ( [ Box ], [ Box ] )
[ IntervalNewtonTree Box ]
continue
cand@( t@( 𝕀 ( 1 t_lo ) ( 1 t_hi ) )
, i
, s@( 𝕀 ( 1 s_lo ) ( 1 s_hi ) )
)
| StrokeDatum { ee = D22 _ ( T ee_t ) (T ee_s ) _ _ _
, 𝛿E𝛿sdcdt = D12 _ ( T ( T f_t ) ) ( T ( T f_s ) ) }
<- ( eqs t `Seq.index` i ) s
, StrokeDatum { ee = D22 _ee_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
= let -- Interval Newton method: take one GaussSeidel step
-- for the equation f'(x) v = - f(x_mid),
-- where f = 𝛿E/𝛿s * dc/dt
!( a, b ) = precondition precondMethod
( midI f_t, midI f_s )
( f_t, f_s ) ( neg f_mid )
--(a, b)
-- | 𝕀 (1 ee_lo) (1 ee_hi) <- ee_mid
-- , 𝕀 (1 ee_t_lo) (1 ee_t_hi) <- ee_t
-- , 𝕀 (1 ee_s_lo) (1 ee_s_hi) <- ee_s
-- , 𝕀 (2 fx_lo fy_lo) (2 fx_hi fy_hi) <- f_mid
-- , 𝕀 (2 f_tx_lo f_ty_lo) (2 f_tx_hi f_ty_hi) <- f_t
-- , 𝕀 (2 f_sx_lo f_sy_lo) (2 f_sx_hi f_sy_hi) <- f_s
-- = ( ( 𝕀 (2 f_tx_lo ee_t_lo) (2 f_tx_hi ee_t_hi)
-- , 𝕀 (2 f_sx_lo ee_s_lo) (2 f_sx_hi ee_s_hi)
-- )
-- , neg $ 𝕀 (2 fx_lo ee_lo) (2 fx_hi ee_hi)
-- )
!gsGuesses = gaussSeidel a b
( coerce ( (-) @( 𝕀 Double ) ) t i_t_mid
, coerce ( (-) @( 𝕀 Double ) ) s i_s_mid )
in if any ( smaller . fst ) gsGuesses
then
-- If the GaussSeidel step was a contraction, then the box
-- contains a unique solution (by the Banach fixed point theorem).
--
-- These boxes can thus be directly added to the solution set:
-- Newton's method is guaranteed to converge to the unique solution.
let !(done, todo) = bimap ( map ( mkGuess . fst ) ) ( map ( mkGuess . fst ) )
$ partition snd gsGuesses
in do tell ([], done)
case todo of
[] -> return [ IntervalNewtonLeaf $ NoSolution "GaussSeidel" cand ]
_ -> recur go ( IntervalNewtonStep ( IntervalNewtonContraction done ) )
todo
else
-- GaussSeidel failed to shrink the boxes, so bisect instead.
-- We have to pick along which dimension to bisect:
-- - if bisecting along a particular dimension discards one of
-- the boxes, do that;
-- - otherwise, bisect along the dimension j that maximises
-- width(x_j) * || J_j ||.
let l_t = 𝕀 ( 1 t_lo ) ( 1 t_mid )
r_t = 𝕀 ( 1 t_mid ) ( 1 t_hi )
d_s = 𝕀 ( 1 s_lo ) ( 1 s_mid )
u_s = 𝕀 ( 1 s_mid ) ( 1 s_hi )
l = ( l_t, i, s )
r = ( r_t, i, s )
d = ( t, i, d_s )
u = ( t, i, u_s )
l_dat = ( eqs l_t `Seq.index` i ) s
r_dat = ( eqs r_t `Seq.index` i ) s
d_dat = ( eqs t `Seq.index` i ) d_s
u_dat = ( eqs t `Seq.index` i ) u_s
l_skip =
not ( ee_potential_zero l_dat )
|| not ( 𝛿E𝛿sdcdt_potential_zero l_dat )
r_skip =
not ( ee_potential_zero r_dat )
|| not ( 𝛿E𝛿sdcdt_potential_zero r_dat )
d_skip =
not ( ee_potential_zero d_dat )
|| not ( 𝛿E𝛿sdcdt_potential_zero d_dat )
u_skip =
not ( ee_potential_zero u_dat )
|| not ( 𝛿E𝛿sdcdt_potential_zero u_dat )
tJWidth = ( t_hi - t_lo ) * normVI3 ee_t f_t
sJWidth = ( s_hi - s_lo ) * normVI3 ee_s f_s
( bisGuesses, whatBis )
| l_skip && r_skip
= ( [], ( "lr", t_mid ) )
| d_skip && u_skip
= ( [], ( "du", s_mid ) )
| l_skip
= ( [ r ], ( "r", t_mid ) )
| r_skip
= ( [ l ], ( "l", t_mid ) )
| d_skip
= ( [ u ], ( "u", s_mid ) )
| u_skip
= ( [ d ], ( "d", s_mid ) )
| tJWidth >= sJWidth
-- ... but don't allow thin boxes.
|| ( t_hi - t_lo >= 10 * ( s_hi - s_lo ) )
&& not ( s_hi - s_lo >= 10 * ( t_hi - t_lo ) )
= ( [ l, r ], ( "t", t_mid ) )
| otherwise
= ( [ d, u ], ( "s", s_mid ) )
in recur go ( IntervalNewtonStep ( IntervalNewtonBisection whatBis ) )
( doStrategy =<< bisGuesses )
-- Run a round of cusp finding strategies, then recur.
doStrategies
:: BoxHistory
-> NonEmpty RootFindingAlgorithm
-> Box
-> Writer ( [ Box ], [ Box ] )
[ RootFindingTree Box ]
doStrategies hist0 = do_strats []
where
t_mid = 0.5 * ( t_lo + t_hi )
do_strats :: [ ( RootFindingStep, Box ) ]
-> NE.NonEmpty RootFindingAlgorithm
-> Box
-> Writer ( [ Box ], [ Box ] )
[ RootFindingTree Box ]
do_strats stratsHist ( algo NE.:| algos ) box = do
-- Run one strategy in the round.
( step, boxes ) <- doStrategy stratsHist hist0 eqs minWidth algo box
case algos of
-- If there are other algorithms to run in this round, run them next.
nextAlgo : otherAlgos ->
let stratsHist' = ( step, box ) : stratsHist
in recur step ( do_strats stratsHist' ( nextAlgo NE.:| otherAlgos ) ) boxes
-- Otherwise, we have done one full round of strategies.
-- Recur back to the top (calling 'go').
[] ->
let stratsHist' = ( step, box ) NE.:| stratsHist
history = stratsHist' : hist0
in recur step ( go history ) boxes
recur :: RootFindingStep
-> ( Box -> Writer ( [ Box ], [ Box ] ) [ RootFindingTree Box ] )
-> [ Box ]
-> Writer ( [Box], [Box] ) [ RootFindingTree Box ]
recur step r cands = do
rest <- traverse ( \ c -> do { trees <- r c; return [ (c, tree) | tree <- trees ] } ) cands
return [ RootFindingStep step $ concat rest ]
-- | Execute a cusp-finding strategy, replacing the input box with
-- (hopefully smaller) output boxes.
doStrategy :: [ ( RootFindingStep, Box ) ]
-> BoxHistory
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) )
-> Double
-> RootFindingAlgorithm
-> Box
-> Writer ( [ Box ], [ Box ] )
( RootFindingStep, [ Box ] )
doStrategy roundHistory previousRoundsHistory eqs minWidth algo box =
case algo of
GaussSeidel ( GaussSeidelOptions { gsPreconditioner } ) -> do
boxes <- intervalGaussSeidel eqs gsPreconditioner box
return ( GaussSeidelStep, boxes )
Box1 ( Box1Options { box1EpsEq } ) ->
return ( Box1Step, makeBox1Consistent eqs minWidth box1EpsEq box )
Box2 ( Box2Options { box2LambdaMin, box2EpsEq } ) ->
return ( Box2Step, [ makeBox2Consistent eqs minWidth box2EpsEq box2LambdaMin box ] )
Bisection ( BisectionOptions { canHaveSols, fallbackBisectionDim } ) -> do
let ( boxes, whatBis ) = bisect ( canHaveSols eqs ) ( fallbackBisectionDim roundHistory previousRoundsHistory eqs ) box
return ( BisectionStep whatBis, boxes )
-- | Bisect the given box.
--
-- (The difficult part lies in determining along which dimension to bisect.)
bisect :: ( Box -> Bool )
-- ^ how to check whether a box contains solutions
-> ( Int, String )
-- ^ fall-back choice of dimension (and "why" we chose it)
-> Box
-> ( [ Box ], ( String, Double ) )
bisect canHaveSols ( dim, why )
( t@( 𝕀 ( 1 t_lo ) ( 1 t_hi ) )
, i
, s@( 𝕀 ( 1 s_lo ) ( 1 s_hi ) )
)
-- We try to bisect along a dimension which eliminates zeros from one of the
-- sub-regions.
--
-- If this fails, we fall-back to the provided dimension choice.
= let t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi )
i_t_mid = singleton ( 1 t_mid )
i_s_mid = singleton ( 1 s_mid )
mkGuess ( t0, s0 ) = ( coerce ( (+) @( 𝕀 Double ) ) t0 i_t_mid
, i
, coerce ( (+) @( 𝕀 Double ) ) s0 i_s_mid )
smaller ( 𝕀 ( 1 t0_lo ) ( 1 t0_hi ), 𝕀 ( 1 s0_lo ) ( 1 s0_hi ) )
= ( t0_lo + t_mid ) > t_lo + 0.25 * minWidth
|| ( t0_hi + t_mid ) < t_hi - 0.25 * minWidth
|| ( s0_lo + s_mid ) > s_lo + 0.25 * minWidth
|| ( s0_hi + s_mid ) < s_hi - 0.25 * minWidth
neg ( 𝕀 ( 2 x_lo y_lo ) ( 2 x_hi y_hi ) )
= let !( 𝕀 x'_lo x'_hi ) = negate $ 𝕀 x_lo x_hi
!( 𝕀 y'_lo y'_hi ) = negate $ 𝕀 y_lo y_hi
in 𝕀 ( 2 x'_lo y'_lo ) ( 2 x'_hi y'_hi )
l_t = 𝕀 ( 1 t_lo ) ( 1 t_mid )
r_t = 𝕀 ( 1 t_mid ) ( 1 t_hi )
d_s = 𝕀 ( 1 s_lo ) ( 1 s_mid )
u_s = 𝕀 ( 1 s_mid ) ( 1 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
r_skip = not $ canHaveSols r
d_skip = not $ canHaveSols d
u_skip = not $ canHaveSols u
-- Attempting to implement Algorithm 6 "Heuristic to apply bound-consistency"
-- from the paper
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
doStrategy box@( 𝕀 ( 1 t_lo ) ( 1 t_hi ), _, 𝕀 ( 1 s_lo ) ( 1 s_hi ) )
| eps_box1 > eps_box2
= if | w_t > ebs_box1 || w_s > ebs_box1
-> makeBox1Consistent box
| w_t > ebs_box2 || w_s > ebs_box2
-> [ makeBox2Consistent box ]
| otherwise
-> [ box ]
| otherwise
= if | w_t > ebs_box2 || w_s > ebs_box2
-> [ makeBox2Consistent box ]
| w_t > ebs_box1 || w_s > ebs_box1
-> makeBox1Consistent box
| otherwise
-> [ box ]
where
eps_box1 = 0.4
eps_box2 = 0.1
w_t = t_hi - t_lo
w_s = s_hi - s_lo
( bisGuesses, whatBis )
| l_skip && r_skip
= ( [], ( "lr", t_mid ) )
| d_skip && u_skip
= ( [], ( "du", s_mid ) )
| l_skip
= ( [ r ], ( "r", t_mid ) )
| r_skip
= ( [ l ], ( "l", t_mid ) )
| d_skip
= ( [ u ], ( "u", s_mid ) )
| u_skip
= ( [ d ], ( "d", s_mid ) )
| otherwise
= let why' = case why of
"" -> ""
_ -> " (" ++ why ++ ")"
in case dim of
0 -> ( [ l, r ], ( "t" ++ why', t_mid ) )
1 -> ( [ d, u ], ( "s" ++ why', s_mid ) )
_ -> error "bisect: fall-back bisection dimension should be either 0 or 1"
in ( bisGuesses, whatBis )
-- An implementation of "bound-consistency" from the paper
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
makeBox2Consistent :: Box -> Box
makeBox2Consistent x = ( `State.evalState` False ) $ doLoop 0.25 x
where
doLoop :: Double -> Box -> State Bool Box
doLoop lambda x = do
x' <- boundConsistency get_t set_t lambda x
x'' <- boundConsistency get_s set_s lambda x'
modified <- State.get
let lambda' = if modified then lambda else 0.5 * lambda
if lambda' < 0.001
then return x''
else do { State.put False ; doLoop lambda' x'' }
-- | Interval Newton method with GaussSeidel step.
intervalGaussSeidel
:: ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) )
-- ^ equations
-> Preconditioner
-- ^ preconditioner to use for the GaussSeidel step
-> Box
-> Writer ( [ Box ], [ Box ] ) [ Box ]
intervalGaussSeidel
eqs
precondMethod
( t@( 𝕀 ( 1 t_lo ) ( 1 t_hi ) )
, i
, s@( 𝕀 ( 1 s_lo ) ( 1 s_hi ) )
)
| StrokeDatum { 𝛿E𝛿sdcdt = D12 _ ( T ( T f_t ) ) ( T ( T f_s ) ) }
<- ( eqs t `Seq.index` i ) s
, StrokeDatum { ee = D22 _ee_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
= let -- Interval Newton method: take one GaussSeidel step
-- for the equation f'(x) v = - f(x_mid),
-- where f = 𝛿E/𝛿s * dc/dt
( a, b ) = precondition precondMethod
( midI f_t, midI f_s )
( f_t, f_s ) ( neg f_mid )
--(a, b)
-- | 𝕀 (1 ee_lo) (1 ee_hi) <- ee_mid
-- , 𝕀 (1 ee_t_lo) (1 ee_t_hi) <- ee_t
-- , 𝕀 (1 ee_s_lo) (1 ee_s_hi) <- ee_s
-- , 𝕀 (2 fx_lo fy_lo) (2 fx_hi fy_hi) <- f_mid
-- , 𝕀 (2 f_tx_lo f_ty_lo) (2 f_tx_hi f_ty_hi) <- f_t
-- , 𝕀 (2 f_sx_lo f_sy_lo) (2 f_sx_hi f_sy_hi) <- f_s
-- = ( ( 𝕀 (2 f_tx_lo ee_t_lo) (2 f_tx_hi ee_t_hi)
-- , 𝕀 (2 f_sx_lo ee_s_lo) (2 f_sx_hi ee_s_hi)
-- )
-- , neg $ 𝕀 (2 fx_lo ee_lo) (2 fx_hi ee_hi)
-- )
boundConsistency :: ( Box -> 𝕀 Double )
-> ( 𝕀 Double -> Box -> Box )
-> Double -> Box -> State Bool Box
boundConsistency getter setter lambda box = do
let x@( 𝕀 x_inf x_sup ) = getter box
c1 = ( 1 - lambda ) * x_inf + lambda * x_sup
c2 = lambda * x_inf + ( 1 - lambda ) * x_sup
x'_inf =
case makeBox1Consistent ( setter ( 𝕀 x_inf c1 ) box ) of
[] -> c1
x's -> minimum $ map ( inf . getter ) x's
x'_sup =
case makeBox1Consistent ( setter ( 𝕀 c2 x_sup ) box ) of
[] -> c2
x's -> maximum $ map ( sup . getter ) x's
x' = 𝕀 x'_inf x'_sup
when ( width x - width x' >= eps_eq ) $
State.put True
return $ setter x' box
gsGuesses = gaussSeidel a b
( coerce ( (-) @( 𝕀 Double ) ) t i_t_mid
, coerce ( (-) @( 𝕀 Double ) ) s i_s_mid )
in
-- If the GaussSeidel step was a contraction, then the box
-- contains a unique solution (by the Banach fixed point theorem).
--
-- These boxes can thus be directly added to the solution set:
-- Newton's method is guaranteed to converge to the unique solution.
let !(done, todo) = bimap ( map ( mkGuess . fst ) ) ( map ( mkGuess . fst ) )
$ partition snd gsGuesses
in do tell ([], done)
return todo
where
t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi )
i_t_mid = singleton ( 1 t_mid )
i_s_mid = singleton ( 1 s_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 ) )
= let !( 𝕀 x'_lo x'_hi ) = negate $ 𝕀 x_lo x_hi
!( 𝕀 y'_lo y'_hi ) = negate $ 𝕀 y_lo y_hi
in 𝕀 ( 2 x'_lo y'_lo ) ( 2 x'_hi y'_hi )
-- An implementation of "bc_enforce" from the paper
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
--
-- See also
-- "Presentation of a highly tuned multithreaded interval solver for underdetermined and well-determined nonlinear systems"
makeBox1Consistent :: Box -> [ Box ]
makeBox1Consistent x =
( `State.evalState` False ) $
pipeFunctionsWhileTrue (allNarrowingOperators eps_eq eps_bis eqs) x
eps_eq = 1e-5 -- TODO: this is an additive constant,
-- but I think we also want a multiplicative constant?
eps_bis = minWidth
-- | An implementation of "bc_enforce" from the paper
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
--
-- See also
-- "Presentation of a highly tuned multithreaded interval solver for underdetermined and well-determined nonlinear systems"
makeBox1Consistent
:: ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) )
-> Double -> Double
-> Box -> [ Box ]
makeBox1Consistent eqs minWidth epsEq x =
( `State.evalState` False ) $
pipeFunctionsWhileTrue (allNarrowingOperators epsEq minWidth eqs) x
-- | An implementation of "bound-consistency" from the paper
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
makeBox2Consistent
:: ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) )
-> Double -> Double -> Double
-> Box -> Box
makeBox2Consistent eqs minWidth epsEq lambdaMin x0 = ( `State.evalState` False ) $ doLoop 0.25 x0
where
doLoop :: Double -> Box -> State Bool Box
doLoop lambda x = do
x' <- boundConsistency get_t set_t lambda x
x'' <- boundConsistency get_s set_s lambda x'
modified <- State.get
let lambda' = if modified then lambda else 0.5 * lambda
if lambda' < lambdaMin
then return x''
else do { State.put False ; doLoop lambda' x'' }
boundConsistency :: ( Box -> 𝕀 Double )
-> ( 𝕀 Double -> Box -> Box )
-> Double -> Box -> State Bool Box
boundConsistency getter setter lambda box = do
let x@( 𝕀 x_inf x_sup ) = getter box
c1 = ( 1 - lambda ) * x_inf + lambda * x_sup
c2 = lambda * x_inf + ( 1 - lambda ) * x_sup
x'_inf =
case makeBox1Consistent eqs minWidth epsEq ( setter ( 𝕀 x_inf c1 ) box ) of
[] -> c1
x's -> minimum $ map ( inf . getter ) x's
x'_sup =
case makeBox1Consistent eqs minWidth epsEq ( setter ( 𝕀 c2 x_sup ) box ) of
[] -> c2
x's -> maximum $ map ( sup . getter ) x's
x' = 𝕀 x'_inf x'_sup
when ( width x - width x' >= epsEq ) $
State.put True
return $ setter x' box
ee_potential_zero :: StrokeDatum 3 𝕀 -> Bool
ee_potential_zero dat =
@ -1736,7 +1783,6 @@ ee_potential_zero dat =
cmp2 (<=) ( inf $ unT $ _D12_v $ 𝛿E𝛿sdcdt dat ) ( 2 0 0 )
&& cmp2 (>=) ( sup $ unT $ _D12_v $ 𝛿E𝛿sdcdt dat ) ( 2 0 0 )
zero, one :: Double
zero = 1e-6
one = 1 - zero
@ -1841,7 +1887,7 @@ leftNarrow eps_equal eps_bisection ff' = left_narrow
x' <- x's
if sup x' - inf x' < eps_bisection
then return x'
else left_narrow =<< bisect x'
else left_narrow =<< bisectI x'
-- TODO: de-duplicate with 'leftNarrow'?
rightNarrow :: Double
@ -1875,10 +1921,10 @@ rightNarrow eps_equal eps_bisection ff' = right_narrow
x' <- x's
if sup x' - inf x' < eps_bisection
then return x'
else right_narrow =<< bisect x'
else right_narrow =<< bisectI x'
bisect :: 𝕀 Double -> [ 𝕀 Double ]
bisect x@( 𝕀 x_inf x_sup )
bisectI :: 𝕀 Double -> [ 𝕀 Double ]
bisectI x@( 𝕀 x_inf x_sup )
| x_inf == x_sup
= [ x ]
| otherwise
@ -1953,7 +1999,10 @@ allNarrowingOperators eps_eq eps_bis eqs =
} = 𝛿E𝛿sdcdt $ ( eqs t `Seq.index` i ) s
in ( 𝕀 y_inf y_sup, 𝕀 y'_inf y'_sup )
get_t, get_s :: Box -> 𝕀 Double
get_t ( 𝕀 ( 1 t_inf ) ( 1 t_sup ), _, _ ) = 𝕀 t_inf t_sup
set_t, set_s :: 𝕀 Double -> Box -> Box
set_t ( 𝕀 t_inf t_sup ) ( _, i, s ) = ( 𝕀 ( 1 t_inf ) ( 1 t_sup ), i, s )
get_s ( _ , _, 𝕀 ( 1 s_inf ) ( 1 s_sup ) ) = 𝕀 s_inf s_sup
set_s ( 𝕀 s_inf s_sup ) ( t, i, _ ) = ( t, i, 𝕀 ( 1 s_inf ) ( 1 s_sup ) )
set_s ( 𝕀 s_inf s_sup ) ( t, i, _ ) = ( t, i, 𝕀 ( 1 s_inf ) ( 1 s_sup ) )

View file

@ -78,7 +78,10 @@ import Math.Bezier.Cubic.Fit
import Math.Bezier.Spline
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
import Math.Bezier.Stroke
( RootSolvingAlgorithm(..), invalidateCache )
( RootSolvingAlgorithm(..)
, CuspFindingOptions(..), Preconditioner(..)
, invalidateCache
)
import Math.Linear
( (..) )
import MetaBrush.Action
@ -212,6 +215,8 @@ runApplication application = do
--HalleyM2
NewtonRaphson
{ maxIters = 20, precision = 8 }
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe CuspFindingOptions ) $
Just defaultCuspFindingOptions
-- Put all these stateful variables in a record for conciseness.
let
@ -337,6 +342,7 @@ runApplication application = do
debug <- STM.readTVar debugTVar
fitParameters <- STM.readTVar fitParametersTVar
rootsAlgo <- STM.readTVar rootsAlgoTVar
mbCuspOptions <- STM.readTVar cuspFindingOptionsTVar
STM.writeTVar recomputeStrokesTVar False
let
addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
@ -348,7 +354,9 @@ runApplication application = do
doc
pure
( addRulers <$> getDocumentRender
colours rootsAlgo fitParameters mode debug
colours
rootsAlgo mbCuspOptions fitParameters
mode debug
modifiers mbMousePos mbHoldAction mbPartialPath
doc
)

View file

@ -74,7 +74,7 @@ import Math.Bezier.Spline
import Math.Bezier.Stroke
( Cusp(..), CachedStroke(..), invalidateCache
, computeStrokeOutline
, RootSolvingAlgorithm
, RootSolvingAlgorithm, CuspFindingOptions
)
import Math.Linear
( (..), T(..) )
@ -148,12 +148,16 @@ blankRender :: Colours -> Cairo.Render ()
blankRender _ = pure ()
getDocumentRender
:: Colours -> RootSolvingAlgorithm -> FitParameters -> Mode -> Bool
:: Colours
-> RootSolvingAlgorithm -> Maybe CuspFindingOptions -> FitParameters
-> Mode -> Bool
-> Set Modifier -> Maybe ( 2 ) -> Maybe HoldAction -> Maybe PartialPath
-> Document
-> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () )
getDocumentRender
cols rootAlgo fitParams mode debug
cols
rootAlgo mbCuspOptions fitParams
mode debug
modifiers mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = 2 cx cy, zoomFactor, documentContent = content } )
= do
@ -215,7 +219,10 @@ getDocumentRender
-> previewStroke :<| foldMap visibleStrokes ( strokes content )
_ -> foldMap visibleStrokes ( strokes content )
strokesRenderData <- traverseMaybe ( sequenceA . strokeRenderData rootAlgo fitParams ) modifiedStrokes
strokesRenderData <-
traverseMaybe
( sequenceA . strokeRenderData rootAlgo mbCuspOptions fitParams )
modifiedStrokes
let
renderSelectionRect :: Cairo.Render ()
@ -276,8 +283,13 @@ instance NFData StrokeRenderData where
-- - the computed outline (using fitting algorithm),
-- - the brush shape function.
-- - Otherwise, this consists of the underlying spline path only.
strokeRenderData :: RootSolvingAlgorithm -> FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
strokeRenderData rootAlgo fitParams
strokeRenderData
:: RootSolvingAlgorithm
-> Maybe CuspFindingOptions
-> FitParameters
-> Stroke
-> Maybe ( ST RealWorld StrokeRenderData )
strokeRenderData rootAlgo mbCuspOptions fitParams
( Stroke
{ strokeSpline = spline :: StrokeSpline clo ( Record pointFields )
, strokeBrush = ( strokeBrush :: Maybe ( Brush brushFields ) )
@ -302,7 +314,7 @@ strokeRenderData rootAlgo fitParams
-- Compute the outline using the brush function.
( outline, fitPts, cusps ) <-
computeStrokeOutline @clo rootAlgo fitParams
computeStrokeOutline @clo rootAlgo mbCuspOptions fitParams
( toUsedParams . brushParams ) embedUsedParams brushFn
spline
pure $