precondition before taking Gauss-Seidel step

This commit is contained in:
sheaf 2023-01-23 13:58:52 +01:00
parent 78c03b99e1
commit 1ae84fec97

View file

@ -25,7 +25,7 @@ import Control.Arrow
import Control.Applicative
( Applicative(..) )
import Control.Monad
( guard, unless )
( unless )
import Control.Monad.ST
( RealWorld, ST )
import Data.Bifunctor
@ -33,7 +33,7 @@ import Data.Bifunctor
import Data.Coerce
( Coercible, coerce )
import Data.Foldable
( for_, toList )
( for_ )
import Data.Functor.Identity
( Identity(..) )
import Data.List
@ -88,6 +88,8 @@ import qualified Control.Parallel.Strategies as Strats
-- rounded-hw
import Numeric.Rounded.Hardware
( Rounded(..) )
import Numeric.Rounded.Hardware.Interval.NonEmpty
( Interval(..) )
import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as Interval
-- transformers
@ -122,7 +124,7 @@ import Math.Differentiable
, type ExtentOrder
)
import Math.Epsilon
( epsilon )
( epsilon, nearZero )
import Math.Interval
import Math.Linear
import Math.Module
@ -339,8 +341,7 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ 1 0
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ 1 1
fwdStartCap, bwdStartCap :: SplinePts Open
cusps :: [ Cusp ]
OutlineData ( fmap fst -> TwoSided fwdStartCap bwdStartCap ) cusps
OutlineData ( fmap fst -> TwoSided fwdStartCap bwdStartCap ) _
= snd . runWriter
$ tellBrushJoin ( endTgt, endTgtFwd, endTgtBwd ) spt0 ( startTgt, startTgtFwd, startTgtBwd )
-> do
@ -596,7 +597,7 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
$ runD ( brushFromParams @Point proxy# id )
$ toBrushParams params_t
( newtDunno, newtSols ) = intervalNewtonGS 0.0001 curvesI
( newtDunno, newtSols ) = intervalNewtonGS InverseMidJacobian 0.0001 curvesI
in --trace
-- ( unlines $
@ -1184,9 +1185,14 @@ cuspCoords eqs ( 𝕀 ( 1 t_lo ) ( 1 t_hi ), i, 𝕀 ( 1 s_lo ) ( 1
}
where
t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi )
data Preconditioner
= NoPreconditioning
| InverseMidJacobian
deriving stock Show
-- | Interval Newton method with GaussSeidel step for inversion
-- of the interval Jacobian.
--
@ -1194,10 +1200,11 @@ cuspCoords eqs ( 𝕀 ( 1 t_lo ) ( 1 t_hi ), i, 𝕀 ( 1 s_lo ) ( 1
-- (and to which Newton's method will converge starting from anywhere inside
-- the box), and @dunno@ which are small boxes which might or might not
-- contain solutions.
intervalNewtonGS :: Double
intervalNewtonGS :: Preconditioner
-> Double
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 'Interval ) )
-> ( [ ( 𝕀 1, Int, 𝕀 1 ) ], [ ( 𝕀 1, Int, 𝕀 1 ) ] )
intervalNewtonGS minWidth eqs =
intervalNewtonGS precondMethod minWidth eqs =
go [ ( 𝕀 ( 1 0 ) ( 1 1 ), i, 𝕀 ( 1 0 ) ( 1 1 ) )
| i <- [ 0 .. length ( eqs ( 𝕀 ( 1 0 ) ( 1 1 ) ) ) - 1 ]
]
@ -1231,13 +1238,11 @@ intervalNewtonGS minWidth eqs =
, cmp2 (>) ( getRounded ( Interval.sup $ ival f ) ) ( 2 0 0 )
-> let -- Interval Newton method: take one GaussSeidel step
-- for the equation f'(X) v = - f(x_mid).
-- !precond = matInverse ( f_t_mid, f_s_mid )
-- !a = matMul precond ( f_t, f_s )
-- !b = matMulVec precond ( neg f_mid )
-- !gsGuesses = gaussSeidel a b ( t, s )
!gsGuesses = gaussSeidel
( f_t, f_s )
( neg f_mid )
!( a, b ) = precondition precondMethod
( f_t_mid, f_s_mid )
( f_t, f_s ) ( neg f_mid )
!gsGuesses = gaussSeidel a b
( coerce ( (-) @( 𝕀 Double ) ) t i_t_mid
, coerce ( (-) @( 𝕀 Double ) ) s i_s_mid )
in if all ( smaller . fst ) gsGuesses
@ -1283,6 +1288,50 @@ intervalNewtonGS minWidth eqs =
!( 𝕀 y'_lo y'_hi ) = negate $ 𝕀 y_lo y_hi
in 𝕀 ( 2 x'_lo y'_lo ) ( 2 x'_hi y'_hi )
precondition :: Preconditioner
-> ( 𝕀 2, 𝕀 2 )
-> ( 𝕀 2, 𝕀 2 )
-> 𝕀 2
-> ( ( 𝕀 2, 𝕀 2 ), 𝕀 2 )
precondition meth jac_mid a@( a1, a2 ) b =
case meth of
NoPreconditioning
-> ( a, b )
InverseMidJacobian
| ( 𝕀 ( 2 a11_lo a21_lo ) ( 2 a11_hi a21_hi )
, 𝕀 ( 2 a12_lo a22_lo ) ( 2 a12_hi a22_hi ) ) <- jac_mid
, let !a11 = 0.5 * ( a11_lo + a11_hi )
!a12 = 0.5 * ( a12_lo + a12_hi )
!a21 = 0.5 * ( a21_lo + a21_hi )
!a22 = 0.5 * ( a22_lo + a22_hi )
!d = a11 * a22 - a12 * a21
, not ( nearZero d )
, let !precond = ( 2 a22 -a21, 2 -a12 a11 )
!inv = recip d
f x = scale inv $ matMulVec precond x
-> ( ( f a1, f a2 ), f b )
| otherwise
-> ( a, b )
scale :: Double -> 𝕀 2 -> 𝕀 2
scale s ( 𝕀 ( 2 a1_lo a2_lo ) ( 2 a1_hi a2_hi ) )
| I ( Rounded b1_lo ) ( Rounded b1_hi )
<- I ( Rounded s ) ( Rounded s ) * I ( Rounded a1_lo ) ( Rounded a1_hi )
, I ( Rounded b2_lo ) ( Rounded b2_hi )
<- I ( Rounded s ) ( Rounded s ) * I ( Rounded a2_lo ) ( Rounded a2_hi )
= 𝕀 ( 2 b1_lo b2_lo ) ( 2 b1_hi b2_hi )
matMulVec :: ( 2, 2 ) -> 𝕀 2 -> 𝕀 2
matMulVec ( 2 a11 a21, 2 a12 a22 ) ( 𝕀 ( 2 u_lo v_lo ) ( 2 u_hi v_hi ) ) =
let !( I ( Rounded u'_lo ) ( Rounded u'_hi ) ) =
I ( Rounded a11 ) ( Rounded a11 ) * I ( Rounded u_lo ) ( Rounded u_hi )
+ I ( Rounded a12 ) ( Rounded a12 ) * I ( Rounded v_lo ) ( Rounded v_hi )
!( I ( Rounded v'_lo ) ( Rounded v'_hi ) ) =
I ( Rounded a21 ) ( Rounded a21 ) * I ( Rounded u_lo ) ( Rounded u_hi )
+ I ( Rounded a22 ) ( Rounded a22 ) * I ( Rounded v_lo ) ( Rounded v_hi )
in 𝕀 ( 2 u'_lo v'_lo ) ( 2 u'_hi v'_hi )
cmp2 :: ( Double -> Double -> Bool ) -> 2 -> 2 -> Bool
cmp2 cmp ( 2 x1 y1 ) ( 2 x2 y2 )
= cmp x1 x2 && cmp y1 y2