Fix extendedRecip (negative infinity)

This commit is contained in:
sheaf 2024-02-24 19:37:34 +01:00
parent d1b3765335
commit 26cfdada8f
4 changed files with 136 additions and 18 deletions

View file

@ -17,16 +17,22 @@ module Main
where
-- base
import Control.Concurrent.MVar
( newMVar )
import Data.Coerce
( coerce )
import Data.Foldable
( for_ )
import Data.List
( intercalate )
import GHC.Exts
( Proxy#, proxy# )
import GHC.Generics
( Generic )
import GHC.TypeNats
( type (-) )
import Numeric
( showFFloat )
-- containers
import Data.Sequence
@ -38,6 +44,8 @@ import Data.Tree
-- brush-strokes
import Calligraphy.Brushes
import Debug.Utils
( logToFile )
import Math.Algebra.Dual
import Math.Bezier.Spline
import Math.Bezier.Stroke
@ -66,6 +74,9 @@ main = for_ testCases $ \ testCase@( TestCase { testName, testAlgorithmParams }
, " dunno: " ++ show dunno
, " sols: " ++ show sols
]
--logFileMVar <- newMVar "logs/trickyCusp.log"
--logToFile logFileMVar (unlines logLines)
-- `seq` return ()
testCases :: [ TestCase ]
testCases = [ ellipse , trickyCusp2 ]
@ -140,9 +151,96 @@ putStrLn $ unlines $ map Data.Tree.View.showTree $ showTrees $ mkBox (0.5798, 0.
([1 0.5798, 1 0.675],3,[1 0.26798, 1 0.26799]) (area 0.000001) N []
([1 0.5973000285624527, 1 0.6750000000000002],3,[1 0.26798, 1 0.26799000000000006]) (area 0.000001) NoSolution "ee" ([1 0.5973000285624527, 1 0.6750000000000002],3,[1 0.26798, 1 0.26799000000000006])
eval fI $ mkBox (0.5798, 0.675) 3 (0.26798, 0.26799)
> D12 {_D12_v = T[2 -10088.6674944889 -3281.3820867312834, 2 4124.668381545453 4524.807156085763], _D12_dx = TT[2 -173746.97965005718 -33281.18494907289, 2 298.2609121556852 23639.772884799597], _D12_dy = TT[2 -18454.27716258352 -28337.509817580823, 2 1163.6949532017436 -13936.383137525536]}}
i.e.
> f = [2 -10088.6674944889 -3281.3820867312834, 2 4124.668381545453 4524.807156085763]
> f_t = [2 -173746.97965005718 -33281.18494907289, 2 298.2609121556852 23639.772884799597]
> f_s = [2 -18454.27716258352 -28337.509817580823, 2 1163.6949532017436 -13936.383137525536]
(f, fI) = testCaseStrokeFunctions trickyCusp2
t = 𝕀 (1 0.5798) (1 0.675)
s = 𝕀 (1 0.26798) (1 0.26799)
t_mid = 0.5 * ( 0.5798 + 0.675 )
s_mid = 0.5 * ( 0.26798 + 0.26799 )
D12 ( T f ) ( T ( T f_t ) ) ( T ( T f_s ) ) = dEdsdcdt $ eval fI (t, 3, s)
t' = coerce ( (-) @( 𝕀 Double ) ) t ( singleton ( 1 t_mid ) ) :: 𝕀 1
s' = coerce ( (-) @( 𝕀 Double ) ) s ( singleton ( 1 s_mid ) ) :: 𝕀 1
a = ( f_t, f_s )
b = negV2 $ singleton $ midV2 f
[((t2', s2'), isContr)] = gaussSeidel a b (t', s')
t2 = coerce ( (+) @( 𝕀 Double ) ) t2' ( singleton ( 1 t_mid ) ) :: 𝕀 1
s2 = coerce ( (+) @( 𝕀 Double ) ) s2' ( singleton ( 1 s_mid ) ) :: 𝕀 1
t2
> [1 0.6102365832093095, 1 0.6750000000000002]
s2
> [1 0.26798, 1 0.26799000000000006]
let ( 𝕀 ( 2 a11_lo a21_lo ) ( 2 a11_hi a21_hi ), 𝕀 ( 2 a12_lo a22_lo ) ( 2 a12_hi a22_hi ) ) = a
let ( 𝕀 ( 2 b1_lo b2_lo ) ( 2 b1_hi b2_hi ) ) = b
let ( 𝕀 ( 1 x1_lo ) ( 1 x1_hi ), 𝕀 ( 1 x2_lo ) ( 1 x2_hi ) ) = ( t', s' )
a11 = 𝕀 a11_lo a11_hi
a12 = 𝕀 a12_lo a12_hi
a21 = 𝕀 a21_lo a21_hi
a22 = 𝕀 a22_lo a22_hi
b1 = 𝕀 b1_lo b1_hi
b2 = 𝕀 b2_lo b2_hi
x1 = 𝕀 x1_lo x1_hi
x2 = 𝕀 x2_lo x2_hi
( b1 - a12 * x2 )
> [2981.90728508591, 2982.0918278575364]
extendedRecip a11
-}
negV2 :: 𝕀 2 -> 𝕀 2
negV2 ( 𝕀 ( 2 x_lo y_lo ) ( 2 x_hi y_hi ) ) =
let !( 𝕀 x'_lo x'_hi ) = negate $ 𝕀 x_lo x_hi
!( 𝕀 y'_lo y'_hi ) = negate $ 𝕀 y_lo y_hi
in 𝕀 ( 2 x'_lo y'_lo ) ( 2 x'_hi y'_hi )
midV2 :: 𝕀 2 -> 2
midV2 ( 𝕀 ( 2 x_lo y_lo ) ( 2 x_hi y_hi ) ) =
2 ( 0.5 * ( x_lo + x_hi ) ) ( 0.5 * ( y_lo + y_hi ) )
logLines :: [ String ]
logLines =
[ "f = dE/ds * dc/dt: f, df/dt, df/ds"
, "{" ++
(intercalate ","
[ "{" ++ showD (midPoint t) ++ "," ++ showD (midPoint s) ++ ",{" ++ intercalate "," vals ++ "}}"
| t <- map ( around 0.5798 ) [-0.05, -0.049.. 0.05]
, let i = 3
, s <- map ( around 0.26798 ) [-0.05, -0.049.. 0.05]
, let StrokeDatum
{ 𝛿E𝛿sdcdt = D12 (T f) (T (T f_t)) (T (T f_s))
} = (curvesI t `Seq.index` i) s
2 vx vy = midPoint2 f
2 vx_t vy_t = midPoint2 f_t
2 vx_s vy_s = midPoint2 f_s
vals = [ "{" ++ showD vx ++ "," ++ showD vy ++ "}"
, "{" ++ showD vx_t ++ "," ++ showD vy_t ++ "}"
, "{" ++ showD vx_s ++ "," ++ showD vy_s ++ "}"
]
]
) ++ "}"
]
where
around :: Double -> Double -> 𝕀 1
around z0 z = 𝕀 ( 1 ( z + z0 - 1e-6 ) ) ( 1 ( z + z0 + 1e-6 ) )
( _, curvesI ) = testCaseStrokeFunctions trickyCusp2
midPoint (𝕀 (1 lo) (1 hi)) = 0.5 * ( lo + hi )
midPoint2 (𝕀 (2 lo_x lo_y) (2 hi_x hi_y))
= 2 ( 0.5 * ( lo_x + hi_x ) ) ( 0.5 * ( lo_y + hi_y ) )
showD :: Double -> String
showD float = showFFloat (Just 6) float ""
--------------------------------------------------------------------------------
ellipse :: TestCase

