mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 09:24:08 +00:00
Modularise root isolation algorithms
Different root isolation algorithms now live in separate modules, and are all instances of the RootIsolationAlgorithm typeclass. This separates the algorithmic code from the top-level driver code in Math.Root.Isolation.
This commit is contained in:
parent
b1df0d04e6
commit
d797abc5e4
|
@ -81,8 +81,9 @@ common common
|
||||||
StandaloneDeriving
|
StandaloneDeriving
|
||||||
StandaloneKindSignatures
|
StandaloneKindSignatures
|
||||||
TupleSections
|
TupleSections
|
||||||
|
TypeAbstractions
|
||||||
TypeApplications
|
TypeApplications
|
||||||
TypeFamilies
|
TypeFamilyDependencies
|
||||||
TypeOperators
|
TypeOperators
|
||||||
UnboxedTuples
|
UnboxedTuples
|
||||||
ViewPatterns
|
ViewPatterns
|
||||||
|
|
|
@ -52,8 +52,9 @@ common common
|
||||||
StandaloneDeriving
|
StandaloneDeriving
|
||||||
StandaloneKindSignatures
|
StandaloneKindSignatures
|
||||||
TupleSections
|
TupleSections
|
||||||
|
TypeAbstractions
|
||||||
TypeApplications
|
TypeApplications
|
||||||
TypeFamilies
|
TypeFamilyDependencies
|
||||||
TypeOperators
|
TypeOperators
|
||||||
UnboxedTuples
|
UnboxedTuples
|
||||||
ViewPatterns
|
ViewPatterns
|
||||||
|
@ -125,6 +126,10 @@ library
|
||||||
, Math.Ring
|
, Math.Ring
|
||||||
, Math.Roots
|
, Math.Roots
|
||||||
, Math.Root.Isolation
|
, Math.Root.Isolation
|
||||||
|
, Math.Root.Isolation.Bisection
|
||||||
|
, Math.Root.Isolation.GaussSeidel
|
||||||
|
, Math.Root.Isolation.Narrowing
|
||||||
|
, Math.Root.Isolation.Core
|
||||||
, Debug.Utils
|
, Debug.Utils
|
||||||
|
|
||||||
other-modules:
|
other-modules:
|
||||||
|
|
|
@ -121,7 +121,9 @@ benchTestCase ( TestCase { testName, testBrushStroke, testCuspOptions, testStart
|
||||||
before <- getMonotonicTime
|
before <- getMonotonicTime
|
||||||
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
|
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
|
||||||
( dunno, sols ) =
|
( dunno, sols ) =
|
||||||
foldMap ( \ ( i, ( _trees, ( mbCusps, defCusps ) ) ) -> ( map ( i , ) mbCusps, map ( i, ) defCusps ) ) $
|
foldMap
|
||||||
|
( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = mbCusps } ) ) ->
|
||||||
|
( map ( ( i , ) . snd ) mbCusps, map ( i, ) defCusps ) ) $
|
||||||
IntMap.toList $
|
IntMap.toList $
|
||||||
findCuspsIn testCuspOptions testStrokeFnI $
|
findCuspsIn testCuspOptions testStrokeFnI $
|
||||||
IntMap.fromList
|
IntMap.fromList
|
||||||
|
|
|
@ -51,7 +51,7 @@ deriving stock instance Functor ( D k u ) => Functor ( C k u )
|
||||||
-- | @D k u v@ is the space of @k@-th order germs of functions from @u@ to @v@,
|
-- | @D k u v@ is the space of @k@-th order germs of functions from @u@ to @v@,
|
||||||
-- represented by the algebra:
|
-- represented by the algebra:
|
||||||
--
|
--
|
||||||
-- \[ \mathbb{Z}[x_1, \ldots, x_n]/(x_1, \ldots, x_n)^(k+1) \otimes_\mathbb{Z} v \]
|
-- \[ \mathbb{Z}[x_1, \ldots, x_n]/(x_1, \ldots, x_n)^{k+1} \otimes_\mathbb{Z} v \]
|
||||||
--
|
--
|
||||||
-- when @u@ is of dimension @n@.
|
-- when @u@ is of dimension @n@.
|
||||||
type D :: Nat -> Type -> Type -> Type
|
type D :: Nat -> Type -> Type -> Type
|
||||||
|
|
|
@ -597,8 +597,8 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams
|
||||||
case mbCuspOptions of
|
case mbCuspOptions of
|
||||||
Just cuspOptions ->
|
Just cuspOptions ->
|
||||||
foldMap
|
foldMap
|
||||||
( \ ( i, ( _trees, ( potCusps, defCusps ) ) ) ->
|
( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = potCusps } ) ) ->
|
||||||
( map ( i , ) potCusps, map ( i , ) defCusps )
|
( map ( ( i , ) . fst ) potCusps, map ( i , ) defCusps )
|
||||||
)
|
)
|
||||||
( IntMap.toList $ findCusps cuspOptions curvesI )
|
( IntMap.toList $ findCusps cuspOptions curvesI )
|
||||||
Nothing ->
|
Nothing ->
|
||||||
|
@ -1166,7 +1166,7 @@ cuspCoords eqs ( i, box )
|
||||||
findCusps
|
findCusps
|
||||||
:: RootIsolationOptions N 3
|
:: RootIsolationOptions N 3
|
||||||
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
||||||
-> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], ( [ Box N ], [ Box N ] ) )
|
-> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], DoneBoxes N )
|
||||||
findCusps opts boxStrokeData =
|
findCusps opts boxStrokeData =
|
||||||
findCuspsIn opts boxStrokeData $
|
findCuspsIn opts boxStrokeData $
|
||||||
IntMap.fromList
|
IntMap.fromList
|
||||||
|
@ -1186,7 +1186,7 @@ findCuspsIn
|
||||||
:: RootIsolationOptions N 3
|
:: RootIsolationOptions N 3
|
||||||
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
||||||
-> IntMap [ Box 2 ]
|
-> IntMap [ Box 2 ]
|
||||||
-> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], ( [ Box N ], [ Box N ] ) )
|
-> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], DoneBoxes N )
|
||||||
findCuspsIn opts boxStrokeData initBoxes =
|
findCuspsIn opts boxStrokeData initBoxes =
|
||||||
IntMap.mapWithKey ( \ i -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) ) initBoxes
|
IntMap.mapWithKey ( \ i -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) ) initBoxes
|
||||||
where
|
where
|
||||||
|
|
|
@ -6,13 +6,15 @@
|
||||||
|
|
||||||
module Math.Interval
|
module Math.Interval
|
||||||
( 𝕀(𝕀), inf, sup
|
( 𝕀(𝕀), inf, sup
|
||||||
, width
|
, width, midpoint
|
||||||
, scaleInterval
|
, scaleInterval
|
||||||
, 𝕀ℝ
|
, 𝕀ℝ
|
||||||
|
, isCanonical
|
||||||
, singleton, nonDecreasing
|
, singleton, nonDecreasing
|
||||||
, inside
|
, inside
|
||||||
, aabb
|
, aabb
|
||||||
, extendedDivide, extendedRecip
|
, extendedDivide, extendedRecip
|
||||||
|
, intersect, bisect
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -20,6 +22,7 @@ module Math.Interval
|
||||||
import Prelude hiding ( Num(..), Fractional(..) )
|
import Prelude hiding ( Num(..), Fractional(..) )
|
||||||
import Data.List
|
import Data.List
|
||||||
( nub )
|
( nub )
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
|
||||||
-- acts
|
-- acts
|
||||||
import Data.Act
|
import Data.Act
|
||||||
|
@ -35,6 +38,8 @@ import Data.Group.Generics
|
||||||
|
|
||||||
-- brush-strokes
|
-- brush-strokes
|
||||||
import Math.Algebra.Dual
|
import Math.Algebra.Dual
|
||||||
|
import Math.Float.Utils
|
||||||
|
( prevFP )
|
||||||
import Math.Interval.Internal
|
import Math.Interval.Internal
|
||||||
( 𝕀(𝕀), inf, sup, scaleInterval )
|
( 𝕀(𝕀), inf, sup, scaleInterval )
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
|
@ -51,18 +56,62 @@ import Math.Ring
|
||||||
type 𝕀ℝ n = 𝕀 ( ℝ n )
|
type 𝕀ℝ n = 𝕀 ( ℝ n )
|
||||||
type instance D k ( 𝕀 v ) = D k v
|
type instance D k ( 𝕀 v ) = D k v
|
||||||
|
|
||||||
|
-- | An interval reduced to a single point.
|
||||||
singleton :: a -> 𝕀 a
|
singleton :: a -> 𝕀 a
|
||||||
singleton a = 𝕀 a a
|
singleton a = 𝕀 a a
|
||||||
|
|
||||||
|
-- | The width of an interval.
|
||||||
|
--
|
||||||
|
-- NB: assumes the endpoints are neither @NaN@ nor infinity.
|
||||||
width :: AbelianGroup a => 𝕀 a -> a
|
width :: AbelianGroup a => 𝕀 a -> a
|
||||||
width ( 𝕀 lo hi ) = hi - lo
|
width ( 𝕀 lo hi ) = hi - lo
|
||||||
|
{-# INLINEABLE width #-}
|
||||||
|
|
||||||
-- | Turn a non-decreasing function into a function on intervals.
|
-- | Turn a non-decreasing function into a function on intervals.
|
||||||
nonDecreasing :: ( a -> b ) -> 𝕀 a -> 𝕀 b
|
nonDecreasing :: ( a -> b ) -> 𝕀 a -> 𝕀 b
|
||||||
nonDecreasing f ( 𝕀 lo hi ) = 𝕀 ( f lo ) ( f hi )
|
nonDecreasing f ( 𝕀 lo hi ) = 𝕀 ( f lo ) ( f hi )
|
||||||
|
|
||||||
|
-- | Does the given value lie inside the specified interval?
|
||||||
inside :: Ord a => a -> 𝕀 a -> Bool
|
inside :: Ord a => a -> 𝕀 a -> Bool
|
||||||
inside x ( 𝕀 lo hi ) = x >= lo && x <= hi
|
inside x ( 𝕀 lo hi ) = x >= lo && x <= hi
|
||||||
|
{-# INLINEABLE inside #-}
|
||||||
|
|
||||||
|
-- | Is this interval canonical, i.e. it consists of either 1 or 2 floating point
|
||||||
|
-- values only?
|
||||||
|
isCanonical :: 𝕀 Double -> Bool
|
||||||
|
isCanonical ( 𝕀 x_inf x_sup ) = x_inf >= prevFP x_sup
|
||||||
|
|
||||||
|
-- | The midpoint of an interval.
|
||||||
|
--
|
||||||
|
-- NB: assumes the endpoints are neither @NaN@ nor infinity.
|
||||||
|
midpoint :: 𝕀 Double -> Double
|
||||||
|
midpoint ( 𝕀 x_inf x_sup ) = 0.5 * ( x_inf + x_sup )
|
||||||
|
|
||||||
|
-- | Compute the intersection of two intervals.
|
||||||
|
--
|
||||||
|
-- Returns whether the first interval is a strict subset of the second interval
|
||||||
|
-- (or the intersection is a single point).
|
||||||
|
intersect :: 𝕀 Double -> 𝕀 Double -> [ ( 𝕀 Double, Bool ) ]
|
||||||
|
intersect ( 𝕀 lo1 hi1 ) ( 𝕀 lo2 hi2 )
|
||||||
|
| lo > hi
|
||||||
|
= [ ]
|
||||||
|
| otherwise
|
||||||
|
= [ ( 𝕀 lo hi, ( lo1 > lo2 && hi1 < hi2 ) || ( lo == hi ) ) ]
|
||||||
|
where
|
||||||
|
lo = max lo1 lo2
|
||||||
|
hi = min hi1 hi2
|
||||||
|
|
||||||
|
-- | Bisect an interval.
|
||||||
|
--
|
||||||
|
-- Generally returns two sub-intervals, but returns the input interval if
|
||||||
|
-- it is canonical (and thus bisection would be pointless).
|
||||||
|
bisect :: 𝕀 Double -> NE.NonEmpty ( 𝕀 Double )
|
||||||
|
bisect x@( 𝕀 x_inf x_sup )
|
||||||
|
| isCanonical x
|
||||||
|
= NE.singleton x
|
||||||
|
| otherwise
|
||||||
|
= 𝕀 x_inf x_mid NE.:| [ 𝕀 x_mid x_sup ]
|
||||||
|
where x_mid = midpoint x
|
||||||
|
|
||||||
deriving via ViaAbelianGroup ( T ( 𝕀 Double ) )
|
deriving via ViaAbelianGroup ( T ( 𝕀 Double ) )
|
||||||
instance Semigroup ( T ( 𝕀 Double ) )
|
instance Semigroup ( T ( 𝕀 Double ) )
|
||||||
|
|
File diff suppressed because it is too large
Load diff
266
brush-strokes/src/lib/Math/Root/Isolation/Bisection.hs
Normal file
266
brush-strokes/src/lib/Math/Root/Isolation/Bisection.hs
Normal file
|
@ -0,0 +1,266 @@
|
||||||
|
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
module Math.Root.Isolation.Bisection
|
||||||
|
( -- * The bisection method for root isolation
|
||||||
|
Bisection
|
||||||
|
, bisection
|
||||||
|
|
||||||
|
-- ** Configuration options
|
||||||
|
, BisectionCoordPicker
|
||||||
|
, BisectionOptions(..), defaultBisectionOptions
|
||||||
|
|
||||||
|
-- *** Helper code for picking which dimension to bisect
|
||||||
|
, CoordBisectionData(..)
|
||||||
|
, spread, normVI, maxVI
|
||||||
|
, sortOnArgNE
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import Data.Kind
|
||||||
|
( Type )
|
||||||
|
import Data.Foldable
|
||||||
|
( toList )
|
||||||
|
import Data.Functor
|
||||||
|
( (<&>) )
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
( NonEmpty(..), cons, filter
|
||||||
|
, head, nonEmpty, singleton, sort
|
||||||
|
)
|
||||||
|
import Data.Semigroup
|
||||||
|
( Arg(..), Dual(..) )
|
||||||
|
import GHC.TypeNats
|
||||||
|
( Nat, KnownNat
|
||||||
|
, type (<=)
|
||||||
|
)
|
||||||
|
|
||||||
|
-- MetaBrush
|
||||||
|
import Math.Algebra.Dual
|
||||||
|
( D )
|
||||||
|
import Math.Interval
|
||||||
|
import Math.Linear
|
||||||
|
import Math.Module
|
||||||
|
( Module(..) )
|
||||||
|
import Math.Monomial
|
||||||
|
( MonomialBasis(..), linearMonomial, zeroMonomial )
|
||||||
|
import qualified Math.Ring as Ring
|
||||||
|
import Math.Root.Isolation.Core
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Bisection
|
||||||
|
|
||||||
|
-- | The bisection algorithm; see 'bisection'.
|
||||||
|
data Bisection
|
||||||
|
instance RootIsolationAlgorithm Bisection where
|
||||||
|
type instance StepDescription Bisection = ( String, Double )
|
||||||
|
type instance RootIsolationAlgorithmOptions Bisection n d = BisectionOptions n d
|
||||||
|
rootIsolationAlgorithm
|
||||||
|
( BisectionOptions { canHaveSols, fallbackBisectionCoord } )
|
||||||
|
thisRoundHist prevRoundsHist eqs box = do
|
||||||
|
let ( boxes, whatBis ) =
|
||||||
|
bisection
|
||||||
|
( canHaveSols eqs )
|
||||||
|
( fallbackBisectionCoord thisRoundHist prevRoundsHist eqs )
|
||||||
|
box
|
||||||
|
return ( whatBis, boxes )
|
||||||
|
|
||||||
|
-- | Options for the bisection method.
|
||||||
|
type BisectionOptions :: Nat -> Nat -> Type
|
||||||
|
data BisectionOptions n d =
|
||||||
|
BisectionOptions
|
||||||
|
{ -- | Custom function to check whether the given box might contain solutions to the
|
||||||
|
-- given equations.
|
||||||
|
--
|
||||||
|
-- If you always return @True@, then we will always bisect along
|
||||||
|
-- the dimension picked by the 'fallbackBisectionCoord' function.
|
||||||
|
--
|
||||||
|
-- NB: only return 'False' if non-existence of solutions is guaranteed
|
||||||
|
-- (otherwise, the root isolation algorithm might not be consistent).
|
||||||
|
canHaveSols :: !( ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> Box n -> Bool )
|
||||||
|
-- | Heuristic to choose which coordinate dimension to bisect.
|
||||||
|
--
|
||||||
|
-- It's only a fallback, as we prefer to bisect along coordinate dimensions
|
||||||
|
-- that minimise the number of sub-boxes created.
|
||||||
|
, fallbackBisectionCoord :: !( BisectionCoordPicker n d )
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | A function to choose along which coordination dimension we should bisect.
|
||||||
|
type BisectionCoordPicker n d
|
||||||
|
= [ ( RootIsolationStep, Box n ) ]
|
||||||
|
-> BoxHistory n
|
||||||
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
|
-> forall r. ( NE.NonEmpty ( Fin n, r ) -> ( r, String ) )
|
||||||
|
|
||||||
|
-- | Default options for the bisection method.
|
||||||
|
defaultBisectionOptions
|
||||||
|
:: forall n d
|
||||||
|
. ( 1 <= n, BoxCt n d )
|
||||||
|
=> Double -> Double
|
||||||
|
-> Box n -> BisectionOptions n d
|
||||||
|
defaultBisectionOptions minWidth _ε_eq box =
|
||||||
|
BisectionOptions
|
||||||
|
{ canHaveSols =
|
||||||
|
\ eqs box' ->
|
||||||
|
-- box(0)-consistency
|
||||||
|
let iRange' :: Box d
|
||||||
|
iRange' = eqs box' `monIndex` zeroMonomial
|
||||||
|
in unT ( origin @Double ) `inside` iRange'
|
||||||
|
|
||||||
|
-- box(1)-consistency
|
||||||
|
--let box1Options = Box1Options _ε_eq ( toList $ universe @n ) ( toList $ universe @d )
|
||||||
|
--in not $ null $ makeBox1Consistent _minWidth box1Options eqs box'
|
||||||
|
|
||||||
|
-- box(2)-consistency
|
||||||
|
--let box2Options = Box2Options _ε_eq 0.001 ( toList $ universe @n ) ( toList $ universe @d )
|
||||||
|
-- box'' = makeBox2Consistent _minWidth box2Options eqs box'
|
||||||
|
-- iRange'' :: Box d
|
||||||
|
-- iRange'' = eqs box'' `monIndex` zeroMonomial
|
||||||
|
--in unT ( origin @Double ) `inside` iRange''
|
||||||
|
, fallbackBisectionCoord =
|
||||||
|
\ _thisRoundHist _prevRoundsHist eqs possibleCoordChoices ->
|
||||||
|
let datPerCoord =
|
||||||
|
possibleCoordChoices <&> \ ( i, r ) ->
|
||||||
|
CoordBisectionData
|
||||||
|
{ coordIndex = i
|
||||||
|
, coordInterval = box `index` i
|
||||||
|
, coordJacobianColumn = eqs box `monIndex` ( linearMonomial i )
|
||||||
|
, coordBisectionData = r
|
||||||
|
}
|
||||||
|
|
||||||
|
-- First, check if the largest dimension is over 20 times larger
|
||||||
|
-- than the smallest dimension; if so bisect that dimension.
|
||||||
|
in case sortOnArgNE ( width . coordInterval ) datPerCoord of
|
||||||
|
Arg _ d NE.:| [] -> ( coordBisectionData d, "" )
|
||||||
|
Arg w0 _ NE.:| ds ->
|
||||||
|
let Arg w1 d1 = last ds
|
||||||
|
in if w1 >= 20 * w0
|
||||||
|
then ( coordBisectionData d1, "tooWide" )
|
||||||
|
-- Otherwise, pick the coordination dimension with maximum spread
|
||||||
|
-- (spread = width * Jacobian column norm).
|
||||||
|
else
|
||||||
|
let isTooSmall ( Arg ( Dual w ) _ ) = w < minWidth
|
||||||
|
in case NE.filter ( not . isTooSmall ) $ sortOnArgNE ( Dual . spread ) datPerCoord of
|
||||||
|
[] -> ( coordBisectionData d1, "tooWide'" )
|
||||||
|
Arg _ d : _ -> ( coordBisectionData d, "spread" )
|
||||||
|
-- TODO: pick a dimension that previous Newton steps did not
|
||||||
|
-- manage to narrow well?
|
||||||
|
}
|
||||||
|
{-# INLINEABLE defaultBisectionOptions #-}
|
||||||
|
|
||||||
|
sortOnArgNE :: Ord b => ( a -> b ) -> NE.NonEmpty a -> NE.NonEmpty ( Arg b a )
|
||||||
|
sortOnArgNE f = NE.sort . fmap ( \ a -> Arg ( f a ) a )
|
||||||
|
{-# INLINEABLE sortOnArgNE #-}
|
||||||
|
|
||||||
|
-- | A utility datatype that is useful in implementing bisection dimension picker
|
||||||
|
-- functions ('fallbackBisectionCoord').
|
||||||
|
type CoordBisectionData :: Nat -> Nat -> Type -> Type
|
||||||
|
data CoordBisectionData n d r =
|
||||||
|
CoordBisectionData
|
||||||
|
{ coordIndex :: !( Fin n )
|
||||||
|
, coordInterval :: !( 𝕀 Double )
|
||||||
|
, coordJacobianColumn :: !( 𝕀ℝ d )
|
||||||
|
, coordBisectionData :: !r
|
||||||
|
}
|
||||||
|
deriving stock instance ( Show ( ℝ d ), Show r )
|
||||||
|
=> Show ( CoordBisectionData n d r )
|
||||||
|
|
||||||
|
spread :: ( BoxCt n d, Representable Double ( ℝ d ) )
|
||||||
|
=> CoordBisectionData n d r -> Double
|
||||||
|
spread ( CoordBisectionData { coordInterval = cd, coordJacobianColumn = j_cd } )
|
||||||
|
= width cd * normVI j_cd
|
||||||
|
{-# INLINEABLE spread #-}
|
||||||
|
|
||||||
|
normVI :: ( Applicative ( Vec d ), Representable Double ( ℝ d ) ) => 𝕀ℝ d -> Double
|
||||||
|
normVI ( 𝕀 los his ) =
|
||||||
|
sqrt $ sum ( nm1 <$> coordinates los <*> coordinates his )
|
||||||
|
where
|
||||||
|
nm1 :: Double -> Double -> Double
|
||||||
|
nm1 lo hi = max ( abs lo ) ( abs hi ) Ring.^ 2
|
||||||
|
{-# INLINEABLE normVI #-}
|
||||||
|
|
||||||
|
maxVI :: ( Applicative ( Vec d ), Representable Double ( ℝ d ) ) => 𝕀ℝ d -> Double
|
||||||
|
maxVI ( 𝕀 los his ) =
|
||||||
|
maximum ( maxAbs <$> coordinates los <*> coordinates his )
|
||||||
|
where
|
||||||
|
maxAbs :: Double -> Double -> Double
|
||||||
|
maxAbs lo hi = max ( abs lo ) ( abs hi )
|
||||||
|
{-# INLINEABLE maxVI #-}
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Bisect the given box.
|
||||||
|
--
|
||||||
|
-- (The difficult part lies in determining along which coordinate
|
||||||
|
-- dimension to bisect.)
|
||||||
|
bisection
|
||||||
|
:: forall n
|
||||||
|
. ( 1 <= n, KnownNat n, Representable Double ( ℝ n ) )
|
||||||
|
=> ( Box n -> Bool )
|
||||||
|
-- ^ how to check whether a box contains solutions
|
||||||
|
-> ( forall r. NE.NonEmpty ( Fin n, r ) -> ( r, String ) )
|
||||||
|
-- ^ heuristic bisection coordinate picker
|
||||||
|
-> Box n
|
||||||
|
-- ^ the box to bisect
|
||||||
|
-> ( [ Box n ], ( String, Double ) )
|
||||||
|
bisection canHaveSols pickFallbackBisCoord box =
|
||||||
|
case NE.nonEmpty solsList of
|
||||||
|
Nothing ->
|
||||||
|
-- We discarded dimensions along which bisection was useless
|
||||||
|
-- (because the interval was canonical in that dimension).
|
||||||
|
-- If there are no dimensions left, then don't do any bisection.
|
||||||
|
-- (TODO: we shouldn't really ever get here.)
|
||||||
|
( [ box ], ( "noBis", 0 / 0 ) )
|
||||||
|
Just solsNE ->
|
||||||
|
case findFewestSols solsNE of
|
||||||
|
-- If there is a coordinate for which bisection results in no solutions,
|
||||||
|
-- or in fewer sub-boxes with solutions than any other coordinate choice,
|
||||||
|
-- pick that coordinate for bisection.
|
||||||
|
Arg nbSols ( ( i, ( mid, subBoxesWithSols ) ) NE.:| [] ) ->
|
||||||
|
( subBoxesWithSols, ( "cd = " ++ show i ++ "(#subs=" ++ show nbSols ++ ")", mid ) )
|
||||||
|
-- Otherwise, fall back to the provided heuristic.
|
||||||
|
Arg _nbSols is ->
|
||||||
|
let ( ( mid, subBoxesWithSols ), why ) = pickFallbackBisCoord is
|
||||||
|
in ( subBoxesWithSols, ( why, mid ) )
|
||||||
|
where
|
||||||
|
solsList =
|
||||||
|
[ Arg ( fromIntegral $ length subBoxesWithSols ) ( i, ( mid, subBoxesWithSols ) )
|
||||||
|
| i <- toList $ universe @n
|
||||||
|
, let ( mid, subBoxes ) = bisectInCoord box i
|
||||||
|
subBoxesWithSols = NE.filter canHaveSols subBoxes
|
||||||
|
-- discard coordinate dimensions in which the box is a singleton
|
||||||
|
, length subBoxes >= 2 || null subBoxesWithSols
|
||||||
|
]
|
||||||
|
{-# INLINEABLE bisection #-}
|
||||||
|
|
||||||
|
-- | Bisect a box in the given coordinate dimension.
|
||||||
|
bisectInCoord
|
||||||
|
:: Representable Double ( ℝ n )
|
||||||
|
=> Box n -> Fin n -> ( Double, NE.NonEmpty ( Box n ) )
|
||||||
|
bisectInCoord box i =
|
||||||
|
let z = box `index` i
|
||||||
|
zs' = bisect z
|
||||||
|
in ( sup ( NE.head zs' )
|
||||||
|
, fmap ( \ z' -> set i z' box ) zs' )
|
||||||
|
{-# INLINEABLE bisectInCoord #-}
|
||||||
|
|
||||||
|
-- | Return the elements with the least argument.
|
||||||
|
--
|
||||||
|
-- NB: this function shortcuts as soon as it finds an element with argument 0.
|
||||||
|
findFewestSols :: forall a. NE.NonEmpty ( Arg Word a ) -> Arg Word ( NE.NonEmpty a )
|
||||||
|
findFewestSols ( Arg nbSols arg NE.:| args )
|
||||||
|
| nbSols == 0
|
||||||
|
= Arg 0 $ NE.singleton arg
|
||||||
|
| otherwise
|
||||||
|
= go nbSols ( NE.singleton arg ) args
|
||||||
|
where
|
||||||
|
go :: Word -> NE.NonEmpty a -> [ Arg Word a ] -> Arg Word ( NE.NonEmpty a )
|
||||||
|
go bestNbSolsSoFar bestSoFar [] = Arg bestNbSolsSoFar bestSoFar
|
||||||
|
go bestNbSolsSoFar bestSoFar ( ( Arg nbSols' arg' ) : args' )
|
||||||
|
| nbSols' == 0
|
||||||
|
= Arg 0 $ NE.singleton arg'
|
||||||
|
| otherwise
|
||||||
|
= case compare nbSols' bestNbSolsSoFar of
|
||||||
|
LT -> go nbSols' ( NE.singleton arg' ) args'
|
||||||
|
GT -> go bestNbSolsSoFar bestSoFar args'
|
||||||
|
EQ -> go bestNbSolsSoFar ( arg `NE.cons` bestSoFar ) args'
|
265
brush-strokes/src/lib/Math/Root/Isolation/Core.hs
Normal file
265
brush-strokes/src/lib/Math/Root/Isolation/Core.hs
Normal file
|
@ -0,0 +1,265 @@
|
||||||
|
|
||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
|
-- | Core definitions and utilities common to root isolation methods.
|
||||||
|
module Math.Root.Isolation.Core
|
||||||
|
( -- * Root isolation types
|
||||||
|
Box
|
||||||
|
, DoneBoxes(..), noDoneBoxes
|
||||||
|
|
||||||
|
-- * General typeclass for root isolation methods
|
||||||
|
, BoxCt
|
||||||
|
, RootIsolationAlgorithm(..)
|
||||||
|
, RootIsolationAlgorithmWithOptions(..)
|
||||||
|
|
||||||
|
-- ** Inspecting history
|
||||||
|
, RootIsolationStep(IsolationStep, ..)
|
||||||
|
, BoxHistory
|
||||||
|
|
||||||
|
-- ** Visualising history
|
||||||
|
, RootIsolationTree(..)
|
||||||
|
, showRootIsolationTree
|
||||||
|
|
||||||
|
-- * Utility functions
|
||||||
|
, pipeFunctionsWhileTrue
|
||||||
|
, forEachCoord
|
||||||
|
) where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import Data.Foldable
|
||||||
|
( toList )
|
||||||
|
import Data.Kind
|
||||||
|
( Type, Constraint )
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
( NonEmpty )
|
||||||
|
import Data.Type.Equality
|
||||||
|
( (:~~:)(HRefl) )
|
||||||
|
import Data.Typeable
|
||||||
|
( Typeable, heqT )
|
||||||
|
import GHC.TypeNats
|
||||||
|
( Nat, KnownNat, type (<=) )
|
||||||
|
import Numeric
|
||||||
|
( showFFloat )
|
||||||
|
|
||||||
|
-- containers
|
||||||
|
import Data.Tree
|
||||||
|
( Tree(..) )
|
||||||
|
|
||||||
|
-- transformers
|
||||||
|
import Control.Monad.Trans.State.Strict as State
|
||||||
|
( State, get, put )
|
||||||
|
import Control.Monad.Trans.Writer.CPS
|
||||||
|
( Writer )
|
||||||
|
|
||||||
|
-- MetaBrush
|
||||||
|
import Math.Algebra.Dual
|
||||||
|
( D )
|
||||||
|
import Math.Interval
|
||||||
|
import Math.Linear
|
||||||
|
import Math.Module
|
||||||
|
( Module(..) )
|
||||||
|
import Math.Monomial
|
||||||
|
( MonomialBasis(..), Deg, Vars )
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | An axis-aligned box in @n@-dimensions.
|
||||||
|
type Box n = 𝕀ℝ n
|
||||||
|
|
||||||
|
-- | Dimension constraints for root isolation in a system of equations:
|
||||||
|
--
|
||||||
|
-- - @n@: number of variables
|
||||||
|
-- - @d@: number of equations
|
||||||
|
--
|
||||||
|
-- NB: we require n <= d (no support for under-constrained systems).
|
||||||
|
--
|
||||||
|
-- NB: in practice, this constraint should specialise away.
|
||||||
|
type BoxCt n d =
|
||||||
|
( KnownNat n, KnownNat d
|
||||||
|
, 1 <= n, 1 <= d, n <= d
|
||||||
|
|
||||||
|
, Show ( 𝕀ℝ n ), Show ( ℝ n )
|
||||||
|
, Eq ( ℝ n )
|
||||||
|
, Representable Double ( ℝ n )
|
||||||
|
, MonomialBasis ( D 1 ( ℝ n ) )
|
||||||
|
, Deg ( D 1 ( ℝ n ) ) ~ 1
|
||||||
|
, Vars ( D 1 ( ℝ n ) ) ~ n
|
||||||
|
, Module Double ( T ( ℝ n ) )
|
||||||
|
, Module ( 𝕀 Double ) ( T ( 𝕀ℝ n ) )
|
||||||
|
, Applicative ( Vec n )
|
||||||
|
|
||||||
|
, Ord ( ℝ d )
|
||||||
|
, Module Double ( T ( ℝ d ) )
|
||||||
|
, Representable Double ( ℝ d )
|
||||||
|
)
|
||||||
|
|
||||||
|
-- | Boxes we are done with and will not continue processing.
|
||||||
|
data DoneBoxes n =
|
||||||
|
DoneBoxes
|
||||||
|
{ -- | Boxes which definitely contain a unique solution.
|
||||||
|
doneSolBoxes :: ![ Box n ]
|
||||||
|
-- | Boxes which may or may not contain solutions,
|
||||||
|
-- and that we have stopped processing for some reason.
|
||||||
|
, doneGiveUpBoxes :: ![ ( Box n, String ) ]
|
||||||
|
}
|
||||||
|
deriving stock instance Show ( Box n ) => Show ( DoneBoxes n )
|
||||||
|
|
||||||
|
instance Semigroup ( DoneBoxes n ) where
|
||||||
|
DoneBoxes a1 b1 <> DoneBoxes a2 b2 = DoneBoxes ( a1 <> a2 ) ( b1 <> b2 )
|
||||||
|
instance Monoid ( DoneBoxes n ) where
|
||||||
|
mempty = noDoneBoxes
|
||||||
|
noDoneBoxes :: DoneBoxes n
|
||||||
|
noDoneBoxes = DoneBoxes [] []
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Class for all root isolation algorithms.
|
||||||
|
--
|
||||||
|
-- This keeps the implementation open-ended, and allows inspection of
|
||||||
|
-- other root isolation methods, so that heuristics can look at
|
||||||
|
-- what happened in previous steps to decide what to do.
|
||||||
|
|
||||||
|
-- | Existential wrapper over any root isolation algorithm,
|
||||||
|
-- with the options necessary to run it.
|
||||||
|
data RootIsolationAlgorithmWithOptions n d where
|
||||||
|
AlgoWithOptions
|
||||||
|
:: RootIsolationAlgorithm ty
|
||||||
|
=> RootIsolationAlgorithmOptions ty n d
|
||||||
|
-> RootIsolationAlgorithmWithOptions n d
|
||||||
|
|
||||||
|
-- | Type-class for root isolation algorithms.
|
||||||
|
--
|
||||||
|
-- This design keeps the set of root isolation algorithms open-ended,
|
||||||
|
-- while retaining the ability to inspect previous steps (using the
|
||||||
|
-- 'IsolationStep' pattern).
|
||||||
|
type RootIsolationAlgorithm :: forall {k}. k -> Constraint
|
||||||
|
class ( Typeable ty, Show ( StepDescription ty ) )
|
||||||
|
=> RootIsolationAlgorithm ty where
|
||||||
|
-- | The type of additional information about an algorithm step.
|
||||||
|
--
|
||||||
|
-- Only really useful for debugging; gets stored in 'RootIsolationTree's.
|
||||||
|
type StepDescription ty
|
||||||
|
-- | Configuration options expected by this root isolation method.
|
||||||
|
type RootIsolationAlgorithmOptions ty (n :: Nat) (d :: Nat) = r | r -> ty n d
|
||||||
|
-- | Run one step of the root isolation method.
|
||||||
|
--
|
||||||
|
-- This gets given the equations and a box, and should attempt to
|
||||||
|
-- shrink the box in some way, returning smaller boxes.
|
||||||
|
--
|
||||||
|
-- Should return:
|
||||||
|
--
|
||||||
|
-- - a description of the step taken (see 'StepDescription'),
|
||||||
|
-- - new boxes to process (the return value of type @['Box' n]@),
|
||||||
|
-- which can be empty if the algorithm can prove that the input
|
||||||
|
-- bix does not contain any solutions;
|
||||||
|
-- - (as a writer side-effect) boxes to definitely stop processing; see 'DoneBoxes'.
|
||||||
|
rootIsolationAlgorithm
|
||||||
|
:: forall (n :: Nat) (d :: Nat)
|
||||||
|
. BoxCt n d
|
||||||
|
=> RootIsolationAlgorithmOptions ty n d
|
||||||
|
-- ^ options for this root isolation algorithm
|
||||||
|
-> [ ( RootIsolationStep, Box n ) ]
|
||||||
|
-- ^ history of the current round
|
||||||
|
-> BoxHistory n
|
||||||
|
-- ^ previous rounds history
|
||||||
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
|
-- ^ equations
|
||||||
|
-> Box n
|
||||||
|
-- ^ box
|
||||||
|
-> Writer ( DoneBoxes n ) ( StepDescription ty, [ Box n ] )
|
||||||
|
|
||||||
|
-- | Match on an unknown root isolation algorithm step with a known algorithm.
|
||||||
|
pattern IsolationStep
|
||||||
|
:: forall (ty :: Type)
|
||||||
|
. RootIsolationAlgorithm ty
|
||||||
|
=> StepDescription ty -> RootIsolationStep
|
||||||
|
pattern IsolationStep stepDescr
|
||||||
|
<- ( rootIsolationAlgorithmStep_maybe @ty -> Just stepDescr )
|
||||||
|
where
|
||||||
|
IsolationStep stepDescr = SomeRootIsolationStep @ty stepDescr
|
||||||
|
|
||||||
|
-- | Helper function used to define the 'IsolationStep' pattern.
|
||||||
|
--
|
||||||
|
-- Inspects whether an existential 'RootIsolationStep' packs a step for
|
||||||
|
-- the given algorithm.
|
||||||
|
rootIsolationAlgorithmStep_maybe
|
||||||
|
:: forall ty. RootIsolationAlgorithm ty
|
||||||
|
=> RootIsolationStep -> Maybe ( StepDescription ty )
|
||||||
|
rootIsolationAlgorithmStep_maybe ( SomeRootIsolationStep @existential descr )
|
||||||
|
| Just HRefl <- heqT @existential @ty
|
||||||
|
= Just descr
|
||||||
|
| otherwise
|
||||||
|
= Nothing
|
||||||
|
{-# INLINEABLE rootIsolationAlgorithmStep_maybe #-}
|
||||||
|
|
||||||
|
-- | History for a given box: what was the outcome of previous root isolation
|
||||||
|
-- methods?
|
||||||
|
type BoxHistory n = [ NE.NonEmpty ( RootIsolationStep, Box n ) ]
|
||||||
|
|
||||||
|
-- | A description of a step taken when isolating roots.
|
||||||
|
data RootIsolationStep where
|
||||||
|
SomeRootIsolationStep
|
||||||
|
:: forall step
|
||||||
|
. ( Typeable step
|
||||||
|
, Show ( StepDescription step )
|
||||||
|
)
|
||||||
|
=> StepDescription step
|
||||||
|
-> RootIsolationStep
|
||||||
|
|
||||||
|
instance Show RootIsolationStep where
|
||||||
|
showsPrec p ( SomeRootIsolationStep stepDescr ) = showsPrec p stepDescr
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Trees recording steps taken by the algorithm, for visualisation & debugging.
|
||||||
|
|
||||||
|
-- | A tree recording the steps taken when isolating roots.
|
||||||
|
data RootIsolationTree d
|
||||||
|
= RootIsolationLeaf String d
|
||||||
|
| RootIsolationStep RootIsolationStep [ ( d, RootIsolationTree d ) ]
|
||||||
|
|
||||||
|
showRootIsolationTree
|
||||||
|
:: ( Representable Double ( ℝ n ), Show ( Box n ) )
|
||||||
|
=> Box n -> RootIsolationTree ( Box n ) -> Tree String
|
||||||
|
showRootIsolationTree cand (RootIsolationLeaf why l) = Node (show cand ++ " " ++ showArea (boxArea cand) ++ " " ++ why ++ " " ++ show l) []
|
||||||
|
showRootIsolationTree cand (RootIsolationStep s ts)
|
||||||
|
= Node (show cand ++ " abc " ++ showArea (boxArea cand) ++ " " ++ show s) $ map (\ (c,t) -> showRootIsolationTree c t) ts
|
||||||
|
|
||||||
|
boxArea :: Representable Double ( ℝ n ) => Box n -> Double
|
||||||
|
boxArea ( 𝕀 lo hi ) =
|
||||||
|
product ( ( \ l h -> abs ( h - l ) ) <$> coordinates lo <*> coordinates hi )
|
||||||
|
|
||||||
|
showArea :: Double -> String
|
||||||
|
showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Utilities.
|
||||||
|
|
||||||
|
-- | Run an effectful computation several times in sequence, piping its output
|
||||||
|
-- into the next input, once for each coordinate dimension.
|
||||||
|
forEachCoord :: forall n a m. ( KnownNat n, Monad m ) => a -> ( Fin n -> a -> m a ) -> m a
|
||||||
|
forEachCoord a0 f = go ( toList $ universe @n ) a0
|
||||||
|
where
|
||||||
|
go [] a = return a
|
||||||
|
go ( i : is ) a = do
|
||||||
|
a' <- f i a
|
||||||
|
go is a'
|
||||||
|
{-# INLINEABLE forEachCoord #-}
|
||||||
|
|
||||||
|
-- | Apply each function in turn, piping the output of one function into
|
||||||
|
-- the next.
|
||||||
|
--
|
||||||
|
-- Once all the functions have been applied, check whether the Bool is True.
|
||||||
|
-- If it is, go around again with all the functions; otherwise, stop.
|
||||||
|
pipeFunctionsWhileTrue :: [ a -> State Bool [ a ] ] -> a -> State Bool [ a ]
|
||||||
|
pipeFunctionsWhileTrue fns = go fns
|
||||||
|
where
|
||||||
|
go [] x = do
|
||||||
|
doAnotherRound <- State.get
|
||||||
|
if doAnotherRound
|
||||||
|
then do { State.put False ; go fns x }
|
||||||
|
else return [ x ]
|
||||||
|
go ( f : fs ) x = do
|
||||||
|
xs <- f x
|
||||||
|
concat <$> traverse ( go fs ) xs
|
239
brush-strokes/src/lib/Math/Root/Isolation/GaussSeidel.hs
Normal file
239
brush-strokes/src/lib/Math/Root/Isolation/GaussSeidel.hs
Normal file
|
@ -0,0 +1,239 @@
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
module Math.Root.Isolation.GaussSeidel
|
||||||
|
( -- * The interval Newton method with Gauss–Seidel step
|
||||||
|
GaussSeidel
|
||||||
|
, intervalGaussSeidel
|
||||||
|
|
||||||
|
-- ** Configuration options
|
||||||
|
, GaussSeidelOptions(..), Preconditioner(..)
|
||||||
|
, defaultGaussSeidelOptions
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import Control.Arrow
|
||||||
|
( first )
|
||||||
|
import Data.Bifunctor
|
||||||
|
( Bifunctor(bimap) )
|
||||||
|
import Data.Coerce
|
||||||
|
( coerce )
|
||||||
|
import Data.Kind
|
||||||
|
( Type )
|
||||||
|
import Data.Foldable
|
||||||
|
( toList )
|
||||||
|
import Data.List
|
||||||
|
( partition )
|
||||||
|
import Data.Proxy
|
||||||
|
( Proxy(..) )
|
||||||
|
import Data.Type.Ord
|
||||||
|
( OrderingI(..) )
|
||||||
|
import GHC.TypeNats
|
||||||
|
( Nat, KnownNat, type (<=), cmpNat )
|
||||||
|
|
||||||
|
-- eigen
|
||||||
|
import qualified Eigen.Matrix as Eigen
|
||||||
|
( Matrix
|
||||||
|
, determinant, generate, inverse, unsafeCoeff
|
||||||
|
)
|
||||||
|
|
||||||
|
-- transformers
|
||||||
|
import Control.Monad.Trans.Writer.CPS
|
||||||
|
( Writer, tell )
|
||||||
|
|
||||||
|
-- MetaBrush
|
||||||
|
import Math.Algebra.Dual
|
||||||
|
( D )
|
||||||
|
import Math.Epsilon
|
||||||
|
( nearZero )
|
||||||
|
import Math.Interval
|
||||||
|
import Math.Linear
|
||||||
|
import Math.Module
|
||||||
|
( Module(..) )
|
||||||
|
import Math.Monomial
|
||||||
|
( MonomialBasis(..), linearMonomial, zeroMonomial )
|
||||||
|
import Math.Root.Isolation.Core
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Gauss–Seidel
|
||||||
|
|
||||||
|
-- | The interval Newton method with a Gauss–Seidel step; see 'intervalGaussSeidel'.
|
||||||
|
data GaussSeidel
|
||||||
|
instance RootIsolationAlgorithm GaussSeidel where
|
||||||
|
type instance StepDescription GaussSeidel = ()
|
||||||
|
type instance RootIsolationAlgorithmOptions GaussSeidel n d = GaussSeidelOptions n d
|
||||||
|
rootIsolationAlgorithm opts _thisRoundHist _prevRoundsHist eqs box = do
|
||||||
|
res <- intervalGaussSeidel opts eqs box
|
||||||
|
return ( (), res )
|
||||||
|
{-# INLINEABLE rootIsolationAlgorithm #-}
|
||||||
|
|
||||||
|
-- | Options for the interval Gauss–Seidel method.
|
||||||
|
type GaussSeidelOptions :: Nat -> Nat -> Type
|
||||||
|
data GaussSeidelOptions n d =
|
||||||
|
GaussSeidelOptions
|
||||||
|
{ -- | Which preconditioner to user?
|
||||||
|
gsPreconditioner :: !Preconditioner
|
||||||
|
-- | Function that projects over the equations we will consider
|
||||||
|
-- (the identity for a well-determined problem, or a projection for
|
||||||
|
-- an overdetermined system).
|
||||||
|
, gsPickEqs :: ( 𝕀ℝ d -> 𝕀ℝ n ) }
|
||||||
|
|
||||||
|
-- | Default options for the interval Gauss–Seidel method.
|
||||||
|
defaultGaussSeidelOptions
|
||||||
|
:: forall n d
|
||||||
|
. ( KnownNat n, KnownNat d
|
||||||
|
, 1 <= n, 1 <= d, n <= d
|
||||||
|
, Representable Double ( ℝ n )
|
||||||
|
, Representable Double ( ℝ d )
|
||||||
|
)
|
||||||
|
=> BoxHistory n
|
||||||
|
-> GaussSeidelOptions n d
|
||||||
|
defaultGaussSeidelOptions history =
|
||||||
|
GaussSeidelOptions
|
||||||
|
{ gsPreconditioner = InverseMidJacobian
|
||||||
|
, gsPickEqs =
|
||||||
|
case cmpNat @n @d Proxy Proxy of
|
||||||
|
EQI -> id
|
||||||
|
LTI ->
|
||||||
|
-- If there are more equations (d) than variables (n),
|
||||||
|
-- pick a size n subset of the variables
|
||||||
|
-- (go through all combinations cyclically).
|
||||||
|
let choices :: [ Vec n ( Fin d ) ]
|
||||||
|
choices = choose @d @n
|
||||||
|
choice :: Vec n ( Fin d )
|
||||||
|
choice = choices !! ( length history `mod` length choices )
|
||||||
|
in \ u -> tabulate \ i -> index u ( choice ! i )
|
||||||
|
}
|
||||||
|
{-# INLINEABLE defaultGaussSeidelOptions #-}
|
||||||
|
|
||||||
|
-- | Preconditioner to use with the interval Gauss–Seidel method.
|
||||||
|
data Preconditioner
|
||||||
|
= NoPreconditioning
|
||||||
|
| InverseMidJacobian
|
||||||
|
deriving stock Show
|
||||||
|
|
||||||
|
-- | Interval Newton method with Gauss–Seidel step.
|
||||||
|
intervalGaussSeidel
|
||||||
|
:: forall n d
|
||||||
|
. BoxCt n d
|
||||||
|
=> GaussSeidelOptions n d
|
||||||
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
|
-- ^ equations
|
||||||
|
-> 𝕀ℝ n
|
||||||
|
-- ^ box
|
||||||
|
-> Writer ( DoneBoxes n ) [ 𝕀ℝ n ]
|
||||||
|
intervalGaussSeidel
|
||||||
|
( GaussSeidelOptions { gsPreconditioner = precondMeth, gsPickEqs = pickEqs } )
|
||||||
|
eqs
|
||||||
|
box
|
||||||
|
| let boxMid = singleton $ boxMidpoint box
|
||||||
|
f' :: Vec n ( 𝕀ℝ n )
|
||||||
|
f' = fmap ( \ i -> pickEqs $ eqs box `monIndex` linearMonomial i ) ( universe @n )
|
||||||
|
f_mid = pickEqs $ eqs boxMid `monIndex` zeroMonomial
|
||||||
|
|
||||||
|
= let -- Interval Newton method: take one Gauss–Seidel step
|
||||||
|
-- for the system of equations f'(x) ( x - x_mid ) = - f(x_mid).
|
||||||
|
( a, b ) = precondition precondMeth
|
||||||
|
( fmap boxMidpoint f' )
|
||||||
|
f' ( singleton $ unT $ -1 *^ T ( boxMidpoint f_mid ) )
|
||||||
|
|
||||||
|
-- NB: we have to change coordinates, putting the midpoint of the box
|
||||||
|
-- at the origin, in order to take a Gauss–Seidel step.
|
||||||
|
gsGuesses = map ( first ( \ box' -> unT $ box' ^+^ T boxMid ) )
|
||||||
|
$ gaussSeidelStep a b ( T box ^-^ T boxMid )
|
||||||
|
in
|
||||||
|
-- If the Gauss–Seidel 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 fst ) ( map fst )
|
||||||
|
$ partition snd gsGuesses
|
||||||
|
in do tell $ noDoneBoxes { doneSolBoxes = done }
|
||||||
|
return todo
|
||||||
|
where
|
||||||
|
{-# INLINEABLE intervalGaussSeidel #-}
|
||||||
|
|
||||||
|
-- | Take one interval Gauss–Seidel step for the equation \( A X = B \),
|
||||||
|
-- refining the initial guess box for \( X \) into up to \( 2^n \) (disjoint) new boxes.
|
||||||
|
--
|
||||||
|
-- The boolean indicates whether the Gauss–Seidel step was a contraction.
|
||||||
|
gaussSeidelStep
|
||||||
|
:: forall n
|
||||||
|
. ( Representable Double ( ℝ n ), Eq ( ℝ n ) )
|
||||||
|
=> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
||||||
|
-> 𝕀ℝ n -- ^ \( B \)
|
||||||
|
-> T ( 𝕀ℝ n ) -- ^ initial box \( X \)
|
||||||
|
-> [ ( T ( 𝕀ℝ n ), Bool ) ]
|
||||||
|
gaussSeidelStep as b ( T x0 ) = coerce $
|
||||||
|
forEachCoord @n ( x0, True ) $ \ i ( x, contraction ) -> do
|
||||||
|
-- x_i' = ( b_i - sum { j /= i } a_ij * x_j ) / a_ii
|
||||||
|
x_i'0 <- ( b `index` i - sum [ ( as ! j ) `index` i * x `index` j | j <- toList ( universe @n ), j /= i ] )
|
||||||
|
`extendedDivide` ( ( as ! i ) `index` i )
|
||||||
|
( x_i', sub_i ) <- x_i'0 `intersect` ( x `index` i )
|
||||||
|
return $ ( set i x_i' x, sub_i && contraction )
|
||||||
|
-- TODO: try implementing the complete interval union Gauss–Seidel algorithm.
|
||||||
|
-- See "Algorithm 2" in
|
||||||
|
-- "Using interval unions to solve linear systems of equations with uncertainties"
|
||||||
|
{-# INLINEABLE gaussSeidelStep #-}
|
||||||
|
|
||||||
|
-- | The midpoint of a box.
|
||||||
|
boxMidpoint :: Representable Double ( ℝ n ) => 𝕀ℝ n -> ℝ n
|
||||||
|
boxMidpoint box =
|
||||||
|
tabulate $ \ i ->
|
||||||
|
let 𝕀 z_lo z_hi = index box i
|
||||||
|
z_mid = 0.5 * ( z_lo + z_hi )
|
||||||
|
in z_mid
|
||||||
|
{-# INLINEABLE boxMidpoint #-}
|
||||||
|
|
||||||
|
-- | Pre-condition the system \( AX = B \).
|
||||||
|
precondition
|
||||||
|
:: forall n
|
||||||
|
. ( KnownNat n, Representable Double ( ℝ n ) )
|
||||||
|
=> Preconditioner -- ^ pre-conditioning method to use
|
||||||
|
-> Vec n ( ℝ n ) -- ^ entry-wise midpoint matrix of the interval Jacobian matrix
|
||||||
|
-> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
||||||
|
-> 𝕀ℝ n -- ^ \( B \)
|
||||||
|
-> ( Vec n ( 𝕀ℝ n ), 𝕀ℝ n )
|
||||||
|
precondition meth jac_mid as b =
|
||||||
|
case meth of
|
||||||
|
NoPreconditioning
|
||||||
|
-> ( as, b )
|
||||||
|
InverseMidJacobian
|
||||||
|
| let mat = toEigen jac_mid
|
||||||
|
det = Eigen.determinant mat
|
||||||
|
, not $ nearZero det
|
||||||
|
-- (TODO: a bit wasteful to compute determinant then inverse.)
|
||||||
|
, let precond = Eigen.inverse mat
|
||||||
|
doPrecond = matMulVec ( fromEigen precond )
|
||||||
|
-> ( fmap doPrecond as, doPrecond b )
|
||||||
|
| otherwise
|
||||||
|
-> ( as, b )
|
||||||
|
where
|
||||||
|
toEigen :: Vec n ( ℝ n ) -> Eigen.Matrix n n Double
|
||||||
|
toEigen cols =
|
||||||
|
Eigen.generate $ \ r c ->
|
||||||
|
( cols ! Fin ( fromIntegral c + 1 ) ) `index` ( Fin ( fromIntegral r + 1 ) )
|
||||||
|
|
||||||
|
fromEigen :: Eigen.Matrix n n Double -> Vec n ( ℝ n )
|
||||||
|
fromEigen mat =
|
||||||
|
fmap
|
||||||
|
( \ ( Fin c ) ->
|
||||||
|
tabulate $ \ ( Fin r ) ->
|
||||||
|
Eigen.unsafeCoeff ( fromIntegral r - 1 ) ( fromIntegral c - 1 ) mat
|
||||||
|
)
|
||||||
|
( universe @n )
|
||||||
|
{-# INLINEABLE precondition #-}
|
||||||
|
|
||||||
|
-- | Matrix multiplication \( A v \).
|
||||||
|
matMulVec
|
||||||
|
:: forall n m
|
||||||
|
. ( Representable Double ( ℝ n ), Representable Double ( ℝ m ) )
|
||||||
|
=> Vec m ( ℝ n ) -- ^ columns of the matrix \( A )
|
||||||
|
-> 𝕀ℝ m -- ^ vector \( v \)
|
||||||
|
-> 𝕀ℝ n
|
||||||
|
matMulVec as v = tabulate $ \ r ->
|
||||||
|
sum [ scaleInterval ( a `index` r ) ( index v c )
|
||||||
|
| ( c, a ) <- toList ( (,) <$> universe @m <*> as )
|
||||||
|
]
|
||||||
|
{-# INLINEABLE matMulVec #-}
|
490
brush-strokes/src/lib/Math/Root/Isolation/Narrowing.hs
Normal file
490
brush-strokes/src/lib/Math/Root/Isolation/Narrowing.hs
Normal file
|
@ -0,0 +1,490 @@
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
module Math.Root.Isolation.Narrowing
|
||||||
|
( -- * @box(1)@-consistency
|
||||||
|
Box1
|
||||||
|
, makeBox1Consistent
|
||||||
|
-- ** Configuration options
|
||||||
|
, Box1Options(..)
|
||||||
|
, defaultBox1Options
|
||||||
|
|
||||||
|
, -- *** Narrowing methods for @box(1)@-consistency
|
||||||
|
NarrowingMethod(..)
|
||||||
|
, narrowingMethods
|
||||||
|
|
||||||
|
-- **** Options for the adaptive shaving method
|
||||||
|
, AdaptiveShavingOptions(..)
|
||||||
|
, defaultAdaptiveShavingOptions
|
||||||
|
|
||||||
|
-- * @box(2)@-consistency
|
||||||
|
, Box2
|
||||||
|
, makeBox2Consistent
|
||||||
|
|
||||||
|
-- ** Configuration options
|
||||||
|
, Box2Options(..)
|
||||||
|
, defaultBox2Options
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import Control.Monad
|
||||||
|
( when )
|
||||||
|
import Data.Foldable
|
||||||
|
( toList )
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
( toList )
|
||||||
|
import GHC.TypeNats
|
||||||
|
( KnownNat )
|
||||||
|
|
||||||
|
-- transformers
|
||||||
|
import Control.Monad.Trans.State.Strict as State
|
||||||
|
( State, evalState, get, put )
|
||||||
|
|
||||||
|
-- brush-strokes
|
||||||
|
import Math.Algebra.Dual
|
||||||
|
( D )
|
||||||
|
import Math.Float.Utils
|
||||||
|
( succFP, prevFP )
|
||||||
|
import Math.Interval
|
||||||
|
import Math.Linear
|
||||||
|
( ℝ
|
||||||
|
, Representable
|
||||||
|
, Fin, set, index, universe
|
||||||
|
)
|
||||||
|
import Math.Monomial
|
||||||
|
( MonomialBasis(..), Deg, Vars
|
||||||
|
, zeroMonomial, linearMonomial
|
||||||
|
)
|
||||||
|
import Math.Root.Isolation.Core
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Box-consistency driver code
|
||||||
|
|
||||||
|
-- | A @box(1)@-consistency enforcing algorithm; see 'makeBox1Consistent'.
|
||||||
|
data Box1
|
||||||
|
instance RootIsolationAlgorithm Box1 where
|
||||||
|
type instance StepDescription Box1 = ()
|
||||||
|
type instance RootIsolationAlgorithmOptions Box1 n d = Box1Options n d
|
||||||
|
rootIsolationAlgorithm opts _thisRoundHist _prevRoundsHist eqs box =
|
||||||
|
return $ ( (), makeBox1Consistent opts eqs box )
|
||||||
|
{-# INLINEABLE rootIsolationAlgorithm #-}
|
||||||
|
|
||||||
|
-- | A @box(2)@-consistency enforcing algorithm; see 'makeBox1Consistent'.
|
||||||
|
data Box2
|
||||||
|
instance RootIsolationAlgorithm Box2 where
|
||||||
|
type instance StepDescription Box2 = ()
|
||||||
|
type instance RootIsolationAlgorithmOptions Box2 n d = Box2Options n d
|
||||||
|
rootIsolationAlgorithm opts _thisRoundHist _prevRoundsHist eqs box =
|
||||||
|
return ( () , [ makeBox2Consistent opts eqs box ] )
|
||||||
|
{-# INLINEABLE rootIsolationAlgorithm #-}
|
||||||
|
|
||||||
|
-- | Options for the @box(1)@-consistency method.
|
||||||
|
data Box1Options n d =
|
||||||
|
Box1Options
|
||||||
|
{ box1EpsEq :: !Double
|
||||||
|
, box1EpsBis :: !Double
|
||||||
|
, box1CoordsToNarrow :: !( [ Fin n ] )
|
||||||
|
, box1EqsToUse :: !( [ Fin d ] )
|
||||||
|
, box1NarrowingMethod :: !NarrowingMethod
|
||||||
|
}
|
||||||
|
deriving stock Show
|
||||||
|
|
||||||
|
-- | Options for the @box(2)@-consistency method.
|
||||||
|
data Box2Options n d =
|
||||||
|
Box2Options
|
||||||
|
{ box2Box1Options :: !( Box1Options n d )
|
||||||
|
, box2EpsEq :: !Double
|
||||||
|
, box2LambdaMin :: !Double
|
||||||
|
}
|
||||||
|
deriving stock Show
|
||||||
|
|
||||||
|
-- | Default options for the @box(1)@-consistency method.
|
||||||
|
defaultBox1Options
|
||||||
|
:: forall n d
|
||||||
|
. ( KnownNat n, KnownNat d )
|
||||||
|
=> Double -- ^ minimum width of boxes (don't bisect further)
|
||||||
|
-> Double -- ^ threshold for progress
|
||||||
|
-> Box1Options n d
|
||||||
|
defaultBox1Options minWidth ε_eq =
|
||||||
|
Box1Options
|
||||||
|
{ box1EpsEq = ε_eq
|
||||||
|
, box1EpsBis = minWidth
|
||||||
|
, box1CoordsToNarrow = toList $ universe @n
|
||||||
|
, box1EqsToUse = toList $ universe @d
|
||||||
|
, box1NarrowingMethod = Kubica
|
||||||
|
}
|
||||||
|
{-# INLINEABLE defaultBox1Options #-}
|
||||||
|
|
||||||
|
-- | Default options for the @box(2)@-consistency method.
|
||||||
|
defaultBox2Options
|
||||||
|
:: forall n d
|
||||||
|
. ( KnownNat n, KnownNat d )
|
||||||
|
=> Double -- ^ minimum width of boxes (don't bisect further)
|
||||||
|
-> Double -- ^ threshold for progress
|
||||||
|
-> Box2Options n d
|
||||||
|
defaultBox2Options minWidth ε_eq =
|
||||||
|
Box2Options
|
||||||
|
{ box2Box1Options = defaultBox1Options minWidth ε_eq
|
||||||
|
, box2EpsEq = ε_eq
|
||||||
|
, box2LambdaMin = 0.001
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
:: ( KnownNat n, Representable Double ( ℝ n )
|
||||||
|
, MonomialBasis ( D 1 ( ℝ n ) )
|
||||||
|
, Deg ( D 1 ( ℝ n ) ) ~ 1
|
||||||
|
, Vars ( D 1 ( ℝ n ) ) ~ n
|
||||||
|
, Representable Double ( ℝ d )
|
||||||
|
)
|
||||||
|
=> Box1Options n d
|
||||||
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
|
-> 𝕀ℝ n -> [ 𝕀ℝ n ]
|
||||||
|
makeBox1Consistent box1Options eqs x =
|
||||||
|
( `State.evalState` False ) $
|
||||||
|
pipeFunctionsWhileTrue ( allNarrowingOperators box1Options eqs ) x
|
||||||
|
{-# INLINEABLE defaultBox2Options #-}
|
||||||
|
|
||||||
|
-- | An implementation of "bound-consistency" from the paper
|
||||||
|
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
|
||||||
|
makeBox2Consistent
|
||||||
|
:: forall n d
|
||||||
|
. ( KnownNat n, Representable Double ( ℝ n )
|
||||||
|
, MonomialBasis ( D 1 ( ℝ n ) )
|
||||||
|
, Deg ( D 1 ( ℝ n ) ) ~ 1
|
||||||
|
, Vars ( D 1 ( ℝ n ) ) ~ n
|
||||||
|
, Representable Double ( ℝ d )
|
||||||
|
)
|
||||||
|
=> Box2Options n d
|
||||||
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
|
-> 𝕀ℝ n -> 𝕀ℝ n
|
||||||
|
makeBox2Consistent (Box2Options box1Options ε_eq λMin) eqs x0
|
||||||
|
= ( `State.evalState` False ) $ doLoop 0.25 x0
|
||||||
|
where
|
||||||
|
doBox1 :: 𝕀ℝ n -> [ 𝕀ℝ n ]
|
||||||
|
doBox1 = makeBox1Consistent box1Options eqs
|
||||||
|
doLoop :: Double -> 𝕀ℝ n -> State Bool ( 𝕀ℝ n )
|
||||||
|
doLoop λ x = do
|
||||||
|
x'' <- forEachCoord @n x $ boundConsistency λ
|
||||||
|
modified <- State.get
|
||||||
|
let λ' = if modified then λ else 0.5 * λ
|
||||||
|
if λ' < λMin
|
||||||
|
then return x''
|
||||||
|
else do { State.put False ; doLoop λ' x'' }
|
||||||
|
|
||||||
|
boundConsistency :: Double -> Fin n -> 𝕀ℝ n -> State Bool ( 𝕀ℝ n )
|
||||||
|
boundConsistency λ i box = do
|
||||||
|
let x@( 𝕀 x_inf x_sup ) = getter box
|
||||||
|
c1 = ( 1 - λ ) * x_inf + λ * x_sup
|
||||||
|
c2 = λ * x_inf + ( 1 - λ ) * x_sup
|
||||||
|
x'_inf =
|
||||||
|
case doBox1 ( setter ( 𝕀 x_inf c1 ) box ) of
|
||||||
|
[] -> c1
|
||||||
|
x's -> minimum $ map ( inf . getter ) x's
|
||||||
|
x'_sup =
|
||||||
|
case doBox1 ( 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' >= ε_eq ) $
|
||||||
|
State.put True
|
||||||
|
return $ setter x' box
|
||||||
|
where
|
||||||
|
getter = ( `index` i )
|
||||||
|
setter = set i
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Narrowing methods
|
||||||
|
|
||||||
|
-- | The narrowing method to use to enforce @box(1)@-consistency.
|
||||||
|
data NarrowingMethod
|
||||||
|
-- | Algorithm 5 from the paper
|
||||||
|
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
|
||||||
|
-- (Bartłomiej Jacek Kubica, 2017)
|
||||||
|
= Kubica
|
||||||
|
-- | Two-sided shaving @sbc@ from the paper
|
||||||
|
-- "A Data-Parallel Algorithm to Reliably Solve Systems of Nonlinear Equations",
|
||||||
|
-- (Goldsztejn & Goualard, 2008)
|
||||||
|
| TwoSidedShaving
|
||||||
|
-- | @sbc3ag@ (adaptive guessing) shaving, from the paper
|
||||||
|
-- "Box Consistency through Adaptive Shaving"
|
||||||
|
-- (Goldsztejn & Goualard, 2010).
|
||||||
|
| AdaptiveShaving AdaptiveShavingOptions
|
||||||
|
deriving stock Show
|
||||||
|
|
||||||
|
narrowingMethods
|
||||||
|
:: Double -> Double
|
||||||
|
-> NarrowingMethod
|
||||||
|
-> [ ( 𝕀 Double -> ( 𝕀 Double, 𝕀 Double ) ) -> 𝕀 Double -> [ 𝕀 Double ] ]
|
||||||
|
narrowingMethods ε_eq ε_bis Kubica
|
||||||
|
= [ leftNarrow ε_eq ε_bis, rightNarrow ε_eq ε_bis ]
|
||||||
|
narrowingMethods ε_eq ε_bis ( AdaptiveShaving opts )
|
||||||
|
= [ leftShave ε_eq ε_bis opts, rightNarrow ε_eq ε_bis ]
|
||||||
|
-- TODO: haven't implemented right shaving yet
|
||||||
|
narrowingMethods _ε_eq ε_bis TwoSidedShaving
|
||||||
|
= [ sbc ε_bis ]
|
||||||
|
{-# INLINE narrowingMethods #-}
|
||||||
|
|
||||||
|
allNarrowingOperators
|
||||||
|
:: forall n d
|
||||||
|
. ( KnownNat n, Representable Double ( ℝ n )
|
||||||
|
, MonomialBasis ( D 1 ( ℝ n ) )
|
||||||
|
, Deg ( D 1 ( ℝ n ) ) ~ 1
|
||||||
|
, Vars ( D 1 ( ℝ n ) ) ~ n
|
||||||
|
, Representable Double ( ℝ d )
|
||||||
|
)
|
||||||
|
=> Box1Options n d
|
||||||
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
|
-> [ 𝕀ℝ n -> State Bool [ 𝕀ℝ n ] ]
|
||||||
|
allNarrowingOperators ( Box1Options ε_eq ε_bis coordsToNarrow eqsToUse narrowingMethod ) eqs =
|
||||||
|
[ \ cand ->
|
||||||
|
let getter = ( `index` coordIndex )
|
||||||
|
setter = set coordIndex
|
||||||
|
newCands = map ( `setter` cand )
|
||||||
|
$ narrowFn ( \ box -> ff' coordIndex eqnIndex $ setter box cand )
|
||||||
|
( getter cand )
|
||||||
|
in do
|
||||||
|
-- Record when we achieved a meaningful reduction,
|
||||||
|
-- so that we continue trying further narrowings.
|
||||||
|
when ( ( width ( getter cand ) - sum ( map ( width . getter ) newCands ) ) >= ε_eq ) $
|
||||||
|
-- NB: making this return 'True' less often seems slightly beneficial?
|
||||||
|
-- Further investigation needed.
|
||||||
|
State.put True
|
||||||
|
return newCands
|
||||||
|
| narrowFn <- narrowingMethods ε_eq ε_bis narrowingMethod
|
||||||
|
, coordIndex <- coordsToNarrow
|
||||||
|
, eqnIndex <- eqsToUse
|
||||||
|
]
|
||||||
|
where
|
||||||
|
ff' :: Fin n -> Fin d -> 𝕀ℝ n -> ( 𝕀 Double, 𝕀 Double )
|
||||||
|
ff' i d ts =
|
||||||
|
let df = eqs ts
|
||||||
|
f, f' :: 𝕀ℝ d
|
||||||
|
f = df `monIndex` zeroMonomial
|
||||||
|
f' = df `monIndex` linearMonomial i
|
||||||
|
in ( f `index` d, f' `index` d )
|
||||||
|
{-# INLINEABLE allNarrowingOperators #-}
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Kubica's algorithm.
|
||||||
|
|
||||||
|
-- Use the univariate interval Newton method to narrow from the left
|
||||||
|
-- a candidate interval.
|
||||||
|
--
|
||||||
|
-- See Algorithm 5 (Procedure left_narrow) in
|
||||||
|
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
|
||||||
|
-- by Bartłomiej Jacek Kubica, 2017
|
||||||
|
leftNarrow :: Double
|
||||||
|
-> Double
|
||||||
|
-> ( 𝕀 Double -> ( 𝕀 Double, 𝕀 Double ) )
|
||||||
|
-> 𝕀 Double
|
||||||
|
-> [ 𝕀 Double ]
|
||||||
|
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 ) )
|
||||||
|
go x_sup x_left =
|
||||||
|
let ( f_x_left, _f'_x_left ) = ff' x_left
|
||||||
|
in
|
||||||
|
if inf f_x_left <= 0 && sup f_x_left >= 0
|
||||||
|
then [ 𝕀 ( inf x_left ) x_sup ]
|
||||||
|
else
|
||||||
|
let x = 𝕀 ( sup x_left ) x_sup
|
||||||
|
( _f_x, f'_x ) = ff' x
|
||||||
|
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 ) ) < ε_eq
|
||||||
|
-> x's
|
||||||
|
| otherwise
|
||||||
|
-> do
|
||||||
|
x' <- x's
|
||||||
|
if sup x' - inf x' < ε_bis
|
||||||
|
then return x'
|
||||||
|
else left_narrow =<< NE.toList ( bisect x' )
|
||||||
|
|
||||||
|
-- TODO: de-duplicate with 'leftNarrow'?
|
||||||
|
rightNarrow :: Double
|
||||||
|
-> Double
|
||||||
|
-> ( 𝕀 Double -> ( 𝕀 Double, 𝕀 Double ) )
|
||||||
|
-> 𝕀 Double
|
||||||
|
-> [ 𝕀 Double ]
|
||||||
|
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 )
|
||||||
|
go x_inf x_right =
|
||||||
|
let ( f_x_right, _f'_x_right ) = ff' x_right
|
||||||
|
in
|
||||||
|
if inf f_x_right <= 0 && sup f_x_right >= 0
|
||||||
|
then [ 𝕀 x_inf ( sup x_right ) ]
|
||||||
|
else
|
||||||
|
let x = 𝕀 x_inf ( inf x_right )
|
||||||
|
( _f_x, f'_x ) = ff' x
|
||||||
|
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 ) ) < ε_eq
|
||||||
|
-> x's
|
||||||
|
| otherwise
|
||||||
|
-> do
|
||||||
|
x' <- x's
|
||||||
|
if sup x' - inf x' < ε_bis
|
||||||
|
then return x'
|
||||||
|
else right_narrow =<< NE.toList ( bisect x' )
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Adaptive shaving.
|
||||||
|
|
||||||
|
data AdaptiveShavingOptions
|
||||||
|
= AdaptiveShavingOptions
|
||||||
|
{ γ_init, σ_good, σ_bad, β_good, β_bad :: !Double
|
||||||
|
}
|
||||||
|
deriving stock Show
|
||||||
|
|
||||||
|
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
|
||||||
|
-> Double
|
||||||
|
-> AdaptiveShavingOptions
|
||||||
|
-> ( 𝕀 Double -> ( 𝕀 Double, 𝕀 Double ) )
|
||||||
|
-> 𝕀 Double
|
||||||
|
-> [ 𝕀 Double ]
|
||||||
|
leftShave ε_eq ε_bis
|
||||||
|
( 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 < ε_bis
|
||||||
|
= [ 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.
|
||||||
|
= γ
|
||||||
|
xs' = x_minus_guess : guesses'
|
||||||
|
in if ( width x' - sum ( map width xs' ) ) < ε_eq
|
||||||
|
then xs'
|
||||||
|
else left_narrow γ' =<< xs'
|
||||||
|
{-# INLINEABLE leftShave #-}
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Two-sided shaving.
|
||||||
|
|
||||||
|
-- | @sbc@ algorithm from the paper
|
||||||
|
--
|
||||||
|
-- "A Data-Parallel Algorithm to Reliably Solve Systems of Nonlinear Equations",
|
||||||
|
-- (Frédéric Goualard, Alexandre Goldsztejn, 2008).
|
||||||
|
sbc :: Double
|
||||||
|
-> ( 𝕀 Double -> ( 𝕀 Double, 𝕀 Double ) )
|
||||||
|
-> 𝕀 Double -> [ 𝕀 Double ]
|
||||||
|
sbc ε ff' = go
|
||||||
|
where
|
||||||
|
go :: 𝕀 Double -> [ 𝕀 Double ]
|
||||||
|
go x@( 𝕀 x_l x_r )
|
||||||
|
| width x <= ε
|
||||||
|
= [ x ]
|
||||||
|
| otherwise
|
||||||
|
= let x_mid = 0.5 * ( x_l + x_r )
|
||||||
|
( left_done, left_todo )
|
||||||
|
| 0 `inside` ( fst $ ff' ( 𝕀 x_l x_lp ) )
|
||||||
|
= ( True, [ ] )
|
||||||
|
| not $ 0 `inside` ( fst $ ff' i_l )
|
||||||
|
= ( False, [ ] )
|
||||||
|
| otherwise
|
||||||
|
= let
|
||||||
|
xls = do
|
||||||
|
let l = 𝕀 x_lp x_lp
|
||||||
|
δ <- fst ( ff' l ) `extendedDivide` snd ( ff' i_l )
|
||||||
|
map fst $ ( l - δ ) `intersect` i_l
|
||||||
|
in ( False, xls )
|
||||||
|
where x_lp = min ( succFP x_l ) x_mid
|
||||||
|
i_l = 𝕀 x_lp x_mid
|
||||||
|
( right_done, right_todo )
|
||||||
|
| 0 `inside` ( fst $ ff' ( 𝕀 x_rm x_r ) )
|
||||||
|
= ( True, [ ] )
|
||||||
|
| not $ 0 `inside` ( fst $ ff' i_r )
|
||||||
|
= ( False, [ ] )
|
||||||
|
| otherwise
|
||||||
|
= let
|
||||||
|
xrs = do
|
||||||
|
let r = 𝕀 x_rm x_rm
|
||||||
|
δ <- fst ( ff' r ) `extendedDivide` snd ( ff' i_r )
|
||||||
|
map fst $ ( r - δ ) `intersect` i_r
|
||||||
|
in ( False, xrs )
|
||||||
|
where x_rm = max ( prevFP x_r ) x_mid
|
||||||
|
i_r = 𝕀 x_mid x_rm
|
||||||
|
in do let lefts' = if left_done
|
||||||
|
then [ 𝕀 x_l x_mid ]
|
||||||
|
else go =<< left_todo
|
||||||
|
rights' = if right_done
|
||||||
|
then [ 𝕀 x_mid x_r ]
|
||||||
|
else go =<< right_todo
|
||||||
|
lefts' ++ rights'
|
||||||
|
{-# INLINEABLE sbc #-}
|
Loading…
Reference in a new issue