Improve robustness of quadratic equation solver

Based on ideas from the paper
  "The Ins and Outs of Solving Quadratic Equations with Floating-Point Arithmetic"
    (Frédéric Goualard, 2023)

Could still be improved further, but I think this is acceptable for now.
This commit is contained in:
sheaf 2024-04-21 14:19:37 +02:00
parent 1338d7ddbe
commit 01fdd9a126
9 changed files with 133 additions and 52 deletions

View file

@ -153,6 +153,8 @@ library
^>= 3.3.7.0
, filepath
>= 1.4 && < 1.6
, fp-ieee
^>= 0.1.0.4
, groups-generic
^>= 0.3.1.0
, parallel

View file

@ -2,6 +2,7 @@ packages: .
constraints:
acts -finitary,
fp-ieee +fma3,
rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double
tests: True

View file

@ -123,9 +123,9 @@ chainRule ( D df ) ( D dg ) =
uncurryD2 :: D 2 a ~ D 2 ( 1 )
=> D 2 ( 1 ) ( C 2 a b ) -> a -> D 2 ( 2 ) b
uncurryD2 ( D21 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) s0 =
let !( D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 ) = b_t0 s0
!( D21 dbdt_t0s0 d2bdtds_t0s0 _ ) = dbdt_t0 s0
!( D21 d2bdt2_t0s0 _ _ ) = d2bdt2_t0 s0
let D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 = b_t0 s0
D21 dbdt_t0s0 d2bdtds_t0s0 _ = dbdt_t0 s0
D21 d2bdt2_t0s0 _ _ = d2bdt2_t0 s0
in D22
b_t0s0
( T dbdt_t0s0 ) dbds_t0s0
@ -134,10 +134,10 @@ uncurryD2 ( D21 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) s0 =
uncurryD3 :: D 3 a ~ D 3 ( 1 )
=> D 3 ( 1 ) ( C 3 a b ) -> a -> D 3 ( 2 ) b
uncurryD3 ( D31 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ( T ( D d3bdt3_t0 ) ) ) s0 =
let !( D31 b_t0s0 dbds_t0s0 d2bds2_t0s0 d3bds3_t0s0 ) = b_t0 s0
!( D31 dbdt_t0s0 d2bdtds_t0s0 d3bdtds2_t0s0 _ ) = dbdt_t0 s0
!( D31 d2bdt2_t0s0 d3bdt2ds_t0s0 _ _ ) = d2bdt2_t0 s0
!( D31 d3bdt3_t0s0 _ _ _ ) = d3bdt3_t0 s0
let D31 b_t0s0 dbds_t0s0 d2bds2_t0s0 d3bds3_t0s0 = b_t0 s0
D31 dbdt_t0s0 d2bdtds_t0s0 d3bdtds2_t0s0 _ = dbdt_t0 s0
D31 d2bdt2_t0s0 d3bdt2ds_t0s0 _ _ = d2bdt2_t0 s0
D31 d3bdt3_t0s0 _ _ _ = d3bdt3_t0 s0
in D32
b_t0s0
( T dbdt_t0s0 ) dbds_t0s0

View file

