mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
Add complete interval-union Gauss–Seidel step method
This commit is contained in:
parent
ac9deb968a
commit
edba0416aa
|
@ -69,7 +69,7 @@ benchTestCase testName ( TestCase { testDescription, testBrushStroke, testCuspOp
|
||||||
( dunno, sols ) =
|
( dunno, sols ) =
|
||||||
foldMap
|
foldMap
|
||||||
( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = mbCusps } ) ) ->
|
( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = mbCusps } ) ) ->
|
||||||
( map ( ( i , ) . snd ) mbCusps, map ( i, ) defCusps ) ) $
|
( map ( ( i , ) . fst ) mbCusps, map ( i, ) defCusps ) ) $
|
||||||
IntMap.toList $
|
IntMap.toList $
|
||||||
findCuspsIn testCuspOptions testStrokeFnI $
|
findCuspsIn testCuspOptions testStrokeFnI $
|
||||||
IntMap.fromList
|
IntMap.fromList
|
||||||
|
|
|
@ -128,8 +128,17 @@ pattern V4 x y z w = T ( ℝ4 x y z w )
|
||||||
|
|
||||||
type Vec :: Nat -> Type -> Type
|
type Vec :: Nat -> Type -> Type
|
||||||
newtype Vec n a = Vec { vecList :: [ a ] }
|
newtype Vec n a = Vec { vecList :: [ a ] }
|
||||||
deriving newtype ( Show, Eq, Ord, Functor, Foldable )
|
type role Vec nominal representational
|
||||||
deriving Applicative via ZipList
|
|
||||||
|
deriving newtype instance Show a => Show ( Vec n a )
|
||||||
|
deriving newtype instance Eq a => Eq ( Vec n a )
|
||||||
|
deriving newtype instance Ord a => Ord ( Vec n a )
|
||||||
|
deriving newtype instance Functor ( Vec n )
|
||||||
|
deriving newtype instance Foldable ( Vec n )
|
||||||
|
deriving via ZipList
|
||||||
|
instance Applicative ( Vec n )
|
||||||
|
instance Traversable ( Vec n ) where
|
||||||
|
traverse f ( Vec as ) = Vec <$> traverse f as
|
||||||
|
|
||||||
universe :: forall n. KnownNat n => Vec n ( Fin n )
|
universe :: forall n. KnownNat n => Vec n ( Fin n )
|
||||||
universe = Vec [ Fin i | i <- [ 1 .. fromIntegral ( natVal' @n proxy# ) ] ]
|
universe = Vec [ Fin i | i <- [ 1 .. fromIntegral ( natVal' @n proxy# ) ] ]
|
||||||
|
|
|
@ -138,9 +138,9 @@ defaultRootIsolationAlgorithms minWidth ε_eq history box =
|
||||||
where
|
where
|
||||||
verySmall = and $ ( \ cd -> width cd <= minWidth ) <$> coordinates box
|
verySmall = and $ ( \ cd -> width cd <= minWidth ) <$> coordinates box
|
||||||
|
|
||||||
_bisOptions = defaultBisectionOptions minWidth ε_eq box
|
_bisOptions = defaultBisectionOptions @n @d minWidth ε_eq box
|
||||||
_gsOptions = defaultGaussSeidelOptions history
|
_gsOptions = defaultGaussSeidelOptions @n @d history
|
||||||
_box1Options = defaultBox1Options minWidth ε_eq
|
_box1Options = defaultBox1Options @n @d minWidth ε_eq
|
||||||
|
|
||||||
-- Did we reduce the box width by at least ε_eq
|
-- Did we reduce the box width by at least ε_eq
|
||||||
-- in at least one of the coordinates?
|
-- in at least one of the coordinates?
|
||||||
|
|
|
@ -89,7 +89,6 @@ type BoxCt n d =
|
||||||
, Vars ( D 1 ( ℝ n ) ) ~ n
|
, Vars ( D 1 ( ℝ n ) ) ~ n
|
||||||
, Module Double ( T ( ℝ n ) )
|
, Module Double ( T ( ℝ n ) )
|
||||||
, Module ( 𝕀 Double ) ( T ( 𝕀ℝ n ) )
|
, Module ( 𝕀 Double ) ( T ( 𝕀ℝ n ) )
|
||||||
, Applicative ( Vec n )
|
|
||||||
|
|
||||||
, Ord ( ℝ d )
|
, Ord ( ℝ d )
|
||||||
, Module Double ( T ( ℝ d ) )
|
, Module Double ( T ( ℝ d ) )
|
||||||
|
|
|
@ -12,6 +12,7 @@ module Math.Root.Isolation.GaussSeidel
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Prelude hiding ( unzip )
|
||||||
import Control.Arrow
|
import Control.Arrow
|
||||||
( first )
|
( first )
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
|
@ -24,6 +25,8 @@ import Data.Foldable
|
||||||
( toList )
|
( toList )
|
||||||
import Data.List
|
import Data.List
|
||||||
( partition )
|
( partition )
|
||||||
|
import Data.List.NonEmpty
|
||||||
|
( unzip )
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
( Proxy(..) )
|
( Proxy(..) )
|
||||||
import Data.Type.Ord
|
import Data.Type.Ord
|
||||||
|
@ -71,12 +74,21 @@ instance RootIsolationAlgorithm GaussSeidel where
|
||||||
type GaussSeidelOptions :: Nat -> Nat -> Type
|
type GaussSeidelOptions :: Nat -> Nat -> Type
|
||||||
data GaussSeidelOptions n d =
|
data GaussSeidelOptions n d =
|
||||||
GaussSeidelOptions
|
GaussSeidelOptions
|
||||||
{ -- | Which preconditioner to user?
|
{ -- | Which preconditioner to use?
|
||||||
gsPreconditioner :: !Preconditioner
|
gsPreconditioner :: !Preconditioner
|
||||||
-- | Function that projects over the equations we will consider
|
-- | Function that projects over the equations we will consider
|
||||||
-- (the identity for a well-determined problem, or a projection for
|
-- (the identity for a well-determined problem, or a projection for
|
||||||
-- an overdetermined system).
|
-- an overdetermined system).
|
||||||
, gsPickEqs :: ( 𝕀ℝ d -> 𝕀ℝ n ) }
|
, gsPickEqs :: !( 𝕀ℝ d -> 𝕀ℝ n )
|
||||||
|
-- | Whether to use a partial or a complete Gauss–Seidel update
|
||||||
|
, gsUpdate :: !GaussSeidelUpdateMethod
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | Whether to use a partial or a complete Gauss–Seidel update.
|
||||||
|
data GaussSeidelUpdateMethod
|
||||||
|
= GS_Partial
|
||||||
|
| GS_Complete
|
||||||
|
deriving stock Show
|
||||||
|
|
||||||
-- | Default options for the interval Gauss–Seidel method.
|
-- | Default options for the interval Gauss–Seidel method.
|
||||||
defaultGaussSeidelOptions
|
defaultGaussSeidelOptions
|
||||||
|
@ -90,7 +102,7 @@ defaultGaussSeidelOptions
|
||||||
-> GaussSeidelOptions n d
|
-> GaussSeidelOptions n d
|
||||||
defaultGaussSeidelOptions history =
|
defaultGaussSeidelOptions history =
|
||||||
GaussSeidelOptions
|
GaussSeidelOptions
|
||||||
{ gsPreconditioner = InverseMidJacobian
|
{ gsPreconditioner = InverseMidpoint
|
||||||
, gsPickEqs =
|
, gsPickEqs =
|
||||||
case cmpNat @n @d Proxy Proxy of
|
case cmpNat @n @d Proxy Proxy of
|
||||||
EQI -> id
|
EQI -> id
|
||||||
|
@ -103,13 +115,14 @@ defaultGaussSeidelOptions history =
|
||||||
choice :: Vec n ( Fin d )
|
choice :: Vec n ( Fin d )
|
||||||
choice = choices !! ( length history `mod` length choices )
|
choice = choices !! ( length history `mod` length choices )
|
||||||
in \ u -> tabulate \ i -> index u ( choice ! i )
|
in \ u -> tabulate \ i -> index u ( choice ! i )
|
||||||
|
, gsUpdate = GS_Complete
|
||||||
}
|
}
|
||||||
{-# INLINEABLE defaultGaussSeidelOptions #-}
|
{-# INLINEABLE defaultGaussSeidelOptions #-}
|
||||||
|
|
||||||
-- | Preconditioner to use with the interval Gauss–Seidel method.
|
-- | Preconditioner to use with the interval Gauss–Seidel method.
|
||||||
data Preconditioner
|
data Preconditioner
|
||||||
= NoPreconditioning
|
= NoPreconditioning
|
||||||
| InverseMidJacobian
|
| InverseMidpoint
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
-- | Interval Newton method with Gauss–Seidel step.
|
-- | Interval Newton method with Gauss–Seidel step.
|
||||||
|
@ -123,44 +136,66 @@ intervalGaussSeidel
|
||||||
-- ^ box
|
-- ^ box
|
||||||
-> Writer ( DoneBoxes n ) [ 𝕀ℝ n ]
|
-> Writer ( DoneBoxes n ) [ 𝕀ℝ n ]
|
||||||
intervalGaussSeidel
|
intervalGaussSeidel
|
||||||
( GaussSeidelOptions { gsPreconditioner = precondMeth, gsPickEqs = pickEqs } )
|
( GaussSeidelOptions
|
||||||
|
{ gsPreconditioner = precondMeth
|
||||||
|
, gsPickEqs = pickEqs
|
||||||
|
, gsUpdate
|
||||||
|
} )
|
||||||
eqs
|
eqs
|
||||||
box
|
x
|
||||||
| let boxMid = singleton $ boxMidpoint box
|
| let x_mid = singleton $ boxMidpoint x
|
||||||
f' :: Vec n ( 𝕀ℝ n )
|
f'_x :: Vec n ( 𝕀ℝ n )
|
||||||
f' = fmap ( \ i -> pickEqs $ eqs box `monIndex` linearMonomial i ) ( universe @n )
|
f'_x = fmap ( \ i -> pickEqs $ eqs x `monIndex` linearMonomial i ) ( universe @n )
|
||||||
f_mid = pickEqs $ eqs boxMid `monIndex` zeroMonomial
|
f_x_mid = pickEqs $ eqs x_mid `monIndex` zeroMonomial
|
||||||
|
|
||||||
= let -- Interval Newton method: take one Gauss–Seidel step
|
= let -- Interval Newton method: take one Gauss–Seidel step
|
||||||
-- for the system of equations f'(x) ( x - x_mid ) = - f(x_mid).
|
-- for the system of equations f'(x) ( x - x_mid ) = - f(x_mid).
|
||||||
|
minus_f_x_mid = unT $ -1 *^ T ( boxMidpoint f_x_mid )
|
||||||
|
|
||||||
|
-- Precondition the above linear system into A ( x - x_mid ) = B.
|
||||||
( a, b ) = precondition precondMeth
|
( a, b ) = precondition precondMeth
|
||||||
( fmap boxMidpoint f' )
|
f'_x ( singleton minus_f_x_mid )
|
||||||
f' ( singleton $ unT $ -1 *^ T ( boxMidpoint f_mid ) )
|
|
||||||
|
|
||||||
-- NB: we have to change coordinates, putting the midpoint of the box
|
-- NB: we have to change coordinates, putting the midpoint of the box
|
||||||
-- at the origin, in order to take a Gauss–Seidel step.
|
-- at the origin, in order to take a Gauss–Seidel step.
|
||||||
gsGuesses = map ( first ( \ box' -> unT $ box' ^+^ T boxMid ) )
|
gsGuesses = map ( first ( \ x' -> unT $ x' ^+^ T x_mid ) )
|
||||||
$ gaussSeidelStep a b ( T box ^-^ T boxMid )
|
$ gaussSeidelUpdate gsUpdate a b ( T x ^-^ T x_mid )
|
||||||
in
|
in
|
||||||
-- If the Gauss–Seidel step was a contraction, then the box
|
-- If the Gauss–Seidel step was a contraction, then the box
|
||||||
-- contains a unique solution (by the Banach fixed point theorem).
|
-- contains a unique solution (by the Banach fixed point theorem).
|
||||||
--
|
--
|
||||||
-- These boxes can thus be directly added to the solution set:
|
-- These boxes can thus be directly added to the solution set:
|
||||||
-- Newton's method is guaranteed to converge to the unique solution.
|
-- Newton's method is guaranteed to converge to the unique solution.
|
||||||
let !(done, todo) = bimap ( map fst ) ( map fst )
|
let ( done, todo ) = bimap ( map fst ) ( map fst )
|
||||||
$ partition snd gsGuesses
|
$ partition snd gsGuesses
|
||||||
in do tell $ noDoneBoxes { doneSolBoxes = done }
|
in do tell $ noDoneBoxes { doneSolBoxes = done }
|
||||||
return todo
|
return todo
|
||||||
where
|
where
|
||||||
{-# INLINEABLE intervalGaussSeidel #-}
|
{-# INLINEABLE intervalGaussSeidel #-}
|
||||||
|
|
||||||
|
-- | A partial or complete Gauss–Seidel step for the equation \( A X = B \),
|
||||||
|
-- refining the initial guess box for \( X \) into up to \( 2^n \) (disjoint) new boxes.
|
||||||
|
gaussSeidelUpdate
|
||||||
|
:: forall n
|
||||||
|
. ( Representable Double ( ℝ n ), n ~ RepDim ( ℝ n ), Eq ( ℝ n ) )
|
||||||
|
=> GaussSeidelUpdateMethod -- ^ which step method to use
|
||||||
|
-> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
||||||
|
-> 𝕀ℝ n -- ^ \( B \)
|
||||||
|
-> T ( 𝕀ℝ n ) -- ^ initial box \( X \)
|
||||||
|
-> [ ( T ( 𝕀ℝ n ), Bool ) ]
|
||||||
|
gaussSeidelUpdate upd as b x =
|
||||||
|
case upd of
|
||||||
|
GS_Partial -> gaussSeidelStep as b x
|
||||||
|
GS_Complete -> gaussSeidelStep_Complete as b x
|
||||||
|
{-# INLINEABLE gaussSeidelUpdate #-}
|
||||||
|
|
||||||
-- | Take one interval Gauss–Seidel step for the equation \( A X = B \),
|
-- | 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.
|
-- 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.
|
-- The boolean indicates whether the Gauss–Seidel step was a contraction.
|
||||||
gaussSeidelStep
|
gaussSeidelStep
|
||||||
:: forall n
|
:: forall n
|
||||||
. ( Representable Double ( ℝ n ), Eq ( ℝ n ) )
|
. ( Representable Double ( ℝ n ), n ~ RepDim ( ℝ n ), Eq ( ℝ n ) )
|
||||||
=> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
=> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
||||||
-> 𝕀ℝ n -- ^ \( B \)
|
-> 𝕀ℝ n -- ^ \( B \)
|
||||||
-> T ( 𝕀ℝ n ) -- ^ initial box \( X \)
|
-> T ( 𝕀ℝ n ) -- ^ initial box \( X \)
|
||||||
|
@ -168,15 +203,80 @@ gaussSeidelStep
|
||||||
gaussSeidelStep as b ( T x0 ) = coerce $
|
gaussSeidelStep as b ( T x0 ) = coerce $
|
||||||
forEachCoord @n ( x0, True ) $ \ i ( x, contraction ) -> do
|
forEachCoord @n ( x0, True ) $ \ i ( x, contraction ) -> do
|
||||||
-- x_i' = ( b_i - sum { j /= i } a_ij * x_j ) / a_ii
|
-- 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 ] )
|
let s = b `index` i - sum [ ( as ! j ) `index` i * x `index` j
|
||||||
`extendedDivide` ( ( as ! i ) `index` i )
|
| j <- toList ( universe @n ), j /= i ]
|
||||||
( x_i', sub_i ) <- x_i'0 `intersect` ( x `index` i )
|
x_i = x `index` i
|
||||||
return $ ( set i x_i' x, sub_i && contraction )
|
a_ii = ( as ! i ) `index` i
|
||||||
-- TODO: try implementing the complete interval union Gauss–Seidel algorithm.
|
-- Take a shortcut before performing the division if possible.
|
||||||
-- See "Algorithm 2" in
|
if | not $ 0 `inside` ( s - a_ii * x_i )
|
||||||
-- "Using interval unions to solve linear systems of equations with uncertainties"
|
-- No solutions: don't bother performing a division.
|
||||||
|
-> [ ]
|
||||||
|
| 0 `inside` s && 0 `inside` a_ii
|
||||||
|
-- The division would produce [-oo,+oo]: don't do anything.
|
||||||
|
-> [ ( x, False ) ]
|
||||||
|
-- Otherwise, perform the division.
|
||||||
|
| otherwise
|
||||||
|
-> do
|
||||||
|
x_i'0 <- s `extendedDivide` a_ii
|
||||||
|
( x_i', sub_i ) <- x_i'0 `intersect` x_i
|
||||||
|
return $ ( set i x_i' x, sub_i && contraction )
|
||||||
{-# INLINEABLE gaussSeidelStep #-}
|
{-# INLINEABLE gaussSeidelStep #-}
|
||||||
|
|
||||||
|
-- | The complete interval-union Gauss–Seidel step.
|
||||||
|
--
|
||||||
|
-- Algorithm 2 from:
|
||||||
|
-- "Using interval unions to solve linear systems of equations with uncertainties"
|
||||||
|
-- (Montanher, Domes, Schichl, Neumaier) (2017)
|
||||||
|
gaussSeidelStep_Complete
|
||||||
|
:: forall n
|
||||||
|
. ( Representable Double ( ℝ n ), n ~ RepDim ( ℝ n ) )
|
||||||
|
=> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
||||||
|
-> 𝕀ℝ n -- ^ \( B \)
|
||||||
|
-> T ( 𝕀ℝ n ) -- ^ initial box \( X \)
|
||||||
|
-> [ ( T ( 𝕀ℝ n ), Bool ) ]
|
||||||
|
gaussSeidelStep_Complete as b ( T x0 ) = coerce $ do
|
||||||
|
( x', subs ) <-
|
||||||
|
forEachCoord @n ( x0, pure False ) $ \ i ( x, contractions ) -> do
|
||||||
|
let s = b `index` i - sum [ ( as ! k ) `index` i * x `index` k
|
||||||
|
| k <- toList ( universe @n ) ]
|
||||||
|
x_i = x `index` i
|
||||||
|
a_ii = ( as ! i ) `index` i
|
||||||
|
( x', subs ) <- fromComponents \ j -> do
|
||||||
|
let x_j = x `index` j
|
||||||
|
a_ij = ( as ! j ) `index` i
|
||||||
|
s_j = s `ominus` ( a_ij * x_j )
|
||||||
|
-- Shortcut division if possible (see gaussSeidelStep for commentary).
|
||||||
|
if | not $ 0 `inside` ( s_j - a_ii * x_i )
|
||||||
|
-> [ ]
|
||||||
|
| 0 `inside` s_j && 0 `inside` a_ij
|
||||||
|
-> [ ( x_j, False ) ]
|
||||||
|
| otherwise
|
||||||
|
-> do
|
||||||
|
x_j'0 <- s_j `extendedDivide` a_ij
|
||||||
|
( x_j', sub_j ) <- x_j'0 `intersect` x_j
|
||||||
|
return $ ( x_j', sub_j )
|
||||||
|
return ( x', (||) <$> contractions <*> subs )
|
||||||
|
return ( x', and subs )
|
||||||
|
{-# INLINEABLE gaussSeidelStep_Complete #-}
|
||||||
|
|
||||||
|
fromComponents
|
||||||
|
:: forall n
|
||||||
|
. ( Representable Double ( ℝ n ), n ~ RepDim ( ℝ n ) )
|
||||||
|
=> ( Fin n -> [ ( 𝕀 Double, Bool ) ] ) -> [ ( 𝕀ℝ n, Vec n Bool ) ]
|
||||||
|
fromComponents f = do
|
||||||
|
( xs, bs ) <- unzip <$> traverse f ( universe @n )
|
||||||
|
return $ ( tabulate $ \ i -> xs ! i, bs )
|
||||||
|
-- TODO: this could be more efficient.
|
||||||
|
{-# INLINEABLE fromComponents #-}
|
||||||
|
|
||||||
|
infixl 6 `ominus`
|
||||||
|
ominus :: 𝕀 Double -> 𝕀 Double -> 𝕀 Double
|
||||||
|
ominus a@( 𝕀 lo1 hi1 ) b@( 𝕀 lo2 hi2 )
|
||||||
|
| width a >= width b
|
||||||
|
= 𝕀 ( lo1 - lo2 ) ( hi1 - hi2 )
|
||||||
|
| otherwise
|
||||||
|
= 𝕀 ( hi1 - hi2 ) ( lo1 - lo2 )
|
||||||
|
|
||||||
-- | The midpoint of a box.
|
-- | The midpoint of a box.
|
||||||
boxMidpoint :: Representable Double ( ℝ n ) => 𝕀ℝ n -> ℝ n
|
boxMidpoint :: Representable Double ( ℝ n ) => 𝕀ℝ n -> ℝ n
|
||||||
boxMidpoint box =
|
boxMidpoint box =
|
||||||
|
@ -191,16 +291,15 @@ precondition
|
||||||
:: forall n
|
:: forall n
|
||||||
. ( KnownNat n, Representable Double ( ℝ n ) )
|
. ( KnownNat n, Representable Double ( ℝ n ) )
|
||||||
=> Preconditioner -- ^ pre-conditioning method to use
|
=> Preconditioner -- ^ pre-conditioning method to use
|
||||||
-> Vec n ( ℝ n ) -- ^ entry-wise midpoint matrix of the interval Jacobian matrix
|
|
||||||
-> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
-> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
||||||
-> 𝕀ℝ n -- ^ \( B \)
|
-> 𝕀ℝ n -- ^ \( B \)
|
||||||
-> ( Vec n ( 𝕀ℝ n ), 𝕀ℝ n )
|
-> ( Vec n ( 𝕀ℝ n ), 𝕀ℝ n )
|
||||||
precondition meth jac_mid as b =
|
precondition meth as b =
|
||||||
case meth of
|
case meth of
|
||||||
NoPreconditioning
|
NoPreconditioning
|
||||||
-> ( as, b )
|
-> ( as, b )
|
||||||
InverseMidJacobian
|
InverseMidpoint
|
||||||
| let mat = toEigen jac_mid
|
| let mat = toEigen $ fmap boxMidpoint as
|
||||||
det = Eigen.determinant mat
|
det = Eigen.determinant mat
|
||||||
, not $ nearZero det
|
, not $ nearZero det
|
||||||
-- (TODO: a bit wasteful to compute determinant then inverse.)
|
-- (TODO: a bit wasteful to compute determinant then inverse.)
|
||||||
|
|
Loading…
Reference in a new issue