View file

@ -24,7 +24,7 @@ module Math.Bezier.Stroke
, IntervalNewtonStep(..)
, IntervalNewtonLeaf(..)
, Box
, intervalNewtonGS, intervalNewtonGSFrom
, intervalNewtonGS, intervalNewtonGSFrom, gaussSeidel
)
where
@ -1288,18 +1288,6 @@ intersect ( 𝕀 lo1 hi1 ) ( 𝕀 lo2 hi2 )
lo = max lo1 lo2
hi = min hi1 hi2
extendedDivide :: 𝕀 Double -> 𝕀 Double -> [ 𝕀 Double ]
extendedDivide x y = map ( x * ) ( extendedRecip y )
extendedRecip :: 𝕀 Double -> [ 𝕀 Double ]
extendedRecip x@( 𝕀 lo hi )
| lo == 0 && hi == 0
= [ 𝕀 ( -1 / 0 ) ( 1 / 0 ) ]
| lo >= 0 || hi <= 0
= [ recip x ]
| otherwise
= [ recip ( 𝕀 lo 0 ), recip ( 𝕀 0 hi ) ]
-- | Computes the brush stroke coordinates of a cusp from
-- the @(t,s)@ parameter values.
cuspCoords :: ( 1 -> Seq ( 1 -> StrokeDatum 2 () ) )
@ -1421,7 +1409,7 @@ intervalNewtonGSFrom precondMethod minWidth eqs initBox =
<- ( eqs t `Seq.index` i ) s
, StrokeDatum { ee = D22 _ee_mid _ _ _ _ _
, 𝛿E𝛿sdcdt = D12 ( T f_mid ) ( T ( T f_t_mid ) ) ( T ( T f_s_mid ) ) }
, 𝛿E𝛿sdcdt = D12 ( T f_mid ) ( T ( T _f_t_mid ) ) ( T ( T _f_s_mid ) ) }
<- ( eqs i_t_mid `Seq.index` i ) i_s_mid
, let ee_potential_zero = inf ee <= 1 0 && sup ee >= 1 0
𝛿E𝛿sdcdt_potential_zero = cmp2 (<=) ( inf f ) ( 2 0 0 ) && cmp2 (>=) ( sup f ) ( 2 0 0 )
@ -1433,7 +1421,7 @@ intervalNewtonGSFrom precondMethod minWidth eqs initBox =
-- for the equation f'(x) v = - f(x_mid),
-- where f = 𝛿E/𝛿s * dc/dt
!( a, b ) = precondition precondMethod
( f_t_mid, f_s_mid )
( midI f_t, midI f_s )
( f_t, f_s ) ( neg f_mid )
--(a, b)
-- | 𝕀 (1 ee_lo) (1 ee_hi) <- ee_mid
@ -1482,6 +1470,9 @@ intervalNewtonGSFrom precondMethod minWidth eqs initBox =
| otherwise
-> return [ IntervalNewtonLeaf $ NoSolution (if ee_potential_zero then "dc/dt" else "ee") cand ]
where
midI :: 𝕀 2 -> 𝕀 2
midI ( 𝕀 ( 2 x_lo y_lo ) ( 2 x_hi y_hi ) ) =
singleton $ 2 ( 0.5 * ( x_lo + x_hi ) ) ( 0.5 * ( y_lo + y_hi ) )
t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi )
i_t_mid = singleton ( 1 t_mid )

