From a18864db55fae03fa4ad2e9ba1095999861255cf Mon Sep 17 00:00:00 2001 From: stla Date: Sun, 5 May 2024 01:56:42 +0200 Subject: [PATCH] removed semi-unbounded intervals (does not work) --- src/Math/Algebra/Hspray.hs | 37 +++++++++++++++---------------------- tests/Main.hs | 27 ++++++++++++++++++--------- 2 files changed, 33 insertions(+), 31 deletions(-) diff --git a/src/Math/Algebra/Hspray.hs b/src/Math/Algebra/Hspray.hs index d49ef56..54884fd 100644 --- a/src/Math/Algebra/Hspray.hs +++ b/src/Math/Algebra/Hspray.hs @@ -2682,55 +2682,48 @@ signVariations' = _signVariations signFunc | otherwise = '-' _numberOfRealRootsInOpenInterval :: - (AlgRing.C a, Ord a) => ([a] -> Int) -> Spray a -> a -> Maybe a -> Int + (AlgRing.C a, Ord a) => ([a] -> Int) -> Spray a -> a -> a -> Int _numberOfRealRootsInOpenInterval signVariationsFunc spray alpha beta | isConstantSpray spray = if isZeroSpray spray then error "numberOfRealRootsInInterval: the spray is null." else 0 - | betaIsJust = - if alpha == beta' + | otherwise = + if alpha == beta then 0 else - if alpha > beta' + if alpha > beta then error "numberOfRealRootsInInterval: the bounds are not ordered." else if isZeroAtBeta then svDiff - 1 else svDiff - | otherwise = svAtAlpha where - betaIsJust = isJust beta - beta' = if betaIsJust then fromJust beta else undefined (ginit, glast) = fromJust $ unsnoc $ filter (not . isZeroSpray) (sturmHabichtSequence 1 spray) sprayAtAlpha = evaluateAt [alpha] glast - sprayAtBeta = evaluateAt [beta'] glast + sprayAtBeta = evaluateAt [beta] glast isZeroAtBeta = sprayAtBeta == AlgAdd.zero galpha = map (evaluateAt [alpha]) ginit ++ [sprayAtAlpha] - gbeta = map (evaluateAt [beta']) ginit ++ [sprayAtBeta] + gbeta = map (evaluateAt [beta]) ginit ++ [sprayAtBeta] svAtAlpha = signVariationsFunc galpha svAtBeta = signVariationsFunc gbeta svDiff = svAtAlpha - svAtBeta _numberOfRealRootsInClosedInterval :: - (AlgRing.C a, Ord a) => ([a] -> Int) -> Spray a -> a -> Maybe a -> Int + (AlgRing.C a, Ord a) => ([a] -> Int) -> Spray a -> a -> a -> Int _numberOfRealRootsInClosedInterval signVariationsFunc spray alpha beta = _numberOfRealRootsInOpenInterval signVariationsFunc spray alpha beta + toAdd where - betaIsJust = isJust beta - beta' = if betaIsJust then fromJust beta else undefined isZeroAtAlpha = evaluateAt [alpha] spray == AlgAdd.zero - isZeroAtBeta = evaluateAt [beta'] spray == AlgAdd.zero - toAdd = if betaIsJust - then if alpha == beta' - then fromEnum isZeroAtAlpha - else fromEnum isZeroAtAlpha + fromEnum isZeroAtBeta - else fromEnum isZeroAtAlpha + isZeroAtBeta = evaluateAt [beta] spray == AlgAdd.zero + toAdd = if alpha == beta + then fromEnum isZeroAtAlpha + else fromEnum isZeroAtAlpha + fromEnum isZeroAtBeta -- | Number of real roots of a spray in an open interval (that makes sense -- only for a spray on a ring embeddable in the real numbers). numberOfRealRootsInOpenInterval :: - (Num a, AlgRing.C a, Ord a) => Spray a -> a -> Maybe a -> Int + (Num a, AlgRing.C a, Ord a) => Spray a -> a -> a -> Int numberOfRealRootsInOpenInterval spray = if isUnivariate spray then _numberOfRealRootsInOpenInterval signVariations spray @@ -2740,7 +2733,7 @@ numberOfRealRootsInOpenInterval spray = -- only for a spray on a ring embeddable in the real numbers). The roots are -- not counted with their multiplicity. numberOfRealRootsInClosedInterval :: - (Num a, AlgRing.C a, Ord a) => Spray a -> a -> Maybe a -> Int + (Num a, AlgRing.C a, Ord a) => Spray a -> a -> a -> Int numberOfRealRootsInClosedInterval spray = if isUnivariate spray then _numberOfRealRootsInClosedInterval signVariations spray @@ -2749,7 +2742,7 @@ numberOfRealRootsInClosedInterval spray = -- | Number of real roots of a spray in an open interval (that makes sense -- only for a spray on a ring embeddable in the real numbers). numberOfRealRootsInOpenInterval' :: - (AlgAbs.C a, Ord a) => Spray a -> a -> Maybe a -> Int + (AlgAbs.C a, Ord a) => Spray a -> a -> a -> Int numberOfRealRootsInOpenInterval' spray = if isUnivariate spray then _numberOfRealRootsInOpenInterval signVariations' spray @@ -2759,7 +2752,7 @@ numberOfRealRootsInOpenInterval' spray = -- only for a spray on a ring embeddable in the real numbers). The roots are -- not counted with their multiplicity. numberOfRealRootsInClosedInterval' :: - (AlgAbs.C a, Ord a) => Spray a -> a -> Maybe a -> Int + (AlgAbs.C a, Ord a) => Spray a -> a -> a -> Int numberOfRealRootsInClosedInterval' spray = if isUnivariate spray then _numberOfRealRootsInClosedInterval signVariations' spray diff --git a/tests/Main.hs b/tests/Main.hs index 459af63..0831413 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TupleSections #-} module Main (main) where import qualified Algebra.Additive as AlgAdd import qualified Algebra.Module as AlgMod @@ -888,15 +887,25 @@ main = defaultMain $ testGroup x = qlone 1 factors = [x ^-^ constantSpray (toRational i) | i <- [1::Int .. 5]] spray = productOfSprays factors - intervals = [(0, Just 9), (1, Just 6), (2, Just 3), (0, Just 4), (2 + (1%4), Just $ 3 - (1%4))] - nroots = map (uncurry (numberOfRealRootsInClosedInterval spray)) intervals - nroots' = map (uncurry (numberOfRealRootsInOpenInterval spray)) intervals - infiniteIntervals = map (, Nothing) [0, 1, 2, 2 + (1%4), 5] - nroots'' = map (uncurry (numberOfRealRootsInClosedInterval spray)) infiniteIntervals - nroots''' = map (uncurry (numberOfRealRootsInOpenInterval spray)) infiniteIntervals + intervals = [ + (0, 9) + , (1, 6) + , (2, 3) + , (0, 4) + , (2 + (1%4), 3 - (1%4)) + ] + nroots = + map (uncurry (numberOfRealRootsInClosedInterval spray)) intervals + nroots' = + map (uncurry (numberOfRealRootsInOpenInterval spray)) intervals + -- infiniteIntervals = map (, Nothing) [0, 1, 2, 2 + (1%4), 5] + -- nroots'' = map (uncurry (numberOfRealRootsInClosedInterval spray)) + -- infiniteIntervals + -- nroots''' = map (uncurry (numberOfRealRootsInOpenInterval spray)) + -- infiniteIntervals assertEqual "" - (nroots, nroots', nroots'', nroots''') - ([5, 5, 2, 4, 0], [5, 4, 0, 3, 0], [5, 5, 4, 3, 1], [5, 4, 3, 3, 0]) + (nroots, nroots') -- , nroots'', nroots''') + ([5, 5, 2, 4, 0], [5, 4, 0, 3, 0]) -- , [5, 5, 4, 3, 1], [5, 4, 3, 3, 0]) , testCase "number of real roots" $ do let