@ -139,7 +139,7 @@ data D1𝔸3 v =
data D2𝔸3 v =
D23 { _D23_v :: v
, _D23_dx, _D23_dy, _D23_dz :: ( T v )
, _D23_dxdx, _D23_dxdy, _D23_dydy, _D23_dxdz, _D23_dydz, _D23_dzdz :: !( T v )
, _D23_dxdx, _D23_dxdy, _D23_dydy, _D23_dxdz, _D23_dydz, _D23_dzdz :: ( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
@ -150,9 +150,9 @@ data D2𝔸3 v =
data D3𝔸3 v =
D33 { _D33_v :: v
, _D33_dx, _D33_dy, _D33_dz :: ( T v )
, _D33_dxdx, _D33_dxdy, _D33_dydy, _D33_dxdz, _D33_dydz, _D33_dzdz :: !( T v )
, _D33_dxdx, _D33_dxdy, _D33_dydy, _D33_dxdz, _D33_dydz, _D33_dzdz :: ( T v )
, _D33_dxdxdx, _D33_dxdxdy, _D33_dxdydy, _D33_dydydy
, _D33_dxdxdz, _D33_dxdydz, _D33_dxdzdz, _D33_dydydz, _D33_dydzdz, _D33_dzdzdz :: !( T v )
, _D33_dxdxdz, _D33_dxdydz, _D33_dxdzdz, _D33_dydydz, _D33_dydzdz, _D33_dzdzdz :: ( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
@ -370,11 +370,13 @@ instance MonomialBasis D1𝔸2 where
_D12_dx = T $ f $ Mon ( Vec [ 1, 0 ] )
_D12_dy = T $ f $ Mon ( Vec [ 0, 1 ] )
in D12 { .. }
{-# INLINE monTabulate #-}
monIndex d = \ case
Mon ( Vec [ 1, 0 ] ) -> unT $ _D12_dx d
Mon ( Vec [ 0, 1 ] ) -> unT $ _D12_dy d
_ -> _D12_v d
{-# INLINE monIndex #-}
type instance Deg D2𝔸2 = 2
type instance Vars D2𝔸2 = 2
@ -453,12 +455,14 @@ instance MonomialBasis D1𝔸3 where
!_D13_dy = T $ f ( Mon ( Vec [ 0, 1, 0 ] ) )
!_D13_dz = T $ f ( Mon ( Vec [ 0, 0, 1 ] ) )
in D13 { .. }
{-# INLINE monTabulate #-}
monIndex d = \ case
Mon ( Vec [ 1, 0, 0 ] ) -> unT $ _D13_dx d
Mon ( Vec [ 0, 1, 0 ] ) -> unT $ _D13_dy d
Mon ( Vec [ 0, 0, 1 ] ) -> unT $ _D13_dz d
_ -> _D13_v d
{-# INLINE monIndex #-}
type instance Deg D2𝔸3 = 2
type instance Vars D2𝔸3 = 3

View file

@ -38,6 +38,10 @@ import Data.Act
import Control.DeepSeq
( NFData, NFData1 )
-- fp-ieee
import Numeric.Floating.IEEE.NaN
( RealFloatNaN )
-- groups
import Data.Group
( Group )
@ -287,10 +291,12 @@ selfIntersectionParameters ( Bezier {..} ) = solveQuadratic c0 c1 c2
c2 = f1 + f2 - f3
-- | Extremal values of the Bézier parameter for a cubic Bézier curve.
extrema :: RealFloat r => Bezier r -> [ r ]
extrema :: RealFloatNaN r => Bezier r -> [ r ]
extrema ( Bezier {..} ) = solveQuadratic c b a
where
a = p3 - 3 * p2 + 3 * p1 - p0
b = 2 * ( p0 - 2 * p1 + p2 )
c = p1 - p0
{-# INLINEABLE extrema #-}
{-# SPECIALISE extrema :: Bezier Double -> [ Double ] #-}

View file

@ -148,23 +148,20 @@ instance RepresentableQ Double ( 0 ) where
instance RepresentableQ Double ( 1 ) where
tabulateQ f = [|| 1 $$( f ( Fin 1 ) ) ||]
indexQ p = \ case
Fin 1 -> [|| un1 $$p ||]
Fin i -> error $ "invalid index for 1: " ++ show i
_ -> [|| un1 $$p ||]
instance RepresentableQ Double ( 2 ) where
tabulateQ f = [|| 2 $$( f ( Fin 1 ) ) $$( f ( Fin 2 ) ) ||]
indexQ p = \ case
Fin 1 -> [|| _2_x $$p ||]
Fin 2 -> [|| _2_y $$p ||]
Fin i -> error $ "invalid index for 2: " ++ show i
_ -> [|| _2_y $$p ||]
instance RepresentableQ Double ( 3 ) where
tabulateQ f = [|| 3 $$( f ( Fin 1 ) ) $$( f ( Fin 2 ) ) $$( f ( Fin 3 ) ) ||]
indexQ p = \ case
Fin 1 -> [|| _3_x $$p ||]
Fin 2 -> [|| _3_y $$p ||]
Fin 3 -> [|| _3_z $$p ||]
Fin i -> error $ "invalid index for 3: " ++ show i
_ -> [|| _3_z $$p ||]
instance RepresentableQ Double ( 4 ) where
tabulateQ f = [|| 4 $$( f ( Fin 1 ) ) $$( f ( Fin 2 ) ) $$( f ( Fin 3 ) ) $$( f ( Fin 4 ) ) ||]
@ -172,8 +169,7 @@ instance RepresentableQ Double ( 4 ) where
Fin 1 -> [|| _4_x $$p ||]
Fin 2 -> [|| _4_y $$p ||]
Fin 3 -> [|| _4_z $$p ||]
Fin 4 -> [|| _4_w $$p ||]
Fin i -> error $ "invalid index for 4: " ++ show i
_ -> [|| _4_w $$p ||]
instance Representable Double ( 0 ) where
tabulate _ = 0
@ -185,8 +181,7 @@ instance Representable Double ( 1 ) where
tabulate f = 1 ( f ( Fin 1 ) )
{-# INLINE tabulate #-}
index p = \ case
Fin 1 -> un1 p
Fin i -> error $ "invalid index for 1: " ++ show i
_ -> un1 p
{-# INLINE index #-}
instance Representable Double ( 2 ) where
@ -194,8 +189,7 @@ instance Representable Double ( 2 ) where
{-# INLINE tabulate #-}
index p = \ case
Fin 1 -> _2_x p
Fin 2 -> _2_y p
Fin i -> error $ "invalid index for 2: " ++ show i
_ -> _2_y p
{-# INLINE index #-}
instance Representable Double ( 3 ) where
@ -204,8 +198,7 @@ instance Representable Double ( 3 ) where
index p = \ case
Fin 1 -> _3_x p
Fin 2 -> _3_y p
Fin 3 -> _3_z p
Fin i -> error $ "invalid index for 3: " ++ show i
_ -> _3_z p
{-# INLINE index #-}
instance Representable Double ( 4 ) where
@ -215,6 +208,5 @@ instance Representable Double ( 4 ) where
Fin 1 -> _4_x p
Fin 2 -> _4_y p
Fin 3 -> _4_z p
Fin 4 -> _4_w p
Fin i -> error $ "invalid index for 4: " ++ show i
_ -> _4_w p
{-# INLINE index #-}

View file

@ -246,16 +246,26 @@ defaultRootIsolationAlgorithms minWidth narrowAbs box history
-- Otherwise, do a normal round.
-- Currently: we try an interval GaussSeidel step followed by box(1)-consistency.
_ -> GaussSeidel defaultGaussSeidelOptions
NE.:| [ Box1 box1Options ]
NE.:| [ Box1 _box1Options ]
where
box1Options :: Box1Options n d
box1Options =
_box1Options :: Box1Options n d
_box1Options =
Box1Options
{ box1EpsEq = narrowAbs
, box1CoordsToNarrow = toList $ universe @n -- [ Fin 1, Fin 2 ]
, box1EqsToUse = toList $ universe @d
}
_box2Options :: Box2Options n d
_box2Options =
Box2Options
{ box2EpsEq = narrowAbs
, box2LambdaMin = 0.001
, box2CoordsToNarrow = toList $ universe @n
, box2EqsToUse = toList $ universe @d
}
-- Did we reduce the box width by at least "narrowAbs" in at least one of the dimensions?
sufficientlySmallerThan :: Box n -> Box n -> Bool
b1 `sufficientlySmallerThan` b2 =
@ -288,13 +298,15 @@ defaultBisectionOptions _minWidth _narrowAbs box =
in unT ( origin @Double ) `inside` iRange'
-- box(1)-consistency
--not $ null $ makeBox1Consistent eqs _minWidth _narrowAbs box'
--let box1Options = Box1Options _narrowAbs ( toList $ universe @n ) ( toList $ universe @d )
--in not $ null $ makeBox1Consistent _minWidth box1Options eqs box'
-- box(2)-consistency
--let box'' = makeBox2Consistent eqs _minWidth _narrowAbs 0.2 box'
--let box2Options = Box2Options _narrowAbs 0.001 ( toList $ universe @n ) ( toList $ universe @d )
-- box'' = makeBox2Consistent _minWidth box2Options eqs box'
-- iRange'' :: Box d
-- iRange'' = value @Double @1 @( Box n ) $ eqs box''
--in origin @Double `inside` iRange''
-- iRange'' = eqs box'' `monIndex` zeroMonomial
--in unT ( origin @Double ) `inside` iRange''
, fallbackBisectionDim =
\ _roundHist _prevRoundsHist eqs ->
let df = eqs box
@ -308,6 +320,8 @@ 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"
[Arg _ d] -> (coordIndex d, "")

View file

@ -33,6 +33,10 @@ import Data.Maybe
import Control.DeepSeq
( NFData, force )
-- fp-ieee
import Numeric.Floating.IEEE.NaN
( RealFloatNaN(copySign) )
-- primitive
import Control.Monad.Primitive
( PrimMonad(PrimState) )
@ -46,6 +50,10 @@ import Data.Primitive.PrimArray
import Data.Primitive.Types
( Prim )
-- rounded-hw
import Numeric.Rounded.Hardware.Internal
( fusedMultiplyAdd )
-- brush-strokes
import Math.Epsilon
( epsilon, nearZero )
@ -55,32 +63,85 @@ import Math.Epsilon
-- | Real solutions to a quadratic equation.
--
-- Coefficients are given in order of increasing degree.
--
-- Implementation taken from https://pbr-book.org/4ed/Utilities/Mathematical_Infrastructure#Quadratic.
solveQuadratic
:: forall a. RealFloat a
:: forall a. RealFloatNaN a
=> a -- ^ constant coefficient
-> a -- ^ linear coefficient
-> a -- ^ quadratic coefficient
-> [ a ]
solveQuadratic c b a
| nearZero b && nearZero a
= if nearZero c
then [ 0, 0.5, 1 ] -- convention
else []
| nearZero ( c * c * a / ( b * b ) )
= [ -c / b ]
| disc < 0
= [] -- non-real solutions
| isNaN a || isNaN b || isNaN c
|| isInfinite a || isInfinite b || isInfinite c
= []
| otherwise
= let
r :: a
r =
if b >= 0
then 2 * c / ( -b - sqrt disc )
else 0.5 * ( -b + sqrt disc ) / a
in [ r, c / ( a * r ) ]
= case (a == 0, c == 0) of
-- First, handle all cases in which a or c is zero.
-- bx = 0
(True , True )
| b == 0
-> [ 0, 0.5, 1 ] -- convention
| otherwise
-> [ 0 ]
-- bx + c = 0
(True , False)
| b == 0
-> [ ]
| otherwise
-> [ -c / b ]
-- ax² + bx = 0
(False, True )
| b == 0
-> [ 0 ]
| signum a == signum b
-> [ -b / a, 0 ]
| otherwise
-> [ 0, -b / a ]
-- General case: ax² + bx + c = 0
(False, False)
| discr < 0
-> []
| otherwise
-> let rootDiscr = sqrt discr
q = -0.5 * ( b + copySign rootDiscr b )
x1 = q / a
x2 = c / q
in if x1 > x2
then [ x2, x1 ]
else [ x1, x2 ]
where discr = discriminant a b c
{-# INLINEABLE solveQuadratic #-}
{-# SPECIALISE solveQuadratic :: Float -> Float -> Float -> [ Float ] #-}
{-# SPECIALISE solveQuadratic :: Double -> Double -> Double -> [ Double ] #-}
-- TODO: implement the version from the paper
-- "The Ins and Outs of Solving Quadratic Equations with Floating-Point Arithmetic"
-- which is even more robust.
-- | Kahan's method for computing the discriminant \( b^2 - 4ac \),
-- using a fused multiply-add operation to avoid cancellation in the naive
-- formula (if \( b^2 \) and \( 4ac \) are close).
--
-- From "The Ins and Outs of Solving Quadratic Equations with Floating-Point Arithmetic",
-- (Frédéric Goualard, 2023).
discriminant :: RealFloat a => a -> a -> a -> a
discriminant a b c
-- b² and 4ac are different enough that b² - 4ac gives a good answer
| 3 * abs d_naive >= b² - m4ac
= d_naive
| otherwise
= let dp = fma b b -b²
dq = fma ( 4 * a ) c m4ac
in d_naive + ( dp - dq )
where
disc :: a
disc = b * b - 4 * a * c
b² = b * b
m4ac = -4 * a * c
d_naive = b² + m4ac
fma = fusedMultiplyAdd
{-# INLINEABLE discriminant #-}
{-# SPECIALISE discriminant :: Float -> Float -> Float -> Float #-}
{-# SPECIALISE discriminant :: Double -> Double -> Double -> Double #-}
--------------------------------------------------------------------------------
-- Root finding using Laguerre's method

View file

@ -3,6 +3,7 @@ packages: ., brush-strokes
constraints:
acts -finitary,
-- brush-strokes +use-fma,
fp-ieee +fma3,
rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double,
text -simdutf
-- text +simdutf causes the "digit" package to fail to build with undefined symbol linker errors