View file

@ -11,11 +11,12 @@ module Math.Interval
, singleton, nonDecreasing
, inside
, aabb
, extendedDivide, extendedRecip
)
where
-- base
import Prelude hiding ( Num(..) )
import Prelude hiding ( Num(..), Fractional(..) )
-- acts
import Data.Act
@ -69,6 +70,26 @@ instance Act ( T ( 𝕀 Double ) ) ( 𝕀 Double ) where
instance Torsor ( T ( 𝕀 Double ) ) ( 𝕀 Double ) where
a --> b = T $ b - a
-------------------------------------------------------------------------------
-- Extended division
extendedDivide :: ( Field d, Field ( 𝕀 d ), Ord d ) => 𝕀 d -> 𝕀 d -> [ 𝕀 d ]
extendedDivide x y = map ( x * ) ( extendedRecip y )
{-# SPECIALISE extendedDivide :: 𝕀 Double -> 𝕀 Double -> [ 𝕀 Double ] #-}
extendedRecip :: ( Field d, Field ( 𝕀 d ), Ord d ) => 𝕀 d -> [ 𝕀 d ]
extendedRecip x@( 𝕀 lo hi )
| lo == fromInteger 0 && hi == fromInteger 0
= [ 𝕀 negInf posInf ]
| lo >= fromInteger 0 || hi <= fromInteger 0
= [ recip x ]
| otherwise
= [ 𝕀 negInf ( recip lo ), 𝕀 ( recip hi ) posInf ]
where
negInf = fromInteger (-1) / fromInteger 0
posInf = fromInteger 1 / fromInteger 0
{-# SPECIALISE extendedRecip :: 𝕀 Double -> [ 𝕀 Double ] #-}
-------------------------------------------------------------------------------
-- Lattices.

View file

@ -109,7 +109,11 @@ instance Prelude.Fractional ( 𝕀 Double ) where
in 𝕀 q q
recip (𝕀 lo hi)
-- #ifdef ASSERTS
| lo >= 0 || hi <= 0
| lo == 0
= 𝕀 ( fst $ divI 1 hi ) ( 1 / 0 )
| hi == 0
= 𝕀 ( -1 / 0 ) ( snd $ divI 1 lo )
| lo > 0 || hi < 0
-- #endif
= 𝕀 ( fst $ divI 1 hi ) ( snd $ divI 1 lo )
-- #ifdef ASSERTS
@ -118,7 +122,11 @@ instance Prelude.Fractional ( 𝕀 Double ) where
-- #endif
𝕀 x_lo x_hi / 𝕀 y_lo y_hi
-- #ifdef ASSERTS
| y_lo >= 0 || y_hi <= 0
| y_lo == 0
= 𝕀 ( fst $ divI x_lo y_hi ) ( 1 / 0 )
| y_hi == 0
= 𝕀 ( -1 / 0 ) ( snd $ divI x_hi y_lo )
| y_lo > 0 || y_hi < 0
-- #endif
= 𝕀 ( fst $ divI x_lo y_hi ) ( snd $ divI x_hi y_lo )
-- #ifdef ASSERTS