Implement adaptive shaving algorithm

This commit is contained in:
sheaf 2024-04-21 18:09:21 +02:00
parent 01fdd9a126
commit ced714987e
2 changed files with 136 additions and 54 deletions

View file

@ -110,8 +110,7 @@ main = do
putStrLn $ unlines
[ replicate 40 '='
, "Best time: " ++ show bestTime ++ "s"
, "Best parameters:"
--, show (testCuspOptions bestTest)
, "Best parameters: " ++ show (testName bestTest)
]
benchTestCase :: TestCase -> IO Double
@ -181,9 +180,15 @@ testCases = benchCases
benchCases :: [ TestCase ]
benchCases =
[ ellipseTestCase opts "full" ( 0, 1 ) pi $ defaultStartBoxes [ 2 ] ] -- [ 0 .. 3 ] ]
where
opts = defaultRootIsolationOptions
[ ellipseTestCase opts ("minWidth=" ++ show minWidth ++ ",ε=" ++ show narrowAbs) ( 0, 1 ) pi $ defaultStartBoxes [ 2 ]
| minWidth <- [ 1e-5 ]
, narrowAbs <- [ 1e-5, 1e-4, 1e-3, 5e-3, 8e-3, 1e-2, 2e-2, 3e-2, 4e-2, 5e-2, 1e-1 ]
, let opts =
RootIsolationOptions
{ minWidth
, cuspFindingAlgorithms = defaultRootIsolationAlgorithms minWidth narrowAbs
}
]
--------------------------------------------------------------------------------

View file

