diff options
| author | MichalKonecny <> | 2009-07-28 23:04:26 (GMT) |
|---|---|---|
| committer | Luite Stegeman <luite@luite.com> | 2009-07-28 23:04:26 (GMT) |
| commit | 9ea559ff4a4eaf5c7232a45050e87fe99bbf9753 (patch) | |
| tree | 87da3114ed0a01cb661829f3f3e8bf95d28fab58 | |
| parent | 70c7767589f1b4b993563dd05fe47c9c6b668a29 (diff) | |
version 0.50.5
55 files changed, 5080 insertions, 2028 deletions
diff --git a/AERN-RnToRm.cabal b/AERN-RnToRm.cabal index a2dee5a..04773d8 100644 --- a/AERN-RnToRm.cabal +++ b/AERN-RnToRm.cabal @@ -1,12 +1,13 @@ Name: AERN-RnToRm -Version: 0.4.9.1 +Version: 0.5 Cabal-Version: >= 1.2 Build-Type: Simple License: BSD3 License-File: LICENCE Author: Michal Konecny (Aston University) -Copyright: (c) 2007-2008 Michal Konecny -Maintainer: mik@konecny.aow.cz +Copyright: (c) 2007-2009 Michal Konecny, Jan Duracz +Maintainer: mikkonecny@gmail.com +Homepage: http://www-users.aston.ac.uk/~konecnym/DISCERN Stability: experimental Category: Data, Math Synopsis: polynomial function enclosures (PFEs) approximating exact real functions @@ -32,49 +33,57 @@ Description: with Taylor Models is included in the paper <http://www-users.aston.ac.uk/~konecnym/papers/cfv08.html>. . - Simple examples of usage can be found in folder @tests@. + Simple examples of usage can be found in folder @demos@ + and a test suite can be run via the module in the folder @tests@. + Extra-source-files: - tests/Demo.hs tests/ISin3.hs -Data-files: + demos/Demo.hs demos/ISin3.hs + tests/RunPolynomTests.hs ChangeLog Library hs-source-dirs: src Build-Depends: - AERN-Real >= 0.9.9, base >= 3, base < 4, containers, binary >= 0.4, html >= 1.0, QuickCheck >= 1.2, QuickCheck < 2, time, filepath, directory + AERN-Real >= 0.10, AERN-Real < 0.10.1, base >= 3, base < 4, containers, binary >= 0.4, html >= 1.0, QuickCheck >= 1.2, QuickCheck < 2, time, filepath, directory Exposed-modules: - Data.Number.ER.RnToRm, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Integration, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Compose, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Elementary, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Division, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Compose, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Bounds, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Ring, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Enclosure, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Elementary, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Reduce, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Division, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Run, - Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom, - Data.Number.ER.RnToRm.UnitDom.Base, - Data.Number.ER.RnToRm.UnitDom.Approx.Interval, - Data.Number.ER.RnToRm.UnitDom.Approx, - Data.Number.ER.RnToRm.TestingDefs, - Data.Number.ER.RnToRm.DefaultRepr, - Data.Number.ER.RnToRm.BisectionTree.Integration, - Data.Number.ER.RnToRm.BisectionTree.Path, - Data.Number.ER.RnToRm.BisectionTree, - Data.Number.ER.RnToRm.Approx.DomEdges, - Data.Number.ER.RnToRm.Approx.DomTransl, - Data.Number.ER.RnToRm.Approx.PieceWise, - Data.Number.ER.RnToRm.Approx.Tuple, - Data.Number.ER.RnToRm.Approx - + Data.Number.ER.RnToRm, + Data.Number.ER.RnToRm.Approx, + Data.Number.ER.RnToRm.Approx.DomEdges, + Data.Number.ER.RnToRm.Approx.DomTransl, + Data.Number.ER.RnToRm.Approx.PieceWise, + Data.Number.ER.RnToRm.Approx.Tuple, + Data.Number.ER.RnToRm.BisectionTree, + Data.Number.ER.RnToRm.BisectionTree.Integration, + Data.Number.ER.RnToRm.BisectionTree.Path, + Data.Number.ER.RnToRm.DefaultRepr, + Data.Number.ER.RnToRm.TestingDefs, + Data.Number.ER.RnToRm.UnitDom.Approx, + Data.Number.ER.RnToRm.UnitDom.Approx.Interval, + Data.Number.ER.RnToRm.UnitDom.Approx.IntervalOI, + Data.Number.ER.RnToRm.UnitDom.Base, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Bounds, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Compose, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Division, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Elementary, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Enclosure, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Integration, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Reduce, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Ring, + Data.Number.ER.RnToRm.UnitDom.Base.Tests.Run, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Compose, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Derivative, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Division, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.DivisionInner, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Elementary, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.ElementaryInner, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.EnclosureInner, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Integration, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce, + Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring @@ -1,3 +1,13 @@ +0.5.0: 28 July 2009 + * Made the testing harness more generic so that it can be used + for any base. Also a readable report is produced for each + tested property with statistics for timing and precision. + * New support for anti-consistent function enclosures and twin arithmetic + (analogous to directed/improper intervals such as [2,0] and + outer+inner rounded Kaucher arithmetic over them). + * Fixed many bugs. + * Improved precision of enclosure comparison. + 0.4.9.1: 24 February 2009: fixed errors in haddoc comments 0.4.9: 23 February 2009 * Added a quickcheck testing harness for the polynomial arithmetic core. diff --git a/tests/Demo.hs b/demos/Demo.hs index 52619f7..275ce21 100644 --- a/tests/Demo.hs +++ b/demos/Demo.hs @@ -13,7 +13,7 @@ module Main where import qualified Data.Number.ER.RnToRm as AERNFunc -import qualified Data.Number.ER.Real.DomainBox as DBox +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox import qualified Data.Number.ER.Real as AERN diff --git a/tests/ISin3.hs b/demos/ISin3.hs index baaa75a..131b64d 100644 --- a/tests/ISin3.hs +++ b/demos/ISin3.hs @@ -28,20 +28,27 @@ type IRA = AERN.IRA B main = do AERN.initialiseBaseArithmetic (0 :: RA) - putStrLn $ "integ(sin(sin(sin(x)))dx = " ++ show result + putStrLn $ "ix = " ++ show ix ++ "; deg = " ++ show deg ++ "; gran = " ++ show gran +-- putStrLn $ "sin(sin(sin(x))) = " ++ show sin3 +-- putStrLn $ "integ(sin(sin(sin(x)))dx = " ++ show integrSin3 + putStrLn $ "integ_0^1(sin(sin(sin(x)))dx] = " ++ show result putStrLn $ " precision = " ++ show (AERN.getPrecision result) where result = - head $ - AERNFunc.eval (AERNFunc.unary 1) $ - AERNFunc.integrateUnary 0 - (sin3 120 0 42 160) - 0 (0 AERN.\/ 1) [0] - sin3 ix depth deg gran = + head $ AERNFunc.eval (AERNFunc.unary 1) integrSin3 + integrSin3 = + AERNFunc.integrateUnary 0 sin3 (0 AERN.\/ 1) 0 [0] + ix = 100 + deg = 50 + size = 1000 + gran = 5000 + depth = 0 + sin3 = AERN.sin ix $ AERN.sin ix $ AERN.sin ix $ AERNFunc.bisectUnbisectDepth depth $ - AERN.setMinGranularity gran $ - AERNFunc.setMaxDegree deg fapwUPX0 + AERNFunc.bisectUnbisectDepth depth $ + AERNFunc.setMaxSize size $ + AERNFunc.setMaxDegree deg fapwUPX0 diff --git a/src/Data/Number/ER/RnToRm.hs b/src/Data/Number/ER/RnToRm.hs index cb87ff7..9a0b889 100644 --- a/src/Data/Number/ER/RnToRm.hs +++ b/src/Data/Number/ER/RnToRm.hs @@ -77,13 +77,13 @@ module Data.Number.ER.RnToRm ( module Data.Number.ER.RnToRm.DefaultRepr, module Data.Number.ER.RnToRm.Approx, - module Data.Number.ER.Real.DomainBox + module Data.Number.ER.BasicTypes.DomainBox ) where import Data.Number.ER.RnToRm.DefaultRepr import Data.Number.ER.RnToRm.Approx -import Data.Number.ER.Real.DomainBox +import Data.Number.ER.BasicTypes.DomainBox import qualified Data.Number.ER.RnToRm.UnitDom.Approx as UFA import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB diff --git a/src/Data/Number/ER/RnToRm/Approx.hs b/src/Data/Number/ER/RnToRm/Approx.hs index 86be60c..9377d58 100644 --- a/src/Data/Number/ER/RnToRm/Approx.hs +++ b/src/Data/Number/ER/RnToRm/Approx.hs @@ -20,15 +20,16 @@ module Data.Number.ER.RnToRm.Approx ERFnDomApprox(..), bisectUnbisectDepth, keyPointsConsistencyCheck, - keyPointsPointwiseConsistencyCheck + keyPointsPointwiseConsistencyCheck, + ERFnApproxApprox(..) ) where import Prelude hiding (const) import qualified Data.Number.ER.Real.Approx as RA -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc @@ -49,7 +50,7 @@ import qualified Data.Map as Map * two real number types (instances of 'RA.ERIntApprox') for working with parts of the function's domain and range; * a type of boxes indexed by variables (instance of 'DomainBox') for working with - parts of the function's domain. + multiple-dimension function domains. -} class (RA.ERApprox fa, RA.ERIntApprox fa, RA.ERIntApprox domra, RA.ERIntApprox ranra, @@ -397,4 +398,33 @@ keyPointsConsistencyCheck g fRes = [fResPt] = eval ptB fRes isInConsistent (_, gResPt, fResPt) = RA.isDisjoint gResPt fResPt -
\ No newline at end of file + + +{-| + A class of types that approximate function enclosures of first-order real functions + @R^n -> R^m@ eg using a pair of function enclosures. The domains + of the functions can be neither specified nor investigated + by operations in this class. + + This class extends 'RA.ERApproxApprox' so that we could perform point-wise + operations on the function enclosures. + + This class is associated with: + + * a real number type (instance of 'RA.ERIntApprox') for working with parts of the function's domain + + * a real number approximation approximation for approximating the function enclosure + range at an individual point or uniformly over many points; + + * a type of boxes indexed by variables (instance of 'DomainBox') for working with + multiple-dimension function domains. +-} +class + (RA.ERIntApprox domra, RA.ERApproxApprox ranraa, + DomainBox box varid domra) => + ERFnApproxApprox box varid domra ranraa fa + | fa -> box varid domra ranraa + where + evalAA :: box -> fa -> [ranraa] + +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/Approx/DomEdges.hs b/src/Data/Number/ER/RnToRm/Approx/DomEdges.hs index 6a42104..b5c0823 100644 --- a/src/Data/Number/ER/RnToRm/Approx/DomEdges.hs +++ b/src/Data/Number/ER/RnToRm/Approx/DomEdges.hs @@ -25,11 +25,11 @@ import qualified Data.Number.ER.RnToRm.Approx as FA import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Approx.Elementary as RAEL -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc -import Data.Number.ER.PlusMinus +import Data.Number.ER.BasicTypes.PlusMinus import Data.Number.ER.ShowHTML import qualified Text.Html as H @@ -226,8 +226,8 @@ instance RA.initialiseBaseArithmetic (0 :: fa) getGranularity (ERFnDomEdgesApprox mainEncl edges) = RA.getGranularity mainEncl - setGranularity gran = edgesLift1 (RA.setGranularity gran) - setMinGranularity gran = edgesLift1 (RA.setMinGranularity gran) + setGranularityOuter gran = edgesLift1 (RA.setGranularityOuter gran) + setMinGranularityOuter gran = edgesLift1 (RA.setMinGranularityOuter gran) f1 /\ f2 = edgesLift2 (RA./\) f1 f2 intersectMeasureImprovement ix f1@(ERFnDomEdgesApprox mainEncl1 edges1) @@ -345,6 +345,7 @@ instance ranra2domra fa r = FA.ranra2domra (erfnMainVolume fa) r setMaxDegree maxDegree = edgesLift1 (FA.setMaxDegree maxDegree) + setMaxSize maxSize = edgesLift1 (FA.setMaxSize maxSize) getTupleSize (ERFnDomEdgesApprox mainEncl _) = FA.getTupleSize mainEncl tuple [] = error "ERFnDomEdgesApprox: FA.tuple: empty list" diff --git a/src/Data/Number/ER/RnToRm/Approx/DomTransl.hs b/src/Data/Number/ER/RnToRm/Approx/DomTransl.hs index d2c8282..1cabe29 100644 --- a/src/Data/Number/ER/RnToRm/Approx/DomTransl.hs +++ b/src/Data/Number/ER/RnToRm/Approx/DomTransl.hs @@ -29,8 +29,8 @@ import qualified Data.Number.ER.RnToRm.Approx as FA import qualified Data.Number.ER.RnToRm.UnitDom.Approx as UFA import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Approx.Elementary as RAEL -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainIntBox, DomainBoxMappable) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainIntBox, DomainBoxMappable) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc @@ -149,7 +149,7 @@ makeDomTransl dom (dL, dH) = RA.bounds dom dHPdL = dH + dL dHMdL = dH - dL - dHMdLgr = RA.setMinGranularity 100 dHMdL + dHMdLgr = RA.setMinGranularityOuter 100 dHMdL -- fromUnit x = (x * (dHMdL) + dHPdL) / 2 -- toUnit y = (2 * y - dHPdL) / dHMdL @@ -303,10 +303,11 @@ instance RA.initialiseBaseArithmetic (0 :: ufa) getGranularity (ERFnDomTranslApprox ufa dtrB) = RA.getGranularity ufa - setGranularity gran (ERFnDomTranslApprox ufa dtrB) = - ERFnDomTranslApprox (RA.setGranularity gran ufa) dtrB - setMinGranularity gran (ERFnDomTranslApprox ufa dtrB) = - ERFnDomTranslApprox (RA.setMinGranularity gran ufa) dtrB + setGranularityOuter gran (ERFnDomTranslApprox ufa dtrB) = + ERFnDomTranslApprox (RA.setGranularityOuter gran ufa) dtrB + setMinGranularityOuter gran (ERFnDomTranslApprox ufa dtrB) = + ERFnDomTranslApprox (RA.setMinGranularityOuter gran ufa) dtrB + isBottom = RA.isBottom . erfnUnitApprox (ERFnDomTranslApprox ufa1 dtrB1) /\ (ERFnDomTranslApprox ufa2 dtrB2) = ERFnDomTranslApprox (ufa1 RA./\ ufa2) (dtrUnion msg dtrB1 dtrB2) where @@ -333,6 +334,16 @@ instance compare dtrB1 dtrB2 ] +instance (RA.ERApproxApprox ufa) => + RA.ERApproxApprox (ERFnDomTranslApprox dtrbox varid ufa domra) + where + safeIncludes fa1 fa2 = + RA.safeIncludes (erfnUnitApprox fa1) (erfnUnitApprox fa2) + safeNotIncludes fa1 fa2 = + RA.safeNotIncludes (erfnUnitApprox fa1) (erfnUnitApprox fa2) + includes fa1 fa2 = + RA.includes (erfnUnitApprox fa1) (erfnUnitApprox fa2) + instance (UFA.ERUnitFnApprox box varid domra ranra ufa, RA.ERIntApprox ufa , DomainBoxMappable dtrbox box varid (DomTransl domra) domra, Eq dtrbox, Ord dtrbox) => @@ -363,6 +374,8 @@ instance where abs ix (ERFnDomTranslApprox ufa dtrB) = ERFnDomTranslApprox (RAEL.abs ix ufa) dtrB + sqrt ix f@(ERFnDomTranslApprox ufa dtrB) = + ERFnDomTranslApprox (RAEL.sqrt ix ufa) dtrB exp ix f@(ERFnDomTranslApprox ufa dtrB) = -- unsafePrintReturn ("DomTransl: exp of " ++ show f ++ "\n = ") $ ERFnDomTranslApprox (RAEL.exp ix ufa) dtrB @@ -570,9 +583,9 @@ instance size = domRgr - domLgr sizeLeft = ptGr - domLgr sizeRight = domRgr - ptGr - domRgr = RA.setMinGranularity gran $ FA.domra2ranra ufa domR - domLgr = RA.setMinGranularity gran $ FA.domra2ranra ufa domL - ptGr = RA.setMinGranularity gran $ FA.domra2ranra ufa pt + domRgr = RA.setMinGranularityOuter gran $ FA.domra2ranra ufa domR + domLgr = RA.setMinGranularityOuter gran $ FA.domra2ranra ufa domL + ptGr = RA.setMinGranularityOuter gran $ FA.domra2ranra ufa pt integrate ix fD@(ERFnDomTranslApprox ufaD dtrBD) x integdomBox origin fI@(ERFnDomTranslApprox ufaInit dtrBInit) = @@ -609,5 +622,18 @@ instance error $ "DomTransl: faIntegrate: variable " ++ showVar x ++ " not in the domain of the function " ++ show fD - - + +instance + (DomainBoxMappable box dtrbox varid domra (DomTransl domra), + FA.ERFnApproxApprox box varid domra ranraa ufa) => + FA.ERFnApproxApprox box varid domra ranraa (ERFnDomTranslApprox dtrbox varid ufa domra) + where + evalAA box (ERFnDomTranslApprox ufa dtrB) = + FA.evalAA translBox ufa + where + translBox = domToUnit dtrB box + + + + + diff --git a/src/Data/Number/ER/RnToRm/Approx/PieceWise.hs b/src/Data/Number/ER/RnToRm/Approx/PieceWise.hs index a5d34ec..364f289 100644 --- a/src/Data/Number/ER/RnToRm/Approx/PieceWise.hs +++ b/src/Data/Number/ER/RnToRm/Approx/PieceWise.hs @@ -36,8 +36,8 @@ import qualified Data.Number.ER.RnToRm.Approx as FA import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Approx.Elementary as RAEL -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc @@ -182,8 +182,8 @@ instance RA.initialiseBaseArithmetic (0 :: fa) getGranularity (ERFnPiecewise bistr) = foldl max 10 $ map RA.getGranularity $ BISTR.collectValues bistr - setGranularity gran = pwLift1 (RA.setGranularity gran) - setMinGranularity gran = pwLift1 (RA.setMinGranularity gran) + setGranularityOuter gran = pwLift1 (RA.setGranularityOuter gran) + setMinGranularityOuter gran = pwLift1 (RA.setMinGranularityOuter gran) f1 /\ f2 = pwLift2 (RA./\) 10 f1 f2 intersectMeasureImprovement ix f1@(ERFnPiecewise bistr1) f2@(ERFnPiecewise bistr2) = -- unsafePrint @@ -269,6 +269,7 @@ instance where (fa : _) = BISTR.collectValues bistr setMaxDegree maxDegree = pwLift1 (FA.setMaxDegree maxDegree) + setMaxSize maxSize = pwLift1 (FA.setMaxSize maxSize) getTupleSize (ERFnPiecewise bistr) = FA.getTupleSize $ head $ BISTR.collectValues bistr tuple fs = diff --git a/src/Data/Number/ER/RnToRm/Approx/Tuple.hs b/src/Data/Number/ER/RnToRm/Approx/Tuple.hs index bb16ab4..58fdecc 100644 --- a/src/Data/Number/ER/RnToRm/Approx/Tuple.hs +++ b/src/Data/Number/ER/RnToRm/Approx/Tuple.hs @@ -25,7 +25,7 @@ where import qualified Data.Number.ER.RnToRm.Approx as FA import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Approx.Elementary as RAEL -import qualified Data.Number.ER.Real.DomainBox as DBox +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox import Data.Number.ER.BasicTypes import Data.Number.ER.Misc @@ -172,8 +172,8 @@ instance RA.initialiseBaseArithmetic (0 :: fa) getGranularity (ERFnTuple fas) = foldl max 10 $ map RA.getGranularity fas - setGranularity gran = tuplesLift1 (RA.setGranularity gran) - setMinGranularity gran = tuplesLift1 (RA.setMinGranularity gran) + setGranularityOuter gran = tuplesLift1 (RA.setGranularityOuter gran) + setMinGranularityOuter gran = tuplesLift1 (RA.setMinGranularityOuter gran) f1 /\ f2 = tuplesLift2 "ERFnTuple: /\\: " (RA./\) f1 f2 refines f1@(ERFnTuple fas1) f2@(ERFnTuple fas2) = and $ zipWith RA.refines fas1 fas2 @@ -242,6 +242,7 @@ instance ranra2domra (ERFnTuple (fa:_)) r = FA.ranra2domra fa r setMaxDegree maxDegree = tuplesLift1 (FA.setMaxDegree maxDegree) + setMaxSize maxSize = tuplesLift1 (FA.setMaxSize maxSize) getTupleSize (ERFnTuple fas) = length fas tuple fs | sameDomains doms = diff --git a/src/Data/Number/ER/RnToRm/BisectionTree.hs b/src/Data/Number/ER/RnToRm/BisectionTree.hs index c73059f..974bf70 100644 --- a/src/Data/Number/ER/RnToRm/BisectionTree.hs +++ b/src/Data/Number/ER/RnToRm/BisectionTree.hs @@ -46,8 +46,8 @@ import Prelude hiding (const, map, compare) import qualified Prelude import qualified Data.Number.ER.Real.Approx as RA -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc @@ -113,18 +113,18 @@ instance (VariableID varid, Show d, Show v, DomainBox box varid d) => showBisectionTree showValue = showB where - showB (Leaf depth dom val) = + showB (Leaf depth domB val) = "\n" ++ (concat (replicate (depth * 2) ".")) ++ "o " ++ - (concatWith "," (Prelude.map showVD $ DBox.toList dom)) + (concatWith "," (Prelude.map showVD $ DBox.toList domB)) ++ " |---> " ++ showValue val - showB (Node depth dom dir pt lo hi) = + showB (Node depth domB dir pt lo hi) = "\n" ++ (concat (replicate (depth * 2) ".")) ++ "o " ++ - (concatWith "," (Prelude.map showVD $ DBox.toList dom)) + (concatWith "," (Prelude.map showVD $ DBox.toList domB)) ++ " //" ++ showVar dir ++ "\\\\" ++ @@ -135,10 +135,10 @@ showBisectionTree showValue = instance (Show d, H.HTML v, DomainBox box varid d) => H.HTML (BisectionTree box varid d v) where - toHtml (Leaf depth dom val) = + toHtml (Leaf depth domB val) = H.toHtmlFromList $ [ - H.toHtml $ concatWith "," (Prelude.map showVD $ DBox.toList dom) + H.toHtml $ concatWith "," (Prelude.map showVD $ DBox.toList domB) , H.primHtml " → " , @@ -147,7 +147,7 @@ instance (Show d, H.HTML v, DomainBox box varid d) => where showVD (v,d) = showVar v ++ " in " ++ show d - toHtml (Node depth dom dir pt lo hi) = + toHtml (Node depth domB dir pt lo hi) = H.toHtml $ besidesTable [H.border 2] [ @@ -168,8 +168,8 @@ const :: box -> v -> BisectionTree box varid d v -const dom value = - Leaf 0 dom value +const domB value = + Leaf 0 domB value {-| value splitter function - parameters are: @@ -213,46 +213,46 @@ split valSplitter ix splitDir splitPt fallbackDom bistr = resultBistr where resultBistr = spl bistr - spl (Leaf depth dom val) = - Node depth dom splitDir splitPt childLO childHI + spl (Leaf depth domB val) = + Node depth domB splitDir splitPt childLO childHI where childLO = Leaf depthInc domLO valLO childHI = Leaf depthInc domHI valHI (valLO, valHI) = - valSplitter ix depth dom val splitDir splitPt + valSplitter ix depth domB val splitDir splitPt depthInc = depth + 1 domLO = - DBox.insert splitDir dirDomLO dom + DBox.insert splitDir dirDomLO domB domHI = - DBox.insert splitDir dirDomHI dom + DBox.insert splitDir dirDomHI domB (dirDomLO, dirDomHI) = RA.bisectDomain (Just splitPt) dirDom dirDom = DBox.findWithDefault (DBox.lookup "BisectionTree: split: fallbackDom: " splitDir fallbackDom) - splitDir dom - spl bistr@(Node depth dom dir pt childLO childHI) + splitDir domB + spl bistr@(Node depth domB dir pt childLO childHI) | dir == splitDir = case RA.compareReals pt splitPt of Just LT -> -- split on lower half - Node depth dom dir pt + Node depth domB dir pt (Node depthInc domChildLO splitDir splitPt childLOsplitLO childLOsplitHI) childHI Just GT -> -- split on higher half - Node depth dom dir pt + Node depth domB dir pt childLO (Node depthInc domChildHI splitDir splitPt childHIsplitLO childHIsplitHI) _ -> bistr | otherwise = -- splitDir < dir = - Node depth dom dir pt + Node depth domB dir pt (Node depthInc domChildLO splitDir splitPt childLOsplitLO childLOsplitHI) (Node depthInc domChildHI splitDir splitPt childHIsplitLO childHIsplitHI) -- | dir < splitDir = - -- Node depth dom dir childLOsplit childHIsplit + -- Node depth domB dir childLOsplit childHIsplit where depthInc = depth + 1 domChildLO = bistrDom childLO @@ -270,8 +270,8 @@ mapWithDom :: (box -> v1 -> v2) -> BisectionTree box varid d v1 -> BisectionTree box varid d v2 -mapWithDom f bistr@(Leaf _ dom val) = - bistr { bistrVal = f dom val } +mapWithDom f bistr@(Leaf _ domB val) = + bistr { bistrVal = f domB val } mapWithDom f bistr@(Node _ _ _ _ cLO cHI) = bistr { @@ -286,7 +286,7 @@ mapLeaves :: (BisectionTree box varid d v1 -> BisectionTree box varid d v2) -> BisectionTree box varid d v1 -> BisectionTree box varid d v2 -mapLeaves f bistr@(Leaf _ dom val) = +mapLeaves f bistr@(Leaf _ domB val) = f bistr mapLeaves f bistr@(Node _ _ _ _ cLO cHI) = bistr @@ -302,7 +302,7 @@ mapMultiLeaves :: (BisectionTree box varid d v1 -> [BisectionTree box varid d v2]) -> BisectionTree box varid d v1 -> [BisectionTree box varid d v2] -mapMultiLeaves f bistr@(Leaf _ dom val) = +mapMultiLeaves f bistr@(Leaf _ domB val) = f bistr mapMultiLeaves f bistr@(Node _ _ _ _ cLO cHI) = Prelude.map (replaceChildren bistr) $ zip (mapMultiLeaves f cLO) (mapMultiLeaves f cHI) @@ -330,24 +330,24 @@ doBistr f Nothing bistr = do m lo m hi - m (Leaf _ dom val) = - f dom val + m (Leaf _ domB val) = + f domB val doBistr f (Just maxDepth) bistr = m maxDepth bistr where - m maxDepth (Node depth dom _ _ lo hi) + m maxDepth (Node depth domB _ _ lo hi) | maxDepth > 0 = do m (maxDepth - 1) lo m (maxDepth - 1) hi | otherwise = error $ "BisectionTree: doBistr: maxDepth (=" ++ show maxDepth ++ ") breached" --- m err (Leaf depth dom val) +-- m err (Leaf depth domB val) -- where -- val = head $ collectValues lo -- err = - m _ (Leaf _ dom val) = - f dom val + m _ (Leaf _ domB val) = + f domB val {-| Perform a given action on all branches of a bisection tree, left to right. @@ -366,14 +366,14 @@ doMap f Nothing bistr = newLo <- m lo newHi <- m hi return $ bistr { bistrLO = newLo, bistrHI = newHi } - m bistr@(Leaf depth dom val) = + m bistr@(Leaf depth domB val) = do - newVal <- f depth dom val + newVal <- f depth domB val return $ bistr { bistrVal = newVal } doMap f (Just maxDepth) bistr = m maxDepth bistr where - m maxDepth bistr@(Node depth dom _ _ lo hi) + m maxDepth bistr@(Node depth domB _ _ lo hi) | maxDepth > 0 = do newLo <- m (maxDepth - 1) lo @@ -381,13 +381,13 @@ doMap f (Just maxDepth) bistr = return $ bistr { bistrLO = newLo, bistrHI = newHi } | otherwise = error $ "BisectionTree: doBistr: maxDepth (=" ++ show maxDepth ++ ") breached" --- m err (Leaf depth dom val) +-- m err (Leaf depth domB val) -- where -- val = head $ collectValues lo -- err = - m _ bistr@(Leaf depth dom val) = + m _ bistr@(Leaf depth domB val) = do - newVal <- f depth dom val + newVal <- f depth domB val return $ bistr { bistrVal = newVal } {-| @@ -408,13 +408,13 @@ doMapLeaves f Nothing bistr = newLo <- m lo newHi <- m hi return $ bistr { bistrLO = newLo, bistrHI = newHi } - m bistr@(Leaf depth dom val) = + m bistr@(Leaf depth domB val) = do f bistr doMapLeaves f (Just maxDepth) bistr = m maxDepth bistr where - m maxDepth bistr@(Node depth dom _ _ lo hi) + m maxDepth bistr@(Node depth domB _ _ lo hi) | maxDepth > 0 = do newLo <- m (maxDepth - 1) lo @@ -422,11 +422,11 @@ doMapLeaves f (Just maxDepth) bistr = return $ bistr { bistrLO = newLo, bistrHI = newHi } | otherwise = error $ "BisectionTree: doBistr: maxDepth (=" ++ show maxDepth ++ ") breached" --- m err (Leaf depth dom val) +-- m err (Leaf depth domB val) -- where -- val = head $ collectValues lo -- err = - m _ bistr@(Leaf depth dom val) = + m _ bistr@(Leaf depth domB val) = do f bistr @@ -439,12 +439,12 @@ removeVars :: removeVars substitutions bistr = aux (bistrDepth bistr) bistr where - aux depth (Leaf _ dom val) = + aux depth (Leaf _ domB val) = Leaf depth domNoVars val where domNoVars = - DBox.difference dom substitutions - aux depth (Node _ dom v pt lo hi) + DBox.difference domB substitutions + aux depth (Node _ domB v pt lo hi) | v `DBox.member` substitutions = case (vVal `RA.refines` vDomLO, vVal `RA.refines` vDomHI) of (True, _) -> aux depth lo @@ -457,7 +457,7 @@ removeVars substitutions bistr = vDomHI = DBox.lookup loc v $ bistrDom hi loc = "RnToRm.BisectionTree: removeVars: " domNoVars = - DBox.difference dom substitutions + DBox.difference domB substitutions loNoVars = aux (depth + 1) lo hiNoVars = aux (depth + 1) hi @@ -480,10 +480,10 @@ sync2 valSplitter1 valSplitter2 ix bistr1 bistr2 = case getPt bistr1 bistr2 of Nothing -> unifyDom bistr1 bistr2 - Just (var, pt, dom) -> + Just (var, pt, domB) -> unifyDom - (split valSplitter1 ix var pt dom bistr1) - (split valSplitter2 ix var pt dom bistr2) + (split valSplitter1 ix var pt domB bistr1) + (split valSplitter2 ix var pt domB bistr2) where getPt bistr1 bistr2 | isLeaf bistr1 && isLeaf bistr2 = Nothing @@ -492,10 +492,10 @@ sync2 valSplitter1 valSplitter2 ix bistr1 bistr2 = | otherwise = Just (bistrDir bistr1, bistrPt bistr1, bistrDom bistr1) unifyDom bistr1 bistr2 = - (bistr1 { bistrDom = dom }, - bistr2 { bistrDom = dom }) + (bistr1 { bistrDom = domB }, + bistr2 { bistrDom = domB }) where - dom = + domB = DBox.unify "RnToRm.BisectionTree: sync: " dom1 dom2 dom1 = bistrDom bistr1 dom2 = bistrDom bistr2 @@ -516,19 +516,19 @@ syncMany :: syncMany valSplitter ix bistrs = case getPt bistrs of Nothing -> unifyDom bistrs - Just (var, pt, dom) -> + Just (var, pt, domB) -> unifyDom $ - Prelude.map (split valSplitter ix var pt dom) bistrs + Prelude.map (split valSplitter ix var pt domB) bistrs where getPt [] = Nothing getPt (bistr : rest) | isLeaf bistr = getPt rest | otherwise = Just (bistrDir bistr, bistrPt bistr, bistrDom bistr) unifyDom bistrs = - Prelude.map (setDom dom) bistrs + Prelude.map (setDom domB) bistrs where - setDom dom bistr = bistr { bistrDom = dom } - dom = + setDom domB bistr = bistr { bistrDom = domB } + domB = foldl (DBox.unify "RnToRm.BisectionTree: sync: ") DBox.noinfo $ Prelude.map bistrDom bistrs @@ -556,13 +556,13 @@ combineWith valSplitter1 valSplitter2 f ix bistr1 bistr2 = (bistr1sync, bistr2sync) = sync2 valSplitter1 valSplitter2 ix bistr1 bistr2 combineAux - bistr1@(Leaf _ dom val1) + bistr1@(Leaf _ domB val1) bistr2@(Leaf _ _ val2) = - case f dom val1 val2 of + case f domB val1 val2 of (Nothing, aux) -> (Nothing, [aux]) (Just val, aux) -> (Just $ bistr1 { bistrVal = val }, [aux]) combineAux - bistr1@(Node _ dom _ _ lo1 hi1) + bistr1@(Node _ domB _ _ lo1 hi1) bistr2@(Node _ _ _ _ lo2 hi2) = ( Just $ bistr1 @@ -597,7 +597,7 @@ collectValues (Node _ _ _ _ cLO cHI) = -} collectDomValues :: BisectionTree box varid d v -> [(box, v)] -collectDomValues (Leaf _ dom val) = [(dom,val)] +collectDomValues (Leaf _ domB val) = [(domB,val)] collectDomValues (Node _ _ _ _ cLO cHI) = (collectDomValues cLO) ++ (collectDomValues cHI) @@ -640,7 +640,7 @@ lookupSubtreeDoms :: (BisectionTree box varid d v) -> box {-^ domain to look up within the tree -} -> [BisectionTree box varid d v] -lookupSubtreeDoms origBistr dom = +lookupSubtreeDoms origBistr domB = lk origBistr where lk bistr@(Leaf _ _ _) = [bistr] @@ -651,10 +651,10 @@ lookupSubtreeDoms origBistr dom = where loDisjoint = and $ Prelude.map snd $ - DBox.zipWithDefault RA.bottomApprox (RA.isDisjoint) dom domLO + DBox.zipWithDefault RA.bottomApprox (RA.isDisjoint) domB domLO hiDisjoint = and $ Prelude.map snd $ - DBox.zipWithDefault RA.bottomApprox (RA.isDisjoint) dom domHI + DBox.zipWithDefault RA.bottomApprox (RA.isDisjoint) domB domHI domLO = bistrDom lo domHI = bistrDom hi @@ -695,18 +695,18 @@ updateVal valSplitter ix maxDepth updateDom updateFn bistr = mapLeaves updateLeaf bistr | otherwise = -- divide and conquer: - Node depth dom dir pt bistrLdone bistrRdone + Node depth domB dir pt bistrLdone bistrRdone where updateLeaf bistr = bistr { bistrVal = updateFn (bistrDom bistr) (bistrVal bistr) } noOverlap = - or $ Prelude.map RA.isEmpty $ DBox.elems domOverlap + or $ Prelude.map (not . RA.isConsistent) $ DBox.elems domOverlap domOverlap = - DBox.intersectionWith (RA./\) dom updateDom + DBox.intersectionWith (RA./\) domB updateDom insideUpdateDom = - and $ Prelude.map snd $ DBox.zipWith RA.refines dom updateDom + and $ Prelude.map snd $ DBox.zipWith RA.refines domB updateDom edgeTouch = - and $ Prelude.map snd $ DBox.zipWithDefaultSecond RA.bottomApprox endPointTouch dom updateDom + and $ Prelude.map snd $ DBox.zipWithDefaultSecond RA.bottomApprox endPointTouch domB updateDom endPointTouch i1 i2 = i1L == i2R || i1R == i2L where @@ -714,13 +714,12 @@ updateVal valSplitter ix maxDepth updateDom updateFn bistr = (i1L, i1R) = RA.bounds i1 (i2L, i2R) = RA.bounds i2 depth = bistrDepth bistr - dom = bistrDom bistr + domB = bistrDom bistr bistrLdone = upd bistrL bistrRdone = upd bistrR (Node _ _ _ _ bistrL bistrR) | (isLeaf bistr) = split valSplitter ix dir pt DBox.noinfo bistr - | otherwise = bistr - (dir, pt) = - DBox.bestSplit dom + | otherwise = bistr + (dir, (_,pt)) = DBox.bestSplit domB diff --git a/src/Data/Number/ER/RnToRm/BisectionTree/Integration.hs b/src/Data/Number/ER/RnToRm/BisectionTree/Integration.hs index f7dc5ba..f4df50e 100644 --- a/src/Data/Number/ER/RnToRm/BisectionTree/Integration.hs +++ b/src/Data/Number/ER/RnToRm/BisectionTree/Integration.hs @@ -19,8 +19,8 @@ where import qualified Data.Number.ER.RnToRm.BisectionTree as BISTR import qualified Data.Number.ER.Real.Approx as RA -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc @@ -89,18 +89,18 @@ zipFromOrigin True -> DBox.insertWith (RA.\/) ivar origin domB False -> domB -- the following function is used when we know the origin is within the current sub-domain: - integrateBistrOriginHere bistrs@((BISTR.Leaf depth dom _) : _) - | decideShouldSplit ix depth dom vals integrVals = -- must descend + integrateBistrOriginHere bistrs@((BISTR.Leaf depth domB _) : _) + | decideShouldSplit ix depth domB vals integrVals = -- must descend integrateBistrOriginHere $ - map (BISTR.split valSplitter ix var pt dom) bistrs + map (BISTR.split valSplitter ix var pt domB) bistrs | otherwise = - (Just lVal, map (\v -> BISTR.Leaf depth dom v) integrVals, Just rVal) + (Just lVal, map (\v -> BISTR.Leaf depth domB v) integrVals, Just rVal) where - (var, pt) = DBox.bestSplit dom + (var, (_,pt)) = DBox.bestSplit domB vals = map BISTR.bistrVal bistrs (lVal, integrVals, rVal) = - integrLeafOH ix depth dom vals - integrateBistrOriginHere bistrs@((BISTR.Node depth dom var pt lBounds rBounds):_) + integrLeafOH ix depth domB vals + integrateBistrOriginHere bistrs@((BISTR.Node depth domB var pt lBounds rBounds):_) | origin `RA.refines` rDom = -- unsafePrint -- ("BTINTEG: integrateBistrOriginHere: rDom = " ++ show rDom ++ @@ -118,14 +118,14 @@ zipFromOrigin | otherwise = -- origin overlaps both sides -- have to amalgamate these trees: integrateBistrOriginHere $ - map (\b -> BISTR.Leaf depth dom (valCombiner ix depth b)) bistrs + map (\b -> BISTR.Leaf depth domB (valCombiner ix depth b)) bistrs where lDom = DBox.lookup "BTINTEG: zipFromOrigin: Here: L: " var (BISTR.bistrDom lBounds) rDom = DBox.lookup "BTINTEG: zipFromOrigin: Here: R: " var (BISTR.bistrDom rBounds) -- recursion when origin is entirely to the right of the centre: bistrsIntgHI = zipWith - (\lo hi -> BISTR.Node depth dom var pt lo hi) + (\lo hi -> BISTR.Node depth domB var pt lo hi) lBoundsIntgHI rBoundsIntgHI (lValHIHI, rBoundsIntgHI, rValHI) = integrateBistrOriginHere $ @@ -137,7 +137,7 @@ zipFromOrigin -- recursion when origin is entirely to the left of the centre: bistrsIntgLO = zipWith - (\lo hi -> BISTR.Node depth dom var pt lo hi) + (\lo hi -> BISTR.Node depth domB var pt lo hi) lBoundsIntgLO rBoundsIntgLO (lValLO, lBoundsIntgLO, rValLOLO) = integrateBistrOriginHere $ @@ -159,23 +159,23 @@ zipFromOrigin (fromJust maybeSupport)) = -- outside the integration domain (outerValTransformer (Just lVal) Nothing bistrs, Nothing) - integrateBistrOriginLeft (Just lVal) bistrs@((BISTR.Leaf depth dom _) : _) - | decideShouldSplit ix depth dom vals integrVals = -- improve granularity by splitting + integrateBistrOriginLeft (Just lVal) bistrs@((BISTR.Leaf depth domB _) : _) + | decideShouldSplit ix depth domB vals integrVals = -- improve granularity by splitting integrateBistrOriginLeft (Just lVal) $ - map (BISTR.split valSplitter ix var pt dom) bistrs + map (BISTR.split valSplitter ix var pt domB) bistrs | otherwise = - (map (\v -> BISTR.Leaf depth dom v) integrVals, + (map (\v -> BISTR.Leaf depth domB v) integrVals, Just rVal) where - (var, pt) = DBox.bestSplit dom + (var, (_,pt)) = DBox.bestSplit domB vals = map BISTR.bistrVal bistrs (integrVals, rVal) = - integrLeafOL ix depth dom lVal vals - integrateBistrOriginLeft mlVal bistrs@((BISTR.Node depth dom var pt _ _):_) = + integrLeafOL ix depth domB lVal vals + integrateBistrOriginLeft mlVal bistrs@((BISTR.Node depth domB var pt _ _):_) = (bistrsIntg, mrVal2) where bistrsIntg = - zipWith (\lo hi -> BISTR.Node depth dom var pt lo hi) lBoundsINT rBoundsINT + zipWith (\lo hi -> BISTR.Node depth domB var pt lo hi) lBoundsINT rBoundsINT (lBoundsINT, mrVal1) = integrateBistrOriginLeft mlVal $ BISTR.syncMany valSplitter ix $ map BISTR.bistrLO bistrs @@ -195,24 +195,24 @@ zipFromOrigin (fromJust maybeSupport)) = -- outside the integration domain (Nothing, outerValTransformer Nothing (Just rVal) bistrs) - integrateBistrOriginRight bistrs@((BISTR.Leaf depth dom _) : _) (Just rVal) - | decideShouldSplit ix depth dom vals integrVals = -- improve granularity by splitting + integrateBistrOriginRight bistrs@((BISTR.Leaf depth domB _) : _) (Just rVal) + | decideShouldSplit ix depth domB vals integrVals = -- improve granularity by splitting integrateBistrOriginRight - (map (BISTR.split valSplitter ix var pt dom) bistrs) + (map (BISTR.split valSplitter ix var pt domB) bistrs) (Just rVal) | otherwise = (Just lVal, - map (\v -> BISTR.Leaf depth dom v) integrVals) + map (\v -> BISTR.Leaf depth domB v) integrVals) where - (var, pt) = DBox.bestSplit dom + (var, (_,pt)) = DBox.bestSplit domB vals = map BISTR.bistrVal bistrs (lVal, integrVals) = - integrLeafOR ix depth dom vals rVal - integrateBistrOriginRight bistrs@((BISTR.Node depth dom var pt _ _):_) mrVal = + integrLeafOR ix depth domB vals rVal + integrateBistrOriginRight bistrs@((BISTR.Node depth domB var pt _ _):_) mrVal = (mlVal2, bistrsIntg) where bistrsIntg = - zipWith (\lo hi -> BISTR.Node depth dom var pt lo hi) lBoundsINT rBoundsINT + zipWith (\lo hi -> BISTR.Node depth domB var pt lo hi) lBoundsINT rBoundsINT (mlVal2, lBoundsINT) = integrateBistrOriginRight (BISTR.syncMany valSplitter ix $ map BISTR.bistrLO bistrs) mlVal1 @@ -247,32 +247,32 @@ zipOnSubdomain :: {-^ what to do with values /outside/ @sd@ -} -> [BISTR.BisectionTree box varid d v1] -> [BISTR.BisectionTree box varid d v2] -zipOnSubdomain valSplitter ix maxDepth sdom updateInside updateTouch updateAway bistrs = +zipOnSubdomain valSplitter ix maxDepth sdomB updateInside updateTouch updateAway bistrs = resultBistrs where resultBistrs = zz $ BISTR.syncMany valSplitter ix bistrs - zz bistrs@(BISTR.Leaf depth dom _ : _) + zz bistrs@(BISTR.Leaf depth domB _ : _) | intersect = case depth < maxDepth of True -> - zz $ map (BISTR.split valSplitter ix var pt dom) bistrs + zz $ map (BISTR.split valSplitter ix var pt domB) bistrs False -> error "BTINTEG: zipOnSubdomain: maxDepth reached but irregular splitting not implemented yet" | away = lift updateAway | touch = lift updateTouch | inside = lift updateInside where - (var, pt) = DBox.bestSplit dom + (var, (_,pt)) = DBox.bestSplit domB lift updateFn = - map (BISTR.Leaf depth dom) $ - updateFn dom $ + map (BISTR.Leaf depth domB) $ + updateFn domB $ map BISTR.bistrVal bistrs (away, touch, intersect, inside) = - DBox.classifyPosition dom sdom - zz bistrs@(BISTR.Node depth dom var pt _ _ : _) = + DBox.classifyPosition domB sdomB + zz bistrs@(BISTR.Node depth domB var pt _ _ : _) = zipWith - (\bLO bHI -> BISTR.Node depth dom var pt bLO bHI) + (\bLO bHI -> BISTR.Node depth domB var pt bLO bHI) (zz $ map BISTR.bistrLO bistrs) (zz $ map BISTR.bistrHI bistrs) diff --git a/src/Data/Number/ER/RnToRm/BisectionTree/Path.hs b/src/Data/Number/ER/RnToRm/BisectionTree/Path.hs index 9bd6ea7..568a523 100644 --- a/src/Data/Number/ER/RnToRm/BisectionTree/Path.hs +++ b/src/Data/Number/ER/RnToRm/BisectionTree/Path.hs @@ -16,7 +16,7 @@ module Data.Number.ER.RnToRm.BisectionTree.Path where import qualified Data.Number.ER.RnToRm.Approx as FA import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.Real.DomainBox (VariableID(..)) +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..)) import Data.Number.ER.BasicTypes import Data.Typeable diff --git a/src/Data/Number/ER/RnToRm/DefaultRepr.hs b/src/Data/Number/ER/RnToRm/DefaultRepr.hs index 0aa2f23..d98516c 100644 --- a/src/Data/Number/ER/RnToRm/DefaultRepr.hs +++ b/src/Data/Number/ER/RnToRm/DefaultRepr.hs @@ -27,7 +27,7 @@ module Data.Number.ER.RnToRm.DefaultRepr ( module Data.Number.ER.RnToRm.DefaultRepr, - module Data.Number.ER.Real.DomainBox.IntMap + module Data.Number.ER.BasicTypes.DomainBox.IntMap ) where @@ -36,14 +36,15 @@ import qualified Data.Number.ER.RnToRm.Approx as FA import qualified Data.Number.ER.RnToRm.UnitDom.Approx as UFA import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Approx.Elementary as RAEL -import qualified Data.Number.ER.Real.DomainBox as DBox +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox import Data.Number.ER.BasicTypes -import Data.Number.ER.Real.DomainBox.IntMap +import Data.Number.ER.BasicTypes.DomainBox.IntMap import Data.Number.ER.RnToRm.UnitDom.Base import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom import Data.Number.ER.RnToRm.UnitDom.Approx.Interval +import Data.Number.ER.RnToRm.UnitDom.Approx.IntervalOI import Data.Number.ER.RnToRm.Approx.DomTransl import Data.Number.ER.RnToRm.Approx.DomEdges import Data.Number.ER.RnToRm.Approx.Tuple @@ -53,8 +54,11 @@ import Data.Number.ER.RnToRm.Approx.PieceWise import qualified Data.Map as Map -type FAPU b = ERFnInterval (ERChebPoly (Box Int) b) (IRA b) +type P b = ERChebPoly (Box Int) b +type FAPU b = ERFnInterval (P b) +type FAPUOI b = ERFnIntervalOI (P b) type FAPD b = ERFnDomTranslApprox (Box (DomTransl (IRA b))) VarID (FAPU b) (IRA b) +type FAPDOI b = ERFnDomTranslApprox (Box (DomTransl (IRA b))) VarID (FAPUOI b) (IRA b) type FAPT b = ERFnTuple (FAPD b) type FAPE b = ERFnDomEdgesApprox VarID (FAPT b) type FAPWP b = ERFnPiecewise (Box (IRA b)) VarID (IRA b) (FAPE b) diff --git a/src/Data/Number/ER/RnToRm/TestingDefs.hs b/src/Data/Number/ER/RnToRm/TestingDefs.hs index 378e17c..d368b78 100644 --- a/src/Data/Number/ER/RnToRm/TestingDefs.hs +++ b/src/Data/Number/ER/RnToRm/TestingDefs.hs @@ -19,7 +19,10 @@ import qualified Data.Number.ER.RnToRm.Approx as FA import qualified Data.Number.ER.RnToRm.UnitDom.Approx as UFA import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Approx.Elementary as RAEL -import qualified Data.Number.ER.Real.DomainBox as DBox +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox + +import Data.Number.ER.Real.Approx.Interval +import Data.Number.ER.Misc import qualified Data.Map as Map diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Approx.hs b/src/Data/Number/ER/RnToRm/UnitDom/Approx.hs index a529fd9..c0c80ee 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/Approx.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/Approx.hs @@ -25,8 +25,8 @@ where import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.RnToRm.Approx as FA -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Approx/Interval.hs b/src/Data/Number/ER/RnToRm/UnitDom/Approx/Interval.hs index 5f409fd..836a873 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/Approx/Interval.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/Approx/Interval.hs @@ -21,7 +21,9 @@ module Data.Number.ER.RnToRm.UnitDom.Approx.Interval ( ERFnInterval(..), - ERFnContext(..) + ERFnContext(..), + erfnContextDefault, + erfnContextUnify ) where @@ -36,8 +38,8 @@ import Data.Number.ER.RnToRm.UnitDom.Base ((+^),(-^),(*^),multiplyEncl) import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Approx.Elementary as RAEL -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc @@ -60,7 +62,7 @@ import Data.Binary --fapuConst2 = (UFA.const 0 [2]) :: FAPU {- end of testing specific code -} -data ERFnInterval fb ra = +data ERFnInterval fb = ERFnIntervalAny { erfnContext :: ERFnContext @@ -70,19 +72,23 @@ data ERFnInterval fb ra = { erfnLowerNeg :: fb, erfnUpper :: fb, - erfnContext :: ERFnContext, - erfnGlobal :: ra + erfnContext :: ERFnContext +-- , +-- erfnIsDefinitelyConsistent :: Bool, +-- erfnIsDefinitelyAntiConsistent :: Bool } deriving (Typeable, Data) -instance (Binary a, Binary b) => Binary (ERFnInterval a b) where +instance (Binary a) => Binary (ERFnInterval a) where put (ERFnIntervalAny a) = putWord8 0 >> put a - put (ERFnInterval a b c d) = putWord8 1 >> put a >> put b >> put c >> put d + put (ERFnInterval a b c) = putWord8 1 >> put a >> put b >> put c +-- put (ERFnInterval a b c d e) = putWord8 1 >> put a >> put b >> put c >> put d >> put e get = do tag_ <- getWord8 case tag_ of 0 -> get >>= \a -> return (ERFnIntervalAny a) - 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (ERFnInterval a b c d) + 1 -> get >>= \a -> get >>= \b -> get >>= \c -> return (ERFnInterval a b c) +-- 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> return (ERFnInterval a b c d e) _ -> fail "no parse" @@ -114,11 +120,13 @@ erfnContextUnify (ERFnContext dg1 sz1 gr1) (ERFnContext dg2 sz2 gr2) = instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => - Show (ERFnInterval fb ra) + Show (ERFnInterval fb) where show (ERFnIntervalAny _) = "ERFnIntervalAny" - show (ERFnInterval ln h ctxt gl) = - "\nERFnInterval" + show (ERFnInterval ln h ctxt) = + "\nERFnInterval {" ++ show ctxt ++ "}" +-- ++ " (definitely consistent: " ++ show isC +-- ++ "anticonsistent: " ++ show isAC ++ ")" ++ "\n upper = " ++ ufbShow h ++ "\n lower = " ++ ufbShow (UFB.neg ln) -- ++ " global = " ++ show gl ++ "\n" @@ -128,11 +136,11 @@ instance instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => - H.HTML (ERFnInterval fb ra) + H.HTML (ERFnInterval fb) where toHtml (ERFnIntervalAny ctxt) = H.toHtml "ERFnIntervalAny" - toHtml (ERFnInterval ln h ctxt gl) = + toHtml (ERFnInterval ln h ctxt) = -- H.toHtml $ -- abovesTable -- [ @@ -148,37 +156,37 @@ instance instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => - Eq (ERFnInterval fb ra) + Eq (ERFnInterval fb) where - (ERFnInterval ln1 h1 ctxt1 gl1) - == (ERFnInterval ln2 h2 ctxt2 gl2) = + (ERFnInterval ln1 h1 ctxt1) + == (ERFnInterval ln2 h2 ctxt2) = error "ERFnInterval: equality not implemented" _ == _ = error "ERFnInterval: equality not implemented" instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => - Ord (ERFnInterval fb ra) + Ord (ERFnInterval fb) where compare - (ERFnInterval ln1 h1 ctxt1 gl1) - (ERFnInterval ln2 h2 ctxt2 gl2) = + (ERFnInterval ln1 h1 ctxt1) + (ERFnInterval ln2 h2 ctxt2) = error "ERFnInterval: comparison not implemented; consider leqReals or compareApprox from class ERApprox instead" compare _ _ = error "ERFnInterval: comparison not implemented; consider leqReals or compareApprox from class ERApprox instead" instance - (UFB.ERUnitFnBase boxb boxra varid b ra fb, Show varid, Show boxra) => - Num (ERFnInterval fb ra) + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, Show varid, Show boxra) => + Num (ERFnInterval fb) where fromInteger n = UFA.const [fromInteger n] negate f@(ERFnIntervalAny _) = f - negate (ERFnInterval ln h ctxt gl) = - (ERFnInterval h ln ctxt (negate gl)) - (ERFnInterval ln1 h1 ctxt1 gl1) + (ERFnInterval ln2 h2 ctxt2 gl2) = + negate (ERFnInterval ln h ctxt) = + (ERFnInterval h ln ctxt) + (ERFnInterval ln1 h1 ctxt1) + (ERFnInterval ln2 h2 ctxt2) = normalise $ - ERFnInterval (reduceSzUp ln) (reduceSzUp h) ctxt (gl1 + gl2) + ERFnInterval (reduceSzUp ln) (reduceSzUp h) ctxt where ln = ln1 +^ ln2 h = h1 +^ h2 @@ -188,9 +196,9 @@ instance f1 + f2 = ERFnIntervalAny ctxt where ctxt = erfnContextUnify (erfnContext f1) (erfnContext f2) - (ERFnInterval ln1 h1 ctxt1 gl1) * (ERFnInterval ln2 h2 ctxt2 gl2) = + (ERFnInterval ln1 h1 ctxt1) * (ERFnInterval ln2 h2 ctxt2) = normalise $ - ERFnInterval ln h ctxt (gl1 * gl2) + ERFnInterval ln h ctxt where (ln, h) = multiplyEncl maxDegr maxSize (ln1, h1) (ln2, h2) maxDegr = erfnMaxDegree ctxt @@ -201,15 +209,15 @@ instance ctxt = erfnContextUnify (erfnContext f1) (erfnContext f2) instance - (UFB.ERUnitFnBase boxb boxra varid b ra fb, Show varid, Show boxra) => - Fractional (ERFnInterval fb ra) + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, Show varid, Show boxra) => + Fractional (ERFnInterval fb) where fromRational r = UFA.const [fromRational r] recip f@(ERFnIntervalAny _) = f - recip (ERFnInterval ln h ctxt gl) + recip (ERFnInterval ln h ctxt) | certainNoZero = normalise $ - ERFnInterval lnR hR ctxt (recip gl) + ERFnInterval lnR hR ctxt | otherwise = ERFnIntervalAny ctxt where (hR, lnR) = UFB.recipEncl maxDegr maxSize ix (h,ln) @@ -228,31 +236,31 @@ instance ix = int2effIx $ 3 * maxDegr instance - (UFB.ERUnitFnBase boxb boxra varid b ra fb, Show varid, Show boxra) => - RA.ERApprox (ERFnInterval fb ra) + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, Show varid, Show boxra) => + RA.ERApprox (ERFnInterval fb) where initialiseBaseArithmetic _ = UFB.initialiseBaseArithmetic (UFB.const 0 :: fb) getGranularity (ERFnIntervalAny ctxt) = erfnCoeffGranularity ctxt - getGranularity (ERFnInterval ln h ctxt gl) = + getGranularity (ERFnInterval ln h ctxt) = max (erfnCoeffGranularity ctxt) $ max (UFB.getGranularity ln) (UFB.getGranularity h) - setGranularity gran (ERFnIntervalAny ctxt) = + setGranularityOuter gran (ERFnIntervalAny ctxt) = ERFnIntervalAny $ ctxt { erfnCoeffGranularity = gran } - setGranularity gran (ERFnInterval ln h ctxt gl) = + setGranularityOuter gran (ERFnInterval ln h ctxt) = ERFnInterval (UFB.setGranularity gran ln) (UFB.setGranularity gran h) - (ctxt { erfnCoeffGranularity = gran }) gl - setMinGranularity gran (ERFnIntervalAny ctxt) = + (ctxt { erfnCoeffGranularity = gran }) + setMinGranularityOuter gran (ERFnIntervalAny ctxt) = ERFnIntervalAny (ctxt { erfnCoeffGranularity = max gran (erfnCoeffGranularity ctxt) }) - setMinGranularity gran (ERFnInterval ln h ctxt gl) = + setMinGranularityOuter gran (ERFnInterval ln h ctxt) = ERFnInterval (UFB.setMinGranularity gran ln) (UFB.setMinGranularity gran h) - (ctxt { erfnCoeffGranularity = max gran (erfnCoeffGranularity ctxt) }) gl + (ctxt { erfnCoeffGranularity = max gran (erfnCoeffGranularity ctxt) }) -- getPrecision (ERFnIntervalAny _) = 0 -- getPrecision f = intLog 2 (1 + (fst $ RA.integerBounds (FA.volume f))) -- wrong! - f1@(ERFnInterval ln1 h1 ctxt1 gl1) /\ f2@(ERFnInterval ln2 h2 ctxt2 gl2) = + f1@(ERFnInterval ln1 h1 ctxt1) /\ f2@(ERFnInterval ln2 h2 ctxt2) = ---- #ifdef RUNTIME_CHECKS ---- check ("ERFnInterval: /\\:\n f1:\n" ++ show f1 ++ " f2:\n" ++ show f2 ++ "\n result:\n") $ ---- #endif @@ -260,17 +268,17 @@ instance ERFnInterval (UFB.minUp maxDegr maxSize ln1 ln2) (UFB.minUp maxDegr maxSize h1 h2) - ctxt (gl1 RA./\ gl2) + ctxt where ctxt = erfnContextUnify ctxt1 ctxt2 maxDegr = erfnMaxDegree ctxt maxSize = erfnMaxSize ctxt - (ERFnIntervalAny ctxt1) /\ (ERFnInterval ln2 h2 ctxt2 gl2) = - ERFnInterval ln2 h2 ctxt gl2 + (ERFnIntervalAny ctxt1) /\ (ERFnInterval ln2 h2 ctxt2) = + ERFnInterval ln2 h2 ctxt where ctxt = erfnContextUnify ctxt1 ctxt2 - (ERFnInterval ln1 h1 ctxt1 gl1) /\ (ERFnIntervalAny ctxt2) = - ERFnInterval ln1 h1 ctxt gl1 + (ERFnInterval ln1 h1 ctxt1) /\ (ERFnIntervalAny ctxt2) = + ERFnInterval ln1 h1 ctxt where ctxt = erfnContextUnify ctxt1 ctxt2 f1 /\ f2 = ERFnIntervalAny ctxt @@ -281,14 +289,14 @@ instance erfnintLeq f1 f2 refines _ (ERFnIntervalAny _) = True refines (ERFnIntervalAny _) _ = False - refines (ERFnInterval ln1 h1 _ _) (ERFnInterval ln2 h2 _ _) = + refines (ERFnInterval ln1 h1 _) (ERFnInterval ln2 h2 _) = (UFB.upperBound 10 (ln2 -^ ln1) >= 0) && (UFB.upperBound 10 (h2 -^ h1) >= 0) compareApprox (ERFnIntervalAny _) (ERFnIntervalAny _) = EQ compareApprox (ERFnIntervalAny _) _ = LT compareApprox _ (ERFnIntervalAny _) = GT - compareApprox (ERFnInterval ln1 h1 _ _) (ERFnInterval ln2 h2 _ _) = + compareApprox (ERFnInterval ln1 h1 _) (ERFnInterval ln2 h2 _) = compareComposeMany [ UFB.compareApprox h1 h2, @@ -312,46 +320,46 @@ erfnintLeq left right | otherwise = False instance - (UFB.ERUnitFnBase boxb boxra varid b ra fb, Show varid, Show boxra) => - RA.ERIntApprox (ERFnInterval fb ra) + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, Show varid, Show boxra) => + RA.ERIntApprox (ERFnInterval fb) where -- doubleBounds = :: ira -> (Double, Double) -- floatBounds :: ira -> (Float, Float) -- integerBounds :: ira -> (ExtendedInteger, ExtendedInteger) bisectDomain maybePt (ERFnIntervalAny c) = error "ERFnInterval: RA.bisectDomain: cannot bisect ERFnIntervalAny" - bisectDomain maybePt (ERFnInterval ln h c g) = - (ERFnInterval ln midUp c g, - ERFnInterval midDownNeg h c g) + bisectDomain maybePt (ERFnInterval ln h c) = + (ERFnInterval ln midUp c, + ERFnInterval midDownNeg h c) where (midDownNeg, midUp) = case maybePt of Nothing -> (UFB.scaleUp (1/2) $ ln -^ h, UFB.scaleUp (1/2) $ h -^ ln) - Just (ERFnInterval lnPt hPt _ _) -> + Just (ERFnInterval lnPt hPt _) -> (lnPt, hPt) bounds (ERFnIntervalAny c) = error "ERFnInterval: RA.bounds: cannot get bounds for ERFnIntervalAny" - bounds (ERFnInterval ln h c g) = - (ERFnInterval ln (UFB.neg ln) c g, - ERFnInterval (UFB.neg h) h c g) - f1@(ERFnInterval ln1 h1 c1 g1) \/ f2@(ERFnInterval ln2 h2 c2 g2) = + bounds (ERFnInterval ln h c) = + (ERFnInterval ln (UFB.neg ln) c, + ERFnInterval (UFB.neg h) h c) + f1@(ERFnInterval ln1 h1 c1) \/ f2@(ERFnInterval ln2 h2 c2) = ---- #ifdef RUNTIME_CHECKS ---- check ("ERFnInterval: abs:\n f1:\n" ++ show f1 ++ " f2:\n" ++ show f2 ++ "\n result:\n") $ ---- #endif normalise $ - ERFnInterval ln h c (g1 RA.\/ g2) + ERFnInterval ln h c where ln = UFB.maxUp maxDegree maxSize ln1 ln2 h = UFB.maxUp maxDegree maxSize h1 h2 c = erfnContextUnify c1 c2 maxDegree = erfnMaxDegree c maxSize = erfnMaxSize c - (ERFnIntervalAny ctxt1) \/ (ERFnInterval ln2 h2 ctxt2 gl2) = + (ERFnIntervalAny ctxt1) \/ (ERFnInterval ln2 h2 ctxt2) = ERFnIntervalAny ctxt where ctxt = erfnContextUnify ctxt1 ctxt2 - (ERFnInterval ln1 h1 ctxt1 gl1) \/ (ERFnIntervalAny ctxt2) = + (ERFnInterval ln1 h1 ctxt1) \/ (ERFnIntervalAny ctxt2) = ERFnIntervalAny ctxt where ctxt = erfnContextUnify ctxt1 ctxt2 @@ -360,19 +368,19 @@ instance ctxt = erfnContextUnify (erfnContext f1) (erfnContext f2) instance - (UFB.ERUnitFnBase boxb boxra varid b ra fb, - RAEL.ERApproxElementary ra, RealFrac b, + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, + RAEL.ERApproxElementary ra, Show varid, Show boxra) => - RAEL.ERApproxElementary (ERFnInterval fb ra) + RAEL.ERApproxElementary (ERFnInterval fb) where -- default abs does not work because we do not have Prelude.abs abs _ f@(ERFnIntervalAny _) = f - abs _ f@(ERFnInterval ln h c g) = + abs _ f@(ERFnInterval ln h c) = ---- #ifdef RUNTIME_CHECKS ---- check ("ERFnInterval: abs:\n f:\n" ++ show f ++ "\n result:\n") $ ---- #endif normalise $ - ERFnInterval minhln0Up maxhlnUp c (abs g) + ERFnInterval minhln0Up maxhlnUp c where maxhlnUp = UFB.maxUp maxDegree maxSize h ln minhln0Up = @@ -381,9 +389,9 @@ instance maxDegree = erfnMaxDegree c maxSize = erfnMaxSize c exp ix f@(ERFnIntervalAny _) = f - exp ix f@(ERFnInterval ln h c g) = + exp ix f@(ERFnInterval ln h c) = normalise $ - ERFnInterval lExpNeg hExp c (RAEL.exp ix g) + ERFnInterval lExpNeg hExp c where maxDegree = erfnMaxDegree c maxSize = erfnMaxSize c @@ -397,10 +405,10 @@ instance (lExpNeg, _) = UFB.expEncl maxDegree maxSize ix (ln, UFB.neg ln) (_, hExp) = UFB.expEncl maxDegree maxSize ix (UFB.neg h,h) sin ix f@(ERFnIntervalAny c) = - ERFnInterval one one c ((-1) RA.\/ 1) + ERFnInterval one one c where one = UFB.const 1 - sin ix f@(ERFnInterval ln h c g) = + sin ix f@(ERFnInterval ln h c) = -- unsafePrint -- ( -- "ERFnInterval: RAEL.sin: " @@ -413,16 +421,16 @@ instance ---- check ("ERFnInterval: sin:\n f:\n" ++ show f ++ "\n result:\n") $ ---- #endif normalise $ - ERFnInterval lSinNeg hSin c (RAEL.sin ix g) + ERFnInterval lSinNeg hSin c where (lSinNeg, hSin) = sincos True maxDegree maxSize ix (ln, h) maxDegree = erfnMaxDegree c maxSize = erfnMaxSize c cos ix f@(ERFnIntervalAny c) = - ERFnInterval one one c ((-1) RA.\/ 1) + ERFnInterval one one c where one = UFB.const 1 - cos ix f@(ERFnInterval ln h c g) = + cos ix f@(ERFnInterval ln h c) = -- unsafePrint -- ( -- "ERFnInterval: RAEL.cos: " @@ -432,16 +440,16 @@ instance -- ++ "\n lCosNeg = " ++ show lCosNeg -- ) $ normalise $ - ERFnInterval lCosNeg hCos c (RAEL.cos ix g) + ERFnInterval lCosNeg hCos c where (lCosNeg, hCos) = sincos False maxDegree maxSize ix (ln,h) maxDegree = erfnMaxDegree c maxSize = erfnMaxSize c atan ix f@(ERFnIntervalAny c) = - ERFnInterval one one c ((-1) RA.\/ 1) + ERFnInterval one one c where one = UFB.const 1 - atan ix f@(ERFnInterval ln h c g) = + atan ix f@(ERFnInterval ln h c) = -- unsafePrint -- ( -- "ERFnInterval: RAEL.atan: " @@ -451,7 +459,7 @@ instance -- ++ "\n lAtanNeg = " ++ show lAtanNeg -- ) $ normalise $ - ERFnInterval lAtanNeg hAtan c (RAEL.atan ix g) + ERFnInterval lAtanNeg hAtan c where maxDegree = erfnMaxDegree c maxSize = erfnMaxSize c @@ -467,7 +475,7 @@ instance (_, hAtan) = UFB.atanEncl maxDegree maxSize ix (UFB.neg h,h) sincos :: - (UFB.ERUnitFnBase boxb boxra varid b ra fb, RAEL.ERApproxElementary ra, RealFrac b) => + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, RAEL.ERApproxElementary ra) => Bool {-^ True iff sine, False iff cosine -} -> Int {-^ maximum representation degree -} -> Int {-^ maximum approx size -} -> @@ -608,57 +616,55 @@ sincos isSine maxDegree maxSize ix (ln,h) errPoly = UFB.const errB normalise f@(ERFnIntervalAny c) = f -normalise f@(ERFnInterval ln h c g) +normalise f@(ERFnInterval ln h c) | UFB.isValid h && UFB.isValid ln = f | otherwise = ERFnIntervalAny c check callerLocation f@(ERFnIntervalAny c) = f -check callerLocation f@(ERFnInterval ln h c g) = +check callerLocation f@(ERFnInterval ln h c) = ERFnInterval (UFB.check (callerLocation ++ "upper: ") h) (UFB.check (callerLocation ++ "neg lower: ") ln) - c g + c instance - (UFB.ERUnitFnBase boxb boxra varid b ra fb, Show varid, Show boxra) => - FA.ERFnApprox boxra varid ra ra (ERFnInterval fb ra) + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, Show varid, Show boxra) => + FA.ERFnApprox boxra varid ra ra (ERFnInterval fb) where check = check domra2ranra _ = id ranra2domra _ = id getMaxDegree (ERFnIntervalAny c) = erfnMaxDegree c - getMaxDegree (ERFnInterval _ _ c _) = + getMaxDegree (ERFnInterval _ _ c) = erfnMaxDegree c setMaxDegree maxDegr (ERFnIntervalAny c) = ERFnIntervalAny (c { erfnMaxDegree = maxDegr } ) - setMaxDegree maxDegr (ERFnInterval ln h c g) = + setMaxDegree maxDegr (ERFnInterval ln h c) = ERFnInterval (UFB.reduceDegreeUp maxDegr ln) (UFB.reduceDegreeUp maxDegr h) (c { erfnMaxDegree = maxDegr } ) - g getSize (ERFnIntervalAny c) = 0 - getSize (ERFnInterval ln h c g) = + getSize (ERFnInterval ln h c) = max (UFB.getSize ln) (UFB.getSize h) getMaxSize (ERFnIntervalAny c) = erfnMaxSize c - getMaxSize (ERFnInterval _ _ c _) = + getMaxSize (ERFnInterval _ _ c) = erfnMaxSize c setMaxSize maxSize (ERFnIntervalAny c) = ERFnIntervalAny (c { erfnMaxDegree = maxSize } ) - setMaxSize maxSize (ERFnInterval ln h c g) = + setMaxSize maxSize (ERFnInterval ln h c) = ERFnInterval (UFB.reduceSizeUp maxSize ln) (UFB.reduceSizeUp maxSize h) (c { erfnMaxSize = maxSize } ) - g getVariables (ERFnIntervalAny _) = [] - getVariables (ERFnInterval ln h _ _) = UFB.getVariables h + getVariables (ERFnInterval ln h _) = UFB.getVariables h getRangeApprox (ERFnIntervalAny _) = RA.bottomApprox - getRangeApprox (ERFnInterval ln h c g) = + getRangeApprox (ERFnInterval ln h c) = UFB.raFromEndpoints h ( (- (UFB.upperBound 10 ln)) @@ -667,16 +673,16 @@ instance ) scale ratio f@(ERFnIntervalAny c) = f - scale ratio f@(ERFnInterval ln h c g) = + scale ratio f@(ERFnInterval ln h c) = ---- #ifdef RUNTIME_CHECKS ---- FA.check ("ERFnInterval: scale:\n before:\n" ++ show f ++ "\n after:\n") $ ---- #endif normalise $ case RA.compareReals ratio 0 of Just GT -> - ERFnInterval (scaleUp ratio ln) (scaleUp ratio h) c g + ERFnInterval (scaleUp ratio ln) (scaleUp ratio h) c Just LT -> - ERFnInterval (scaleUp (- ratio) h) (scaleUp (- ratio) ln) c g + ERFnInterval (scaleUp (- ratio) h) (scaleUp (- ratio) ln) c _ -> (UFA.const [ratio]) * f where @@ -684,22 +690,22 @@ instance maxDegree = erfnMaxDegree c maxSize = erfnMaxSize c eval ptBox (ERFnIntervalAny c) = [RA.bottomApprox] - eval ptBox (ERFnInterval ln h c g) = + eval ptBox (ERFnInterval ln h c) = [lo RA.\/ up] where up = UFB.evalApprox ptBox h lo = negate $ UFB.evalApprox ptBox ln partialEval substitutions f@(ERFnIntervalAny c) = f - partialEval substitutions f@(ERFnInterval ln h c g) = + partialEval substitutions f@(ERFnInterval ln h c) = normalise $ - (ERFnInterval lnP hP c g) + ERFnInterval lnP hP c where hP = UFB.partialEvalApproxUp substitutions h lnP = UFB.partialEvalApproxUp substitutions ln composeNonDecreasing - fOuter@(ERFnInterval lnOuter hOuter cOuter gOuter) + fOuter@(ERFnInterval lnOuter hOuter cOuter) varid - fInner@(ERFnInterval lnInner hInner cInner gInner) = + fInner@(ERFnInterval lnInner hInner cInner) = -- unsafePrintReturn -- ( -- "ER.RnToRm.UnitDom.Interval: composeNonDecreasing: " @@ -721,17 +727,17 @@ instance FA.ranra2domra fInner $ (\[x] -> x) $ FA.eval ptB fInner - result = ERFnInterval ln h c gOuter + result = ERFnInterval ln h c h = erfnUpper $ UFA.composeWithThin fOuter $ Map.singleton varid - (ERFnInterval (UFB.neg hInner) hInner cInner gInner) + (ERFnInterval (UFB.neg hInner) hInner cInner) ln = erfnLowerNeg $ UFA.composeWithThin fOuter $ Map.singleton varid $ - (ERFnInterval lnInner (UFB.neg lnInner) cInner gInner) + (ERFnInterval lnInner (UFB.neg lnInner) cInner) c = erfnContextUnify cOuter cInner composeNonDecreasing fOuter varid fInner = @@ -740,8 +746,8 @@ instance c = erfnContextUnify (erfnContext fOuter) (erfnContext fInner) instance - (UFB.ERUnitFnBase boxb boxra varid b ra fb, Show varid, Show boxra) => - UFA.ERUnitFnApprox boxra varid ra ra (ERFnInterval fb ra) + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, Show varid, Show boxra) => + UFA.ERUnitFnApprox boxra varid ra ra (ERFnInterval fb) where bottomApprox = ERFnIntervalAny erfnContextDefault @@ -755,8 +761,7 @@ instance { erfnLowerNeg = fbLNeg, erfnUpper = fbH, - erfnContext = context, - erfnGlobal = val + erfnContext = context } | otherwise = ERFnIntervalAny context @@ -779,11 +784,12 @@ instance { erfnLowerNeg = fbLNeg, erfnUpper = fbH, - erfnContext = context, - erfnGlobal = - UFB.raFromEndpoints fbH - (valL - coeffCorr - coeffsAbsSum, - valH + coeffCorr + coeffsAbsSum) + erfnContext = context +-- , +-- erfnGlobal = +-- UFB.raFromEndpoints fbH +-- (valL - coeffCorr - coeffsAbsSum, +-- valH + coeffCorr + coeffsAbsSum) } | otherwise = ERFnIntervalAny context @@ -811,7 +817,7 @@ instance substitutions = f composeWithThin - f@(ERFnInterval ln1 h1 ctxt1 gl1) + f@(ERFnInterval ln1 h1 ctxt1) substitutions = -- unsafePrintReturn -- ( @@ -835,7 +841,7 @@ instance evalPtB fInner = FA.ranra2domra fInner $ (\[x] -> x) $ FA.eval ptB fInner - result = ERFnInterval ln h ctxt1 gl1 + result = ERFnInterval ln h ctxt1 ln = UFB.composeManyUp maxDegree maxSize ln1 ufbSubstitutions h = UFB.composeManyUp maxDegree maxSize h1 ufbSubstitutions ufbSubstitutions = Map.map erfnUpper substitutions @@ -850,19 +856,19 @@ instance ctxt = erfnContextUnify ctxt1 ctxt2 intersectMeasureImprovement ix vars f1@(ERFnIntervalAny ctxt1) - f2@(ERFnInterval ln2 h2 ctxt2 gl2) = - (ERFnInterval ln2 h2 ctxt gl2, 1 / 0) + f2@(ERFnInterval ln2 h2 ctxt2) = + (ERFnInterval ln2 h2 ctxt, RA.plusInfinity) where ctxt = erfnContextUnify ctxt1 ctxt2 intersectMeasureImprovement ix vars - f1@(ERFnInterval ln1 h1 ctxt1 gl1) + f1@(ERFnInterval ln1 h1 ctxt1) f2@(ERFnIntervalAny ctxt2) = - (ERFnInterval ln1 h1 ctxt gl1, 1) + (ERFnInterval ln1 h1 ctxt, 1) where ctxt = erfnContextUnify ctxt1 ctxt2 intersectMeasureImprovement ix vars - f1@(ERFnInterval ln1 h1 ctxt1 gl1) - f2@(ERFnInterval ln2 h2 ctxt2 gl2) = + f1@(ERFnInterval ln1 h1 ctxt1) + f2@(ERFnInterval ln2 h2 ctxt2) = case RA.compareReals improvementRA 1 of Just LT -> (f1, 1) -- intersection made it worse, keep original _ -> (intersection, improvementRA) @@ -883,8 +889,8 @@ instance intersectionVolume = UFA.volume vars intersection f1Volume = UFA.volume vars f1 ctxt = erfnContextUnify ctxt1 ctxt2 - volume vars (ERFnIntervalAny c) = 1/0 - volume vars (ERFnInterval ln h c g) = + volume vars (ERFnIntervalAny c) = RA.plusInfinity + volume vars (ERFnInterval ln h c) = UFB.raFromEndpoints h (volL, volH) where volH = UFB.volumeAboveZeroUp vars (ln +^ h) @@ -893,8 +899,8 @@ instance hn = UFB.neg h integrate _ f@(ERFnIntervalAny c) _ _ _ = f integrate - ix fD@(ERFnInterval ln h c g) x - origin fI@(ERFnInterval lnInit hInit cInit gInit) = + ix fD@(ERFnInterval ln h c) x + origin fI@(ERFnInterval lnInit hInit cInit) = -- unsafePrintReturn -- ( -- "ERFnInterval: integrate: " @@ -920,7 +926,7 @@ instance ---- check ("ERFnInterval: integrate:\n fD:\n" ++ show fD ++ "\n fI:\n" ++ show fI ++ "\n result:\n") $ ---- #endif normalise $ - (ERFnInterval lnIov hIov c gIov) + (ERFnInterval lnIov hIov c) where -- perform raw integration of both bounds: (hIuL, hIuH) = @@ -944,7 +950,4 @@ instance lnIov = UFB.reduceSizeUp maxSize $ lnIuH +^ lnInit +^ lnIuOriginLNeg +^ (lnIuOriginH +^ lnIuOriginLNeg) - - gIov = - gInit + g * ((1 - origin) RA.\/ (-1 - origin)) diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Approx/IntervalOI.hs b/src/Data/Number/ER/RnToRm/UnitDom/Approx/IntervalOI.hs new file mode 100644 index 0000000..9ba4dca --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Approx/IntervalOI.hs @@ -0,0 +1,1086 @@ +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Approx.IntervalOI + Description : arbitrary precision outer/inner function enclosures on @[-1,1]^n@ + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + A construction of an outer/inner enclosure of a real function on + the domain [-1,1]^n for some n using elements of some + base (eg rational functions or polynomials). +-} +module Data.Number.ER.RnToRm.UnitDom.Approx.IntervalOI +( + ERFnIntervalOI(..) +) +where + +import qualified Data.Number.ER.Real.Base as B +import Data.Number.ER.Real.Approx.Interval +import Data.Number.ER.Real.Approx.OI +import Data.Number.ER.Real.Arithmetic.Elementary + + +import qualified Data.Number.ER.RnToRm.Approx as FA +import qualified Data.Number.ER.RnToRm.UnitDom.Approx as UFA +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB +import Data.Number.ER.RnToRm.UnitDom.Base ((+^),(-^),(*^),multiplyEncl) +import Data.Number.ER.RnToRm.UnitDom.Approx.Interval + +import qualified Data.Number.ER.Real.Approx as RA +import qualified Data.Number.ER.Real.Approx.Elementary as RAEL + +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import Data.Number.ER.BasicTypes + +import Data.Number.ER.Misc + +import Data.Number.ER.ShowHTML +import qualified Text.Html as H + +import qualified Data.Map as Map + +import Data.Typeable +import Data.Generics.Basics +import Data.Binary + +{- only for testing in ghci, to be removed: -} +--import Data.Number.ER.Real.DefaultRepr +--import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom +--import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.PolynomBase +--type FAPU = ERFnInterval (ERChebPoly (Box Int) B) +--fapuConst1 = (UFA.const 0 [1]) :: FAPU +--fapuConst2 = (UFA.const 0 [2]) :: FAPU +{- end of testing specific code -} + +data ERFnIntervalOI fb = + ERFnIntervalOIAny + { + erfnoiContext :: ERFnContext + } + | + ERFnIntervalOI + { +-- erfnLowerNeg :: fb, +-- erfnUpper :: fb, + erfnoiContext :: ERFnContext, + erfnoiOuter :: (fb, fb), + erfnoiInner :: ((fb, fb), Bool) +-- , +-- erfnIsDefinitelyConsistent :: Bool, +-- erfnIsDefinitelyAntiConsistent :: Bool + } + deriving (Typeable, Data) + +instance (Binary a) => Binary (ERFnIntervalOI a) where + put (ERFnIntervalOIAny a) = putWord8 0 >> put a + put (ERFnIntervalOI a b c) = putWord8 1 >> put a >> put b >> put c +-- put (ERFnInterval a b c d e) = putWord8 1 >> put a >> put b >> put c >> put d >> put e + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (ERFnIntervalOIAny a) + 1 -> get >>= \a -> get >>= \b -> get >>= \c -> return (ERFnIntervalOI a b c) +-- 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> return (ERFnInterval a b c d e) + _ -> fail "no parse" + +instance + (UFB.ERUnitFnBase boxb boxra varid b ra fb) => + Show (ERFnIntervalOI fb) + where + show (ERFnIntervalOIAny _) = "ERFnIntervalIOAny" + show (ERFnIntervalOI ctxt (oln,oh) ((iln,ih),isDefinitelyAC)) = + "\nERFnIntervalOI" +-- ++ " (definitely consistent: " ++ show isC +-- ++ "anticonsistent: " ++ show isDefinitelyAC ++ ")" + ++ "\n context = " ++ show ctxt + ++ "\n outer upper = " ++ ufbShow oh + ++ "\n outer lower = " ++ ufbShow (UFB.neg oln) + ++ "\n inner upper = " ++ ufbShow ih + ++ "\n inner lower = " ++ ufbShow (UFB.neg iln) + ++ "\n inner is definitely anticonsistent: " ++ show isDefinitelyAC ++ "\n" +-- ++ " global = " ++ show gl ++ "\n" + where + ufbShow = UFB.showDiGrCmp 10 False False + +instance + (UFB.ERUnitFnBase boxb boxra varid b ra fb) => + H.HTML (ERFnIntervalOI fb) +-- where +-- toHtml (ERFnIntervalAny ctxt) = +-- H.toHtml "ERFnIntervalAny" +-- toHtml (ERFnInterval ln h ctxt) = +---- H.toHtml $ +---- abovesTable +---- [ +---- H.toHtml "ERFnInterval", +-- H.toHtml $ H.simpleTable [H.border 2] [] +-- [ +-- [H.toHtml "upper = ", H.toHtml $ ufbShow h], +-- [H.toHtml "lower = ", H.toHtml $ ufbShow (UFB.neg ln)] +-- ] +---- ] +-- where +-- ufbShow = UFB.showDiGrCmp 10 False False +-- +instance + (UFB.ERUnitFnBase boxb boxra varid b ra fb) => + Eq (ERFnIntervalOI fb) + where + (ERFnIntervalOI ctxt1 o1 i1) + == (ERFnIntervalOI ctxt2 o2 i2) = + error "ERFnIntervalIO: equality not implemented" + _ == _ = + error "ERFnIntervalIO: equality not implemented" + +instance + (UFB.ERUnitFnBase boxb boxra varid b ra fb) => + Ord (ERFnIntervalOI fb) + where + compare + (ERFnIntervalOI ctxt1 o1 i1) + (ERFnIntervalOI ctxt2 o2 i2) = + error "ERFnIntervalOI: comparison not implemented; consider leqReals or compareApprox from class ERApprox instead" + compare _ _ = + error "ERFnIntervalOI: comparison not implemented; consider leqReals or compareApprox from class ERApprox instead" + + +instance + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, + UFB.ERUnitFnBaseIElementary boxb boxra varid b ra fb, + Show varid, Show boxra) => + Num (ERFnIntervalOI fb) + where + fromInteger n = UFA.const [fromInteger n] + negate f@(ERFnIntervalOIAny _) = f + negate (ERFnIntervalOI ctxt (oln,oh) ((iln,ih),isDefinitelyAC)) = + ERFnIntervalOI ctxt (oh,oln) ((ih,iln),isDefinitelyAC) + (ERFnIntervalOI ctxt1 oe1 ie1) + + (ERFnIntervalOI ctxt2 oe2 ie2) = + normalise $ + ERFnIntervalOI ctxt oe ie + where + oe = UFB.addEncl maxDegr maxSize oe1 oe2 + ie = UFB.addIEncl maxDegr maxSize ie1 ie2 + maxDegr = erfnMaxDegree ctxt + maxSize = erfnMaxSize ctxt + ctxt = erfnContextUnify ctxt1 ctxt2 + f1 + f2 = ERFnIntervalOIAny ctxt + where + ctxt = erfnContextUnify (erfnoiContext f1) (erfnoiContext f2) + (ERFnIntervalOI ctxt1 oe1 ie1) * + (ERFnIntervalOI ctxt2 oe2 ie2) = + normalise $ + ERFnIntervalOI ctxt oe ie + where + oe = UFB.multiplyEncl maxDegr maxSize oe1 oe2 + ie = UFB.multiplyIEncl maxDegr maxSize ie1 ie2 + maxDegr = erfnMaxDegree ctxt + maxSize = erfnMaxSize ctxt + ctxt = erfnContextUnify ctxt1 ctxt2 + f1 * f2 = ERFnIntervalOIAny ctxt + where + ctxt = erfnContextUnify (erfnoiContext f1) (erfnoiContext f2) + +instance + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, + UFB.ERUnitFnBaseIElementary boxb boxra varid b ra fb, + Show varid, Show boxra) => + Fractional (ERFnIntervalOI fb) + where + fromRational r = UFA.const [fromRational r] + recip f@(ERFnIntervalOIAny _) = f + recip (ERFnIntervalOI ctxt oe@(oln,oh) ie@((iln,ih),isDAC)) + | certainAboveZero = + normalise $ + ERFnIntervalOI ctxt oeR posieR + | certainBelowZero = + normalise $ + ERFnIntervalOI ctxt oeR negieR +-- | certainNoZero = +-- normalise $ +-- ERFnIntervalOI ctxt oeR ieR + | otherwise = ERFnIntervalOIAny ctxt + where +-- certainNoZero = +-- certainAboveZero || certainBelowZero + certainAboveZero = + certainOuterAboveZero && certainInnerACAboveZero + certainBelowZero = + certainOuterBelowZero && certainInnerACBelowZero + certainOuterAboveZero = + UFB.upperBound ix oln < 0 + certainInnerACAboveZero = + UFB.upperBound ix (UFB.neg ih) < 0 + certainOuterBelowZero = + UFB.upperBound ix oh < 0 + certainInnerACBelowZero = + UFB.upperBound ix (UFB.neg iln) < 0 + oeR = + UFB.recipEncl maxDegr maxSize ix oe + posieR = + UFB.recipIEnclPositive maxDegr maxSize ix ((iln,ih),isDAC) + negieR = + negIEncl $ + UFB.recipIEnclPositive maxDegr maxSize ix $ + ((ih,iln),isDAC) + negIEncl ((a,b),c) = ((b,a),c) +-- hnRecipUp = +-- UFB.recipUp maxDegr maxSize ix (negate h) +-- lRecipUp = +-- UFB.recipUp maxDegr maxSize ix (negate ln) + maxDegr = erfnMaxDegree ctxt + maxSize = erfnMaxSize ctxt + ix = int2effIx $ 3 * maxDegr + +instance + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, UFB.ERUnitFnBaseIElementary boxb boxra varid b ra fb, + Show varid, Show boxra) => + RA.ERApprox (ERFnIntervalOI fb) + where + initialiseBaseArithmetic _ = + UFB.initialiseBaseArithmetic (UFB.const 0 :: fb) +-- getGranularity (ERFnIntervalOIAny ctxt) = erfnCoeffGranularity ctxt +-- getGranularity (ERFnIntervalOI ctxt (oln,oh) ((iln,ih),_)) = +-- maximum $ +-- erfnCoeffGranularity ctxt : map UFB.getGranularity [oln,oh,iln,ih] +-- setGranularity gran (ERFnIntervalAny ctxt) = +-- ERFnIntervalAny $ ctxt { erfnCoeffGranularity = gran } +-- setGranularity gran (ERFnInterval ln h ctxt) = +-- ERFnInterval +-- (UFB.setGranularity gran ln) (UFB.setGranularity gran h) +-- (ctxt { erfnCoeffGranularity = gran }) +-- setMinGranularity gran (ERFnIntervalAny ctxt) = +-- ERFnIntervalAny +-- (ctxt { erfnCoeffGranularity = max gran (erfnCoeffGranularity ctxt) }) +-- setMinGranularity gran (ERFnInterval ln h ctxt) = +-- ERFnInterval +-- (UFB.setMinGranularity gran ln) (UFB.setMinGranularity gran h) +-- (ctxt { erfnCoeffGranularity = max gran (erfnCoeffGranularity ctxt) }) +---- getPrecision (ERFnIntervalAny _) = 0 +---- getPrecision f = intLog 2 (1 + (fst $ RA.integerBounds (FA.volume f))) -- wrong! + isBottom (ERFnIntervalOIAny _) = True + isBottom _ = False +-- f1@(ERFnInterval ln1 h1 ctxt1) /\ f2@(ERFnInterval ln2 h2 ctxt2) = +------ #ifdef RUNTIME_CHECKS +------ check ("ERFnInterval: /\\:\n f1:\n" ++ show f1 ++ " f2:\n" ++ show f2 ++ "\n result:\n") $ +------ #endif +-- normalise $ +-- ERFnInterval +-- (UFB.minUp maxDegr maxSize ln1 ln2) +-- (UFB.minUp maxDegr maxSize h1 h2) +-- ctxt +-- where +-- ctxt = erfnContextUnify ctxt1 ctxt2 +-- maxDegr = erfnMaxDegree ctxt +-- maxSize = erfnMaxSize ctxt +-- (ERFnIntervalAny ctxt1) /\ (ERFnInterval ln2 h2 ctxt2) = +-- ERFnInterval ln2 h2 ctxt +-- where +-- ctxt = erfnContextUnify ctxt1 ctxt2 +-- (ERFnInterval ln1 h1 ctxt1) /\ (ERFnIntervalAny ctxt2) = +-- ERFnInterval ln1 h1 ctxt +-- where +-- ctxt = erfnContextUnify ctxt1 ctxt2 +-- f1 /\ f2 = ERFnIntervalAny ctxt +-- where +-- ctxt = erfnContextUnify (erfnContext f1) (erfnContext f2) + leqReals f1 f2 = +-- unsafePrint ("ERInterval: leqReals: sizes: " ++ show (FA.getSize f1) ++ ", " ++ show (FA.getSize f2)) $ + erfnintLeq f1 f2 + {- + The relation 'refines' corresponds to enclosure inclusion of the outer + enclosure of the left argument in the inner enclosure of the right + argument. Probably wrong way to implement this... should split into + refinesI and refinesO? + -} +-- refines _ (ERFnIntervalOIAny _) = True +-- refines (ERFnIntervalOIAny _) _ = False +-- refines (ERFnIntervalOI _ (oln,oh) _) (ERFnIntervalOI _ _ ((iln,ih),_)) = +-- (UFB.upperBound 10 (iln -^ oln) >= 0) +-- && +-- (UFB.upperBound 10 (ih -^ oh) >= 0) +-- compareApprox (ERFnIntervalAny _) (ERFnIntervalAny _) = EQ +-- compareApprox (ERFnIntervalAny _) _ = LT +-- compareApprox _ (ERFnIntervalAny _) = GT +-- compareApprox (ERFnInterval ln1 h1 _) (ERFnInterval ln2 h2 _) = +-- compareComposeMany +-- [ +-- UFB.compareApprox h1 h2, +-- UFB.compareApprox ln1 ln2 +-- ] +-- +erfnintLeq left right + | left `isClearlyBelow` right = Just True + | right `isClearlyStrictlyBelow` left = Just False + | otherwise = Nothing + where + isClearlyBelow (ERFnIntervalOIAny _) _ = False + isClearlyBelow _ (ERFnIntervalOIAny _) = False + isClearlyBelow + f@(ERFnIntervalOI _ (_,ohf) _) + g@(ERFnIntervalOI _ (olng,_) _) + | UFB.upperBoundPrecise 10 (ohf +^ olng) <= 0 = True +-- | UFB.upperBoundPrecise 10 (erfnUpper f +^ erfnLowerNeg g) <= 0 = True + | otherwise = False + isClearlyStrictlyBelow (ERFnIntervalOIAny _) _ = False + isClearlyStrictlyBelow _ (ERFnIntervalOIAny _) = False + isClearlyStrictlyBelow + f@(ERFnIntervalOI _ (_,ohf) _) + g@(ERFnIntervalOI _ (olng,_) _) + | UFB.upperBoundPrecise 10 (ohf +^ olng) < 0 = True +-- | UFB.upperBoundPrecise 10 (erfnUpper f +^ erfnLowerNeg g) < 0 = True + | otherwise = False + +instance + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, + UFB.ERUnitFnBaseIElementary boxb boxra varid b ra fb, + Show varid, Show boxra) => + RA.ERIntApprox (ERFnIntervalOI fb) + where +---- doubleBounds = :: ira -> (Double, Double) +---- floatBounds :: ira -> (Float, Float) +---- integerBounds :: ira -> (ExtendedInteger, ExtendedInteger) +-- bisectDomain maybePt (ERFnIntervalAny c) = +-- error "ERFnInterval: RA.bisectDomain: cannot bisect ERFnIntervalAny" +-- bisectDomain maybePt (ERFnInterval ln h c) = +-- (ERFnInterval ln midUp c, +-- ERFnInterval midDownNeg h c) +-- where +-- (midDownNeg, midUp) = +-- case maybePt of +-- Nothing -> +-- (UFB.scaleUp (1/2) $ ln -^ h, UFB.scaleUp (1/2) $ h -^ ln) +-- Just (ERFnInterval lnPt hPt _) -> +-- (lnPt, hPt) +-- bounds (ERFnIntervalAny c) = +-- error "ERFnInterval: RA.bounds: cannot get bounds for ERFnIntervalAny" +-- bounds (ERFnInterval ln h c) = +-- (ERFnInterval ln (UFB.neg ln) c, +-- ERFnInterval (UFB.neg h) h c) + f1@(ERFnIntervalOI ctxt1 oe1@(oln1,oh1) ie1@((iln1,ih1),isDAC1)) \/ + f2@(ERFnIntervalOI ctxt2 oe2@(oln2,oh2) ie2@((iln2,ih2),isDAC2)) = +---- #ifdef RUNTIME_CHECKS +---- check ("ERFnInterval: abs:\n f1:\n" ++ show f1 ++ " f2:\n" ++ show f2 ++ "\n result:\n") $ +---- #endif + normalise $ + ERFnIntervalOI ctxt oe ie + where + ctxt = erfnContextUnify ctxt1 ctxt2 + oe = (oln,oh) + oln = UFB.maxUp maxDegree maxSize oln1 oln2 + oh = UFB.maxUp maxDegree maxSize oh1 oh2 + ie = ((iln,ih),isDAC) + iln = UFB.maxDown maxDegree maxSize iln1 iln2 + ih = UFB.maxDown maxDegree maxSize ih1 ih2 + {-^ + Note that using maxDown here is safe, but very wasteful. It should + be possible to find a safe yet more precise way of computing this + type of min/max for bound functions... + -} + isDAC = False + maxDegree = erfnMaxDegree ctxt + maxSize = erfnMaxSize ctxt + (ERFnIntervalOIAny ctxt1) \/ (ERFnIntervalOI ctxt2 _ _) = + ERFnIntervalOIAny ctxt + where + ctxt = erfnContextUnify ctxt1 ctxt2 + (ERFnIntervalOI ctxt1 _ _) \/ (ERFnIntervalOIAny ctxt2) = + ERFnIntervalOIAny ctxt + where + ctxt = erfnContextUnify ctxt1 ctxt2 + f1 \/ f2 = ERFnIntervalOIAny ctxt + where + ctxt = erfnContextUnify (erfnoiContext f1) (erfnoiContext f2) + +instance + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, + UFB.ERUnitFnBaseIElementary boxb boxra varid b ra fb, + RAEL.ERApproxElementary ra, + Show varid, Show boxra) => + RAEL.ERApproxElementary (ERFnIntervalOI fb) + where +-- -- default abs does not work because we do not have Prelude.abs +-- abs _ f@(ERFnIntervalAny _) = f +-- abs _ f@(ERFnInterval ln h c) = +------ #ifdef RUNTIME_CHECKS +------ check ("ERFnInterval: abs:\n f:\n" ++ show f ++ "\n result:\n") $ +------ #endif +-- normalise $ +-- ERFnInterval minhln0Up maxhlnUp c +-- where +-- maxhlnUp = UFB.maxUp maxDegree maxSize h ln +-- minhln0Up = +-- UFB.minUp maxDegree maxSize (UFB.const 0) $ +-- UFB.minUp maxDegree maxSize h ln +-- maxDegree = erfnMaxDegree c +-- maxSize = erfnMaxSize c + sqrt ix f@(ERFnIntervalOIAny _) = f + sqrt ix f@(ERFnIntervalOI ctxt oe@(oln,_) ie@((iln,ih),_)) + | certainAboveZero = + normalise $ + ERFnIntervalOI ctxt oeR ieR + | otherwise = ERFnIntervalOIAny ctxt + where + certainAboveZero = -- OK since consistent inner will be inside outer + certainOuterAboveZero && certainInnerACAboveZero + certainOuterAboveZero = + UFB.upperBound ix oln < 0 + certainInnerACAboveZero = + UFB.upperBound ix (UFB.neg ih) < 0 + && + UFB.upperBound ix iln < 0 + oeR = + UFB.sqrtEncl maxDegr maxSize ix oe + ieR = + UFB.sqrtIEncl maxDegr maxSize ix ie + maxDegr = erfnMaxDegree ctxt + maxSize = erfnMaxSize ctxt + +-- exp ix f@(ERFnIntervalAny _) = f +-- exp ix f@(ERFnInterval ln h c) = +-- normalise $ +-- ERFnInterval lExpNeg hExp c +-- where +-- maxDegree = erfnMaxDegree c +-- maxSize = erfnMaxSize c +-- (lExpNeg, hExp) = +-- case (UFB.upperBound ix (h +^ ln) <= 1) of +-- True -> +-- UFB.expEncl maxDegree maxSize ix (ln, h) +-- False -> +-- (lExpNeg, hExp) +-- where +-- (lExpNeg, _) = UFB.expEncl maxDegree maxSize ix (ln, UFB.neg ln) +-- (_, hExp) = UFB.expEncl maxDegree maxSize ix (UFB.neg h,h) +-- sin ix f@(ERFnIntervalAny c) = +-- ERFnInterval one one c +-- where +-- one = UFB.const 1 +-- sin ix f@(ERFnInterval ln h c) = +---- unsafePrint +---- ( +---- "ERFnInterval: RAEL.sin: " +---- ++ "\n h = " ++ show h +---- ++ "\n ln = " ++ show ln +---- ++ "\n hSin = " ++ show hSin +---- ++ "\n lSinNeg = " ++ show lSinNeg +---- ) $ +------ #ifdef RUNTIME_CHECKS +------ check ("ERFnInterval: sin:\n f:\n" ++ show f ++ "\n result:\n") $ +------ #endif +-- normalise $ +-- ERFnInterval lSinNeg hSin c +-- where +-- (lSinNeg, hSin) = sincos True maxDegree maxSize ix (ln, h) +-- maxDegree = erfnMaxDegree c +-- maxSize = erfnMaxSize c +-- cos ix f@(ERFnIntervalAny c) = +-- ERFnInterval one one c +-- where +-- one = UFB.const 1 +-- cos ix f@(ERFnInterval ln h c) = +---- unsafePrint +---- ( +---- "ERFnInterval: RAEL.cos: " +---- ++ "\n h = " ++ show h +---- ++ "\n ln = " ++ show ln +---- ++ "\n uCos = " ++ show uCos +---- ++ "\n lCosNeg = " ++ show lCosNeg +---- ) $ +-- normalise $ +-- ERFnInterval lCosNeg hCos c +-- where +-- (lCosNeg, hCos) = sincos False maxDegree maxSize ix (ln,h) +-- maxDegree = erfnMaxDegree c +-- maxSize = erfnMaxSize c +-- atan ix f@(ERFnIntervalAny c) = +-- ERFnInterval one one c +-- where +-- one = UFB.const 1 +-- atan ix f@(ERFnInterval ln h c) = +---- unsafePrint +---- ( +---- "ERFnInterval: RAEL.atan: " +---- ++ "\n u = " ++ show u +---- ++ "\n ln = " ++ show ln +---- ++ "\n uAtan = " ++ show uAtan +---- ++ "\n lAtanNeg = " ++ show lAtanNeg +---- ) $ +-- normalise $ +-- ERFnInterval lAtanNeg hAtan c +-- where +-- maxDegree = erfnMaxDegree c +-- maxSize = erfnMaxSize c +---- ix = int2effIx maxDegree +-- (lAtanNeg, hAtan) = +-- case (UFB.upperBound ix (h +^ ln) <= 1) of +-- True -> +-- UFB.atanEncl maxDegree maxSize ix (ln, h) +-- False -> +-- (lAtanNeg, hAtan) +-- where +-- (lAtanNeg, _) = UFB.atanEncl maxDegree maxSize ix (ln, UFB.neg ln) +-- (_, hAtan) = UFB.atanEncl maxDegree maxSize ix (UFB.neg h,h) +-- +--sincos :: +-- (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, RAEL.ERApproxElementary ra, RealFrac b) => +-- Bool {-^ True iff sine, False iff cosine -} -> +-- Int {-^ maximum representation degree -} -> +-- Int {-^ maximum approx size -} -> +-- EffortIndex {-^ how hard to try to eliminate truncation errors -} -> +-- (fb, fb) -> +-- (fb, fb) +--sincos isSine maxDegree maxSize ix (ln,h) +-- -- p - 2k*pi range within [-pi/2, pi/2]: +-- | ranfNear0 `RA.refines` plusMinusPiHalf = +---- unsafePrint +---- ( +---- "ERFnInterval: sincos: [-pi/2, pi/2]: " +---- ++ "\n u = " ++ show u +---- ++ "\n l = " ++ show l +---- ++ "\n ranf = " ++ show ranf +---- ++ "\n k = " ++ show k +---- ++ "\n ranfNear0 = " ++ show ranfNear0 +---- ) $ +-- case isSine of +-- True -> sineShifted (- k2pi) +-- False -> cosineShifted (- k2pi) +-- -- p - 2k*pi range within [0, pi]: +-- | (ranfNear0 - piHalf) `RA.refines` plusMinusPiHalf = +---- unsafePrint +---- ( +---- "ERFnInterval: sincos: [0, pi]: " +---- ++ "\n u = " ++ show u +---- ++ "\n l = " ++ show l +---- ++ "\n ranf = " ++ show ranf +---- ++ "\n k = " ++ show k +---- ++ "\n ranfNear0 = " ++ show ranfNear0 +---- ) $ +-- case isSine of +-- -- use sin(x) = cos(x - pi/2) and cos(x) = - sin(x - pi/2): +-- True -> cosineShifted (- k2pi - piHalf) +-- False -> sineShiftedNegated (- k2pi - piHalf) +-- -- p - 2k*pi range within [-pi, 0]: +-- | (ranfNear0 + piHalf) `RA.refines` plusMinusPiHalf = +---- unsafePrint +---- ( +---- "ERFnInterval: sincos: [-pi, 0]: " +---- ++ "\n u = " ++ show u +---- ++ "\n l = " ++ show l +---- ++ "\n ranf = " ++ show ranf +---- ++ "\n k = " ++ show k +---- ++ "\n ranfNear0 = " ++ show ranfNear0 +---- ) $ +-- case isSine of +-- -- use sin(x) = - cos(x + pi/2) and cos(x) = sin(x + pi/2): +-- True -> cosineShiftedNegated (-k2pi + piHalf) +-- False -> sineShifted (-k2pi + piHalf) +-- -- p - 2k*pi range within [pi/2, 3pi/2]: +-- | (ranfNear0 - pi) `RA.refines` plusMinusPiHalf = +---- unsafePrint +---- ( +---- "ERFnInterval: sincos: [pi/2, 3pi/2]: " +---- ++ "\n u = " ++ show u +---- ++ "\n l = " ++ show l +---- ++ "\n ranf = " ++ show ranf +---- ++ "\n k = " ++ show k +---- ++ "\n ranfNear0 = " ++ show ranfNear0 +---- ) $ +-- -- use sin(x) = - sin(x - pi) and cos(x) = - cos(x - pi) +-- case isSine of +-- True -> sineShiftedNegated (- k2pi - pi) +-- False -> cosineShiftedNegated (- k2pi - pi) +-- | otherwise = +---- unsafePrint +---- ( +---- "ERFnInterval: sincos: big range: " +---- ++ "\n u = " ++ show u +---- ++ "\n l = " ++ show l +---- ++ "\n ranf = " ++ show ranf +---- ++ "\n k = " ++ show k +---- ++ "\n ranfNear0 = " ++ show ranfNear0 +---- ) $ +-- (UFB.const (-1), UFB.const 1) +---- (expDownwards, expUpwards + valueAtRDnNeg + (UFB.const expRUp)) +-- where +---- l = UFB.neg ln +-- ranfNear0 = ranf - k2pi +-- k2pi = k * 2 * pi +-- plusMinusPiHalf = (-piHalfLO) RA.\/ piHalfLO +-- pi = RAEL.pi ix +-- piHalf = pi / 2 +-- (piHalfLO, piHalfHI) = RA.bounds piHalf +-- ranf = +-- ERInterval +-- (negate $ UFB.upperBound 10 ln) +-- (UFB.upperBound 10 h) +-- k = fromInteger $ toInteger kEI +-- (kEI,_) = RA.integerBounds $ 0.5 + (ranf / (2*pi)) +-- +-- sineShiftedNegated shift = +-- boundsNegate $ sineShifted shift +-- +-- cosineShiftedNegated shift = +-- boundsNegate $ cosineShifted shift +-- +-- boundsNegate (pLONeg, pHI) = (pHI, pLONeg) +-- +-- sineShifted shift = -- moving to domain where sinus is non-decreasing +-- case (UFB.upperBound ix (h +^ ln) <= 0.25) of +-- True -> +-- UFB.sinEncl maxDegree maxSize ix (lnShifted, hShifted) +-- False -> +-- (lSinNeg, hSin) +-- where +-- (lSinNeg, _) = UFB.sinEncl maxDegree maxSize ix (ln, UFB.neg ln) +-- (_, hSin) = UFB.sinEncl maxDegree maxSize ix (UFB.neg h,h) +-- where +-- lnShifted = ln +^ (UFB.const (- shiftLOB)) +-- hShifted = h +^ (UFB.const shiftHIB) +-- ERInterval shiftLOB shiftHIB = shift +-- +-- +-- +-- cosineShifted shift = -- moving to domain where cosinus is non-decreasing +-- case (UFB.upperBound ix (h +^ ln) <= 0.25) of +-- True -> +-- UFB.cosEncl maxDegree maxSize ix (lnShifted, hShifted) +-- False -> +-- (UFB.minUp maxDegree maxSize lCosDownNeg hCosDownNeg, +-- UFB.maxUp maxDegree maxSize lCosUp hCosUp +-- +^ (UFB.scaleUp 0.5 (h +^ ln))) +-- -- this term is important when enclosure hits 0; +-- -- without it, the result could miss cosine's maximum at 0 +-- where +-- (lCosDownNeg, lCosUp) = UFB.cosEncl maxDegree maxSize ix (ln, UFB.neg ln) +-- (hCosDownNeg, hCosUp) = UFB.cosEncl maxDegree maxSize ix (UFB.neg h,h) +-- lnShifted = ln +^ (UFB.const (- shiftLOB)) +-- hShifted = h +^ (UFB.const shiftHIB) +-- ERInterval shiftLOB shiftHIB = shift +-- +-- boundsAddErr errB (pLONeg, pHI) = +-- (pLONeg +^ errPoly, pHI +^ errPoly) +-- where +-- errPoly = UFB.const errB + +normalise f@(ERFnIntervalOIAny _) = f +normalise f@(ERFnIntervalOI ctxt (oln,oh) ((iln,ih),_)) + | UFB.isValid oh && UFB.isValid oln && UFB.isValid ih && UFB.isValid iln = f + | otherwise = ERFnIntervalOIAny ctxt + +--check callerLocation f@(ERFnIntervalAny c) = f +--check callerLocation f@(ERFnInterval ln h c) = +-- ERFnInterval +-- (UFB.check (callerLocation ++ "upper: ") h) +-- (UFB.check (callerLocation ++ "neg lower: ") ln) +-- c +-- +-- +instance + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, + UFB.ERUnitFnBaseIElementary boxb boxra varid b ra fb, + Show varid, Show boxra) => + FA.ERFnApprox boxra varid ra ra (ERFnIntervalOI fb) + where +-- check = check + domra2ranra _ = id + ranra2domra _ = id + getMaxDegree (ERFnIntervalOIAny ctxt) = + erfnMaxDegree ctxt + getMaxDegree (ERFnIntervalOI ctxt _ _) = + erfnMaxDegree ctxt + setMaxDegree maxDegr (ERFnIntervalOIAny c) = + ERFnIntervalOIAny (c { erfnMaxDegree = maxDegr } ) + setMaxDegree maxDegr (ERFnIntervalOI ctxt oe@(oln,oh) ie@((iln,ih),isDAC)) = + ERFnIntervalOI + (ctxt { erfnMaxDegree = maxDegr } ) + (UFB.reduceDegreeUp maxDegr oln, UFB.reduceDegreeUp maxDegr oh) + ((UFB.neg $ UFB.reduceDegreeUp maxDegr (UFB.neg iln), + UFB.neg $ UFB.reduceDegreeUp maxDegr (UFB.neg ih)),isDAC) +-- getSize (ERFnIntervalAny c) = 0 +-- getSize (ERFnInterval ln h c) = +-- max (UFB.getSize ln) (UFB.getSize h) +-- getMaxSize (ERFnIntervalOIAny ctxt) = +-- erfnMaxSize ctxt +-- getMaxSize (ERFnIntervalOI ctxt _ _) = +-- erfnMaxSize ctxt +-- setMaxSize maxSize (ERFnIntervalOIAny ctxt) = +-- ERFnIntervalOIAny (ctxt { erfnMaxDegree = maxSize } ) +-- setMaxSize maxSize (ERFnIntervalOI ctxt oe@(oln,oh) ie@((iln,ih),isDAC)) = +-- ERFnIntervalOI +-- (ctxt { erfnMaxSize = maxSize } ) +-- (UFB.neg $ UFB.reduceSizeUp maxSize (UFB.neg oln), UFB.reduceSizeUp maxSize oh) +-- ((UFB.neg $ UFB.reduceSizeUp maxSize (UFB.neg iln), UFB.neg $ UFB.reduceSizeUp maxSize ih),isDAC) +-- getVariables (ERFnIntervalAny _) = [] +-- getVariables (ERFnInterval ln h _) = UFB.getVariables h +-- getRangeApprox (ERFnIntervalAny _) = +-- RA.bottomApprox +-- getRangeApprox (ERFnInterval ln h c) = +-- UFB.raFromEndpoints h +-- ( +-- (- (UFB.upperBound 10 ln)) +-- , +-- (UFB.upperBound 10 h) +-- ) +-- scale ratio f@(ERFnIntervalAny c) = +-- f +-- scale ratio f@(ERFnInterval ln h c) = +------ #ifdef RUNTIME_CHECKS +------ FA.check ("ERFnInterval: scale:\n before:\n" ++ show f ++ "\n after:\n") $ +------ #endif +-- normalise $ +-- case RA.compareReals ratio 0 of +-- Just GT -> +-- ERFnInterval (scaleUp ratio ln) (scaleUp ratio h) c +-- Just LT -> +-- ERFnInterval (scaleUp (- ratio) h) (scaleUp (- ratio) ln) c +-- _ -> +-- (UFA.const [ratio]) * f +-- where +-- scaleUp = UFB.scaleApproxUp maxDegree maxSize +-- maxDegree = erfnMaxDegree c +-- maxSize = erfnMaxSize c +-- eval ptBox (ERFnIntervalAny c) = [RA.bottomApprox] +-- eval ptBox (ERFnInterval ln h c) = +-- [lo RA.\/ up] +-- where +-- up = UFB.evalApprox ptBox h +-- lo = negate $ UFB.evalApprox ptBox ln +-- partialEval substitutions f@(ERFnIntervalAny c) = f +-- partialEval substitutions f@(ERFnInterval ln h c) = +-- normalise $ +-- ERFnInterval lnP hP c +-- where +-- hP = UFB.partialEvalApproxUp substitutions h +-- lnP = UFB.partialEvalApproxUp substitutions ln +-- composeNonDecreasing +-- fOuter@(ERFnInterval lnOuter hOuter cOuter) +-- varid +-- fInner@(ERFnInterval lnInner hInner cInner) = +---- unsafePrintReturn +---- ( +---- "ER.RnToRm.UnitDom.Interval: composeNonDecreasing: " +---- ++ "\n fOuter = " ++ show fOuter +---- ++ "\n varid = " ++ show varid +---- ++ "\n fInner = " ++ show fInner +---- ++ "\n inconsistencies = " ++ show (UFA.keyPointsConsistencyCheck resultReals result) +---- ++ "\n result = " +---- ) +---- $ +-- result +-- where +-- resultReals ptB = -- this is only used for consistency checking... +-- (\[x] -> x) $ FA.eval ptBOuter fOuter +-- where +-- ptBOuter = +-- DBox.insert varid fInnerVal ptB +-- fInnerVal = +-- FA.ranra2domra fInner $ +-- (\[x] -> x) $ FA.eval ptB fInner +-- +-- result = ERFnInterval ln h c +-- h = +-- erfnUpper $ +-- UFA.composeWithThin fOuter $ +-- Map.singleton varid +-- (ERFnInterval (UFB.neg hInner) hInner cInner) +-- ln = +-- erfnLowerNeg $ +-- UFA.composeWithThin fOuter $ +-- Map.singleton varid $ +-- (ERFnInterval lnInner (UFB.neg lnInner) cInner) +-- c = erfnContextUnify cOuter cInner +-- +-- composeNonDecreasing fOuter varid fInner = +-- ERFnIntervalAny c +-- where +-- c = erfnContextUnify (erfnContext fOuter) (erfnContext fInner) +-- +instance + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, + UFB.ERUnitFnBaseIElementary boxb boxra varid b ra fb, + Show varid, Show boxra) => + UFA.ERUnitFnApprox boxra varid ra ra (ERFnIntervalOI fb) + where + bottomApprox = + ERFnIntervalOIAny erfnContextDefault + {- + Can't get 'const' through the type checker, even when adding the + suggested declaration... why doesn't the trick used for ERFnInterval + work here? + -} + const [val] + | RA.isBounded val = +---- #ifdef RUNTIME_CHECKS +---- check ("ERFnInterval: const:\n") $ +---- #endif + normalise $ + ERFnIntervalOI ctxt oe ie +-- ERFnIntervalOI +-- { +-- erfnoiContext = ctxt, +-- erfnoiOuter = oe, +-- erfnoiInner = ie +-- } + | otherwise = + ERFnIntervalOIAny ctxt + where + oe@(_,h) = UFB.constEncl valEndpoints + ie = UFB.constIEncl valEndpoints + valEndpoints = UFB.raEndpoints h val + ctxt = + erfnContextDefault + { + erfnCoeffGranularity = RA.getGranularity val + } + affine [val] coeffsSingletons + | RA.isBounded val && (and $ map (RA.isBounded . head) $ Map.elems coeffsSingletons) = +---- #ifdef RUNTIME_CHECKS +---- check ("ERFnInterval: affine:\n") $ +---- #endif + normalise $ + ERFnIntervalOI ctxt oe ie + | otherwise = + ERFnIntervalOIAny ctxt + where + ctxt = + erfnContextDefault + { + erfnCoeffGranularity = coeffGranularity + } + coeffGranularity = + Map.fold max (RA.getGranularity val) (Map.map RA.getGranularity coeffs) + coeffs = Map.map (\[a] -> a) coeffsSingletons + + oe = (oln, oh) + oh = UFB.affine (valH + coeffTotalRadius) (Map.map fst coeffsMidsAndErrbnds) + oln = UFB.affine (coeffTotalRadius - valL) (Map.map (negate . fst) coeffsMidsAndErrbnds) + + ie = ((iln, ih), True) + ih = + UFB.affine + (valH `plusDown` (- coeffTotalErrbnd)) + (Map.map fst coeffsMidsAndErrbnds) + iln = + UFB.affine + (negate $ coeffTotalErrbnd + valL) + (Map.map (negate . fst) coeffsMidsAndErrbnds) + coeffTotalErrbnd = + Map.fold (+) 0 $ Map.map snd coeffsMidsAndErrbnds + + (valL, valH) = UFB.raEndpoints oh val + + coeffTotalRadius = + Map.fold (+) 0 coeffsRads + coeffsRads = + Map.map (\(l,h) -> (h - l)/2) coeffsEndpoints + coeffsEndpoints = + Map.map + (mapPairHomog (B.setMinGranularity coeffGranularity) + . + UFB.raEndpoints oh) + coeffs + coeffsMidsAndErrbnds = + Map.map computeMidCorr coeffsEndpoints + where + computeMidCorr (l,h) = + (midUp, midUp - midDown) + where + midUp = (l+h)/2 + midDown = negate $ ((negate l) + (negate h)) / 2 + composeWithThin + f@(ERFnIntervalOIAny ctxt) + substitutions = + f + composeWithThin + f@(ERFnIntervalOI ctxt oe@(oln,oh) ie@((iln,ih),isDefinitelyAC)) + substitutions = +-- unsafePrintReturn +-- ( +-- "ER.RnToRm.UnitDom.Interval: composeWithThin: " +-- ++ "\n f = " ++ show f +-- ++ "\n substitutions = " ++ show substitutions +-- ++ "\n inconsistencies = " ++ show (UFA.keyPointsConsistencyCheck resultReals result) +-- ++ "\n result = " +-- ) +-- $ + result + where + resultReals ptB = -- this is only used for consistency checking... + (\[x] -> x) $ + FA.eval ptBOuter f + where + ptBOuter = + foldl insertVal ptB $ Map.toList substitutions + insertVal ptB (varid, fInner) = + DBox.insert varid (evalPtB fInner) ptB + evalPtB fInner = + FA.ranra2domra fInner $ (\[x] -> x) $ FA.eval ptB fInner + + result = ERFnIntervalOI ctxt oeNew ieNew + oeNew = (olnNew, ohNew) + ieNew = ((ilnNew, ihNew), isDefinitelyAC) + olnNew = UFB.composeManyUp maxDegree maxSize oln ufbSubstitutions + ohNew = UFB.composeManyUp maxDegree maxSize oh ufbSubstitutions + ilnNew = UFB.composeManyDown maxDegree maxSize iln ufbSubstitutions + ihNew = UFB.composeManyDown maxDegree maxSize ih ufbSubstitutions + ufbSubstitutions = Map.map (snd . erfnoiOuter) substitutions + maxDegree = erfnMaxDegree ctxt + maxSize = erfnMaxSize ctxt +-- ctxt = erfnContextUnify ctxt1 ctxt2 +-- intersectMeasureImprovement ix vars +-- f1@(ERFnIntervalAny ctxt1) +-- f2@(ERFnIntervalAny ctxt2) = +-- (ERFnIntervalAny ctxt, RA.bottomApprox) +-- where +-- ctxt = erfnContextUnify ctxt1 ctxt2 +-- intersectMeasureImprovement ix vars +-- f1@(ERFnIntervalAny ctxt1) +-- f2@(ERFnInterval ln2 h2 ctxt2) = +-- (ERFnInterval ln2 h2 ctxt, RA.plusInfinity) +-- where +-- ctxt = erfnContextUnify ctxt1 ctxt2 +-- intersectMeasureImprovement ix vars +-- f1@(ERFnInterval ln1 h1 ctxt1) +-- f2@(ERFnIntervalAny ctxt2) = +-- (ERFnInterval ln1 h1 ctxt, 1) +-- where +-- ctxt = erfnContextUnify ctxt1 ctxt2 +-- intersectMeasureImprovement ix vars +-- f1@(ERFnInterval ln1 h1 ctxt1) +-- f2@(ERFnInterval ln2 h2 ctxt2) = +-- case RA.compareReals improvementRA 1 of +-- Just LT -> (f1, 1) -- intersection made it worse, keep original +-- _ -> (intersection, improvementRA) +-- where +-- intersection = +------ #ifdef RUNTIME_CHECKS +------ check ("ERFnInterval: intersectMeasureImprovement:\n f1:\n" ++ show f1 ++ "\n f2:\n" ++ show f2 ++ "\n intersection:\n") $ +------ #endif +-- normalise $ +-- f1 RA./\ f2 +-- improvementRA +-- | 0 `RA.refines` intersectionVolume && 0 `RA.refines` f1Volume = 1 +---- error $ +---- "ERFnInterval: intersectMeasureImprovement: inconsistent result: " +---- ++ show intersection +-- | otherwise = +-- f1Volume / intersectionVolume +-- intersectionVolume = UFA.volume vars intersection +-- f1Volume = UFA.volume vars f1 +-- ctxt = erfnContextUnify ctxt1 ctxt2 +-- volume vars (ERFnIntervalOIAny c) = RA.plusInfinity +-- volume vars (ERFnIntervalOI ctxt (oln,oh) ((iln,ih),_)) = +-- UFB.raFromEndpoints h (volL, volH) +-- where +-- ovolH = UFB.volumeAboveZeroUp vars (ln +^ h) +-- ovolL = negate $ UFB.volumeAboveZeroUp vars (l +^ hn) +-- ivolH = UFB.volumeAboveZeroUp vars (ln +^ h) +-- l = UFB.neg ln +-- hn = UFB.neg h +-- integrate _ f@(ERFnIntervalAny c) _ _ _ = f +-- integrate +-- ix fD@(ERFnInterval ln h c) x +-- origin fI@(ERFnInterval lnInit hInit cInit) = +---- unsafePrintReturn +---- ( +---- "ERFnInterval: integrate: " +---- ++ "\n u = " ++ show u +---- ++ "\n ln = " ++ show ln +---- ++ "\n origin = " ++ show origin +---- ++ "\n uInit = " ++ show uInit +---- ++ "\n lnInit = " ++ show lnInit +---- ++ "\n uIuL = " ++ show uIuL +---- ++ "\n uIuU = " ++ show uIuU +---- ++ "\n uIuOriginL = " ++ show uIuOriginL +---- ++ "\n uIuOriginU = " ++ show uIuOriginU +---- ++ "\n lnIuL = " ++ show lnIuL +---- ++ "\n lnIuU = " ++ show lnIuU +---- ++ "\n lnIuOriginL = " ++ show lnIuOriginL +---- ++ "\n lnIuOriginU = " ++ show lnIuOriginU +---- ++ "\n uIov = " ++ show uIov +---- ++ "\n lnIov = " ++ show lnIov +---- ++ "\n result = " +---- ) +---- $ +------ #ifdef RUNTIME_CHECKS +------ check ("ERFnInterval: integrate:\n fD:\n" ++ show fD ++ "\n fI:\n" ++ show fI ++ "\n result:\n") $ +------ #endif +-- normalise $ +-- (ERFnInterval lnIov hIov c) +-- where +-- -- perform raw integration of both bounds: +-- (hIuL, hIuH) = +---- mapPair (UFB.reduceDegreeDown maxDegree, UFB.reduceDegreeUp maxDegree) $ +-- UFB.integrate x h +-- (lnIuL, lnIuH) = +---- mapPair (UFB.reduceDegreeDown maxDegree, UFB.reduceDegreeUp maxDegree) $ +-- UFB.integrate x ln +-- maxDegree = erfnMaxDegree c +-- maxSize = erfnMaxSize c +-- -- constrain the raw integrals to the origin: +-- (hIuOriginLNeg, hIuOriginH) = +-- UFB.composeEncl maxDegree maxSize hIuL x originEncl +-- (lnIuOriginLNeg, lnIuOriginH) = +-- UFB.composeEncl maxDegree maxSize lnIuL x originEncl +-- originEncl = UFB.constEncl $ UFB.raEndpoints h origin +-- -- adjust the raw integrated functions to enclose the initial condition function: +-- hIov = +-- UFB.reduceSizeUp maxSize $ +-- hIuH +^ hInit +^ hIuOriginLNeg +^ (hIuOriginH +^ hIuOriginLNeg) +-- lnIov = +-- UFB.reduceSizeUp maxSize $ +-- lnIuH +^ lnInit +^ lnIuOriginLNeg +^ (lnIuOriginH +^ lnIuOriginLNeg) +-- + +instance + (UFB.ERUnitFnBase boxb boxra varid b ra fb) => + RA.ERApproxApprox (ERFnIntervalOI fb) + where + safeIncludes _ (ERFnIntervalOIAny _) = False + safeIncludes (ERFnIntervalOIAny _) _ = True + safeIncludes f g = + (UFB.upperBound 10 (olng -^ ilnf) <= 0) + && + (UFB.upperBound 10 (ohg -^ ihf) <= 0) + where + (ERFnIntervalOI _ _ ((ilnf,ihf),_)) = f + (ERFnIntervalOI _ (olng,ohg) _) = g + safeNotIncludes _ (ERFnIntervalOIAny _) = True + safeNotIncludes (ERFnIntervalOIAny _) _ = False + safeNotIncludes f g = + (UFB.upperBound 10 (olnf -^ ilng) < 0) + || + (UFB.upperBound 10 (ohf -^ ihg) < 0) + where + (ERFnIntervalOI _ (olnf,ohf) _) = f + (ERFnIntervalOI _ _ ((ilng,ihg),_)) = g + includes _ (ERFnIntervalOIAny _) = Just False + includes (ERFnIntervalOIAny _) _ = Just True + includes f g + | RA.safeIncludes f g = Just True + | RA.safeNotIncludes f g = Just False + | otherwise = Nothing + +instance + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra fb, + UFB.ERUnitFnBaseIEncl boxb boxra varid b ra fb) + => + FA.ERFnApproxApprox boxra varid ra (ERApproxOI ra) (ERFnIntervalOI fb) + where + evalAA box (ERFnIntervalOIAny _) = + [ERApproxOI (RA.bottomApprox) (RA.topApprox)] + evalAA box (ERFnIntervalOI _ oe ie) = + [ERApproxOI (UFB.evalEncl box oe) (UFB.evalIEncl box ie)] + diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base.hs index 23011c7..cab9b16 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/Base.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base.hs @@ -11,8 +11,8 @@ Stability : experimental Portability : portable - A class abstracting function arithmetic with directed rounding. - It is used to describe a boundary for an approximation + Classes abstracting function arithmetic with directed rounding. + Instances are used to describe a boundary for an approximation to a real function on the interval [-1,1]^n. To be imported qualified, usually with the synonym UFB. @@ -21,8 +21,8 @@ module Data.Number.ER.RnToRm.UnitDom.Base where import Prelude hiding (min, max, recip, const) -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) import Data.Number.ER.BasicTypes import qualified Data.Number.ER.Real.Base as B import qualified Data.Number.ER.Real.Approx as RA @@ -33,7 +33,7 @@ import qualified Data.Map as Map import Data.Typeable -class +class (B.ERRealBase b, RA.ERIntApprox ra, Ord ufb, DomainBox boxb varid b, DomainIntBox boxra varid ra) => ERUnitFnBase boxb boxra varid b ra ufb @@ -135,9 +135,6 @@ class {-| Construct a constant basic function. -} const :: b -> ufb - {-| Construct a constant basic enclosure (negated lower bound, upper bound). -} - constEncl :: (b,b) -> (ufb, ufb) - {-| Construct an affine basic function. -} affine :: b {-^ value at 0 -} -> @@ -151,9 +148,19 @@ class {-| Find an upper bound of a basic function over @[-1,1]^n@. -} + bounds :: EffortIndex -> ufb -> (b,b) + + {-| + Find an upper bound of a basic function over @[-1,1]^n@. + -} upperBound :: EffortIndex -> ufb -> b {-| + Find an upper bound of a basic function over @[-1,1]^n@. + -} + upperBoundPrecise :: EffortIndex -> ufb -> b + + {-| Approximate the function @max(f1,f2)@ from above. -} maxUp :: @@ -171,7 +178,25 @@ class ufb {-^ @f1@ -} -> ufb {-^ @f2@ -} -> ufb - + {-| + Approximate the function @max(f1,f2)@ from below. + -} + maxDown :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + ufb {-^ @f1@ -} -> + ufb {-^ @f2@ -} -> + ufb + {-| + Approximate the function @min(f1,f2)@ from below. + -} + minDown :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + ufb {-^ @f1@ -} -> + ufb {-^ @f2@ -} -> + ufb + {--------------} {----- Field operations ----------} {--------------} @@ -180,6 +205,11 @@ class neg :: ufb -> ufb {-| + Add a scalar to a basic function, rounding upwards. + -} + addConstUp :: b -> ufb -> ufb + + {-| Multiply a basic function by a scalar, rounding upwards. -} scaleUp :: b -> ufb -> ufb @@ -200,34 +230,12 @@ class {-| Pointwise upwards rounded multiplication -} (*^) :: ufb -> ufb -> ufb - {-| Enclosure multiplication - - IMPORTANT: enclosure = (negated lower bound, upper bound) - -} - multiplyEncl :: - Int {-^ maximum polynomial degree -} -> - Int {-^ maximum term count -} -> - (ufb,ufb) -> (ufb,ufb) -> (ufb, ufb) - {-| Approximate the function @1/f@ from above, assuming @f@ does not hit zero in the unit domain. -} recipUp :: Int -> Int -> EffortIndex -> ufb -> ufb - {-| - Approximate the reciprocal of an enclosure, assuming - @f@ does not hit zero in the unit domain. - - IMPORTANT: enclosure = (negated lower bound, upper bound) - -} - recipEncl :: - Int {-^ max degree for result -} -> - Int {-^ max approx size for result -} -> - EffortIndex -> - (ufb,ufb) {-^ enclosure of @f@ -} -> - (ufb,ufb) - {--------------} {----- Evaluation and composition of functions -----} {--------------} @@ -239,6 +247,12 @@ class evalUp :: boxb -> ufb -> b {-| + Evaluate a basic function at a point rounding downwards + using a basic number for both the point and the result. + -} +-- evalDown :: boxb -> ufb -> b + + {-| Safely evaluate a basic function at a point using a real number approximation for both the point and the result. -} @@ -252,7 +266,7 @@ class partialEvalApproxUp :: boxra -> ufb -> ufb {-| - Compose two basic functions, rounding downwards and upwards, + Compose two basic functions, rounding upwards, assuming @f_v@ ranges within the domain @[-1,1]@. -} composeUp :: @@ -266,25 +280,40 @@ class ufb {-^ pointwise upper bound of @f[v |-> f_v]@ -} {-| - Compose two basic functions, rounding downwards and upwards, + Substitute several variables in a basic function with other basic functions, + rounding upwards, assuming each @f_v@ ranges + within the domain @[-1,1]@. + -} + composeManyUp :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + ufb {-^ function @f@ -} -> + Map.Map varid ufb + {-^ variables to substitute and for each variable @v@, + function @f_v@ to substitute for @v@ + that maps @[-1,1]@ into @[-1,1]@ -} -> + ufb {-^ pointwise upper bound of @f[v |-> f_v]@ -} + + {-| + Compose two basic functions, rounding downwards, assuming @f_v@ ranges within the domain @[-1,1]@. -} - composeEncl :: + composeDown :: Int {-^ max degree for result -} -> Int {-^ max approx size for result -} -> ufb {-^ function @f@ -} -> varid {-^ variable @v@ to substitute in @f@ -} -> - (ufb, ufb) - {-^ enclosure of a function @f_v@ to substitute for @v@ + ufb + {-^ function @f_v@ to substitute for @v@ that maps @[-1,1]@ into @[-1,1]@ -} -> - (ufb, ufb) {-^ enclosure of @f[v |-> f_v]@ -} + ufb {-^ pointwise lower bound of @f[v |-> f_v]@ -} {-| Substitute several variables in a basic function with other basic functions, - rounding downwards and upwards, assuming each @f_v@ ranges + rounding downwards, assuming each @f_v@ ranges within the domain @[-1,1]@. -} - composeManyUp :: + composeManyDown :: Int {-^ max degree for result -} -> Int {-^ max approx size for result -} -> ufb {-^ function @f@ -} -> @@ -292,7 +321,136 @@ class {-^ variables to substitute and for each variable @v@, function @f_v@ to substitute for @v@ that maps @[-1,1]@ into @[-1,1]@ -} -> - ufb {-^ pointwise upper bound of @f[v |-> f_v]@ -} + ufb {-^ pointwise lower bound of @f[v |-> f_v]@ -} + + {--------------} + {----- Approximate symbolic integration ----------} + {--------------} + + {-| + Approximate the primitive function of @f@ from below and from above. + -} + integrate :: + varid {-^ variable to integrate by -} -> + ufb {-^ @f@ -} -> + (ufb, ufb) + + {-| + Approximate the derivative of @f@ from below and from above. + -} + differentiate :: + varid {-^ variable to differentiate by -} -> + ufb {-^ @f@ -} -> + (ufb, ufb) + + {-| + Measure the volume between a function + and the zero hyperplane on the domain @[-1,1]^n@. + -} + volumeAboveZeroUp :: + [varid] + {-^ dimensions to include in the measuring domain; + have to include all those present in @f@ -} -> + ufb {-^ @f@ -} -> + b + volumeAboveZeroUp vars p = +-- unsafePrint ("chplVolumeAboveZero: returning:" ++ show result) $ +-- unsafePrint ("chplVolumeAboveZero: vars = " ++ show vars) $ + result + where + result = integUpAtEvenCorners - integDownAtOddCorners + integUpAtEvenCorners = sumUp $ map (\pt -> evalUp pt integUp) evenCorners + integDownAtOddCorners = sumUp $ map (\pt -> evalUp pt integDownNeg) oddCorners + evenCorners = map (DBox.fromList) evenCornersL + oddCorners = map (DBox.fromList) oddCornersL + (evenCornersL, oddCornersL) = + allPairsCombinationsEvenOdd $ zip vars $ repeat (1,-1) + integUp = integrateByAllVars snd p vars + integDownNeg = neg $ integrateByAllVars fst p vars + integrateByAllVars pick p [] = p + integrateByAllVars pick p (x : xs) = + integrateByAllVars pick ip xs + where + ip = pick $ integrate x p + + +class + (ERUnitFnBase boxb boxra varid b ra ufb) => + ERUnitFnBaseEncl boxb boxra varid b ra ufb + | ufb -> boxb boxra varid b ra + where + boundsEncl :: EffortIndex -> (ufb,ufb) -> (b,b) + + {-| Construct a constant basic enclosure (negated lower bound fn, upper bound fn) + from bounds given as coeffients (lower bound, upper bound). -} + constEncl :: (b,b) -> (ufb, ufb) + + evalEncl :: boxra -> (ufb,ufb) -> ra + + evalEnclInner :: boxra -> (ufb,ufb) -> ra + + {-| Enclosure and base constant addition + + IMPORTANT: enclosure = (NEGATED lower bound, upper bound) + -} + addConstEncl :: + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + b -> (ufb,ufb) -> (ufb, ufb) + + {-| Enclosure scaling by a base constant + + IMPORTANT: enclosure = (NEGATED lower bound, upper bound) + -} + scaleEncl :: + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + b -> (ufb,ufb) -> (ufb, ufb) + + {-| Enclosure addition + + IMPORTANT: enclosure = (NEGATED lower bound, upper bound) + -} + addEncl :: + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + (ufb,ufb) -> (ufb,ufb) -> (ufb, ufb) + + {-| Enclosure multiplication + + IMPORTANT: enclosure = (NEGATED lower bound, upper bound) + -} + multiplyEncl :: + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + (ufb,ufb) -> (ufb,ufb) -> (ufb, ufb) + + {-| + Approximate the reciprocal of an enclosure, assuming + @f@ does not hit zero in the unit domain. + + IMPORTANT: enclosure = (negated lower bound, upper bound) + -} + recipEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + EffortIndex -> + (ufb,ufb) {-^ enclosure of @f@ -} -> + (ufb,ufb) + + {-| + Compose two basic functions, rounding downwards and upwards, + assuming @f_v@ ranges within the domain @[-1,1]@. + -} + composeEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + ufb {-^ function @f@ -} -> + varid {-^ variable @v@ to substitute in @f@ -} -> + (ufb, ufb) + {-^ enclosure of a function @f_v@ to substitute for @v@ + that maps @[-1,1]@ into @[-1,1]@ -} -> + (ufb, ufb) {-^ enclosure of @f[v |-> f_v]@ -} {-| Substitute several variables in a basic function with other basic functions, @@ -309,10 +467,12 @@ class that maps @[-1,1]@ into @[-1,1]@ -} -> (ufb, ufb) {-^ enclosure of @f[v |-> f_v]@ -} - {--------------} - {----- Selected elementary operations ----------} - {--------------} - + +class + (ERUnitFnBaseEncl boxb boxra varid b ra ufb) => + ERUnitFnBaseElementary boxb boxra varid b ra ufb + | ufb -> boxb boxra varid b ra + where {-| Approximate @sqrt(f)@ for enclosures. -} @@ -369,47 +529,140 @@ class EffortIndex {-^ how hard to try when approximating cos as a polynomial -} -> (ufb, ufb) {-^ @f@ -} -> (ufb, ufb) - - {--------------} - {----- Approximate symbolic integration ----------} - {--------------} - {-| - Approximate the primitive function of @f@ from below and from above. +class + (ERUnitFnBase boxb boxra varid b ra ufb) => + ERUnitFnBaseIEncl boxb boxra varid b ra ufb + | ufb -> boxb boxra varid b ra + where + {-| Construct a constant basic inner enclosure + (negated lower bound fn, upper bound fn, is enclosure definitely anticonsistent?) + from bounds given as coeffients (lower bound, upper bound). + An inner enclosure @(lnI,hI)@ is anticonsistent + iff @hI + lnI <= 0@, ie upper bound is never above lower bound. -} - integrate :: - varid {-^ variable to integrate by -} -> - ufb {-^ @f@ -} -> - (ufb, ufb) + constIEncl :: (b,b) -> ((ufb, ufb), Bool) + evalIEncl :: boxra -> ((ufb,ufb),Bool) -> ra + {-| + Inner enclosure addition. + -} + addIEncl :: + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + ((ufb, ufb), Bool) -> + ((ufb, ufb), Bool) -> + ((ufb, ufb), Bool) + + {-| + Inner enclosure multiplication. + -} + multiplyIEncl :: + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + ((ufb, ufb), Bool) -> + ((ufb, ufb), Bool) -> + ((ufb, ufb), Bool) + + {-| + Approximate the reciprocal of an inner enclosure, assuming + @f@ is positive in the unit domain. + -} + recipIEnclPositive :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + EffortIndex -> + ((ufb, ufb), Bool) -> + ((ufb, ufb), Bool) + {-| - Measure the volume between a function - and the zero hyperplane on the domain @[-1,1]^n@. + Compose two basic functions, rounding downwards and upwards, + assuming @f_v@ ranges within the domain @[-1,1]@. -} - volumeAboveZeroUp :: - [varid] - {-^ dimensions to include in the measuring domain; - have to include all those present in @f@ -} -> - ufb {-^ @f@ -} -> - b - volumeAboveZeroUp vars p = --- unsafePrint ("chplVolumeAboveZero: returning:" ++ show result) $ --- unsafePrint ("chplVolumeAboveZero: vars = " ++ show vars) $ - result - where - result = integUpAtEvenCorners - integDownAtOddCorners - integUpAtEvenCorners = sumUp $ map (\pt -> evalUp pt integUp) evenCorners - integDownAtOddCorners = sumUp $ map (\pt -> evalUp pt integDownNeg) oddCorners - evenCorners = map (DBox.fromList) evenCornersL - oddCorners = map (DBox.fromList) oddCornersL - (evenCornersL, oddCornersL) = - allPairsCombinationsEvenOdd $ zip vars $ repeat (1,-1) - integUp = integrateByAllVars snd p vars - integDownNeg = neg $ integrateByAllVars fst p vars - integrateByAllVars pick p [] = p - integrateByAllVars pick p (x : xs) = - integrateByAllVars pick ip xs - where - ip = pick $ integrate x p - + composeIEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + ufb {-^ function @f@ -} -> + varid {-^ variable @v@ to substitute in @f@ -} -> + ((ufb, ufb), Bool) + {-^ inverse enclosure of a function @f_v@ to substitute for @v@ + that maps @[-1,1]@ into @[-1,1]@ -} -> + ((ufb, ufb), Bool) {-^ inverse enclosure of @f[v |-> f_v]@ -} + {-| + Substitute several variables in a basic function with other basic functions, + rounding downwards and upwards, assuming each @f_v@ ranges + within the domain @[-1,1]@. + -} + composeManyIEncls :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + ufb {-^ function @f@ -} -> + Map.Map varid ((ufb, ufb), Bool) + {-^ variables to substitute and for each variable @v@ + inverse enclosure of a function @f_v@ to substitute for @v@ + that maps @[-1,1]@ into @[-1,1]@ -} -> + ((ufb, ufb), Bool) {-^ inverse enclosure of @f[v |-> f_v]@ -} + +class + (ERUnitFnBaseIEncl boxb boxra varid b ra ufb) => + ERUnitFnBaseIElementary boxb boxra varid b ra ufb + | ufb -> boxb boxra varid b ra + where + {-| + Approximate @sqrt(f)@ for enclosures. + -} + sqrtIEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + EffortIndex {-^ how hard to try when approximating exp as a polynomial -} -> + ((ufb, ufb), Bool) {-^ @f@ -} -> + ((ufb, ufb), Bool) + {-| + Approximate @exp(f)@ for enclosures. + -} + expIEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + EffortIndex {-^ how hard to try when approximating exp as a polynomial -} -> + ((ufb, ufb), Bool) {-^ @f@ -} -> + ((ufb, ufb), Bool) + {-| + Approximate @log(f)@ for enclosures. + -} + logIEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + EffortIndex {-^ how hard to try when approximating log as a polynomial -} -> + ((ufb, ufb), Bool) {-^ @f@ -} -> + ((ufb, ufb), Bool) + {-| + Approximate @sin(f)@ for enclosures, + assuming the range of @f@ is within @[-pi/2,pi/2]@. + -} + sinIEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + EffortIndex {-^ how hard to try when approximating sin as a polynomial -} -> + ((ufb, ufb), Bool) {-^ @f@ -} -> + ((ufb, ufb), Bool) + {-| + Approximate @cos(f)@ for enclosures, + assuming the range of @f@ is within @[-pi/2,pi/2]@. + -} + cosIEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + EffortIndex {-^ how hard to try when approximating cos as a polynomial -} -> + ((ufb, ufb), Bool) {-^ @f@ -} -> + ((ufb, ufb), Bool) + {-| + Approximate @atan(f)@ for enclosures. + -} + atanIEncl :: + Int {-^ max degree for result -} -> + Int {-^ max approx size for result -} -> + EffortIndex {-^ how hard to try when approximating cos as a polynomial -} -> + ((ufb, ufb), Bool) {-^ @f@ -} -> + ((ufb, ufb), Bool) +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Generate.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Generate.hs new file mode 100644 index 0000000..0c8935b --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Generate.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate + Description : (testing) generating basic functions for testing + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + A collection of basic functions to pick from when testing. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate +( + FBSize10(..), + FBSize10Small(..), + FBSize10Degree3(..), + FBEnclThinSize10(..), + FBEnclThinSize10Small(..), + FBEnclThinSize10Degree3(..), + FBEnclParalSize10(..), + FBEnclParalSize10Small(..), + FBEnclParalSize10Degree3(..), + FBEnclThickSize10(..), + FBEnclThickSize10Small(..), + FBEnclThickSize10Degree3(..), + Deg20Size20(..), + Deg10Size10(..), + Deg5Size10(..), + polynomials1200ishSize10, + polynomials1200ishSize10Small, + polynomials1200ishSize10Degree3, + makeThinEncl, + makeThickEncl, + makeParalEncl +) +where + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB +import Data.Number.ER.RnToRm.UnitDom.Base ((+^),(-^),(*^)) + +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox + +import Data.Number.ER.BasicTypes.Tests.Generate + +import qualified Data.Map as Map + +import Test.QuickCheck + +{---------------------} +{----- Generation of maximum size and degree limits -----} +{---------------------} + +data Deg20Size20 = Deg20Size20 Int Int deriving (Show) +data Deg10Size10 = Deg10Size10 Int Int deriving (Show) +data Deg5Size10 = Deg5Size10 Int Int deriving (Show) + +instance (Arbitrary Deg20Size20) + where + arbitrary = + do + maxDegree <- choose (2,20) + maxSize <- choose (10,20) + return $ Deg20Size20 maxDegree maxSize + coarbitrary (Deg20Size20 maxDegree maxSize) = + error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for Deg20Size20" + +instance (Arbitrary Deg10Size10) + where + arbitrary = + do + maxDegree <- choose (1,10) + maxSize <- choose (5,10) + return $ Deg10Size10 maxDegree maxSize + coarbitrary (Deg10Size10 maxDegree maxSize) = + error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for Deg10Size10" + +instance (Arbitrary Deg5Size10) + where + arbitrary = + do + maxDegree <- choose (1,5) + maxSize <- choose (5,10) + return $ Deg5Size10 maxDegree maxSize + coarbitrary (Deg5Size10 maxDegree maxSize) = + error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for Deg5Size10" + +{---------------------} +{----- Types for different function enclosure generation distributions ----} +{---------------------} + +type E fb = (fb,fb) + +newtype FBEnclThinSize10 fb = FBEnclThinSize10 ((Int, Int), E fb) deriving (Show) +newtype FBEnclThinSize10Small fb = FBEnclThinSize10Small (Int, E fb) deriving (Show) +newtype FBEnclThinSize10Degree3 fb = FBEnclThinSize10Degree3 (Int, E fb) deriving (Show) + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclThinSize10 fb)) + where + arbitrary = + do + (FBSize10 (fbId, fb)) <- arbitrary + return $ FBEnclThinSize10 (fbId, makeThinEncl fb) + coarbitrary (FBEnclThinSize10 p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclThinSize10Small fb)) + where + arbitrary = + do + (FBSize10Small (fbId, fb)) <- arbitrary + return $ FBEnclThinSize10Small (fbId, makeThinEncl fb) + coarbitrary (FBEnclThinSize10Small p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclThinSize10Degree3 fb)) + where + arbitrary = + do + (FBSize10Degree3 (fbId, fb)) <- arbitrary + return $ FBEnclThinSize10Degree3 (fbId, makeThinEncl fb) + coarbitrary (FBEnclThinSize10Degree3 p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +makeThinEncl fb = (UFB.neg fb, fb) + +newtype FBEnclParalSize10 fb = FBEnclParalSize10 (((Int, Int), SmallRatio), E fb) deriving (Show) +newtype FBEnclParalSize10Small fb = FBEnclParalSize10Small ((Int, SmallRatio), E fb) deriving (Show) +newtype FBEnclParalSize10Degree3 fb = FBEnclParalSize10Degree3 ((Int, SmallRatio), E fb) deriving (Show) + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclParalSize10 fb)) + where + arbitrary = + do + (FBSize10 (fbId, fb)) <- arbitrary + rat <- arbitrary + return $ FBEnclParalSize10 ((fbId, rat), makeParalEncl fb rat) + coarbitrary (FBEnclParalSize10 p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclParalSize10Small fb)) + where + arbitrary = + do + (FBSize10Small (fbId, fb)) <- arbitrary + rat <- arbitrary + return $ FBEnclParalSize10Small ((fbId, rat), makeParalEncl fb rat) + coarbitrary (FBEnclParalSize10Small p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclParalSize10Degree3 fb)) + where + arbitrary = + do + (FBSize10Degree3 (fbId, fb)) <- arbitrary + rat <- arbitrary + return $ FBEnclParalSize10Degree3 ((fbId, rat), makeParalEncl fb rat) + coarbitrary (FBEnclParalSize10Degree3 p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +makeParalEncl fb (SmallRatio num denom) = +-- unsafePrintReturn +-- ( +-- "makeThinEncl: result = " +-- ) + (fbNeg, fb +^ cFB) + where + fbNeg = UFB.neg fb + cFB = UFB.const cB + cB = abs $ numB / (1000 * denomB) + numB = fromInteger $ toInteger num + denomB = fromInteger $ toInteger denom + +newtype FBEnclThickSize10 fb = FBEnclThickSize10 (((Int, Int), (Int, Int)), E fb) deriving (Show) +newtype FBEnclThickSize10Small fb = FBEnclThickSize10Small ((Int, Int), E fb) deriving (Show) +newtype FBEnclThickSize10Degree3 fb = FBEnclThickSize10Degree3 ((Int, Int), E fb) deriving (Show) + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclThickSize10 fb)) + where + arbitrary = + do + (FBSize10 (fbId1, fb1)) <- arbitrary + (FBSize10 (fbId2, fb2)) <- arbitrary + return $ FBEnclThickSize10 ((fbId1, fbId2), makeThickEncl 5 10 fb1 fb2) + coarbitrary (FBEnclThickSize10 p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclThickSize10Small fb)) + where + arbitrary = + do + (FBSize10Small (fbId1, fb1)) <- arbitrary + (FBSize10Small (fbId2, fb2)) <- arbitrary + return $ FBEnclThickSize10Small ((fbId1, fbId2), makeThickEncl 5 10 fb1 fb2) + coarbitrary (FBEnclThickSize10Small p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBEnclThickSize10Degree3 fb)) + where + arbitrary = + do + (FBSize10Degree3 (fbId1, fb1)) <- arbitrary + (FBSize10Degree3 (fbId2, fb2)) <- arbitrary + return $ FBEnclThickSize10Degree3 ((fbId1, fbId2), makeThickEncl 5 10 fb1 fb2) + coarbitrary (FBEnclThickSize10Degree3 p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +makeThickEncl maxDegree maxSize p1 p2 = + (pMax q1Neg q2Neg, pMax q1 q2) + where + q1Neg = UFB.neg q1 + q2Neg = UFB.neg q2 + q1 = p1 +^ p2Mp1ScaledDown + q2 = p1 -^ p2Mp1ScaledDown + p2Mp1ScaledDown = + UFB.scaleUp (10/sizeB) p2Mp1 + where + sizeB = max (abs upperB) (abs lowerB) + (lowerB, upperB) = UFB.bounds 10 p2Mp1 + p2Mp1 = p2 -^ p1 + pMax = UFB.maxUp maxDegree maxSize + + +{---------------------} +{----- Types for different function generation distributions ----} +{---------------------} + +newtype FBSize10 fb = FBSize10 ((Int, Int), fb) deriving (Show) +newtype FBSize10Small fb = FBSize10Small (Int, fb) deriving (Show) +newtype FBSize10Degree3 fb = FBSize10Degree3 (Int, fb) deriving (Show) + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBSize10 fb)) + where + arbitrary = + sized arbitrarySized + where + arbitrarySized n + | n <= 28 = + elements $ map FBSize10 $ + zip (map (\n -> (0,n)) [0..]) $ + polynomials1200ishSize10Small $ UFB.const 0 + | otherwise = + elements $ map FBSize10 $ + zip (map (\n -> (1,n)) [0..]) $ + polynomials1200ishSize10 $ UFB.const 0 + coarbitrary (FBSize10 p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBSize10Degree3 fb)) + where + arbitrary = + sized arbitrarySized + where + arbitrarySized n = + elements $ map FBSize10Degree3 $ + zip [0..] $ + polynomials1200ishSize10Degree3 $ UFB.const 0 + coarbitrary (FBSize10Degree3 p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +instance (UFB.ERUnitFnBase boxb boxra varid b ra fb) => (Arbitrary (FBSize10Small fb)) + where + arbitrary = + sized arbitrarySized + where + arbitrarySized n = + elements $ map FBSize10Small $ + zip [0..] $ + polynomials1200ishSize10Small $ UFB.const 0 + coarbitrary (FBSize10Small p) = + error "ER.RnToRm.UnitDom.Base.Tests.Generate: coarbitrary not implemented" + +polynomials1200ishSize10 sample = + polynomials1200ish sample $ UFB.reduceSizeUp 10 + +polynomials1200ishSize10Small sample = + polynomials1200ishSmall sample $ UFB.reduceSizeUp 10 + +polynomials1200ishSize10Degree3 sample = + polynomials1200ish sample $ UFB.reduceSizeUp 10 . UFB.reduceDegreeUp 3 + +polynomials1200ishSmallSize10Degree3 sample = + polynomials1200ishSmall sample $ UFB.reduceSizeUp 10 . UFB.reduceDegreeUp 3 + +polynomials1200ish sample rdc = + polynomials1200ishBoth False sample rdc + +polynomials1200ishSmall sample rdc = + polynomials1200ishBoth True sample rdc + + +{------------------} +{-------- A diverse collection of polynomials to pick from: ----------} +{------------------} + +polynomials1200ishBoth :: + (UFB.ERUnitFnBase boxb boxra varid b ra fb) => + Bool -> fb -> (fb -> fb) -> [fb] +polynomials1200ishBoth isSmall sample rdc + | isSmall = + concat $ map (powers2 rdc) $ + concat $ map addConsts5 $ + concat $ map multConsts5 $ + concat $ map addConsts2 $ + polyBase12 + | otherwise = + concat $ map (powers4 rdc) $ + concat $ map addConsts5 $ + concat $ map multConsts5 $ + polyBase12 + where + _ = [x0,one,sample] -- help type inference + [x0,x1,x2,x3,x4] = map makeVar $ DBox.getNVars 5 + where + makeVar i = UFB.affine 0 (Map.singleton i 1) + [mone, one, two, three, seven, thousand, million, tiny, huge] = + map UFB.const [-1,1,2,3,7,1000,1000000,10^^(-200),10^^200] + polyBase12 = + [ + x0 + , + x0 +^ x1 + , + x0 -^ x1 + , + (two *^ x0) +^ x1 + , + (two *^ x0) -^ x1 + , + (seven *^ x0) +^ x1 + , + (seven *^ x0) -^ x1 + , + (tiny *^ x0) +^ x1 + , + (tiny *^ x0) -^ x1 + , + x0 -^ x1 *^ x2 + , + x0 *^ x1 +^ x2 *^ x3 +^ x4 + , + x0 -^ x1 +^ x2 -^ x3 +^ x4 + ] + powersAll rdc p = + powersAux [p, rdc $ p *^ p] + where + powersAux (pNHalfM1 : pNHalf : rest) = + pNHalfM1 : (powersAux $ (pNHalf : rest) ++ [pNM1, pN]) + where + pNM1 = rdc $ pNHalf *^ pNHalfM1 + pN = rdc $ pNHalf *^ pNHalf + + powersForExps rdc p exponents = + map pw exponents + where + pw n = pws !! (n - 1) + pws = powersAll rdc p + + powers4 rdc p = + powersForExps rdc p [1,2,3,4] + + powers2 rdc p = + powersForExps rdc p [1,2] + + addConsts5 p = + [p, p +^ mone, p +^ three, p +^ seven, p +^ thousand] + + multConsts5 p = + [p, p *^ mone, p *^ two, p *^ three, p *^ seven] + + addConsts2 p = + [p, p +^ mone] +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Bounds.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Bounds.hs new file mode 100644 index 0000000..e5f6d54 --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Bounds.hs @@ -0,0 +1,54 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Bounds + Description : (testing) properties of bounding operations + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Quickcheck properties of bounding operations, ie constant bounds and binary min/max. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Bounds +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB + +import Data.Number.ER.BasicTypes +import Data.Number.ER.BasicTypes.Tests.Generate + +import Test.QuickCheck + +prop_fbBounds_consistent sample reportFileName (Ix20 ix, FBSize10 (n,fb)) = + fbAtKeyPointsCanBeLeq reportFileName (ix,n,True) fb fbHigh + && + fbAtKeyPointsCanBeLeq reportFileName (ix,n,False) fbLow fb + where + _ = [fb,sample] + fbLow = UFB.const cLow + fbHigh = UFB.const cHigh + (cLow, cHigh) = UFB.bounds ix fb + +prop_fbMax_consistent sample reportFileName + (Deg20Size20 maxDegree maxSize, FBSize10 (n1,fb1), FBSize10 (n2, fb2)) = + fbAtKeyPointsPointwiseBinaryDownUpConsistent + reportFileName ((maxDegree, maxSize), n1, n2) + max fb1 fb2 (maxLow, maxHigh) + where + _ = [fb1,sample] + maxLow = UFB.maxDown maxDegree maxSize fb1 fb2 + maxHigh = UFB.maxUp maxDegree maxSize fb1 fb2 + +prop_fbMin_consistent sample reportFileName + (Deg20Size20 maxDegree maxSize, FBSize10 (n1,fb1), FBSize10 (n2, fb2)) = + fbAtKeyPointsPointwiseBinaryDownUpConsistent + reportFileName ((maxDegree, maxSize), n1, n2) + min fb1 fb2 (minLow, minHigh) + where + _ = [fb1,sample] + minLow = UFB.minDown maxDegree maxSize fb1 fb2 + minHigh = UFB.minUp maxDegree maxSize fb1 fb2 diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Common.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Common.hs new file mode 100644 index 0000000..0ba662a --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Common.hs @@ -0,0 +1,276 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common + Description : (testing) generating polynomials for tests + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Auxiliary functions for use in test for polynomial enclosure arithmetic. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB +import Data.Number.ER.RnToRm.UnitDom.Base ((+^),(-^),(*^)) + +import Data.Number.ER.Real.Approx.Tests.Reporting + +import qualified Data.Number.ER.Real.Base as B +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import Data.Number.ER.Misc + +import qualified Data.Number.ER.Real.Approx as RA + +fbAtKeyPointsCanBeLeq :: + (UFB.ERUnitFnBase boxb boxra varid b ra fb, Show boxra, Show testId) => + String {-^ report file name -} -> + testId {-^ item to identify the random input given to the test -} -> + fb -> + fb -> + Bool +fbAtKeyPointsCanBeLeq reportFileName testId fb1 fb2 = + and $ map testPoint points + where + points = getKeyPoints (fb1 +^ fb2) + testPoint point + | lower1 <= upper2 = + unsafeERTestReport reportFileName + (testId, point, val1, val2) $ + True + | otherwise = + unsafePrint + ( + "Failure at point = " ++ (show point) + ) $ + False + where + val1 = UFB.evalApprox point fb1 + val2 = UFB.evalApprox point fb2 + (lower1, upper1) = UFB.raEndpoints fb1 val1 + (lower2, upper2) = UFB.raEndpoints fb1 val2 + +getKeyPoints fb = + getKeyPointsForVars $ UFB.getVariables fb + +getKeyPointsForVars vars = + points + where + points = map DBox.fromList $ allCombinations $ varDomPoints + varDomPoints = map (\v -> (v,[-1,0,1])) vars + +fbAtKeyPointsPointwiseBinaryDownUpConsistent :: + (UFB.ERUnitFnBase boxb boxra varid b ra fb, Show boxra, Show testId) => + String {-^ report file name -} -> + testId {-^ item to identify the random input given to the test -} -> + (ra -> ra -> ra) -> + fb -> fb -> + (fb, fb) -> + Bool +fbAtKeyPointsPointwiseBinaryDownUpConsistent reportFileName testId raOp fb1 fb2 (resLow, resHigh) = + and $ map testPoint points + where + points = getKeyPoints (fb1 +^ fb2) + testPoint point + | ok = + unsafeERTestReport reportFileName + (testId, point, raOpAtPoint, resAtPoint) $ + True + | otherwise = + unsafePrint + ( + "fbAtKeyPointsPointwiseBinaryDownUpConsistent failed:" + ++ "\n point = " ++ show point + ++ "\n raOpAtPoint = " ++ show raOpAtPoint + ++ "\n resAtPoint = " ++ show resAtPoint + ) + False + where + ok = not $ RA.isDisjoint resAtPoint raOpAtPoint + resAtPoint = valLow RA.\/ valHigh + resAtPointLow = fst $ UFB.raEndpoints fb1 $ valLow + resAtPointHigh = snd $ UFB.raEndpoints fb1 $ valHigh + valLow = UFB.evalApprox point resLow + valHigh = UFB.evalApprox point resHigh + + raOpAtPoint= raOp fb1AtPoint fb2AtPoint + fb1AtPoint = UFB.evalApprox point fb1 + fb2AtPoint = UFB.evalApprox point fb2 + + +enclRestrictRange ix md ms (Nothing, Nothing) preEncl = (True, preEncl) +enclRestrictRange ix md ms (maybeLower, maybeUpper) preEncl = + (succeeded, fbEncl) + where + succeeded = lowerSucceeded && upperSucceeded + lowerSucceeded = + case maybeLower of + Nothing -> True + Just lower -> lower < pLowerBound + upperSucceeded = + case maybeUpper of + Nothing -> True + Just upper -> pUpperBound < upper + (pLowerBound, pUpperBound) = UFB.boundsEncl ix fbEncl + fbEncl = + case (maybeLower, maybeUpper) of + (Just lowerB, Nothing) -> + case lowerB < preLowerBoundB of + True -> preEncl -- enclosure already in the range + False -> -- a shift needed to get above the lower bound + UFB.addEncl md ms (b2encl $ lowerB - preLowerBoundB + sepB) preEncl + (Nothing, Just upperB) -> + case preUpperBoundB < upperB of + True -> preEncl -- enclosure already in the range + False -> -- a shift needed to get below the upper bound + UFB.addEncl md ms (b2encl $ upperB - preUpperBoundB - sepB) preEncl + (Just lowerB, Just upperB) -> + case lowerB < preLowerBoundB && preUpperBoundB < upperB of + True -> preEncl -- enclosure already in the range + _ -> + case preWidthB + sepB <= widthB of + True -> -- no scaling needed, only shifting by a constant to the centre of the range + UFB.addEncl md ms + (b2encl $ lowerB - preLowerBoundB + (preWidthB - widthB)/2) + preEncl + _ -> -- full affine transformation needed + UFB.addEncl md ms + (b2encl $ lowerB + sepB) $ + UFB.multiplyEncl md ms -- scale preEncl so that it fits inside the range + (b2encl $ widthB / saferPreWidthB) $ + UFB.addEncl md ms -- shift preEncl so that it is non-negative and as close to 0 as safely possible + (b2encl $ sepB - preLowerBoundB) + preEncl + where + widthB = upperB - lowerB + saferPreWidthB = preWidthB + 2 * sepB + sepB = preWidthB / 1000000 + preWidthB = preUpperBoundB - preLowerBoundB + (preLowerBoundB, preUpperBoundB) = UFB.boundsEncl ix preEncl + +b2encl b = UFB.constEncl (b,b) + +enclAtKeyPointsPointwiseBinaryInnerInOuter :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra fb, Show boxra, Show testId) => + String {-^ report file name -} -> + testId {-^ item to identify the random input given to the test -} -> + (ra -> ra -> ra) + {-^ this real approx operation has to return an *inner* approximation of the exact result set, + ie each number that the approximation supports is in the maximal extension -} -> + (fb, fb) {-^ enclosure of argument 1 -} -> + (fb, fb) {-^ enclosure of argument 2 -} -> + (fb, fb) {-^ alleged enclosure of result -} -> + Bool +enclAtKeyPointsPointwiseBinaryInnerInOuter + reportFileName testId + raOpInner + p1Encl@(p1LowNeg, p1High) p2Encl@(p2LowNeg, p2High) resEncl = + and $ map testPoint points + where + points = getKeyPoints (p1High +^ p2High +^ p1LowNeg +^ p2LowNeg) + testPoint point + | result = + unsafeERTestReport reportFileName + (testId, point, p1OpInnerP2AtPoint, resAtPoint) $ + result + | otherwise = + unsafePrint + ( + "enclAtKeyPointsPointwiseBinaryInnerInOuter failed" + ++ "\n point = " ++ show point + ++ "\n p1AtPoint = " ++ show p1AtPoint + ++ "\n p2AtPoint = " ++ show p2AtPoint + ++ "\n p1OpInnerP2AtPoint = " ++ show p1OpInnerP2AtPoint + ++ "\n resAtPoint = " ++ show resAtPoint + ) $ + result + where + result = p1OpInnerP2AtPoint `RA.refines` resAtPoint + p1OpInnerP2AtPoint = p1AtPoint `raOpInner` p2AtPoint + resAtPoint = UFB.evalEncl point resEncl +-- resAtPoint = p1OpInnerP2AtPoint -- for dummy testing that never <<loop>>s + p1AtPoint = UFB.evalEnclInner point p1Encl + p2AtPoint = UFB.evalEnclInner point p2Encl + +enclAtKeyPointsPointwiseUnaryInnerInOuter :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra fb, Show boxra, Show testId) => + String {-^ report file name -} -> + testId {-^ item to identify the random input given to the test -} -> + (ra -> ra) + {-^ this real approx operation has to return an inner approximation of the exact result set, + ie each number that the approximation supports is in the maximal extension -} -> + (fb, fb) {-^ enclosure of argument -} -> + (fb, fb) {-^ alleged enclosure of result -} -> + Bool +enclAtKeyPointsPointwiseUnaryInnerInOuter + reportFileName testId + raOpInner + fbEncl@(pLowNeg, pHigh) resEncl = + and $ map testPoint points + where + points = getKeyPoints (pHigh +^ pLowNeg) + testPoint point + | result = + unsafeERTestReport reportFileName + (testId, point, opInnerPAtPoint, resAtPoint) $ + result + | otherwise = + unsafePrint + ( + "enclAtKeyPointsPointwiseUnaryInnerInOuter failed" + ++ "\n point = " ++ show point + ++ "\n pAtPoint = " ++ show pAtPoint + ++ "\n opInnerPAtPoint = " ++ show opInnerPAtPoint + ++ "\n resAtPoint = " ++ show resAtPoint + ) $ + result + where + result = opInnerPAtPoint `RA.refines` resAtPoint + opInnerPAtPoint = raOpInner pAtPoint + resAtPoint = UFB.evalEncl point resEncl + pAtPoint = +-- normaliseERInterval $ + UFB.evalEnclInner point fbEncl + + +enclAtKeyPointsConsistent :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra fb, Show boxra, Show testId) => + String {-^ report file name -} -> + testId {-^ item to identify the random input given to the test -} -> + (boxra -> ra) + {-^ this operation has to return an inner approximation of the exact result set, + ie each number that the approximation supports is a solution in the maximal extension -} -> + [varid] {-^ variables to test over -} -> + (fb, fb) {-^ alleged enclosure of result -} -> + Bool +enclAtKeyPointsConsistent + reportFileName testId + opInner allVars resEncl@(resLowNeg, resHigh) = + and $ map testPoint points + where + points = getKeyPointsForVars allVars + testPoint point + | result = + unsafeERTestReport reportFileName + (testId, point, opInnerAtPoint, resAtPoint) $ + result + | otherwise = + unsafePrint + ( + "enclAtKeyPointsConsistent failed" + ++ "\n point = " ++ show point + ++ "\n opInnerAtPoint = " ++ show opInnerAtPoint + ++ "\n resAtPoint = " ++ show resAtPoint + ) $ + result + where + result = opInnerAtPoint `RA.refines` resAtPoint + opInnerAtPoint = opInner point + resAtPoint = UFB.evalEncl point resEncl + +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Compose.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Compose.hs new file mode 100644 index 0000000..d7f2c16 --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Compose.hs @@ -0,0 +1,121 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Compose + Description : (testing) properties of enclosure composition + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Quickcheck properties of polynomial enclosure composition. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Compose +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate + +import qualified Data.Number.ER.Real.Approx as RA +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox + +import Data.Number.ER.BasicTypes +import Data.Number.ER.BasicTypes.Tests.Generate + +import Data.Number.ER.Misc + +import Test.QuickCheck + +prop_enclCompose_ThinEncl_consistent + sampleE reportFileName + (Deg10Size10 maxDegree maxSize, + varSelector, + (FBEnclThinSize10 (n1,e1)), + (FBEnclThinSize10 (n2,e2))) = + compose_encl_consistent + sampleE reportFileName + maxDegree maxSize + varSelector + n1 e1 n2 e2 + +prop_enclCompose_ThickEncl_consistent + sampleE reportFileName + (Deg10Size10 maxDegree maxSize, + varSelector, + (FBEnclThinSize10 (n1,e1)), + (FBEnclThickSize10 (n2,e2))) = + compose_encl_consistent + sampleE reportFileName + maxDegree maxSize + varSelector + n1 e1 n2 e2 + +prop_enclCompose_ParalEncl_consistent + sampleE reportFileName + (Deg10Size10 maxDegree maxSize, + varSelector, + (FBEnclThinSize10 (n1, e1)), + (FBEnclParalSize10 (n2,e2))) = + compose_encl_consistent + sampleE reportFileName + maxDegree maxSize + varSelector + n1 e1 n2 e2 + +compose_encl_consistent + sampleE reportFileName + maxDegree maxSize + varSelector + e1Id e1@(e1LowNeg, e1High) e2Id e2@(e2LowNeg, e2High) = +-- unsafePrint +-- ( +-- "compose_encl_consistent: " +-- ++ "\n e1High = " ++ show e1High +-- ++ "\n substVar = " ++ show substVar +-- ++ "\n e2High = " ++ show e2High +-- ++ "\n e2Low = " ++ show (UFB.neg e2LowNeg) +-- ++ "\n composition = " ++ show resEncl +-- ++ "\n**********************" +-- ) $ + enclAtKeyPointsConsistent + reportFileName + ((maxDegree, maxSize), varSelector, e1Id, e2Id) + composeAtPointInner + allVars + resEncl + where + _ = [sampleE,e1] + resEncl = UFB.composeEncl maxDegree maxSize e1High substVar e2 + substVar = e1Vars !! (varSelector `mod` (length e1Vars)) + e1Vars = UFB.getVariables e1High + allVars = + UFB.getVariables $ + e1High UFB.+^ e2High UFB.+^ e2Low + where + e2Low = UFB.neg e2LowNeg + composeAtPointInner point = +-- unsafePrintReturn +-- ( +-- "\n point = " ++ show point +-- ++ "\n substVar = " ++ show substVar +-- ++ " substVal = " ++ show substVal +-- ++ "\n result = " +-- ) $ + result + where + result + | RA.isConsistent substVal = + UFB.evalEnclInner pointWithSubst (UFB.neg e1High, e1High) + | otherwise = + RA.toggleConsistency $ + UFB.evalEncl pointWithSubstReversed (UFB.neg e1High, e1High) + pointWithSubstReversed = + DBox.insert substVar (RA.toggleConsistency substVal) point + pointWithSubst = + DBox.insert substVar substVal point + substVal = + UFB.evalEnclInner point e2 + +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Division.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Division.hs new file mode 100644 index 0000000..07fc905 --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Division.hs @@ -0,0 +1,88 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Division + Description : (testing) properties of polynomial enclosure division + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Quickcheck properties of polynomial enclosure division. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Division +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate + +import qualified Data.Number.ER.Real.Approx as RA +import Data.Number.ER.Real.Approx.Interval + +import Data.Number.ER.BasicTypes +import Data.Number.ER.BasicTypes.Tests.Generate + +import Test.QuickCheck + +prop_enclRecip_ThickEncl_consistent + sampleE reportFileName + (Deg5Size10 maxDegree maxSize, + Ix10 ix, + SmallRatio sepNum sepDenom, + (isNegative, FBEnclThickSize10Small (n,preEncl))) = + recip_encl_consistent + sampleE reportFileName + maxDegree maxSize + ix + sepNum sepDenom isNegative n preEncl + +prop_enclRecip_ParalEncl_consistent + sampleE reportFileName + (Deg5Size10 maxDegree maxSize, + Ix10 ix, + SmallRatio sepNum sepDenom, + (isNegative, FBEnclParalSize10Small (n,preEncl))) = + recip_encl_consistent + sampleE reportFileName + maxDegree maxSize + ix + sepNum sepDenom isNegative n preEncl + +prop_enclRecip_ThinEncl_consistent + sampleE reportFileName + (Deg5Size10 maxDegree maxSize, + Ix10 ix, + SmallRatio sepNum sepDenom, + (isNegative, FBEnclThinSize10Small (n,preEncl))) = + recip_encl_consistent + sampleE reportFileName + maxDegree maxSize + ix + sepNum sepDenom isNegative n preEncl + +recip_encl_consistent + sampleE reportFileName + maxDegree maxSize + ix + sepNum sepDenom isNegative pId preEncl = + excludedZero ==> + enclAtKeyPointsPointwiseUnaryInnerInOuter + reportFileName + ((maxDegree, maxSize), ix, (sepNum, sepDenom), (isNegative, pId)) + ((RA./:) 1) + pEncl resEncl + where + _ = [sampleE, pEncl] + resEncl = UFB.recipEncl maxDegree maxSize ix pEncl + (excludedZero, pEncl) = + enclRestrictRange ix maxDegree maxSize rangeNoZero preEncl + rangeNoZero + | isNegative = (Nothing, Just (-sepB)) + | otherwise = (Just sepB, Nothing) + sepB = abs sepNumB / sepDenomB + sepNumB = fromInteger $ toInteger sepNum + sepDenomB = fromInteger $ toInteger sepDenom + +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Elementary.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Elementary.hs new file mode 100644 index 0000000..68a3b43 --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Elementary.hs @@ -0,0 +1,140 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Elementary + Description : (testing) properties of enclosure elementary operations + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Quickcheck properties of some elementary operations on primitive polynomial + enclosures. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Elementary +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate + +import qualified Data.Number.ER.Real.Approx as RA +import qualified Data.Number.ER.Real.Base as B +import Data.Number.ER.Real.Arithmetic.Elementary + +import Data.Number.ER.BasicTypes +import Data.Number.ER.BasicTypes.Tests.Generate + +import Test.QuickCheck + +prop_enclSqrt_ThickEncl_consistent sampleE = + encl_op_ThickEncl_consistent sampleE UFB.sqrtEncl erSqrt_IR_Inner positiveDomain + +prop_enclSqrt_ParalEncl_consistent sampleE = + encl_op_ParalEncl_consistent sampleE UFB.sqrtEncl erSqrt_IR_Inner positiveDomain + +prop_enclSqrt_ThinEncl_consistent sampleE = + encl_op_ThinEncl_consistent sampleE UFB.sqrtEncl erSqrt_IR_Inner positiveDomain + + +prop_enclExp_ThickEncl_consistent sampleE = + encl_op_ThickEncl_consistent sampleE UFB.expEncl erExp_IR_Inner noDomainRestriction + +prop_enclExp_ParalEncl_consistent sampleE = + encl_op_ParalEncl_consistent sampleE UFB.expEncl erExp_IR_Inner noDomainRestriction + +prop_enclExp_ThinEncl_consistent sampleE = + encl_op_ThinEncl_consistent sampleE UFB.expEncl erExp_IR_Inner noDomainRestriction + +prop_enclSine_ThickEncl_consistent sampleE = + encl_op_ThickEncl_consistent sampleE UFB.sinEncl erSine_IR_Inner sincosDomain + +prop_enclSine_ParalEncl_consistent sampleE = + encl_op_ParalEncl_consistent sampleE UFB.sinEncl erSine_IR_Inner sincosDomain + +prop_enclSine_ThinEncl_consistent sampleE = + encl_op_ThinEncl_consistent sampleE UFB.sinEncl erSine_IR_Inner sincosDomain + +prop_enclCosine_ThickEncl_consistent sampleE = + encl_op_ThickEncl_consistent sampleE UFB.cosEncl erCosine_IR_Inner sincosDomain + +prop_enclCosine_ParalEncl_consistent sampleE = + encl_op_ParalEncl_consistent sampleE UFB.cosEncl erCosine_IR_Inner sincosDomain + +prop_enclCosine_ThinEncl_consistent sampleE = + encl_op_ThinEncl_consistent sampleE UFB.cosEncl erCosine_IR_Inner sincosDomain + +prop_enclAtan_ThickEncl_consistent sampleE = + encl_op_ThickEncl_consistent sampleE UFB.atanEncl erATan_IR_Inner noDomainRestriction + +prop_enclAtan_ParalEncl_consistent sampleE = + encl_op_ParalEncl_consistent sampleE UFB.atanEncl erATan_IR_Inner noDomainRestriction + +prop_enclAtan_ThinEncl_consistent sampleE = + encl_op_ThinEncl_consistent sampleE UFB.atanEncl erATan_IR_Inner noDomainRestriction + +sincosDomain :: (B.ERRealBase b) => (Maybe b, Maybe b) +sincosDomain = (Just (-1.57), Just 1.57) -- almost (-pi/2, pi/2) + +noDomainRestriction :: (B.ERRealBase b) => (Maybe b, Maybe b) +noDomainRestriction = (Nothing, Nothing) + +positiveDomain :: (B.ERRealBase b) => (Maybe b, Maybe b) +positiveDomain = (Just 0, Nothing) + +encl_op_ThickEncl_consistent + sampleE + opEncl opInner rangeRestriction + reportFileName + (Deg5Size10 maxDegree maxSize, + (Ix10 ix), + (FBEnclThickSize10Degree3 (n,preE))) = + enclAtKeyPointsPointwiseUnaryInnerInOuter + reportFileName + ((maxDegree, maxSize), ix, n) + (opInner ix) + e resEncl + where + _ = [sampleE, preE] + (succeeded, e) = + enclRestrictRange ix maxDegree maxSize rangeRestriction preE + resEncl = opEncl maxDegree maxSize ix e + +encl_op_ParalEncl_consistent + sampleE + opEncl opInner rangeRestriction + reportFileName + (Deg5Size10 maxDegree maxSize, + (Ix10 ix), + (FBEnclParalSize10Degree3 (n,preE))) = + enclAtKeyPointsPointwiseUnaryInnerInOuter + reportFileName + ((maxDegree, maxSize), ix, n) + (opInner ix) + e resEncl + where + _ = [sampleE, preE] + (succeeded, e) = + enclRestrictRange ix maxDegree maxSize rangeRestriction preE + resEncl = opEncl maxDegree maxSize ix e + +encl_op_ThinEncl_consistent + sampleE + opEncl opInner rangeRestriction + reportFileName + (Deg5Size10 maxDegree maxSize, + (Ix10 ix), + (FBEnclThinSize10Degree3 (n,preE))) = + enclAtKeyPointsPointwiseUnaryInnerInOuter + reportFileName + ((maxDegree, maxSize), ix, n) + (opInner ix) + e resEncl + where + _ = [sampleE, preE] + (succeeded, e) = + enclRestrictRange ix maxDegree maxSize rangeRestriction preE + resEncl = opEncl maxDegree maxSize ix e + +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Enclosure.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Enclosure.hs new file mode 100644 index 0000000..ed06db8 --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Enclosure.hs @@ -0,0 +1,176 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Enclosure + Description : (testing) properties of basic enclosure operations + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Quickcheck properties of basic enclosure operations, + mainly ring operations. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Enclosure +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB + +import Data.Number.ER.BasicTypes.Tests.Generate + +import qualified Data.Number.ER.Real.Approx as RA + +{--- addition ----} + +prop_enclAdd_ThickEncls_consistent :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra t, Show boxra, RA.ERInnerOuterApprox ra) => + (t,t) -> String -> (Deg5Size10, (FBEnclThickSize10 t, FBEnclThickSize10 t)) -> + Bool +prop_enclAdd_ThickEncls_consistent = + prop_binary_ThickEncls_consistent (RA.+:) UFB.addEncl + + +prop_enclAdd_ParalEncls_consistent :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra t, Show boxra, RA.ERInnerOuterApprox ra) => + (t,t) -> String -> (Deg5Size10, (FBEnclParalSize10 t, FBEnclParalSize10 t)) -> + Bool +prop_enclAdd_ParalEncls_consistent = + prop_binary_ParalEncls_consistent (RA.+:) UFB.addEncl + + +prop_enclAdd_ThinEncls_consistent :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra t, Show boxra, RA.ERInnerOuterApprox ra) => + (t,t) -> String -> (Deg5Size10, (FBEnclThinSize10 t, FBEnclThinSize10 t)) -> + Bool +prop_enclAdd_ThinEncls_consistent = + prop_binary_ThinEncls_consistent (RA.+:) UFB.addEncl + +{--- multiplication ----} + +prop_enclMult_ThickEncls_consistent :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra t, Show boxra, RA.ERInnerOuterApprox ra) => + (t,t) -> String -> (Deg5Size10, (FBEnclThickSize10 t, FBEnclThickSize10 t)) -> + Bool +prop_enclMult_ThickEncls_consistent = + prop_binary_ThickEncls_consistent (RA.*:) UFB.multiplyEncl + + +prop_enclMult_ParalEncls_consistent :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra t, Show boxra, RA.ERInnerOuterApprox ra) => + (t,t) -> String -> (Deg5Size10, (FBEnclParalSize10 t, FBEnclParalSize10 t)) -> + Bool +prop_enclMult_ParalEncls_consistent = + prop_binary_ParalEncls_consistent (RA.*:) UFB.multiplyEncl + + +prop_enclMult_ThinEncls_consistent :: + (UFB.ERUnitFnBaseEncl boxb boxra varid b ra t, Show boxra, RA.ERInnerOuterApprox ra) => + (t,t) -> String -> (Deg5Size10, (FBEnclThinSize10 t, FBEnclThinSize10 t)) -> + Bool +prop_enclMult_ThinEncls_consistent = + prop_binary_ThinEncls_consistent (RA.*:) UFB.multiplyEncl + +{--- scaling ----} + +prop_enclScale_ThickEncl_consistent + sampleE reportFileName + (Deg10Size10 maxDegree maxSize, + SmallRatio num denom, + FBEnclThickSize10 (n, e)) = + enclAtKeyPointsPointwiseBinaryInnerInOuter + reportFileName + ((maxDegree, maxSize), (num, denom), n) + (RA.*:) + cEncl e scaledEncl + where + _ = [e,sampleE] + scaledEncl = UFB.scaleEncl maxDegree maxSize cB e + cEncl = UFB.constEncl (cB,cB) + cB = numB / denomB + numB = fromInteger $ toInteger num + denomB = fromInteger $ toInteger denom + +prop_enclScale_ParalEncl_consistent + sampleE reportFileName + (Deg10Size10 maxDegree maxSize, + SmallRatio num denom, + FBEnclParalSize10 (n, e)) = + enclAtKeyPointsPointwiseBinaryInnerInOuter + reportFileName + ((maxDegree, maxSize), (num, denom), n) + (RA.*:) + cEncl e scaledEncl + where + _ = [e,sampleE] + scaledEncl = UFB.scaleEncl maxDegree maxSize cB e + cEncl = UFB.constEncl (cB,cB) + cB = numB / denomB + numB = fromInteger $ toInteger num + denomB = fromInteger $ toInteger denom + +prop_enclScale_ThinEncl_consistent + sampleE reportFileName + (Deg10Size10 maxDegree maxSize, + SmallRatio num denom, + FBEnclThinSize10 (n, e)) = + enclAtKeyPointsPointwiseBinaryInnerInOuter + reportFileName + ((maxDegree, maxSize), (num, denom), n) + (RA.*:) + cEncl e scaledEncl + where + _ = [e,sampleE] + scaledEncl = UFB.scaleEncl maxDegree maxSize cB e + cEncl = UFB.constEncl (cB,cB) + cB = numB / denomB + numB = fromInteger $ toInteger num + denomB = fromInteger $ toInteger denom + +prop_binary_ThickEncls_consistent + opInner opEncl + sampleE reportFileName + (Deg5Size10 maxDegree maxSize, + (FBEnclThickSize10 (n1,e1), + FBEnclThickSize10 (n2,e2))) = + enclAtKeyPointsPointwiseBinaryInnerInOuter + reportFileName + ((maxDegree, maxSize), (n1, n2)) + opInner + e1 e2 resE + where + _ = [sampleE, e1] + resE = opEncl maxDegree maxSize e1 e2 + +prop_binary_ParalEncls_consistent + opInner opEncl + sampleE reportFileName + (Deg5Size10 maxDegree maxSize, + (FBEnclParalSize10 (n1,e1), + FBEnclParalSize10 (n2,e2))) = + enclAtKeyPointsPointwiseBinaryInnerInOuter + reportFileName + ((maxDegree, maxSize), (n1, n2)) + opInner + e1 e2 sumE + where + _ = [sampleE, e1] + sumE = opEncl maxDegree maxSize e1 e2 + +prop_binary_ThinEncls_consistent + opInner opEncl + sampleE reportFileName + (Deg5Size10 maxDegree maxSize, + (FBEnclThinSize10 (n1,e1), + FBEnclThinSize10 (n2,e2))) = + enclAtKeyPointsPointwiseBinaryInnerInOuter + reportFileName + ((maxDegree, maxSize), (n1, n2)) + opInner + e1 e2 sumE + where + _ = [sampleE, e1] + sumE = opEncl maxDegree maxSize e1 e2 + diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Integration.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Integration.hs new file mode 100644 index 0000000..108f3dc --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Integration.hs @@ -0,0 +1,49 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Integration + Description : (testing) properties of ring operations + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Quickcheck properties for checking that polynomial intergration + is consistent with polynomial differentiation. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Integration +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB + +import Data.Number.ER.BasicTypes.Tests.Generate + + +prop_fbIntegrateDiffUp_consistent sample reportFileName + (FBSize10 (n1,fb1), Nat10 varSelector) = + fbAtKeyPointsCanBeLeq + reportFileName (n1,var) + fb1 fb1ID + where + _ = [fb1,sample] + fb1ID = snd $ UFB.differentiate var fb1I + fb1I = snd $ UFB.integrate var fb1 + + var = vars !! (varSelector `mod` (length vars)) + vars = UFB.getVariables fb1 + +prop_fbIntegrateDiffDown_consistent sample reportFileName + (FBSize10 (n1,fb1), Nat10 varSelector) = + fbAtKeyPointsCanBeLeq + reportFileName (n1,var) + fb1ID fb1 + where + _ = [fb1,sample] + fb1ID = fst $ UFB.differentiate var fb1I + fb1I = fst $ UFB.integrate var fb1 + + var = vars !! (varSelector `mod` (length vars)) + vars = UFB.getVariables fb1 diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Reduce.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Reduce.hs new file mode 100644 index 0000000..44f76e0 --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Reduce.hs @@ -0,0 +1,44 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Reduce + Description : (testing) properties of reduction operations + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Quickcheck properties of operations that reduce the size of polynomials. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Reduce +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB + + +import Test.QuickCheck + +prop_fbReduceTermCount_consistent sample reportFileName + (FBSize10 (n,fb), Deg5Size10 _ maxSize) = + maxSize < UFB.getSize fb ==> + fbAtKeyPointsCanBeLeq reportFileName (n, maxSize, True) fb fbUp + && + fbAtKeyPointsCanBeLeq reportFileName (n, maxSize, False) fbDown fb + where + _ = [fb,sample] + fbUp = UFB.reduceSizeUp maxSize fb + fbDown = UFB.neg $ UFB.reduceSizeUp maxSize $ UFB.neg fb + +prop_fbReduceDegree_consistent sample reportFileName + (FBSize10 (n,fb), Deg5Size10 maxDegree _) = + maxDegree < UFB.getDegree fb ==> + fbAtKeyPointsCanBeLeq reportFileName (n, maxDegree, True) fb fbUp + && + fbAtKeyPointsCanBeLeq reportFileName (n, maxDegree, False) fbDown fb + where + _ = [fb,sample] + fbUp = UFB.reduceDegreeUp maxDegree fb + fbDown = UFB.neg $ UFB.reduceDegreeUp maxDegree $ UFB.neg fb diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Ring.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Ring.hs new file mode 100644 index 0000000..a1f74ed --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Properties/Ring.hs @@ -0,0 +1,70 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Ring + Description : (testing) properties of ring operations + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Quickcheck properties of ring operations, ie addition and multiplication. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Ring +where + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB + +import Data.Number.ER.BasicTypes.Tests.Generate + +prop_fbAddConst_consistent sample reportFileName + (SmallRatio num denom, FBSize10 (n, fb)) = + fbAtKeyPointsPointwiseBinaryDownUpConsistent + reportFileName ((num, denom), n) + (+) cFB fb (sumLow, sumHigh) + where + _ = [fb,sample] + sumHigh = UFB.addConstUp cB fb + sumLow = UFB.neg $ UFB.addConstUp (-cB) (UFB.neg fb) + cFB = UFB.const cB + cB = numB / denomB + numB = fromInteger $ toInteger num + denomB = fromInteger $ toInteger denom + +prop_fbScale_consistent sample reportFileName + (SmallRatio num denom, FBSize10 (n, fb)) = + fbAtKeyPointsPointwiseBinaryDownUpConsistent + reportFileName ((num, denom), n) + (*) cP fb (prodLow, prodHigh) + where + _ = [fb,sample] + prodHigh = UFB.scaleUp cB fb + prodLow = UFB.neg $ UFB.scaleUp (-cB) fb + cP = UFB.const cB + cB = numB / denomB + numB = fromInteger $ toInteger num + denomB = fromInteger $ toInteger denom + +prop_fbAdd_consistent sample reportFileName + (FBSize10 (n1,fb1), FBSize10 (n2, fb2)) = + fbAtKeyPointsPointwiseBinaryDownUpConsistent + reportFileName (n1,n2) + (+) fb1 fb2 (sumLow, sumHigh) + where + _ = [fb1,sample] + sumLow = UFB.neg $ (UFB.neg fb1) UFB.+^ (UFB.neg fb2) + sumHigh = fb1 UFB.+^ fb2 + +prop_fbMult_consistent sample reportFileName + (FBSize10 (n1,fb1), FBSize10 (n2, fb2)) = + fbAtKeyPointsPointwiseBinaryDownUpConsistent + reportFileName (n1,n2) + (*) fb1 fb2 (prodLow, prodHigh) + where + _ = [fb1,sample] + prodHigh = fb1 UFB.*^ fb2 + prodLow = UFB.neg $ (UFB.neg fb1) UFB.*^ fb2 + diff --git a/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Run.hs b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Run.hs new file mode 100644 index 0000000..73e24ab --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/Base/Tests/Run.hs @@ -0,0 +1,134 @@ +{-| + Module : Data.Number.ER.RnToRm.UnitDom.BaseTests.Run + Description : (testing) running all function enclosure base tests in a batch + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Support for running all function enclosure base tests in a batch. +-} +module Data.Number.ER.RnToRm.UnitDom.Base.Tests.Run +where + +import Data.Number.ER.Real.Approx.Tests.Reporting + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Reduce +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Bounds +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Ring +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Integration +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Enclosure +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Division +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Compose +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Elementary + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB +import qualified Data.Number.ER.Real.Approx as RA + +import Data.Number.ER.Misc.Tests +import Data.Number.ER.Misc + +import Test.QuickCheck +import Test.QuickCheck.Batch + +import System.Directory +import qualified System.FilePath as FP +import Data.Time.Clock +import Data.Time.Calendar + +runUFBTests :: + (UFB.ERUnitFnBaseElementary boxb boxra varid b ra fb, + UFB.ERUnitFnBaseIElementary boxb boxra varid b ra fb, + RA.ERInnerOuterApprox ra, + Ord ra, Show fb, Show boxra, Show varid) => + String -> fb -> IO () -> IO () +runUFBTests title sample initialise = + do + (UTCTime (ModifiedJulianDay days) secs) <- getCurrentTime + let folder = "tests-" ++ title ++ "-" ++ (show days) ++ "-" ++ (show $ floor $ toRational secs) + createDirectory folder +-- erRunTests (title ++ " ufb tests") ufbTestOptions initialise (ufbTests sample folder) + erRunTests (title ++ " ufb encl tests") ufbTestOptions initialise (ufbEnclTests (sample,sample) folder) + +ufbTestOptions = + TestOptions + { +-- no_of_tests = 10 +-- no_of_tests = 50 + no_of_tests = 200 +-- no_of_tests = 500 + , + length_of_tests = 240 * 3600 -- ie 4h time limit + , + debug_tests = False + } + +ufbTests sample folder = + [ + ("reduce term count", runR (prop_fbReduceTermCount_consistent sample) "reduceSize"), + ("reduce degree", runR (prop_fbReduceDegree_consistent sample) "reduceDegree"), + ("bounds of poly", runR (prop_fbBounds_consistent sample) "bounds"), + ("max of two functions", runR (prop_fbMax_consistent sample) "max"), + ("min of two functions", runR (prop_fbMin_consistent sample) "min"), + ("add const to poly", runR (prop_fbAddConst_consistent sample) "addConst"), + ("scale poly", runR (prop_fbScale_consistent sample) "scale"), + ("add two polys", runR (prop_fbAdd_consistent sample) "add"), + ("mult two polys", runR (prop_fbMult_consistent sample) "mult"), + ("integrate + diff up", runR (prop_fbIntegrateDiffUp_consistent sample) "integrateDiffUp"), + ("integrate + diff down", runR (prop_fbIntegrateDiffDown_consistent sample) "integrateDiffDown") + ] + where + runR test filename opts = + unsafeReport filepath "started" $ + do + run (test filepath) opts + where + filepath = addFolder filename + addFolder name = FP.combine folder name + +ufbEnclTests sampleE folder = + [ + ("add thick encls", runR (prop_enclAdd_ThickEncls_consistent sampleE) "enclAdd_Thick"), + ("add paral encls", runR (prop_enclAdd_ParalEncls_consistent sampleE) "enclAdd_Paral"), + ("add thin encls", runR (prop_enclAdd_ThinEncls_consistent sampleE) "enclAdd_Thin"), + ("scale thick encl", runR (prop_enclScale_ThickEncl_consistent sampleE) "enclScale_Thick"), + ("scale paral encl", runR (prop_enclScale_ParalEncl_consistent sampleE) "enclScale_Paral"), + ("scale thin encl", runR (prop_enclScale_ThinEncl_consistent sampleE) "enclScale_Thin"), + ("mult thick encls", runR (prop_enclMult_ThickEncls_consistent sampleE) "enclMultiply_Thick"), + ("mult paral encls", runR (prop_enclMult_ParalEncls_consistent sampleE) "enclMultiply_Paral"), + ("mult thin encls", runR (prop_enclMult_ThinEncls_consistent sampleE) "enclMultiply_Thin"), + ("recip thick encl", runR (prop_enclRecip_ThickEncl_consistent sampleE) "enclRecip_Thick"), + ("recip paral encl", runR (prop_enclRecip_ParalEncl_consistent sampleE) "enclRecip_Paral"), + ("recip thin encl", runR (prop_enclRecip_ThinEncl_consistent sampleE) "enclRecip_Thin"), + ("compose thick encl", runR (prop_enclCompose_ThickEncl_consistent sampleE) "enclCompose_Thick"), + ("compose paral encl", runR (prop_enclCompose_ParalEncl_consistent sampleE) "enclCompose_Paral"), + ("compose thin encl", runR (prop_enclCompose_ThinEncl_consistent sampleE) "enclCompose_Thin"), + ("sqrt thin encl", runR (prop_enclSqrt_ThinEncl_consistent sampleE) "enclSqrt_Thin"), + ("sqrt paral encl", runR (prop_enclSqrt_ParalEncl_consistent sampleE) "enclSqrt_Paral"), + ("sqrt thick encl", runR (prop_enclSqrt_ThickEncl_consistent sampleE) "enclSqrt_Thick"), + ("exp thin encl", runR (prop_enclExp_ThinEncl_consistent sampleE) "enclExp_Thin"), + ("exp paral encl", runR (prop_enclExp_ParalEncl_consistent sampleE) "enclExp_Paral"), + ("exp thick encl", runR (prop_enclExp_ThickEncl_consistent sampleE) "enclExp_Thick"), + ("sine thin encl", runR (prop_enclSine_ThinEncl_consistent sampleE) "enclSine_Thin"), + ("sine paral encl", runR (prop_enclSine_ParalEncl_consistent sampleE) "enclSine_Paral"), + ("sine thick encl", runR (prop_enclSine_ThickEncl_consistent sampleE) "enclSine_Thick"), + ("cosine thin encl", runR (prop_enclCosine_ThinEncl_consistent sampleE) "enclCosine_Thin"), + ("cosine paral encl", runR (prop_enclCosine_ParalEncl_consistent sampleE) "enclCosine_Paral"), + ("cosine thick encl", runR (prop_enclCosine_ThickEncl_consistent sampleE) "enclCosine_Thick"), + ("atan thin encl", runR (prop_enclAtan_ThinEncl_consistent sampleE) "enclAtan_Thin"), + ("atan paral encl", runR (prop_enclAtan_ParalEncl_consistent sampleE) "enclAtan_Paral"), + ("atan thick encl", runR (prop_enclAtan_ThickEncl_consistent sampleE) "enclAtan_Thick") + ] + where + runR test filename opts = + unsafeReport filepath "started" $ + do + result <- run (test filepath) opts + produceSummary filepath + return result + where + filepath = FP.combine folder filename + diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom.hs index 1d1ba9f..115830c 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom.hs @@ -3,7 +3,7 @@ {-# LANGUAGE UndecidableInstances #-} {-| Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom - Description : multivariate polynomials in the Chebyshev basis + Description : polynoms in the Chebyshev basis of the 1st kind Copyright : (c) 2007-2008 Michal Konecny License : BSD3 @@ -29,23 +29,28 @@ import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Derivative import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.EnclosureInner import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Compose import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Integration +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Derivative import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Division +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.DivisionInner import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Elementary +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.ElementaryInner import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB import qualified Data.Number.ER.Real.Base as B import Data.Number.ER.Real.Approx.Interval -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) import qualified Data.Map as Map {- code for testing purpose, to be deleted later -} import Data.Number.ER.Real.DefaultRepr -import Data.Number.ER.Real.DomainBox.IntMap +import Data.Number.ER.BasicTypes.DomainBox.IntMap type P = ERChebPoly (Box Int) B x0 = chplVar 0 :: P x1 = chplVar 1 :: P @@ -53,11 +58,26 @@ x2 = chplVar 2 :: P x3 = chplVar 3 :: P x4 = chplVar 4 :: P p1 = x1 *^ x1 *^ x1 +^ x1 *^ (x2 +^ (chplConst 2)) *^ (x3 -^ (chplConst 3)) + +e23 = enclRAConst (ERInterval 2 3) :: (P,P) +e32 = enclRAConst (ERInterval 3 2) :: (P,P) +em12 = enclRAConst (ERInterval (-1) 2) :: (P,P) +e2m1 = enclRAConst (ERInterval 2 (-1)) :: (P,P) +ex0 = enclThin x0 +ex0sq = enclMultiply 3 10 ex0 ex0 +ep = enclAdd 3 10 (enclConst 2) (enclAdd 3 10 ex0 ex0sq) + +i23 = ienclRAConst (ERInterval 2 3) :: ((P,P),Bool) +i32 = ienclRAConst (ERInterval 3 2) :: ((P,P),Bool) +im12 = ienclRAConst (ERInterval (-1) 2) :: ((P,P),Bool) +i2m1 = ienclRAConst (ERInterval 2 (-1)) :: ((P,P),Bool) +ix0 = ienclThin x0 + {- end of code for testing purposes -} instance (B.ERRealBase rb, RealFrac rb, - DomainBox box varid Int, Ord box, + DomainBox box varid Int, Ord box, Show varid, DomainBoxMappable boxb boxras varid rb [ERInterval rb], DomainBoxMappable boxra boxras varid (ERInterval rb) [ERInterval rb], DomainIntBox boxra varid (ERInterval rb)) => @@ -65,8 +85,7 @@ instance where {----- Miscellaneous associated operations -----} raEndpoints _ (ERInterval l h) = (l,h) - raEndpoints _ ERIntervalAny = (- B.plusInfinity, B.plusInfinity) - raFromEndpoints _ (l,h) = normaliseERInterval (ERInterval l h) + raFromEndpoints _ (l,h) = ERInterval l h compareApprox = chplCompareApprox showDiGrCmp = chplShow @@ -84,45 +103,107 @@ instance {----- Construction of basic functions -----} const = chplConst - constEncl (low, high) = (chplConst (-low), chplConst high) affine = chplAffine - {----- Pointwise order operations ----------} + {----- Pointwise order operations ----------} + bounds = chplBounds upperBound = chplUpperBound + upperBoundPrecise = chplUpperBoundExpensive maxUp = chplMaxUp minUp = chplMinUp + maxDown = chplMaxDn + minDown = chplMinDn {----- Field operations ----------} neg = chplNeg + addConstUp = chplAddConstUp scaleUp = chplScaleUp scaleApproxUp = chplScaleRAUp (+^) = (+^) (-^) = (-^) (*^) = (*^) - multiplyEncl = enclMultiply recipUp md mt ix f = snd $ enclRecip md mt ix (md + 1) (chplNeg f, f) - recipEncl md mt ix = enclRecip md mt ix (md + 1) {----- Evaluation and composition of functions -----} evalUp pt f = chplEvalUp f pt +-- evalDown pt f = chplEvalDown f pt evalApprox x ufb = chplRAEval (\ b -> ERInterval b b) ufb x partialEvalApproxUp substitutions ufb = snd $ chplPartialRAEval (UFB.raEndpoints ufb) ufb substitutions composeUp m n f v fv = snd $ enclCompose m n f v (enclThin fv) - composeEncl = enclCompose composeManyUp m n f subst = snd $ enclComposeMany m n f (Map.map enclThin subst) + composeDown m n f v fv = chplNeg $ fst $ enclCompose m n f v (enclThin fv) + composeManyDown m n f subst = chplNeg $ fst $ enclComposeMany m n f (Map.map enclThin subst) + + integrate = chplIntegrate + differentiate var fb = chplDifferentiate fb var + +instance + (B.ERRealBase rb, RealFrac rb, + DomainBox box varid Int, Ord box, Show varid, + DomainBoxMappable boxb boxras varid rb [ERInterval rb], + DomainBoxMappable boxra boxras varid (ERInterval rb) [ERInterval rb], + DomainIntBox boxra varid (ERInterval rb)) => + (UFB.ERUnitFnBaseEncl boxb boxra varid rb (ERInterval rb) (ERChebPoly box rb)) + where + boundsEncl = enclBounds + constEncl (low, high) = (chplConst (-low), chplConst high) + evalEncl pt encl = enclRAEval encl pt + evalEnclInner pt encl = enclRAEvalInner encl pt + addConstEncl _ _ = enclAddConst + scaleEncl = enclScale + addEncl = enclAdd + multiplyEncl = enclMultiply + recipEncl md mt ix = enclRecip md mt ix (md + 1) + composeEncl = enclCompose composeManyEncls = enclComposeMany - {----- Selected elementary operations ----------} - sqrtEncl = enclSqrt +instance + (B.ERRealBase rb, RealFrac rb, + DomainBox box varid Int, Ord box, Show varid, + DomainBoxMappable boxb boxras varid rb [ERInterval rb], + DomainBoxMappable boxra boxras varid (ERInterval rb) [ERInterval rb], + DomainIntBox boxra varid (ERInterval rb)) => + (UFB.ERUnitFnBaseIEncl boxb boxra varid rb (ERInterval rb) (ERChebPoly box rb)) + where + constIEncl (low, high) = ((chplConst (-low), chplConst high), low >= high) + evalIEncl pt ie = ienclRAEval ie pt + addIEncl = ienclAdd + multiplyIEncl = ienclMultiply + recipIEnclPositive md mt ix = ienclRecipPositive md mt ix (md + 1) + composeIEncl = error "ERChebPoly: composeIEncl not yet" -- ienclCompose + composeManyIEncls = error "ERChebPoly: composeManyIEncls not yet" -- ienclComposeMany + +instance + (B.ERRealBase rb, RealFrac rb, + DomainBox box varid Int, Ord box, Show varid, + DomainBoxMappable boxb boxras varid rb [ERInterval rb], + DomainBoxMappable boxra boxras varid (ERInterval rb) [ERInterval rb], + DomainIntBox boxra varid (ERInterval rb)) => + (UFB.ERUnitFnBaseElementary boxb boxra varid rb (ERInterval rb) (ERChebPoly box rb)) + where + sqrtEncl md ms ix = enclSqrt md ms ix md expEncl = enclExp logEncl = enclLog sinEncl = enclSine cosEncl = enclCosine atanEncl = enclAtan - - integrate = chplIntegrate - +instance + (B.ERRealBase rb, RealFrac rb, + DomainBox box varid Int, Ord box, Show varid, + DomainBoxMappable boxb boxras varid rb [ERInterval rb], + DomainBoxMappable boxra boxras varid (ERInterval rb) [ERInterval rb], + DomainIntBox boxra varid (ERInterval rb)) => + (UFB.ERUnitFnBaseIElementary boxb boxra varid rb (ERInterval rb) (ERChebPoly box rb)) + where + sqrtIEncl md ms ix = ienclSqrt md ms ix md +-- error "ERChebPoly: sqrtIEncl not yet" + expIEncl = error "ERChebPoly: expIEncl not yet" -- ienclExp + logIEncl = error "ERChebPoly: logIEncl not yet" -- ienclLog + sinIEncl = error "ERChebPoly: sinIEncl not yet" -- ienclSine + cosIEncl = error "ERChebPoly: cosIEncl not yet" -- ienclCosine + atanIEncl = error "ERChebPoly: atanIEncl not yet" -- ienclAtan +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Basic.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Basic.hs index 6135ee4..bde96fa 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Basic.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Basic.hs @@ -20,8 +20,8 @@ module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic where import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) import Data.Number.ER.Misc import qualified Data.Map as Map @@ -110,11 +110,10 @@ chplGetConst :: (ERChebPoly box b) -> Maybe b chplGetConst (ERChebPoly coeffs) = - case Map.keys coeffs of - [key] | chplIsConstTermKey key -> - Just $ head $ Map.elems coeffs + case Map.toList coeffs of + [] -> Just 0 + [(key,val)] | chplIsConstTermKey key -> Just val _ -> Nothing - -- chplGetArity = length . chplGetVars diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Bounds.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Bounds.hs index 3e9b949..ce2bb2e 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Bounds.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Bounds.hs @@ -20,13 +20,14 @@ import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Derivative import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Base as B import Data.Number.ER.Real.Approx.Interval import Data.Number.ER.Real.Arithmetic.LinearSolver -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc @@ -37,9 +38,15 @@ import Data.List {-| Find an upper bound on a polynomial over the unit domain [-1,1]^n. + + Quick method that does not converge to exact result with increasing + effort index. -} chplUpperBound :: - (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => EffortIndex {-^ how hard to try -} -> ERChebPoly box b -> b @@ -48,9 +55,15 @@ chplUpperBound ix p = snd $ chplBounds ix p {-| Find a lower bound on a polynomial over the unit domain [-1,1]^n. + + Quick method that does not converge to exact result with increasing + effort index. -} chplLowerBound :: - (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => EffortIndex {-^ how hard to try -} -> ERChebPoly box b -> b @@ -59,13 +72,68 @@ chplLowerBound ix p = fst $ chplBounds ix p {-| Find both lower and upper bounds on a polynomial over the unit domain [-1,1]^n. + + Quick method that does not converge to exact result with increasing + effort index. -} chplBounds :: - (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => + EffortIndex {-^ how hard to try -} -> + ERChebPoly box b -> + (b,b) +chplBounds = + chplBoundsAffine + +{-| + Find an upper bound on a polynomial over the + unit domain [-1,1]^n. +-} +chplUpperBoundExpensive :: + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => + EffortIndex {-^ how hard to try -} -> + ERChebPoly box b -> + b +chplUpperBoundExpensive ix p = snd $ chplBoundsExpensive ix p + +{-| + Find a lower bound on a polynomial over the + unit domain [-1,1]^n. + + Quick method that does not converge to exact result with increasing + effort index. +-} +chplLowerBoundExpensive :: + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => + EffortIndex {-^ how hard to try -} -> + ERChebPoly box b -> + b +chplLowerBoundExpensive ix p = fst $ chplBoundsExpensive ix p + +{-| + Find both lower and upper bounds on a polynomial over the + unit domain [-1,1]^n. + + Quick method that does not converge to exact result with increasing + effort index. +-} +chplBoundsExpensive :: + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => EffortIndex {-^ how hard to try -} -> ERChebPoly box b -> (b,b) -chplBounds = chplBoundsAffine +chplBoundsExpensive = chplBoundsByDerivative {-| Find bounds on a polynomial over the unit domain [-1,1]^n. @@ -95,116 +163,253 @@ chplBoundsAffine ix p@(ERChebPoly coeffs) = absCoeffs = Map.map abs $ Map.delete chplConstTermKey coeffs constTerm = Map.findWithDefault 0 chplConstTermKey coeffs -{-| - Find a close upper bound on a quadratic polynomial over the - unit domain [-1,1]^n. - Much slower and somewhat more accurate method, in essence - taking the maximum of the upper quadratic reduction. +{-| + Find a close upper bound of a polynomial over the + unit domain [-1,1]^n. - !!! Not yet properly tested !!! + Approximates all local extrema and computes their maximum. -} -chplUpperBoundQuadr :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box, - DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b], - DomainBoxMappable boxra boxra varid (ERInterval b) (ERInterval b), - DomainIntBox boxra varid (ERInterval b), Num varid, Enum varid) => +chplBoundsByDerivative :: + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => EffortIndex {-^ how hard to try looking for peaks -} -> ERChebPoly box b -> - b -chplUpperBoundQuadr ix p@(ERChebPoly coeffs) = - quadBound (coeffsQ, vars) + (b,b) +chplBoundsByDerivative ix p = +-- unsafePrint +-- ( +-- "chplBoundsByDerivative: " +-- ++ "\n extremaValues = " ++ show extremaValues +-- ) $ + (lowerBound, upperBound) where - pQ@(ERChebPoly coeffsQ) = chplReduceDegreeUp 2 p - vars = chplGetVars pQ - quadBound (coeffs, vars) - | null vars = - Map.findWithDefault 0 chplConstTermKey coeffs - | hasInteriorPeak = - foldl max peakValue edgeBounds + lowerBound = foldl1 min $ map fst extremaValues + upperBound = foldl1 max $ map snd extremaValues + ra2bb (ERInterval l r) = (l,r) + b2ra b = ERInterval b b + extremaValues = + collectValuesOnFaces vars varDerivatives (p,p) + where + vars = chplGetVars p + varDerivatives = -- var |-> (lower, upper) bounds on partial derivative + Map.fromList $ + map getDerivatives vars + getDerivatives var = + (var, + chplBall2DownUp $ + ballDifferentiate p var) + collectValuesOnFaces varsSpecialise varDerivatives (pDown, pUp) = +-- unsafePrint +-- ( +-- "chplBoundsByDerivative: collectValuesOnFaces: " +-- ++ "\n vars = " ++ (show $ Map.keys varDerivatives) +-- ++ "\n valuesThisFace = " ++ show valuesThisFace +-- ) $ + valuesThisFace ++ (valuesSubFaces varsSpecialise) + where + valuesThisFace = + collectExtremeValues varDerivatives (pDown, pUp) + valuesSubFaces [] = [] + valuesSubFaces (var : vars) = + (collectValuesOnFaces vars varDerivativesNoVarL (pDownNoVarL, pUpNoVarL)) + ++ + (collectValuesOnFaces vars varDerivativesNoVarR (pDownNoVarR, pUpNoVarR)) + ++ + (valuesSubFaces vars) + where + (pDownNoVarR, pUpNoVarR) = substVarR (pDown, pUp) + (pDownNoVarL, pUpNoVarL) = substVarL (pDown, pUp) + substVarL = substVar (-1) + substVarR = substVar 1 + substVar val (pDown, pUp) = + (fst $ chplPartialRAEval ra2bb pDown $ DBox.singleton var val, + snd $ chplPartialRAEval ra2bb pUp $ DBox.singleton var val) + varDerivativesNoVarL = + Map.map substVarL varDerivativesNoVar + varDerivativesNoVarR = + Map.map substVarR varDerivativesNoVar + varDerivativesNoVar = + Map.delete var varDerivatives + collectExtremeValues varDerivatives (pDown, pUp) + | null varsNoConst = +-- unsafePrint +-- ( +-- "chplBoundsByDerivative: collectExtremeValues:" +-- ++ "\n null varsNoConst" +-- ++ "\n varDerivatives = " ++ show varDerivatives +-- ) + -- corner or near constant function + [pEvalAt unitDomBox] | otherwise = - foldl1 max edgeBounds +-- unsafePrint +-- ( +-- "chplBoundsByDerivative: collectExtremeValues:" +-- ++ "\n varDerivatives = " ++ show varDerivatives +-- ++ "\n boxesWithPotentialExtrema = " ++ show boxesWithPotentialExtrema +-- ) $ + map pEvalAt boxesWithPotentialExtrema where - edgeBounds = - map quadBound $ concat $ map removeVar vars - (hasInteriorPeak, peakValue) = - case maybePeak of - Just peak -> - (noPositiveSquare -- if any term x^2 has a positive coeff, there is no peak - && - (and $ map maybeInUnit $ DBox.elems peak) - , - erintv_right $ - chplRAEval makeInterval p peak - ) - Nothing -> (False, undefined) + boxesWithPotentialExtrema = + paveFindBoxes [(unitDomBox,0)] + varDerivativesNoZeros = + Map.filter (not . isConstWithZero) varDerivatives where - noPositiveSquare = - and $ map (<= 0) $ map getQuadCoeff vars - getQuadCoeff var = - Map.findWithDefault 0 (DBox.singleton var 2) coeffs - maybeInUnit r = - case (RA.compareReals r (-1), RA.compareReals (1) r) of - (Just LT, _) -> False -- ie r < -1 - (_, Just LT) -> False -- ie r > 1 - _ -> True - maybePeak = - linearSolver - (map derivZeroLinearEq vars) - (DBox.fromList $ map (\v -> (v,(-1) RA.\/ 1)) vars) - (2^^(-ix)) + isConstWithZero (pDown, pUp) = + (snd $ chplBoundsAffine ix pDown) <= 0 + && + (fst $ chplBoundsAffine ix pUp) >= 0 +-- case (chplGetConst pDown, chplGetConst pUp) of +-- (Just cDown, Just cUp) -> +-- cDown <= 0 && cUp >= 0 +-- _ -> False + vars = Map.keys varDerivatives + varsNoConst = Map.keys varDerivativesNoZeros + varsNoConstLength = length varsNoConst + pEvalAt = evalAt (pDown, pUp) + evalAt (pDown,pUp) box = + (fst $ ra2bb $ chplRAEval b2ra pDown box, + snd $ ra2bb $ chplRAEval b2ra pUp box) + unitDomBox = + DBox.fromList $ zip vars (repeat unitInterval) + unitInterval = ((-1) RA.\/ 1) + maxDepth = fromInteger $ toInteger $ max 3 ix + keepBox box = + and $ map evalDeriv $ Map.elems varDerivativesNoZeros where - derivZeroLinearEq var = - (linCoeffs, - constCoeff) - where - constCoeff = - makeInterval $ - Map.findWithDefault 0 (DBox.singleton var 1) coeffs - -- recall T_1(x) = x, T_1'(x) = 1 - linCoeffs = - DBox.fromList $ - (var, 4 * quadCoeff) -- T_2(x) = 2*x^2 - 1; T_2'(x) = 4*x - : (map getVarVarCoeff $ var `delete` vars) - quadCoeff = - makeInterval $ - Map.findWithDefault 0 (DBox.singleton var 2) coeffs - getVarVarCoeff var2 = - (var2, - makeInterval $ - Map.findWithDefault 0 (DBox.fromList [(var,1), (var2,1)]) coeffs) - makeInterval b = ERInterval b b - removeVar var = - [(substVar True, newVars), - (substVar False, newVars)] + evalDeriv derivBounds = hasZero $ evalAt derivBounds box + hasZero (l,h) = l <= 0 && h >= 0 + paveFindBoxes [] = [] + paveFindBoxes boxes@((box, depth) : boxesRest) + | keepBox box = + case depth < maxDepth of + True -> + paveFindBoxes ((boxL, newDepth) : (boxR, newDepth) : boxesRest) + False -> + box : (paveFindBoxes boxesRest) + | otherwise = + paveFindBoxes boxesRest where - newVars = var `delete` vars - substVar isOne = - chplCoeffs $ - foldl (+^) (chplConst 0) $ - map (makeMonomial isOne) $ - Map.toList coeffs - makeMonomial isOne (term, coeff) = - ERChebPoly $ Map.fromList $ - case (DBox.toList term) of - [(v,2)] | v == var -> - [(chplConstTermKey, coeff)] - [(v,1)] | v == var -> - [(chplConstTermKey, - case isOne of True -> coeff; False -> - coeff)] - [(v1,1), (v2,1)] | v1 == var -> - [(DBox.fromList [(v2,1)], - case isOne of True -> coeff; False -> - coeff)] - [(v1,1), (v2,1)] | v2 == var -> - [(DBox.fromList [(v1,1)], - case isOne of True -> coeff; False -> - coeff)] - _ -> - [(term, coeff)] + var = varsNoConst !! (depth `mod` varsNoConstLength) + (boxL, boxR) = DBox.split box var Nothing + newDepth = depth + 1 + + +--{-| +-- Find a close upper bound on a quadratic polynomial over the +-- unit domain [-1,1]^n. +-- +-- Much slower and somewhat more accurate method, in essence +-- taking the maximum of the upper quadratic reduction. +-- +-- !!! Not properly tested !!! +---} +--chplUpperBoundQuadr :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box, +-- DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b], +-- DomainBoxMappable boxra boxra varid (ERInterval b) (ERInterval b), +-- DomainIntBox boxra varid (ERInterval b), Num varid, Enum varid) => +-- EffortIndex {-^ how hard to try looking for peaks -} -> +-- ERChebPoly box b -> +-- b +--chplUpperBoundQuadr ix p@(ERChebPoly coeffs) = +-- quadBound (coeffsQ, vars) +-- where +-- pQ@(ERChebPoly coeffsQ) = chplReduceDegreeUp 2 p +-- vars = chplGetVars pQ +-- quadBound (coeffs, vars) +-- | null vars = +-- Map.findWithDefault 0 chplConstTermKey coeffs +-- | hasInteriorPeak = +-- foldl max peakValue edgeBounds +-- | otherwise = +-- foldl1 max edgeBounds +-- where +-- edgeBounds = +-- map quadBound $ concat $ map removeVar vars +-- (hasInteriorPeak, peakValue) = +-- case maybePeak of +-- Just peak -> +-- (noPositiveSquare -- if any term x^2 has a positive coeff, there is no peak +-- && +-- (and $ map maybeInUnit $ DBox.elems peak) +-- , +-- erintv_right $ +-- chplRAEval makeInterval p peak +-- ) +-- Nothing -> (False, undefined) +-- where +-- noPositiveSquare = +-- and $ map (<= 0) $ map getQuadCoeff vars +-- getQuadCoeff var = +-- Map.findWithDefault 0 (DBox.singleton var 2) coeffs +-- maybeInUnit r = +-- case (RA.compareReals r (-1), RA.compareReals (1) r) of +-- (Just LT, _) -> False -- ie r < -1 +-- (_, Just LT) -> False -- ie r > 1 +-- _ -> True +-- maybePeak = +-- linearSolver +-- (map derivZeroLinearEq vars) +-- (DBox.fromList $ map (\v -> (v,(-1) RA.\/ 1)) vars) +-- (2^^(-ix)) +-- where +-- derivZeroLinearEq var = +-- (linCoeffs, - constCoeff) +-- where +-- constCoeff = +-- makeInterval $ +-- Map.findWithDefault 0 (DBox.singleton var 1) coeffs +-- -- recall T_1(x) = x, T_1'(x) = 1 +-- linCoeffs = +-- DBox.fromList $ +-- (var, 4 * quadCoeff) -- T_2(x) = 2*x^2 - 1; T_2'(x) = 4*x +-- : (map getVarVarCoeff $ var `delete` vars) +-- quadCoeff = +-- makeInterval $ +-- Map.findWithDefault 0 (DBox.singleton var 2) coeffs +-- getVarVarCoeff var2 = +-- (var2, +-- makeInterval $ +-- Map.findWithDefault 0 (DBox.fromList [(var,1), (var2,1)]) coeffs) +-- makeInterval b = ERInterval b b +-- removeVar var = +-- [(substVar True, newVars), +-- (substVar False, newVars)] +-- where +-- newVars = var `delete` vars +-- substVar isOne = +-- chplCoeffs $ +-- foldl (+^) (chplConst 0) $ +-- map (makeMonomial isOne) $ +-- Map.toList coeffs +-- makeMonomial isOne (term, coeff) = +-- ERChebPoly $ Map.fromList $ +-- case (DBox.toList term) of +-- [(v,2)] | v == var -> +-- [(chplConstTermKey, coeff)] +-- [(v,1)] | v == var -> +-- [(chplConstTermKey, +-- case isOne of True -> coeff; False -> - coeff)] +-- [(v1,1), (v2,1)] | v1 == var -> +-- [(DBox.fromList [(v2,1)], +-- case isOne of True -> coeff; False -> - coeff)] +-- [(v1,1), (v2,1)] | v2 == var -> +-- [(DBox.fromList [(v1,1)], +-- case isOne of True -> coeff; False -> - coeff)] +-- _ -> +-- [(term, coeff)] {-| Approximate from below and from above the pointwise maximum of two polynomials -} chplMax :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> ERChebPoly box b -> @@ -215,7 +420,7 @@ chplMax maxDegree maxSize p1 p2 = where (differenceDown, _) = chplNonneg maxDegree maxSize p2MinusP1Down (_, differenceUp) = chplNonneg maxDegree maxSize $ p2MinusP1Up - (p2MinusP1Down, p2MinusP1Up, _) = chplAdd p2 (chplNeg p1) + (p2MinusP1Down, p2MinusP1Up) = chplBall2DownUp $ ballAdd p2 (chplNeg p1) chplMaxDn m s a b = fst $ chplMax m s a b chplMaxUp m s a b = snd $ chplMax m s a b @@ -226,7 +431,10 @@ chplMinUp m s a b = snd $ chplMin m s a b Approximate from below and from above the pointwise minimum of two polynomials -} chplMin :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> ERChebPoly box b -> @@ -252,7 +460,10 @@ chplNonpos m s p = and from above. -} chplNonneg :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> ERChebPoly box b -> @@ -263,7 +474,10 @@ chplNonneg = chplNonnegCubic A version of 'chplNonneg' using a cubic approximation. -} chplNonnegCubic :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> ERChebPoly box b -> @@ -271,7 +485,7 @@ chplNonnegCubic :: chplNonnegCubic maxDegree maxSize p | upperB <= 0 = (chplConst 0, chplConst 0) | lowerB >= 0 = (p, p) - | not allInterimsBounded = (chplConst (1/0), chplConst (1/0)) + | not allInterimsBounded = (chplConst (B.plusInfinity), chplConst (B.plusInfinity)) | otherwise = -- ie lowerB < 0 < upperB: polynomial may be crossing 0... -- unsafePrintReturn -- ( @@ -319,13 +533,13 @@ chplNonnegCubic maxDegree maxSize p addConsts (lo, hi, wd) (cLo, cHi) = (alo, ahi, wd + wdlo + wdhi) where - (alo, _, wdlo) = chplAddConst cLo lo - (_, ahi, wdhi) = chplAddConst cHi hi + (alo, _, wdlo) = chplBall2DownUpWd $ ballAddConst cLo lo + (_, ahi, wdhi) = chplBall2DownUpWd $ ballAddConst cHi hi scaleByPositiveConsts (lo, hi, wd) (cLo, cHi) = (slo, shi, wd + wdlo + wdhi) where - (slo, _, wdlo) = chplScale cLo lo - (_, shi, wdhi) = chplScale cHi hi + (slo, _, wdlo) = chplBall2DownUpWd $ ballScale cLo lo + (_, shi, wdhi) = chplBall2DownUpWd $ ballScale cHi hi -- convert interval coefficients to pairs of bounds: ERInterval rbLo rbHi = rb @@ -394,26 +608,28 @@ chplNonnegCubic maxDegree maxSize p valueAt0B = case a0 / b of ERInterval lo hi -> hi - ERIntervalAny -> 1/0 {-| Multiply a polynomial by an enclosure (with non-negated lower bound). -} chplTimesLoHi :: - (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => ERChebPoly box b -> (ERChebPoly box b, ERChebPoly box b, b) -> (ERChebPoly box b, ERChebPoly box b, b) chplTimesLoHi p1 (p2Low, p2High, p2Width) = (prodMid -. (chplConst width), - prodMid +^ (chplConst width), + prodMid +^ (chplConst width), 2 * width) where prodMid = prodLowUp (prodLowDown, prodLowUp, prodLowWidth) = - chplMultiply p1 p2Low + chplBall2DownUpWd $ ballMultiply p1 p2Low (prodHighDown, prodHighUp, prodHighWidth) = - chplMultiply p1 p2High + chplBall2DownUpWd $ ballMultiply p1 p2High width = p1Norm `timesUp` p2Width `plusUp` prodLowWidth `plusUp` prodHighWidth p1Norm = diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Compose.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Compose.hs index 9dd7353..4ef4209 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Compose.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Compose.hs @@ -23,8 +23,10 @@ import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox, DomainBoxMappable) + +import Data.Number.ER.Real.Approx.Interval import Data.Number.ER.Misc import qualified Data.Map as Map @@ -34,7 +36,10 @@ import qualified Data.Map as Map assuming the second polynomial maps [-1,1] into [-1,1]. -} enclCompose :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ max degree for result -} -> Int {-^ max approx size for result -} -> ERChebPoly box b {-^ @f@ -} -> @@ -105,7 +110,10 @@ enclCompose maxDegree maxSize p@(ERChebPoly coeffs) substVar substEncl = provided the second polynomial maps [-1,1] into [-1,1]. -} enclComposeMany :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ max degree for result -} -> Int {-^ max approx size for result -} -> ERChebPoly box b -> @@ -114,6 +122,16 @@ enclComposeMany :: (ERChebPoly box b, ERChebPoly box b) {-^ lower bound (negated) and upper bound -} enclComposeMany maxDegree maxSize p@(ERChebPoly coeffs) substitutions = +-- unsafePrintReturn +-- ( +-- "ChebyshevBase.Polynom.Compose: enclComposeMany:" +-- ++ "\n maxDegree = " ++ show maxDegree +-- ++ "\n maxSize = " ++ show maxSize +-- ++ "\n p = " ++ show p +-- ++ "\n substitutions = " ++ show substitutions +-- ++ "\n terms... \n" ++ (unlines $ map (show . (\t -> map evalVar (DBox.toList t) ) . fst) $ Map.toList coeffs) +-- ++ "\n result = " +-- ) result where result = @@ -134,5 +152,5 @@ enclComposeMany maxDegree maxSize p@(ERChebPoly coeffs) substitutions = substDegrees = Map.map mkPVDegrees substitutions mkPVDegrees pvEncl = - enclEvalTs maxSize maxDegree pvEncl + enclEvalTs maxDegree maxSize pvEncl
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Derivative.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Derivative.hs new file mode 100644 index 0000000..41c2003 --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Derivative.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Derivative + Description : (internal) derivative of polynomials + Copyright : (c) 2009 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Internal module for "Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom". + + Implementation of safely rounded derivative of polynomials. +-} +module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Derivative where + +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring + +import qualified Data.Number.ER.Real.Base as B +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import Data.Number.ER.Misc + +import qualified Data.Map as Map + +{-| + Differentiate a polynomial using one of its variables. +-} +chplDifferentiate :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + ERChebPoly box b -> + varid {-^ variable to differentiate over -} -> + (ERChebPoly box b, ERChebPoly box b) +chplDifferentiate p diffVar = chplBall2DownUp $ ballDifferentiate p diffVar + +{-| + Differentiate a polynomial using one of its variables. +-} +ballDifferentiate :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + ERChebPoly box b -> + varid {-^ variable to differentiate over -} -> + (ERChebPoly box b, b) +ballDifferentiate (ERChebPoly coeffs) diffVar = + (ERChebPoly diffCoeffs, diffRadius) + where + (diffCoeffs, diffRadius) = + -- ((term |-> coeff), radius) + Map.foldWithKey extractTerm (Map.empty, 0) coeffs + extractTerm term c prevBall = + addDiffTerms (diffVarDegree - 1) prevBall + where + diffVarDegree = DBox.findWithDefault 0 diffVar term + cConstUp = c * (B.fromIntegerUp $ toInteger diffVarDegree) + cConstDown = c `timesDown` (B.fromIntegerDown $ toInteger diffVarDegree) + cConstErr = cConstUp - cConstDown + cNonconstUp = 2 * cConstUp + cNonconstDown = 2 `timesDown` cConstDown + cNonconstErr = cNonconstUp - cNonconstDown + addDiffTerms degreeToAdd ball@(coeffs, radius) + | degreeToAdd < 0 = ball + | degreeToAdd == 0 = + addTermWithDegree 0 cConstDown cConstErr + | otherwise = + addDiffTerms (degreeToAdd - 2) $ + addTermWithDegree degreeToAdd cNonconstUp cNonconstErr + where + addTermWithDegree diffVarDegree c cErr = + (newCoeffs, radius + cErr + newCoeffErr) + where + newCoeffs = Map.insert newTerm newCoeffDown coeffs + newCoeffUp = oldCoeff + c + newCoeffDown = oldCoeff `plusDown` c + newCoeffErr = newCoeffUp - newCoeffDown + oldCoeff = + case Map.lookup newTerm coeffs of + Nothing -> 0 + Just c -> c + newTerm = DBox.insert diffVar degreeToAdd term + addRadius (p,r) = (p, r + radius) +-- +-- +-- (centrePolyWithDiffTerm, prevRadius + ) +-- Map.insertWith Map.union substVarDegree (Map.singleton termNoSubstVar c) prevPolynomMap + + + +
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Division.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Division.hs index e9e5700..34eb890 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Division.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Division.hs @@ -11,7 +11,7 @@ Internal module for "Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom". - Implementation of elementary functions applied to polynomials. + Implementation of division applied to basic polynomial enclosures. -} module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Division where @@ -28,21 +28,24 @@ import qualified Data.Number.ER.Real.Approx.Elementary as RAEL import qualified Data.Number.ER.Real.Base as B import Data.Number.ER.Real.Approx.Interval import Data.Number.ER.Real.Arithmetic.Elementary -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox, DomainBoxMappable) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc import qualified Data.Map as Map {-| - Approximate the pointwise cosine of a polynomial + Approximate the pointwise reciprocal of a polynomial by another polynomial from below and from above using the tau method as described in [Mason & Handscomb 2003, p 62]. -} enclRecip :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> EffortIndex {-^ minimum approx degree -} -> @@ -76,7 +79,7 @@ enclRecip maxDegree maxSize ix tauDegr pEncl@(pLowNeg, pHigh) -- ) $ case allInterimsBounded of True -> resEncl - False -> (chplConst 0, chplConst (1/0)) + False -> (chplConst 0, chplConst (B.plusInfinity)) | otherwise = -- cannot establish 0 freedom error $ "ERChebPoly: enclRecip: " @@ -107,7 +110,7 @@ enclRecip maxDegree maxSize ix tauDegr pEncl@(pLowNeg, pHigh) trT1Encl = enclAddConst (-1) (enclRAScale maxDegree maxSize nu (enclAddConst (-1) pAbove1Encl)) nu = recip nuInv -- auxiliary constant - nuInv = (RA.setMinGranularity coeffGr (ERInterval upperBtr upperBtr) - 1) / 2 + nuInv = (RA.setMinGranularityOuter coeffGr (ERInterval upperBtr upperBtr) - 1) / 2 nuPlus1 = nu + 1 nuInvPlus1 = nuInv + 1 diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/DivisionInner.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/DivisionInner.hs new file mode 100644 index 0000000..748a34f --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/DivisionInner.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.DivisionInner + Description : (internal) division of polynomials + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Internal module for "Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom". + + Implementation of inner-rounded division + applied to basic polynomial enclosures. +-} +module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.DivisionInner +where + +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.EnclosureInner +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Division + +import qualified Data.Number.ER.Real.Approx as RA +import qualified Data.Number.ER.Real.Approx.Elementary as RAEL +import qualified Data.Number.ER.Real.Base as B +import Data.Number.ER.Real.Approx.Interval +import Data.Number.ER.Real.Arithmetic.Elementary +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox, DomainBoxMappable) +import Data.Number.ER.BasicTypes +import Data.Number.ER.Misc + +import qualified Data.Map as Map + +{-| + Approximate the pointwise reciprocal of a positive polynomial + by another polynomial from below and from above + using the tau method + as described in [Mason & Handscomb 2003, p 62]. +-} +ienclRecipPositive :: + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + EffortIndex {-^ minimum approx degree -} -> + Int {-^ degree of tau expansion -} -> + ((ERChebPoly box b, ERChebPoly box b), Bool) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclRecipPositive maxDegree maxSize ix tauDegr (e@(ln, h), isAC) = + ((hnRDown,lRDown), isAC) + where + hnRDown = chplNeg hRUp + lRDown = chplNeg lnRUp + (_, lnRUp) = enclRecip maxDegree maxSize ix tauDegr (chplNeg ln,ln) + (_, hRUp) = enclRecip maxDegree maxSize ix tauDegr (chplNeg h,h) + + +-- | lDefinitelyPositive && hDefinitelyPositive = +-- ((hnRDown,lRDown), isAC) +-- | lDefinitelyNegative && hDefinitelyNegative = +-- ienclRecip maxDegree maxSize ix tauDegr ((h, ln), isAC) +-- | otherwise = +-- error "" +-- where +-- lDefinitelyPositive = chplUpperBound ix ln < 0 +-- hDefinitelyPositive = chplLowerBound ix h > 0 +-- lDefinitelyNegative = chplLowerBound ix ln > 0 +-- hDefinitelyNegative = chplUpperBound ix h < 0 + diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Elementary.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Elementary.hs index d1157bd..7aaeeb7 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Elementary.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Elementary.hs @@ -29,31 +29,92 @@ import qualified Data.Number.ER.Real.Approx.Elementary as RAEL import qualified Data.Number.ER.Real.Base as B import Data.Number.ER.Real.Approx.Interval import Data.Number.ER.Real.Arithmetic.Elementary -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox, DomainBoxMappable) import Data.Number.ER.BasicTypes import Data.Number.ER.Misc import qualified Data.Map as Map {-| - Approximate the pointwise exponential of a square root enclosure. + Approximate the pointwise square root of a polynomial enclosure. -} enclSqrt :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> - EffortIndex {-^ ?? -} -> + EffortIndex {-^ for calls to other ER functions -} -> + Int {-^ how many times to iterate -} -> (ERChebPoly box b, ERChebPoly box b) -> (ERChebPoly box b, ERChebPoly box b) -enclSqrt maxDegree maxSize ix p = - error "ERChebPoly: chplSqrt: not implemented yet" - +enclSqrt maxDegree maxSize ix maxIters p = + result + where + result + | pLowerBound >= 1 = + eSqrt p + | pLowerBound > 0 = + enclRAScale maxDegree maxSize (RAEL.sqrt ix pLowerBoundRA) $ + eSqrt $ + enclRAScale maxDegree maxSize (recip pLowerBoundRA) p + | otherwise = + error $ "ERChebPoly: enclSqrt: cannot confirm positivity of " ++ show p + pLowerBound = fst $ enclBounds ix p + pLowerBoundRA = ERInterval pLowerBound pLowerBound + eSqrt p@(ln,h) +-- | chplUpperBound ix ln >= 0 = +-- error $ "ERChebPoly: enclSqrt: internal error at eSqrt: cannot show l is positive" +-- | chplLowerBound ix h <= 0 = +-- error $ "ERChebPoly: enclSqrt: internal error at eSqrt: cannot show h is positive" + | otherwise = + -- assuming p >= 1, which implies 1 <= sqrt p <= p and 0 < 1/p <= 1/(sqrt p) + (chplMultiplyUp ln lRecipSqrtDown, + chplRecipUp hRecipSqrtDown) + where + lRecipSqrtDown = recipSqrtDown $ chplNeg ln + hRecipSqrtDown = recipSqrtDown $ h + chplMultiplyUp p1 p2 = + chplReduceTermCountUp maxSize $ + chplReduceDegreeUp maxDegree $ p1 *^ p2 + chplMultiplyDown p1 p2 = + chplReduceTermCountDown maxSize $ + chplReduceDegreeDown maxDegree $ p1 *. p2 + chplRecipUp p = + snd $ + enclRecip maxDegree maxSize ix (maxDegree + 1) $ + enclThin p + recipSqrtDown p + | chplLowerBound ix pRecipDown > 0 = + iterRecipSqrt maxIters pRecipDown + | otherwise = + chplConst $ negate $ recip $ negate $ chplUpperBound ix p + where + pRecipDown = + chplNeg $ fst $ + enclRecip maxDegree maxSize ix (maxDegree + 1) $ + enclThin p + iterRecipSqrt maxIters qNm1 + | maxIters > 0 && qNpositive = + iterRecipSqrt (maxIters - 1) qN + | otherwise = qNm1 + where + qNpositive = + chplLowerBound ix qN > 0 + qN = + chplMultiplyDown + (chplScaleDown (0.5) qNm1) + ((chplConst 3) -. (chplMultiplyUp p $ chplMultiplyUp qNm1 qNm1)) {-| Approximate the pointwise exponential of a polynomial enclosure. -} enclExp :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> EffortIndex {-^ used to derive minimum approx Taylor degree -} -> @@ -101,7 +162,7 @@ enclExp maxDegree maxSize ix pEncl = -- the difference between exact exp and finite Taylor expanstion is an increasing function -- therefore it is enough to compensate the error at the right-most point expTayNear0 = - expAux pNear0Encl 1 (RA.setGranularity coeffGr 1) + expAux pNear0Encl 1 (RA.setGranularityOuter coeffGr 1) expAux p0Encl nextDegree thisCoeff | nextDegree > taylorDegree = enclRAConst thisCoeff @@ -123,7 +184,7 @@ enclExp maxDegree maxSize ix pEncl = getConst p = case chplGetConst p of Just c -> c; _ -> 0 (valueAtRNear0LowNeg, valueAtRNear0High) = - expAux rNear0Encl 1 (RA.setGranularity coeffGr 1) + expAux rNear0Encl 1 (RA.setGranularityOuter coeffGr 1) rNear0Encl = enclRAConst rNear0 _ = [rNear0Encl, pEncl] -- help the typechecker... @@ -131,7 +192,10 @@ enclExp maxDegree maxSize ix pEncl = Approximate the pointwise integer power of an enclosure. -} enclPow :: - (B.ERRealBase b, RealFrac b, Integral i, DomainBox box varid Int, Ord box) => + (Integral i, B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> (ERChebPoly box b, ERChebPoly box b) -> @@ -158,7 +222,7 @@ enclPow maxDegree maxSize pEncl n Approximate the pointwise natural logarithm of an enclosure. -} enclLog :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, DomainBox box varid Int, Ord box) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> EffortIndex {-^ ?? -} -> @@ -173,7 +237,10 @@ enclLog maxDegree maxSize ix p = Assuming the polynomial range is [-pi/2, pi/2]. -} enclSine :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> EffortIndex {-^ how hard to try (determines Taylor degree and granularity) -} -> @@ -194,12 +261,11 @@ enclSine maxDegree maxSize ix pEncl = enclMultiply maxDegree maxSize pEncl sineTayEncl (sineTayEncl, sineErrorTermDegree, sineErrorTermCoeffRA) = sincosTaylorAux maxDegree maxSize True pSqrEncl taylorDegree 1 one - one = RA.setGranularity coeffGr 1 + one = RA.setGranularityOuter coeffGr 1 pSqrEncl = enclMultiply maxDegree maxSize pEncl pEncl sineErrorBound = case sineErrorBoundRA of ERInterval lo hi -> hi - ERIntervalAny -> 1/0 where sineErrorBoundRA = (ranLargerEndpointRA ^ sineErrorTermDegree) * sineErrorTermCoeffHighRA @@ -219,7 +285,10 @@ enclSine maxDegree maxSize ix pEncl = Assuming the polynomial range is [-pi/2, pi/2]. -} enclCosine :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> EffortIndex {-^ how hard to try (determines Taylor degree and granularity) -} -> @@ -240,12 +309,11 @@ enclCosine maxDegree maxSize ix pEncl = cosineTayEncl (cosineTayEncl, cosineErrorTermDegree, cosineErrorTermCoeffRA) = sincosTaylorAux maxDegree maxSize True pSqrEncl taylorDegree 0 one - one = RA.setGranularity coeffGr 1 + one = RA.setGranularityOuter coeffGr 1 pSqrEncl = enclMultiply maxDegree maxSize pEncl pEncl cosineErrorBound = case cosineErrorBoundRA of ERInterval lo hi -> hi - ERIntervalAny -> 1/0 where cosineErrorBoundRA = (ranLargerEndpointRA ^ cosineErrorTermDegree) * cosineErrorTermCoeffHighRA @@ -260,7 +328,10 @@ enclCosine maxDegree maxSize ix pEncl = coeffGr = effIx2gran $ ix sincosTaylorAux :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> Bool {-^ is sine ? -} -> @@ -315,7 +386,10 @@ sincosTaylorAux Approximate the pointwise arcus tangens of an enclosure. -} enclAtan :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> EffortIndex {-^ how far to go in the Euler's series -} -> @@ -346,7 +420,7 @@ enclAtan maxDegree maxSize ix pEncl@(pLowNeg, pHigh) (pLowerBound, pUpperBound) = enclBounds ix pEncl onePlusSqrtOnePlusPSquare = enclAddConst 1 $ - enclSqrt maxDegree maxSize ix pSquarePlus1Encl + enclSqrt maxDegree maxSize ix maxDegree pSquarePlus1Encl avoidingDivBy0 = lower1 > 0 && lower2 > 0 where diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/ElementaryInner.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/ElementaryInner.hs new file mode 100644 index 0000000..3363435 --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/ElementaryInner.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Elementary + Description : (internal) elementary functions applied to polynomials + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Internal module for "Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom". + + Implementation of inner-rounded + elementary functions applied to polynomials. +-} +module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.ElementaryInner +where + +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Division +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Elementary + +import qualified Data.Number.ER.Real.Approx as RA +import qualified Data.Number.ER.Real.Approx.Elementary as RAEL +import qualified Data.Number.ER.Real.Base as B +import Data.Number.ER.Real.Approx.Interval +import Data.Number.ER.Real.Arithmetic.Elementary +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox, DomainBoxMappable) +import Data.Number.ER.BasicTypes +import Data.Number.ER.Misc + +import qualified Data.Map as Map + +{-| + +-} +ienclSqrt :: + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + EffortIndex {-^ for calls to other ER functions -} -> + Int {-^ how many times to iterate -} -> + ((ERChebPoly box b, ERChebPoly box b), Bool) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclSqrt maxDegree maxSize ix maxIters (e@(ln, h), isDAC) = + ((lnRDown,hRDown), isDAC) + where + lnRDown = chplNeg lRUp + hRDown = chplNeg hnRUp + (_, lRUp) = enclSqrt maxDegree maxSize ix maxIters (ln,chplNeg ln) + (hnRUp, _) = enclSqrt maxDegree maxSize ix maxIters (chplNeg h,h) + +--{-| +-- Approximate the pointwise exponential of a polynomial enclosure. +---} +--enclExp :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- EffortIndex {-^ used to derive minimum approx Taylor degree -} -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- (ERChebPoly box b, ERChebPoly box b) +--enclExp maxDegree maxSize ix pEncl = +---- unsafePrintReturn +---- ( +---- "chplExp:" ++ +---- "\n pEncl = " ++ show pEncl ++ +---- "\n upperB = " ++ show upperB ++ +---- "\n lowerB = " ++ show lowerB ++ +---- "\n m = " ++ show m ++ +---- "\n expM = " ++ show expM ++ +---- "\n r = " ++ show r ++ +---- "\n a_int = " ++ show a_int ++ +---- "\n a_base = " ++ show a_base ++ +---- "\n pNear0Encl = " ++ show (pNear0Encl) ++ +---- "\n expNear0 = " ++ show (expNear0) ++ +------ "\n chplPow maxDegree (expNear0Up pNear0Up) a_int = " ++ show (chplPow maxDegree (expNear0Up pNear0Up) a_int) +---- "\n result = " +---- ) +---- $ +-- result +-- where +-- result = +-- enclRAScale maxDegree maxSize expM $ enclPow maxDegree maxSize expNear0 a_int +-- +-- (lowerB, upperB) = enclBounds ix pEncl +-- mB = (upperB + lowerB) / 2 +-- rB = (upperB - lowerB) / 2 +-- r = ERInterval rB rB +-- m = ERInterval mB mB +-- expM = max 0 $ erExp_IR ix m +-- +-- -- scale the problem down for polynomials whose value is always near zero: +-- pNear0Encl = +-- enclRAScale maxDegree maxSize (recip a_base) (pEncl -: (enclConst mB)) +-- rNear0 = r / a_base +-- a_base = fromInteger a_int +-- a_int = max 1 $ floor rB -- could this be too high? +-- +-- expNear0 = +-- expTayNear0 +: (chplConst 0, chplConst (erintv_right truncCorrNear0)) +-- -- the difference between exact exp and finite Taylor expanstion is an increasing function +-- -- therefore it is enough to compensate the error at the right-most point +-- expTayNear0 = +-- expAux pNear0Encl 1 (RA.setGranularity coeffGr 1) +-- expAux p0Encl nextDegree thisCoeff +-- | nextDegree > taylorDegree = +-- enclRAConst thisCoeff +-- | otherwise = +-- (enclRAConst thisCoeff) +: (p0Encl *: (expAux p0Encl (nextDegree + 1) nextCoeff)) +-- where +-- (*:) = enclMultiply maxDegree maxSize +-- nextCoeff = +-- thisCoeff / (fromInteger nextDegree) +-- taylorDegree = 1 + 2 * (ix `div` 6) +-- coeffGr = effIx2gran $ 10 + 3 * taylorDegree +-- -- correction of truncation error (highest at the right-most point): +-- truncCorrNear0 = expRNear0 - tayRNear0 +-- expRNear0 = erExp_R ix rNear0 +-- tayRNear0 = +-- ERInterval +-- (negate $ getConst valueAtRNear0LowNeg) +-- (getConst valueAtRNear0High) +-- getConst p = +-- case chplGetConst p of Just c -> c; _ -> 0 +-- (valueAtRNear0LowNeg, valueAtRNear0High) = +-- expAux rNear0Encl 1 (RA.setGranularity coeffGr 1) +-- rNear0Encl = enclRAConst rNear0 +-- _ = [rNear0Encl, pEncl] -- help the typechecker... +-- +--{-| +-- Approximate the pointwise integer power of an enclosure. +---} +--enclPow :: +-- (B.ERRealBase b, Integral i, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- i -> +-- (ERChebPoly box b, ERChebPoly box b) +-- {-^ lower (negated) and upper bound -} +--enclPow maxDegree maxSize pEncl n +-- | n == 0 = +-- enclConst 1 +-- | n == 1 = +-- pEncl +-- | even n = +-- powEvenEncl +-- | odd n = +-- enclMultiply maxDegree maxSize powEvenEncl pEncl +-- where +-- powEvenEncl = +-- enclMultiply maxDegree maxSize powHalfEncl powHalfEncl +-- powHalfEncl = +-- enclPow maxDegree maxSize pEncl halfN +-- halfN = n `div` 2 +-- +--{-| +-- Approximate the pointwise natural logarithm of an enclosure. +---} +--enclLog :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- EffortIndex {-^ ?? -} -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- (ERChebPoly box b, ERChebPoly box b) +--enclLog maxDegree maxSize ix p = +-- error "ERChebPoly: chplLog: not implemented yet" +-- +--{-| +-- Approximate the pointwise sine of an enclosure. +-- +-- Assuming the polynomial range is [-pi/2, pi/2]. +---} +--enclSine :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- EffortIndex {-^ how hard to try (determines Taylor degree and granularity) -} -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- (ERChebPoly box b, ERChebPoly box b) +--enclSine maxDegree maxSize ix pEncl = +---- unsafePrint +---- ( +---- "ERChebPoly: enclSine: " +---- ++ "\n pEncl = " ++ show pEncl +---- ++ "\n ranLargerEndpoint = " ++ show ranLargerEndpoint +---- ++ "\n sineEncl = " ++ show sineEncl +---- ) $ +-- sineEncl +-- where +-- sineEncl = +-- enclAddErr sineErrorBound $ +-- enclMultiply maxDegree maxSize pEncl sineTayEncl +-- (sineTayEncl, sineErrorTermDegree, sineErrorTermCoeffRA) = +-- sincosTaylorAux maxDegree maxSize True pSqrEncl taylorDegree 1 one +-- one = RA.setGranularity coeffGr 1 +-- pSqrEncl = enclMultiply maxDegree maxSize pEncl pEncl +-- sineErrorBound = +-- case sineErrorBoundRA of +-- ERInterval lo hi -> hi +-- ERIntervalAny -> B.plusInfinity +-- where +-- sineErrorBoundRA = +-- (ranLargerEndpointRA ^ sineErrorTermDegree) * sineErrorTermCoeffHighRA +-- sineErrorTermCoeffHighRA = +-- snd $ RA.bounds $ abs sineErrorTermCoeffRA +-- ranLargerEndpointRA = +-- ERInterval ranLargerEndpoint ranLargerEndpoint +-- ranLargerEndpoint = +-- max (abs ranLowB) (abs ranHighB) +-- (ranLowB, ranHighB) = enclBounds ix pEncl +-- taylorDegree = effIx2int $ ix `div` 3 +-- coeffGr = effIx2gran $ ix +-- +--{-| +-- Approximate the pointwise cosine of an enclosure. +-- +-- Assuming the polynomial range is [-pi/2, pi/2]. +---} +--enclCosine :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- EffortIndex {-^ how hard to try (determines Taylor degree and granularity) -} -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- (ERChebPoly box b, ERChebPoly box b) +--enclCosine maxDegree maxSize ix pEncl = +---- unsafePrint +---- ( +---- "ERChebPoly: chplCosine: " +---- ++ "\n pEncl = " ++ show pEncl +---- ++ "\n ranLargerEndpoint = " ++ show ranLargerEndpoint +---- ++ "\n cosineEncl = " ++ show cosineEncl +---- ) $ +-- cosineEncl +-- where +-- cosineEncl = +-- enclAddErr cosineErrorBound $ +-- cosineTayEncl +-- (cosineTayEncl, cosineErrorTermDegree, cosineErrorTermCoeffRA) = +-- sincosTaylorAux maxDegree maxSize True pSqrEncl taylorDegree 0 one +-- one = RA.setGranularity coeffGr 1 +-- pSqrEncl = enclMultiply maxDegree maxSize pEncl pEncl +-- cosineErrorBound = +-- case cosineErrorBoundRA of +-- ERInterval lo hi -> hi +-- ERIntervalAny -> B.plusInfinity +-- where +-- cosineErrorBoundRA = +-- (ranLargerEndpointRA ^ cosineErrorTermDegree) * cosineErrorTermCoeffHighRA +-- cosineErrorTermCoeffHighRA = +-- snd $ RA.bounds $ abs cosineErrorTermCoeffRA +-- ranLargerEndpointRA = +-- ERInterval ranLargerEndpoint ranLargerEndpoint +-- ranLargerEndpoint = +-- max (abs ranLowB) (abs ranHighB) +-- (ranLowB, ranHighB) = enclBounds ix pEncl +-- taylorDegree = effIx2int $ ix `div` 3 +-- coeffGr = effIx2gran $ ix +-- +--sincosTaylorAux :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- Bool {-^ is sine ? -} -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- Int {-^ how far to go in the Taylor series -} -> +-- Int {-^ degree of the term now being constructed -} -> +-- ERInterval b {-^ the coefficient of the term now being constructed -} -> +-- ((ERChebPoly box b, ERChebPoly box b), +-- Int, +-- ERInterval b) +-- {-^ +-- Bounds for the series result and information about the first discarded term, +-- from which some bound on the uniform error can be deduced. +-- -} +--sincosTaylorAux +-- maxDegree maxSize resultPositive pSqrEncl tayDegree +-- thisDegree thisCoeffRA = +-- sct thisDegree thisCoeffRA +-- where +-- sct thisDegree thisCoeffRA +-- | nextDegree > tayDegree = +---- unsafePrint +---- ( +---- "ERChebPoly: sincosTaylorAux: " +---- ++ "\n thisCoeffRA = " ++ show thisCoeffRA +---- ++ "\n nextDegree = " ++ show nextDegree +---- ) +-- (thisCoeffEncl, nextDegree, nextCoeffRA) +-- | otherwise = +---- unsafePrint +---- ( +---- "ERChebPoly: chplSine: taylorAux: " +---- ++ "\n thisCoeffRA = " ++ show thisCoeffRA +---- ++ "\n nextDegree = " ++ show nextDegree +---- ++ "\n errorTermCoeffRA = " ++ show errorTermCoeffRA +---- ++ "\n errorTermDegree = " ++ show errorTermDegree +---- ) +-- (resultEncl, errorTermDegree, errorTermCoeffRA) +-- where +-- thisCoeffEncl = enclRAConst thisCoeffRA +-- resultEncl = +-- thisCoeffEncl +: (enclMultiply maxDegree maxSize pSqrEncl restEncl) +-- (restEncl, errorTermDegree, errorTermCoeffRA) = +-- sct nextDegree nextCoeffRA +-- nextDegree = thisDegree + 2 +-- nextCoeffRA = thisCoeffRA / nextCoeffDenominatorRA +-- nextCoeffDenominatorRA = +-- fromInteger $ toInteger $ +-- negate $ nextDegree * (nextDegree - 1) +-- +--{-| +-- Approximate the pointwise arcus tangens of an enclosure. +---} +--enclAtan :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- EffortIndex {-^ how far to go in the Euler's series -} -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- (ERChebPoly box b, ERChebPoly box b) +--{- arctan using Euler's series: +-- (http://en.wikipedia.org/wiki/Inverse_trigonometric_function#Infinite_series) +-- +-- (x / (1 + x^2)) * (1 + t*2*1/(2*1 + 1)*(1 + t*2*2/(2*2 + 1)*(1 + ... (1 + t*2*n/(2*n+1)*(1 + ...))))) +-- where +-- t = x^2/(1 + x^2) +-- +-- where the tail (1 + t*2*n/(2*n+1)*(1 + ...)) is inside the interval: +-- [1, 1 + x^2] +---} +--enclAtan maxDegree maxSize ix pEncl@(pLowNeg, pHigh) +-- | True = -- pLowerBound >= (-3) && pUpperBound <= 3 = +-- enclAtanAux maxDegree maxSize ix (Just pSquareEncl) pEncl +-- | otherwise = -- too far from 0, needs atan(x) = 2*atan(x/(1+sqrt(1+x^2))) +-- case avoidingDivBy0 of +-- True -> +-- enclScale maxDegree maxSize 2 $ +-- enclAtanAux maxDegree maxSize ix Nothing $ +-- enclMultiply maxDegree maxSize pEncl $ +-- enclRecip maxDegree maxSize ix (maxDegree + 1) $ +-- onePlusSqrtOnePlusPSquare +-- where +-- (pLowerBound, pUpperBound) = enclBounds ix pEncl +-- onePlusSqrtOnePlusPSquare = +-- enclAddConst 1 $ +-- enclSqrt maxDegree maxSize ix maxDegree pSquarePlus1Encl +-- avoidingDivBy0 = +-- lower1 > 0 && lower2 > 0 +-- where +-- (lower1, _) = enclBounds ix pSquarePlus1Encl +-- (lower2, _) = enclBounds ix onePlusSqrtOnePlusPSquare +-- pSquareEncl = +-- enclSquare maxDegree maxSize pEncl +-- pSquarePlus1Encl = +-- pSquareEncl +: (enclConst 1) +-- +-- +--enclAtanAux maxDegree maxSize ix maybePSquareEncl pEncl@(pLowNeg, pHigh) +-- | avoidingDivBy0 = resultEncl +-- | otherwise = +-- (piHalfUp, piHalfUp) -- [-22/14,22/14] is always safe... +-- where +-- piHalfUp = chplConst $ 22/7 +-- avoidingDivBy0 = +-- lower > 0 +-- where +-- (lower, _) = enclBounds ix pSquarePlus1Encl +-- resultEncl = +-- enclMultiply maxDegree maxSize +-- pOverPSquarePlus1Encl preresEncl +-- preresEncl = +-- series termsCount 2 +-- termsCount = +-- max 0 $ ix `div` 3 +-- gran = effIx2gran ix +-- series termsCount coeffBase +-- | termsCount > 0 = +-- enclAddConst 1 $ +-- enclRAScale maxDegree maxSize coeff $ +-- enclMultiply maxDegree maxSize +-- pSquareOverPSquarePlus1Encl $ +-- series (termsCount - 1) (coeffBase + 2) +-- | otherwise = +-- enclAddConst 1 $ +-- (chplConst 0, pSquareHigh) +-- where +-- coeff = coeffBase / (coeffBase + 1) +-- +-- pSquareEncl@(pSquareLowNeg, pSquareHigh) = +-- case maybePSquareEncl of +-- Just pSquareEncl -> pSquareEncl +-- Nothing -> +-- enclSquare maxDegree maxSize pEncl +-- pSquarePlus1Encl = +-- pSquareEncl +: (enclConst 1) +-- recipPSquarePlus1Encl = +-- enclRecip maxDegree maxSize ix (maxDegree + 1) pSquarePlus1Encl +-- pSquareOverPSquarePlus1Encl = +-- enclMultiply maxDegree maxSize pSquareEncl recipPSquarePlus1Encl +-- pOverPSquarePlus1Encl = +-- enclMultiply maxDegree maxSize pEncl recipPSquarePlus1Encl diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Enclosure.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Enclosure.hs index 46eede1..b057f17 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Enclosure.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Enclosure.hs @@ -2,7 +2,7 @@ {-# LANGUAGE UndecidableInstances #-} {-| Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure - Description : (internal) basic operations for primitive polynomial enclosures + Description : (internal) field operations applied to polynomials Copyright : (c) 2007-2008 Michal Konecny License : BSD3 @@ -27,8 +27,8 @@ import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox, DomainBoxMappable) import Data.Number.ER.Real.Approx.Interval import qualified Data.Number.ER.Real.Approx as RA import Data.Number.ER.Misc @@ -50,56 +50,37 @@ enclConst c = (chplConst (-c), chplConst c) enclBounds ix (ln, h) = - (negate $ chplUpperBound ix ln, chplUpperBound ix h) + (min lLower hLower, max lUpper hUpper) + where + (lLower, lUpper) = chplBounds ix $ chplNeg ln + (hLower, hUpper) = chplBounds ix h + +enclBoundsExpensive ix (ln, h) = + (negate $ chplUpperBoundExpensive ix ln, chplUpperBoundExpensive ix h) enclEval e@(ln, h) pt - | lB > hB = - unsafePrintReturn - ( - "ERChebPoly: enclEval: inverted result:" - ++ "\n h = " ++ show h - ++ "\n ln = " ++ show ln - ++ "\n result = " - ) - result - | otherwise = result +-- | lB > hB = +-- unsafePrintReturn +-- ( +-- "ERChebPoly: enclEval: inverted result:" +-- ++ "\n h = " ++ show h +-- ++ "\n ln = " ++ show ln +-- ++ "\n result = " +-- ) +-- result +-- | otherwise = result + = result where result = ERInterval lB hB lB = negate $ chplEvalUp ln pt hB = chplEvalUp h pt -enclEvalInner (ln, h) pt = --- normaliseERInterval $ - ERInterval - (negate $ chplEvalDown ln pt) - (chplEvalDown h pt) - enclRAEval e@(ln, h) pt = result where - result = lRA RA.\/ hRA - lRA = fst $ RA.bounds $ negate $ chplRAEval (\b -> ERInterval b b) ln pt - hRA = snd $ RA.bounds $ chplRAEval (\b -> ERInterval b b) h pt - -enclRAEvalInner e@(ln, h) pt = --- unsafePrintReturn --- ( --- "ERChebPoly: enclRAEvalInner: " --- ++ "\n lB = " ++ show lB --- ++ "\n hB = " ++ show hB --- ++ "\n result = " --- ) - result - where - result = --- normaliseERInterval $ - ERInterval lB hB - lB = - case negate $ chplRAEval (\b -> ERInterval b b) ln pt of - ERInterval _ lB -> lB - hB = - case chplRAEval (\b -> ERInterval b b) h pt of - ERInterval hB _ -> hB + result = ERInterval lAtPt hAtPt + ERInterval lAtPt _ = negate $ chplRAEval (\b -> ERInterval b b) ln pt + ERInterval _ hAtPt = chplRAEval (\b -> ERInterval b b) h pt enclAddErr errB (pLowNeg, pHigh) = (chplAddConstUp errB pLowNeg, chplAddConstUp errB pHigh) @@ -110,7 +91,6 @@ enclRAConst :: (ERInterval b) -> (ERChebPoly box b, ERChebPoly box b) enclRAConst (ERInterval lo hi) = (chplConst (-lo), chplConst hi) -enclRAConst ERIntervalAny = (chplConst (-1/0), chplConst (1/0)) enclReduceDegree maxDegree (pLowNeg, pHigh) = (chplReduceDegreeUp maxDegree pLowNeg, chplReduceDegreeUp maxDegree pHigh) @@ -129,8 +109,22 @@ enclNeg (pLowNeg, pHigh) = (pHigh, pLowNeg) (p1LowNeg, p1High) -: (p2LowNeg, p2High) = (p1LowNeg +^ p2High, p1High +^ p2LowNeg) +enclAdd :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + (ERChebPoly box b, ERChebPoly box b) -> + (ERChebPoly box b, ERChebPoly box b) -> + (ERChebPoly box b, ERChebPoly box b) +enclAdd maxDegr maxSize (p1LowNeg, p1High) (p2LowNeg, p2High) = + enclReduceSize maxSize $ + (p1LowNeg +^ p2LowNeg, p1High +^ p2High) + enclMultiply :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> (ERChebPoly box b, ERChebPoly box b) -> @@ -141,13 +135,23 @@ enclMultiply maxDegr maxSize (ln1, h1) (ln2, h2) = enclReduceDegree maxDegr $ case (ln1UpperBound <= 0, h1UpperBound <= 0, ln2UpperBound <= 0, h2UpperBound <= 0) of (True, _, True, _) -> -- both non-negative +-- unsafePrint "both non-negative" $ (l1l2Neg, h1h2) (_, True, _, True) -> -- both non-positive +-- unsafePrint "both non-positive" $ (h1h2Neg, l1l2) (True, _, _, True) -> -- first non-negative, second non-positive +-- unsafePrint "first non-negative, second non-positive" $ (h1l2Neg, l1h2) (_, True, True, _) -> -- first non-positive, second non-negative - (l1h2Neg, l1h2) +-- unsafePrint +-- ("ERChebPoly: enclMultiply: first non-positive, second non-negative:" +-- ++ "\n l1 = " ++ show (chplNeg ln1) +-- ++ "\n h1 = " ++ show h1 +-- ++ "\n l2 = " ++ show (chplNeg ln2) +-- ++ "\n h2 = " ++ show h2 +-- ) $ + (l1h2Neg, h1l2) _ -> -- one of both may be crossing zero ( (h1h2Neg `maxP` l1l2Neg) `maxP` (h1l2Neg `maxP` l1h2Neg) @@ -173,7 +177,10 @@ enclMultiply maxDegr maxSize (ln1, h1) (ln2, h2) = enclSquare :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> (ERChebPoly box b, ERChebPoly box b) -> @@ -197,8 +204,8 @@ enclSquare maxDegr maxSize (ln, h) -- maxNegSqUpperB = chplUpperBound 10 maxNegSq -- minZeroMaxNegSqUpperB = chplUpperBound 10 minZeroMaxNegSq - (ln2Down, ln2Up, _) = chplMultiply ln ln - (h2Down, h2Up, _) = chplMultiply h h + (ln2Down, ln2Up) = chplBall2DownUp $ ballMultiply ln ln + (h2Down, h2Up) = chplBall2DownUp $ ballMultiply h h -- reduceDegrSize = reduceSize maxSize . reduceDegree maxDegr maxP = chplMaxUp maxDegr maxSize @@ -211,7 +218,7 @@ enclSquare maxDegr maxSize (ln, h) assuming the enclosure is non-negative on the whole unit domain. -} enclScaleNonneg :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, DomainBox box varid Int, Ord box) => b {-^ ratio to scale by -} -> (ERChebPoly box b, ERChebPoly box b) -> (ERChebPoly box b, ERChebPoly box b) @@ -224,7 +231,10 @@ enclScaleNonneg ratio pEncl@(ln, h) = Multiply an enclosure by a scalar. -} enclScale :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> b {-^ ratio to scale by -} -> @@ -234,7 +244,10 @@ enclScale maxDegree maxSize ratio pEncl = enclMultiply maxDegree maxSize pEncl (enclConst ratio) enclRAScale :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> (ERInterval b) -> @@ -247,14 +260,16 @@ enclRAScale maxDegree maxSize ra pEncl = Multiply a polynomial by a scalar interval, returning an enclosure. -} chplScaleRA :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> ERInterval b {-^ lower and upper bounds on the ratio to scale by -} -> ERChebPoly box b -> (ERChebPoly box b, ERChebPoly box b) -chplScaleRA maxDegr maxSize (ERIntervalAny) p = enclRAConst ERIntervalAny -chplScaleRA maxDegr maxSize (ERInterval ratioDown ratioUp) p = +chplScaleRA maxDegr maxSize ratio@(ERInterval ratioDown ratioUp) p = (scaledPDownNeg, scaledPUp) where (scaledPDownNeg, scaledPUp) = @@ -269,7 +284,10 @@ chplScaleRAUp m n r = snd . chplScaleRA m n r applied to a given polynomial, yielding a list of polynomial enclosures. -} enclEvalTs :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ max degree for result -} -> Int {-^ max approx size for result -} -> (ERChebPoly box b, ERChebPoly box b) {-^ bounds of a polynomial enclosure to evaluate -} -> @@ -289,7 +307,10 @@ enclEvalTs maxDegree maxSize p1@(pLowNeg, pHigh) = Multiply a polynomial by an enclosure using min/max -} enclThinTimes :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box) => + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => Int {-^ maximum polynomial degree -} -> Int {-^ maximum term count -} -> ERChebPoly box b -> diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/EnclosureInner.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/EnclosureInner.hs new file mode 100644 index 0000000..75f12ce --- /dev/null +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/EnclosureInner.hs @@ -0,0 +1,355 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-| + Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.EnclosureInner + Description : (internal) basic operations for primitive polynomial inner-rounded enclosures + Copyright : (c) 2007-2008 Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + Internal module for "Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom". + + Implementation of selected operations working on pairs + of polynomials understood as *inner approximations* of function enclosures. + These are needed to define full Kaucher arithmetic. +-} +module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.EnclosureInner + +where + +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval +import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure + +import qualified Data.Number.ER.Real.Base as B +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox, DomainBoxMappable) +import Data.Number.ER.Real.Approx.Interval +import qualified Data.Number.ER.Real.Approx as RA +import Data.Number.ER.Misc + +import qualified Data.Map as Map + +ienclThin :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + ERChebPoly box b -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclThin p = + ((chplNeg p, p), True) + +ienclConst :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + b -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclConst c = + ((chplConst (-c), chplConst c), True) + +--ienclBounds ix ((ln, h), isAC) = +-- (negate $ chplUpperBound ix ln, chplUpperBound ix h) + +ienclEval ((ln, h), isAC) pt = + result + where + result = ERInterval lB hB + lB = negate $ chplEvalDown ln pt + hB = chplEvalDown h pt + +enclEvalInner e pt = ienclEval (e, False) pt + +ienclRAEval (e@(ln, h), _) pt = +-- unsafePrintReturn +-- ( +-- "ERChebPoly: ienclRAEval: " +-- ++ "\n lB = " ++ show lB +-- ++ "\n hB = " ++ show hB +-- ++ "\n result = " +-- ) + result + where + result = ERInterval lAtPt hAtPt + ERInterval _ lAtPt = negate $ chplRAEval (\b -> ERInterval b b) ln pt + ERInterval hAtPt _ = chplRAEval (\b -> ERInterval b b) h pt + +enclRAEvalInner e pt = ienclRAEval (e, False) pt + +ienclAddErr errB ((pLowNeg, pHigh), isAC) = + ((chplAddConstDown (- errB) pLowNeg, + chplAddConstDown (- errB) pHigh), + isAC) + + +ienclRAConst :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (ERInterval b) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclRAConst (ERInterval lo hi) = ((chplConst (-lo), chplConst hi), lo >= hi) + +ienclReduceDegree maxDegree ((pLowNeg, pHigh), isAC) = + ((chplReduceDegreeDown maxDegree pLowNeg, + chplReduceDegreeDown maxDegree pHigh), + isAC) + +ienclReduceSize maxSize ((pLowNeg, pHigh), isAC) = + ((chplReduceTermCountUp maxSize pLowNeg, + chplReduceTermCountUp maxSize pHigh), + isAC) + +ienclAddConst c ((pLowNeg, pHigh),isAC) = + ((chplAddConstDown (-c) pLowNeg, + chplAddConstDown c pHigh), + isAC) + +ienclNeg ((pLowNeg, pHigh), isAC) = ((pHigh, pLowNeg), isAC) + +((p1LowNeg, p1High), isAC1) +:: ((p2LowNeg, p2High), isAC2) = + ((p1LowNeg +. p2LowNeg, p1High +. p2High), isAC1 && isAC2) + +((p1LowNeg, p1High), isAC1) -:: ((p2LowNeg, p2High), isAC2) = + ((p1LowNeg +. p2High, p1High +. p2LowNeg), isAC1 && isAC2) + +ienclAdd :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + ((ERChebPoly box b, ERChebPoly box b), Bool) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclAdd maxDegr maxSize ie1 ie2 = + ienclReduceSize maxSize $ ie1 +:: ie2 + +ienclMultiply :: + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + ((ERChebPoly box b, ERChebPoly box b), Bool) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclMultiply maxDegr maxSize ie1@(e1@(ln1, h1), isAC1_prev) ie2@(e2@(ln2, h2), isAC2_prev) = +-- unsafePrintReturn +-- ( +-- "ERChebPoly: ienclMultiply: " +-- ++ "\n ie1 = " ++ show ie1 +-- ++ "\n ie2 = " ++ show ie2 +-- ++ "\n isPos1 = " ++ show isPos1 +-- ++ "\n isNeg1 = " ++ show isNeg1 +-- ++ "\n isPos2 = " ++ show isPos2 +-- ++ "\n isNeg2 = " ++ show isNeg2 +-- ++ "\n result = " +-- ) + result + where + result = + ienclReduceSize maxSize $ + ienclReduceDegree maxDegr $ + (plainProduct, isAC1 && isAC2) + plainProduct + | isPos1 && isPos2 = multPosPos e1 e2 + | isPos1 && isNeg2 = multPosNeg e1 e2 + | isNeg1 && isNeg2 = multPosPos (enclNeg e1) (enclNeg e2) + | isNeg1 && isPos2 = multPosNeg e2 e1 + | isPos1 = multPosZer (e1, isC1, isAC1) e2 + | isNeg1 = multPosZer (enclNeg e1, isC1, isAC1) (enclNeg e2) + | isPos2 = multPosZer (e2, isC2, isAC2) e1 + | isNeg2 = multPosZer (enclNeg e2, isC2, isAC2) (enclNeg e1) + | otherwise = multZerZer (e1, isC1, isAC1) (e2, isC2, isAC2) + isPos1 = chplUpperBound ix ln1 <= 0 && chplLowerBound ix h1 >= 0 + isNeg1 = chplLowerBound ix ln1 >= 0 && chplUpperBound ix h1 <= 0 + isPos2 = chplUpperBound ix ln2 <= 0 && chplLowerBound ix h2 >= 0 + isNeg2 = chplLowerBound ix ln2 >= 0 && chplUpperBound ix h2 <= 0 + isAC1 = isAC1_prev || chplUpperBound ix (h1 +^ ln1) <= 0 + isAC2 = isAC2_prev || chplUpperBound ix (h2 +^ ln2) <= 0 + isC1 = chplLowerBound ix (h1 +. ln1) >= 0 + isC2 = chplLowerBound ix (h2 +. ln2) >= 0 + ix = 10 + + multPosPos (ln1, h1) (ln2, h2) = + (chplNeg $ ln1 *^ ln2, h1 *. h2) + multPosNeg (ln1, h1) (ln2, h2) = + (h1 *. ln2, (chplNeg ln1) *. h2) + multPosZer ((ln1,h1), isC1, isAC1) (ln2, h2) = + multAux ((l1,h1), isC1, isAC1) ln2 h2 + where + l1 = chplNeg ln1 + + multZerZer ((ln1, h1), isC1, isAC1) ((ln2, h2), isC2, isAC2) + | isC1 || isAC2 = multZZ12 + | isC2 || isAC1 = multZZ21 + | otherwise = isect multZZ12 multZZ21 + where + multZZ12 + | isC2 = union multZZ12L multZZ12R + | otherwise = isect multZZ12L multZZ12R + multZZ21 + | isC1 = union multZZ21L multZZ21R + | otherwise = isect multZZ21L multZZ21R + multZZ12L = multAux ((l1,h1), isC1, isAC1) ln2 l2 + multZZ12R = multAux ((l1,h1), isC1, isAC1) hn2 h2 + multZZ21L = multAux ((l2,h2), isC2, isAC2) ln1 l1 + multZZ21R = multAux ((l2,h2), isC2, isAC2) hn1 h1 + l1 = chplNeg ln1 + l2 = chplNeg ln2 + hn1 = chplNeg h1 + hn2 = chplNeg h2 + + isect (ln1, h1) (ln2, h2) = (minP ln1 ln2, minP h1 h2) + union (ln1, h1) (ln2, h2) = (maxP ln1 ln2, maxP h1 h2) + minP = chplMinDn maxDegr maxSize + maxP = chplMaxDn maxDegr maxSize + + multAux ((l,h), isC, isAC) an b + | isC = + ( + maxP (an *. h) (an *. l) + , + maxP (b *. h) (b *. l) + ) + | isAC = + ( + minP (an *. h) (an *. l) + , + minP (b *. h) (b *. l) + ) + | otherwise = -- enclosure could be a mix of consistent and inconsistent + ( + ((nonnegP an) *. h) + +. + ((nonposP an) *. l) + -- ie: if (l <= h) then max(an*h, an*l) else min(an*h, an*l) + , + ((nonnegP b) *. h) + +. + ((nonposP b) *. l) + -- ie: if (l <= h) then max(b*h, b*l) else min(b*h, b*l) + ) + + nonposP = chplNonposDown maxDegr maxSize + nonnegP = chplNonnegDown maxDegr maxSize + + +ienclSquare :: + (B.ERRealBase b, + DomainBox box varid Int, Ord box, Show varid, + DomainIntBox boxra varid (ERInterval b), + DomainBoxMappable boxra boxras varid (ERInterval b) [ERInterval b]) => + Int {-^ maximum polynomial degree -} -> + Int {-^ maximum term count -} -> + ((ERChebPoly box b, ERChebPoly box b), Bool) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclSquare maxDegr maxSize ie@((ln, h), isAC) = + ienclMultiply maxDegr maxSize ie ie + +-- {- +-- formula: +-- (ln, h)^2 = +-- ( minUp( 0, maxUp( - ln *. ln, - h *. h)), maxUp(ln *^ ln, h *^ h) ) +-- -} +---- | minZeroHelps = +-- = (minZeroMaxNegSq, maxSq) +---- | otherwise = +---- (maxNegSq, maxSq) +-- where +-- maxSq = maxP ln2Up h2Up +-- maxNegSq = maxP (chplNeg ln2Down) (chplNeg h2Down) +-- minZeroMaxNegSq = chplNonposUp maxDegr maxSize maxNegSq +---- minZeroHelps = +---- (maxNegSqUpperB > 0) && (minZeroMaxNegSqUpperB / maxNegSqUpperB < 1/2) +---- maxNegSqUpperB = chplUpperBound 10 maxNegSq +---- minZeroMaxNegSqUpperB = chplUpperBound 10 minZeroMaxNegSq +-- +-- (ln2Down, ln2Up, _) = chplMultiply ln ln +-- (h2Down, h2Up, _) = chplMultiply h h +-- +---- reduceDegrSize = reduceSize maxSize . reduceDegree maxDegr +-- maxP = chplMaxUp maxDegr maxSize + +{-| + Multiply an enclosure by a scalar + assuming the enclosure is non-negative on the whole unit domain. +-} +ienclScaleNonneg :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + b {-^ ratio to scale by -} -> + ((ERChebPoly box b, ERChebPoly box b), Bool) -> + ((ERChebPoly box b, ERChebPoly box b), Bool) +ienclScaleNonneg ratio pEncl@((ln, h), isAC) = + ((ln *. pRatio, h *. pRatio), isAC) + where + pRatio = chplConst ratio + +--{-| +-- Multiply an enclosure by a scalar. +---} +--enclScale :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- b {-^ ratio to scale by -} -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- (ERChebPoly box b, ERChebPoly box b) +--enclScale maxDegree maxSize ratio pEncl = +-- enclMultiply maxDegree maxSize pEncl (enclConst ratio) +-- +--enclRAScale :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- (ERInterval b) -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- (ERChebPoly box b, ERChebPoly box b) +--enclRAScale maxDegree maxSize ra pEncl = +-- enclMultiply maxDegree maxSize pEncl (enclRAConst ra) +-- +--{-| +-- Evaluate the Chebyshev polynomials of the first kind +-- applied to a given polynomial, yielding a list of polynomial enclosures. +---} +--enclEvalTs :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ max degree for result -} -> +-- Int {-^ max approx size for result -} -> +-- (ERChebPoly box b, ERChebPoly box b) {-^ bounds of a polynomial enclosure to evaluate -} -> +-- [(ERChebPoly box b, ERChebPoly box b)] +--enclEvalTs maxDegree maxSize p1@(pLowNeg, pHigh) = +-- chebyIterate (enclConst 1) p1 +-- where +-- chebyIterate pNm2 pNm1 = +-- pNm2 : (chebyIterate pNm1 pN) +-- where +-- pN = +-- (enclScale maxDegree maxSize 2 $ +-- enclMultiply maxDegree maxSize p1 pNm1) +-- -: pNm2 +-- +--{-| +-- Multiply a polynomial by an enclosure using min/max +---} +--enclThinTimes :: +-- (B.ERRealBase b, DomainBox box varid Int, Ord box) => +-- Int {-^ maximum polynomial degree -} -> +-- Int {-^ maximum term count -} -> +-- ERChebPoly box b -> +-- (ERChebPoly box b, ERChebPoly box b) -> +-- (ERChebPoly box b, ERChebPoly box b) +--enclThinTimes maxDegree maxSize p1 (p2LowNeg, p2High) = +-- (prodLowNeg, prodHigh) +-- where +-- prodHigh = +-- chplMaxUp maxDegree maxSize +-- (p1 *^ p2High) +-- (p1n *^ p2LowNeg) -- beware: p1 can cross zero +-- prodLowNeg = +-- chplMaxUp maxDegree maxSize +-- (p1n *^ p2High) +-- (p1 *^ p2LowNeg) +-- p1n = chplNeg p1 +-- +-- diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Eval.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Eval.hs index 6e728e1..6025c1b 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Eval.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Eval.hs @@ -20,8 +20,8 @@ import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic import qualified Data.Number.ER.Real.Approx as RA import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) import Data.Number.ER.Real.Approx.Interval import Data.Number.ER.Misc @@ -39,8 +39,6 @@ chplEval :: chplEval (ERChebPoly coeffs) vals = case resultRA of ERInterval low high -> (low, high) - ERIntervalAny -> (-1/0,1/0) - ERIntervalEmpty -> (1/0, -1/0) where resultRA = sum $ map evalTerm $ Map.toList coeffs diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Integration.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Integration.hs index 400cf5a..dcb6f31 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Integration.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Integration.hs @@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-| Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Integration - Description : (internal) integration of polynomials etc - Copyright : (c) 2007-2008 Michal Konecny + Description : (internal) integration of polynomials + Copyright : (c) 2007-2009 Michal Konecny License : BSD3 Maintainer : mik@konecny.aow.cz @@ -23,8 +23,8 @@ import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) import Data.Number.ER.Real.Approx.Interval import Data.Number.ER.Misc @@ -148,20 +148,4 @@ chplIntegrate x p@(ERChebPoly coeffs) = -- ip = pick $ chplIntegrate x p ---- vars = chplGetVars p --- ---{-| --- Differentiate a polynomial using one of its variables. --- --- This is not implemented yet and will probably never be needed --- because differentiation is not a computable operator --- and thus we have to rely on automatic differentiation --- when we need derivative enclosures. ----} ---chplDifferentiate :: --- (B.ERRealBase b, DomainBox box varid Int, Ord box) => --- ERChebPoly box b -> --- varid {-^ variable to differentiate over -} -> --- ERChebPoly box b ---chplDifferentiate (ERChebPoly coeffs) varName = --- errorModule "chplDifferentiate: not implemented yet" diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Reduce.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Reduce.hs index 61b0e12..1d23cbf 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Reduce.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Reduce.hs @@ -23,8 +23,8 @@ where import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) import Data.Number.ER.Misc import qualified Data.List as List diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Ring.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Ring.hs index 7bf93c5..51a169c 100644 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Ring.hs +++ b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Ring.hs @@ -22,8 +22,8 @@ where import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox) +import qualified Data.Number.ER.BasicTypes.DomainBox as DBox +import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainIntBox) import Data.Number.ER.Misc import qualified Data.Map as Map @@ -34,22 +34,52 @@ import qualified Data.Map as Map chplNeg (ERChebPoly coeffs) = ERChebPoly $ Map.map negate coeffs +chplBall2DownUp :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (ERChebPoly box b, b) -> + (ERChebPoly box b, ERChebPoly box b) +chplBall2DownUp ball = + (down, up) + where + (down, up, _) = chplBall2DownUpWd ball + +chplBall2DownUpWd :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (ERChebPoly box b, b) -> + (ERChebPoly box b, ERChebPoly box b, b) +chplBall2DownUpWd (ERChebPoly coeffsCentre, radius) = + (ERChebPoly coeffsDown, ERChebPoly coeffsUp, 2 * radius) + where + coeffsDown = + Map.insertWith plusDown chplConstTermKey (- radius) coeffsCentre + coeffsUp = + Map.insertWith plusUp chplConstTermKey radius coeffsCentre + +chplBall2Down :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (ERChebPoly box b, b) -> + (ERChebPoly box b) +chplBall2Down = fst . chplBall2DownUp + +chplBall2Up :: + (B.ERRealBase b, DomainBox box varid Int, Ord box) => + (ERChebPoly box b, b) -> + (ERChebPoly box b) +chplBall2Up = snd . chplBall2DownUp + {-| Add a constant to a polynomial, rounding downwards and upwards. -} -chplAddConst :: +ballAddConst :: (B.ERRealBase b, DomainBox box varid Int, Ord box) => b -> - ERChebPoly box b -> - (ERChebPoly box b, ERChebPoly box b, b) - {-^ lower and upper bounds on the sum and an upper bound on their difference -} -chplAddConst c (ERChebPoly coeffs) = - (ERChebPoly sumCoeffsDown, ERChebPoly sumCoeffsUp, err) + (ERChebPoly box b) -> + (ERChebPoly box b, b) +ballAddConst c (ERChebPoly coeffs) = + (ERChebPoly sumCoeffs, err) where - sumCoeffsUp = + sumCoeffs = Map.insert chplConstTermKey newConstUp coeffs - sumCoeffsDown = - Map.insert chplConstTermKey newConstDown coeffs oldConst = case Map.lookup chplConstTermKey coeffs of Just c -> c @@ -58,29 +88,20 @@ chplAddConst c (ERChebPoly coeffs) = newConstDown = oldConst `plusDown` c err = newConstUp - newConstDown -chplAddConstUp c p = (\(sumDown, sumUp, width) -> sumUp) $ chplAddConst c p -chplAddConstDown c p = (\(sumDown, sumUp, width) -> sumDown) $ chplAddConst c p +chplAddConstUp c p = chplBall2Up $ ballAddConst c p +chplAddConstDown c p = chplBall2Down $ ballAddConst c p {-| Add two polynomials, rounding downwards and upwards. -} -chplAdd :: +ballAdd :: (B.ERRealBase b, DomainBox box varid Int, Ord box) => - ERChebPoly box b -> - ERChebPoly box b -> - (ERChebPoly box b, ERChebPoly box b, b) - {-^ lower and upper bounds on the sum and an upper bound on their difference -} -chplAdd (ERChebPoly coeffs1) (ERChebPoly coeffs2) = - (ERChebPoly sumCoeffsDown, ERChebPoly sumCoeffsUp, 2 * maxError) + (ERChebPoly box b) -> + (ERChebPoly box b) -> + (ERChebPoly box b, b) +ballAdd (ERChebPoly coeffs1) (ERChebPoly coeffs2) = + (ERChebPoly coeffsUp, maxError) where - sumCoeffsUp = - Map.insertWith plusUp chplConstTermKey maxError coeffsDown - -- point-wise sum of polynomials with coeff rounding errors - -- compensated for by enlarging the constant term - sumCoeffsDown = - Map.insertWith plusDown chplConstTermKey (- maxError) coeffsUp - -- point-wise sum of polynomials with coeff rounding errors - -- compensated for by enlarging the constant term coeffsUp = (Map.unionWith plusUp coeffs1 coeffs2) -- point-wise sum of polynomials with coeffs rounded upwards @@ -95,33 +116,27 @@ chplAdd (ERChebPoly coeffs1) (ERChebPoly coeffs2) = -- and thus can make the result drop below the exact result -- -> to compensate add the rounding difference to the constant term -p1 +^ p2 = (\(sumDown, sumUp, width) -> sumUp) $ chplAdd p1 p2 -p1 +. p2 = (\(sumDown, sumUp, width) -> sumDown) $ chplAdd p1 p2 -p1 -^ p2 = p1 +^ (chplNeg p2) -p1 -. p2 = p1 +. (chplNeg p2) +p1 +^ p2 = chplBall2Up $ ballAdd p1 p2 +p1 +. p2 = chplBall2Down $ ballAdd p1 p2 +p1 -^ p2 = chplBall2Up $ ballAdd p1 (chplNeg p2) +p1 -. p2 = chplBall2Down $ ballAdd p1 (chplNeg p2) {-| Multiply two polynomials, rounding downwards and upwards. -} -chplMultiply :: +ballMultiply :: (B.ERRealBase b, DomainBox box varid Int, Ord box) => ERChebPoly box b -> ERChebPoly box b -> - (ERChebPoly box b, ERChebPoly box b, b) + (ERChebPoly box b, b) {-^ lower and upper bounds on the product and an upper bound on their difference -} -chplMultiply p1@(ERChebPoly coeffs1) p2@(ERChebPoly coeffs2) = +ballMultiply p1@(ERChebPoly coeffs1) p2@(ERChebPoly coeffs2) = case (chplGetConst p1, chplGetConst p2) of - (Just c1, _) -> chplScale c1 p2 - (_, Just c2) -> chplScale c2 p1 + (Just c1, _) -> ballScale c1 p2 + (_, Just c2) -> ballScale c2 p1 _ -> - (ERChebPoly prodCoeffsDown, ERChebPoly prodCoeffsUp, 2 * roundOffCompensation) + (ERChebPoly directProdCoeffsUp, roundOffCompensation) where - prodCoeffsUp = - Map.insertWith plusUp chplConstTermKey roundOffCompensation $ - Map.map negate directProdCoeffsDownNeg - prodCoeffsDown = - Map.insertWith plusDown chplConstTermKey (- roundOffCompensation) $ - directProdCoeffsUp roundOffCompensation = Map.fold plusUp 0 $ Map.unionWith plusUp directProdCoeffsUp directProdCoeffsDownNeg @@ -169,30 +184,26 @@ chplMultiply p1@(ERChebPoly coeffs1) p2@(ERChebPoly coeffs2) = coeffs2List = Map.toList coeffs2 -p1 *^ p2 = (\(prodDown,prodUp,width) -> prodUp) $ chplMultiply p1 p2 -p1 *. p2 = (\(prodDown,prodUp,width) -> prodDown) $ chplMultiply p1 p2 +p1 *^ p2 = chplBall2Up $ ballMultiply p1 p2 +p1 *. p2 = chplBall2Down $ ballMultiply p1 p2 {-| Multiply a polynomial by a scalar rounding downwards and upwards. -} -chplScale :: +ballScale :: (B.ERRealBase b, DomainBox box varid Int, Ord box) => b -> (ERChebPoly box b) -> - (ERChebPoly box b, ERChebPoly box b, b) + (ERChebPoly box b, b) {-^ lower and upper bounds on the product and an upper bound on their difference -} -chplScale ratio p@(ERChebPoly coeffs) = +ballScale ratio p@(ERChebPoly coeffs) = case chplGetConst p of Just c -> - (chplConst cScaledDown, chplConst cScaledUp, cScaledUp - cScaledDown) + (chplConst cScaledDown, cScaledUp - cScaledDown) where cScaledUp = ratio `timesUp` c cScaledDown = ratio `timesDown` c - _ -> - (ERChebPoly coeffsDown, ERChebPoly coeffsUp, 2 * errBound) + _ -> + (ERChebPoly coeffsScaled, errBound) where - coeffsDown = - Map.insertWith plusDown chplConstTermKey (- errBound) coeffsScaled - coeffsUp = - Map.insertWith plusUp chplConstTermKey errBound coeffsScaled (errBound, coeffsScaled) = Map.mapAccum processTerm 0 coeffs processTerm errBoundPrev coeff = @@ -202,17 +213,14 @@ chplScale ratio p@(ERChebPoly coeffs) = coeffScaledDown = ratio `timesDown` coeff coeffScaledUp = ratio `timesUp` coeff -chplScaleDown r p = (\(prodDown,prodUp,width) -> prodDown) $ chplScale r p -chplScaleUp r p = (\(prodDown,prodUp,width) -> prodUp) $ chplScale r p +chplScaleDown r p = chplBall2Down $ ballScale r p +chplScaleUp r p = chplBall2Up $ ballScale r p {-| Multiply a polynomial by itself, rounding downwards and upwards. -} -chplSquare :: +ballSquare :: (B.ERRealBase b, DomainBox box varid Int, Ord box) => ERChebPoly box b -> - (ERChebPoly box b, ERChebPoly box b) -chplSquare p = - (p2Down, p2Up) - where - (p2Down, p2Up, wd) = chplMultiply p p + (ERChebPoly box b, b) +ballSquare p = ballMultiply p p diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Bounds.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Bounds.hs deleted file mode 100644 index 31a448a..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Bounds.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Bounds - Description : (testing) properties of bounding operations - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Quickcheck properties of bounding operations, ie constant bounds and binary min/max. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Bounds -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate - -import Data.Number.ER.BasicTypes - -import Test.QuickCheck - -prop_chplBounds_consistent (ixI, PSize30 (_,p)) = - ixI >= 2 ==> - ixI < 100 ==> - chplAtKeyPointsCanBeLeq p pHigh - && - chplAtKeyPointsCanBeLeq pLow p - where - pLow = chplConst cLow - pHigh = chplConst cHigh - (cLow, cHigh) = chplBounds ix p - ix = int2effIx ixI - -prop_chplMax_consistent - (Deg20Size20 maxDegree maxSize, PSize30 (_,p1), PSize30 (_, p2)) = - chplAtKeyPointsPointwiseBinaryDownUpConsistent max p1 p2 (maxLow, maxHigh) - where - (maxLow, maxHigh) = chplMax maxDegree maxSize p1 p2 - -prop_chplMin_consistent (Deg20Size20 maxDegree maxSize, PSize30 (_,p1), PSize30 (_, p2)) = - chplAtKeyPointsPointwiseBinaryDownUpConsistent min p1 p2 (minLow, minHigh) - where - (minLow, minHigh) = chplMin maxDegree maxSize p1 p2 - diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Compose.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Compose.hs deleted file mode 100644 index 983ebed..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Compose.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Compose - Description : (testing) properties of enclosure composition - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Quickcheck properties of polynomial enclosure composition. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Compose -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Compose -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate - -import Data.Number.ER.Real.Approx.Interval -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.BasicTypes - -import Data.Number.ER.Misc - -import Test.QuickCheck - -prop_enclCompose_ThinEncl_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - varSelector, - (PSize30 (n1,p1)), - (PSize30 (n2,p2))) = - compose_encl_consistent - reportFileName - maxDegree maxSize - varSelector - n1 p1 n2 p2Encl - where - p2Encl = enclThin p2 - -prop_enclCompose_ThickEncl_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - varSelector, - (PSize30 (n1,p1)), - (PSize30 (n21,p21), PSize30 (n22, p22))) = - compose_encl_consistent - reportFileName - maxDegree maxSize - varSelector - n1 p1 (n21, n22) p2Encl - where - p2Encl = makeThickEncl maxDegree maxSize p21 p22 - -prop_enclCompose_ParalEncl_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - varSelector, - (PSize30 (n1, p1)), - (SmallRatio w2Num w2Denom, PSize30 (n2, p2))) = - compose_encl_consistent - reportFileName - maxDegree maxSize - varSelector - n1 p1 ((w2Num, w2Denom), n2) p2Encl - where - p2Encl = makeParalEncl p2 w2Num w2Denom - -compose_encl_consistent - reportFileName - maxDegree maxSize - varSelector - p1Id p1 p2Id p2Encl@(p2LowNeg, p2High) = --- unsafePrint --- ( --- "compose_encl_consistent: " --- ++ "\n p1 = " ++ show p1 --- ++ "\n substVar = " ++ show substVar --- ++ "\n p2Low = " ++ show (chplNeg p2LowNeg) --- ++ "\n p2High = " ++ show p2High --- ++ "\n composition = " ++ show resEncl --- ++ "\n**********************" --- ) $ - enclAtKeyPointsConsistent - reportFileName - ((maxDegree, maxSize), varSelector, p1Id, p2Id) - composeAtPointInner - allVars - resEncl - where - resEncl = enclCompose maxDegree maxSize p1 substVar p2Encl - substVar = p1Vars !! (varSelector `mod` (length p1Vars)) - p1Vars = chplGetVars p1 - allVars = chplGetVars $ p1 +^ p2LowNeg +^ p2High - p1Encl = (chplNeg p1, p1) - composeAtPointInner point = --- unsafePrintReturn --- ( --- "\n point = " ++ show point --- ++ "\n substVar = " ++ show substVar --- ++ " substVal = " ++ show substVal --- ++ "\n result = " --- ) $ - enclRAEvalInner p1Encl pointWithSubst - where - pointWithSubst = - DBox.insert substVar substVal $ DBox.map (\b -> ERInterval b b) point - substVal = - enclEvalInner p2Encl point - -
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Division.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Division.hs deleted file mode 100644 index ae88609..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Division.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Division - Description : (testing) properties of polynomial enclosure division - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Quickcheck properties of polynomial enclosure division. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Division -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Division -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure ---import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate - -import Data.Number.ER.Real.Approx.Interval - -import Data.Number.ER.BasicTypes - -import Test.QuickCheck - -prop_enclRecip_ThickEncl_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - (Int20 ixInt, Int20 tauDegr), - SmallRatio sepNum sepDenom, - (isNegative, PSize30 (n1,p1), PSize30 (n2, p2))) = - recip_encl_consistent - reportFileName - maxDegree maxSize - ixInt tauDegr - sepNum sepDenom isNegative (n1, n2) preEncl - where - preEncl = makeThickEncl maxDegree maxSize p1 p2 - -prop_enclRecip_ParalEncl_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - (Int20 ixInt, Int20 tauDegr), - SmallRatio sepNum sepDenom, - (isNegative, SmallRatio wNum wDenom, PSize30 (n, p))) = - recip_encl_consistent - reportFileName - maxDegree maxSize - ixInt tauDegr - sepNum sepDenom isNegative ((wNum, wDenom), n) preEncl - where - preEncl = makeParalEncl p wNum wDenom - -recip_encl_consistent - reportFileName - maxDegree maxSize - ixInt tauDegr - sepNum sepDenom isNegative pId preEncl = - excludedZero ==> - enclAtKeyPointsPointwiseUnaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), (ixInt, tauDegr), (sepNum, sepDenom), (isNegative, pId)) - (intervalDivideInner 1) - pEncl resEncl - where - resEncl = enclRecip maxDegree maxSize ix tauDegr pEncl - ix = int2effIx ixInt - (excludedZero, pEncl) = - enclRestrictRange ix rangeNoZero preEncl - rangeNoZero - | isNegative = (Nothing, Just (-sepB)) - | otherwise = (Just sepB, Nothing) - sepB = abs sepNumB / sepDenomB - sepNumB = fromInteger $ toInteger sepNum - sepDenomB = fromInteger $ toInteger sepDenom - -
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Elementary.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Elementary.hs deleted file mode 100644 index 0ef00d8..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Elementary.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Elementary - Description : (testing) properties of enclosure elementary operations - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Quickcheck properties of some elementary operations on primitive polynomial - enclosures. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Elementary -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Elementary -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure ---import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.Real.Approx.Interval -import Data.Number.ER.Real.Arithmetic.Elementary - -import Data.Number.ER.BasicTypes - -import Test.QuickCheck - -prop_enclExp_ThickEncl_consistent = - encl_op_ThickEncl_consistent enclExp erExp_IR_Inner noDomainRestriction - -prop_enclExp_ParalEncl_consistent = - encl_op_ParalEncl_consistent enclExp erExp_IR_Inner noDomainRestriction - -prop_enclExp_ThinEncl_consistent = - encl_op_ThinEncl_consistent enclExp erExp_IR_Inner noDomainRestriction - -prop_enclSine_ThickEncl_consistent = - encl_op_ThickEncl_consistent enclSine erSine_IR_Inner sincosDomain - -prop_enclSine_ParalEncl_consistent = - encl_op_ParalEncl_consistent enclSine erSine_IR_Inner sincosDomain - -prop_enclSine_ThinEncl_consistent = - encl_op_ThinEncl_consistent enclSine erSine_IR_Inner sincosDomain - -prop_enclCosine_ThickEncl_consistent = - encl_op_ThickEncl_consistent enclCosine erCosine_IR_Inner sincosDomain - -prop_enclCosine_ParalEncl_consistent = - encl_op_ParalEncl_consistent enclCosine erCosine_IR_Inner sincosDomain - -prop_enclCosine_ThinEncl_consistent = - encl_op_ThinEncl_consistent enclCosine erCosine_IR_Inner sincosDomain - -prop_enclAtan_ThickEncl_consistent = - encl_op_ThickEncl_consistent enclAtan erATan_IR_Inner noDomainRestriction - -prop_enclAtan_ParalEncl_consistent = - encl_op_ParalEncl_consistent enclAtan erATan_IR_Inner noDomainRestriction - -prop_enclAtan_ThinEncl_consistent = - encl_op_ThinEncl_consistent enclAtan erATan_IR_Inner noDomainRestriction - -sincosDomain = (Just (-1.57), Just 1.57) -- almost (-pi/2, pi/2) -noDomainRestriction = (Nothing, Nothing) - -encl_op_ThickEncl_consistent - opEncl opInner rangeRestriction - reportFileName - (Deg20Size20 maxDegree maxSize, - (Int20 ixInt), - (PSize30 (n1,p1), PSize30 (n2, p2))) = - enclAtKeyPointsPointwiseUnaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), ixInt, (n1, n2)) - (opInner ix) - pEncl resEncl - where - (succeeded, pEncl) = - enclRestrictRange ix rangeRestriction $ makeThickEncl maxDegree maxSize p1 p2 - resEncl = opEncl maxDegree maxSize ix pEncl - ix = int2effIx ixInt - -encl_op_ParalEncl_consistent - opEncl opInner rangeRestriction - reportFileName - (Deg20Size20 maxDegree maxSize, - (Int20 ixInt), - (SmallRatio wNum wDenom, PSize30 (n, p))) = - enclAtKeyPointsPointwiseUnaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), ixInt, ((wNum, wDenom), n)) - (opInner ix) - pEncl resEncl - where - (succeeded, pEncl) = - enclRestrictRange ix rangeRestriction $ makeParalEncl p wNum wDenom - resEncl = opEncl maxDegree maxSize ix pEncl - ix = int2effIx ixInt - -encl_op_ThinEncl_consistent - opEncl opInner rangeRestriction - reportFileName - (Deg20Size20 maxDegree maxSize, - (Int20 ixInt), - (PSize30 (n, p))) = - enclAtKeyPointsPointwiseUnaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), ixInt, n) - (opInner ix) - pEncl resEncl - where - (succeeded, pEncl) = - enclRestrictRange ix rangeRestriction $ enclThin p - resEncl = opEncl maxDegree maxSize ix pEncl - ix = int2effIx ixInt - -
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Enclosure.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Enclosure.hs deleted file mode 100644 index 2fe024c..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Enclosure.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Enclosure - Description : (testing) properties of basic enclosure operations - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Quickcheck properties of basic enclosure operations, - mainly ring operations. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Enclosure -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate - -import Data.Number.ER.Real.Approx.Interval - -prop_enclAdd_ThickEncls_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - (PSize30 (n11,p11), PSize30 (n12, p12)), - (PSize30 (n21,p21), PSize30 (n22, p22))) = - enclAtKeyPointsPointwiseBinaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), (n11, n12), (n21, n22)) - intervalPlusInner - p1Encl p2Encl sumEncl - where - sumEncl = p1Encl +: p2Encl - p1Encl = makeThickEncl maxDegree maxSize p11 p12 - p2Encl = makeThickEncl maxDegree maxSize p21 p22 - -prop_enclMultiply_ThickEncls_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - (PSize30 (n11,p11), PSize30 (n12, p12)), - (PSize30 (n21,p21), PSize30 (n22, p22))) = - enclAtKeyPointsPointwiseBinaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), (n11, n12), (n21, n22)) - intervalTimesInner - p1Encl p2Encl prodEncl - where - prodEncl = enclMultiply maxDegree maxSize p1Encl p2Encl - p1Encl = makeThickEncl maxDegree maxSize p11 p12 - p2Encl = makeThickEncl maxDegree maxSize p21 p22 - -prop_enclMultiply_ParalEncls_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - (SmallRatio num1 denom1, - PSize30 (n1,p1)), - (SmallRatio num2 denom2, - PSize30 (n2,p2))) = - enclAtKeyPointsPointwiseBinaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), ((num1, denom1), n1), ((num2, denom2), n2)) - intervalTimesInner - p1Encl p2Encl prodEncl - where - prodEncl = enclMultiply maxDegree maxSize p1Encl p2Encl - p1Encl = makeParalEncl p1 num1 denom1 - p2Encl = makeParalEncl p2 num2 denom2 - -prop_enclScale_ThickEncl_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - SmallRatio num denom, - PSize30 (n1, p1), - PSize30 (n2, p2)) = - enclAtKeyPointsPointwiseBinaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), (num, denom), (n1, n2)) - intervalTimesInner - cEncl pEncl scaledEncl - where - scaledEncl = enclScale maxDegree maxSize cB pEncl - pEncl = makeThickEncl maxDegree maxSize p1 p2 - cEncl = enclConst cB - cB = numB / denomB - numB = fromInteger $ toInteger num - denomB = fromInteger $ toInteger denom - -prop_enclScale_ParalEncl_consistent - reportFileName - (Deg20Size20 maxDegree maxSize, - SmallRatio cNum cDenom, - (SmallRatio wNum wDenom, PSize30 (n, p))) = - enclAtKeyPointsPointwiseBinaryDownUpConsistent - reportFileName - ((maxDegree, maxSize), (cNum, cDenom), ((wNum, wDenom), n)) - intervalTimesInner - cEncl pEncl scaledEncl - where - scaledEncl = enclScale maxDegree maxSize cB pEncl - pEncl = makeParalEncl p wNum wDenom - cEncl = enclConst cB - cB = cNumB / cDenomB - cNumB = fromInteger $ toInteger cNum - cDenomB = fromInteger $ toInteger cDenom - -
\ No newline at end of file diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Generate.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Generate.hs deleted file mode 100644 index 6f9c74c..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Generate.hs +++ /dev/null @@ -1,592 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate - Description : (testing) generating polynomials for tests - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - A collection of polynomials to pick from when testing. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Eval -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Bounds -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Enclosure - -import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.Real.DomainBox as DBox -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) -import Data.Number.ER.Misc -import Data.Number.ER.BasicTypes - -import Data.Number.ER.Real.DefaultRepr -import Data.Number.ER.Real.DomainBox.IntMap -import Data.Number.ER.Real.Approx.Interval -import qualified Data.Number.ER.Real.Approx as RA - - -import Test.QuickCheck hiding (two, three) - -import qualified Data.Map as Map - -{---------------------} -{----- Type synonyms for different polynomial generation distributions ----} -{---------------------} - -type P = ERChebPoly (Box Int) BM - -newtype PNoLimits = PNoLimits (Int, P) deriving (Show) -newtype PSize10Degree3 = PSize10Degree3 (Int, P) deriving (Show) -newtype PSize10Degree10 = PSize10Degree10 (Int, P) deriving (Show) -newtype PSize10 = PSize10 (Int, P) deriving (Show) -newtype PSize30 = PSize30 ((Int, Int), P) deriving (Show) - -instance (Arbitrary PNoLimits) - where - arbitrary = - elements $ map PNoLimits $ zip [0..] $ - polynomials1200ish id - coarbitrary p = - error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for polynomials" - -instance (Arbitrary PSize10Degree3) - where - arbitrary = - elements $ map PSize10Degree3 $ zip [0..] $ polynomials1200ishSize10Degree3 - coarbitrary (PSize10Degree3 p) = - error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for polynomials" - -polynomials1200ishSize10Degree3 = - polynomials1200ish $ chplReduceTermCountUp 10 . chplReduceDegreeUp 3 - -instance (Arbitrary PSize10Degree10) - where - arbitrary = - elements $ map PSize10Degree10 $ zip [0..] $ - polynomials1200ishSize10Degree10 - coarbitrary (PSize10Degree10 p) = - error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for polynomials" - -polynomials1200ishSize10Degree10 = - polynomials1200ish $ chplReduceTermCountUp 10 . chplReduceDegreeUp 10 - -instance (Arbitrary PSize10) - where - arbitrary = - elements $ map PSize10 $ zip [0..] $ polynomials1200ishSize10 - - coarbitrary (PSize10 p) = - error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for polynomials" - -polynomials1200ishSize10 = - polynomials1200ish $ chplReduceTermCountUp 10 - -instance (Arbitrary PSize30) - where - arbitrary = - sized arbitrarySized - where - arbitrarySized n - | n <= 28 = - elements $ map PSize30 $ - zip (map (\n -> (0,n)) [0..]) $ - polynomials200ishSize30 - | otherwise = - elements $ map PSize30 $ - zip (map (\n -> (1,n)) [0..]) $ - polynomials1200ishSize30 - coarbitrary (PSize30 p) = - error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for polynomials" - -polynomials1200ishSize30 = - polynomials1200ish $ chplReduceTermCountUp 30 - -polynomials200ishSize30 = - polynomials200ishSmall $ chplReduceTermCountUp 30 - -data Int20 = Int20 Int deriving (Show) - -instance (Arbitrary Int20) - where - arbitrary = - do - n <- choose (2,20) - return $ Int20 n - coarbitrary (Int20 n) = - error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for EffIx20" - -data Deg20Size20 = Deg20Size20 Int Int deriving (Show) - -instance (Arbitrary Deg20Size20) - where - arbitrary = - do - maxDegree <- choose (2,20) - maxSize <- choose (10,20) - return $ Deg20Size20 maxDegree maxSize - coarbitrary (Deg20Size20 maxDegree maxSize) = - error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for Deg20Size20" - -data SmallRatio = SmallRatio Int Int deriving (Show) - -instance (Arbitrary SmallRatio) - where - arbitrary = - do - num <- choose (-1000000,1000000) - denom <- choose (1,1000000) - return $ SmallRatio num denom - coarbitrary (SmallRatio num denom) = - error "ERChebPoly: Generate: Arbitrary: coarbitrary not implemented for SmallRatio" - - -{------------------} -{-------- Functions commonly used in tests: ----------} -{------------------} - -chplAtKeyPointsCanBeLeq :: - (B.ERRealBase b, DomainBox box varid Int, Ord box, - DomainBoxMappable boxb boxbb varid b [ERInterval b], Show boxb) => - ERChebPoly box b -> - ERChebPoly box b -> - Bool -chplAtKeyPointsCanBeLeq p1 p2 = - and $ map testPoint points - where - points = getKeyPoints (p1 +^ p2) - testPoint point - | lower1 <= upper2 = - True - | otherwise = - unsafePrint - ( - "Failure at point = " ++ (show point) - ) $ - False - where - lower1 = chplEvalDown p1 point - upper2 = chplEvalUp p2 point - -getKeyPoints p = - getKeyPointsForVars $ chplGetVars p - -getKeyPointsForVars vars = - points - where - points = map DBox.fromList $ allCombinations $ map getVarPoints varDoms - varDoms = map (\v -> (v,unitInterval)) vars - unitInterval = ERInterval (-1) 1 - getVarPoints (var, dom) = - (var, [domLB, domMB, domRB]) - where - ERInterval domLB domRB = dom - domMB = (domLB + domRB)/2 - -chplAtKeyPointsPointwiseBinaryDownUpConsistent :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box, - DomainBoxMappable boxb boxbb varid b [ERInterval b], Show boxb) => - ((ERInterval b) -> (ERInterval b) -> (ERInterval b)) -> - ERChebPoly box b -> - ERChebPoly box b -> - (ERChebPoly box b, ERChebPoly box b) -> - Bool -chplAtKeyPointsPointwiseBinaryDownUpConsistent raOp p1 p2 (resLow, resHigh) = - and $ map testPoint points - where - points = getKeyPoints (p1 +^ p2) - testPoint point - | ok = ok - | otherwise = - unsafePrint - ( - "chplAtKeyPointsPointwiseBinaryDownUpConsistent failed:" - ++ "\n point = " ++ show point - ++ "\n raOpAtPointHigh = " ++ show raOpAtPointHigh - ++ "\n raOpAtPointLow = " ++ show raOpAtPointLow - ++ "\n resAtPointHigh = " ++ show resAtPointHigh - ++ "\n resAtPointLow = " ++ show resAtPointLow - ) - ok - where - ok = - raOpAtPointLow <= resAtPointHigh - && - raOpAtPointHigh >= resAtPointLow - resAtPointLow = chplEvalDown resLow point - resAtPointHigh = chplEvalUp resHigh point - raOpAtPoint@(ERInterval raOpAtPointLow raOpAtPointHigh) = - raOp p1AtPoint p2AtPoint - p1AtPoint = ERInterval p1AtPointLow p1AtPointHigh - (p1AtPointLow, p1AtPointHigh) = chplEval p1 point - p2AtPoint = ERInterval p2AtPointLow p2AtPointHigh - (p2AtPointLow, p2AtPointHigh) = chplEval p2 point - -makeThickEncl maxDegree maxSize p1 p2 = - (pMax q1Neg q2Neg, pMax q1 q2) - where - q1Neg = chplNeg q1 - q2Neg = chplNeg q2 - q1 = p1 +^ p2Mp1ScaledDown - q2 = p1 -^ p2Mp1ScaledDown - p2Mp1ScaledDown = - chplScaleUp (10/sizeB) p2Mp1 - where - sizeB = max (abs upperB) (abs lowerB) - (lowerB, upperB) = chplBounds 10 p2Mp1 - p2Mp1 = p2 -^ p1 - pMax = chplMaxUp maxDegree maxSize - -makeParalEncl p num denom = --- unsafePrintReturn --- ( --- "makeThinEncl: result = " --- ) - (pNeg, p +^ cP) - where - pNeg = chplNeg p - cP = chplConst cB - cB = abs $ numB / (1000 * denomB) - numB = fromInteger $ toInteger num - denomB = fromInteger $ toInteger denom - -enclRestrictRange ix (Nothing, Nothing) pEncl = (True, pEncl) -enclRestrictRange ix (maybeLower, maybeUpper) preEncl = - (succeeded, pEncl) - where - succeeded = lowerSucceeded && upperSucceeded - lowerSucceeded = - case maybeLower of - Nothing -> True - Just lower -> pLowerBound > lower - upperSucceeded = - case maybeUpper of - Nothing -> True - Just upper -> pUpperBound < upper - (pLowerBound, pUpperBound) = enclBounds ix pEncl - pEncl = - case (maybeLower, maybeUpper) of - (Just lowerB, Nothing) -> - case lowerB <= preLowerBoundB of - True -> preEncl -- enclosure already in the range - False -> -- a shift needed to get above the lower bound - enclAddConst (lowerB - preLowerBoundB + sepB) preEncl - (Nothing, Just upperB) -> - case preUpperBoundB <= upperB of - True -> preEncl -- enclosure already in the range - False -> -- a shift needed to get below the upper bound - enclAddConst (upperB - preUpperBoundB - sepB) preEncl - (Just lowerB, Just upperB) -> - case lowerB <= preLowerBoundB && preUpperBoundB <= upperB of - True -> preEncl -- enclosure already in the range - _ -> - case preWidthB + sepB <= widthB of - True -> -- no scaling needed, only shifting by a constant to the centre of the range - enclAddConst - (lowerB - preLowerBoundB + (preWidthB - widthB)/2) - preEncl - _ -> -- full affine transformation needed - enclAddConst - (lowerB + sepB) $ - enclScaleNonneg -- scale preEncl so that it fits inside the range - (widthB / saferPreWidthB) $ - enclAddConst -- shift preEncl so that it is non-negative and as close to 0 as safely possible - (sepB - preLowerBoundB) - preEncl - where - widthB = upperB - lowerB - saferPreWidthB = preWidthB + 2 * sepB - sepB = preWidthB / 1000000 - preWidthB = preUpperBoundB - preLowerBoundB - (preLowerBoundB, preUpperBoundB) = enclBounds ix preEncl - - - -enclAtKeyPointsPointwiseBinaryDownUpConsistent :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box, - DomainBoxMappable boxb boxbb varid b [ERInterval b], Show boxb, Show testId) => - String {-^ report file name -} -> - testId {-^ item to identify the random input given to the test -} -> - ((ERInterval b) -> (ERInterval b) -> (ERInterval b)) - {-^ this real approx operation has to return an inner approximation of the exact result set, - ie each number that the approximation supports is in the maximal extension -} -> - (ERChebPoly box b, ERChebPoly box b) {-^ enclosure of argument 1 -} -> - (ERChebPoly box b, ERChebPoly box b) {-^ enclosure of argument 2 -} -> - (ERChebPoly box b, ERChebPoly box b) {-^ alleged enclosure of result -} -> - Bool -enclAtKeyPointsPointwiseBinaryDownUpConsistent - reportFileName testId - raOpInner - p1Encl@(p1LowNeg, p1High) p2Encl@(p2LowNeg, p2High) resEncl = - and $ map testPoint points - where - points = getKeyPoints (p1High +^ p2High +^ p1LowNeg +^ p2LowNeg) - testPoint point - | result = - unsafeReport reportFileName - ( - show $ - (testId, point, p1OpInnerP2AtPoint, resAtPoint) - ) - result - | otherwise = - unsafePrint - ( - "enclAtKeyPointsPointwiseBinaryDownUpConsistent failed" - ++ "\n point = " ++ show point - ++ "\n p1AtPoint = " ++ show p1AtPoint - ++ "\n p2AtPoint = " ++ show p2AtPoint - ++ "\n p1OpInnerP2AtPoint = " ++ show p1OpInnerP2AtPoint - ++ "\n resAtPoint = " ++ show resAtPoint - ) $ - result - where - result = p1OpInnerP2AtPoint `RA.refines` resAtPoint - p1OpInnerP2AtPoint = p1AtPoint `raOpInner` p2AtPoint - resAtPoint = enclEval resEncl point --- resAtPoint = p1OpInnerP2AtPoint -- for dummy testing that never <<loop>>s - p1AtPoint = normaliseERInterval $ enclEvalInner p1Encl point - p2AtPoint = normaliseERInterval $ enclEvalInner p2Encl point - -enclAtKeyPointsPointwiseUnaryDownUpConsistent :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box, - DomainBoxMappable boxb boxbb varid b [ERInterval b], Show boxb, Show testId) => - String {-^ report file name -} -> - testId {-^ item to identify the random input given to the test -} -> - ((ERInterval b) -> (ERInterval b)) - {-^ this real approx operation has to return an inner approximation of the exact result set, - ie each number that the approximation supports is in the maximal extension -} -> - (ERChebPoly box b, ERChebPoly box b) {-^ enclosure of argument -} -> - (ERChebPoly box b, ERChebPoly box b) {-^ alleged enclosure of result -} -> - Bool -enclAtKeyPointsPointwiseUnaryDownUpConsistent - reportFileName testId - raOpInner - pEncl@(pLowNeg, pHigh) resEncl = - and $ map testPoint points - where - points = getKeyPoints (pHigh +^ pLowNeg) - testPoint point - | result = - unsafeReport reportFileName - ( - show $ - (testId, point, opInnerPAtPoint, resAtPoint) - ) - result - | otherwise = - unsafePrint - ( - "enclAtKeyPointsPointwiseUnaryDownUpConsistent failed" - ++ "\n point = " ++ show point - ++ "\n pAtPoint = " ++ show pAtPoint - ++ "\n opInnerPAtPoint = " ++ show opInnerPAtPoint - ++ "\n resAtPoint = " ++ show resAtPoint - ) $ - result - where - result = opInnerPAtPoint `RA.refines` resAtPoint - opInnerPAtPoint = raOpInner pAtPoint - resAtPoint = enclEval resEncl point - pAtPoint = --- normaliseERInterval $ - enclEvalInner pEncl point - - -enclAtKeyPointsConsistent :: - (B.ERRealBase b, RealFrac b, DomainBox box varid Int, Ord box, - DomainBoxMappable boxb boxbb varid b [ERInterval b], Show boxb, Show testId) => - String {-^ report file name -} -> - testId {-^ item to identify the random input given to the test -} -> - (boxb -> (ERInterval b)) - {-^ this operation has to return an inner approximation of the exact result set, - ie each number that the approximation supports is a solution in the maximal extension -} -> - [varid] {-^ variables to test over -} -> - (ERChebPoly box b, ERChebPoly box b) {-^ alleged enclosure of result -} -> - Bool -enclAtKeyPointsConsistent - reportFileName testId - opInner allVars resEncl@(resLowNeg, resHigh) = - and $ map testPoint points - where - points = getKeyPointsForVars allVars - testPoint point - | result = - unsafeReport reportFileName - ( - show $ - (testId, point, opInnerAtPoint, resAtPoint) - ) - result - | otherwise = - unsafePrint - ( - "enclAtKeyPointsConsistent failed" - ++ "\n point = " ++ show point - ++ "\n opInnerAtPoint = " ++ show opInnerAtPoint - ++ "\n resAtPoint = " ++ show resAtPoint - ) $ - result - where - result = opInnerAtPoint `RA.refines` resAtPoint - opInnerAtPoint = opInner point - resAtPoint = enclEval resEncl point - - -{------------------} -{-------- A diverse collection of polynomials to pick from: ----------} -{------------------} - -type E = (P,P) - -vars :: [P] -vars = map chplVar [0..7] - -varsE :: [E] -varsE = map (\p -> (chplNeg p, p)) vars - -x0 = vars !! 0 -x1 = vars !! 1 -x2 = vars !! 2 -x3 = vars !! 3 -x4 = vars !! 4 - -x0E = varsE !! 0 -x1E = varsE !! 1 -x2E = varsE !! 2 -x3E = varsE !! 3 -x4E = varsE !! 4 - -one :: P -[mone, one, two, three, seven, thousand, million, tiny, huge] = - map chplConst - [-1,1,2,3,7,1000,1000000,10^^(-200),10^^200] - -oneE :: E -[moneE, oneE, twoE, threeE, sevenE, thousandE, millionE, tinyE, hugeE] = - map (\ c -> (chplConst (-c), chplConst c)) - [-1,1,2,3,7,1000,1000000,10^^(-200),10^^200] - -polynomials1200ish rdc = - concat $ map (powers10 rdc) $ - concat $ map addConsts3 $ - concat $ map multConsts3 $ - polyBase13 - -polynomials200ish rdc = - concat $ map (powers4 rdc) $ - concat $ map addConsts3 $ - concat $ map multConsts3 $ - polyBase5 - -polynomials40ish rdc = - concat $ map (powers2 rdc) $ - concat $ map addConsts2 $ - concat $ map multConsts2 $ - polyBase5 - -polynomials200ishSmall rdc = - concat $ map (powers4Small rdc) $ - concat $ map addConsts3 $ - concat $ map multConsts3 $ - polyBase5 - -polynomials40ishSmall rdc = - concat $ map (powers2Small rdc) $ - concat $ map addConsts2 $ - concat $ map multConsts2 $ - polyBase5 - - -polyBase5 = - [ - (two *^ x0) +^ x1 - , - (seven *^ x0) -^ x1 - , - (tiny *^ x0) +^ x1 - , - x0 -^ x1 *^ x2 - , - x0 -^ x1 +^ x2 -^ x3 +^ x4 - ] - -polyBase13 = - [ - x0 - , - x0 +^ x1 - , - x0 -^ x1 - , - (two *^ x0) +^ x1 - , - (two *^ x0) -^ x1 - , - (seven *^ x0) +^ x1 - , - (seven *^ x0) -^ x1 - , - (tiny *^ x0) +^ x1 - , - (tiny *^ x0) -^ x1 - , - x0 -^ x1 +^ x2 - , - x0 -^ x1 *^ x2 - , - x0 +^ x1 +^ x2 +^ x3 +^ x4 - , - x0 -^ x1 +^ x2 -^ x3 +^ x4 - ] - -powersAll rdc p = - powersAux [p, rdc $ p *^ p] - where - powersAux (pNHalfM1 : pNHalf : rest) = - pNHalfM1 : (powersAux $ (pNHalf : rest) ++ [pNM1, pN]) - where - pNM1 = rdc $ pNHalf *^ pNHalfM1 - pN = rdc $ pNHalf *^ pNHalf - -powersForExps rdc p exponents = - map pw exponents - where - pw n = pws !! (n - 1) - pws = powersAll rdc p - -powers10 rdc p = - powersForExps rdc p [1..10] - -powers4 rdc p = - powersForExps rdc p [1,3,5,7] - -powers4Small rdc p = - powersForExps rdc p [1,2,3,5] - -powers2 rdc p = - powersForExps rdc p [1,7] - -powers2Small rdc p = - powersForExps rdc p [1,3] - -addConsts3 p = - [p +^ one, p +^ three, p +^ seven] - -multConsts3 p = - [p *^ two, p *^ three, p *^ seven] - -addConsts2 p = - [p +^ one, p +^ three] - -multConsts2 p = - [p *^ two, p *^ seven] - diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Reduce.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Reduce.hs deleted file mode 100644 index 4d954b6..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Reduce.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Reduce - Description : (testing) properties of reduction operations - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Quickcheck properties of operations that reduce the size of polynomials. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Reduce -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Reduce -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate - -import Test.QuickCheck - -prop_chplReduceTermCount_consistent (PSize30 (_,p), Deg20Size20 _ maxSize) = - maxSize < chplCountTerms p ==> - chplAtKeyPointsCanBeLeq p pUp - && - chplAtKeyPointsCanBeLeq pDown p - where - (pDown, pUp) = chplReduceTermCount maxSize p - - -prop_chplReduceDegree_consistent (PSize30 (_,p), Deg20Size20 maxDegree _) = - maxDegree < chplGetDegree p ==> - chplAtKeyPointsCanBeLeq p pUp - && - chplAtKeyPointsCanBeLeq pDown p - where - (pDown, pUp) = chplReduceDegree maxDegree p diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Ring.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Ring.hs deleted file mode 100644 index fae2a10..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Ring.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Ring - Description : (testing) properties of ring operations - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Quickcheck properties of ring operations, ie addition and multiplication. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Ring -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Ring -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Basic -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate - -prop_chplAdd_consistent (PSize30 (_,p1), PSize30 (_, p2)) = - chplAtKeyPointsPointwiseBinaryDownUpConsistent (+) p1 p2 (sumLow, sumHigh) - where - (sumLow, sumHigh, _) = chplAdd p1 p2 - -prop_chplAddConst_consistent (SmallRatio num denom, PSize30 (_, p)) = - chplAtKeyPointsPointwiseBinaryDownUpConsistent (+) cP p (sumLow, sumHigh) - where - (sumLow, sumHigh, _) = chplAddConst cB p - cP = chplConst cB - cB = numB / denomB - numB = fromInteger $ toInteger num - denomB = fromInteger $ toInteger denom - -prop_chplMult_consistent (PSize30 (_,p1), PSize30 (_, p2)) = - chplAtKeyPointsPointwiseBinaryDownUpConsistent (*) p1 p2 (prodLow, prodHigh) - where - (prodLow, prodHigh, _) = chplMultiply p1 p2 - -prop_chplScale_consistent (SmallRatio num denom, PSize30 (_, p)) = - chplAtKeyPointsPointwiseBinaryDownUpConsistent (*) cP p (prodLow, prodHigh) - where - (prodLow, prodHigh, _) = chplScale cB p - cP = chplConst cB - cB = numB / denomB - numB = fromInteger $ toInteger num - denomB = fromInteger $ toInteger denom - diff --git a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Run.hs b/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Run.hs deleted file mode 100644 index edca3f6..0000000 --- a/src/Data/Number/ER/RnToRm/UnitDom/ChebyshevBase/Polynom/Tests/Run.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-| - Module : Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Run - Description : (testing) running all polynomial tests in a batch - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Support for running all polynomial tests in a batch. --} -module Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Run -where - -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Generate -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Reduce -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Ring -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Bounds -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Enclosure -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Division -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Elementary -import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Compose ---import Data.Number.ER.RnToRm.UnitDom.ChebyshevBase.Polynom.Tests.Integration - -import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB -import qualified Data.Number.ER.Real.Base as B -import Data.Number.ER.Real.Approx.Interval -import Data.Number.ER.Real.Arithmetic.Elementary -import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) - -import Data.Number.ER.Real.DefaultRepr -import Data.Number.ER.Misc - -import Test.QuickCheck -import Test.QuickCheck.Batch - -import System.IO -import System.Directory -import qualified System.FilePath as FP -import Data.Time.Clock -import Data.Time.Calendar - -initArith = B.initialiseBaseArithmetic (0::BM) - -runPolynomTests = - do - (UTCTime (ModifiedJulianDay days) secs) <- getCurrentTime - let folder = "tests-" ++ (show days) ++ "-" ++ (show $ floor $ toRational secs) - createDirectory folder --- mkRunTests "poly tests" chplTestOptions (chplTests folder) - mkRunTests "poly tests" chplTestOptions (enclTests folder) - -instance Show TestResult - where - show result = - case result of - TestOk msg ntest stamps -> - msg ++ " " ++ show ntest ++ " " -- ++ show stamps - TestExausted msg ntest stamps -> - msg ++ " " ++ show ntest ++ " " -- ++ show stamps - TestAborted exception -> - "aborted: " ++ show exception - TestFailed args ntest -> - "failed after " ++ show ntest ++ " tests" - ++ "\n args = " ++ show args - -mkRunTests testsetName options tests = - do - initArith - mapM (mkRunTest $ length tests) $ zip [1..] tests - return () - where - mkRunTest testCount (n, (testName, test)) = - do - putStr testDescr - result <- test options - putStrLn $ " result: " ++ show result --- runTests testDescr options [test] - hFlush stdout - where - testDescr = - "(" ++ show n ++ "/" ++ show testCount ++ ") " ++ testsetName ++ ": " ++ testName ++ "\n" - -chplTestOptions = - TestOptions - { --- no_of_tests = 10 --- no_of_tests = 50 - no_of_tests = 100 --- no_of_tests = 200 - , - length_of_tests = 240 * 3600 -- ie 4h time limit - , - debug_tests = False - } - -chplTests folder = - [ - ("reduce term count", run prop_chplReduceTermCount_consistent), - ("reduce degree", run prop_chplReduceDegree_consistent), - ("add two polys", run prop_chplAdd_consistent), - ("add const to poly", run prop_chplAddConst_consistent), - ("mult two polys", run prop_chplMult_consistent), - ("scale poly", run prop_chplScale_consistent), - ("bounds of poly", run prop_chplBounds_consistent), - ("max of two polys", run prop_chplMax_consistent), - ("min of two polys", run prop_chplMin_consistent) - ] -enclTests folder = - [ - ("add thick encls", run $ prop_enclAdd_ThickEncls_consistent $ addFolder "enclAdd_Thick"), - ("mult paral encls", run $ prop_enclMultiply_ParalEncls_consistent $ addFolder "enclMultiply_Paral"), - ("mult thick encls", run $ prop_enclMultiply_ThickEncls_consistent $ addFolder "enclMultiply_Thick"), - ("scale paral encl", run $ prop_enclScale_ParalEncl_consistent $ addFolder "enclScale_Paral"), - ("scale thick encl", run $ prop_enclScale_ThickEncl_consistent $ addFolder "enclScale_Thick"), - ("recip paral encl", run $ prop_enclRecip_ParalEncl_consistent $ addFolder "enclRecip_Paral"), - ("recip thick encl", run $ prop_enclRecip_ThickEncl_consistent $ addFolder "enclRecip_Thick"), - ("compose thin encl", run $ prop_enclCompose_ThinEncl_consistent $ addFolder "enclCompose_Thin"), - ("compose paral encl", run $ prop_enclCompose_ParalEncl_consistent $ addFolder "enclCompose_Paral"), - ("compose thick encl", run $ prop_enclCompose_ThickEncl_consistent $ addFolder "enclCompose_Thick"), - ("exp thin encl", run $ prop_enclExp_ThinEncl_consistent $ addFolder "enclExp_Thin"), - ("exp paral encl", run $ prop_enclExp_ParalEncl_consistent $ addFolder "enclExp_Paral"), - ("exp thick encl", run $ prop_enclExp_ThickEncl_consistent $ addFolder "enclExp_Thick"), - ("sine thin encl", run $ prop_enclSine_ThinEncl_consistent $ addFolder "enclSine_Thin"), - ("sine paral encl", run $ prop_enclSine_ParalEncl_consistent $ addFolder "enclSine_Paral"), - ("sine thick encl", run $ prop_enclSine_ThickEncl_consistent $ addFolder "enclSine_Thick"), - ("cosine thin encl", run $ prop_enclCosine_ThinEncl_consistent $ addFolder "enclCosine_Thin"), - ("cosine paral encl", run $ prop_enclCosine_ParalEncl_consistent $ addFolder "enclCosine_Paral"), - ("cosine thick encl", run $ prop_enclCosine_ThickEncl_consistent $ addFolder "enclCosine_Thick"), - ("atan thin encl", run $ prop_enclAtan_ThinEncl_consistent $ addFolder "enclAtan_Thin"), - ("atan paral encl", run $ prop_enclAtan_ParalEncl_consistent $ addFolder "enclAtan_Paral"), - ("atan thick encl", run $ prop_enclAtan_ThickEncl_consistent $ addFolder "enclAtan_Thick") - ] - where - addFolder name = FP.combine folder name - - --- failed tests: - ---failed1 = --- -- identified 19 Feb 9:33 --- -- fixed 19 Feb 16:50 --- prop_enclCompose_ThickEncl_consistent "a" --- (Deg20Size20 4 18, 0, --- PSize30 ((0,112), polynomials200ishSize30 !! 112), --- (PSize30 ((0,57), polynomials200ishSize30 !! 57), --- PSize30 ((0,18), polynomials200ishSize30 !! 18) --- ) --- ) - -failed2 = - -- identified 19 Feb 18:59 -- this one makes the automatic test abort with <<loop>> - -- but runs ok when executed individually - prop_enclMultiply_ParalEncls_consistent "a" - (Deg20Size20 5 11, - (SmallRatio 680377 535300, PSize30 ((1,1018), polynomials1200ishSize30 !! 1018)), - (SmallRatio (-157647) 491208, PSize30 ((1,465), polynomials1200ishSize30 !! 465)) - ) diff --git a/tests/RunPolynomTests.hs b/tests/RunPolynomTests.hs new file mode 100644 index 0000000..57b2095 --- /dev/null +++ b/tests/RunPolynomTests.hs @@ -0,0 +1,51 @@ +{-| + Module : Main + Description : laucher for polynomial arith tests + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mik@konecny.aow.cz + Stability : experimental + Portability : portable + + An executable for easy automated launch of + polynomial arithmetic tests. +-} +module Main where + +import qualified Data.Number.ER.RnToRm.UnitDom.Base as UFB +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Run +import Data.Number.ER.RnToRm.DefaultRepr +import Data.Number.ER.Real.DefaultRepr + +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Compose +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Properties.Common +import Data.Number.ER.RnToRm.UnitDom.Base.Tests.Generate +import Data.Number.ER.BasicTypes.Tests.Generate + +main = + do + runUFBTests "cheb-poly-double" samplePBM (UFB.initialiseBaseArithmetic samplePBM) + +samplePBM :: P BM +samplePBM = UFB.const 0 + +failed1 = + -- identified 24 Jul 19:00 + prop_enclCompose_ThinEncl_consistent (samplePBM,samplePBM) "a" + (Deg10Size10 9 8, 7, + FBEnclThinSize10 ((0,72), + makeThinEncl (polynomials1200ishSize10Small samplePBM !! 72)), + FBEnclThinSize10 ((0,853), + makeThinEncl (polynomials1200ishSize10Small samplePBM !! 853)) + ) + +--failed1 = +-- -- identified 24 Jul 15:00 +-- -- fixed - error in enclMultiply 24 Jul 16:25 +-- prop_enclScale_ParalEncl_consistent (samplePBM,samplePBM) "a" +-- (Deg10Size10 7 7, SmallRatio 220736 320174, +-- FBEnclParalSize10 (((0,872),SmallRatio (-50723) 723338), +-- makeParalEncl (polynomials1200ishSize10Small samplePBM !! 872) (SmallRatio (-50723) 723338)) +-- ) + |