@ -55,7 +55,8 @@ import Data.Semigroup
import Numeric
( showFFloat )
import GHC.TypeNats
( Nat, KnownNat )
( Nat, KnownNat
, type (<=) )
-- containers
import Data.Tree
@ -285,10 +286,10 @@ defaultGaussSeidelOptions =
defaultBisectionOptions
:: forall n d
. BoxCt n d
. ( 1 <= n, BoxCt n d )
=> Double -> Double
-> Box n -> BisectionOptions n d
defaultBisectionOptions _minWidth _narrowAbs box =
defaultBisectionOptions minWidth _narrowAbs box =
BisectionOptions
{ canHaveSols =
\ eqs box' ->
@ -320,21 +321,20 @@ defaultBisectionOptions _minWidth _narrowAbs box =
-- First, check if the largest dimension is over 10 times larger
-- than the smallest dimension; if so bisect along that coordinate.
--
-- TODO: filter out dimensions smaller than minimum width.
in case sortOnArg ( width . coordInterval ) datPerCoord of
[] -> error "dimension 0"
[] -> error "impossible: dimension 0"
[Arg _ d] -> (coordIndex d, "")
Arg w0 _ : ds ->
let Arg w1 d1 = last ds
in if w1 >= 10 * w0
then ( coordIndex d1, "tooWide")
then ( coordIndex d1, "tooWide" )
-- Otherwise, pick the dimension with the largest spread = width * Jacobian column norm
else case sortOnArg ( Dual . spread ) datPerCoord of
[] -> error "dimension 0"
Arg _ d : _ ->
(coordIndex d, "spread")
else case filter ( not . isTooSmall ) $ sortOnArg ( Dual . spread ) datPerCoord of
[] -> ( coordIndex d1, "tooWide'" )
Arg _ d : _ -> ( coordIndex d, "spread" )
}
where
isTooSmall ( Arg ( Dual w ) _ ) = w < minWidth
{-# INLINEABLE defaultBisectionOptions #-}
sortOnArg :: Ord b => (a -> b) -> [a] -> [Arg b a]
@ -494,7 +494,7 @@ bisect canHaveSols ( fallbackDim, why ) box =
( oks, ("cd = " ++ show i, mid ) )
Nothing ->
case bisectInCoord box fallbackDim of
( mid, (lo, hi) ) ->
( mid, ( lo, hi ) ) ->
( [ lo, hi ], ( why, mid ) )
where
solsList =
@ -673,30 +673,27 @@ makeBox2Consistent
-> Box2Options n d
-> ( 𝕀 n -> D 1 ( 𝕀 n ) ( 𝕀 d ) )
-> Box n -> Box n
makeBox2Consistent minWidth (Box2Options epsEq lambdaMin coordsToNarrow eqsToUse) eqs x0
makeBox2Consistent minWidth (Box2Options ε_eq λMin coordsToNarrow eqsToUse) eqs x0
= ( `State.evalState` False ) $ doLoop 0.25 x0
where
box1Options :: Box1Options n d
box1Options = Box1Options epsEq coordsToNarrow eqsToUse
box1Options = Box1Options ε_eq coordsToNarrow eqsToUse
doBox1 :: Box n -> [ Box n ]
doBox1 = makeBox1Consistent minWidth box1Options eqs
doLoop :: Double -> Box n -> State Bool ( Box n )
doLoop lambda x = do
x'' <- forEachDim @n x $ \ i ->
boundConsistency ( `index` i ) ( set i ) lambda
doLoop λ x = do
x'' <- forEachDim @n x $ boundConsistency λ
modified <- State.get
let lambda' = if modified then lambda else 0.5 * lambda
if lambda' < lambdaMin
let λ' = if modified then λ else 0.5 * λ
if λ' < λMin
then return x''
else do { State.put False ; doLoop lambda' x'' }
else do { State.put False ; doLoop λ' x'' }
boundConsistency :: ( Box n -> 𝕀 Double )
-> ( 𝕀 Double -> Box n -> Box n )
-> Double -> Box n -> State Bool ( Box n )
boundConsistency getter setter lambda box = do
boundConsistency :: Double -> Fin n -> Box n -> State Bool ( Box n )
boundConsistency λ i 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
c1 = ( 1 - λ ) * x_inf + λ * x_sup
c2 = λ * x_inf + ( 1 - λ ) * x_sup
x'_inf =
case doBox1 ( setter ( 𝕀 x_inf c1 ) box ) of
[] -> c1
@ -706,9 +703,12 @@ makeBox2Consistent minWidth (Box2Options epsEq lambdaMin coordsToNarrow eqsToUse
[] -> c2
x's -> maximum $ map ( sup . getter ) x's
x' = 𝕀 x'_inf x'_sup
when ( width x - width x' >= epsEq ) $
when ( width x - width x' >= ε_eq ) $
State.put True
return $ setter x' box
where
getter = ( `index` i )
setter = set i
-- | Pre-condition the system \( AX = B \).
precondition
@ -779,7 +779,7 @@ leftNarrow :: Double
-> ( 𝕀 Double -> ( 𝕀 Double, 𝕀 Double ) )
-> 𝕀 Double
-> [ 𝕀 Double ]
leftNarrow eps_equal eps_bisection ff' = left_narrow
leftNarrow ε_eq ε_bis ff' = left_narrow
where
left_narrow ( 𝕀 x_inf x_sup ) =
go x_sup ( 𝕀 x_inf ( if x_inf == x_sup then x_inf else succFP x_inf ) )
@ -791,19 +791,18 @@ leftNarrow eps_equal eps_bisection ff' = left_narrow
else
let x = 𝕀 ( sup x_left ) x_sup
( _f_x, f'_x ) = ff' x
x's = do delta <- f_x_left `extendedDivide` f'_x --f'_x_left
let x_new = x_left - delta
x's = do δ <- f_x_left `extendedDivide` f'_x
let x_new = x_left - δ
map fst $ x_new `intersect` x
in
if | null x's
-> []
| ( width x - sum ( map width x's ) ) < eps_equal
-- TODO: do a check with the relative reduction in size?
| ( width x - sum ( map width x's ) ) < ε_eq
-> x's
| otherwise
-> do
x' <- x's
if sup x' - inf x' < eps_bisection
if sup x' - inf x' < ε_bis
then return x'
else left_narrow =<< bisectI x'
@ -813,7 +812,7 @@ rightNarrow :: Double
-> ( 𝕀 Double -> ( 𝕀 Double, 𝕀 Double ) )
-> 𝕀 Double
-> [ 𝕀 Double ]
rightNarrow eps_equal eps_bisection ff' = right_narrow
rightNarrow ε_eq ε_bis ff' = right_narrow
where
right_narrow ( 𝕀 x_inf x_sup ) =
go x_inf ( 𝕀 ( if x_inf == x_sup then x_sup else prevFP x_sup ) x_sup )
@ -825,19 +824,18 @@ rightNarrow eps_equal eps_bisection ff' = right_narrow
else
let x = 𝕀 x_inf ( inf x_right )
( _f_x, f'_x ) = ff' x
x's = do delta <- f_x_right `extendedDivide` f'_x --f'_x_right
let x_new = x_right - delta
x's = do δ <- f_x_right `extendedDivide` f'_x
let x_new = x_right - δ
map fst $ x_new `intersect` x
in
if | null x's
-> []
| ( width x - sum ( map width x's ) ) < eps_equal
-- TODO: do a check with the relative reduction in size?
| ( width x - sum ( map width x's ) ) < ε_eq
-> x's
| otherwise
-> do
x' <- x's
if sup x' - inf x' < eps_bisection
if sup x' - inf x' < ε_bis
then return x'
else right_narrow =<< bisectI x'
@ -873,25 +871,21 @@ allNarrowingOperators
-> Box1Options n d
-> ( 𝕀 n -> D 1 ( 𝕀 n ) ( 𝕀 d ) )
-> [ Box n -> State Bool [ Box n ] ]
allNarrowingOperators eps_bis ( Box1Options eps_eq coordsToNarrow eqsToUse ) eqs =
allNarrowingOperators ε_bis ( Box1Options ε_eq coordsToNarrow eqsToUse ) eqs =
[ \ cand ->
let getter = ( `index` coordIndex )
setter = set coordIndex
newCands = map ( `setter` cand ) $ narrowFn eps_eq eps_bis ( \ x0 -> fn $ setter x0 cand ) ( getter cand )
newCands = map ( `setter` cand ) $ narrowFn ( \ box -> ff' coordIndex eqnIndex $ setter box cand ) ( getter cand )
in do
when ( ( width ( getter cand ) - sum ( map ( width . getter ) newCands ) ) > eps_eq ) $
when ( ( width ( getter cand ) - sum ( map ( width . getter ) newCands ) ) > ε_eq ) $
-- TODO: do a check with the relative reduction in size?
State.put True
return newCands
| narrowFn <- [ leftNarrow, rightNarrow ]
, ( coordIndex, fn ) <-
[ ( i, ff' i d )
| i <- coordsToNarrow
, d <- eqsToUse
]
| narrowFn <- [ leftNarrow ε_eq ε_bis, rightNarrow ε_eq ε_bis ]
, coordIndex <- coordsToNarrow
, eqnIndex <- eqsToUse
]
where
ff' :: Fin n -> Fin d -> 𝕀 n -> ( 𝕀 Double, 𝕀 Double )
ff' i d ts =
let df = eqs ts
@ -900,3 +894,86 @@ allNarrowingOperators eps_bis ( Box1Options eps_eq coordsToNarrow eqsToUse ) eqs
f' = df `monIndex` linearMonomial i
in ( f `index` d, f' `index` d )
{-# INLINEABLE allNarrowingOperators #-}
data AdaptiveShavingOptions
= AdaptiveShavingOptions
{ γ_init, σ_good, σ_bad, β_good, β_bad :: !Double
}
defaultAdaptiveShavingOptions :: AdaptiveShavingOptions
defaultAdaptiveShavingOptions =
AdaptiveShavingOptions
{ γ_init = 0.25
, σ_good = 0.25
, σ_bad = 0.75
, β_good = 1.5
, β_bad = 0.7
}
-- | Algorithm @lnar_sbc3ag@ (adaptive guessing) from the paper
-- "Box Consistency through Adaptive Shaving" (Goldsztejn & Goualard, 2010).
leftShave :: Double
-> AdaptiveShavingOptions
-> ( 𝕀 Double -> ( 𝕀 Double, 𝕀 Double ) )
-> 𝕀 Double
-> [ 𝕀 Double ]
leftShave ε -- minimum width
( AdaptiveShavingOptions { γ_init, σ_good, σ_bad, β_good, β_bad } )
ff' i0 =
left_narrow γ_init i0
where
w0 = width i0
left_narrow :: Double -> 𝕀 Double -> [ 𝕀 Double ]
left_narrow γ i@( 𝕀 x_inf x_sup )
-- Stop if the box is too small.
| width i < ε
= [ i ]
| otherwise
= go γ x_sup ( 𝕀 x_inf ( if x_inf == x_sup then x_inf else succFP x_inf ) )
go :: Double -> Double -> 𝕀 Double -> [ 𝕀 Double ]
go γ x_sup x_left =
let ( f_x_left, _f'_x_left ) = ff' x_left
in
if 0 `inside` f_x_left
-- Box-consistency achieved; finish.
then [ 𝕀 ( inf x_left ) x_sup ]
else
-- Otherwise, try to shave off a chunk on the left of the interval.
let --x' = 𝕀 ( sup x_left ) x_sup
inf_guess = sup x_left
sup_guess = min x_sup ( inf_guess + γ * w0 ) -- * width x' )
guess = 𝕀 inf_guess sup_guess
-- NB: this always uses the initial width (to "avoid asymptotic behaviour" according to the paper)
( f_guess, f'_guess ) = ff' guess
x_minus_guess = 𝕀 ( min x_sup ( succFP $ sup guess ) ) x_sup
in if not ( 0 `inside` f_guess )
then
-- We successfully shaved "guess" off; go round again after removing it.
-- TODO: here we could go back to the top with a new "w" maybe?
left_narrow ( β_good * γ ) x_minus_guess
else
-- Do a Newton step to try to reduce the guess interval.
-- Starting from "guess", we get a collection of sub-intervals
-- "guesses'" refining where the function can be zero.
let guesses' :: [ ( 𝕀 Double ) ]
guesses' = do
δ <- f_x_left `extendedDivide` f'_guess
let guess' = singleton ( inf guess ) - δ
map fst $ guess' `intersect` guess
w_guess = width guess
w_guesses'
| null guesses'
= 0
| otherwise
= sup_guess - minimum ( map inf guesses' )
γ' | w_guesses' < σ_good * w_guess
-- Good improvement, try larger guesses in the future.
= β_good * γ
| w_guesses' > σ_bad * w_guess
-- Poor improvement, try smaller guesses in the future.
= β_bad * γ
| otherwise
-- Otherwise, keep the γ factor the same.
= γ
in left_narrow γ' =<< ( x_minus_guess : guesses' )