diff --git a/AERN-Real.cabal b/AERN-Real.cabal --- a/AERN-Real.cabal +++ b/AERN-Real.cabal @@ -1,85 +1,80 @@ Name: AERN-Real -Version: 0.10.0.2 +Version: 2011.1 Cabal-Version: >= 1.2 Build-Type: Simple License: BSD3 License-File: LICENCE Author: Michal Konecny (Aston University) -Copyright: (c) 2007-2009 Michal Konecny, Amin Farjudian, Jan Duracz +Copyright: (c) 2011 Michal Konecny, Jan Duracz Maintainer: mikkonecny@gmail.com -Homepage: http://www-users.aston.ac.uk/~konecnym/DISCERN -Stability: beta +Homepage: http://code.google.com/p/aern/ +Stability: experimental Category: Data, Math -Synopsis: arbitrary precision interval arithmetic for approximating exact real numbers -Tested-with: GHC ==6.10.1 +Synopsis: arbitrary precision real interval arithmetic +Tested-with: GHC ==6.12.3 Description: - Datatypes and abstractions for approximating exact real numbers - and a basic arithmetic over such approximations. - The main datatype is interval with arbitrary precision endpoints - supported by safely rounding field and elementary operations - whose precision can be increased arbitrarily, so that they - all converge to the exact operations. - . - The design of the library is inspired to some degree - by Mueller's iRRAM and Lambov's RealLib - (both are C++ libraries for exact real arithmetic). - . - For an architectural overview, see module "Data.Number.ER.Real". - . - Simple examples of usage can be found in folder @examples@. + Type classes abstracting typical approximate real number arithmetic operations + including rounded + field operations and common elementary operations. + Two kinds of rounding are supported: rounding up/down in the numerical order + or rounding in/out in a refinement order. . - There is a built-in test suite and it can be evoked using - the module in the folder @tests@. + A concrete implementation of refinement order rounded operations + is given for intervals in the package AERN-Real-Interval. + Concrete implementations of up/down rounded operations is + given in AERN-Real-Double for ordinary Double + fixed-precision numbers. These can serve as interval + endpoints. In a future release also MPFR arbitrary-precision numbers + will be made available as interval endpoints. Extra-Source-Files: - examples/Demo.hs examples/Pi.hs examples/Matrix.hs - tests/RunERIntervalTests.hs - ChangeLog - -Flag use-hmpfr - Default: False + CHANGES Library - hs-source-dirs: src - if flag(use-hmpfr) - Build-Depends: - base >= 3, base < 4, containers, binary, html >= 1.0, regex-compat >= 0.71, stm, time, QuickCheck == 1.2.0.0, filepath, directory, hmpfr == 0.2 - cpp-options: -DUSE_MPFR - else - Build-Depends: - base >= 3, base < 4, containers, binary, html >= 1.0, regex-compat >= 0.71, stm, time, QuickCheck == 1.2.0.0, filepath, directory + hs-source-dirs: src + ghc-options: -O2 + Build-Depends: + base >= 4 && < 5, + QuickCheck >= 2.1 && < 3, + test-framework >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4, + criterion >= 0.5 && < 0.6, + AERN-Basics == 2011.1 Exposed-modules: - Data.Number.ER, - Data.Number.ER.BasicTypes, - Data.Number.ER.BasicTypes.DomainBox, - Data.Number.ER.BasicTypes.DomainBox.IntMap, - Data.Number.ER.BasicTypes.ExtendedInteger, - Data.Number.ER.BasicTypes.PlusMinus, - Data.Number.ER.BasicTypes.Tests.Generate, - Data.Number.ER.Misc, - Data.Number.ER.Misc.STM, - Data.Number.ER.Misc.Tests, - Data.Number.ER.Real, - Data.Number.ER.Real.Approx, - Data.Number.ER.Real.Approx.Elementary, - Data.Number.ER.Real.Approx.Interval, - Data.Number.ER.Real.Approx.OI, - Data.Number.ER.Real.Approx.Sequence, - Data.Number.ER.Real.Approx.Tests.Generate, - Data.Number.ER.Real.Approx.Tests.Properties, - Data.Number.ER.Real.Approx.Tests.Reporting, - Data.Number.ER.Real.Approx.Tests.Run, - Data.Number.ER.Real.Arithmetic.Elementary, - Data.Number.ER.Real.Arithmetic.Integration, - Data.Number.ER.Real.Arithmetic.LinearSolver, - Data.Number.ER.Real.Arithmetic.Newton, - Data.Number.ER.Real.Arithmetic.Taylor, - Data.Number.ER.Real.Base, - Data.Number.ER.Real.Base.CombinedMachineAP, - Data.Number.ER.Real.Base.Float, - Data.Number.ER.Real.Base.MachineDouble, - Data.Number.ER.Real.Base.MPFR, - Data.Number.ER.Real.Base.Rational, - Data.Number.ER.Real.Base.Tests.Generate, - Data.Number.ER.Real.DefaultRepr, - Data.Number.ER.ShowHTML + Numeric.AERN.RealArithmetic.ExactOps, + Numeric.AERN.RealArithmetic.NumericOrderRounding, + Numeric.AERN.RealArithmetic.NumericOrderRounding.OpsDefaultEffort, + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.OpsDefaultEffort, + Numeric.AERN.RealArithmetic.NumericOrderRounding.OpsImplicitEffort, + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.OpsImplicitEffort, + Numeric.AERN.RealArithmetic.RefinementOrderRounding, + Numeric.AERN.RealArithmetic.RefinementOrderRounding.ElementaryFromFieldOps.Exponentiation, + Numeric.AERN.RealArithmetic.RefinementOrderRounding.OpsDefaultEffort, + Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.OpsDefaultEffort, + Numeric.AERN.RealArithmetic.RefinementOrderRounding.OpsImplicitEffort, + Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.OpsImplicitEffort, + Numeric.AERN.RealArithmetic.Measures, + Numeric.AERN.RealArithmetic.Laws, + Numeric.AERN.RealArithmetic.Bench, + Numeric.AERN.Misc.IntegerArithmetic + + Other-modules: + Numeric.AERN.RealArithmetic.Auxiliary + Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion + Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary + Numeric.AERN.RealArithmetic.NumericOrderRounding.SpecialConst + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.MixedFieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.Elementary + Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion + Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps + Numeric.AERN.RealArithmetic.RefinementOrderRounding.MixedFieldOps + Numeric.AERN.RealArithmetic.RefinementOrderRounding.Elementary + Numeric.AERN.RealArithmetic.RefinementOrderRounding.SpecialConst + Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace + Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.FieldOps + Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.MixedFieldOps + Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.Elementary + diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +2011.1: 6th May 2011 + * initial release of a completely rewritten version of AERN-Real + diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 --- a/ChangeLog +++ /dev/null @@ -1,78 +0,0 @@ -0.10.0.2: 29 July 2009: renamed "demos" folder to "examples" -0.10.0.1: 28 July 2009: fixed a few bugs in meta-data -0.10.0: 28 July 2009 - * switching to beta status - * new QuickCheck test suite covering most functionality - * new support for anti-consistent intervals (eg [2,0]) - (also called directed or improper; using Kaucher arithmetic) - * new support for inner-rounded interval arithemtic - * fixed errors in some elementary functions for extreme values - * fixed performance bug in arctan - * improved hierarchy of auxiliary modules - -0.9.9: 23 February 2009 - * Small changes needed in other AERN packages: - * New operation for domain boxes: get its dimension. - * Exponentiation, sine, cosine and arctan signinificantly improved for arguments further away from 0. - * Fixed a bug in sine Taylor series error term. - * Some interval arithmetic operations now have also "inner" versions - that approximate the maximal extension of the operation from inside - (useful for testing the normal "outer" versions). - -0.9.8: 1 December 2008 - * added instance of the HTML class for intervals - * added syntactic comparison of variable-indexed domain boxes - * some extra miscellaneous functions - * moved miscellaneous facilities for STM from AERN-RnToRm-Plot to here so that they can be used by AERN-Net - -0.9.7.2: 7 October 2008 - * hmpfr interface now uses a faster toDouble conversion - -0.9.7.1: 30 September 2008 - * switched the Demo program to a more suitable (ie faster) base - -0.9.7: 30 September 2008 - * made it easier to switch among various bases (double, mpfr, pure haskell floats...) - * added MPFR backend via hmpfr (cabal install -f "use-hmpfr") - * added two new samples (computing pi, inverting Hilbert matrix) that - demonstrate the speedup when using MPFR - -0.9.6.1: 7 August 2008 - * revamped package description to make it much shorter and linked it - to the main module - -0.9.6: 7 August 2008 - * improved domain box class interface and implementation - * fixed broken domain box splitting function - * improved the integer logarithm auxiliary function - -0.9.5: 24 July 2008 - * new operation for testing disjoing interiors - * real approximations not automatically instances of Ord - because comparison is not decidable in general; - one should use the four-valued compareReals instead of <, =<, == - * removed rependency on haskell98 - -0.9.4: 15 July 2008 - * fixed buggy formatting of floating point numbers - * added a simple although inefficient linear solver - -0.9.3.1: 12 July 2008 - * fixed email in cabal maintainer field - -0.9.3: 12 July 2008 - * Fixed Data.Number.ER.Real so that it is usable as a single import - for the library and its documentation links are more useful. - * Added a module with some tests, which can also serve as an example. - * Improved formatting of floating point numbers. - -0.9.2: 11 July 2008 - * declared dependency on haskell98 in cabal file (thanks to Don Stewart) - -0.9.1: 11 July 2008 - * fixed licence specification within modules - -0.9.0: 11 July 2008 - * initial release of AERN-Real - - diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,4 +1,4 @@ -Copyright (c) 2007-2008 Michal Konecny, Amin Farjudian, Jan Duracz +Copyright (c) 2010 Michal Konecny All rights reserved. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/examples/Demo.hs b/examples/Demo.hs deleted file mode 100644 --- a/examples/Demo.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| - Module : Main - Description : simple examples of using AERN-Real - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Simple examples of using AERN-Real --} -module Main where - -import qualified Data.Number.ER.Real as AERN -import Data.Number.ER.Real (ConvergRealSeq(..), convertFuncRA2Seq) - -#ifdef USE_MPFR ---type B = AERN.BAP -- use pure Haskell floats -type B = AERN.BMAP -- use combination of double and pure Haskell floats ---type B = AERN.BMPFR -- use MPFR floats -#else ---type B = AERN.BAP -- use pure Haskell floats -type B = AERN.BMAP -- use combination of double and pure Haskell floats -#endif -type RA = AERN.RA B -type IRA = AERN.IRA B -type R = ConvergRealSeq IRA - -one :: R -one = 1 - -two :: R -two = 2 - -piSeq :: R -piSeq = ConvergRealSeq $ AERN.pi - -seqExp = convertFuncRA2Seq $ AERN.exp -seqSine = convertFuncRA2Seq $ AERN.sin -seqCosine = convertFuncRA2Seq $ AERN.cos - -main = - do - AERN.initialiseBaseArithmetic (0 :: RA) - putStrLn "****************************" - putStrLn "Testing interval arithmetic:" - putStrLn "****************************" - putStrLn "**** Fractions:" - putStrLn $ - "(default granularity, show internals) 1/3 =\n " ++ - AERN.showApprox 30 True True (1/3 :: RA) - putStrLn $ - "(granularity 50, show internals) 1/3 =\n " ++ - AERN.showApprox 30 True True ((AERN.setGranularityOuter 50 1/3) :: RA) - putStrLn $ - "(granularity 100, show internals) 1/3 =\n " ++ - AERN.showApprox 40 True True ((AERN.setGranularityOuter 100 1/3) :: RA) - putStrLn $ - "(granularity 100, do not show internals) 1/3 =\n " ++ - AERN.showApprox 40 True False ((AERN.setGranularityOuter 100 1/3) :: RA) - putStrLn $ - "(granularity 100, default show) 1/3 =\n " ++ - show ((AERN.setGranularityOuter 100 1/3) :: RA) - putStrLn "**** Exp:" - putStrLn $ - "(effort 5, granularity 50) exp 1 =\n " ++ - (show $ AERN.exp 5 (AERN.setGranularityOuter 50 (1::RA))) - putStrLn $ - "(effort 10, granularity 50) exp 1 =\n " ++ - (show $ AERN.exp 10 (AERN.setGranularityOuter 50 (1::RA))) - putStrLn $ - "(effort 10, granularity 100) exp 1 =\n " ++ - (show $ AERN.exp 10 (AERN.setGranularityOuter 100 (1::RA))) - putStrLn $ - "(effort 20, granularity 50) exp 1 =\n " ++ - (show $ AERN.exp 20 (AERN.setGranularityOuter 50 (1::RA))) - putStrLn $ - "(effort 20, granularity 100) exp 1 =\n " ++ - (show $ AERN.exp 20 (AERN.setGranularityOuter 100 (1::RA))) - putStrLn "**** Pi:" - putStrLn $ - "(effort 10) pi =\n " ++ - (show $ (AERN.pi 10 :: RA)) - putStrLn $ - "(effort 50) pi =\n " ++ - (AERN.showApprox 20 True False $ (AERN.pi 50 :: RA)) - putStrLn $ - "(effort 100) pi =\n " ++ - (AERN.showApprox 35 True False $ (AERN.pi 100 :: RA)) - putStrLn $ - "(effort 200) pi =\n " ++ - (AERN.showApprox 65 True False $ (AERN.pi 200 :: RA)) - putStrLn $ - "(effort 400) pi =\n " ++ - (AERN.showApprox 125 True False $ (AERN.pi 400 :: RA)) - putStrLn "**** Sine:" - putStrLn $ - "(effort 10, granularity 50) sin 1 =\n " ++ - (show $ AERN.sin 10 (AERN.setGranularityOuter 50 (1::RA))) - putStrLn $ - "(effort 10, granularity 100) sin 1 =\n " ++ - (show $ AERN.sin 10 (AERN.setGranularityOuter 100 (1::RA))) - putStrLn "**** Integration:" - putStrLn $ - "(effort 10, granularity 50) integrate exp 0 1 =\n " ++ - (show $ AERN.integrateContAdapt_R AERN.exp 10 0 (AERN.setGranularityOuter 50 (1::RA))) - putStrLn $ - "(effort 20, granularity 50) integrate exp 0 1 =\n " ++ - (show $ AERN.integrateContAdapt_R AERN.exp 20 0 (AERN.setGranularityOuter 50 (1::RA))) --- putStrLn $ --- "(effort 30, granularity 50) integrate exp 0 1 =\n " ++ --- (show $ AERN.integrateContAdapt_R AERN.exp 30 0 (AERN.setGranularityOuter 50 (1::RA))) - putStrLn "*****************************" - putStrLn "Testing convergent sequences:" - putStrLn "*****************************" --- putStrLn $ "1 =\n " ++ show one --- putStrLn $ "1 + 2 =\n " ++ (show $ one + two) - putStrLn "**** Fractions:" - putStrLn $ - "(precision 20) 1/3 =\n " ++ - (AERN.showConvergRealSeqAuto 20 $ one / 3) - putStrLn $ - "(precision 20) 100000000001/300000000000 =\n " ++ - (AERN.showConvergRealSeqAuto 20 $ (one + 100000000000)/300000000000 ) - putStrLn $ - "100000000001/300000000000 =? 1/3:\n " ++ - (show $ one/3 == 100000000001/300000000000) --- putStrLn $ "abs -1 = " ++ (show $ abs (- one)) --- putStrLn $ "neg 2 = " ++ (show $ negate two) --- putStrLn $ "1 + 2 = " ++ (show $ one + 2) - putStrLn "**** Elementary:" - putStrLn $ - "(precision 30) exp 1 =\n " ++ - (AERN.showConvergRealSeqAuto 30 $ seqExp one) - putStrLn $ - "(precision 500) pi =\n " ++ - (AERN.showConvergRealSeqAuto 500 $ piSeq) - putStrLn $ - "(precision 30) cosine(1) =\n " ++ - (AERN.showConvergRealSeqAuto 30 $ seqCosine one) - putStrLn $ - "(precision 30) sine(1) =\n " ++ - (AERN.showConvergRealSeqAuto 30 $ seqSine one) - putStrLn "**** Integration:" - putStrLn $ -- very slow for precision > 4 - "(precision 3) integrate exp 0 1 =\n " ++ - (AERN.showConvergRealSeqAuto 3 $ AERN.integrateCont AERN.exp 0 one) diff --git a/examples/Matrix.hs b/examples/Matrix.hs deleted file mode 100644 --- a/examples/Matrix.hs +++ /dev/null @@ -1,385 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Main - -where - -import qualified Data.Number.ER.Real as AERN -import Data.Number.ER.BasicTypes -import Data.Number.ER.Misc - -import Data.Maybe -import qualified Data.List as List -import qualified Data.Map as Map - -import qualified Data.Array.IArray as IAr -import qualified Data.Array.MArray as MAr -import qualified Data.Array.ST as STAr -import qualified Data.Ix as Ix -import qualified Data.Array.Base as BAr - -import Control.Monad.ST -import GHC.Arr - -#ifdef USE_MPFR -type B = AERN.BAP -- use pure Haskell floats ---type B = AERN.BMPFR -- use MPFR floats -#else -type B = AERN.BAP -- use pure Haskell floats -#endif -type RA = AERN.RA B -type IRA = AERN.IRA B - -testMatrixN = 100 -incrementGran = (+) 50 - --- Hilbert 100x100 matrix: -addOneDiag = False -targetPrec = 167 -- approx 50 decimal digits after the point -initialGran = 2050 -- 100x100 ---initialGran = 2388 -- 100x100 Norbert's ---initialGran = 750 -- 50x50 ---initialGran = 300 -- 10x10 - ---targetPrec = 34 -- approx 10 decimal digits after the point ---initialGran = 1350 ---initialGran = 50 -- 50x50 - --- Hilbert matrix + 1: ---addOneDiag = True ---targetPrec = 167 -- approx 50 decimal digits after the point ---initialGran = 200 - ---targetPrec = 34 -- approx 10 decimal digits after the point ---initialGran = 50 - -main = - do - AERN.initialiseBaseArithmetic (0 :: RA) - putStrLn $ - "Inverting the " ++ show n ++ "x" ++ show n ++ " Hilbert matrix " - ++ "with target binary precision " ++ show targetPrec ++ "..." --- putStrLn $ --- "sorted matrix elements = \n" ++ (unlines $ map show elemsSortedByPrec) - putStrLn $ - "sum of all elements in inverted matrix = " ++ show (sum elems) --- putStrLn $ show (Matrix n n rarr) - where - n = testMatrixN - elems = IAr.elems rarr - elemsSortedByPrec = - List.sortBy comparePrec elems - where - comparePrec a b = - compare aPrecLO bPrecLO - where - aPrecLO = fst $ AERN.bounds $ aHI - aLO - (aLO, aHI) = AERN.bounds a - bPrecLO = fst $ AERN.bounds $ bHI - bLO - (bLO, bHI) = AERN.bounds b - rarr = - STAr.runSTArray $ - do - mInv@(Matrix _ _ rowsInv) <- - invert testMatrix --- m <- testMatrix initialGran --- mUnit@(Matrix _ _ rowsUnit) <- multM m mInv - return rowsInv - - -testMatrix :: - Granularity -> - ST s (STMatrix s IRA) -testMatrix gran = - do - marr <- MAr.newArray ((1,1),(n,n)) 0 - mapM (updateCell marr) assocsGran - return $ Matrix n n marr - where - assocsGran = map (mapSnd $ AERN.setMinGranularityOuter gran) assocs - assocs = --- assocsMini - assocsHilbert gran n - assocsMini = - [((1,1),1), - ((1,2),3), - ((2,1),2), - ((2,2),0) - ] - n = testMatrixN - updateCell marr (ix, el) = - do - unsafeMatrixWrite marr n ix el - -assocsHilbert gran n = - [((i,j), coeff i j)| i <- [1..n], j <- [1..n]] - where - coeff i j - | addOneDiag && i == j = - 1 + oneOverIplusJ - | otherwise = - oneOverIplusJ - where - oneOverIplusJ = - recip $ (AERN.setMinGranularityOuter gran $ iRA + jRA + 1) - iRA = fromInteger $ toInteger i - jRA = fromInteger $ toInteger j - - ---invert :: --- Precision -> --- () -> -invert getMatrix = - do - gaussElim getMatrixI - where - n = testMatrixN - getMatrixI gran = - do - m <- getMatrix gran - mI <- addIdentity m - return mI - -gaussElim getMatrix = - elimWithMinGran initialGran - where - elimWithMinGran workingGran = - do - mI@(Matrix colN rowN _) <- getMatrix workingGran - idPerm <- MAr.newListArray (1,rowN) [1..rowN] - elimAtRow mI 1 idPerm - where - elimAtRow mI@(Matrix colN rowN mIarr) i perm = - do - success <- ensureNonZeroDiag -- make sure (i,i) is non-zero by permuting - case success of - False -> -- failed - all elements contain 0 -> try larger granularity - unsafePrint ("failed to divide at granularity " ++ show workingGran) $ - elimWithMinGran (incrementGran workingGran) - True -> - do - normaliseRow - eliminateColumn - case i == rowN of - True -> - do - mInv <- permuteRowsDropCols perm testMatrixN mI - mPrec <- getMatrixPrecision mInv - case mPrec >= targetPrec of - False -> -- resulting precision insufficient - unsafePrint - ("insufficient precision " ++ show mPrec ++ - " at granularity " ++ show workingGran) $ - elimWithMinGran (incrementGran workingGran) - True -> - unsafePrint - ("precision " ++ show mPrec ++ - " succeeded at granularity " ++ show workingGran) - return mInv - False -> elimAtRow mI (i+1) perm - where - ensureNonZeroDiag = - do - maybeNonZeroIx <- findNonZeroRow - case maybeNonZeroIx of - Nothing -> - return False - Just ii -> - do - case ii > 0 of - True -> swap i (i + ii) perm - False -> return () - return True - findNonZeroRow = - do - elems <- mapM getElemPerm [(i,rowIx) | rowIx <- [i..rowN]] - return $ List.findIndex (\e -> not $ 0 `AERN.refines` e) elems - getElemPerm (colIx,rowIx) = - do - rowIxPerm <- unsafePermRead perm rowIx - unsafeMatrixRead mIarr rowN (colIx, rowIxPerm) - - normaliseRow = - do - rowIxPerm <- unsafePermRead perm i - e <- unsafeMatrixRead mIarr rowN (i, rowIxPerm) - unsafeMatrixWrite mIarr rowN (i, rowIxPerm) 1 - mapM (divideCellBy e rowIxPerm) [(i+1)..colN] - divideCellBy e rowIxPerm colIx = - do - e2 <- unsafeMatrixRead mIarr rowN (colIx, rowIxPerm) - unsafeMatrixWrite mIarr rowN (colIx, rowIxPerm) (e2/e) - - eliminateColumn = - do - iRowPerm <- unsafePermRead perm i - mapM (eliminateColumnRow iRowPerm) $ [1..(i-1)] ++ [(i+1)..rowN] - eliminateColumnRow iRowPerm rowIx = - do - rowIxPerm <- unsafePermRead perm rowIx - c <- unsafeMatrixRead mIarr rowN (i, rowIxPerm) -- remember old element for scaling i'th row - unsafeMatrixWrite mIarr rowN (i,rowIxPerm) 0 -- at column i we set 0 - mapM (eliminateColumnRowColumn iRowPerm rowIxPerm c) [(i+1)..colN] - eliminateColumnRowColumn iRowPerm rowIxPerm c colIx = - do - ei <- unsafeMatrixRead mIarr rowN (colIx, iRowPerm) -- at i'th row - er <- unsafeMatrixRead mIarr rowN (colIx, rowIxPerm) -- at current row - unsafeMatrixWrite mIarr rowN (colIx, rowIxPerm) (er - c * ei) -- eliminate by i'th row - - -swap :: - Int -> - Int -> - (STAr.STUArray s Int Int) -> - ST s () -swap i1 i2 perm = - do - a1 <- unsafePermRead perm i1 - a2 <- unsafePermRead perm i2 - unsafePermWrite perm i1 a2 - unsafePermWrite perm i2 a1 - - -unsafePermWrite permArr i e = - do - BAr.unsafeWrite permArr (i - 1) e - -unsafePermRead permArr i = - do - BAr.unsafeRead permArr (i - 1) - - -addIdentity :: - (STMatrix s IRA) -> - ST s (STMatrix s IRA) -addIdentity (Matrix colN rowN marr) = - do --- (_, (colN,rowN)) <- MAr.getBounds marr - mElems <- MAr.getElems marr - mIarr <- MAr.newListArray ((1,1),(colN+rowN,rowN)) $ mElems ++ (idElems rowN) - return $ Matrix (colN + rowN) rowN mIarr - where - idElems m = - 1 : (concat $ replicate (m-1) $ (replicate m 0) ++ [1]) - - -data Matrix marr el = - Matrix - { - mxRowN :: Int, - mxColN :: Int, - mxRows :: marr (ColIx,RowIx) el - } - -type ColIx = Int -type RowIx = Int - -type IMatrix el = - Matrix Array el - -type STMatrix s el = - Matrix (STArray s) el - -instance - (IAr.IArray marr el,-- IAr.IArray marr (marr Int el), - Show el) => - Show (Matrix marr el) - where - show (Matrix colN rowN rows) = - "\nMatrix:\n" ++ - (concat $ map showCol [1..colN]) - where --- (_,(colN,rowN)) = IAr.bounds rows - showCol colIx = - unlines $ - map showCell [(colIx, rowIx) | rowIx <- [1..rowN]] - showCell ix@(colIx, rowIx) = - (show ix) ++ - (replicate colIx '.') ++ - (show $ (IAr.!) rows ix) - -getMatrixPrecision (Matrix _ _ marr) = - do - elems <- MAr.getElems marr - return $ foldl1 min $ map AERN.getPrecision elems - -unsafeMatrixWrite marr rowN (i,j) e = - do - BAr.unsafeWrite marr (rowN*(i-1) + j-1) e --- MAr.writeArray marr (i,j) e - -unsafeMatrixRead marr rowN (i,j) = - do - BAr.unsafeRead marr (rowN*(i-1) + j-1) --- MAr.readArray marr (i,j) - -permuteRowsDropCols :: - (STAr.STUArray s Int Int) -> - Int {-^ drop this many first columns -} -> - (STMatrix s IRA) -> - ST s (STMatrix s IRA) -permuteRowsDropCols perm dropN (Matrix colN rowN marr) = - do --- (_, (colN,rowN)) <- MAr.getBounds marr - (_, permN) <- MAr.getBounds perm - rarr <- MAr.newArray ((1,1),(colN - dropN, permN)) 0 - mapM (copyElem marr rarr rowN) [(colIx, rowIx) | colIx <- [1..colN - dropN], rowIx <- [1..permN]] - return (Matrix (colN - dropN) permN rarr) - where - copyElem marr rarr rowN (colIx, rowIx) = - do - permRowIx <- unsafePermRead perm rowIx - e <- unsafeMatrixRead marr rowN (colIx + dropN, permRowIx) - unsafeMatrixWrite rarr rowN (colIx, rowIx) e - - -addM m1 m2 - | mxColN m1 == mxColN m2 && mxRowN m1 == mxRowN m2 = - do - marr <- MAr.newArray ((1,1),(colN, rowN)) 0 - mapM (addCell marr) [(c,r) | c <- [1..colN], r <- [1..rowN]] - return (Matrix colN rowN marr) - | otherwise = - error "Matrix: addM mismatch" - where - colN = mxColN m1 - rowN = mxRowN m1 - marr1 = mxRows m1 - marr2 = mxRows m2 - addCell marr (colIx, rowIx) = - do - elem1 <- unsafeMatrixRead marr1 rowN (colIx, rowIx) - elem2 <- unsafeMatrixRead marr2 rowN (colIx, rowIx) - unsafeMatrixWrite marr rowN (colIx, rowIx) (elem1 + elem2) - -multM m1 m2 - | colN1 == rowN2 = - do - marr <- MAr.newArray ((1,1),(colN, rowN)) 0 - mapM (multCell marr) [(c,r) | c <- [1..colN], r <- [1..rowN]] - return (Matrix colN rowN marr) - | otherwise = - error "Matrix: multM mismatch" - where - colN1 = mxColN m1 - rowN1 = mxRowN m1 - colN2 = mxColN m2 - rowN2 = mxRowN m2 - colN = colN2 - rowN = rowN1 - marr1 = mxRows m1 - marr2 = mxRows m2 - multCell marr (colIx, rowIx) = - do - elems1 <- mapM (getCell1 rowIx) [1..colN1] - elems2 <- mapM (getCell2 colIx) [1..rowN2] - unsafeMatrixWrite marr rowN (colIx, rowIx) (sum $ zipWith (*) elems1 elems2) - getCell1 rowIx colIx = - do - unsafeMatrixRead marr1 rowN1 (colIx, rowIx) - getCell2 rowIx colIx = - do - unsafeMatrixRead marr2 rowN2 (colIx, rowIx) - diff --git a/examples/Pi.hs b/examples/Pi.hs deleted file mode 100644 --- a/examples/Pi.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Main - -where - -import qualified Data.Number.ER.Real as AERN -import Data.Number.ER.Real (ConvergRealSeq(..), convertFuncRA2Seq) -import Data.Number.ER.BasicTypes -import Data.Number.ER.Misc - -import Data.Maybe - -#ifdef USE_MPFR ---type B = AERN.BMPFR -- use MPFR floats -type B = AERN.BAP -- use pure Haskell floats -#else -type B = AERN.BAP -- use pure Haskell floats ---type B = AERN.BMAP -- use combination of double and pure Haskell floats -#endif -type RA = AERN.RA B -type IRA = AERN.IRA B - - -decimalPrec = 1000 -binaryPrec = - fromInteger $ toInteger $ - snd $ AERN.integerBounds $ - (fromInteger decimalPrec :: RA) * (AERN.log 100 10)/(AERN.log 100 2) - -main = - do - AERN.initialiseBaseArithmetic (0 :: RA) - putStrLn $ - show decimalPrec - ++ " decimal digits of pi = \n" - ++ (AERN.showConvergRealSeqAuto binaryPrec pi) - where - pi :: ConvergRealSeq RA - pi = ConvergRealSeq AERN.pi - diff --git a/src/Data/Number/ER.hs b/src/Data/Number/ER.hs deleted file mode 100644 --- a/src/Data/Number/ER.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-| - Module : Data.Number.ER - Description : top level of the exactreals framework - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : non-portable (requires fenv.h) - - This namespace is the root for the AERN family of packages. - AERN stands for Approximated Exact Real Numbers. - All AERN packages build on the package AERN-Real. - - Module "Data.Number.ER.Real" contains an overview - of the AERN-Real package. - --} -module Data.Number.ER -( - module Data.Number.ER.Real -) -where - -import Data.Number.ER.Real diff --git a/src/Data/Number/ER/BasicTypes.hs b/src/Data/Number/ER/BasicTypes.hs deleted file mode 100644 --- a/src/Data/Number/ER/BasicTypes.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-| - Module : Data.Number.ER.BasicTypes - Description : auxiliary types for exact real number processing - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - auxiliary types for exact real number processing --} -module Data.Number.ER.BasicTypes -where - -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI - -{-| - Precision represents an upper bound on the measure of - an approximation viewed as a set; - not to be confused with the precision of - an 'Data.Number.ER.Real.Base.Float.ERFloat' and similar. - - In an approximation comprising a number of - instances of 'Data.Number.ER.Real.Base.ERRealBase', - we will refer to the bit-precision of these base components - as the 'Granularity' of the approximation. --} -type Precision = EI.ExtendedInteger - -{-| - The bit size of the floating point numbers (or similar) - used internally in real number and function approximations. --} -type Granularity = Int - -prec2gran :: Precision -> Granularity -prec2gran = fromInteger . toInteger - -{-| - This type synonym should be used for funciton parameter(s) - that guide the convergence of the function's result to - a perfect (exact) result. - - The name should remind us - that there is no universally valid relationship between - this integer the quality (precision) of the result. - The only condition usually assumed is that in the limit - when the effort index rises to infinity, the result - should be exact. --} -type EffortIndex = Integer - -effIx2gran :: EffortIndex -> Granularity -effIx2gran = fromInteger . toInteger - -effIx2prec :: EffortIndex -> Precision -effIx2prec = fromInteger . toInteger - -effIx2int :: EffortIndex -> Int -effIx2int = fromInteger . toInteger - -int2effIx :: Int -> EffortIndex -int2effIx = fromInteger . toInteger - -prec2effIx :: Precision -> EffortIndex -prec2effIx = fromInteger . toInteger - -gran2effIx :: Granularity -> EffortIndex -gran2effIx = fromInteger . toInteger - diff --git a/src/Data/Number/ER/BasicTypes/DomainBox.hs b/src/Data/Number/ER/BasicTypes/DomainBox.hs deleted file mode 100644 --- a/src/Data/Number/ER/BasicTypes/DomainBox.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-| - Module : Data.Number.ER.BasicTypes.DomainBox - Description : portions of many-dimensional domains - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Abstractions of the 'Box' datatype, often used to represent - sections of multi-dimensional function domains. - - To be imported qualified, usually with prefix DBox. - - VariableID(..) and DomainBox - are usually imported separately and not qualified. --} -module Data.Number.ER.BasicTypes.DomainBox -( - VariableID(..), - getNVars, - DomainBox(..), - DomainBoxMappable(..), - DomainIntBox(..) -) -where - -import Data.Number.ER.BasicTypes - -import qualified Data.Set as Set -import qualified Data.Map as Map - -import Prelude hiding (lookup) - - -{-| - A class abstracting a type of variable identifiers - for axes in function domains, polynomials etc. --} -class (Ord varid) => VariableID varid - where - newVarID :: Set.Set varid -> varid - defaultVar :: varid - defaultVar = newVarID Set.empty - showVar :: varid -> String - -getNVars :: (VariableID varid) => Int -> [varid] -getNVars n = - aux (Set.empty) n - where - aux prevVars n - | n > 0 = - aux (Set.insert (newVarID prevVars) prevVars) (n - 1) - | n == 0 = - Set.toAscList $ prevVars - -{-| - A class abstracting a type of many-dimensional points, intervals - or anything indexed by a subset of dimensions. - - More generally, this class abstracts most of 'Data.Map.Map'. --} -class (VariableID varid) => DomainBox box varid val - | box -> varid val, varid val -> box - where - noinfo :: box - isNoinfo :: box -> Bool - size :: box -> Int - {-| constructor using 'defaultVar' -} - unary :: val -> box - singleton :: varid -> val -> box - toList :: box -> [(varid, val)] - fromList :: [(varid, val)] -> box - toAscList :: box -> [(varid, val)] - fromAscList :: [(varid, val)] -> box --- toMap :: box -> Map.Map varid val --- fromMap :: Map.Map varid val -> box - compare :: (val -> val -> Ordering) -> box -> box -> Ordering - adjust :: (val -> val) -> varid -> box -> box - insert :: varid -> val -> box -> box - insertWith :: (val -> val -> val) -> varid -> val -> box -> box - delete :: varid -> box -> box - member :: varid -> box -> Bool - notMember :: varid -> box -> Bool - union :: box -> box -> box - unionWith :: (val -> val -> val) -> box -> box -> box - keys :: box -> [varid] - elems :: box -> [val] - filter :: (val -> Bool) -> box -> box - fold :: (val -> a -> a) -> a -> box -> a - foldWithKey :: (varid -> val -> a -> a) -> a -> box -> a - {-| - for all variables that appear in both boxes, - apply the function and add the result to the list - -} - zipWith :: (val -> val -> a) -> box -> box -> [(varid, a)] - {-| - For all variables that appear in either of the two boxes, - apply the function and add the result to the list. - - Supply the default value when the variable is missing from either box. - -} - zipWithDefault :: val -> (val -> val -> a) -> box -> box -> [(varid, a)] - {-| - For all variables that appear in the first box, - apply the function and add the result to the list. - - Supply the default value when the variable is missing from the second box. - -} - zipWithDefaultSecond :: val -> (val -> val -> a) -> box -> box -> [(varid, a)] - findWithDefault :: val -> varid -> box -> val - {-| - Pick the extents of a single variable in a domain box. - If there is no information for this variable, assume the - variable ranges over the whole real line. - -} - lookup :: - String {-^ identification of caller location to use in error messages -} -> - varid -> - box -> - val - -{-| - A class linking two domain box types that share the - index type so that boxes of the two types can be - converted etc. --} -class (DomainBox box1 varid val1, DomainBox box2 varid val2) => - DomainBoxMappable box1 box2 varid val1 val2 - where - map :: (val1 -> val2) -> box1 -> box2 - mapWithKey :: (varid -> val1 -> val2) -> box1 -> box2 - intersectionWith :: (val1 -> val2 -> val1) -> box1 -> box2 -> box1 - difference :: box1 -> box2 -> box1 - -{-| - A class abstracting a type of many-dimensional intervals. --} -class (DomainBox box varid ira) => DomainIntBox box varid ira - | box -> varid ira, varid ira -> box - where - {-| - Check whether the two domains specify the same - interval for each variable that they share. - -} - compatible :: - box -> - box -> - Bool - {-| - Assuming that two domains are compatible, take the - most information from both of the domains about the - ranges of variables. - -} - unify :: - String {-^ identification of caller location to use in error messages -} -> - box -> - box -> - box - {-| - Find the variable with the largest interval - and return it together with the default splitting point - in its domain. - -} - bestSplit :: - box {-^ box considered for splitting -} -> - (varid, (ira, ira)) - {-^ variable with widest domain, its domain and default split point -} - split :: - box {-^ box to split -} -> - varid {-^ direction to split in -} -> - Maybe ira {-^ point to split the domain of variable @varid@ at, if absent use default -} -> - (box, box) - classifyPosition :: - box {-^ domain @d1@ -} -> - box {-^ domain @d2@ -} -> - (Bool, Bool, Bool, Bool) - {-^ - Answers to these (mutually exclusive) questions: - - * is @d1@ outside and /not/ touching @d2@? - - * is @d1@ outside and touching @d2@? - - * is @d1@ intersecting and not inside @d2@? - - * is @d1@ inside @d2@? - -} - diff --git a/src/Data/Number/ER/BasicTypes/DomainBox/IntMap.hs b/src/Data/Number/ER/BasicTypes/DomainBox/IntMap.hs deleted file mode 100644 --- a/src/Data/Number/ER/BasicTypes/DomainBox/IntMap.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-| - Module : Data.Number.ER.BasicTypes.DomainBox.IntMap - Description : implementation of DomainBox based on Data.IntMap - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - A simple implementation of the 'VariableID' and 'DomainBox' classes. --} -module Data.Number.ER.BasicTypes.DomainBox.IntMap -( - VarID, Box -) -where - -import qualified Data.Number.ER.Real.Approx as RA -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.IntMap as IMap -import qualified Data.Set as Set - -type VarID = Int -type Box ira = IMap.IntMap ira - -instance VariableID VarID - where - newVarID prevVars - | Set.null prevVars = 0 - | otherwise = - 1 + (Set.findMax prevVars) - showVar v - | v == 0 = "x" - | otherwise = "x" ++ show v - -instance (Show val) => (DomainBox (Box val) VarID val) - where - noinfo = IMap.empty - isNoinfo = IMap.null - size = IMap.size - unary r = IMap.singleton defaultVar r - singleton = IMap.singleton - toList = IMap.toList - fromList = IMap.fromList - toAscList = IMap.toAscList - fromAscList = IMap.fromAscList --- toMap = id --- fromMap = id - compare compareVals b1 b2 = - compareListsWith comparePairs (IMap.toList b1) (IMap.toList b2) - where - comparePairs (k1,v1) (k2,v2) = - compareComposeMany - [ - compare k1 k2, - compareVals v1 v2 - ] - - adjust = IMap.adjust - insert = IMap.insert - insertWith = IMap.insertWith - delete = IMap.delete - member = IMap.member - notMember = IMap.notMember - union = IMap.union - unionWith = IMap.unionWith - elems = IMap.elems - keys = IMap.keys - filter = IMap.filter - fold = IMap.fold - foldWithKey = IMap.foldWithKey - zipWith f b1 b2 = - applyF (IMap.toAscList b1) (IMap.toAscList b2) - where - applyF [] _ = [] - applyF _ [] = [] - applyF bl1@((k1,v1):rest1) bl2@((k2,v2):rest2) - | k1 == k2 = - (k1, f v1 v2) : (applyF rest1 rest2) - | k1 < k2 = applyF rest1 bl2 - | otherwise = applyF bl1 rest2 - zipWithDefault defaultValue f b1 b2 = - applyF (IMap.toAscList b1) (IMap.toAscList b2) - where - applyF [] [] = [] - applyF bl1@((k1,v1):rest1) [] = - (k1, f v1 defaultValue) : (applyF rest1 []) - applyF [] bl2@((k2,v2):rest2) = - (k2, f defaultValue v2) : (applyF [] rest2) - applyF bl1@((k1,v1):rest1) bl2@((k2,v2):rest2) - | k1 == k2 = - (k1, f v1 v2) : (applyF rest1 rest2) - | k1 < k2 = - (k1, f v1 defaultValue) : (applyF rest1 bl2) - | otherwise = - (k2, f defaultValue v2) : (applyF bl1 rest2) - zipWithDefaultSecond defaultValue f b1 b2 = - applyF (IMap.toAscList b1) (IMap.toAscList b2) - where - applyF [] _ = [] - applyF bl1@((k1,v1):rest1) [] = - (k1, f v1 defaultValue) : (applyF rest1 []) - applyF bl1@((k1,v1):rest1) bl2@((k2,v2):rest2) - | k1 == k2 = - (k1, f v1 v2) : (applyF rest1 rest2) - | k1 < k2 = - (k1, f v1 defaultValue) : (applyF rest1 bl2) - | otherwise = - applyF bl1 rest2 - findWithDefault = IMap.findWithDefault - lookup locspec var dom = - IMap.findWithDefault err var dom - where - err = - error $ - locspec ++ "DomainBox.IntMap lookup: domain box " ++ show dom - ++ " ignores variable " ++ show var - -instance (Show val1, Show val2) => - (DomainBoxMappable (Box val1) (Box val2) VarID val1 val2) - where - map = IMap.map - mapWithKey = IMap.mapWithKey - intersectionWith = IMap.intersectionWith - difference = IMap.difference - -instance (RA.ERIntApprox ira) => DomainIntBox (Box ira) VarID ira - where - compatible dom1 dom2 = - foldl (&&) True $ map snd $ - DBox.zipWith RA.equalIntervals dom1 dom2 - unify locspec dom1 dom2 - | DBox.compatible dom1 dom2 = - IMap.union dom1 dom2 - | otherwise = - error $ - locspec ++ "incompatible domains " ++ show dom1 ++ " and " ++ show dom2 - bestSplit domB = - (var, (varDom, pt)) - where - pt = - RA.defaultBisectPt varDom - (_, (varDom, var)) = - foldl findWidestVar (0, err) $ IMap.toList domB - err = - error $ "DomainBox: bestSplit: failed to find a split for " ++ show domB - findWidestVar (prevWidth, prevRes) (v, d) - | currWidth `RA.leqSingletons` prevWidth = (prevWidth, prevRes) - | otherwise = (currWidth, (d, v)) - where - currWidth = snd $ RA.bounds $ domHI - domLO - (domLO, domHI) = RA.bounds d - split domB var maybePt = - (IMap.insert var varDomL domB, - IMap.insert var varDomR domB) - where - varDomL = varDomLO RA.\/ pt - varDomR = pt RA.\/ varDomHI - pt = - case maybePt of - Nothing -> varDomMid - Just pt | pt `RA.refines` varDom -> pt - Just pt -> - error $ - "ER.DomainBox.IntMap: split given an invalid split point " - ++ show pt ++ " for the domain box " ++ show domB - ++ " and split variable " ++ show var - (varDomLO, varDomMid, varDomHI, _) = RA.exactMiddle varDom - varDom = DBox.lookup "DomainBox.IntMap: split: " var domB - classifyPosition dom sdom = - (away, touch, intersect, inside) - where - (away, touch, inside, intersect) = - foldl addDimension (True, True, True, False) awayTouchInsides - addDimension - (prevAway, prevTouch, prevInside, prevIntersect) - (thisAway, thisTouch, thisInside, thisIntersect) = - (prevAway && thisAway, - (prevTouch || prevAway) && (thisTouch || thisAway) && (prevTouch || thisTouch), - prevInside && thisInside, - prevIntersect || thisIntersect) - awayTouchInsides = - map snd $ - DBox.zipWith classifyRA dom sdom - classifyRA d sd = - (outsideNoTouch, outsideTouch, inside, - not (outsideNoTouch || outsideTouch || inside)) - where - outsideNoTouch = sdR < dL || dR < sdL - outsideTouch = sdR == dL || dR == sdL - inside = sdL =< dL && dR =< sdR - (==) = RA.eqSingletons - (<) = RA.ltSingletons - (=<) = RA.leqSingletons - (dL, dR) = RA.bounds d - (sdL, sdR) = RA.bounds sd - - - diff --git a/src/Data/Number/ER/BasicTypes/ExtendedInteger.hs b/src/Data/Number/ER/BasicTypes/ExtendedInteger.hs deleted file mode 100644 --- a/src/Data/Number/ER/BasicTypes/ExtendedInteger.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-| - Module : Data.Number.ER.BasicTypes.ExtendedInteger - Description : integer with infinities - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - An arbitrary sized integer type with additional +infinity and -infinity. - - To be imported qualified, usually with prefix EI. --} -module Data.Number.ER.BasicTypes.ExtendedInteger -( - ExtendedInteger(..), - isInfinite, binaryLog, take -) -where - -import Prelude hiding (isInfinite, take) -import qualified Prelude - -data ExtendedInteger - = MinusInfinity | Finite Integer | PlusInfinity - deriving (Eq) - -isInfinite :: ExtendedInteger -> Bool -isInfinite MinusInfinity = True -isInfinite PlusInfinity = True -isInfinite _ = False - -{-| - the smallest integer i for which 2^i <= abs n --} -binaryLog :: ExtendedInteger -> ExtendedInteger -binaryLog PlusInfinity = PlusInfinity -binaryLog MinusInfinity = PlusInfinity -binaryLog (Finite n) - | n < 0 = binaryLog (Finite (- n)) - | n == 0 = MinusInfinity - | otherwise = -- (n > 0) - -- how to do this fast? - intBinaryLog n - -intBinaryLog n - | n > 1 = 1 + (intBinaryLog (n `div` 2)) - | n == 1 = 0 - -instance Show ExtendedInteger where - show MinusInfinity = "-InfInt" - show PlusInfinity = "+InfInt" - show (Finite i) = show i - -take :: ExtendedInteger -> [a] -> [a] -take MinusInfinity _ = error "takeEI called with MinusInfinity" -take PlusInfinity list = list -take (Finite n) list = Prelude.take (fromInteger n) list - -instance Ord ExtendedInteger where - compare MinusInfinity MinusInfinity = EQ - compare MinusInfinity _ = LT - compare _ MinusInfinity = GT - compare PlusInfinity PlusInfinity = EQ - compare PlusInfinity _ = GT - compare _ PlusInfinity = LT - compare (Finite i1) (Finite i2) = - compare i1 i2 - -instance Num ExtendedInteger where - fromInteger i = Finite i - {- abs -} - abs MinusInfinity = PlusInfinity - abs PlusInfinity = PlusInfinity - abs (Finite i) = Finite $ abs i - {- signum -} - signum ei - | ei < 0 = -1 - | ei > 0 = 1 - | otherwise = 0 - {- negate -} - negate (Finite i) = Finite (-i) - negate MinusInfinity = PlusInfinity - negate PlusInfinity = MinusInfinity - {- addition -} - PlusInfinity + MinusInfinity = - error "cannot add PlusInfinity and MinusInfinity" - MinusInfinity + PlusInfinity = - error "cannot add PlusInfinity and MinusInfinity" - PlusInfinity + ei = PlusInfinity - ei + PlusInfinity = PlusInfinity - MinusInfinity + ei = MinusInfinity - ei + MinusInfinity = MinusInfinity - (Finite i1) + (Finite i2) = Finite $ i1 + i2 - {- multiplication -} - ei1 * ei2 | ei1 > ei2 = ei2 * ei1 - MinusInfinity * ei - | ei < 0 = PlusInfinity - | ei > 0 = MinusInfinity - | otherwise = error "cannot multiply MinusInfinity and 0" - ei * PlusInfinity - | ei < 0 = MinusInfinity - | ei > 0 = PlusInfinity - | otherwise = error "cannot multiply PlusInfinity and 0" - (Finite i1) * (Finite i2) = Finite $ i1 * i2 - -instance Enum ExtendedInteger where - toEnum i = Finite $ toInteger i - fromEnum (Finite i) = fromInteger i - fromEnum _ = error "infinite integers cannot be enumerated" - -instance Real ExtendedInteger where - toRational (Finite i) = toRational i - toRational _ = error "infinite integers cannot be converted to rational" - -instance Integral ExtendedInteger where - quotRem (Finite i) (Finite m) = - (Finite a, Finite b) - where - (a,b) = quotRem i m - quotRem _ _ = error "cannot make a quotient involving an infinite integer" - toInteger (Finite i) = i - toInteger _ = error "infinite integers cannot be converted to Integer" - diff --git a/src/Data/Number/ER/BasicTypes/PlusMinus.hs b/src/Data/Number/ER/BasicTypes/PlusMinus.hs deleted file mode 100644 --- a/src/Data/Number/ER/BasicTypes/PlusMinus.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-| - Module : Data.Number.ER.BasicTypes.PlusMinus - Description : mini sign datatype - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - A mini enumeration to represent the sign of different numbers and approximations. --} -module Data.Number.ER.BasicTypes.PlusMinus where - -import Data.Typeable -import Data.Generics.Basics -import Data.Binary ---import BinaryDerive - -data PlusMinus = Minus | Plus - deriving (Eq, Ord, Typeable, Data) - -instance Show PlusMinus where - show Plus = "+" - show Minus = "-" - -{- the following has been generated by BinaryDerive -} -instance Binary PlusMinus where - put Minus = putWord8 0 - put Plus = putWord8 1 - get = do - tag_ <- getWord8 - case tag_ of - 0 -> return Minus - 1 -> return Plus - _ -> fail "no parse" -{- the above has been generated by BinaryDerive -} - -signNeg Plus = Minus -signNeg Minus = Plus - -signMult Plus s = s -signMult Minus s = signNeg s - -signToNum Plus = 1 -signToNum Minus = -1 diff --git a/src/Data/Number/ER/BasicTypes/Tests/Generate.hs b/src/Data/Number/ER/BasicTypes/Tests/Generate.hs deleted file mode 100644 --- a/src/Data/Number/ER/BasicTypes/Tests/Generate.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-| - Module : Data.Number.ER.BasicTypes.Tests.Generate - Description : (testing) generating values for tests - Copyright : (c) 2007-2008 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Instances of Arbitrary so that values - can be randomly generated for use in QuickCheck tests. --} - -module Data.Number.ER.BasicTypes.Tests.Generate -where - -import Data.Number.ER.BasicTypes -import Data.Number.ER.BasicTypes.ExtendedInteger -import Data.Number.ER.BasicTypes.PlusMinus - -import Test.QuickCheck hiding (two, three) - -data Nat10 = Nat10 Int deriving (Show) -data Nat100 = Nat100 Int deriving (Show) - -data Ix10 = Ix10 EffortIndex deriving (Show) -data Ix20 = Ix20 EffortIndex deriving (Show) - -data Gran100 = Gran100 Granularity deriving (Show) -data Gran1000 = Gran1000 Granularity deriving (Show) - -data SmallRatio = SmallRatio Int Int deriving (Show) - -instance (Arbitrary Nat10) - where - arbitrary = - do - ix <- choose (0,10) - return $ Nat10 ix - coarbitrary (Nat10 ix) = - error "ER.BasicTypes.Tests.Generate: coarbitrary not implemented for Nat10" - -instance (Arbitrary Nat100) - where - arbitrary = - do - ix <- choose (0,100) - return $ Nat100 ix - coarbitrary (Nat100 ix) = - error "ER.BasicTypes.Tests.Generate: coarbitrary not implemented for Nat100" - -instance (Arbitrary Ix20) - where - arbitrary = - do - ix <- choose (2,20) - return $ Ix20 ix - coarbitrary (Ix20 ix) = - error "ER.BasicTypes.Tests.Generate: coarbitrary not implemented for Ix20" - -instance (Arbitrary Ix10) - where - arbitrary = - do - ix <- choose (1,10) - return $ Ix10 ix - coarbitrary (Ix10 ix) = - error "ER.BasicTypes.Tests.Generate: coarbitrary not implemented for Ix10" - -instance (Arbitrary PlusMinus) - where - arbitrary = - do - isPlus <- arbitrary - case isPlus of - True -> return Plus - False -> return Minus - coarbitrary pm = - error "ER.BasicTypes.Tests.Generate: coarbitrary not implemented for PlusMinus" - -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" - - diff --git a/src/Data/Number/ER/Misc.hs b/src/Data/Number/ER/Misc.hs deleted file mode 100644 --- a/src/Data/Number/ER/Misc.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-| - Module : Data.Number.ER.Misc - Description : general purpose extras - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Miscelaneous utilities (eg related to Ordering, pairs, booleans, strings) --} -module Data.Number.ER.Misc where - -import Data.List -import System.IO.Unsafe -import Data.Time.Clock.POSIX - -unsafePrint msg val = - unsafePerformIO $ - do - putStrLn $ "unsafe: " ++ msg - return val - -unsafePrintReturn msg a = - unsafePrint (msg ++ show a) a - -unsafeReport fileName msg val = - unsafePerformIO $ - do - stamp <- getPOSIXTime - appendFile fileName $ showStamp stamp ++ ":" - appendFile fileName $ msg ++ "\n" - return val - where - showStamp stamp = - padTo18 $ show stamp - padTo18 s = s ++ (replicate (18 - (length s)) ' ') - -{-| - Compose as when defining the lexicographical ordering. --} -compareCompose :: Ordering -> Ordering -> Ordering -compareCompose EQ o = o -compareCompose o _ = o - -{-| - Compose as when defining the lexicographical ordering. --} -compareComposeMany :: [Ordering] -> Ordering -compareComposeMany [] = EQ -compareComposeMany (EQ:os) = compareComposeMany os -compareComposeMany (o:_) = o - -{-| - The lexicographical ordering. --} -compareLex :: (Ord a) => [a] -> [a] -> Ordering -compareLex [] _ = LT -compareLex _ [] = GT -compareLex (x:xs) (y:ys) - | x == y = compareLex xs ys - | otherwise = compare x y - -compareListsWith :: - (a -> a -> Ordering) -> - [a] -> [a] -> Ordering -compareListsWith _ [] [] = EQ -compareListsWith _ [] _ = LT -compareListsWith _ _ [] = GT -compareListsWith compareVals (x:xs) (y:ys) = - case compareVals x y of - EQ -> compareListsWith compareVals xs ys - res -> res - -mapFst :: (a1 -> a2) -> (a1,b) -> (a2,b) -mapFst f (a,b) = (f a,b) -mapSnd :: (b1 -> b2) -> (a,b1) -> (a,b2) -mapSnd f (a,b) = (a,f b) -mapPair :: (a1 -> a2, b1 -> b2) -> (a1,b1) -> (a2,b2) -mapPair (f1, f2) (a,b) = (f1 a, f2 b) -mapPairHomog :: (a1 -> a2) -> (a1,a1) -> (a2,a2) -mapPairHomog f = mapPair (f,f) - -unpair :: [(a,a)] -> [a] -unpair = (\(l1,l2) -> l1 ++ l2) . unzip - -bool2maybe :: Bool -> Maybe () -bool2maybe True = Just () -bool2maybe False = Nothing - -dropLast :: Int -> [a] -> [a] -dropLast n list = reverse $ drop n (reverse list) - -{-| - eg - -> concatWith "," ["a","b"] = "a,b" - --} -concatWith :: - String {-^ a connective -} -> - [String] -> - String -concatWith sep [] = "" -concatWith sep [str] = str -concatWith sep (str : strs) = str ++ sep ++ (concatWith sep strs) - -{-| - eg - -> replicateSeveral [(2,"a"),(1,"b")] = "aab" - --} -replicateSeveral :: [(Int,a)] -> [a] -replicateSeveral [] = [] -replicateSeveral ((n,e):rest) = - replicate n e ++ (replicateSeveral rest) - -{-| - eg - -> countDuplicates "aaba" = [(2,"a"),(1,"b"),(1,"a")] - --} -countDuplicates :: - Eq a => - [a] -> - [(Int,a)] -countDuplicates list = - map (\ g -> (length g, head g)) $ group list - -{-| - eg - -> allCombinations -> [ -> (1,['a']), -> (2,['b','c']), -> (3,['d','e','f']) -> ] = -> [ -> [(1,'a'),(2,'b'),(3,'d')], -> [(1,'a'),(2,'b'),(3,'e')], -> [(1,'a'),(2,'b'),(3,'f')], -> [(1,'a'),(2,'c'),(3,'d')], -> [(1,'a'),(2,'c'),(3,'e')], -> [(1,'a'),(2,'c'),(3,'f')] -> ] --} -allCombinations :: - [(k,[v])] -> [[(k,v)]] -allCombinations [] = [[]] -allCombinations ((k, vals) : rest) = - concat $ map (\ v -> map ((k,v):) restCombinations) vals - where - restCombinations = - allCombinations rest - -allPairsCombinations :: - [(k,(v,v))] -> [[(k,v)]] -allPairsCombinations [] = [[]] -allPairsCombinations ((k, (v1,v2)) : rest) = - (map ((k, v1) :) restCombinations) - ++ - (map ((k, v2) :) restCombinations) - where - restCombinations = - allPairsCombinations rest - - -{-| - eg - -> allPairsCombinationsEvenOdd -> [ -> (1,('a0','a1'), -> (2,('b0','b1'), -> (3,('c0','c1') -> ] = -> ([ -> [(1,'a0'),(2,'b0'),(3,'c0')], -> [(1,'a0'),(2,'b1'),(3,'c1')], -> [(1,'a1'),(2,'b1'),(3,'c0')], -> [(1,'a1'),(2,'b0'),(3,'c1')] -> ] -> ,[ -> [(1,'a0'),(2,'b0'),(3,'c1')], -> [(1,'a0'),(2,'b1'),(3,'c0')], -> [(1,'a1'),(2,'b0'),(3,'c0')], -> [(1,'a1'),(2,'b1'),(3,'c1')] -> ] -> ) --} -allPairsCombinationsEvenOdd :: - [(k,(v,v))] {-^ the first value is even, the second odd -} -> - ([[(k,v)]], [[(k,v)]]) -allPairsCombinationsEvenOdd [] = ([[]], []) -allPairsCombinationsEvenOdd ((k, (evenVal,oddVal)) : rest) = - ( - (map ((k, evenVal) :) restCombinationsEven) - ++ - (map ((k, oddVal) :) restCombinationsOdd) - , - (map ((k, evenVal) :) restCombinationsOdd) - ++ - (map ((k, oddVal) :) restCombinationsEven) - ) - where - (restCombinationsEven, restCombinationsOdd) = - allPairsCombinationsEvenOdd rest - - - -{- numeric -} - -intLogDown b n = fst $ intLog b n -intLogUp b n = snd $ intLog b n - -intLog :: - (Num n1, Num n2, Ord n1, Integral n2) => - n1 {-^ base -} -> - n1 {-^ x -} -> - (n2, n2) -intLog b n - | n == 1 = (0,0) - | n > 1 && n < b = (0,1) - | n >= b = - bisect (lgDn, pwDn) (lgUp, pwUp) - | otherwise = - error $ "Data.Number.ER.Misc: intLog: illegal argument n = " ++ show n - where - ((lgDn, pwDn), (lgUp, pwUp)) = - findBounds (1, b) - -- lgDn <= log_b n < lgUp; pwDn = b^lgDn; pwUp = b^lgUp - findBounds (lg, pw) - | n < pwNext = ((lg, pw), (lgNext, pwNext)) - | otherwise = findBounds (lgNext, pwNext) - where - lgNext = 2 * lg - pwNext = pw * pw - bisect (lgDn, pwDn) (lgUp, pwUp) - | pwDn == n = (lgDn, lgDn) - | pwUp == n = (lgUp, lgUp) - | lgDn == lgMid = (lgDn, lgUp) - | lgUp == lgMid = (lgDn, lgUp) - | n < pwMid = - bisect (lgDn, pwDn) (lgMid, pwMid) - | otherwise = - bisect (lgMid, pwMid) (lgUp, pwUp) - where - lgMid = (lgDn + lgUp) `div` 2 - pwMid = pwDn * (b ^ (lgMid - lgDn)) - - -{-| - Directionally rounded versions of @+,*,sum,prod@. --} -plusUp, plusDown, timesUp, timesDown :: - (Num t) => - t -> t -> t -divideUp, divideDown :: - (Fractional t) => - t -> t -> t -sumUp, sumDown, productDown, productUp :: - (Num t) => - [t] -> t -plusUp = (+) -plusDown c1 c2 = - ((- c1) - c2) -sumUp = foldl plusUp 0 -sumDown = foldl plusDown 0 -timesUp = (*) -timesDown c1 c2 = - ((- c1) * c2) -productUp = foldl timesUp 1 -productDown = foldl timesDown 1 -divideUp c1 c2 = c1 / c2 -divideDown c1 c2 = - ((- c1) / c2) - -{- parsing -} -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = - case reads s of - [] -> Nothing - (val,_) : _ -> Just val - -showFirstLastLines :: - (Show a) => - Int {-^ how many initial lines to use -} -> - Int {-^ how many final lines to use -} -> - a -> - String -showFirstLastLines lineCountInit lineCountFinal x - | linesTotal > lineCount = - unlines $ - firstLines - ++ ["...(" ++ show (linesTotal - lineCount) ++ " lines omitted)..."] ++ - lastLines - | otherwise = unlines firstLines - where - lineCount = lineCountInit + lineCountFinal - firstLines = take lineCountInit allLines - lastLines = drop (linesTotal - lineCountFinal) allLines - allLines = lines $ show x - linesTotal = length allLines - -{- sequences -} -listUpdate :: Int -> a -> [a] -> [a] -listUpdate i newx (x:xs) - | i == 0 = newx : xs - | i > 0 = x : (listUpdate (i - 1) newx xs) - - -listHasMatch :: (a -> Bool) -> [a] -> Bool -listHasMatch f s = - foldl (\b a -> b && (f a)) False s - ---{-| types encoding natural numbers -} ---class TypeNumber n --- where --- getTNData :: n --- getTNNumber :: n -> Int --- ---data TN_0 = TN_0 ---tn_0 = TN_0 ---data TN_SUCC tn_prev = TN_SUCC tn_prev --- ---type TN_ONE = TN_SUCC TN_0 ---tn_1 = TN_SUCC TN_0 --- ---instance (TypeNumber TN_0) --- where --- getTNData = TN_0 --- getTNNumber _ = 0 --- ---instance --- (TypeNumber tn_prev) => --- (TypeNumber (TN_SUCC tn_prev)) --- where --- getTNData = TN_SUCC getTNData --- getTNNumber (TN_SUCC p) = 1 + (getTNNumber p) - diff --git a/src/Data/Number/ER/Misc/STM.hs b/src/Data/Number/ER/Misc/STM.hs deleted file mode 100644 --- a/src/Data/Number/ER/Misc/STM.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-| - Module : Data.Number.ER.Misc.STM - Description : some STM extras - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Miscelaneous utilities related to concurrency. --} -module Data.Number.ER.Misc.STM where - -import Control.Concurrent as Concurrent -import Control.Concurrent.STM as STM - -modifyTVar tv update = - do - value <- readTVar tv - let newValue = update value - writeTVar tv newValue - return newValue - -modifyTVarGetOldVal tv update = - do - value <- readTVar tv - writeTVar tv $ update value - return value - -modifyTVarHasChanged tv update = - do - value <- readTVar tv - let newValue = update value - if value == newValue - then return False - else - do - writeTVar tv $ update value - return True - - diff --git a/src/Data/Number/ER/Misc/Tests.hs b/src/Data/Number/ER/Misc/Tests.hs deleted file mode 100644 --- a/src/Data/Number/ER/Misc/Tests.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-| - Module : Data.Number.ER.Misc.Tests - Description : some QuickCheck extras - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Miscelaneous utilities related to testing. --} -module Data.Number.ER.Misc.Tests - -where - -import Data.Number.ER.Misc - -import Test.QuickCheck -import Test.QuickCheck.Batch - -import System.IO - -erRunTests testsetName options initialise tests = - do - mapM (mkRunTest $ length tests) $ zip [1..] tests - return () - where - mkRunTest testCount (n, (testName, test)) = - do - initialise - putStr testDescr - result <- test options - putStrLn $ " result: " ++ show result --- runTests testDescr options [test] - hFlush stdout - where - testDescr = - "(" ++ show n ++ "/" ++ show testCount ++ ") " ++ testsetName ++ ": " ++ testName ++ "\n" - -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 - diff --git a/src/Data/Number/ER/Real.hs b/src/Data/Number/ER/Real.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-| - Module : Data.Number.ER.Real - Description : overview of AERN-Real - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : non-portable (requires fenv.h) - - This module bundles some of the most important functionality - of the AERN-Real package. It is intended to be imported *qualified*. - - AERN-Real provides - datatypes and abstractions for approximating exact real numbers - and a basic arithmetic over such approximations. The approach is - inspired to some degree by Mueller's iRRAM and Lambov's RealLib - (both are C++ libraries for exact real arithmetic). - - Abstractions are provided via 4 type classes: - - * 'B.ERRealBase': generalises floating point numbers - (not exported here, used only internally) - - * 'ERApprox': generalises measurable subsets of real numbers - - * 'ERIntApprox': generalises interval neighbourhoods of real numbers - - * 'ERApproxElementary': generalises real number approximations - that support elementary operations - - For ERRealBase we give several implementations. The default is - an arbitrary precision floating point type that uses Double - for lower precisions and an Integer-based simulation for higher - precisions. Rational numbers can be used as one of the alternatives. - Augustsson's Data.Number.BigFloat can be easily wrapped as an instance - of ERRealBase except that it uses a different method to control precision. - Optionally, one can also have MPFR floating point numbers via package - hmpfr if compiled with USE_MPFR. - - ERIntApprox is implemented via outwards-rounded arbitrary precision interval arithmetic. - Any instance of ERRealBase can be used for the endpoints of the intervals. - - ERApproxElementary is implemented generically for any implementation - of ERIntApprox. This way some of the most common elementary operations are provided, - notably: sqrt, exp, log, sin, cos, atan. These operations converge - to an arbitrary precision and also work well over larger intervals without - excessive wrapping. - - There is also some support for generic Taylor series, interval Newton method - and simple numerical integration. - --} -module Data.Number.ER.Real -( - module Data.Number.ER.Real.Approx, - module Data.Number.ER.Real.Approx.Elementary, - module Data.Number.ER.Real.DefaultRepr, - module Data.Number.ER.Real.Approx.Sequence, - module Data.Number.ER.Real.Arithmetic.Taylor, - module Data.Number.ER.Real.Arithmetic.Newton, - module Data.Number.ER.Real.Arithmetic.Integration, - module Data.Number.ER.BasicTypes -) -where - -import Data.Number.ER.Real.DefaultRepr -import Data.Number.ER.BasicTypes -import qualified Data.Number.ER.Real.Base as B -import Data.Number.ER.Real.Approx -import Data.Number.ER.Real.Approx.Elementary -import Data.Number.ER.Real.Approx.Sequence -import Data.Number.ER.Real.Arithmetic.Taylor -import Data.Number.ER.Real.Arithmetic.Newton -import Data.Number.ER.Real.Arithmetic.Integration - diff --git a/src/Data/Number/ER/Real/Approx.hs b/src/Data/Number/ER/Real/Approx.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx.hs +++ /dev/null @@ -1,421 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Approx - Description : classes abstracting exact reals - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Definitions of classes that describe what is - required from arbitrary precision approximations - of exact real numbers. - - We introduce two levels of abstraction for these - approximations: - - * 'ERApprox' = - Approximating a real number by a *set* of real numbers - that includes the approximated number. - Precision is measured using some fixed measure on the sets. - Operations are "safe" wrt inclusion. - The sets can sometimes be "anti-consistent" - being smaller than - the empty set in the inclusion order. - - * 'ERInnerOuterApprox' = - Like 'ERApprox' with the addition of operations that are "inner rounded" - in the sense that each element of the rounded result set can - be obtained by the same operation performed on some elements of the arument set(s). - - * 'ERIntApprox' = - Like ERApprox but assuming that the sets are - *intervals* of real numbers with finitely - representable endpoints. - - To be imported qualified, usually with the synonym RA. --} -module Data.Number.ER.Real.Approx -( - ERApprox(..), - eqSingletons, - leqSingletons, - ltSingletons, - effIx2ra, - ERInnerOuterApprox(..), - ERIntApprox(..), - splitIRA, - equalIntervals, - exactMiddle, - maxExtensionR2R, - maxExtensionInnerR2R, - ERApproxApprox(..) -) -where - -import Data.Number.ER.BasicTypes -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI - -import Data.Typeable - -{-| - A type whose elements represent sets that can be used - to approximate a single extended real number with arbitrary precision. - - Operations are "safe" with respect to inclusion, which means that - for any numbers admitted by the operand approximations the result - of the operation is admitted by the result approximation. - - The sets can sometimes be "anti-consistent" - being smaller than - the empty set in the inclusion order. - This can be understood as indicating that not only there is no correct real number - approximated here, but some numbers (ie those in interior of the set) - are excluded more strongly than the others. - Prime examples of such sets are directed "inverted" intervals such as [2,1]. - Such sets arise naturally from "inner rounded" operations - see 'ERInnerOuterApprox'. --} -class (Fractional ra) => ERApprox ra - where - initialiseBaseArithmetic :: ra -> IO () - getPrecision :: ra -> Precision - {-^ - Precision is a measure of the set size. It can be infinite. - - The default interpretation: - - * If the diameter of the set is d, then the precision - should be near floor(- log_2 d). - -} - getGranularity :: ra -> Granularity - -- ^ the lower the granularity the bigger the rounding errors - setGranularityOuter :: Granularity -> ra -> ra - -- ^ increase or safely decrease granularity - setMinGranularityOuter :: Granularity -> ra -> ra - -- ^ ensure granularity is not below the first arg - isBottom :: ra -> Bool - -- ^ true if this approximation holds no information, ie it admits any real number - bottomApprox :: ra - -- ^ the bottom approximation - it admits any real number - isExact :: ra -> Bool - -- ^ true if this approximation admits only one real number - isConsistent :: ra -> Bool - {- ^ true iff this approximation admits at least one real number -} - isAnticonsistent :: ra -> Bool - {- ^ true if this approximation is anti-consistent, which is a computational error - unless we used inner rounded operations -} - toggleConsistency :: ra -> ra - {- ^ - Toggle consistency - anti-consistency of the approximation. - Top is toggled with bottom. - Exact approximations are the only fixed points for this operation. - -} - isTop :: ra -> Bool - -- ^ true if this approximation is the most anti-consistent one - topApprox :: ra - -- ^ the top approximation - strongly rejects all real numbers - isDisjoint :: ra -> ra -> Bool - isDisjoint a b = not $ isConsistent $ a /\ b - isInteriorDisjoint :: ra -> ra -> Bool - isInteriorDisjoint a b = isAnticonsistent $ a /\ b - isBounded :: ra -> Bool - {- ^ - True iff the approximation excludes infinity - and, if anti-consistent, does not strongly exclude infinity. - -} - plusInfinity :: ra - -- ^ an exact approximation admitting only the positive infinity - refines :: ra -> ra -> Bool - -- ^ first arg is a subset of the second arg - maybeRefines :: ra -> ra -> Maybe Bool - -- ^ like 'refines' but usable for types where 'refines' is only partially decidable - (/\) :: ra -> ra -> ra - -- ^ join; combining the information in two approximations of the same number - intersectMeasureImprovement :: - EffortIndex -> ra -> ra -> (ra, ra) - {-^ - First component of result is the intersection and the second component: - - * measures precision improvement of the intersection relative to the first argument - - * is a positive number: 1 means no improvement, 2 means doubled precision, etc. - -} - equalReals :: ra -> ra -> Maybe Bool - -- ^ semantic semi-decidable equality test - compareReals :: ra -> ra -> Maybe Ordering - -- ^ semantic semi-decidable comparison - leqReals :: ra -> ra -> Maybe Bool - -- ^ semantic semi-decidable less-than-or-equal comparison - equalApprox :: ra -> ra -> Bool - -- ^ syntactic equality test - compareApprox :: ra -> ra -> Ordering - -- ^ syntactic linear ordering - double2ra :: Double -> ra - -- ^ safe approximate conversion - showApprox :: - Int {-^ number of relevant decimals to show -} -> - Bool {-^ should show granularity -} -> - Bool {-^ should show internal representation details -} -> - ra {-^ the approximation to show -} -> - String - -{-| - Assuming the arguments are singletons, equality is decidable. --} -eqSingletons :: (ERApprox ra) => ra -> ra -> Bool -eqSingletons s1 s2 = - case equalReals s1 s2 of - Just b -> b - _ -> False - -{-| - Assuming the arguments are singletons, @<=@ is decidable. --} -leqSingletons :: (ERApprox ra) => ra -> ra -> Bool -leqSingletons s1 s2 = - case compareReals s1 s2 of - Just EQ -> True - Just LT -> True - _ -> False - -{-| - Assuming the arguments are singletons, @<@ is decidable. --} -ltSingletons :: (ERApprox ra) => ra -> ra -> Bool -ltSingletons s1 s2 = - case compareReals s1 s2 of - Just LT -> True - _ -> False - -{-| - This function converts - an effort index to a real number approximation. - - Useful when an effort index is used in a formula - mixed with real approximations. --} -effIx2ra :: - (ERApprox ra) => - EffortIndex -> ra -effIx2ra = fromInteger . toInteger - -{-| - A type whose elements represent some kind of nominal sets of real numbers - over which one can perform two kinds of arithmetic: - - * "outer rounded": arithmetic that approximates maximal extensions from outside (ie the 'ERApprox' arithmetic) - - * "inner rounded": arithmetic that approximates maximal extensions from inside, potentially leading to - anti-consistent set specifications (eg intervals whose endpoints are not in the usual order) - - Another explanation of the difference: - - * `outer': the approximation contains all the number(s) of interest - * `inner': all numbers eligible for the approximation are numbers of interest - - Ie inner rounded operations have the property that each real number admitted by the result can - be obtained as the exact result of the same operation performed on some real numbers admitted - by the operand approximations. - - While in "outer rounded" operations it is desirable to make the result set as small as - possible in order to reduce the amount of bogus result numbers, - in "inner rounded" operations it is desirable to make the result set as large as possible - to lose less of the genuinely feasible result numbers. - - Inner rounded arithmetic is useful eg for proving/disproving inclusions "f(x) subset g(x)" - where f and g are expressions using arithmetic extended to sets. - For proving the inclusion, we need an inner rounded approximation of g(x) - and for disproving the inclusion we need an inner rounded approximation of f(x). - - This is an abstraction of Kaucher's extended interval arithmetic - [Kaucher, E.: Interval Analysis in the Extended Interval Space IR, - Computing, Suppl. 2, 1980, pp. 33-49]. --} -class (ERApprox xra) => ERInnerOuterApprox xra - where - (+:) :: xra -> xra -> xra - -- ^ inner rounded addition - (-:) :: xra -> xra -> xra - -- ^ inner rounded subtraction - a -: b = a +: (negate b) - (*:) :: xra -> xra -> xra - -- ^ inner rounded multiplication - (/:) :: xra -> xra -> xra - -- ^ inner rounded division - setGranularityInner :: Granularity -> xra -> xra - -- ^ increase or safely decrease granularity - setMinGranularityInner :: Granularity -> xra -> xra - -- ^ ensure granularity is not below the first arg - -{-| - A type whose elements represent sets that can be used - to approximate a recursive set of closed extended real number intervals - with arbitrary precision. --} ---class (ERApprox sra) => ERSetApprox sra where --- (\/) :: sra -> sra -> sra -- ^ union; either approximation could be correct - -{-| - A type whose elements represent real *intervals* that can be used - to approximate a single extended real number with arbitrary precision. - - Sometimes, these types can be used to approximate - a closed extended real number interval with arbitrary precision. - Nevetheless, this is not guaranteed. --} -class (ERApprox ira) => ERIntApprox ira - where - doubleBounds :: ira -> (Double, Double) - floatBounds :: ira -> (Float, Float) - integerBounds :: ira -> (EI.ExtendedInteger, EI.ExtendedInteger) - bisectDomain :: - Maybe ira {-^ point to split at -} -> - ira {-^ interval to split -} -> - (ira, ira) -- ^ left and right, overlapping on a singleton - defaultBisectPt :: ira -> ira - -- | returns thin approximations of endpoints, in natural order - bounds :: ira -> (ira, ira) - -- | make an interval from thin approximations of endpoints - fromBounds :: (ira, ira) -> ira - {-| - meet, usually constructing interval from approximations of its endpoints - - This does not need to be the meet of the real intervals - but it has to be a maximal element in the set of all - ira elements that are below the two parameters. - -} - (\/) :: ira -> ira -> ira - -{-| - Return true if and only if the two intervals have equal endpoints. --} -equalIntervals :: - (ERIntApprox ira) => ira -> ira -> Bool -equalIntervals d1 d2 = - d1L == d2L && d1U == d2U - where - (==) = eqSingletons - (d1L, d1U) = bounds d1 - (d2L, d2U) = bounds d2 - - -{-| - Split an interval to a sequence of intervals whose union is the - original interval using a given sequence of cut points. - The cut points are expected to be in increasing order and contained - in the given interval. Violations of this rule are tolerated. --} -splitIRA :: - (ERIntApprox ira) => - ira {-^ an interval to be split -} -> - [ira] {-^ approximations of the cut points in increasing order -} -> - [ira] -splitIRA interval splitPoints = - doSplit [] end pointsRev - where - (start, end) = bounds interval - pointsRev = reverse $ start : splitPoints - doSplit previousSegments nextRight [] = previousSegments - doSplit previousSegments nextRight (nextLeft : otherPoints) = - doSplit (nextLeft \/ nextRight : previousSegments) nextLeft otherPoints - -{-| - * Return the endpoints of the interval as well as the exact midpoint. - - * To be able to do this, there may be a need to increase granularity. - - * All three singleton intervals are set to the same new granularity. --} -exactMiddle :: - (ERIntApprox ira) => - ira -> - (ira,ira,ira,Granularity) -exactMiddle dom = - case isExact domM of - True -> - (domL, domM, domR, gran) - False -> - (domLhg, domMhg, domRhg, higherGran) - where - (domL, domR) = bounds dom - gran = max (getGranularity domL) (getGranularity domR) - domM = (domL + domR) / 2 - higherGran = gran + 1 - domLhg = setMinGranularityOuter higherGran domL - domRhg = setMinGranularityOuter higherGran domR - domMhg = (domLhg + domRhg) / 2 - - -{-| - This produces a function that computes the maximal extension of the - given function. A maximal extension function has the property: - f(I) = { f(x) | x in I }. Here we get this property only for the - limit function for its 'EffortIndex' tending to infinity. - For finite effor indices the function may add *outer* rounding - but it should be reasonably small. --} -maxExtensionR2R :: - (ERIntApprox ira) => - (EffortIndex -> ira -> [ira]) - {-^ returns an *outer* approximation of all extrema within the interval -} -> - (EffortIndex -> ira -> ira) - {-^ an *outer* rounding function behaving well on sequences that intersect to a point -} -> - (EffortIndex -> ira -> ira) - {- ^ an outer rounding function behaving well on sequences that intersect to a non-empty interval -} -maxExtensionR2R getExtremes f ix x - | not $ isConsistent x = - toggleConsistency $ - maxExtensionInnerR2R getExtremes f ix $ toggleConsistency x - | getPrecision x < effIx2prec ix = - foldl1 (\/) $ [f ix xL, f ix xR] ++ (getExtremes ix x) - -- x is thin enough (?), don't bother evaluating by endpoints and extrema: - | otherwise = - f ix x - where - (xL, xR) = bounds x - -{-| - This produces a function that computes the maximal extension of the - given function. A maximal extension function has the property: - f(I) = { f(x) | x in I }. Here we get this property only for the - limit function for its 'EffortIndex' tending to infinity. - For finite effor indices the function may include *inner* rounding - but it should be reasonably small. --} -maxExtensionInnerR2R :: - (ERIntApprox ira) => - (EffortIndex -> ira -> [ira]) - {-^ returns an *outer* approximation of all extrema within the interval -} -> - (EffortIndex -> ira -> ira) - {-^ an *outer* rounding function behaving well on sequences that intersect to a point -} -> - (EffortIndex -> ira -> ira) - {- ^ an inner rounding function behaving well on sequences that intersect to a non-empty interval -} -maxExtensionInnerR2R getExtremes f ix x - | not $ isConsistent x = - toggleConsistency $ - maxExtensionR2R getExtremes f ix $ toggleConsistency x - | otherwise = - foldl1 (\/) $ map toggleConsistency $ [f ix xL, f ix xR] ++ (getExtremes ix x) - where - (xL, xR) = bounds x - -{-| - A type whose elements are thought of as sets of approximations of real numbers. - - Eg intervals of intervals, eg [[0,3],[1,2]] containing all intervals - whose left endpoint is between 0 and 1 and the right endpoint is between 2 and 3. - The upper bound interval can sometimes be anti-consistent, - eg [[0,3],[2,1]] containing all intervals (consistent as well as anti-consistent) - with a left endpoint between [0,2] and the right endpoint between [1,3]. --} -class ERApproxApprox xra - where - safeIncludes :: xra -> xra -> Bool - -- ^ safe inclusion of approximations - safeNotIncludes :: xra -> xra -> Bool - -- ^ safe negation of inclusion of approximations - includes :: xra -> xra -> Maybe Bool - -- ^ like 'safeIncludes' but usable for types where 'safeIncludes' is only partially decidable - includes aa1 aa2 - | safeIncludes aa1 aa2 = Just True - | safeNotIncludes aa1 aa2 = Just False - | otherwise = Nothing diff --git a/src/Data/Number/ER/Real/Approx/Elementary.hs b/src/Data/Number/ER/Real/Approx/Elementary.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx/Elementary.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Approx.Elementary - Description : abstraction of exact reals capable of elementary operations - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - To be imported qualified, usually with the synonym RAEL. --} -module Data.Number.ER.Real.Approx.Elementary -( - ERApproxElementary(..), - ERInnerOuterApproxElementary(..) -) -where - -import Prelude hiding (exp, log, sin, cos) - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.Real.Approx ((+:),(-:),(*:),(/:)) -import Data.Number.ER.BasicTypes - -import Data.Number.ER.Real.Arithmetic.Elementary - -{-| - A class defining various common real number operations - in a approximation-aware fashion, ie introducing effort indices. - - All operations here have default implementations based on - "Data.Number.ER.Real.Arithmetic.Elementary". --} -class (RA.ERIntApprox ra, Ord ra) => (ERApproxElementary ra) - where - abs :: EffortIndex -> ra -> ra - abs ix = Prelude.abs - min :: EffortIndex -> ra -> ra -> ra - min ix = Prelude.min - max :: EffortIndex -> ra -> ra -> ra - max ix = Prelude.max - sqrt :: EffortIndex -> ra -> ra - sqrt = erSqrt_IR - exp :: EffortIndex -> ra -> ra - exp = erExp_IR - log :: EffortIndex -> ra -> ra - log = erLog_IR - (**) :: EffortIndex -> ra -> ra -> ra - (**) ix b e = exp ix $ e * (log ix b) - pi :: EffortIndex -> ra - pi = erPi_R - sin :: EffortIndex -> ra -> ra - sin = erSine_IR - cos :: EffortIndex -> ra -> ra - cos = erCosine_IR - tan :: EffortIndex -> ra -> ra - tan ix r = (sin ix r) / (cos ix r) - atan :: EffortIndex -> ra -> ra - atan = erATan_IR - -{-| - A class defining various common real number operations - in a approximation-aware fashion, ie introducing effort indices. - - All operations here have default implementations based on - "Data.Number.ER.Real.Arithmetic.Elementary". --} -class (RA.ERIntApprox ra, RA.ERInnerOuterApprox ra, Ord ra) => (ERInnerOuterApproxElementary ra) - where - absInner :: EffortIndex -> ra -> ra - absInner ix = Prelude.abs - minInner :: EffortIndex -> ra -> ra -> ra - minInner ix = Prelude.min - maxInner :: EffortIndex -> ra -> ra -> ra - maxInner ix = Prelude.max - sqrtInner :: EffortIndex -> ra -> ra - sqrtInner = erSqrt_IR_Inner - expInner :: EffortIndex -> ra -> ra - expInner = erExp_IR_Inner - logInner :: EffortIndex -> ra -> ra - logInner = erLog_IR_Inner - (**:) :: EffortIndex -> ra -> ra -> ra - (**:) ix b e = expInner ix $ e *: (logInner ix b) - sinInner :: EffortIndex -> ra -> ra - sinInner = erSine_IR_Inner - cosInner :: EffortIndex -> ra -> ra - cosInner = erCosine_IR_Inner - tanInner :: EffortIndex -> ra -> ra - tanInner ix r = (sinInner ix r) /: (cosInner ix r) - atanInner :: EffortIndex -> ra -> ra - atanInner = erATan_IR_Inner - - - - diff --git a/src/Data/Number/ER/Real/Approx/Interval.hs b/src/Data/Number/ER/Real/Approx/Interval.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx/Interval.hs +++ /dev/null @@ -1,574 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-| - Module : Data.Number.ER.Real.Approx.Interval - Description : safe interval arithmetic - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - This module defines an arbitrary precision interval type and - most of its interval arithmetic operations. --} -module Data.Number.ER.Real.Approx.Interval -( - ERInterval(..), - normaliseERIntervalOuter, - normaliseERIntervalInner -) -where - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.Real.Approx ((+:),(-:),(*:),(/:)) -import qualified Data.Number.ER.Real.Approx.Elementary as RAEL -import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI - -import Data.Number.ER.BasicTypes -import Data.Number.ER.Misc - -import Data.Ratio - -import qualified Text.Html as H - -import Data.Typeable -import Data.Generics.Basics -import Data.Binary ---import BinaryDerive - -{-| - Type for arbitrary precision interval arithmetic. --} -data ERInterval base = --- ERIntervalEmpty -- ^ usually represents computation error (top element in the interval domain) --- | ERIntervalAny -- ^ represents no knowledge of result (bottom element in the interval domain) - ERInterval - { - erintv_left :: !base, - erintv_right :: !base - } - deriving (Typeable, Data) - -{- the following has been generated by BinaryDerive -} -instance (Binary a) => Binary (ERInterval a) where - put (ERInterval a b) = putWord8 0 >> put a >> put b - get = do - tag_ <- getWord8 - case tag_ of - 0 -> get >>= \a -> get >>= \b -> return (ERInterval a b) - _ -> fail "no parse" -{- the above has been generated by BinaryDerive -} - - -{-| - convert to a normal form, ie: - - * no NaNs as endpoints - - Note that inverted intervals are fully supported using Warmus-Kaucher arithmetic. - This version interprets NaN's as bottomApprox. --} -normaliseERIntervalOuter :: - (B.ERRealBase b) => - ERInterval b -> ERInterval b -normaliseERIntervalOuter (ERInterval nan1 nan2) - | B.isERNaN nan1 && B.isERNaN nan2 = - RA.bottomApprox -normaliseERIntervalOuter (ERInterval nan r) - | B.isERNaN nan = - ERInterval (- B.plusInfinity) r -normaliseERIntervalOuter (ERInterval l nan) - | B.isERNaN nan = - ERInterval l (B.plusInfinity) -normaliseERIntervalOuter i = i - -{-| - convert to a normal form, ie: - - * no NaNs as endpoints - - Note that inverted intervals are fully supported using Warmus-Kaucher arithmetic. - This version interprets NaN's as topApprox. --} -normaliseERIntervalInner :: - (B.ERRealBase b) => - ERInterval b -> ERInterval b -normaliseERIntervalInner (ERInterval nan1 nan2) - | B.isERNaN nan1 && B.isERNaN nan2 = - RA.topApprox -normaliseERIntervalInner (ERInterval nan r) - | B.isERNaN nan = - ERInterval (B.plusInfinity) r -normaliseERIntervalInner (ERInterval l nan) - | B.isERNaN nan = - ERInterval l (- B.plusInfinity) -normaliseERIntervalInner i = i - -{-| - erintvPrecision returns an approximation of the number of bits required - to represent the mantissa of a normalised size of the interval: - - > - log_2 ((r - l) / (1 + abs(r) + abs(l))) - - Notice that this is +Infty for singleton and anti-consistent intervals - and -Infty for unbounded intervals. --} -erintvPrecision :: - (B.ERRealBase b) => - ERInterval b -> EI.ExtendedInteger -erintvPrecision i@(ERInterval l r) - | not $ RA.isConsistent i = EI.PlusInfinity - | not $ RA.isBounded i = EI.MinusInfinity - | otherwise = - -1 - (B.getApproxBinaryLog $ (r - l)) -- /(1 + abs r + abs l)) - -erintvGranularity :: - (B.ERRealBase b) => - ERInterval b -> Int -erintvGranularity (ERInterval l r) = - min (B.getGranularity l) (B.getGranularity r) - -{- syntactic comparisons -} - -{-| - a syntactic equality test --} -erintvEqualApprox :: - (B.ERRealBase b) => - ERInterval b -> ERInterval b -> Bool -erintvEqualApprox (ERInterval l1 r1) (ERInterval l2 r2) = - l1 == l2 && r1 == r2 - -{-| - a syntactic linear order --} -erintvCompareApprox :: - (B.ERRealBase b) => - ERInterval b -> ERInterval b -> Ordering -erintvCompareApprox (ERInterval l1 r1) (ERInterval l2 r2) = - case compare l1 l2 of - EQ -> compare r1 r2 - res -> res - -{- semantic comparisons -} - -{-| - Compare for equality two intervals interpreted as approximations for - 2 single real numbers. When equality or inequality cannot - be established, return Nothing (ie bottom). --} -erintvEqualReals :: - (B.ERRealBase b) => - ERInterval b -> - ERInterval b -> - Maybe Bool -erintvEqualReals (ERInterval l1 r1) (ERInterval l2 r2) - | l1 == r1 && l2 == r2 && l1 == l2 = Just True - | r1 < l2 || l1 > r2 = Just False - | otherwise = Nothing - -{-| - Compare in natural order two intervals interpreted as approximations for - 2 single real numbers. When equality or inequality cannot - be established, return Nothing (ie bottom). --} -erintvCompareReals :: - (B.ERRealBase b) => - ERInterval b -> - ERInterval b -> - Maybe Ordering -erintvCompareReals i1@(ERInterval l1 r1) i2@(ERInterval l2 r2) - | r1 < l2 = Just LT - | l1 > r2 = Just GT - | l1 == r1 && l2 == r2 && l1 == l2 = Just EQ - | otherwise = Nothing - -{-| - Compare in natural order two intervals interpreted as approximations for - 2 single real numbers. When relaxed equality cannot - be established nor disproved, return Nothing (ie bottom). --} -erintvLeqReals :: - (B.ERRealBase b) => - ERInterval b -> - ERInterval b -> - Maybe Bool -erintvLeqReals i1@(ERInterval l1 r1) i2@(ERInterval l2 r2) - | r1 <= l2 = Just True - | l1 > r2 = Just False - | otherwise = Nothing - - -{-| - - Default splitting: - - > [-Infty,+Infty] |-> [-Infty,0] [0,+Infty] - - > [-Infty,x] |-> [-Infty,2*x-1] [2*x-1, x] (x <= 0) - - > [-Infty,x] |-> [-Infty,0] [0, x] (x > 0) - - > [x,+Infty] |-> [x,2*x+1] [2*x+1,+Infty] (x => 0) - - > [x,+Infty] |-> [x,0] [0,+Infty] (x < 0) - - > [x,y] |-> [x, (x+y)/2] [(x+y)/2, y] - - > empty |-> empty empty --} -erintvDefaultBisectPt :: - (B.ERRealBase b) => - Granularity -> - (ERInterval b) -> - (ERInterval b) -erintvDefaultBisectPt gran (ERInterval l r) = - ERInterval m m - where - m = - case (B.isMinusInfinity l, B.isPlusInfinity r, B.isPlusInfinity l, B.isMinusInfinity r) of - (True, True, _, _) -> 0 -- [-oo,+oo] - (True, _,_,True) -> B.minusInfinity -- [-oo,-oo] - (_, True,True,_) -> B.plusInfinity -- [+oo,+oo] - (True, _,_,_) | r > 0 -> 0 - (True, _,_,_) -> 2 * (B.setMinGranularity gran r) - 1 - (_,True,_,_) | l < 0 -> 0 - (_,True,_,_) -> 2 * (B.setMinGranularity gran l) + 1 - (_,_,True,_) | r < 0 -> 0 - (_,_,True,_) -> 2 * (B.setMinGranularity gran r) + 1 - (_,_,_,True) | l > 0 -> 0 - (_,_,_,True) -> 2 * (B.setMinGranularity gran l) - 1 - _ -> ((B.setMinGranularity gran l) + r)/2 -- no infinities - - -erintvBisect :: - (B.ERRealBase b) => - Granularity -> - (Maybe (ERInterval b)) -> - (ERInterval b) -> - (ERInterval b, ERInterval b) -erintvBisect gran maybePt i@(ERInterval l r) = - (ERInterval l mR, ERInterval mL r) - where - ERInterval mL mR = m - m = - case maybePt of - Just m -> m - Nothing -> erintvDefaultBisectPt gran i - -instance (B.ERRealBase b) => Eq (ERInterval b) where - i1 == i2 = - case erintvEqualReals i1 i2 of - Nothing -> - error $ - "ERInterval: Eq: comparing overlapping intervals:\n" ++ - show i1 ++ "\n" ++ - show i2 - Just b -> b - -instance (B.ERRealBase b) => Ord (ERInterval b) where - compare i1 i2 = - case erintvCompareReals i1 i2 of - Nothing -> - error $ - "ERInterval: Ord: comparing overlapping intervals:\n" ++ - show i1 ++ "\n" ++ - show i2 - Just r -> r - {- max: - (Default implementation is wrong in this case: - eg compare is not defined for overlapping intervals.) - -} - max i1@(ERInterval l1 r1) i2@(ERInterval l2 r2) = - ERInterval (max l1 l2) (max r1 r2) - {- min: -} - min i1@(ERInterval l1 r1) i2@(ERInterval l2 r2) = - ERInterval (min l1 l2) (min r1 r2) - -instance (B.ERRealBase b) => Show (ERInterval b) - where - show = erintvShow 16 True False - -erintvShow numDigits showGran showComponents interval = - showERI interval - where - showERI (ERInterval l r) - | (B.isMinusInfinity r) && (B.isPlusInfinity r) = - "[ANY]" - | l == r = "<" ++ showBase l ++ ">" - | l > r = - "[!" ++ showBase l ++ "," ++ showBase r ++ "!]" - | otherwise = - "[" ++ showBase l ++ "," ++ showBase r ++ "]" - showBase = B.showDiGrCmp numDigits showGran showComponents - -instance (B.ERRealBase b, H.HTML b) => H.HTML (ERInterval b) - where - toHtml (ERInterval l r) - | l == r = - H.toHtml $ show l - | otherwise = - H.simpleTable [] [] [[H.toHtml l],[H.toHtml r]] - -instance (B.ERRealBase b) => Num (ERInterval b) where - fromInteger n = - ERInterval (B.fromIntegerDown n) (B.fromIntegerUp n) - {- abs -} - abs (ERInterval l r) - | l <= 0 && r >= 0 = ERInterval 0 (max (-l) r) - | l >= 0 && r <= 0 = ERInterval (max l (-r)) 0 - | r <= 0 = ERInterval (-r) (-l) - | otherwise = ERInterval l r - {- signum -} - signum i@(ERInterval l r) = - error "ER.Real.Approx.Interval: signum not implemented for ERInterval" --- | l < 0 && r > 0 = ERInterval (-1) 1 -- need many-valuedness via sequences of intervals --- | r < 0 = ERInterval (-1) (-1) --- | l > 0 = ERInterval 1 1 --- | l == 0 && r == 0 = i --- | l == 0 = ERInterval 0 1 --- | r == 0 = ERInterval (-1) 0 - {- negate -} - negate (ERInterval l r) = (ERInterval (-r) (-l)) - {- addition -} - i1@(ERInterval l1 r1) + i2@(ERInterval l2 r2) = - normaliseERIntervalOuter $ - ERInterval (l1 `plusDown` l2) (r1 `plusUp` r2) - {- multiplication -} - i1@(ERInterval l1 r1) * i2@(ERInterval l2 r2) = - normaliseERIntervalOuter $ - intervalTimes timesDown timesUp i1 i2 - -instance (B.ERRealBase b) => Fractional (ERInterval b) where - fromRational rat = - (fromInteger $ numerator rat) - / (fromInteger $ denominator rat) - {- division -} - recip i@(ERInterval l r) - | not $ RA.isConsistent i = - RA.toggleConsistency $ - 1 /: (RA.toggleConsistency i) - | 0 < l || r < 0 = - normaliseERIntervalOuter $ - ERInterval (1 `divideDown` r) (1 `divideUp` l) - | otherwise = - RA.bottomApprox - - -instance (B.ERRealBase b) => RA.ERInnerOuterApprox (ERInterval b) - where - {- addition -} - i1@(ERInterval l1 r1) +: i2@(ERInterval l2 r2) = - normaliseERIntervalInner $ - ERInterval (l1 `plusUp` l2) (r1 `plusDown` r2) - {- multiplication -} - i1@(ERInterval l1 r1) *: i2@(ERInterval l2 r2) = - normaliseERIntervalInner $ - intervalTimes timesUp timesDown i1 i2 - {- division -} - i1@(ERInterval l1 r1) /: i2@(ERInterval l2 r2) - | not $ RA.isConsistent i2 = - (*:) i1 $ - RA.toggleConsistency $ - 1 / (RA.toggleConsistency i2) - | 0 < l2 || r2 < 0 = - (*:) i1 $ - normaliseERIntervalInner $ - ERInterval (1 `divideDown` r2) (1 `divideUp` l2) - | otherwise = - RA.bottomApprox - {- setMinGranularityInner -} - setMinGranularityInner gr (ERInterval l r) = - normaliseERIntervalInner $ - (ERInterval (B.setMinGranularity gr l) (negate $ B.setMinGranularity gr (-r))) - {- setGranularityInner -} - setGranularityInner gr (ERInterval l r) = - normaliseERIntervalInner $ - (ERInterval (B.setGranularity gr l) (negate $ B.setGranularity gr (- r))) - -intervalTimes timesL timesR i1@(ERInterval l1 r1) i2@(ERInterval l2 r2) = - ERInterval l r - where - (l,r) = - case (compare l1 0, compare r1 0, l1 <= r1, compare l2 0, compare r2 0, l2 <= r2) of - -- i1 negative, i2 positive - (LT, LT, _, GT, GT, _) -> (l1 `timesL` r2, r1 `timesR` l2) - -- i1 negative, i2 negative - (LT, LT, _, LT, LT, _) -> (r1 `timesL` r2, l1 `timesR` l2) - -- i1 negative, i2 consistent and containing zero - (LT, LT, _, _, _, True) -> (l1 `timesL` r2, l1 `timesR` l2) - -- i1 negative, i2 inconsistent and anti-containing zero - (LT, LT, _, _, _, False) -> (r1 `timesL` r2, r1 `timesR` l2) - - -- i1 positive, i2 positive - (GT, GT, _, GT, GT, _) -> (l1 `timesL` l2, r1 `timesR` r2) - -- i1 positive, i2 negative - (GT, GT, _, LT, LT, _) -> (r1 `timesL` l2, l1 `timesR` r2) - -- i1 positive, i2 consistent and containing zero - (GT, GT, _, _, _, True) -> (r1 `timesL` l2, r1 `timesR` r2) - -- i1 positive, i2 inconsistent and anti-containing zero - (GT, GT, _, _, _, False) -> (l1 `timesL` l2, l1 `timesR` r2) - - -- i1 consistent and containing zero, i2 positive - (_, _, True, GT, GT, _) -> (l1 `timesL` r2, r1 `timesR` r2) - -- i1 consistent and containing zero, i2 negative - (_, _, True, LT, LT, _) -> (r1 `timesL` l2, l1 `timesR` l2) - -- i1 consistent and containing zero, i2 consistent and containing zero - (_, _, True, _, _, True) -> - (l,r) - where - l | B.isERNaN l1r2 || B.isERNaN r1l2 = B.minusInfinity - | otherwise = min l1r2 r1l2 - where - l1r2 = l1 `timesL` r2 - r1l2 = r1 `timesL` l2 - r | B.isERNaN l1l2 || B.isERNaN r1r2 = B.plusInfinity - | otherwise = max l1l2 r1r2 - where - l1l2 = l1 `timesR` l2 - r1r2 = r1 `timesR` r2 - -- i1 consistent and containing zero, i2 inconsistent and anti-containing zero - (_, _, True, _, _, False) -> (0, 0) - - -- i1 inconsistent and anti-containing zero, i2 positive - (_, _, False, GT, GT, _) -> (l1 `timesL` l2, r1 `timesR` l2) - -- i1 inconsistent and anti-containing zero, i2 negative - (_, _, False, LT, LT, _) -> (r1 `timesL` r2, l1 `timesR` r2) - -- i1 inconsistent and anti-containing zero, i2 consistent and containing zero - (_, _, False, _, _, True) -> (0, 0) - -- i1 inconsistent and anti-containing zero, i2 the same - (_, _, False, _, _, False) -> - (l,r) - where - l | B.isERNaN l1l2 || B.isERNaN r1r2 = B.plusInfinity - | otherwise = max l1l2 r1r2 - where - l1l2 = l1 `timesL` l2 - r1r2 = r1 `timesL` r2 - r | B.isERNaN l1r2 || B.isERNaN r1l2 = B.minusInfinity - | otherwise = min l1r2 r1l2 - where - l1r2 = l1 `timesR` r2 - r1l2 = r1 `timesR` l2 - - - - -instance (B.ERRealBase b) => RA.ERApprox (ERInterval b) where - initialiseBaseArithmetic _ = - B.initialiseBaseArithmetic (0 :: b) - getPrecision i = erintvPrecision i - getGranularity i = erintvGranularity i - {- setMinGranularity -} - setMinGranularityOuter gr (ERInterval l r) = - normaliseERIntervalOuter $ - (ERInterval (- (B.setMinGranularity gr (-l))) (B.setMinGranularity gr r)) - {- setGranularity -} - setGranularityOuter gr (ERInterval l r) = - normaliseERIntervalOuter $ - (ERInterval (- (B.setGranularity gr (-l))) (B.setGranularity gr r)) - {- isBottom -} - isBottom (ERInterval l r) = - B.isMinusInfinity l && B.isPlusInfinity r - {- bottomApprox -} - bottomApprox = - ERInterval B.minusInfinity B.plusInfinity - {- isExact -} - isExact (ERInterval l r) = l == r - {- isConsistent -} - isConsistent (ERInterval l r) = l <= r - {- isAnticonsistent -} - isAnticonsistent (ERInterval l r) = l >= r - {- toggleConsistency -} - toggleConsistency (ERInterval l r) = (ERInterval r l) - {- isTop -} - isTop (ERInterval l r) = - B.isPlusInfinity l && B.isMinusInfinity r - {- topApprox -} - topApprox = - ERInterval B.plusInfinity B.minusInfinity - {- isBounded -} - isBounded (ERInterval l r) = - (- B.plusInfinity) < l && l < B.plusInfinity - && - (- B.plusInfinity) < r && r < B.plusInfinity - {- plusInfinity -} - plusInfinity = ERInterval B.plusInfinity B.plusInfinity - {- refines -} - refines (ERInterval l1 r1) (ERInterval l2 r2) = - l2 <= l1 && r1 <= r2 - {- maybeRefines -} - maybeRefines i1 i2 = Just $ RA.refines i1 i2 - - {- intersection -} - (ERInterval l1 r1) /\ (ERInterval l2 r2) = - ERInterval (max l1 l2) (min r1 r2) - {- intersectMeasureImprovement -} - intersectMeasureImprovement ix i1 i2 = - (isec, impr) - where - isec = i1 RA./\ i2 - impr - | 0 `RA.refines` isecWidth && 0 `RA.refines` i1Width = 1 -- 0 -> 0 is no improvement - | otherwise = i1Width / isecWidth - i1Width = i1H - i1L - isecWidth = isecH - isecL - (isecL, isecH) = RA.bounds $ RA.setMinGranularityOuter gran isec - (i1L, i1H) = RA.bounds $ RA.setMinGranularityOuter gran i1 - gran = effIx2gran ix - - {- semantic comparisons -} - equalReals = erintvEqualReals - compareReals = erintvCompareReals - leqReals = erintvLeqReals - {- non-semantic comparisons -} - equalApprox = erintvEqualApprox - compareApprox = erintvCompareApprox - {- conversion from Double -} - double2ra d = - ERInterval b b - where - b = B.fromDouble d - {- formatting -} - showApprox = erintvShow - -instance (B.ERRealBase b) => RA.ERIntApprox (ERInterval b) - where - doubleBounds (ERInterval l r) = - (negate $ B.toDouble (-l), B.toDouble r) - floatBounds (ERInterval l r) = - (negate $ B.toFloat (-l), B.toFloat r) - integerBounds (ERInterval l r) = - (negate $ mkEI (- l), mkEI r) - where - mkEI f - | B.isPlusInfinity f = EI.PlusInfinity - | B.isMinusInfinity f = EI.MinusInfinity - | otherwise = ceiling f - defaultBisectPt dom = - erintvDefaultBisectPt (RA.getGranularity dom + 1) dom - bisectDomain maybePt dom = - erintvBisect (RA.getGranularity dom + 1) maybePt dom - {- \/ -} - (ERInterval l1 r1) \/ (ERInterval l2 r2) = - ERInterval (min l1 l2) (max r1 r2) - {- RA.bounds -} - bounds (ERInterval l r) = - (ERInterval l l, ERInterval r r) - {- RA.fromBounds -} - fromBounds (ERInterval l1 r1, ERInterval l2 r2) - | l1 == r1 && l2 == r2 = ERInterval l1 l2 - fromBounds i1i2 = - error $ - "ER.Real.Approx.Interval: fromBounds: bounds not exact: " - ++ show i1i2 - -instance (B.ERRealBase b) => RAEL.ERApproxElementary (ERInterval b) -instance (B.ERRealBase b) => RAEL.ERInnerOuterApproxElementary (ERInterval b) --- all operations here have appropriate default implementations - - diff --git a/src/Data/Number/ER/Real/Approx/OI.hs b/src/Data/Number/ER/Real/Approx/OI.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx/OI.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-methods #-} -{-| - Module : Data.Number.ER.Real.Approx.OI - Description : outer and inner approximations of approximations - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - This module offers a transformation of a safely rounded real approximation type into - a type that approximates these approximations from outside as well as *inside*. --} -module Data.Number.ER.Real.Approx.OI where - -import qualified Data.Number.ER.Real.Approx as RA - -{-| - A pair of approximations that form an "interval" in the lattice of - approximations. - - Eg outer = [1,4] inner = [3,2] can be thought of as the set of all - generalised intervals where the left endpoint is between 1 and 3 - and the right endpoint is between 2 and 4 (eg [1,4], [3,4], - [3,2], [3,3]). --} -data ERApproxOI ra = - ERApproxOI - { - eroiOuter :: ra, - eroiInner :: ra - } - deriving (Eq, Ord) - -instance (RA.ERApprox ra) => (Show (ERApproxOI ra)) - where - show (ERApproxOI oi ii) = - "{ outer = " ++ show oi ++ "; inner = " ++ show ii ++ "}" - -instance (RA.ERApprox ra) => RA.ERApproxApprox (ERApproxOI ra) - where - safeIncludes (ERApproxOI oi1 ii1) (ERApproxOI oi2 ii2) = - oi2 `RA.refines` ii1 - safeNotIncludes (ERApproxOI oi1 ii1) (ERApproxOI oi2 ii2) = - not $ ii2 `RA.refines` oi1 - -{- TODO when required: -} -instance (RA.ERApprox ra) => (Num (ERApproxOI ra)) -instance (RA.ERApprox ra) => (Fractional (ERApproxOI ra)) -instance (RA.ERApprox ra) => RA.ERApprox (ERApproxOI ra) - where - (ERApproxOI oi1 ii1) `leqReals` (ERApproxOI oi2 ii2) = - oi1 `RA.leqReals` oi2 - - diff --git a/src/Data/Number/ER/Real/Approx/Sequence.hs b/src/Data/Number/ER/Real/Approx/Sequence.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx/Sequence.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Approx.Sequence - Description : exact reals via convergent sequences - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Types and methods related to explicit - convergent sequences of real number approximations. --} -module Data.Number.ER.Real.Approx.Sequence -( - ConvergRealSeq(..), - makeFastConvergRealSeq, - convertFuncRA2Seq, - convertBinFuncRA2Seq, - convergRealSeqElem, - showConvergRealSeq, - showConvergRealSeqAuto -) -where - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.BasicTypes - -import Data.Maybe -import Data.Ratio - -{-| - A converging sequence of real number approximations. - - * Every finite subsequence has a non-empty intersection. - - * The limit should be a singleton. --} -data ConvergRealSeq ra = - ConvergRealSeq (EffortIndex -> ra) - -convergRealSeqElem :: (ConvergRealSeq ra) -> EffortIndex -> ra -convergRealSeqElem (ConvergRealSeq sq) ix = sq ix - -{-| - Using this operator, a unary funtion working over - approximations can be converted to one that works - over exact numbers represented through a sequence - of approximations. --} -convertFuncRA2Seq :: - (EffortIndex -> ra -> ra) -> - (ConvergRealSeq ra) -> - (ConvergRealSeq ra) -convertFuncRA2Seq f (ConvergRealSeq argSeq) = - ConvergRealSeq resultSeq - where - resultSeq ix = - f ix (argSeq ix) - -{-| - The same as above, where f is binary --} -convertBinFuncRA2Seq :: - (EffortIndex -> ra -> ra -> ra) -> - (ConvergRealSeq ra) -> - (ConvergRealSeq ra) -> - (ConvergRealSeq ra) - -convertBinFuncRA2Seq f (ConvergRealSeq arg1) (ConvergRealSeq arg2) = - ConvergRealSeq resultSeq - where - resultSeq ix = - f ix (arg1 ix) (arg2 ix) - -{-| - Turn an arbitrary convergent sequence into one with - a guaranteed convergence rate - the precision (as defined - by 'RA.ERApprox.RA.getPrecision') of x_ix is at least ix. --} -makeFastConvergRealSeq :: - (RA.ERApprox ra) => - (ConvergRealSeq ra) -> - (ConvergRealSeq ra) -makeFastConvergRealSeq (ConvergRealSeq argSeq) = - ConvergRealSeq fastSeq - where - fastSeq ix = - head $ catMaybes $ map (precisionOK . argSeq) indexSeries - where - indexSeries = - -- take 5 $ -- upper bound on iteration - for testing - binGeomSeries (max 1 ix) - precisionOK ra - | RA.getPrecision ra >= (effIx2prec ix) = Just ra - | otherwise = Nothing - -{-| - binGeomSeries n is the geometric series - [ n, 2n, 4n, 8n, ...] --} -binGeomSeries - :: (Num a) - => a - -> [a] -binGeomSeries n = - n : (binGeomSeries (2 * n)) - -instance (RA.ERApprox ra) => Show (ConvergRealSeq ra) - where - show = showConvergRealSeq 6 True False 10 -- cheating here, should throw an error - - -{-| - Show function for ConvergRealSeq's with full arguments. --} -showConvergRealSeq - :: (RA.ERApprox ra) - => Int - -> Bool - -> Bool - -> Precision - -> (ConvergRealSeq ra) - -> String - -showConvergRealSeq numDigits showGran showComponents prec r = - RA.showApprox numDigits showGran showComponents $ - convergRealSeqElem (makeFastConvergRealSeq r) (prec2effIx prec) - - -{-| - Show function for ConvergRealSeq's with all parameters fixed - except for number of digits --} -showConvergRealSeqAuto - :: (RA.ERApprox ra) - => Int - -> (ConvergRealSeq ra) - -> String -showConvergRealSeqAuto numDigits argSeq = - showConvergRealSeq numDigits True False prec argSeq - where - prec = effIx2prec $ ceiling $ (fromInteger $ toInteger numDigits) * 3.3219280948873626 - - - -instance - (RA.ERApprox ra) - => Eq (ConvergRealSeq ra) - where - r1 == r2 = - iterateRA_A raEq 2 [r1, r2] - where - raEq _ ([a1,a2]) = RA.equalReals a1 a2 - -instance - (RA.ERApprox ra) - => Ord (ConvergRealSeq ra) - where - compare r1 r2 = - iterateRA_A eraComp 2 [r1, r2] - where - eraComp _ ([a1,a2]) = RA.compareReals a1 a2 - -pointwiseConvergRealSeq1 f (ConvergRealSeq sq) = - ConvergRealSeq (f . sq) -pointwiseConvergRealSeq2 f (ConvergRealSeq sq1) (ConvergRealSeq sq2) = - ConvergRealSeq (\ix -> f (sq1 ix) (sq2 ix)) - -instance - (RA.ERApprox ra) - => Num (ConvergRealSeq ra) - where - fromInteger n = ConvergRealSeq sq - where - sq ix = - RA.setMinGranularityOuter (effIx2gran ix) $ fromInteger n - abs = pointwiseConvergRealSeq1 $ abs - signum = pointwiseConvergRealSeq1 $ signum - negate = pointwiseConvergRealSeq1 $ negate - (+) = pointwiseConvergRealSeq2 $ (+) - (*) = pointwiseConvergRealSeq2 $ (*) - -instance - (RA.ERApprox ra) - => Fractional (ConvergRealSeq ra) - where - fromRational q = ConvergRealSeq sq - where - sq ix = - (RA.setMinGranularityOuter (effIx2gran ix) num) / denom - num = fromInteger $ numerator q - denom = fromInteger $ denominator q - recip = pointwiseConvergRealSeq1 $ recip - -{-| - Take a converging sequence of partial functions F_i that operate on - real approximations and turn it into a function F that operates on converging sequences. - F looks for some members of the real approximation sequences - and an i so that F_i is defined for the chosen approximations - and returns its result. --} -iterateRA_A - :: (EffortIndex -> [ra] -> Maybe a) - -- ^ a sequence of partial functions based on approximations - -> EffortIndex -- ^ a starting index to use when searching sequences - -> ([ConvergRealSeq ra] -> a) - -- ^ a total function based on sequences - -iterateRA_A fn_RA startIx args = - head $ catMaybes $ map ((uncurry fn_RA) . args_Prec) indexSeries - where - indexSeries = --- take 5 $ -- upper bound on iteration - for testing - binGeomSeries $ max 1 startIx - -- [(max 1 startIx)..] - args_Prec currentIndex = - (currentIndex, map (\ arg -> convergRealSeqElem arg currentIndex) args) - - diff --git a/src/Data/Number/ER/Real/Approx/Tests/Generate.hs b/src/Data/Number/ER/Real/Approx/Tests/Generate.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx/Tests/Generate.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Approx.Tests.Generate - Description : (testing) generating real approximations - Copyright : (c) 2009 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Generic instances of 'Arbitrary' class for generating (almost) random instances. --} - -module Data.Number.ER.Real.Approx.Tests.Generate where - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.BasicTypes - -import Test.QuickCheck - -import qualified Data.List as List - -newtype RAThin ira = RAThin ira deriving (Show) -newtype RAConsistent ira = RAConsistent ira deriving (Show) -newtype RADirected ira = RADirected ira deriving (Show) - - -instance (RA.ERIntApprox ira) => Arbitrary (RAThin ira) - where - arbitrary = - sized arbitrarySized - where - arbitrarySized n - | n < 28 = - do - gran <- choose (8,20) - (f1,f2,f3) <- arbitrary - isInfty <- choose (-inftyChance,inftyChance) - pow <- choose (-10,10) - return $ RAThin $ constructThinRA isInfty gran (f1,f2,f3) pow - | n <= 68 = - do - gran <- choose (30,100) - (f1,f2,f3) <- arbitrary - isInfty <- choose (-inftyChance,inftyChance) - pow <- choose (-100,100) - return $ RAThin $ constructThinRA isInfty gran (f1,f2,f3) pow - | otherwise = - do - gran <- choose (400,1000) - (f1,f2,f3) <- arbitrary - isInfty <- choose (-inftyChance,inftyChance) - pow <- choose (-10000,10000) - return $ RAThin $ constructThinRA isInfty gran (f1,f2,f3) pow - coarbitrary _ = - error "ER.Real.Approx: Tests: coarbitrary not implemented" - -inftyChance = 15 - -constructThinRA :: - (RA.ERIntApprox ra) => - Granularity -> - Int -> - (Double, Double, Double) -> - Int -> - ra -constructThinRA gran isInfty (f1,f2,f3) pow - | isInfty == inftyChance = - RA.setGranularityOuter gran $ RA.plusInfinity - | isInfty == - inftyChance = - RA.setGranularityOuter gran $ negate $ RA.plusInfinity - | isInfty == 0 = - RA.setGranularityOuter gran 0 - | otherwise = - fst $ RA.bounds $ -- ensure thinness - (\ (Just a) -> a) $ List.find RA.isBounded results - where - results = [result1, result2, result3, result4, result5, 0] - result1 = (b1/b2) ^^ pow + b3 - result2 = b1 * b2 + b3 - result3 = b1 ^^ pow - b2 - result4 = b1 - b2 - result5 = b1 - [b1,b2,b3] = map cvt [f1,f2,f3] - cvt f = RA.setGranularityOuter gran $ RA.double2ra f - -instance (RA.ERIntApprox ira) => Arbitrary (RAConsistent ira) - where - arbitrary = - sized arbitrarySized - where - arbitrarySized n - | n < 28 = - do - gran <- choose (8,20) - (f11,f12,f13) <- arbitrary - isInfty1 <- choose (-inftyChance,inftyChance) - pow1 <- choose (-10,10) - (f21,f22,f23) <- arbitrary - isInfty2 <- choose (-inftyChance,inftyChance) - pow2 <- choose (-10,10) - let t1 = constructThinRA isInfty1 gran (f11,f12,f13) pow1 - let t2 = constructThinRA isInfty2 gran (f21,f22,f23) pow2 - return $ RAConsistent $ t1 RA.\/ t2 - | n <= 68 = - do - gran <- choose (30,100) - (f11,f12,f13) <- arbitrary - isInfty1 <- choose (-inftyChance,inftyChance) - pow1 <- choose (-100,100) - (f21,f22,f23) <- arbitrary - isInfty2 <- choose (-inftyChance,inftyChance) - pow2 <- choose (-100,100) - let t1 = constructThinRA isInfty1 gran (f11,f12,f13) pow1 - let t2 = constructThinRA isInfty2 gran (f21,f22,f23) pow2 - return $ RAConsistent $ t1 RA.\/ t2 - | otherwise = - do - gran <- choose (400,1000) - (f11,f12,f13) <- arbitrary - isInfty1 <- choose (-inftyChance,inftyChance) - pow1 <- choose (-10000,10000) - (f21,f22,f23) <- arbitrary - isInfty2 <- choose (-inftyChance,inftyChance) - pow2 <- choose (-10000,10000) - let t1 = constructThinRA isInfty1 gran (f11,f12,f13) pow1 - let t2 = constructThinRA isInfty2 gran (f21,f22,f23) pow2 - return $ RAConsistent $ t1 RA.\/ t2 - coarbitrary _ = - error "ER.Real.Approx: Tests: coarbitrary not implemented" - -instance (RA.ERIntApprox ira) => Arbitrary (RADirected ira) - where - arbitrary = - sized arbitrarySized - where - arbitrarySized n - | n < 28 = - do - gran <- choose (8,20) - (f11,f12,f13) <- arbitrary - isInfty1 <- choose (-inftyChance,inftyChance) - pow1 <- choose (-10,10) - (f21,f22,f23) <- arbitrary - isInfty2 <- choose (-inftyChance,inftyChance) - pow2 <- choose (-10,10) - let t1 = constructThinRA isInfty1 gran (f11,f12,f13) pow1 - let t2 = constructThinRA isInfty2 gran (f21,f22,f23) pow2 - return $ RADirected $ RA.fromBounds (t1, t2) - | n <= 68 = - do - gran <- choose (30,100) - (f11,f12,f13) <- arbitrary - isInfty1 <- choose (-inftyChance,inftyChance) - pow1 <- choose (-100,100) - (f21,f22,f23) <- arbitrary - isInfty2 <- choose (-inftyChance,inftyChance) - pow2 <- choose (-100,100) - let t1 = constructThinRA isInfty1 gran (f11,f12,f13) pow1 - let t2 = constructThinRA isInfty2 gran (f21,f22,f23) pow2 - return $ RADirected $ RA.fromBounds (t1, t2) - | otherwise = - do - gran <- choose (400,1000) - (f11,f12,f13) <- arbitrary - isInfty1 <- choose (-inftyChance,inftyChance) - pow1 <- choose (-10000,10000) - (f21,f22,f23) <- arbitrary - isInfty2 <- choose (-inftyChance,inftyChance) - pow2 <- choose (-10000,10000) - let t1 = constructThinRA isInfty1 gran (f11,f12,f13) pow1 - let t2 = constructThinRA isInfty2 gran (f21,f22,f23) pow2 - return $ RADirected $ RA.fromBounds (t1, t2) - coarbitrary _ = - error "ER.Real.Approx: Tests: coarbitrary not implemented" - - diff --git a/src/Data/Number/ER/Real/Approx/Tests/Properties.hs b/src/Data/Number/ER/Real/Approx/Tests/Properties.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx/Tests/Properties.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Base.Tests.Properties - Description : (testing) properties to check for real approximations - Copyright : (c) 2009 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Properties of real approximations we want to check in tests. --} - -module Data.Number.ER.Real.Approx.Tests.Properties -where - -import Data.Number.ER.Real.Approx.Tests.Generate -import Data.Number.ER.Real.Approx.Tests.Reporting -import Data.Number.ER.BasicTypes.Tests.Generate - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.Real.Approx ((+:),(-:),(*:),(/:)) -import qualified Data.Number.ER.Real.Approx.Elementary as RAEL - -import Data.Number.ER.BasicTypes - -import Data.Number.ER.Misc - -import Test.QuickCheck - -type RAPropTupleUnary ira = - ira -> - String -> - ((Ix20, RAThin ira) -> Bool, - (Ix20, RAConsistent ira) -> Bool, - (Ix20, RAThin ira) -> Bool, - (Ix20, RAConsistent ira) -> Bool, - (Ix20, RADirected ira) -> Bool) - -props_ra_AMinusA_eq_oi :: - (RA.ERIntApprox ira, RA.ERInnerOuterApprox ira) => RAPropTupleUnary ira -props_ra_AMinusA_eq_oi = - props_ra_eq_oi_unary 0 (\ix a -> a - a) (\ix a -> a -: a) - -props_ra_ADivA_eq_oi :: - (RA.ERIntApprox ira, RA.ERInnerOuterApprox ira) => RAPropTupleUnary ira -props_ra_ADivA_eq_oi = - props_ra_eq_oi_unary 1 (\ix a -> a / a) (\ix a -> a /: a) - -props_ra_AddCommut_eq_oi :: - (RA.ERIntApprox ira, RA.ERInnerOuterApprox ira) => RAPropTupleUnary ira -props_ra_AddCommut_eq_oi = - props_ra_eq_oi_unary 0 commutDiff commutDiffInner - where - commutDiff ix a = - (a + b) - (b + a) - where - b = 1 / (a + 1) - commutDiffInner ix a = - (a +: b) -: (b +: a) - where - b = 1 / (a + 1) - -props_ra_MultCommut_eq_oi :: - (RA.ERIntApprox ira, RA.ERInnerOuterApprox ira) => RAPropTupleUnary ira -props_ra_MultCommut_eq_oi = - props_ra_eq_oi_unary 0 commutDiff commutDiffInner - where - commutDiff ix a = - (a * b) - (b * a) - where - b = 1 / (a + 1) - commutDiffInner ix a = - (a *: b) -: (b *: a) - where - b = 1 / (a + 1) - -props_ra_AddAssoc_eq_oi :: - (RA.ERIntApprox ira, RA.ERInnerOuterApprox ira) => RAPropTupleUnary ira -props_ra_AddAssoc_eq_oi = - props_ra_eq_oi_unary 0 assocDiff assocDiffInner - where - assocDiff ix a = - ((a + b) + c) - (a + (b + c)) - where - b = 1 / (a + 1) - c = (a - 1) - assocDiffInner ix a = - ((a +: b) +: c) -: (a +: (b +: c)) - where - b = 1 / (a + 1) - c = (a - 1) - -props_ra_MultAssoc_eq_oi :: - (RA.ERIntApprox ira, RA.ERInnerOuterApprox ira) => RAPropTupleUnary ira -props_ra_MultAssoc_eq_oi = - props_ra_eq_oi_unary 0 assocDiff assocDiffInner - where - assocDiff ix a = - ((a * b) * c) - (a * (b * c)) - where - b = 1 / (a + 1) - c = (a - 1) - assocDiffInner ix a = - ((a *: b) *: c) -: (a *: (b *: c)) - where - b = 1 / (a + 1) - c = (a - 1) - -props_ra_Distr_eq_oi :: - (RA.ERIntApprox ira, RA.ERInnerOuterApprox ira) => RAPropTupleUnary ira -props_ra_Distr_eq_oi = - props_ra_eq_oi_unary 0 distrDiff distrDiffInner - where - distrDiff ix a = - (a * (b + c)) - (a * b + a * c) - where - b = 1 / (a + 1) - c = (a - 1) - distrDiffInner ix a = - (a *: (b +: c)) -: ((a *: b) +: (a *: c)) - where - b = 1 / (a + 1) - c = (a - 1) - -props_ra_SinCos_eq_oi :: - (RAEL.ERInnerOuterApproxElementary ira, RAEL.ERApproxElementary ira) => RAPropTupleUnary ira -props_ra_SinCos_eq_oi = - props_ra_eq_oi_unary 1 sincos sincosInner - where - sincos ix a = - (RAEL.sin ix a)^2 + (RAEL.cos ix a)^2 - sincosInner ix a = - (sina *: sina) +: (cosa *: cosa) - where - sina = RAEL.sinInner ix a - cosa = RAEL.cosInner ix a - -props_ra_TanATan_eq_oi :: - (RAEL.ERInnerOuterApproxElementary ira, RAEL.ERApproxElementary ira) => RAPropTupleUnary ira -props_ra_TanATan_eq_oi = - props_ra_eq_oi_unary 0 tanAtan tanAtanInner - where - tanAtan ixP a = --- unsafePrint --- ( --- "tanAtan: " --- ++ "\n ix = " ++ show ix --- ++ "\n a = " ++ show a --- ++ "\n atan ix a = " ++ show tana --- ++ "\n tan ix (atan ix a) = " ++ show tanatana --- ) $ - tanatana - a - where - tanatana = RAEL.tan ix tana - tana = RAEL.atan ix a - ix = min 10 ixP - tanAtanInner ixP a = - (RAEL.tanInner ix $ RAEL.atanInner ix a) -: a - where - ix = min 10 ixP - -props_ra_LogExp_eq_oi :: - (RAEL.ERInnerOuterApproxElementary ira, RAEL.ERApproxElementary ira) => RAPropTupleUnary ira -props_ra_LogExp_eq_oi = - props_ra_eq_oi_unary 0 logExp logExpInner - where - logExp ixP a = --- unsafePrint --- ( --- "logExp: " --- ++ "\n ix = " ++ show ix --- ++ "\n a = " ++ show a --- ++ "\n exp ix a = " ++ show expa --- ++ "\n log ix (exp ix a) = " ++ show logexpa --- ) $ - logexpa - a - where - logexpa = RAEL.log ix expa - expa = RAEL.exp ix a - ix = min 10 ixP - logExpInner ixP a = - logexpa -: a - where - logexpa = RAEL.logInner ix expa - expa = RAEL.expInner ix a - ix = min 10 ixP - - -{------------------ auxiliary functions ------------------------} - -props_ra_eq_oi_unary constRes opOuter opInner sampleRA reportFileName = - (prop_Eq_Thin, prop_Eq_Consistent, - prop_OI_Thin, prop_OI_Consistent, prop_OI_Directed) - where - prop_Eq_Thin (Ix20 ix, RAThin a) = - raConsistentWithPrecise sampleRA (reportFileName ++ "_Eq_Thin") (ix,aId) 0 constRes resOuter - where - resOuter = opOuter ix a - aId = RA.showApprox 10 True True a - prop_Eq_Consistent (Ix20 ix, RAConsistent a) = - raConsistentWithPrecise sampleRA (reportFileName ++ "_Eq_Consistent") (ix,aId) 0 constRes resOuter - where - resOuter = opOuter ix a - aId = RA.showApprox 10 True True a - prop_OI_Thin (Ix20 ix, RAThin a) = - raIncludedIn sampleRA (reportFileName ++ "_OI_Thin") (ix, aId) 0 resInner resOuter - where - resOuter = opOuter ix a - resInner = opInner ix a - aId = RA.showApprox 10 True True a - prop_OI_Consistent (Ix20 ix, RAConsistent a) = - raIncludedIn sampleRA (reportFileName ++ "_OI_Consistent") (ix,aId) 0 resInner resOuter - where - resOuter = opOuter ix a - resInner = opInner ix a - aId = RA.showApprox 10 True True a - prop_OI_Directed (Ix20 ix, RADirected a) = - raIncludedIn sampleRA (reportFileName ++ "_OI_Directed") (ix, aId) 0 resInner resOuter - where - resOuter = opOuter ix a - resInner = opInner ix a - aId = RA.showApprox 10 True True a - -raConsistentWithPrecise sampleRA reportFileName caseId subId preciseVal approxVal - | result = - unsafeERTestReport reportFileName - (caseId, subId, preciseVal, approxVal) $ - result - | otherwise = - unsafePrint - ( - "raAntiIncludes failed" - ++ "\n caseId = " ++ show caseId - ++ "\n subId = " ++ show subId - ++ "\n preciseVal = " ++ show preciseVal - ++ "\n approxVal = " ++ show approxVal - ) $ - result - where - result = - (approxVal `RA.refines` preciseVal) - || - (preciseVal `RA.refines` approxVal) - _ = [sampleRA, approxVal] - -raIncludedIn sampleRA reportFileName caseId subId innerVal outerVal - | result = - unsafeERTestReport reportFileName - (caseId, subId, innerVal, outerVal) $ - result - | otherwise = - unsafePrint - ( - "raIncludes failed" - ++ "\n caseId = " ++ show caseId - ++ "\n subId = " ++ show subId - ++ "\n innerVal = " ++ show innerVal - ++ "\n outerVal = " ++ show outerVal - ) $ - result - where - result = innerVal `RA.refines` outerVal - _ = [sampleRA, innerVal] - - diff --git a/src/Data/Number/ER/Real/Approx/Tests/Reporting.hs b/src/Data/Number/ER/Real/Approx/Tests/Reporting.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx/Tests/Reporting.hs +++ /dev/null @@ -1,167 +0,0 @@ - -module Data.Number.ER.Real.Approx.Tests.Reporting - -where - -import qualified Data.Number.ER.Real.Approx as RA - -import Data.Number.ER.Misc - -import qualified Data.List as List -import Text.Regex -import System.IO - - -unsafeERTestReport :: - (Show tId, Show sId, RA.ERIntApprox ira) => - String -> - (tId, sId, ira, ira) -> - a -> a -unsafeERTestReport reportFileName (testId, subId, almostPreciseVal, approxVal) = - unsafeReport reportFileName $ - stdRepLine (testId, subId) (overestimation, detail) - where - overestimation = fst $ getOverestimation almostPreciseVal approxVal - detail = (almostPreciseVal, approxVal) - -stdRepLine (testId, subId) (overestimation, detail) = - "case=" ++ show testId - ++ ";pt=" ++ show subId - ++ ";ovest=" ++ show overestimation - ++ ";detail=" ++ show detail - -getOverestimation :: - (RA.ERIntApprox ira) => - ira -> ira -> (Double, (ira, ira)) -getOverestimation model res = - ((abs $ wMod - wRes) / (1 + (max 0 (wMod))), (model, res)) - where - wMod = hMod - lMod - wRes = hRes - lRes - (lMod, hMod) = RA.doubleBounds model - (lRes, hRes) = RA.doubleBounds res - -produceSummary :: String -> IO () -produceSummary filepath = - do - casesInfo <- parseReport filepath - writeFile summaryFilepath $ formatSummary casesInfo - return () - where - summaryFilepath = filepath ++ "-summary" - formatSummary casesInfo = - "all " ++ show casesCount ++ " cases:" - ++ "\n approx. average time per case: " ++ show timeInSeconds ++ " seconds" - ++ "\n approx. average per case average overestimation: " ++ show avgOverestimation - ++ "\n approx. average per case maximum overestimation: " ++ show maxOverestimation - ++ "\n\n removing the worst 5% of the cases (for each measure separately):" - ++ "\n approx. average time per case: " ++ show timeInSeconds95 ++ " seconds" - ++ "\n approx. average per case average overestimation: " ++ show avgOverestimation95 - ++ "\n approx. average per case maximum overestimation: " ++ show maxOverestimation95 - ++ "\n\n considering only the worst 50% but not the worst 5% of the cases (for each measure separately):" - ++ "\n approx. average time per case: " ++ show timeInSeconds45 ++ " seconds" - ++ "\n approx. average per case average overestimation: " ++ show avgOverestimation45 - ++ "\n approx. average per case maximum overestimation: " ++ show maxOverestimation45 - ++ "\n\n considering only the best 50% of the cases (for each measure separately):" - ++ "\n approx. average time per case: " ++ show timeInSeconds50 ++ " seconds" - ++ "\n approx. average per case average overestimation: " ++ show avgOverestimation50 - ++ "\n approx. average per case maximum overestimation: " ++ show maxOverestimation50 - ++ "\n\n" ++ (unlines $ map formatSummaryCase casesInfo) - where - (allTimes, (allAvgOvers, allMaxOvers)) = - mapSnd unzip $ unzip $ snd $ unzip casesInfo - timeInSeconds = (sum allTimes) / casesCountF - avgOverestimation = (sum allAvgOvers) / casesCountF - maxOverestimation = (sum allMaxOvers) / casesCountF - casesCount = length casesInfo - casesCountF :: Double - casesCountF = fromInteger $ toInteger casesCount - - timeInSeconds95 = (sum allTimes95) / casesCount95F - avgOverestimation95 = (sum allAvgOvers95) / casesCount95F - maxOverestimation95 = (sum allMaxOvers95) / casesCount95F - allTimes95 = drop fivePerCent $ reverse $ List.sort allTimes - allAvgOvers95 = drop fivePerCent $ reverse $ List.sort allAvgOvers - allMaxOvers95 = drop fivePerCent $ reverse $ List.sort allMaxOvers - casesCount95F = fromInteger $ toInteger $ casesCount - fivePerCent - fivePerCent = max 1 $ (5 * casesCount) `div` 100 - - timeInSeconds50 = (sum allTimes50) / casesCount50F - avgOverestimation50 = (sum allAvgOvers50) / casesCount50F - maxOverestimation50 = (sum allMaxOvers50) / casesCount50F - allTimes50 = drop fiftyPerCent $ reverse $ List.sort allTimes - allAvgOvers50 = drop fiftyPerCent $ reverse $ List.sort allAvgOvers - allMaxOvers50 = drop fiftyPerCent $ reverse $ List.sort allMaxOvers - casesCount50F = fromInteger $ toInteger $ casesCount - fiftyPerCent - fiftyPerCent = casesCount `div` 2 - - timeInSeconds45 = (sum allTimes45) / casesCount45F - avgOverestimation45 = (sum allAvgOvers45) / casesCount45F - maxOverestimation45 = (sum allMaxOvers45) / casesCount45F - allTimes45 = drop fivePerCent $ reverse $ drop fiftyPerCent $ List.sort allTimes - allAvgOvers45 = drop fivePerCent $ reverse $ drop fiftyPerCent $ List.sort allAvgOvers - allMaxOvers45 = drop fivePerCent $ reverse $ drop fiftyPerCent $ List.sort allMaxOvers - casesCount45F = fromInteger $ toInteger $ casesCount - fiftyPerCent - fivePerCent - formatSummaryCase (caseId, (timeInSeconds, (avgOverestimation, maxOverestimation))) = - "case " ++ caseId ++ ":" - ++ "\n approximate time = " ++ show timeInSeconds ++ " seconds" - ++ "\n average sampled overestimation = " ++ show avgOverestimation - ++ "\n maximal sampled overestimation = " ++ show maxOverestimation - parseReport :: String -> IO [(String, (Double, (Double, Double)))] - parseReport filepath = - withFile filepath ReadMode readFirstAndOtherLines - where - readFirstAndOtherLines h = - do - startLine <- hGetLine h - firstLine <- hGetLine h - readCases (firstLine, (getTime firstLine) - (getTime startLine)) h - readCases (currentLine, caseCompTime) h = - do - (caseOverestimations, maybeNextLineAndTime) <- readCase [] 0 currentLine - let caseInfo = (caseId, (caseCompTime, avgAndMax caseOverestimations)) - case maybeNextLineAndTime of - Nothing -> return [caseInfo] - Just (nextLine, nextCaseTime) -> - do - otherCases <- readCases (nextLine, nextCaseTime) h - return $ caseInfo : otherCases - where - avgAndMax ns = - (sum ns / (fromInteger $ toInteger $ length ns), foldl1 max ns) - caseId = getCaseId currentLine - readCase overestimationsSoFar currentTimeStep currentLine - | currentCaseId /= caseId = - return (overestimationsSoFar, Just (currentLine, currentTimeStep)) - | otherwise = - do - finished <- hIsEOF h - case finished of - True -> return (currentOverestimations, Nothing) - False -> - do - nextLine <- hGetLine h - let nextTimeStep = (getTime nextLine) - (getTime currentLine) - readCase currentOverestimations nextTimeStep nextLine - where - currentCaseId = getCaseId currentLine - currentOverestimations = - currentOverestimation : overestimationsSoFar - currentOverestimation = getOverestimation currentLine - getTime :: String -> Double - getTime line = - case reads line of - [(time,'s':_)] -> time - getCaseId :: String -> String - getCaseId line = - case matchRegex idRegex line of - Just [caseId] -> caseId - where - idRegex = mkRegex "case=([^;]*);" - getOverestimation :: String -> Double - getOverestimation line = - case matchRegex ovestRegex line of - Just [ovestS] -> read ovestS - where - ovestRegex = mkRegex "ovest=([^;]*);" - diff --git a/src/Data/Number/ER/Real/Approx/Tests/Run.hs b/src/Data/Number/ER/Real/Approx/Tests/Run.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Approx/Tests/Run.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Approx.Tests.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.Real.Approx.Tests.Run -where - -import Data.Number.ER.Real.Approx.Tests.Generate -import Data.Number.ER.Real.Approx.Tests.Properties -import Data.Number.ER.Real.Approx.Tests.Reporting - -import qualified Data.Number.ER.Real.Approx as RA -import qualified Data.Number.ER.Real.Approx.Elementary as RAEL - -import Data.Number.ER.BasicTypes.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox) - -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 - -runRATests :: - (RAEL.ERApproxElementary ra, - RAEL.ERInnerOuterApproxElementary ra, - Ord ra) => - String -> ra -> IO () -> IO () -runRATests title sampleRA initialise = - do - (UTCTime (ModifiedJulianDay days) secs) <- getCurrentTime - let folder = "tests-" ++ title ++ "-" ++ (show days) ++ "-" ++ (show $ floor $ toRational secs) - createDirectory folder - erRunTests (title ++ " real approx tests") raTestOptions initialise (raTests sampleRA folder) - -raTestOptions = - 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 - } - -raTests sampleRA folder = - (propTuple "a-a=0" "AMinusAIsZero" props_ra_AMinusA_eq_oi) - ++ - (propTuple "a/a=1" "ADivAIsOne" props_ra_ADivA_eq_oi) - ++ - (propTuple "a+b=b+a" "AddCommut" props_ra_AddCommut_eq_oi) - ++ - (propTuple "a*b=b*a" "MultCommut" props_ra_MultCommut_eq_oi) - ++ - (propTuple "(a+b)+c=a+(b+c)" "AddAssoc" props_ra_AddAssoc_eq_oi) - ++ - (propTuple "(a*b)*c=a*(b*c)" "MultAssoc" props_ra_MultAssoc_eq_oi) - ++ - (propTuple "a*(b+c)=a*b+a*c" "Distr" props_ra_Distr_eq_oi) - ++ - (propTuple "log(exp(a))=a" "LogExp" props_ra_LogExp_eq_oi) - ++ - (propTuple "(sin a)^2+(cos a)^2=1" "SinCos" props_ra_SinCos_eq_oi) - ++ - (propTuple "tan(atan(a))=a" "TanATan" props_ra_TanATan_eq_oi) - where - propTuple testName testFileName propGen = - [ - (testName ++ ", equality, thin intervals", runR prop_eq_Thin $ filepath ++ "_Eq_Thin"), - (testName ++ ", equality, consistent intervals", runR prop_eq_Consistent $ filepath ++ "_Eq_Consistent"), - (testName ++ ", inner in outer, thin intervals", runR prop_oi_Thin $ filepath ++ "_OI_Thin"), - (testName ++ ", inner in outer, consistent intervals", runR prop_oi_Consistent $ filepath ++ "_OI_Consistent"), - (testName ++ ", inner in outer, directed intervals", runR prop_oi_Directed $ filepath ++ "_OI_Directed") - ] - where - (prop_eq_Thin, prop_eq_Consistent, prop_oi_Thin, prop_oi_Consistent, prop_oi_Directed) = - propGen sampleRA filepath - filepath = FP.combine folder testFileName - runR test filepath opts = - unsafeReport filepath "started" $ - do - result <- run test opts - produceSummary filepath - return result - diff --git a/src/Data/Number/ER/Real/Arithmetic/Elementary.hs b/src/Data/Number/ER/Real/Arithmetic/Elementary.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Arithmetic/Elementary.hs +++ /dev/null @@ -1,771 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Arithmetic.Elementary - Description : some elementary functions - Copyright : (c) Michal Konecny, Amin Farjudian, Jan Duracz - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Some important elementary functions for real approximations - and their maximal extensions for interval approximations. --} -module Data.Number.ER.Real.Arithmetic.Elementary -( - -- * specialised exponentiation - erSqr_R, - erSqr_IR, - erPow_R, - erPow_IR, - erSqrt_R, - erSqrt_IR, - erSqrt_IR_Inner, - erRoot_R, - erRoot_IR, - erRoot_IR_Inner, - -- * exponentiation and logarithm - erExp_R, - erExp_IR, - erExp_IR_Inner, - erLog_R, - erLog_IR, - erLog_IR_Inner, - -- * trigonometrics - erSine_R, - erSine_IR, - erSine_IR_Inner, - erCosine_R, - erCosine_IR, - erCosine_IR_Inner, - erATan_R, - erATan_IR, - erATan_IR_Inner, - erPi_R -) -where - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.BasicTypes -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI - -import Data.Number.ER.Real.Arithmetic.Taylor --- import Data.Number.ER.Real.Arithmetic.Newton - -import Data.Number.ER.Misc - -{- - sqr --} - -erSqr_IR :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> - ira -> ira -erSqr_IR = - RA.maxExtensionR2R - sqrExtrema - erSqr_R - where - sqrExtrema ix x - | 0 `RA.refines` x = [0] - | otherwise = [] - -erSqr_R :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> - ira -> ira -erSqr_R ix a = - max 0 $ a' * a' - where - a' = RA.setMinGranularityOuter gran a - gran = effIx2gran ix - -{- - integer exponentiation x ^ p --} - -erPow_IR :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> - Integer -> - ira -> ira -erPow_IR ix n x = - RA.maxExtensionR2R - powExtrema - (\ ix x -> erPow_R ix n x) - ix x - where - powExtrema ix x - | even n && 0 `RA.refines` x = [0] - | otherwise = [] - - -erPow_R :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> - Integer -> - ira -> ira -erPow_R ix p a - | p < 0 = - 1 / erPow_R ix (-p) a - | p == 0 = - 1 - | even p = - erPow_R ix (div p 2) (erSqr_R ix a') - | otherwise = - a' * (erPow_R ix (div (p - 1) 2) (erSqr_R ix a')) - where - a' = RA.setMinGranularityOuter gran a - gran = effIx2gran ix - -{- - sqrt --} - -erSqrt_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira -erSqrt_R = erSqrtNewton_R - -erSqrt_IR :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira -erSqrt_IR = - RA.maxExtensionR2R - sqrtExtrema - (\ ix x -> erSqrt_R ix x) - -erSqrt_IR_Inner :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira -erSqrt_IR_Inner = - RA.maxExtensionInnerR2R - sqrtExtrema - (\ ix x -> erSqrt_R ix x) - -sqrtExtrema ix x = fst $ sqrtExtremaAndDirections ix x - -sqrtExtremaAndDirections ix x = - case RA.compareReals 0 x of - Just LT -> ([], (Just True, Just True)) - Just GT -> ([], (Nothing, Nothing)) - _ -> ([0], (Nothing, Just True)) - - - -erSqrtContFr_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira -erSqrtContFr_R ix a - | aR == 0 = 0 - | aL == RA.plusInfinity = RA.plusInfinity - | aR `RA.ltSingletons` 0 = RA.topApprox - | otherwise = - contFrIter (ix + 3) $ - RA.setMinGranularityOuter gran $ 0 RA.\/ aR -- assuming aR >= 0 - where - gran = effIx2gran ix - (aL, aR) = RA.bounds a - aM1 = a - 1 - - contFrIter i x_i - | i == 0 = - x_i - | otherwise = - 1 + (aM1 / (x_iPlus1 + 1)) - where - x_iPlus1 = contFrIter (i - 1) x_i - -erSqrtNewton_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira -erSqrtNewton_R ix a - | aR == 0 = 0 - | aL == RA.plusInfinity = RA.plusInfinity - | aR `RA.ltSingletons` 0 = RA.topApprox - | otherwise = - x_i RA.\/ (a/x_i) - where - gran = effIx2gran ix - (aL, aR) = RA.bounds a - aM1 = a - 1 - - x_i = - newtonIter ((ix `div` 10) + 5) $ - RA.setMinGranularityOuter gran aR -- assuming aR >= 0 - newtonIter i x_i - | i == 0 = x_i - | otherwise = - snd $ RA.bounds $ - (x_iMinus1 + a / (x_iMinus1)) / 2 - where - x_iMinus1 = newtonIter (i - 1) x_i - -{- - pth root x ^ (1/p) --} - -erRoot_R :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> Integer -> ira -> ira -erRoot_R = erRootNewton_R - -erRoot_IR :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> Integer -> ira -> ira -erRoot_IR ix p = - RA.maxExtensionR2R - (rootExtrema p) - (\ ix x -> erRoot_R ix p x) $ - ix - -erRoot_IR_Inner :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> Integer -> ira -> ira -erRoot_IR_Inner ix p = - RA.maxExtensionInnerR2R - (rootExtrema p) - (\ ix x -> erRoot_R ix p x) $ - ix -rootExtrema p ix x = fst $ rootExtremaAndDirections p ix x - -rootExtremaAndDirections p ix x - | odd p = ([], (Just True, Just True)) - | otherwise = - case RA.compareReals 0 x of - Just LT -> ([], (Just True, Just True)) - Just GT -> ([], (Nothing, Nothing)) - _ -> ([0], (Nothing, Just True)) - -erRootNewton_R :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> Integer -> ira -> ira -erRootNewton_R ix p a - | aR == 0 = 0 - | aL == RA.plusInfinity = RA.plusInfinity - | aR < 0 && even p = RA.topApprox - | aR < 0 = - erRootNewton_R ix p (-a) - | p > 0 = - x_i RA.\/ (a/x_i_pow_p_minus_1) - | otherwise = - 1 / (erRootNewton_R ix (-p) a) -- TODO: check extremes - where - gran = effIx2gran ix - (aL, aR) = RA.bounds a - aM1 = a - 1 - pIRA = fromInteger p - pIRA_minus_1 = pIRA - 1 - - (x_i, x_i_pow_p_minus_1) = - newtonIter (ix + 5) $ - RA.setMinGranularityOuter gran $ max 0 aR - - newtonIter i x_0 - | i == 0 = - (x_0, x_0_pow_p_minus_1) - | otherwise = - (x_i, x_i_pow_p_minus_1) - - where - (x_iMinus1, x_iMinus1_pow_p_minus_1) = - newtonIter (i - 1) x_0 - x_i = - snd $ RA.bounds $ - (pIRA_minus_1 * x_iMinus1 + a / x_iMinus1_pow_p_minus_1) / pIRA - x_i_pow_p_minus_1 = - erPow_R ix (p - 1) x_i - x_0_pow_p_minus_1 = - erPow_R ix (p - 1) x_0 - -{- - e^x and log --} - -erExp_R :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> ira -> ira - -erExp_R ix x - | RA.isBounded x = --- unsafePrintReturn --- ( --- "erExp_R: " --- ++ "\n x = " ++ show x --- ++ "\n xNear0 = " ++ show xNear0 --- ++ "\n n = " ++ show n --- ++ "\n erExp_Tay_Opt_R ix xNear0 = " ++ (show $ erExp_Tay_Opt_R ix xNear0) --- ++ "\n result = " --- ) $ - erPow_IR ix n $ - erExp_Tay_Opt_R ix xNear0 - | x `RA.refines` (-RA.plusInfinity) = 0 - | (-RA.plusInfinity) `RA.refines` x = - 0 RA.\/ (erExp_R ix (snd $ RA.bounds x)) - | otherwise = RA.bottomApprox - where - (xNear0, n) = scaleNear0 (x,1) - scaleNear0 (xPrev, nPrev) = - case xPrev `RA.refines` ((-1) RA.\/ 1) of - True -> (xPrev, nPrev) - False -> scaleNear0 (xNext, nNext) - where - xNext = xPrev / 2 - nNext = 2 * nPrev - -erExp_IR :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> ira -> ira - -erExp_IR = - RA.maxExtensionR2R - noExtrema - erExp_R - -erExp_IR_Inner :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> ira -> ira -erExp_IR_Inner = - RA.maxExtensionInnerR2R - noExtrema - erExp_R - -noExtrema ix x = [] - -{- Log using Newton -} - -erLog_R :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> ira -> ira - -erLog_R = - logDivSeries_R --- erLog_IR -- intervals are more efficient for log than singletons - -erLog_IR :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> ira -> ira - -erLog_IR = - RA.maxExtensionR2R - logExtrema - (\ ix x -> logDivSeries_R ix x) - -erLog_IR_Inner :: - (RA.ERIntApprox ira, Ord ira) => - EffortIndex -> ira -> ira - -erLog_IR_Inner = - RA.maxExtensionInnerR2R - logExtrema - (\ ix x -> logDivSeries_R ix x) - -logExtrema ix x = fst $ logExtremaAndDirections ix x - -logExtremaAndDirections ix x = - case RA.compareReals 0 x of - Just LT -> ([], (Just True, Just True)) - Just GT -> ([], (Nothing, Nothing)) - _ -> ([-RA.plusInfinity], (Nothing, Just True)) - -{-| log using a fast converging series, designed to be used with singletons -} -logDivSeries_R :: - (RA.ERIntApprox ira, Ord ira) => EffortIndex -> ira -> ira -logDivSeries_R ix x - | posx `RA.refines` 0 = -RA.plusInfinity - | 0 `RA.refines` posx = RA.bottomApprox - | posx `RA.refines` (RA.plusInfinity) = RA.plusInfinity - | otherwise = - case RA.compareReals posx 1 of - Just LT -> --- unsafePrint --- ( --- "logDivSeries_R: recursion via recip" --- ) $ - negate $ - (logDivSeries_R ix posxRecipL) - RA.\/ - (logDivSeries_R ix posxRecipR) - _ -> --- unsafePrint --- ( --- "logDivSeries_R: using series" --- ++ "\n posx = " ++ show posx --- ++ "\n nearLogx = " ++ show nearLogx --- ++ "\n remNearLogx = " ++ show remNearLogx --- ++ "\n t = " ++ show t --- ) $ - nearLogx + 2 * t * (series ix (RA.setMinGranularityOuter gran 1)) - where - gran = effIx2gran ix - posx = (RA.setMinGranularityOuter gran x) RA./\ (0 RA.\/ (RA.plusInfinity)) - (posxRecipL, posxRecipR) = RA.bounds $ recip posx - nearLogx = - 0.69314718055994530941 * (fromInteger $ intLogUp 2 $ xCeiling) - remNearLogx = - posx / (erExp_R ix nearLogx) -- should be very close to 1 - xCeiling = - snd $ RA.integerBounds posx - t = - ((remNearLogx - 1) / (remNearLogx + 1)) -- the range of this expression is [-1,1] - RA./\ ((-1) RA.\/ 1) -- correction of wrapping - tsquare = abs $ t * t -- the range is [0,1] - series termsCount currentDenominator - | termsCount > 0 = - (recip currentDenominator) + tsquare * (series (termsCount - 1) (currentDenominator + 2)) - | otherwise = - (recip currentDenominator) - * (1 RA.\/ (recip $ 1 - tsquare)) -- [1,1/(1-t^2)] is a valid error bound - ---{- log using Newton -} --- ---logNewton_RA --- :: (RA.ERIntApprox ira) --- => EffortIndex --- -> ra -- must not be below 1 --- -> ra --- ---logNewton_RA i x = --- case compareReals posx 1 of --- Just LT -> --- - (logNewton_RA i (recip posx)) --- _ -> --- erNewton_FullArgs --- ( \ i y -> (erExp_RA i y) - posx, erExp_RA) --- (RA.setMinGranularityOuter gran nearLogx) --- (RA.setMinGranularityOuter gran 1) --- (fromInteger $ toInteger i) --- i --- where --- gran = effIx2gran i --- posx = --- RA.setMinGranularityOuter gran x /\ (ira2ra $ 0 RA.\/ (RA.plusInfinity)) --- nearLogx = --- 0.69314718055994530941 * (fromInteger $ intLog 2 $ xCeiling) --- xCeiling --- | RA.isEmpty posx = 1 -- choice of constant irrelevant --- | otherwise = --- snd $ RA.iraIntegerBounds $ ra2ira posx - - -{- - sin(x) and cos(x) --} - -erSine_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erSine_R ix x = - case (RA.isBounded x) of - True | xNear0 `RA.refines` plusMinusPiHalf -> - erSine_Tay_Opt_R ix xNear0 - True | (xNear0 - piHalf) `RA.refines` plusMinusPiHalf -> - erCosine_Tay_Opt_R ix (xNear0 - piHalf) - True | (xNear0 + piHalf) `RA.refines` plusMinusPiHalf -> - negate $ erCosine_Tay_Opt_R ix (xNear0 + piHalf) - True | (xNear0 - pi) `RA.refines` plusMinusPiHalf -> - negate $ erSine_Tay_Opt_R ix (xNear0 - pi) - _ -> - (-1) RA.\/ 1 - where - xNear0 = x - k * 2 * pi -- should be in [-pi,3*pi/2] - k = fromInteger $ toInteger kEI - (kEI,_) = RA.integerBounds $ 0.5 + (x / (2*pi)) - - plusMinusPiHalf = (- piHalf) RA.\/ piHalf - piHalf = pi / 2 - pi = erPi_R ix - - -erCosine_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erCosine_R ix x = - case (RA.isBounded x) of - True | xNear0 `RA.refines` plusMinusPiHalf -> - erCosine_Tay_Opt_R ix xNear0 - True | (xNear0 - piHalf) `RA.refines` plusMinusPiHalf -> - negate $ erSine_Tay_Opt_R ix (xNear0 - piHalf) - True | (xNear0 + piHalf) `RA.refines` plusMinusPiHalf -> - erSine_Tay_Opt_R ix (xNear0 + piHalf) - True | (xNear0 - pi) `RA.refines` plusMinusPiHalf -> - negate $ erCosine_Tay_Opt_R ix (xNear0 - pi) - _ -> - (-1) RA.\/ 1 - where - xNear0 = x - k * 2 * pi -- should be in [-pi,3*pi/2] - k = fromInteger $ toInteger kEI - (kEI,_) = RA.integerBounds $ 0.5 + (x / (2*pi)) - - plusMinusPiHalf = (- piHalf) RA.\/ piHalf - piHalf = pi / 2 - pi = erPi_R ix - - -{- Sine using generic Taylor (see Taylor for an optimised version) -} - -erSine_Tay_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erSine_Tay_R ix x - | (RA.plusInfinity) `RA.refines` x || (-RA.plusInfinity) `RA.refines` x = - (-1) RA.\/ 1 - | otherwise = - erTaylor_R ix sine_coefSeq sine_error 0 x - -sine_coefSeq :: - (RA.ERIntApprox ira) => - Int -> ira - -sine_coefSeq n - | n `mod` 4 == 0 = 0 - | n `mod` 4 == 1 = 1 - | n `mod` 4 == 2 = 0 - | n `mod` 4 == 3 = -1 - -sine_error n = (-1) RA.\/ 1 - -{- maximal extensions -} - -erSine_IR :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erSine_IR = - RA.maxExtensionR2R sineExtremes erSine_R - -erCosine_IR :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erCosine_IR = - RA.maxExtensionR2R cosineExtremes erCosine_R - -erSine_IR_Inner :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erSine_IR_Inner = - RA.maxExtensionInnerR2R sineExtremes erSine_R - -erCosine_IR_Inner :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erCosine_IR_Inner = - RA.maxExtensionInnerR2R cosineExtremes erCosine_R - -sineExtremes ix x = fst $ sineExtremesAndDirections ix x -cosineExtremes ix x = fst $ cosineExtremesAndDirections ix x - -sineExtremesAndDirections ix x - | RA.isBounded x = - alternatingExtremes 1 (-1) ix scaledX - | otherwise = ([-1,1], (Nothing, Nothing)) - where - scaledX = (x / (erPi_R ix)) - 0.5 - -cosineExtremesAndDirections ix x - | RA.isBounded x = - alternatingExtremes 1 (-1) ix scaledX - | otherwise = ([-1,1], (Nothing, Nothing)) - where - scaledX = (x / (erPi_R ix)) - -alternatingExtremes extrHigh extrLow ix scaledX - | extremesCount == 1 && even minExtremeN = - ([extrHigh], (Just True, Just False)) -- increasing, decreasing - | extremesCount == 1 = - ([extrLow], (Just False, Just True)) -- decreasing, increasing - | extremesCount >= 2 = - ([extrHigh,extrLow], (Just $ even minExtremeN, Just $ odd maxExtremeN)) - | otherwise = - ([], (Just isIncreasing, Just isIncreasing)) - where - extremesCount = 1 + maxExtremeN - minExtremeN - isIncreasing = even maxExtremeN - (xFloor, xCeiling) = RA.integerBounds scaledX - minExtremeN = - case RA.compareReals (fromInteger $ toInteger xFloor) scaledX of - Just LT -> (xFloor + 1) - _ -> xFloor - maxExtremeN = - case RA.compareReals scaledX (fromInteger $ toInteger xCeiling) of - Just LT -> xCeiling - 1 - _ -> xCeiling - - -{- - tan(x), atan(x) and pi --} - -erATan_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erATan_R = atanEuler_R - -erATan_IR :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erATan_IR = - RA.maxExtensionR2R noExtrema erATan_R - -erATan_IR_Inner :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erATan_IR_Inner = - RA.maxExtensionInnerR2R noExtrema erATan_R - -{- atan using Euler's 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] --} - -atanEuler_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -atanEuler_R ix x - | x `RA.refines` RA.plusInfinity = RA.plusInfinity - | x `RA.refines` (- RA.plusInfinity) = - RA.plusInfinity - | not $ RA.isBounded x = RA.bottomApprox - | x `RA.refines` ((-1.5) RA.\/ 1.5) = - (x / xSquarePlus1) * (series ix (RA.setMinGranularityOuter gran 2)) - | otherwise = -- too far from 0, needs atan(x) = 2*atan(x/(1+sqrt(1+x^2))) - 2 * (atanEuler_R ix $ x / (1 + sqrtXQuarePlus1)) - where - gran = effIx2gran ix - series termsCount coeffBase - | termsCount > 0 = - 1 + xSquareOverXSquarePlus1 * coeff * (series (termsCount - 1) (coeffBase + 2)) - | otherwise = - 1 + xSquare * (0 RA.\/ 1) - where - coeff = coeffBase / (coeffBase + 1) - xSquare = abs $ x * x - xSquarePlus1 = xSquare + 1 - xSquareOverXSquarePlus1 = xSquare / xSquarePlus1 - sqrtXQuarePlus1 = - iterateIx 10 EI.MinusInfinity - where - iterateIx ix prevPrec - | prevPrec == currentPrec = result - | otherwise = - iterateIx (ix * 2) currentPrec - where - result = erSqrt_R ix xSquarePlus1 - currentPrec = RA.getPrecision result - ---{- atan using Newton -} --- ---atanNewton_RA :: --- (RA.ERIntApprox ira) => --- EffortIndex -> ra -> ra --- ---atanNewton_RA i x = --- erNewton_FullArgs --- ( \ i y -> (erTan_RA i y) - x, erTanDeriv_RA) --- (RA.setMinGranularityOuter (effIx2gran i) (x)) --- (RA.setMinGranularityOuter (effIx2gran i) 1) --- (fromInteger $ toInteger i) --- i - -{- tan -} - -erTan_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -> ira - -erTan_R ix x = - (erSine_R ix x) / (erCosine_R ix x) - -erTanDeriv_R ix x = - recip $ abs $ cosx * cosx - where - cosx = erCosine_R ix x - - -{- pi -} - -{-| - pi using Bellard's formula - - Convergence properties: - - * shrinking sequence - - * rate at least 2^(-i). - --} -erPi_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -erPi_R = piBellard_R - --- | pi using atan -piAtan_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -piAtan_R ix = - (*) 4 $ atanEuler_R ix 1 - -{-| - pi using Bellard's formula - (see ) - - Convergence properties: - - * shrinking sequence - - * rate at least 2^(-i). - --} -piBellard_R :: - (RA.ERIntApprox ira) => - EffortIndex -> ira -piBellard_R ix = - r1over64 * (sum $ reverse $ bellardTerms 0 (10 + (ix `div` 10)) (1,z,z)) - {- - sum from the smallest to the largest - (got this trick from Martin Escardo who said he got it from Andrej Bauer) - - the rounding error dominates the truncation error to such - a degree that the truncation error can be safely left out - - each bellard term contributes 10 binary digits that the following terms - do not influence - -} - where - gran = max 0 (effIx2gran ix) + 10 - r1over64 = (RA.setMinGranularityOuter gran 1) / 64 - r1over1024 = (RA.setMinGranularityOuter gran 1) / 1024 - z = RA.setMinGranularityOuter gran 0 - bellardTerms n nMax (mult, r4n, r10n) - | n >= nMax = [] - | otherwise = - termN : rest - where - rest = - bellardTerms (n + 1) nMax (- mult * r1over1024, r4n + 4, r10n + 10) - termN = - mult * bellardSum - bellardSum = - -- sum from the smallest to the largest - (recip $ r10n + 9) - - (recip $ r4n + 3) - - 4 * ((recip $ r10n + 7) + (recip $ r10n + 5)) - - (64 / (r10n + 3)) - - (32 / (r4n + 1)) - + (256 / (r10n + 1)) - - diff --git a/src/Data/Number/ER/Real/Arithmetic/Integration.hs b/src/Data/Number/ER/Real/Arithmetic/Integration.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Arithmetic/Integration.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Arithmetic.Integration - Description : simple integration methods - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Simple integration methods for Haskell functions operating - on real number approximations. --} -module Data.Number.ER.Real.Arithmetic.Integration -( - integrateCont, --- integrateDiff, - integrateCont_R, - integrateContAdapt_R -) -where - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.BasicTypes -import Data.Number.ER.Real.Approx.Sequence -import Data.Number.ER.Real.Arithmetic.Elementary - -testIntegr1 :: - (RA.ERIntApprox ira, Ord ira) => - (ConvergRealSeq ira) -testIntegr1 = integrateCont erExp_IR 0 1 - -integrateCont :: - (RA.ERIntApprox ira) => - (EffortIndex -> ira -> ira) -> - (ConvergRealSeq ira) -> (ConvergRealSeq ira) -> (ConvergRealSeq ira) - -integrateCont f = convertBinFuncRA2Seq $ integrateContAdapt_R f - -integrateDiff :: - (RA.ERIntApprox ira) => - (EffortIndex -> ira -> ira, EffortIndex -> ira -> ira) -> - (ConvergRealSeq ra) -> (ConvergRealSeq ra) -> (ConvergRealSeq ra) - -integrateDiff f = convertBinFuncRA2Seq $ integrateDiffAdapt_RA f - - -{-| - naive integration, using a partition of 2 * prec equally sized intervals --} -integrateCont_R :: - (RA.ERIntApprox ira) => - (EffortIndex -> ira -> ira) -> - EffortIndex -> (ira) -> (ira) -> (ira) -integrateCont_R f ix a b = - sum $ map rectArea rectangles - where - rectArea (width, height) = width * height - rectangles = - zip (repeat width) $ map (f ix) covering - width = (b - a) / (fromInteger rectCount) - rectCount = 2 * (fromInteger $ toInteger gran) - gran = effIx2gran ix - covering = getCoveringIntervals division - getCoveringIntervals ( pt1 : pt2 : rest ) = - ((pt1) RA.\/ (pt2)) : (getCoveringIntervals $ pt2 : rest) - getCoveringIntervals _ = [] - division = map getEndPoint $ [0..rectCount] - getEndPoint n = - a + ((fromInteger n) * width) - -{-| - integration using divide and conquer adaptive partitioning --} -integrateContAdapt_R :: - (RA.ERIntApprox ira) => - (EffortIndex -> ira -> ira) -> - EffortIndex -> (ira) -> (ira) -> (ira) -integrateContAdapt_R f ix a b = - sum rectangleAreas - where - rectangleAreas = - getRs 10 a b - getRs subix l r - | RA.getPrecision area >= prec = [area] - | otherwise = - (getRs nsubix l m) ++ (getRs nsubix m r) - where - prec = foldl1 min [effIx2prec ix, RA.getPrecision l, RA.getPrecision r] - area = (r - l) * (f subix (l RA.\/ r)) - nsubix = subix + 1 - m = (l + r)/2 - - -{-| - integration using divide and conquer adaptive partitioning - making use of the derivative of the integrated function --} -integrateDiffAdapt_RA :: - (RA.ERIntApprox ira) => - (EffortIndex -> ira -> ira, EffortIndex -> ira -> ira) -> - EffortIndex -> (ra) -> (ra) -> (ra) -integrateDiffAdapt_RA f prec a b = - error "TODO" - -{- - sum rectangleAreas - where - rectangleAreas = - getRs prec a b - getRs p l r - | getPrecision area >= prec = [area] - | otherwise = - (getRs np l m) ++ (getRs np m r) - where - np = p + 1 - m = (l + r)/2 --- area = areaDiff - area = areaRect /\ areaDiff - -- merge the information given by the rectangle method - -- with the information given by the derivative method - areaRect = w * fVal -- same as in integrateContAdapt_R - (fVal, fDeriv) = applyRdiffR f p (l \/ r) - w = r - l - areaDiff - | isExact fDeriv = w * (fl + fr) / 2 -- derivative is constant and perfectly known - | otherwise = areaLow \/ areaHigh - fl = fst $ applyRdiffR f (2 * p) l - fr = fst $ applyRdiffR f (2 * p) r - -- interestingly, we have to request fl, fr with higher precision than - -- we requested fDeriv so that the derivative would be of any use - -- with these values - replace (2 * p) by p and it will not converge! - -- area computed by a scary formula: - areaLow = t + w * (fl * dHigh - fr * dLow) / dDiff - areaHigh = - t - w * (fl * dLow - fr * dHigh) / dDiff -- swap dHigh and dLow - t = (w^2 * dLow * dHigh + (fr - fl)^2)/(2 * dDiff) - dDiff = dHigh - dLow - (dLow, dHigh) = getBounds fDeriv --} - - diff --git a/src/Data/Number/ER/Real/Arithmetic/LinearSolver.hs b/src/Data/Number/ER/Real/Arithmetic/LinearSolver.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Arithmetic/LinearSolver.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-| - Module : Data.Number.ER.Real.LinearSolver - Description : arbitrary precision piece-wise something function enclosures - Copyright : (c) Jan Duracz, Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - A simple validated solver for systems of linear equations with - interval coefficients. It uses a naive splitting approach and is - therefore very slow. --} -module Data.Number.ER.Real.Arithmetic.LinearSolver -( - linearSolver -) -where - -import qualified Data.Number.ER.Real.Approx as RA -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.List -import Data.Maybe ---import qualified Data.Map as Map - --- the following is code for unit testing -{- - -import Data.Number.ER.Real.DefaultRepr - -eq1 :: (Box IRA, IRA) -eq1 = (mkBox [1,2,1], 2) -eq2 = (mkBox [2,4,2], 4) -eq3 = (mkBox [2,4,4], 5) -eqs = [eq1,eq2,eq3] - -box = mkBox $ replicate 3 $ (-1)RA.\/1 -x1 = (-13/16)RA.\/(-3/4) :: IRA -x2 = (5/16)RA.\/(3/8) :: IRA -tol = 2^^(-20) :: IRA - -mkBox :: [IRA] -> Box IRA -mkBox iras = Map.fromList $ zip [1..] iras --} - -linearSolver :: - (RA.ERIntApprox ira, - DomainIntBox box varid ira, - DomainBoxMappable box box varid ira ira) => - [(box, ira)] - {-^ the equations; - each equation has coefficients of linear terms - + constant term -} -> - box {-^ the domain of the variables -} -> - ira {-^ an upper bound on the size of an acceptable solution box -} -> - Maybe box - {-^ - A box containing at least one solution within the domain; - Nothing if there is no solution. - -} -linearSolver eqns domBox tolerance = - linearSolver' eqns [domBox] tolerance - -linearSolver' eqns [] tolerance = - Nothing -linearSolver' eqns (b:bs) tolerance - | not $ evalEqns b eqns = -- no solutions in the box - linearSolver' eqns bs tolerance - | belowTolerance = - Just b - | otherwise = - linearSolver' eqns (splitBox b ++ bs) tolerance - where - belowTolerance = - and $ map (\d -> width d `RA.ltSingletons` tolerance) $ DBox.elems b - -evalEqns box eqns = - and $ map (evalEqn box) eqns - -{-| - returns true iff there exists a solution to the equation in the box --} -evalEqn box (expr,cons) = - cons `RA.refines` (evalExpr expr box) - where - evalExpr expr box = sum $ DBox.elems $ DBox.intersectionWith (*) expr box - -{-| - returns the list of (two) boxes resulting from splitting the widest edge - of the box in half --} -splitBox box = - [DBox.insert k (iLg RA.\/ iMg) box, - DBox.insert k (iMg RA.\/ iRg) box] - where - iMg = (iLg+iRg)/2 - iLg = incrementGranularity iL - iRg = incrementGranularity iR - (iL,iR) = RA.bounds i - i = DBox.lookup "ER: LinearSolver: splitBox: " k box - k = widestVar box - incrementGranularity x = - RA.setMinGranularityOuter (RA.getGranularity x + 1) x - -widestVar box = - fst $ DBox.bestSplit box - -width i = - snd $ RA.bounds (iR-iL) - where - (iL,iR) = RA.bounds i - diff --git a/src/Data/Number/ER/Real/Arithmetic/Newton.hs b/src/Data/Number/ER/Real/Arithmetic/Newton.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Arithmetic/Newton.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-| - - Module : Data.Number.ER.Real.Arithmetic.Taylor - Description : interval Newton method - Copyright : (c) Amin Farjudian, Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : alpha - Portability : portable - - Interval Newton's method for root finding. - - To be used for obtaining functions out of their inverse(s) over various - intervals. --} -module Data.Number.ER.Real.Arithmetic.Newton -( - erNewton_FullArgs, - erNewton_mdfd_FullArgs -) -where - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.BasicTypes -import Data.Number.ER.Real.Arithmetic.Taylor - -erNewton_FullArgs - :: (RA.ERIntApprox ira) - => (EffortIndex -> ira -> ira, EffortIndex -> ira -> ira) -- ^ a function and its derivative - -> ira -- ^ a starting point - -> ira -- ^ a lower bound of the absolute value of the derivative over the working interval - -> Int -- ^ number of iterations - -> EffortIndex -- ^ the initial index to use for argument function and its derivative - -> ira -- ^ the result - -erNewton_FullArgs (f ,df) startPt minDrv iterCnt i = - erNewton_FullArgs_aux startPt startOtherPt iterCnt - where - erNewton_FullArgs_aux newtonPt otherPt iterCnt - | (iterCnt <= 0 || RA.getPrecision result >= prec) = - result - | otherwise = - erNewton_FullArgs_aux newNewtonPt newOtherPt (iterCnt - 1) - where - result = - newtonPt RA.\/ otherPt - prec = effIx2prec i - newNewtonPt = - midPoint $ RA.bounds $ - (newtonPt - ( (f i newtonPt) / (( df i newtonPt)))) - -- /\ (ira2ra ((ra2ira minDrv) \/ 100000000))))) - newOtherPt = otherEndPoint newNewtonPt - startOtherPt = otherEndPoint startPt - otherEndPoint a = a - ((f i a) / minDrv) -- /\ (0 \/ 10000000) - - -{-| - This auxiliary function returns the average of two ra's --} -midPoint - :: (RA.ERIntApprox ira) - => (ira ,ira) - -> ira -midPoint (x1, x2) = (x1 + x2) / 2 - - -{-| Modified Newton Method - Notes: - - 1. It has a cubic convergence speed, as opposed to the original Newton's - square convergence speed. - - 2. It does not deal with multiple roots. - - 3. Per iteration, it makes two queries on the derivative, so it best - suits the cases where computation of the derivative is at most as - expensive as the function itself. --} -erNewton_mdfd_FullArgs - :: (RA.ERIntApprox ira) - => (EffortIndex -> ira -> ira, EffortIndex -> ira -> ira) -- ^ a function and its derivative - -> ira -- ^ a starting point - -> ira -- ^ The minimum of absolute value of derivative over the working interval - -> Int -- ^ number of iterations - -> EffortIndex -- ^ It triggers the initial index to be called by the argument function and its derivative. - -> ira -- ^ the result - -erNewton_mdfd_FullArgs (f ,df) startPt minDrv iterCnt i = - erNewton_FullArgs_aux startPt startOtherPt iterCnt - where - erNewton_FullArgs_aux newtonPt otherPt iterCnt - | iterCnt <= 0 = newtonPt RA.\/ otherPt - | otherwise = erNewton_FullArgs_aux newNewtonPt newOtherPt (iterCnt - 1) - where - valueAtNewOtherPt = f i newOtherPt - derivAtNewtonPt = df i newOtherPt - unblurredDeriv = midPoint $ RA.bounds $ derivAtNewtonPt - intermediaryPt = midPoint $ RA.bounds $ newtonPt - valueAtNewOtherPt / (2 * derivAtNewtonPt) - derivAtIntermediaryPt = df i intermediaryPt - newNewtonPt = - midPoint $ RA.bounds $ - (newtonPt - ( valueAtNewOtherPt / derivAtIntermediaryPt)) - newOtherPt = otherEndPoint newNewtonPt - startOtherPt = otherEndPoint startPt - otherEndPoint a = a - ((f i a) / minDrv) - -erNewton_mdfd - :: (RA.ERIntApprox ira) - => (EffortIndex -> ira -> ira, EffortIndex -> ira -> ira) -- ^ a function and its derivative - -> ira -- ^ a starting point - -> ira -- ^ The minimum of absolute value of derivative over the working interval - -> EffortIndex -- ^ It triggers the initial index to be called by the argument function and its derivative. - -> ira -- ^ the result - -erNewton_mdfd (f ,df) startPt minDrv i = - erNewton_mdfd_FullArgs (f, df) startPt minDrv (fromInteger $ toInteger $ i) i - ---apNewton_mdfd --- :: (RA.ERIntApprox ira) --- => (EffortIndex -> ra -> ra, EffortIndex -> ra -> ra) -- ^ a function and its derivative --- -> ra -- ^ a starting point --- -> ra -- ^ The minimum of absolute value of derivative over the working interval --- -> EffortIndex -- ^ It triggers the initial index to be called by the argument function and its derivative. Moreover, the number of iterations are predefined by this argument. --- -> ra -- ^ the result --- ---apNewton_mdfd (f, df) startPt minDrv i = --- erNewton_mdfd_FullArgs --- - ---id_RA --- :: (RA.ERIntApprox ira) --- => EffortIndex -> ira -> ira --- ---id_RA i x = x --- ---const_one_RA --- :: (RA.ERIntApprox ira) --- => EffortIndex -> ira -> ira --- ---const_one_RA i x = (setMinGranularity (effIx2gran i) 1) --- --- ---test_erNewton_FullArgs_01_RA --- :: (RA.ERIntApprox ira) --- => EffortIndex -> ira -> ira --- ---test_erNewton_FullArgs_01_RA i x = erNewton_FullArgs_01 ( id_RA, const_one_RA) x 10 i --- ---test_erNewton_FullArgs_01 --- :: (RA.ERIntApprox ira) --- => (ConvergRealSeq ira) -> (ConvergRealSeq ira) --- ---test_erNewton_FullArgs_01 = convertFuncRA2Seq test_erNewton_FullArgs_01_RA --- ---exp_Ra_minus_r_RA --- :: (RA.ERIntApprox ira) --- => EffortIndex -> ira -> ira -> ira --- ---exp_Ra_minus_r_RA i r x = (erExp_RA i x) - r --- ---exp_Ra_minus_r --- :: (RA.ERIntApprox ira) --- => (ConvergRealSeq ira) -> (ConvergRealSeq ira) -> (ConvergRealSeq ira) --- ---exp_Ra_minus_r = convertBinFuncRA2Seq exp_Ra_minus_r_RA --- ---logNewton_RA_02 --- :: (RA.ERIntApprox ira) --- => EffortIndex -> ira -> ira --- ---logNewton_RA_02 i x = --- erNewton_FullArgs_02 --- ( \ i y -> (erExp_RA i y) - x, erExp_RA) --- (setMinGranularity (effIx2gran i) (2)) --- (setMinGranularity (effIx2gran i) 1) --- i --- ---logNewton_02 --- :: (RA.ERIntApprox ira) --- => (ConvergRealSeq ira) -> (ConvergRealSeq ira) --- ---logNewton_02 = convertFuncRA2Seq logNewton_RA_02 - - ---logNewton_mdfd_RA --- :: (RA.ERIntApprox ira) --- => EffortIndex -> ira -> ira - ---logNewton_mdfd_RA i x = --- erNewton_mdfd_FullArgs --- ( \ i y -> (erExp_RA i y) - x, erExp_RA) --- (setMinGranularity (effIx2gran i) (2)) --- (setMinGranularity (effIx2gran i) 1) --- i - ---logNewton_mdfd --- :: (RA.ERIntApprox ira) --- => (ConvergRealSeq ira) -> (ConvergRealSeq ira) --- ---logNewton_mdfd = convertFuncRA2Seq logNewton_mdfd_RA diff --git a/src/Data/Number/ER/Real/Arithmetic/Taylor.hs b/src/Data/Number/ER/Real/Arithmetic/Taylor.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Arithmetic/Taylor.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Arithmetic.Taylor - Description : implementation of Taylor series - Copyright : (c) Amin Farjudian, Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Taylor series related functions. --} -module Data.Number.ER.Real.Arithmetic.Taylor where - -import qualified Data.Number.ER.Real.Approx as RA -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI -import Data.Number.ER.BasicTypes -import Data.Number.ER.Misc - - -erTaylor_R - :: (RA.ERIntApprox ira) - => EffortIndex - -> (Int -> ira) -- ^ coefficients of the Taylor series - -> (Int -> ira) -- ^ function to estimate the n'th derivative between a and x - -> ira -- ^ centre of the Taylor Expansion - -> ira - -> ira -erTaylor_R ix coefSeq derivBounds a x = - erTaylor_R_FullArgs coefSeq derivBounds n a gran x - where - n = fromInteger ix - gran = fromInteger $ toInteger $ ix - -erTaylor_R_FullArgs - :: (RA.ERIntApprox ira) - => (Int -> ira) -- ^ coefficients of the Taylor series - -> (Int -> ira) -- ^ function to estimate the n'th derivative between a and x - -> Int -- ^ use this many elements of the series (+ account for error appropriately) - -> ira -- ^ centre of the Taylor Expansion - -> Granularity -- ^ make all constants have this granularity, thus influencing rounding errors - -> ira - -> ira -erTaylor_R_FullArgs coefSeq derivBounds n a gran x = - rec_apTaylor (RA.setMinGranularityOuter gran 0) 0 - where - rec_apTaylor i j - | n > j = (coefSeq(j)) + - ((x - a)/(i+1)) * (rec_apTaylor (i+1) (j+1)) - | n == j = derivBounds n - | otherwise = - error "Data.Number.ER.Real.Arithmetic.Taylor.hs: erTaylor_RA_FullArgs: The index n cannot be negative" - -{-| - A Taylor series for exponentiation. --} -erExp_Tay_Opt_R - :: (RA.ERIntApprox ira) - => EffortIndex - -> ira - -> ira -erExp_Tay_Opt_R ix x - | x `RA.refines` (-RA.plusInfinity) = --- unsafePrintReturn --- ( --- "erExp_Tay_Opt_R (x `RA.refines` (-RA.plusInfinity)): " --- ++ "\n x = " ++ show x --- ++ "\n ix = " ++ show ix --- ++ "\n result = " --- ) $ - 0 -- -infty is not handled well by the Taylor formula - | otherwise = --- unsafePrintReturn --- ( --- "erExp_Tay_Opt_R: " --- ++ "\n x = " ++ show x --- ++ "\n ix = " ++ show ix --- ++ "\n result = " --- ) $ - 1 + (te ix x (RA.setMinGranularityOuter gran 1)) - where - gran = effIx2gran ix - te steps x i - | steps > 0 = - (x/i) * (1 + (te (steps - 1) x (i + 1))) - | steps == 0 = - errorBound - where - errorBound = - (x/i) * ithDerivBound - ithDerivBound - | xCeiling == EI.MinusInfinity = -- certainly -infty: - 0 - | xCeiling < 0 = -- certainly negative: - pow26xFloor RA.\/ 1 - | xFloor > 0 = -- certainly positive: - 1 RA.\/ pow28xCeiling - | otherwise = -- could contain 0: - pow26xFloor RA.\/ pow28xCeiling - where - (xFloor, xCeiling) = RA.integerBounds x - pow26xFloor - | xFloor == EI.MinusInfinity = - 0 - | otherwise = - ((RA.setMinGranularityOuter gran 26)/10) ^^ xFloor - -- lower estimate of e^x - pow28xCeiling - | xCeiling == EI.PlusInfinity = - (RA.plusInfinity) - | otherwise = - ((RA.setMinGranularityOuter gran 28)/10) ^^ xCeiling - -- upper estimate of e^x - -{- - The sine and cosine are implemented in almost exactly the same way --} - -{-| - A Taylor series for sine. --} -erSine_Tay_Opt_R - :: (RA.ERIntApprox ira) - => EffortIndex - -> ira - -> ira -erSine_Tay_Opt_R ix x = - taylor_seg ix x (RA.setMinGranularityOuter gran 1) - where - gran = effIx2gran ix - taylor_seg i x n -- 'i' for iterator - | i > 0 = x - (x*x)/((n+1)*(n+2)) * (taylor_seg (i-2) x (n+2)) - | otherwise = errorRegion - where - errorRegion = (- x) RA.\/ x - - -{-| - A Taylor series for cosine. --} -erCosine_Tay_Opt_R - :: (RA.ERIntApprox ira) - => EffortIndex - -> ira - -> ira -erCosine_Tay_Opt_R ix x = taylor_seg ix x (RA.setMinGranularityOuter gran 1) - where - gran = effIx2gran ix - taylor_seg i x n -- 'i' for iterator - | i > 0 = 1 - ((x*x)/(n*(n+1))) * (taylor_seg (i-2) x (n+2)) - | otherwise = errorRegion - where - errorRegion = (-1) RA.\/ (1) - - - -{-| Natural Logarithm: The following is a code for obtaining natural - logarithm using taylor series. Note that it only works for - x in [ 1, 2]. For other values, a scaling by factors of e^q is - best to do, i.e. if x is not in [1,2], then find some ratioal number - q where exp(q) * x is in [1,2]. Then you have: - log ( exp(q) * m) = q + log(m) --} - -{-| Coefficients of the taylor series around a=1 -} ---logTayCoefs --- :: (RA.ERIntApprox ira) --- => Int -- up to how many terms of the Taylor series is desired --- -> Int --- -> ra --- ---logTayCoefs n i ----- | i < 0 = error "ERTaylor.logTayCoefs: Negative n for the n-th term of Taylor series for logarithm" --- | i == 0 = 0 --- | i == n = fromInteger $ toInteger $ amFact(n-1) --- | otherwise = fromInteger $ toInteger $ ((-1)^(i-1) * amFact(i-1)) --- where --- amFact (m) = product [1..m] - ---logTay_RA --- :: (RA.ERIntApprox ira) --- => EffortIndex --- -> ra --- -> ra --- ---logTay_RA i = erTaylor_RA_FullArgs (logTayCoefs $fromInteger $ toInteger $ i) --- (100000) (setMinGranularity (effIx2gran i) 1) (effIx2gran i) --- --- ---logTay --- :: (RA.ERIntApprox ira) --- => (ConvergRealSeq ra) --- -> (ConvergRealSeq ra) ---logTay = convertFuncRA2Seq logTay_RA - diff --git a/src/Data/Number/ER/Real/Base.hs b/src/Data/Number/ER/Real/Base.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Base.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Base - Description : class abstracting floats - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Abstraction over various fixed and floating point types as well - as rational numbers. - - This module should be included qualified as is often given the local - synonym B. --} -module Data.Number.ER.Real.Base -( - module Data.Number.ER.BasicTypes, - ERRealBase(..) -) -where - -import Data.Number.ER.BasicTypes -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI - -import Data.Typeable - -{-| - This class is an abstraction of a subset of real numbers - with *upwards rounded* operations. --} -class (RealFrac rb, Ord rb) => ERRealBase rb - where - typeName :: rb -> String - initialiseBaseArithmetic :: rb -> IO () - initialiseBaseArithmetic x = - do - putStrLn $ "Base arithmetic: " ++ typeName x - defaultGranularity :: rb -> Granularity - getApproxBinaryLog :: rb -> EI.ExtendedInteger - getGranularity :: rb -> Granularity - setMinGranularity :: Granularity -> rb -> rb - setGranularity :: Granularity -> rb -> rb - {-| - if @a@ is rounded to @ao@ then @|a-ao| <= getBaseMaxRounding ao@ - -} - getMaxRounding :: rb -> rb - isERNaN :: rb -> Bool - erNaN :: rb - isPlusInfinity :: rb -> Bool - isMinusInfinity :: rb -> Bool - isMinusInfinity = isPlusInfinity . negate - plusInfinity :: rb - minusInfinity :: rb - minusInfinity = - plusInfinity - fromIntegerUp :: Integer -> rb - fromIntegerDown :: Integer -> rb - fromIntegerDown i = negate $ fromIntegerUp $ - i - fromDouble :: Double -> rb - toDouble :: rb -> Double - fromFloat :: Float -> rb - toFloat :: rb -> Float - showDiGrCmp :: - Int {- ^ number of decimal digits to show -} -> - Bool {-^ whether to show granularity -} -> - Bool {-^ whether to show internal structure -} -> - rb -> String diff --git a/src/Data/Number/ER/Real/Base/CombinedMachineAP.hs b/src/Data/Number/ER/Real/Base/CombinedMachineAP.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Base/CombinedMachineAP.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-| - Module : Data.Number.ER.Real.Base.CombinedMachineAP - Description : auto-switching hardware-software floats - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : non-portable (requires fenv.h) - - Arbitrary precision floating point numbers that use - machine double up to its precision. When a higher - granularity is required, it automatically switches - to another floating point type. --} -module Data.Number.ER.Real.Base.CombinedMachineAP -( - ERMachineAP, - doubleDigits -) -where - -import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI -import Data.Number.ER.Real.Base.MachineDouble -import Data.Number.ER.Real.Base.Float -import Data.Number.ER.BasicTypes -import Data.Number.ER.Misc - -import Data.Typeable -import Data.Generics.Basics -import Data.Binary ---import BinaryDerive - -import Data.Ratio - -data ERMachineAP b = - ERMachineAPMachineDouble - { - machapfltDoubleGranularity :: Granularity - {-^ this has to be between 1 and 'doubleDigits' -} - , - machapfltDouble :: Double - } - | - ERMachineAPB - { - machapfltB :: b - } - deriving (Typeable, Data) - -doubleDigits = floatDigits (0 :: Double) - -{- the following has been generated by BinaryDerive -} -instance (Binary b) => (Binary (ERMachineAP b)) where - put (ERMachineAPMachineDouble a b) = putWord8 0 >> put a >> put b - put (ERMachineAPB a) = putWord8 1 >> put a - get = do - tag_ <- getWord8 - case tag_ of - 0 -> get >>= \a -> get >>= \b -> return (ERMachineAPMachineDouble a b) - 1 -> get >>= \a -> return (ERMachineAPB a) - _ -> fail "no parse" -{- the above has been generated by BinaryDerive -} - -lift1ERMachineAP :: - (Double -> Double) -> - (b -> b) -> - (ERMachineAP b -> ERMachineAP b) -lift1ERMachineAP fD fB (ERMachineAPMachineDouble g d) = - ERMachineAPMachineDouble g (fD d) -lift1ERMachineAP fD fB (ERMachineAPB b) = - ERMachineAPB (fB b) - -op1ERMachineAP :: - (Double -> a) -> - (b -> a) -> - (ERMachineAP b -> a) -op1ERMachineAP fD fB (ERMachineAPMachineDouble g d) = - fD d -op1ERMachineAP fD fB (ERMachineAPB b) = - fB b - -lift2ERMachineAP :: - (B.ERRealBase b) => - (Double -> Double -> Double) -> - (b -> b -> b) -> - (ERMachineAP b -> ERMachineAP b -> ERMachineAP b) -lift2ERMachineAP fD fB - (ERMachineAPMachineDouble g1 d1) (ERMachineAPMachineDouble g2 d2) = - ERMachineAPMachineDouble (max g1 g2) (fD d1 d2) -lift2ERMachineAP fD fB - (ERMachineAPMachineDouble g1 d1) (ERMachineAPB b2) = - ERMachineAPB $ fB (B.fromDouble d1) b2 -lift2ERMachineAP fD fB - (ERMachineAPB b1) (ERMachineAPMachineDouble g2 d2) = - ERMachineAPB $ fB b1 (B.fromDouble d2) -lift2ERMachineAP fD fB - (ERMachineAPB b1) (ERMachineAPB b2) = - ERMachineAPB $ fB b1 b2 - -op2ERMachineAP :: - (B.ERRealBase b) => - (Double -> Double -> a) -> - (b -> b -> a) -> - (ERMachineAP b -> ERMachineAP b -> a) -op2ERMachineAP fD fB - (ERMachineAPMachineDouble g1 d1) (ERMachineAPMachineDouble g2 d2) = - fD d1 d2 -op2ERMachineAP fD fB - (ERMachineAPMachineDouble g1 d1) (ERMachineAPB b2) = - fB (B.fromDouble d1) b2 -op2ERMachineAP fD fB - (ERMachineAPB b1) (ERMachineAPMachineDouble g2 d2) = - fB b1 (B.fromDouble d2) -op2ERMachineAP fD fB - (ERMachineAPB b1) (ERMachineAPB b2) = - fB b1 b2 - -instance (B.ERRealBase b) => Show (ERMachineAP b) - where - show = showERMachineAP 6 True True - -showERMachineAP numDigits showGran showComponents = - showEMA - where - maybeGran gr - | showGran = "{g=" ++ show gr ++ "}" - | otherwise = "" - maybeComps - | showComponents = "{Double}" - | otherwise = "" - showEMA (ERMachineAPMachineDouble gr d) = - show d ++ (maybeGran gr) ++ maybeComps - showEMA (ERMachineAPB b) = - B.showDiGrCmp numDigits showGran showComponents b - - -instance (B.ERRealBase b) => Eq (ERMachineAP b) - where - (==) = op2ERMachineAP (==) (==) - -instance (B.ERRealBase b) => Ord (ERMachineAP b) - where - compare = op2ERMachineAP compare compare - - - -instance (B.ERRealBase b) => Num (ERMachineAP b) - where - fromInteger n - | gran < doubleDigits = - ERMachineAPMachineDouble gran $ fromInteger n - | otherwise = - ERMachineAPB b - where - gran = B.getGranularity b - b = fromInteger n - abs = lift1ERMachineAP abs abs - signum = lift1ERMachineAP signum signum - negate = lift1ERMachineAP negate negate - (+) = lift2ERMachineAP (+) (+) - (*) = lift2ERMachineAP (*) (*) - -instance (B.ERRealBase b) => Fractional (ERMachineAP b) - where - fromRational rat = - (fromInteger $ numerator rat) - / (fromInteger $ denominator rat) - recip = lift1ERMachineAP recip recip - (/) = lift2ERMachineAP (/) (/) - -instance (B.ERRealBase b, Real b) => Real (ERMachineAP b) - where - toRational = op1ERMachineAP toRational toRational - -instance (B.ERRealBase b, RealFrac b) => RealFrac (ERMachineAP b) - where - properFraction (ERMachineAPMachineDouble g d) = - (a, ERMachineAPMachineDouble g remainder) - where - (a,remainder) = properFraction d - properFraction (ERMachineAPB b) = - (a, ERMachineAPB remainder) - where - (a,remainder) = properFraction b - - -instance (B.ERRealBase b) => B.ERRealBase (ERMachineAP b) - where - typeName _ = "auto switching double and " ++ (B.typeName (0::b)) - initialiseBaseArithmetic x = - do - putStr $ "Base arithmetic:" ++ B.typeName x ++ "; " - initMachineDouble - defaultGranularity _ = (B.defaultGranularity (0 :: b)) - getApproxBinaryLog = - op1ERMachineAP doubleBinaryLog B.getApproxBinaryLog - where - doubleBinaryLog d - | d < 0 = - error $ "ERMachineAP: getApproxBinaryLog: negative argument " ++ show d - | d == 0 = EI.MinusInfinity - | d >= 1 = - fromInteger $ intLogUp 2 $ ceiling d - | d < 1 = - negate $ fromInteger $ intLogUp 2 $ ceiling $ recip d - getGranularity (ERMachineAPB b) = B.getGranularity b - getGranularity (ERMachineAPMachineDouble gr _) = gr - setMinGranularity gran (ERMachineAPMachineDouble g d) - | gran > doubleDigits = - ERMachineAPB $ B.setMinGranularity gran $ B.fromDouble d - | otherwise = - ERMachineAPMachineDouble gran d - setMinGranularity gran (ERMachineAPB b) = ERMachineAPB $ B.setMinGranularity gran b - setGranularity gran (ERMachineAPMachineDouble g d) - | gran > doubleDigits = - ERMachineAPB $ B.setGranularity gran $ B.fromDouble d - | otherwise = - ERMachineAPMachineDouble gran d - setGranularity gran (ERMachineAPB b) - | gran <= doubleDigits = - ERMachineAPMachineDouble gran $ B.toDouble b - | otherwise = - ERMachineAPB $ B.setGranularity gran b - getMaxRounding _ = - error "ERMachineAP: getMaxRounding not implemented yet" - isERNaN = op1ERMachineAP isNaN B.isERNaN - erNaN = B.fromDouble (0/0) - isPlusInfinity = - op1ERMachineAP (== 1/0) B.isPlusInfinity - plusInfinity = B.fromDouble $ 1/0 - fromIntegerUp = fromInteger - fromDouble d = - ERMachineAPMachineDouble (B.defaultGranularity (0 :: b)) d - toDouble = op1ERMachineAP id B.toDouble - fromFloat f = - ERMachineAPMachineDouble (B.defaultGranularity (0 :: b)) $ - fromRational $ toRational f - toFloat = op1ERMachineAP (fromRational . toRational) B.toFloat - showDiGrCmp = showERMachineAP - diff --git a/src/Data/Number/ER/Real/Base/Float.hs b/src/Data/Number/ER/Real/Base/Float.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Base/Float.hs +++ /dev/null @@ -1,518 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-| - Module : Data.Number.ER.Real.Base - Description : arbitrary precision floating point numbers - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - This module defines an arbitrary precision floating point type and - its operations. It should be viewed more abstractly as an instance - of 'B.ERRealBase' when used as interval endpoints. --} -module Data.Number.ER.Real.Base.Float -( - ERFloat -) -where - -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI -import Data.Number.ER.BasicTypes.PlusMinus -import Data.Number.ER.Misc -import Data.Number.ER.BasicTypes -import qualified Data.Number.ER.Real.Base as B - -import Data.Ratio - -import Data.Typeable -import Data.Generics.Basics -import Data.Binary --- import BinaryDerive - ---debugMsg = unsafePrint -debugMsg msg = id - - -{-| -A floating point number with a given but arbitrary precision represented by its 'Granularity'. - - * base: 2. - - * granularity specifies the bit-size of both the significand and the exponent - - * special values: NaN, signed Infinity and signed Zero - - * no denormalised numbers - - * operations unify the granularity of their operands to the maximum 'Granularity' - - * Rounding is always towards +Infinity. - For field operations, the rounded result is as close as possible to the exact result. --} -data ERFloat = - ERFloatNaN -- any number / bottom - { - apfltGran :: Granularity -- >0 - } - | ERFloatInfty - { - apfltGran :: Granularity, -- >0 - apfltSign :: PlusMinus - } - | ERFloatZero - { - apfltGran :: Granularity, -- >0 - apfltSign :: PlusMinus - } - | ERFloat - { - -- represents: - -- sign * (1 + (mant/2^gran)) * (2 ^ exp) - apfltGran :: Granularity, -- >0 granularity - apfltSign :: PlusMinus, - apfltMant :: Integer, -- 0 .. (2^gran - 1) - apfltExp :: Integer -- -2^gran..2^gran - } - deriving (Typeable, Data) - -zero = ERFloatZero 10 Plus - -{- the following has been generated by BinaryDerive -} -instance Binary ERFloat where - put (ERFloatNaN a) = putWord8 0 >> put a - put (ERFloatInfty a b) = putWord8 1 >> put a >> put b - put (ERFloatZero a b) = putWord8 2 >> put a >> put b - put (ERFloat a b c d) = putWord8 3 >> put a >> put b >> put c >> put d - get = do - tag_ <- getWord8 - case tag_ of - 0 -> get >>= \a -> return (ERFloatNaN a) - 1 -> get >>= \a -> get >>= \b -> return (ERFloatInfty a b) - 2 -> get >>= \a -> get >>= \b -> return (ERFloatZero a b) - 3 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (ERFloat a b c d) - _ -> fail "no parse" -{- the above has been generated by BinaryDerive -} - - -{-| normalisation - - * ensures that the components are within their regions - - * possibly turning the number into a zero or infinity --} -normaliseERFloat :: ERFloat -> ERFloat -normaliseERFloat flt@(ERFloat gr s m e) - | m < 0 = - normaliseERFloat $ - ERFloat gr s (2*m + grmax) (e - 1) - | m >= grmax = - normaliseERFloat $ - ERFloat gr s ((m - grmax + (rndCorr s)) `div` 2) (e + 1) - | e > grmax = - case s of - Plus -> ERFloatInfty gr Plus - Minus -> minERFloat gr -- round upwards! - | e < -grmax = - case s of - Plus -> ulpERFloat gr -- round upwards! - Minus -> ERFloatZero gr Minus - | otherwise = flt - where - grmax = 2^gr -normaliseERFloat flt = flt - -ulpERFloat gr = - ERFloat gr Plus 0 (-2^gr) - -minERFloat gr = - ERFloat gr Minus (grmax - 1) grmax - where - grmax = 2^gr - -maxERFloat gr = - ERFloat gr Plus (grmax - 1) grmax - where - grmax = 2^gr - -rndCorr Plus = 1 -rndCorr Minus = 0 - -increaseERFloatExp e flt@(ERFloat gr s m eOld) = - ERFloat gr s mNew e - where - mNew = - -grmax + ((m + grmax + (rndCorr s) * (ediff - 1)) `div` ediff) - -- .^^^^^^^^^^^^^^^^^^^^^^^^^ round upwards - grmax = 2^gr - ediff = 2^(e - eOld) -- assuming e >= eOld -increaseERFloatExp _ flt = flt - -decreaseERFloatExp e flt@(ERFloat gr s m eOld) = - ERFloat gr s mNew e - where - mNew = - -grmax + ediff * (m + grmax) - grmax = 2^gr - ediff = 2^(eOld - e) -- assuming e <= eOld -decreaseERFloatExp _ flt = flt - - -apFloatExponent :: ERFloat -> EI.ExtendedInteger - -apFloatExponent (ERFloatInfty _ _) = EI.PlusInfinity -apFloatExponent (ERFloatZero _ _) = EI.MinusInfinity -apFloatExponent (ERFloatNaN _) = EI.PlusInfinity -- includes infinity -apFloatExponent flt = EI.Finite $ apfltExp flt - - -setERFloatGranularity :: - Granularity -> ERFloat -> ERFloat -setERFloatGranularity gr flt@(ERFloat oldGr s m e) - | gr > 0 = - normaliseERFloat $ ERFloat gr s newM e - | otherwise = - flt - where - newM = - (m * (2^gr) - + ((rndCorr s)*(2^oldGr - 1))) -- round upwards! - `div` (2^oldGr) -setERFloatGranularity gr f = f { apfltGran = gr } - -setERFloatMinGranularity :: - Granularity -> ERFloat -> ERFloat -setERFloatMinGranularity gr flt - | gr > oldGr = - setERFloatGranularity gr flt - | otherwise = flt - where - oldGr = apfltGran flt - -apfltGranularity = apfltGran - -{-^ see the documentation of 'ERRealBase.getBaseMaxRounding' -} -apfltGetMaxRounding :: - ERFloat -> ERFloat -apfltGetMaxRounding f@(ERFloatNaN _) = f -apfltGetMaxRounding f@(ERFloatInfty _ _) = f -apfltGetMaxRounding (ERFloatZero gr _) = - ERFloat gr Plus 0 (-(2^gr)) -apfltGetMaxRounding (ERFloat gr s m e) = - ERFloat gr Plus 0 (max (e - (toInteger gr)) (-(2^gr))) - -instance Show ERFloat where - show = showERFloat 6 True False - - -showERFloat numDigits showGran showComponents flt = - showERF flt - where - maybeGran gr - | showGran = "{g=" ++ show gr ++ "}" - | otherwise = "" - showPM Plus = "" - showPM Minus = "-" - showERF (ERFloatNaN gr) = "NaN" ++ (maybeGran gr) - showERF (ERFloatZero gr pm) = showPM pm ++ "0.0" ++ (maybeGran gr) - showERF (ERFloatInfty gr pm) = showPM pm ++ "oo" ++ (maybeGran gr) - showERF f@(ERFloat gr s m e) = - decimal ++ (maybeGran gr) ++ maybeComps - where - maybeComps - | showComponents = "{val="++ show (s,m,e) ++ "}" - | otherwise = "" - decimal = - showPM s - ++ show digit1 ++ "." ++ (concat $ map show $ take numDigits digits) - ++ (if dexp == 0 then "" else "e" ++ show dexp) - (dexp, digit1 : digits) - | noLeadingZerosDexp == -1 = - (0, 0 : noLeadingZeroDigits) - | otherwise = - (noLeadingZerosDexp, noLeadingZeroDigits) - noLeadingZerosDexp = dexpBound - zerosCount - (zerosCount, noLeadingZeroDigits) = - stripCountZeros 0 preDigits - stripCountZeros prevZeros ds@(d : dsRest) - | d == 0 = stripCountZeros (prevZeros + 1) dsRest - | otherwise = (prevZeros, ds) - dexpBound -- upper bound of dexp: f/10^dexpBound < 1 - | e >= 0 = intLogUp 10 (2^e) - | e < 0 = 2 - (intLogUp 10 (2^(-e))) - preDigits = - getDigits $ (abs $ setERFloatGranularity gran f) / (ten ^^ dexpBound) - ten = setERFloatGranularity gran 10 - gran = 10 + (max (4 * numDigits) gr) - getDigits ff = - digit : digits - where - digit :: Integer - digit = truncate ff - digits = - getDigits ((ff - (fromInteger digit)) * ten) - - -{- - Beware: cannot use List.elem with ERFloat because of - the intensional nature of Eq (eg ERFloatNaN /= ERFloatNaN). --} -instance Eq ERFloat where - (ERFloatNaN _) == _ = - False - -- error "cannot compare NaN" - _ == (ERFloatNaN _) = - False - -- error "cannot compare NaN" - (ERFloatZero _ _) == (ERFloatZero _ _) = True - (ERFloatInfty _ pm1) == (ERFloatInfty _ pm2) = (pm1 == pm2) - f1@(ERFloat gr1 s1 m1 e1) == f2@(ERFloat gr2 s2 m2 e2) - | gr1 < gr2 = - (setERFloatGranularity gr2 f1) == f2 - | gr1 > gr2 = - f1 == (setERFloatGranularity gr1 f2) - | otherwise = - s1 == s2 && m1 == m2 && e1 == e2 - _ == _ = False - -isERFloatNaN (ERFloatNaN _) = True -isERFloatNaN _ = False - -instance Ord ERFloat where - {- compare NaN -} - compare a b@(ERFloatNaN _) = - unsafePrint ("ERFloat: comparing NaN: " ++ show a ++ " vs. " ++ show b) EQ --- error $ "ERFloat: comparing NaN: " ++ show a ++ " vs. " ++ show b - compare a@(ERFloatNaN _) b = - unsafePrint ("ERFloat: comparing NaN: " ++ show a ++ " vs. " ++ show b) EQ --- error $ "ERFloat: comparing NaN: " ++ show a ++ " vs. " ++ show b - {- compare infty -} - compare (ERFloatInfty gr1 pm1) (ERFloatInfty gr2 pm2) = - compare pm1 pm2 - compare _ (ERFloatInfty _ Plus) = LT - compare _ (ERFloatInfty _ Minus) = GT - compare (ERFloatInfty _ Plus) _ = GT - compare (ERFloatInfty _ Minus) _ = LT - {- compare zero -} - compare (ERFloatZero gr1 pm1) (ERFloatZero gr2 pm2) = EQ - compare (ERFloatZero _ _) (ERFloat _ Plus _ _) = LT - compare (ERFloatZero _ _) (ERFloat _ Minus _ _) = GT - compare (ERFloat _ Minus _ _) (ERFloatZero _ _) = LT - compare (ERFloat _ Plus _ _) (ERFloatZero _ _) = GT - {- compare regular -} - compare (ERFloat _ Minus _ _) (ERFloat _ Plus _ _) = LT - compare (ERFloat _ Plus _ _) (ERFloat _ Minus _ _) = GT - compare (ERFloat gr1 Plus m1 e1) (ERFloat gr2 _ m2 e2) - | e1 < e2 = LT - | e1 > e2 = GT - | gr1 == gr2 = compare m1 m2 - | otherwise = compare ((2^gr2)*m1) ((2^gr1)*m2) - compare f1@(ERFloat _ Minus _ _) f2@(ERFloat _ _ _ _) = - compare (-f2) (-f1) - -instance Num ERFloat where - fromInteger n - | n == 0 = ERFloatZero (B.defaultGranularity zero) Plus - | n < 0 = - normaliseERFloat $ ERFloat gr Minus m e - | otherwise = - normaliseERFloat $ ERFloat gr Plus m e - where - gr = fromInteger e - e = max (toInteger (B.defaultGranularity zero)) $ (intLogUp 2 $ abs n) - 1 - m = (abs n) - 2^gr - abs f@(ERFloatNaN _) = f - abs f = f { apfltSign = Plus } - signum f@(ERFloatNaN _) = f - signum (ERFloatZero gr Plus) = setERFloatMinGranularity gr 1 - signum (ERFloatZero gr Minus) = setERFloatMinGranularity gr (-1) - signum (ERFloatInfty gr Plus) = setERFloatMinGranularity gr 1 - signum (ERFloatInfty gr Minus) = setERFloatMinGranularity gr (-1) - signum flt = - case apfltSign flt of { Plus -> 1; Minus -> -1 } - negate (ERFloat gr s m e) = ERFloat gr (signNeg s) m e - negate (ERFloatZero gr s) = ERFloatZero gr (signNeg s) - negate (ERFloatInfty gr s) = ERFloatInfty gr (signNeg s) - negate f@(ERFloatNaN _) = f - {- addition -} - f1 + f2 -- ensure equal granularity: - | gr1 > gr2 = f1 + (setERFloatGranularity gr1 f2) - | gr1 < gr2 = (setERFloatGranularity gr2 f1) + f2 - where - gr1 = apfltGran f1 - gr2 = apfltGran f2 - f@(ERFloatNaN _) + _ = f - _ + f@(ERFloatNaN _) = f - (ERFloatZero _ _) + f = f - f + (ERFloatZero _ _) = f - (ERFloatInfty gr Plus) + (ERFloatInfty _ Minus) = - debugMsg ("ERFloat: infty - infty -> NaN\n") $ - ERFloatNaN gr - (ERFloatInfty gr Minus) + (ERFloatInfty _ Plus) = - debugMsg ("ERFloat: -infty + infty -> NaN\n") $ - ERFloatNaN gr - f@(ERFloatInfty gr s) + _ = f - _ + f@(ERFloatInfty gr s) = f - f1@(ERFloat gr s1 m1 e1) + f2@(ERFloat _ s2 m2 e2) - -- equalise the exponents: - | e1 < e2 = f1 + (decreaseERFloatExp e1 f2) - | e1 > e2 = (decreaseERFloatExp e2 f1) + f2 - -- ensure positive comes before negative: - | s1 == Minus && s2 == Plus = - f2 + f1 - -- opposite signs: - | s1 == Plus && s2 == Minus && m1 == m2 = - ERFloatZero gr Plus - | s1 == Plus && s2 == Minus && m1 > m2 = - normaliseERFloat $ - ERFloat gr s1 (m1 - m2 - 2^gr) e1 - | s1 == Plus && s2 == Minus && m1 < m2 = - normaliseERFloat $ - ERFloat gr s2 (m2 - m1 - 2^gr) e1 - -- equal signs: - | otherwise = - normaliseERFloat $ - ERFloat gr s1 (m1 + m2 + 2^gr) e1 - {- multiplication -} - -- ensure equal granularity: - f1 * f2 - | gr1 > gr2 = f1 * (setERFloatGranularity gr1 f2) - | gr1 < gr2 = (setERFloatGranularity gr2 f1) * f2 - where - gr1 = apfltGran f1 - gr2 = apfltGran f2 - -- NaN: - f@(ERFloatNaN _) * _ = f - _ * f@(ERFloatNaN _) = f - -- Infty - (ERFloatInfty gr _) * (ERFloatZero _ _) = - debugMsg ("ERFloat: infty * 0 -> NaN\n") $ - ERFloatNaN gr - (ERFloatZero gr _) * (ERFloatInfty _ _) = - debugMsg ("ERFloat: 0 * infty -> NaN\n") $ - ERFloatNaN gr - f * (ERFloatInfty gr s) = ERFloatInfty gr $ signMult s (apfltSign f) - (ERFloatInfty gr s) * f = ERFloatInfty gr $ signMult s (apfltSign f) - -- Zero - (ERFloatZero gr s) * f = ERFloatZero gr $ signMult s (apfltSign f) - f * (ERFloatZero gr s) = ERFloatZero gr $ signMult s (apfltSign f) - -- regular - f1@(ERFloat gr s1 m1 e1) * f2@(ERFloat _ s2 m2 e2) = - normaliseERFloat $ - ERFloat gr s mNew (e1 + e2) - where - s = signMult s1 s2 - mNew = - m1 + m2 - + ((m1 * m2 + (rndCorr s) * (2^gr - 1)) - `div` 2^gr) - -instance Fractional ERFloat where - fromRational rat = --- error "ERFloat: fromRational cannot be implemented reliably: use apfloatFromRational instead" - (fromInteger $ numerator rat) - / (fromInteger $ denominator rat) - f1 / f2 - | gr1 > gr2 = f1 / (setERFloatGranularity gr1 f2) - | gr1 < gr2 = (setERFloatGranularity gr2 f1) / f2 - where - gr1 = apfltGran f1 - gr2 = apfltGran f2 - f@(ERFloatNaN _) / _ = f - f1 / f2 = - case apfltSign f1 of - Plus -> f1 * (recip f2) - Minus -> (- f1) * (recip (- f2)) -- rounding upwards! - recip f@(ERFloatNaN _) = f - recip (ERFloatZero gr s) = ERFloatInfty gr s - recip (ERFloatInfty gr s) = ERFloatZero gr s - recip (ERFloat gr s m e) = - normaliseERFloat $ - ERFloat gr s mNew (-e) - where - mNew = - (- grmax * m - + (rndCorr s) * (grmax + m -1)) -- rounding upwards! - `div` - (grmax + m) - grmax = 2^gr - - -apfloatFromRational :: - Granularity -> Rational -> ERFloat -apfloatFromRational gran rat = - (setERFloatMinGranularity gran (fromInteger $ numerator rat)) - / (fromInteger $ denominator rat) - - - -instance Real ERFloat where - toRational (ERFloat gr s m e) = - case s of - Plus -> r - Minus -> -r - where - r = (eOn2R) * (1 + mR/(grOn2R)) - mR = toRational m - eOn2R = toRational $ 2 ^^ e - grOn2R = toRational $ 2 ^ gr - toRational (ERFloatZero _ _) = 0 - toRational f = - error $ "cannot covert " ++ show f ++ " to a rational" - -instance RealFrac ERFloat where - properFraction (ERFloatNaN _) = - error "no integral part in ERFloatNaN" - properFraction (ERFloatZero _ _) = - (0, 0) - properFraction (ERFloatInfty _ _) = - error "no integral part in ERFloatInfty" - properFraction f@(ERFloat gr s m e) - | e < 0 = (0, f) - | s == Plus = - (n, frac) - | s == Minus = - (-n, frac) - where - n = fromInteger $ 2^e + (m*(2^e) `div` 2^gr) - frac = f - (fromInteger $ toInteger n) - - -instance B.ERRealBase ERFloat - where - typeName _ = "ERFloat (pure Haskell implementation)" - defaultGranularity _ = 10 - getApproxBinaryLog = apFloatExponent - getGranularity = apfltGran - setMinGranularity = setERFloatMinGranularity - setGranularity = setERFloatGranularity - getMaxRounding = apfltGetMaxRounding - isERNaN (ERFloatNaN _) = True - isERNaN _ = False - erNaN = ERFloatNaN (B.defaultGranularity zero) - isPlusInfinity (ERFloatInfty _ Plus) = True - isPlusInfinity _ = False - plusInfinity = ERFloatInfty (B.defaultGranularity zero) Plus - fromIntegerUp i = fromInteger i - fromDouble d - | isNaN d = ERFloatNaN (B.defaultGranularity zero) - | otherwise = (fromRational . toRational) d - toDouble (ERFloatInfty _ s) = signToNum s * (1/0) - toDouble (ERFloatNaN _) = 0/0 - toDouble flt = - (fromInteger $ numerator rat) / (fromInteger $ denominator rat) - where - rat = toRational flt - fromFloat f - | isNaN f = ERFloatNaN (B.defaultGranularity zero) - | otherwise = (fromRational . toRational) f - toFloat (ERFloatInfty _ s) = signToNum s * (1/0) - toFloat (ERFloatNaN _) = 0/0 - toFloat flt = - (fromInteger $ numerator rat) / (fromInteger $ denominator rat) - where - rat = toRational flt - showDiGrCmp = showERFloat - diff --git a/src/Data/Number/ER/Real/Base/MPFR.hs b/src/Data/Number/ER/Real/Base/MPFR.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Base/MPFR.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE CPP #-} --- #define USE_MPFR -{-| - Module : Data.Number.ER.Real.Base.MPFR - Description : enabling MPFR dyadics as interval endpoints - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : non-portable (requires fenv.h) - - Make Ales Bizjak's Haskell interface to MPFR an instance of - 'B.ERRealBase'. - - If compiled without USE_MPFR, this module is empty. --} -module Data.Number.ER.Real.Base.MPFR -( -#ifdef USE_MPFR - MPFR -#endif -) -where - -import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI -import Data.Number.ER.Misc - -import Data.Binary - -#ifdef USE_MPFR -import qualified Data.Number.MPFR.Up as M - -type MPFR = M.MPFR - -instance Binary M.MPFR - where - get = error "Data.Number.Dyadic: Binary not implemented yet" - put = error "Data.Number.Dyadic: Binary not implemented yet" - - -instance B.ERRealBase M.MPFR - where - typeName _ = "MPFR float" - defaultGranularity _ = 30 - getApproxBinaryLog d - | d < 0 = - error $ "ER.Real.Base.MPFR: getApproxBinaryLog: negative argument " ++ show d - | d == 0 = EI.MinusInfinity - | d >= 1 = - fromInteger $ intLogUp 2 $ ceiling d - | d < 1 = - negate $ fromInteger $ intLogUp 2 $ ceiling $ recip d - getGranularity = mPrec2gran . M.getPrec - setMinGranularity g x - | g > xGran = B.setGranularity g x - | otherwise = x - where - xGran = B.getGranularity x - setGranularity g = M.set M.Up (gran2mPrec g) - getMaxRounding _ = - error "ER.Real.Base.MPFR: getMaxRounding undefined" - isERNaN = M.isNaN - erNaN = 0/0 - isPlusInfinity x = M.isInfinite x && x > 0 - plusInfinity = 1/0 - fromIntegerUp = fromInteger - fromDouble = M.fromDouble M.Up 53 - toDouble = M.toDouble M.Up - fromFloat = B.fromDouble . fromRational . toRational - toFloat = fromRational . toRational . B.toDouble - showDiGrCmp numDigits _showGran _showComponents f = - M.toStringExp (int2word numDigits) f -#endif - -mPrec2gran = fromInteger . toInteger -gran2mPrec = fromInteger . toInteger -int2word = fromInteger . toInteger diff --git a/src/Data/Number/ER/Real/Base/MachineDouble.hs b/src/Data/Number/ER/Real/Base/MachineDouble.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Base/MachineDouble.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# INCLUDE #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-| - Module : Data.Number.ER.Real.Base.MachineDouble - Description : enabling Double's as interval endpoints - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : non-portable (requires fenv.h) - - Make 'Double' an instance of 'B.ERRealBase' as much as possible. --} -module Data.Number.ER.Real.Base.MachineDouble -( - initMachineDouble -) -where - -import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI -import Data.Number.ER.Misc - -import Foreign.C - -{- - The following section is taken from Oleg Kiselyov's email - http://www.haskell.org/pipermail/haskell/2005-October/016574.html --} - -type FP_RND_T = CInt -- fenv.h - -eFE_TONEAREST = 0 -eFE_DOWNWARD = 0x400 -eFE_UPWARD = 0x800 -eFE_TOWARDZERO = 0xc00 - -foreign import ccall "fenv.h fegetround" fegetround - :: IO FP_RND_T - -foreign import ccall "fenv.h fesetround" fesetround - :: FP_RND_T -> IO FP_RND_T -{- end of Oleg's code -} - -{-| - Set machine floating point unit to the upwards-directed rounding - mode. - - This procedure has to be executed before using 'Double' - as a basis for interval and polynomial arithmetic defined in this package. --} -initMachineDouble :: IO () -initMachineDouble = - do - currentRndMode <- fegetround - case currentRndMode == eFE_UPWARD of - True -> - putStrLn "already rounding upwards" - False -> - do - fesetround eFE_UPWARD - putStrLn "switching to upwards rounding" - -instance B.ERRealBase Double - where - typeName _ = "double" - initialiseBaseArithmetic x = - do - putStr $ "Base arithmetic:" ++ B.typeName x ++ "; " - initMachineDouble - defaultGranularity _ = 53 - getApproxBinaryLog d - | d < 0 = - error $ "ER.Real.Base.MachineDouble: getApproxBinaryLog: negative argument " ++ show d - | d == 0 = EI.MinusInfinity - | d >= 1 = - fromInteger $ intLogUp 2 $ ceiling d - | d < 1 = - negate $ fromInteger $ intLogUp 2 $ ceiling $ recip d - | otherwise = - error $ "ER.Real.Base.MachineDouble: getApproxBinaryLog: illegal argument " ++ show d - getGranularity _ = 53 - setMinGranularity _ = id - setGranularity _ = id - getMaxRounding _ = 0 - isERNaN f = isNaN f - erNaN = 0/0 - isPlusInfinity f = isInfinite f && f > 0 - plusInfinity = 1/0 - fromIntegerUp i - | i <= floor nearest = nearest - | otherwise = nearestIncreased - where - nearestCeil = ceiling nearest - nearest = fromInteger i - nearestIncreased = encodeFloat (s+1) e - (s,e) = decodeFloat nearest - fromDouble = fromRational . toRational - toDouble = fromRational . toRational - fromFloat = fromRational . toRational - toFloat = fromRational . toRational - showDiGrCmp _numDigits _showGran _showComponents f = show f - - diff --git a/src/Data/Number/ER/Real/Base/Rational.hs b/src/Data/Number/ER/Real/Base/Rational.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Base/Rational.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-| - Module : Data.Number.ER.Real.Base.Rational - Description : rational numbers with infinities - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Unlimited size rational numbers extended with signed infinities and NaN. - - These can serve as endpoints of 'Data.Number.ER.Real.Approx.Interval.ERInterval'. - - To be imported qualified, usually with prefix ERAT. --} -module Data.Number.ER.Real.Base.Rational -( - ExtendedRational(..) -) -where - -import Prelude hiding (isNaN) - -import qualified Data.Number.ER.Real.Base as B -import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI -import Data.Number.ER.BasicTypes.PlusMinus -import Data.Number.ER.Misc - -import Data.Ratio -import Data.Typeable -import Data.Generics.Basics - -import Data.Binary - -data ExtendedRational = - NaN - | Infinity PlusMinus - | Finite Rational - deriving (Typeable, Data) - -{- the following has been generated by BinaryDerive -} -instance Binary ExtendedRational where - put NaN = putWord8 0 - put (Infinity a) = putWord8 1 >> put a - put (Finite a) = putWord8 2 >> put a - get = do - tag_ <- getWord8 - case tag_ of - 0 -> return NaN - 1 -> get >>= \a -> return (Infinity a) - 2 -> get >>= \a -> return (Finite a) - _ -> fail "no parse" -{- the above has been generated by BinaryDerive -} - -eratSign :: ExtendedRational -> PlusMinus -eratSign NaN = error "ExtendedRational: eratSign: NaN" -eratSign (Infinity s) = s -eratSign (Finite r) - | r < 0 = Minus - | otherwise = Plus - -liftToERational1 :: - (Rational -> Rational) -> - (ExtendedRational -> ExtendedRational) -liftToERational1 f (Finite r) = - Finite (f r) - -liftToERational2 :: - (Rational -> Rational -> Rational) -> - (ExtendedRational -> ExtendedRational -> ExtendedRational) -liftToERational2 f (Finite r1) (Finite r2) = - Finite (f r1 r2) - - -instance Show ExtendedRational - where - show = showERational 6 True False - -showERational numDigits _showGran showComponents = - showER - where - showER NaN = "NaN" - showER (Infinity pm) = - show pm ++ "oo" - showER (Finite r) | r == 0 = - "0" - showER (Finite r) = - decimal - ++ (if showComponents then components else "") - where - components = "{" ++ show r ++ "}" - decimal = - show pm - ++ show digit1 ++ "." ++ (concat $ map show $ take numDigits digits) - ++ "E" ++ show dexp - pm | r < 0 = Minus - | otherwise = Plus - dexp = dexpBound - zerosCount - digit1 : digits = - drop zerosCount preDigits - dexpBound = -- upper bound of dexp: f/10^dexpBound < 1 - 2 + (intLogUp 10 num) - (intLogUp 10 dnm) - num = numerator absr - dnm = denominator absr - absr = abs r - (zerosCount, preDigits) = - getDigits 0 $ absr / (10 ^^ dexpBound) - getDigits prevZeros rr - | digit == 0 = (zerosCount, digit : digits) - | otherwise = (prevZeros, digit : digits) - where - digit :: Integer - digit = truncate rr - (zerosCount, digits) = - getDigits zerosNow ((rr - (fromInteger digit)) * 10) - zerosNow - | digit == 0 = prevZeros + 1 - | otherwise = 0 - -instance Eq ExtendedRational where - NaN == _ = - False - -- error "cannot compare NaN" - _ == NaN = - False - -- error "cannot compare NaN" - (Infinity pm1) == (Infinity pm2) = (pm1 == pm2) - (Finite r1) == (Finite r2) = r1 == r2 - _ == _ = False - -isNaN NaN = True -isNaN _ = False - -instance Ord ExtendedRational where - {- compare NaN -} - compare _ NaN = - error "comparing NaN - aborting" - compare NaN _ = - error "comparing NaN - aborting" - {- compare infty -} - compare (Infinity pm1) (Infinity pm2) = - compare pm1 pm2 - compare _ (Infinity Plus) = LT - compare _ (Infinity Minus) = GT - compare (Infinity Plus) _ = GT - compare (Infinity Minus) _ = LT - {- compare regular -} - compare (Finite r1) (Finite r2) = compare r1 r2 - -instance Num ExtendedRational where - fromInteger n = Finite (fromInteger n) - abs NaN = NaN - abs (Infinity _) = Infinity Plus - abs r = liftToERational1 abs r - signum NaN = NaN - signum (Infinity Plus) = 1 - signum (Infinity Minus) = -1 - signum r = liftToERational1 signum r - negate NaN = NaN - negate (Infinity s) = Infinity (signNeg s) - negate (Finite r) = Finite (negate r) - {- addition -} - -- NaN - NaN + _ = NaN - _ + NaN = NaN - -- Infty - (Infinity Plus) + (Infinity Minus) = NaN - (Infinity Minus) + (Infinity Plus) = NaN - (Infinity s) + _ = Infinity s - _ + (Infinity s) = Infinity s - -- regular - r1 + r2 = liftToERational2 (+) r1 r2 - {- multiplication -} - -- NaN - NaN * _ = NaN - _ * NaN = NaN - -- Infty - (Infinity _) * (Finite r) | r == 0 = NaN - (Finite r) * (Infinity _) | r == 0 = NaN - r * (Infinity s) = Infinity $ signMult s (eratSign r) - (Infinity s) * r = Infinity $ signMult s (eratSign r) - -- regular - r1 * r2 = liftToERational2 (*) r1 r2 - -instance Fractional ExtendedRational where - fromRational rat = Finite rat - recip NaN = NaN - recip (Infinity s) = 0 - recip (Finite r) - | r == 0 = Infinity Plus - | otherwise = (Finite $ recip r) - -instance Real ExtendedRational where - toRational (Finite r) = r - toRational r = error $ "cannot convert " ++ show r ++ " to Rational" - -instance RealFrac ExtendedRational where - properFraction (Finite r) = - (a, Finite b) - where - (a,b) = properFraction r - properFraction r = - error $ "ExtendedRational: RealFrac: no integral part in " ++ show r - -instance B.ERRealBase ExtendedRational - where - typeName _ = "extended rationals" - defaultGranularity _ = 10 - getApproxBinaryLog (Finite r) - | r == 0 = - EI.MinusInfinity - | otherwise = - (intLogUp 2 (abs $ numerator $ r)) - - - (intLogUp 2 (abs $ denominator $ r)) - getApproxBinaryLog (Infinity _) = EI.PlusInfinity - getApproxBinaryLog (NaN) = error "RationalBase: getApproxBinaryLog: NaN" - getGranularity _ = 0 - setMinGranularity _ = id - setGranularity _ = id - getMaxRounding _ = 0 - isERNaN = isNaN - erNaN = NaN - isPlusInfinity (Infinity Plus) = True - isPlusInfinity _ = False - plusInfinity = Infinity Plus - fromIntegerUp = fromInteger - fromDouble = fromRational . toRational - toDouble (Infinity Plus) = 1/0 - toDouble (Infinity Minus) = -1/0 - toDouble (NaN) = 0/0 - toDouble (Finite r) = fromRational r - fromFloat = fromRational . toRational - toFloat (Infinity Plus) = 1/0 - toFloat (Infinity Minus) = -1/0 - toFloat (NaN) = 0/0 - toFloat (Finite r) = fromRational r - showDiGrCmp = showERational - - - - diff --git a/src/Data/Number/ER/Real/Base/Tests/Generate.hs b/src/Data/Number/ER/Real/Base/Tests/Generate.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/Base/Tests/Generate.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-| - Module : Data.Number.ER.Real.Base.Tests.Generate - Description : (testing) generating base real numbers - Copyright : (c) 2009 Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - Generic instances of 'Arbitrary' class for generating (almost) random instances - according to different distributions. --} -module Data.Number.ER.Real.Base.Tests.Generate where - -import qualified Data.Number.ER.Real.Base as B -import Data.Number.ER.BasicTypes - -import Test.QuickCheck - -newtype BGran20 b = BGran20 b deriving Show -newtype BGran100 b = BGran100 b deriving Show -newtype BGran1000 b = BGran1000 b deriving Show - -instance (B.ERRealBase b) => Arbitrary (BGran20 b) - where - arbitrary = - do - gran <- choose (8,20) - (f1,f2,f3) <- arbitrary - pow <- choose (-10,10) - return $ BGran20 $ constructB gran (f1,f2,f3) pow - coarbitrary _ = - error "ER.Real.Base: Tests: coarbitrary not implemented" - -constructB :: - (B.ERRealBase b) => - Granularity -> - (Double, Double, Double) -> - Int -> - b -constructB gran (f1,f2,f3) pow = - (b1/b2) ^^ pow + b3 - where - [b1,b2,b3] = map cvt [f1,f2,f3] - cvt f = B.setGranularity gran $ B.fromDouble f - -instance (B.ERRealBase b) => Arbitrary (BGran100 b) - where - arbitrary = - sized arbitrarySized - where - arbitrarySized n - | n <= 28 = - do - (BGran20 b) <- arbitrary - return (BGran100 b) - | otherwise = - do - gran <- choose (30,100) - (f1,f2,f3) <- arbitrary - pow <- choose (-100,100) - return $ BGran100 $ constructB gran (f1,f2,f3) pow - coarbitrary _ = - error "ER.Real.Base: Tests: coarbitrary not implemented" - -instance (B.ERRealBase b) => Arbitrary (BGran1000 b) - where - arbitrary = - sized arbitrarySized - where - arbitrarySized n - | n <= 28 = - do - (BGran20 b) <- arbitrary - return (BGran1000 b) - | n <= 68 = - do - (BGran100 b) <- arbitrary - return (BGran1000 b) - | otherwise = - do - gran <- choose (400,1000) - (f1,f2,f3) <- arbitrary - pow <- choose (-10000,10000) - return $ BGran1000 $ constructB gran (f1,f2,f3) pow - coarbitrary _ = - error "ER.Real.Base: Tests: coarbitrary not implemented" - - diff --git a/src/Data/Number/ER/Real/DefaultRepr.hs b/src/Data/Number/ER/Real/DefaultRepr.hs deleted file mode 100644 --- a/src/Data/Number/ER/Real/DefaultRepr.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE CPP #-} --- #define USE_MPFR -{-| - Module : Data.Number.ER.Real.DefaultRepr - Description : concise names for default real representations - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : non-portable (requires fenv.h) - - This module supplies default instances for the real number classes - defined in "Data.Number.ER.Real.Approx". - - These classes express loosely coupled abstraction layers. - To preserve the intended loose coupling, - please use these definitions only in functions that do not import or export - any real numbers or real functions. --} -module Data.Number.ER.Real.DefaultRepr -( - B, BM, BAP, BMAP, BR, -#ifdef USE_MPFR - BMPFR, -#endif - RA, IRA -) -where - ---import - -import Data.Number.ER.Real.Base.Float -import Data.Number.ER.Real.Base.Rational - -import Data.Number.ER.Real.Approx.Interval - ---import Data.Number.ER.Real.Base.BigFloatBase -import Data.Number.ER.Real.Base.MachineDouble -import Data.Number.ER.Real.Base.CombinedMachineAP - -import Data.Number.ER.Real.Base.MPFR - -type BAP = ERFloat - -{-| - Limited granularity, but sometimes up to 100x faster - than ERFloat! - - !!! to be safe, one has to run 'initMachineDouble' --} -type BM = Double - -#ifdef USE_MPFR -type BMPFR = MPFR -#endif - -{-| - Use machine 'Double' while the granularity is up to its significant bit length - and when the granularity grows beyond that, use 'ERFloat'. - - !!! to be safe, one has to run 'initMachineDouble' --} -type BMAP = ERMachineAP BAP - ---type BBF = BigFloat Prec50 -- seems incomplete on 25/Jun/2008 - -{-| very inefficient -} -type BR = ExtendedRational - -{-| - the default base type --} - -#ifdef USE_MPFR -type B = BMPFR ---type B = BMAP ---type B = BAP ---type B = BM ---type B = BR -#else -type B = BMAP ---type B = BAP ---type B = BM ---type B = BR -#endif - -{-| - the default instance of 'Data.Number.ER.Real.Approx.ERApprox' --} -type RA b = ERInterval b - -{-| - the default instance of 'Data.Number.ER.Real.Approx.ERIntApprox' --} -type IRA b = ERInterval b - diff --git a/src/Data/Number/ER/ShowHTML.hs b/src/Data/Number/ER/ShowHTML.hs deleted file mode 100644 --- a/src/Data/Number/ER/ShowHTML.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| - Module : Data.Number.ER.ShowHTML - Description : Misc facilities for HTML rendering. - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - --} -module Data.Number.ER.ShowHTML where - -import qualified Text.Html as H -import Text.Regex - -{-| - Render HTML is a way that can be inlined in - Javascript strings etc. --} -showHTML :: - (H.HTML t) => - t -> String -showHTML v = - escapeNewLines $ - renderHtmlNoHeader $ - H.toHtml v - where --- stripHeader s = --- (splitRegex (mkRegex "-->") s) !! 1 - escapeNewLines s = - (subRegex (mkRegex "([^\\])$") s "\\1\\\\") - -abovesTable attrs cells = - H.table H.! attrs H.<< (H.aboves $ map (H.td H.<<) cells) -besidesTable attrs cells = - H.table H.! attrs H.<< (H.aboves [H.besides $ map (H.td H.<<) cells]) - -renderHtmlNoHeader :: H.Html -> String -renderHtmlNoHeader theHtml = - foldr (.) id (map (H.renderHtml' 0) - (H.getHtmlElements theHtml)) "\n" - -toHtmlDefault :: (Show a) => a -> H.Html -toHtmlDefault = H.toHtml . show - -instance (H.HTML a) => H.HTML (Maybe a) where - toHtml Nothing = H.toHtml $ "[Nothing]" - toHtml (Just a) = H.toHtml a - diff --git a/src/Numeric/AERN/Misc/IntegerArithmetic.hs b/src/Numeric/AERN/Misc/IntegerArithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Misc/IntegerArithmetic.hs @@ -0,0 +1,52 @@ +{-| + Module : Numeric.AERN.Misc.IntegerArithmetic + Description : miscellaneous integer arithmetic functions + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Miscellaneous integer arithmetic functions. +-} + +module Numeric.AERN.Misc.IntegerArithmetic where + +intLogDown b n = fst $ intLog b n +intLogUp b n = snd $ intLog b n + +intLog :: + (Num n1, Num n2, Ord n1, Integral n2) => + n1 {-^ base -} -> + n1 {-^ x -} -> + (n2, n2) +intLog b n + | n == 1 = (0,0) + | n > 1 && n < b = (0,1) + | n >= b = + bisect (lgDn, pwDn) (lgUp, pwUp) + | otherwise = + error $ "Numeric.ER.Misc: intLog: illegal argument n = " ++ show n + where + ((lgDn, pwDn), (lgUp, pwUp)) = + findBounds (1, b) + -- lgDn <= log_b n < lgUp; pwDn = b^lgDn; pwUp = b^lgUp + findBounds (lg, pw) + | n < pwNext = ((lg, pw), (lgNext, pwNext)) + | otherwise = findBounds (lgNext, pwNext) + where + lgNext = 2 * lg + pwNext = pw * pw + bisect (lgDn, pwDn) (lgUp, pwUp) + | pwDn == n = (lgDn, lgDn) + | pwUp == n = (lgUp, lgUp) + | lgDn == lgMid = (lgDn, lgUp) + | lgUp == lgMid = (lgDn, lgUp) + | n < pwMid = + bisect (lgDn, pwDn) (lgMid, pwMid) + | otherwise = + bisect (lgMid, pwMid) (lgUp, pwUp) + where + lgMid = (lgDn + lgUp) `div` 2 + pwMid = pwDn * (b ^ (lgMid - lgDn)) diff --git a/src/Numeric/AERN/RealArithmetic/Auxiliary.hs b/src/Numeric/AERN/RealArithmetic/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/Auxiliary.hs @@ -0,0 +1,81 @@ +{-| + Module : Numeric.AERN.RealArithmetic.Auxiliary + Description : auxiliary generic operators and utilities + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Auxiliary generic operators and utilities. + + This is a hidden internal module. +-} + +module Numeric.AERN.RealArithmetic.Auxiliary where + +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.Basics.Exception +import Numeric.AERN.Basics.Mutable + +import Control.Exception +import Control.Monad.ST + + +powerFromMult :: + (HasOne t) => + (t -> t -> t) {-^ associative binary operation @*@ -} -> + t {-^ @x@ -} -> + Int {-^ @n@ positive -} -> + t {-^ product @x * x * ... * x@ of @n@ copies of @x@ -} +powerFromMult mult x n + | n < 0 = throw $ AERNException "powerFromMult does not support negative exponents" + | otherwise = p n + where + p n + | n == 0 = one + | n == 1 = x + | otherwise = + case even n of + True -> + powHalf `mult` powHalf + False -> + x `mult` (powHalf `mult` powHalf) + where + powHalf = p (n `div` 2) + +powerFromMultInPlace :: + (HasOne t, CanBeMutable t) => + (Mutable t s -> Mutable t s -> Mutable t s -> ST s ()) {-^ associative binary operation @*@ -} -> + (Mutable t s) {-^ where to put the resulting power @x^n@ -} -> + (Mutable t s) {-^ @x@ -} -> + Int {-^ @n@ positive -} -> + ST s () +powerFromMultInPlace mult rM xM n + -- beware rM and xM may alias! + | n < 0 = throw $ AERNException "powerFromMultInPlace does not support negative exponents" + | otherwise = + do + nrM <- cloneMutable xM -- a non-aliased variable for interim results + p nrM n -- nrM := x^n + assignMutable rM nrM -- rM := nr + where + p nrM n -- ensures nrM holds x^n + | n == 0 = writeMutable nrM one + | n == 1 = return () -- assuming nrM already contains x + | otherwise = + case even n of + True -> + do + powHalf -- rM now holds x^(n/2) + mult nrM nrM nrM -- square rM + False -> + do + powHalf -- rM now holds x^(n-1/2) + mult nrM nrM nrM -- square rM + mult nrM nrM xM -- multiply by x one more time + where + rM = () -- avoid accidental use of rM from parent context + powHalf = p nrM (n `div` 2) + diff --git a/src/Numeric/AERN/RealArithmetic/Bench.hs b/src/Numeric/AERN/RealArithmetic/Bench.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/Bench.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Numeric.AERN.RealArithmetic.Bench + Description : benchmarking utilities + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Benchmarking utilities. +-} + +module Numeric.AERN.RealArithmetic.Bench where + +import Numeric.AERN.Basics.Consistency +import Numeric.AERN.Basics.NumericOrder.OpsDefaultEffort + +import qualified Numeric.AERN.RealArithmetic.NumericOrderRounding as ArithUpDn + +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.Measures + +import Numeric.AERN.Misc.Debug + +{-| Approximate the imprecision of an operation by measuring + the distance between its outer rounded result and inner rounded result +-} +mkCommentImprecision1 :: + (HasDistance t, + ArithUpDn.Convertible (Distance t) Double, + Show (Distance t)) => + (ei -> t -> t) -> + (ei -> t -> t) -> + ei -> t -> String +mkCommentImprecision1 opOut opIn effort a = + show $ imprecisionD + where + imprecisionD :: Double + imprecisionD = + case ArithUpDn.convertUpEff (ArithUpDn.convertDefaultEffort imprecision sampleD) imprecision of + Just imprecisionUp -> imprecisionUp + Nothing -> error $ "mkCommentImprecision: cannot convert up to a Double: " ++ show imprecision + sampleD = 0 :: Double + imprecision = distanceBetweenEff (distanceDefaultEffort resultOut) resultOut resultIn + resultOut = opOut effort a + resultIn = opIn effort a + +mkCommentAreaImprecision op effort a = + unsafePrint + ( + "mkCommentImprecision: " + ++ "\n a = " ++ show a + ++ "\n effort = " ++ show effort + ++ "\n aE = " ++ show aE + ++ "\n aD = " ++ show aD + ++ "\n aExp = " ++ show aExp + ++ "\n resultE = " ++ show resultE + ++ "\n imprecisionE = " ++ show imprecisionE + ++ "\n imprecisionD = " ++ show imprecisionD + ++ "\n imprecisionExp = " ++ show imprecisionExp + ++ "\n resultBinaryDigits = " ++ show resultBinaryDigits + ) $ + signOfaE ++ "x" ++ show aExp ++ "rd" ++ show resultBinaryDigits + where + signOfaE = + case (aE >? zero, aE "+" + (_, Just True) -> "-" + _ -> "" + aE = getThinRepresentative a + Just aD = + ArithUpDn.convertUpEff (ArithUpDn.convertDefaultEffort a sampleD) aE + aExp = exponent aD + + resultE = op effort aE + Just resultD = + ArithUpDn.convertUpEff (ArithUpDn.convertDefaultEffort a sampleD) resultE + resultExp = exponent resultD + + imprecisionE = + imprecisionOfEff (imprecisionDefaultEffort a) resultE + Just imprecisionD = + ArithUpDn.convertUpEff (ArithUpDn.convertDefaultEffort imprecisionE sampleD) imprecisionE + imprecisionExp = exponent imprecisionD + + resultBinaryDigits = resultExp - imprecisionExp + + imprecisionD, aD, resultD, sampleD :: Double + sampleD = 0 diff --git a/src/Numeric/AERN/RealArithmetic/ExactOps.hs b/src/Numeric/AERN/RealArithmetic/ExactOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/ExactOps.hs @@ -0,0 +1,107 @@ +{-| + Module : Numeric.AERN.RealArithmetic.ExactOps + Description : access to exact zero and one + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Access to exact zero and one. +-} +module Numeric.AERN.RealArithmetic.ExactOps where + +import Prelude hiding (EQ, LT, GT) +import Numeric.AERN.Basics.PartialOrdering + +import Control.Monad.ST +import Data.STRef + +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd + +import Numeric.AERN.Basics.Mutable + +import Data.Ratio + +class HasZero t where + zero :: t + +pNonnegNonposEff effort a = + (nonneg, nonpos) + where + (_, nonneg, _, nonpos) = + pPosNonnegNegNonposEff effort a + +pPosNonnegNegNonposEff effort a = + case NumOrd.pCompareEff effort a zero of + Just EQ -> (Just False, Just True, Just False, Just True) + Just LT -> (Just False, Just False, Just True, Just True) + Just GT -> (Just True, Just True, Just False, Just False) + Just LEE -> (Just False, Nothing, Nothing, Just True) + Just GEE -> (Nothing, Just True, Just False, Nothing) + _ -> (Nothing, Nothing, Nothing, Nothing) + +class HasOne t where + one :: t + +class HasInfinities t where + plusInfinity :: t + minusInfinity :: t + excludesPlusInfinity :: t -> Bool + excludesMinusInfinity :: t -> Bool + excludesInfinity :: t -> Bool + excludesInfinity a = + excludesMinusInfinity a && excludesPlusInfinity a + +class Neg t where + neg :: t -> t + +class (Neg t, CanBeMutable t) => NegInPlace t where + negInPlace :: OpMutable1 t s + negInPlace = + pureToMutable1 neg +-- +-- -- default such as this one is very inefficient +-- -- but facilitates an API that works even for +-- -- types that do not have native in-place updates +-- do +-- a <- readMutable aM +-- let _ = [a,sample] +-- writeMutable rM (neg a) + +propNegFlip :: + (Eq t, Neg t) => + t -> t -> Bool +propNegFlip _ e = + neg (neg e) == e + +-- instances for some common types: + +instance HasZero Int where zero = 0 +instance HasOne Int where one = 1 +instance Neg Int where neg = negate + +instance HasZero Integer where zero = 0 +instance HasOne Integer where one = 1 +instance Neg Integer where neg = negate + +instance (HasZero t, HasOne t, Integral t) => + HasZero (Ratio t) + where zero = zero % one +instance (HasOne t, Integral t) => + HasOne (Ratio t) + where one = one % one +instance (Integral t) => Neg (Ratio t) where neg = negate + +instance HasZero Double where zero = 0 +instance HasOne Double where one = 1 +instance Neg Double where neg = negate + +instance HasInfinities Double where + plusInfinity = 1/0 + minusInfinity = -1/0 + excludesPlusInfinity a = (a /= plusInfinity) + excludesMinusInfinity a = (a /= minusInfinity) + + diff --git a/src/Numeric/AERN/RealArithmetic/Laws.hs b/src/Numeric/AERN/RealArithmetic/Laws.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/Laws.hs @@ -0,0 +1,585 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams, RankNTypes #-} +{-| + Module : Numeric.AERN.Basics.Laws.Relation + Description : common properties of arithmetic operations arbitrarily-little rounded + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Common properties of arithmetic operations when these operations + are rounded but the rounding can be diminished arbitrarily + by increasing an effort indicator. +-} + +module Numeric.AERN.RealArithmetic.Laws where + +import Numeric.AERN.RealArithmetic.Measures + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Consistency +import Numeric.AERN.Basics.Laws.Utilities +import Numeric.AERN.Basics.Mutable + +import Numeric.AERN.Misc.Bool +import Numeric.AERN.Misc.Debug +import Numeric.AERN.Misc.List +import Numeric.AERN.Misc.Maybe +import Data.Maybe + +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd + +import Numeric.AERN.Basics.Exception +import Control.Exception + +roundedRefinementMonotone1 :: + (RefOrd.PartialComparison t, + RefOrd.ArbitraryOrderedTuple t, + Show t, HasLegalValues t) => + String -> + (Expr1Eff ei t) -> + (Expr1Eff ei t) -> + ei -> (RefOrd.LEPair t) -> + (RefOrd.PartialCompareEffortIndicator t) -> + Bool +roundedRefinementMonotone1 contextDescription exprUp exprDn effort (RefOrd.LEPair (e1L, e1H)) effortComp = + case RefOrd.pLeqEff effortComp resDn resUp of + Just b -> b + _ -> True + where + resUp = check $ exprUp effort e1H + resDn = check $ exprDn effort e1L + check = detectIllegalValues $ contextDescription ++ " monotone" + +roundedRefinementMonotone2 :: + (RefOrd.PartialComparison t, + RefOrd.ArbitraryOrderedTuple t, + Show t, HasLegalValues t) => + String -> + (Expr2Eff ei t) -> + (Expr2Eff ei t) -> + ei -> (RefOrd.LEPair t) -> (RefOrd.LEPair t) -> + (RefOrd.PartialCompareEffortIndicator t) -> + Bool +roundedRefinementMonotone2 + contextDescription exprUp exprDn effort + (RefOrd.LEPair (e1L, e1H)) (RefOrd.LEPair (e2L, e2H)) effortComp = +-- unsafePrint ("\nroundedRefinementMonotone2: " +-- ++ "\n Up: op(" ++ show e1H ++ ", " ++ show e2H ++ ") = " ++ show resUp +-- ++ "\n Dn: op(" ++ show e1L ++ ", " ++ show e2L ++ ") = " ++ show resDn +-- ++ "\n" +-- ) $ + case RefOrd.pLeqEff effortComp resDn resUp of + Just b -> b + _ -> True + where + resUp = check $ exprUp effort e1H e2H + resDn = check $ exprDn effort e1L e2L + check = detectIllegalValues $ contextDescription ++ " monotone" + +roundedUnit :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + t -> + (PRelEff eiRel t) -> + (OpEff eiOp t) -> (OpEff eiOp t) -> + (eiRel, eiOp) -> + t -> Bool +roundedUnit unit = + equalRoundingUpDnBin1Var1 "roundedUnit" (\_ _ e -> e) expr2 + where + expr2 opEff effort e = + unit * e + where + (*) = opEff effort + +roundedReflexiveCollapse :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + t -> + (PRelEff eiRel t) -> + (OpEff eiOp t) -> (OpEff eiOp t) -> + (eiRel, eiOp) -> + t -> Bool +roundedReflexiveCollapse unit = + equalRoundingUpDnBin1Var1 "roundedReflexiveCollapse" (\_ _ e -> unit) expr2 + where + expr2 opEff effort e = + e * e + where + (*) = opEff effort + +roundedCommutative :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + (PRelEff eiRel t) -> + (OpEff eiOp t) -> (OpEff eiOp t) -> + (eiRel, eiOp) -> + t -> t -> Bool +roundedCommutative = + equalRoundingUpDnBin1Var2 "roundedCommutative" expr1 expr2 + where + expr1 opEff effort e1 e2 = + e1 * e2 + where + (*) = opEff effort + expr2 opEff effort e1 e2 = + e2 * e1 + where + (*) = opEff effort + +roundedAssociative :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + (PRelEff eiRel t) -> + (OpEff eiOp t) -> (OpEff eiOp t) -> + (eiRel, eiOp) -> + t -> t -> t -> Bool +roundedAssociative = + equalRoundingUpDnBin1Var3 "roundedAssociative" expr1 expr2 + where + expr1 opEff effort e1 e2 e3 = + (e1 * e2) * e3 + where + (*) = opEff effort + expr2 opEff effort e1 e2 e3 = + e1 * (e2 * e3) + where + (*) = opEff effort + +roundedDistributive :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp1, Show eiOp1, + EffortIndicator eiOp2, Show eiOp2, + HasAntiConsistency t, Show t, HasLegalValues t) => + (PRelEff eiRel t) -> + (OpEff eiOp1 t) -> (OpEff eiOp2 t) -> + (OpEff eiOp1 t) -> (OpEff eiOp2 t) -> + (ConsistencyEffortIndicator t) -> + (eiRel, (eiOp1, eiOp2)) -> + t -> t -> t -> Bool +roundedDistributive + pCompareEff + op1UpEff op2UpEff + op1DnEff op2DnEff + effortConsistency + initEffort + e1 e2 e3 = +-- unsafePrint +-- ( +-- "property roundedDistributive: " +-- ++ "\n e1 = " ++ show e1 +-- ++ "\n e2 = " ++ show e2 +-- ++ "\n e3 = " ++ show e3 +-- ) $ + thinEqualConsLeqRoundingUpDnImprovement "roundedDistributive" + -- cannot get equality when e1 is not thin + -- because e1 appears twice in expr1 (dependency error) + [e1] expr1Up expr1Dn expr2Up expr2Dn + pCompareEff + effortConsistency + initEffort + where + expr1Up eff = expr1 op1UpEff op2UpEff eff e1 e2 e3 + expr1Dn eff = expr1 op1DnEff op2DnEff eff e1 e2 e3 + expr2Up eff = expr2 op1UpEff op2UpEff eff e1 e2 e3 + expr2Dn eff = expr2 op1DnEff op2DnEff eff e1 e2 e3 + expr1 op1Eff op2Eff (effort1, effort2) e1 e2 e3 = + (e1 * e2) + (e1 * e3) + where + (*) = op1Eff effort1 + (+) = op2Eff effort2 + expr2 op1Eff op2Eff (effort1, effort2) e1 e2 e3 = + e1 * (e2 + e3) + where + (*) = op1Eff effort1 + (+) = op2Eff effort2 + + +roundedNegSymmetric :: + (Neg t, + EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + (PRelEff eiRel t) -> + (UnaryOpEff eiOp t) -> (UnaryOpEff eiOp t) -> + (eiRel, eiOp) -> + t -> Bool +roundedNegSymmetric = + equalRoundingUpDnUnary1Var1 "roundedNegSymmetric" expr1 expr2 + where + expr1 opEff effort e = + opEff effort e + expr2 opEff effort e = + opEff effort (neg e) + +roundedIdempotent :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + (PRelEff eiRel t) -> + (UnaryOpEff eiOp t) -> (UnaryOpEff eiOp t) -> + (eiRel, eiOp) -> + t -> Bool +roundedIdempotent = + equalRoundingUpDnUnary1Var1 "roundedIdempotent" expr1 expr2 + where + expr1 opEff effort e = + opEff effort e + expr2 opEff effort e = + opEff effort (opEff effort e) + + +equalRoundingUpDnUnary1Var1 :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + String -> + (Expr1UnaryOp1Eff eiOp t) -> + (Expr1UnaryOp1Eff eiOp t) -> + (PRelEff eiRel t) -> + (UnaryOpEff eiOp t) -> (UnaryOpEff eiOp t) -> + (eiRel, eiOp) -> + t -> Bool +equalRoundingUpDnUnary1Var1 contextDescription expr1 expr2 pCompareEff opUpEff opDnEff + initEffort e = + equalRoundingUpDn contextDescription expr1Up expr1Dn expr2Up expr2Dn pCompareEff initEffort + where + expr1Up eff = expr1 opUpEff eff e + expr1Dn eff = expr1 opDnEff eff e + expr2Up eff = expr2 opUpEff eff e + expr2Dn eff = expr2 opDnEff eff e + +equalRoundingUpDnBin1Var1 :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + String -> + (Expr1Op1Eff eiOp t) -> + (Expr1Op1Eff eiOp t) -> + (PRelEff eiRel t) -> + (OpEff eiOp t) -> (OpEff eiOp t) -> + (eiRel, eiOp) -> + t -> Bool +equalRoundingUpDnBin1Var1 + contextDescription expr1 expr2 pCompareEff + opUpEff opDnEff initEffort e = + equalRoundingUpDn + contextDescription expr1Up expr1Dn expr2Up expr2Dn pCompareEff initEffort + where + expr1Up eff = expr1 opUpEff eff e + expr1Dn eff = expr1 opDnEff eff e + expr2Up eff = expr2 opUpEff eff e + expr2Dn eff = expr2 opDnEff eff e + +equalRoundingUpDnBin1Var2 :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + String -> + (Expr1Op2Eff eiOp t) -> + (Expr1Op2Eff eiOp t) -> + (PRelEff eiRel t) -> + (OpEff eiOp t) -> (OpEff eiOp t) -> + (eiRel, eiOp) -> + t -> t -> Bool +equalRoundingUpDnBin1Var2 contextDescription expr1 expr2 pCompareEff opUpEff opDnEff + initEffort e1 e2 = + equalRoundingUpDn contextDescription expr1Up expr1Dn expr2Up expr2Dn pCompareEff initEffort + where + expr1Up eff = expr1 opUpEff eff e1 e2 + expr1Dn eff = expr1 opDnEff eff e1 e2 + expr2Up eff = expr2 opUpEff eff e1 e2 + expr2Dn eff = expr2 opDnEff eff e1 e2 + +equalRoundingUpDnBin1Var3 :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp, Show eiOp, + Show t, HasLegalValues t) => + String -> + (Expr1Op3Eff eiOp t) -> + (Expr1Op3Eff eiOp t) -> + (PRelEff eiRel t) -> + (OpEff eiOp t) -> (OpEff eiOp t) -> + (eiRel, eiOp) -> + t -> t -> t -> Bool +equalRoundingUpDnBin1Var3 contextDescription expr1 expr2 pCompareEff opUpEff opDnEff + initEffort e1 e2 e3 = + equalRoundingUpDn contextDescription expr1Up expr1Dn expr2Up expr2Dn pCompareEff initEffort + where + expr1Up eff = expr1 opUpEff eff e1 e2 e3 + expr1Dn eff = expr1 opDnEff eff e1 e2 e3 + expr2Up eff = expr2 opUpEff eff e1 e2 e3 + expr2Dn eff = expr2 opDnEff eff e1 e2 e3 + +equalRoundingUpDnBin2Var3 :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp1, Show eiOp1, + EffortIndicator eiOp2, Show eiOp2, + Show t, HasLegalValues t) => + String -> + (Expr2Op3Eff eiOp1 eiOp2 t) -> + (Expr2Op3Eff eiOp1 eiOp2 t) -> + (PRelEff eiRel t) -> + (OpEff eiOp1 t) -> (OpEff eiOp2 t) -> + (OpEff eiOp1 t) -> (OpEff eiOp2 t) -> + (eiRel, (eiOp1, eiOp2)) -> + t -> t -> t -> Bool +equalRoundingUpDnBin2Var3 contextDescription expr1 expr2 pCompareEff + op1UpEff op2UpEff + op1DnEff op2DnEff + initEffort e1 e2 e3 = + equalRoundingUpDn contextDescription expr1Up expr1Dn expr2Up expr2Dn pCompareEff initEffort + where + expr1Up eff = expr1 op1UpEff op2UpEff eff e1 e2 e3 + expr1Dn eff = expr1 op1DnEff op2DnEff eff e1 e2 e3 + expr2Up eff = expr2 op1UpEff op2UpEff eff e1 e2 e3 + expr2Dn eff = expr2 op1DnEff op2DnEff eff e1 e2 e3 + +thinEqualConsLeqRoundingUpDnImprovementBin2Var3 :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp1, Show eiOp1, + EffortIndicator eiOp2, Show eiOp2, + HasAntiConsistency t, Show t, HasLegalValues t) => + String -> + (Expr2Op3Eff eiOp1 eiOp2 t) -> + (Expr2Op3Eff eiOp1 eiOp2 t) -> + (PRelEff eiRel t) -> + (OpEff eiOp1 t) -> (OpEff eiOp2 t) -> + (OpEff eiOp1 t) -> (OpEff eiOp2 t) -> + (ConsistencyEffortIndicator t) -> + (eiRel, (eiOp1, eiOp2)) -> + t -> t -> t -> Bool +thinEqualConsLeqRoundingUpDnImprovementBin2Var3 + contextDescription + expr1 expr2 pCompareEff + op1UpEff op2UpEff + op1DnEff op2DnEff + effortConsistency + initEffort + e1 e2 e3 = + thinEqualConsLeqRoundingUpDnImprovement + contextDescription + [e1,e2,e3] expr1Up expr1Dn expr2Up expr2Dn + pCompareEff + effortConsistency + initEffort + where + expr1Up eff = expr1 op1UpEff op2UpEff eff e1 e2 e3 + expr1Dn eff = expr1 op1DnEff op2DnEff eff e1 e2 e3 + expr2Up eff = expr2 op1UpEff op2UpEff eff e1 e2 e3 + expr2Dn eff = expr2 op1DnEff op2DnEff eff e1 e2 e3 + + + +equalRoundingUpDnBin2Var2 :: + (EffortIndicator eiRel, Show eiRel, + EffortIndicator eiOp1, Show eiOp1, + EffortIndicator eiOp2, Show eiOp2, + Show t, HasLegalValues t) => + String -> + (Expr2Op2Eff eiOp1 eiOp2 t) -> + (Expr2Op2Eff eiOp1 eiOp2 t) -> + (PRelEff eiRel t) -> + (OpEff eiOp1 t) -> (OpEff eiOp2 t) -> + (OpEff eiOp1 t) -> (OpEff eiOp2 t) -> + (eiRel, (eiOp1, eiOp2)) -> + t -> t -> Bool +equalRoundingUpDnBin2Var2 contextDescription expr1 expr2 pCompareEff + op1UpEff op2UpEff + op1DnEff op2DnEff + initEffort e1 e2 = + equalRoundingUpDn contextDescription expr1Up expr1Dn expr2Up expr2Dn pCompareEff initEffort + where + expr1Up eff = expr1 op1UpEff op2UpEff eff e1 e2 + expr1Dn eff = expr1 op1DnEff op2DnEff eff e1 e2 + expr2Up eff = expr2 op1UpEff op2UpEff eff e1 e2 + expr2Dn eff = expr2 op1DnEff op2DnEff eff e1 e2 + +thinEqualConsLeqRoundingUpDnImprovement :: + (EffortIndicator eiRel, EffortIndicator eiOp, + Show eiOp, Show eiRel, + HasAntiConsistency t, Show t, HasLegalValues t) => + String -> + [t] -> + (eiOp -> t) {-^ left hand side expression UP -} -> + (eiOp -> t) {-^ left hand side expression DN -} -> + (eiOp -> t) {-^ right hand side expression UP -} -> + (eiOp -> t) {-^ right hand side expression DN -} -> + (PRelEff eiRel t) -> + (ConsistencyEffortIndicator t) -> + (eiRel, eiOp) -> Bool +thinEqualConsLeqRoundingUpDnImprovement + contextDescription + parameters + expr1Up expr1Dn expr2Up expr2Dn + pCompareEff + consistencyEffort + initEffort@(effComp, effOp) + | allConsistent && allAntiConsistent = + okIfThin + | allConsistent = + okIfConsistent + | allAntiConsistent = + okIfAntiConsistent + where + allConsistent = + and $ map isConsistent parameters + allAntiConsistent = + and $ map isAntiConsistent parameters + okIfThin = + (equalRoundingUpDn contextDescription + expr1Up expr1Dn expr2Up expr2Dn + pCompareEff initEffort) + okIfConsistent = + leqRoundingUpDn expr1Dn expr2Up + okIfAntiConsistent = + leqRoundingUpDn expr2Dn expr1Up + isConsistent a = + justButNot False $ isConsistentEff consistencyEffort a + isAntiConsistent a = + justButNot False $ isAntiConsistentEff consistencyEffort a + leqRoundingUpDn expr1Dn expr2Up = + case pCompareEff effComp (expr1Dn effOp) (expr2Up effOp) of + Just res -> res + Nothing -> True + + +equalRoundingUpDn :: + (EffortIndicator eiRel, EffortIndicator eiOp, + Show eiOp, Show eiRel, + Show t, HasLegalValues t) => + String -> + (eiOp -> t) {-^ left hand side expression UP -} -> + (eiOp -> t) {-^ left hand side expression DN -} -> + (eiOp -> t) {-^ right hand side expression UP -} -> + (eiOp -> t) {-^ right hand side expression DN -} -> + (PRelEff eiRel t) -> + (eiRel, eiOp) -> Bool +equalRoundingUpDn + contextDescription + expr1Up expr1Dn expr2Up expr2Dn + pCompareEff initEffort = +-- unsafePrint +-- ( +-- "equalRoundingUpDn:" +-- ++ "\n efforts executed = \n" ++ unlines (map show $ take (comparisonCount + 1) efforts) +-- ++ "\n 5 successes = \n" ++ unlines (map show relevantSuccesses) +-- ) +-- $ + case evalCatchDomViolationExceptions "checking a property" result of + Left e -> True + -- ignore tests during which a domain violation exception arises + Right res -> res + -- throw an exception if the result is an illegal values (eg NaN) + where + result = + (andUnsafeReportFirstFalse relevantSuccesses) + relevantSuccesses = take 5 successes + successes = map check efforts + efforts = + (initEffort : ) $ take 15 $ effortIncrementSequence initEffort + check (effortRel, effortOp) = + successWithMsg + where + successWithMsg = + (success, + "failure for effortRel = " ++ show effortRel + ++ " effortOp = " ++ show effortOp + ++ "\n val1Dn <=? val2Up is " + ++ show val1Dn ++ " <=? " ++ show val2Up ++ " = " + ++ show (val1Dn <=? val2Up) + ++ "\n val2Dn <=? val1Up is " + ++ show val2Dn ++ " <=? " ++ show val1Up ++ " = " + ++ show (val2Dn <=? val1Up) + ) + success = + (defined (val1Dn <=? val2Up) ===> (val1Dn <= val2Up)) + && + (defined (val2Dn <=? val1Up) ===> (val2Dn <= val1Up)) + val1Dn = check $ expr1Dn effortOp + val1Up = check $ expr1Up effortOp + val2Dn = check $ expr2Dn effortOp + val2Up = check $ expr2Up effortOp + check = detectIllegalValues contextDescription + (<=) = assumeTotal2 (<=?) + (<=?) = pCompareEff effortRel + +roundedInPlace1ConsistentWithPure :: + (EffortIndicator eiRel, EffortIndicator eiOp, + Show eiOp, Show eiRel, + CanBeMutable t, Show t, HasLegalValues t) => + String -> + (forall s. eiOp -> OpMutable1 t s) {-^ left hand side expression UP -} -> + (forall s. eiOp -> OpMutable1 t s) {-^ left hand side expression DN -} -> + (eiOp -> UnaryOp t) {-^ right hand side expression UP -} -> + (eiOp -> UnaryOp t) {-^ right hand side expression DN -} -> + (PRelEff eiRel t) -> + (eiRel, eiOp) -> + t -> + Bool +roundedInPlace1ConsistentWithPure + contextDescription + opUpInPlaceEff opDnInPlaceEff opUpEff opDnEff + pLeqEff initEffort + e + = + equalRoundingUpDn + ("in-place" ++ contextDescription ++ " consistent with pure") + expr1Up expr1Dn expr2Up expr2Dn + pLeqEff initEffort + where + opUpEffViaInPlace = mutable1EffToPure (opUpInPlaceEff) + opDnEffViaInPlace = mutable1EffToPure (opDnInPlaceEff) + expr1Up eff = opUpEff eff e + expr1Dn eff = opDnEff eff e + expr2Up eff = opUpEffViaInPlace eff e + expr2Dn eff = opDnEffViaInPlace eff e + +roundedInPlace2ConsistentWithPure :: + (EffortIndicator eiRel, EffortIndicator eiOp, + Show eiOp, Show eiRel, + CanBeMutable t, Show t, HasLegalValues t) => + String -> + (forall s. eiOp -> OpMutable2 t s) {-^ left hand side expression UP -} -> + (forall s. eiOp -> OpMutable2 t s) {-^ left hand side expression DN -} -> + (eiOp -> Op t) {-^ right hand side expression UP -} -> + (eiOp -> Op t) {-^ right hand side expression DN -} -> + (PRelEff eiRel t) -> + (eiRel, eiOp) -> + t -> t -> + Bool +roundedInPlace2ConsistentWithPure + contextDescription + opUpInPlaceEff opDnInPlaceEff opUpEff opDnEff + pLeqEff initEffort + e1 e2 + = + equalRoundingUpDn + ("in-place" ++ contextDescription ++ " consistent with pure") + expr1Up expr1Dn expr2Up expr2Dn + pLeqEff initEffort + where + opUpEffViaInPlace = mutable2EffToPure (opUpInPlaceEff) + opDnEffViaInPlace = mutable2EffToPure (opDnInPlaceEff) + expr1Up eff = + let (*^) = opUpEff eff in e1 *^ e2 + expr1Dn eff = + let (*.) = opDnEff eff in e1 *. e2 + expr2Up eff = + let (*^) = opUpEffViaInPlace eff in e1 *^ e2 + expr2Dn eff = + let (*.) = opDnEffViaInPlace eff in e1 *. e2 + diff --git a/src/Numeric/AERN/RealArithmetic/Measures.hs b/src/Numeric/AERN/RealArithmetic/Measures.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/Measures.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.Measures + Description : measures of quality for approximations + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Measures of quality for approximations. +-} +module Numeric.AERN.RealArithmetic.Measures where + +import {-# Source #-} Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps + +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +{-| + Ability to measure a distance. Distance + should be a numeric type approximating the + positive real numbers with Partial comparison. +-} +class HasDistance t where + type Distance t + type DistanceEffortIndicator t + distanceDefaultEffort :: t -> (DistanceEffortIndicator t) + {-| distance measure -} + distanceBetweenEff :: + DistanceEffortIndicator t -> t -> t -> Distance t + +propDistanceTriangular :: + (HasDistance t, + NumOrd.PartialComparison (Distance t), + RoundedAdd (Distance t) + ) => + t -> + (DistanceEffortIndicator t) -> + (NumOrd.PartialCompareEffortIndicator (Distance t)) -> + (AddEffortIndicator (Distance t)) -> + t -> t -> t -> Bool +propDistanceTriangular _ effortDist effortComp effortAdd e1 e2 e3 = + let ?pCompareEffort = effortComp in + let (<+>) = addOutEff effortAdd in + let + d12 = distanceBetweenEff effortDist e1 e2 + d23 = distanceBetweenEff effortDist e2 e3 + d13 = distanceBetweenEff effortDist e1 e3 + in + case (d12 <+> d23) >=? d13 of + Nothing -> True + Just b -> b + +testsDistance :: + (HasDistance t, + NumOrd.PartialComparison (Distance t), + RoundedAdd (Distance t), + Arbitrary (NumOrd.PartialCompareEffortIndicator (Distance t)), + Show (NumOrd.PartialCompareEffortIndicator (Distance t)), + Arbitrary (AddEffortIndicator (Distance t)), + Show (AddEffortIndicator (Distance t)), + Arbitrary (DistanceEffortIndicator t), + Show (DistanceEffortIndicator t), + Arbitrary t, Show t) => + (String, t) -> Test +testsDistance (name, sample) = + testGroup (name ++ " distance measure") $ + [ + testProperty "triangle inequality" (propDistanceTriangular sample) + ] + +{-| + A numeric measure of imprecision of approximations. + A zero imprecision means the approximation is exact. + The imprecision type should support Partial comparison. +-} +class HasImprecision t where + type Imprecision t + type ImprecisionEffortIndicator t + imprecisionDefaultEffort :: t -> ImprecisionEffortIndicator t + imprecisionOfEff :: ImprecisionEffortIndicator t -> t -> Imprecision t + +propImprecisionDecreasesWithRefinement :: + (HasImprecision t, NumOrd.PartialComparison (Imprecision t)) => + t -> + (ImprecisionEffortIndicator t) -> + (NumOrd.PartialCompareEffortIndicator (Imprecision t)) -> + RefOrd.LEPair t -> Bool +propImprecisionDecreasesWithRefinement _ effortImpr effortComp (RefOrd.LEPair (e1,e2)) = + let + ?pCompareEffort = effortComp + in + case (imprecisionOfEff effortImpr e1) >=? (imprecisionOfEff effortImpr e2) of + Nothing -> True + Just b -> b + +testsImprecision (name, sample) = + testGroup (name ++ " imprecision measure") $ + [ + testProperty "decreases with refinement" (propImprecisionDecreasesWithRefinement sample) + ] + + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding + Description : common arithmetical operations rounded up/down + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Common arithmetical operations rounded up/down. + + This module is meant to be imported qualified. + It is recommended to use the prefix ArithUpDn. +-} +module Numeric.AERN.RealArithmetic.NumericOrderRounding +( + module Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion, + module Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps, + module Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps, + module Numeric.AERN.RealArithmetic.NumericOrderRounding.SpecialConst, + module Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary, + module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace, + RoundedReal(..), RoundedRealInPlace +) +where + +import Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion +import Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.SpecialConst +import Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary +import Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace + +import Numeric.AERN.RealArithmetic.ExactOps +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd + +{-| + An aggregate class collecting together all functionality + normally expected from up/down rounded approximations to + real numbers such as the floating point numbers. + + It also provides a single aggregate effort indicator type + from which effort indicators for all the rounded operations can + be extracted. +-} +class + (HasZero t, HasOne t, HasInfinities t, Neg t, + NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + Convertible Int t, Convertible t Int, + Convertible Integer t, Convertible t Integer, + Convertible Double t, Convertible t Double, + Convertible Rational t, Convertible t Rational, + RoundedAbs t, + RoundedField t, + RoundedMixedField t Int, + RoundedMixedField t Integer, + RoundedMixedField t Double, + RoundedMixedField t Rational) => + RoundedReal t + where + type RoundedRealEffortIndicator t + roundedRealDefaultEffort :: t -> RoundedRealEffortIndicator t + rrEffortComp :: t -> (RoundedRealEffortIndicator t) -> (NumOrd.PartialCompareEffortIndicator t) + rrEffortMinmax :: t -> (RoundedRealEffortIndicator t) -> (NumOrd.MinmaxEffortIndicator t) + rrEffortToInt :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator t Int) + rrEffortFromInt :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator Int t) + rrEffortToInteger :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator t Integer) + rrEffortFromInteger :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator Integer t) + rrEffortToDouble :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator t Double) + rrEffortFromDouble :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator Double t) + rrEffortToRational :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator t Rational) + rrEffortFromRational :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator Rational t) + rrEffortAbs :: t -> (RoundedRealEffortIndicator t) -> (AbsEffortIndicator t) + rrEffortField :: t -> (RoundedRealEffortIndicator t) -> (FieldOpsEffortIndicator t) + rrEffortIntMixedField :: t -> (RoundedRealEffortIndicator t) -> (MixedFieldOpsEffortIndicator t Int) + rrEffortIntegerMixedField :: t -> (RoundedRealEffortIndicator t) -> (MixedFieldOpsEffortIndicator t Integer) + rrEffortDoubleMixedField :: t -> (RoundedRealEffortIndicator t) -> (MixedFieldOpsEffortIndicator t Double) + rrEffortRationalMixedField :: t -> (RoundedRealEffortIndicator t) -> (MixedFieldOpsEffortIndicator t Rational) + +{-| + A mutable version of 'RoundedReal' with additional support for mutable ops. +-} +class + (RoundedReal t, + NegInPlace t, + RoundedAbsInPlace t, + RoundedFieldInPlace t, + RoundedMixedFieldInPlace t Int, + RoundedMixedFieldInPlace t Integer, + RoundedMixedFieldInPlace t Double, + RoundedMixedFieldInPlace t Rational) => + RoundedRealInPlace t + + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/Conversion.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/Conversion.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion + Description : conversion between approximations and other types + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Conversion between approximations and other types. + + This module is hidden and reexported via its parent NumericOrderRounding. +-} +module Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion where + +import Prelude hiding (EQ, LT, GT) + +import Numeric.AERN.RealArithmetic.ExactOps + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.PartialOrdering +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import Numeric.AERN.Misc.Bool +import Numeric.AERN.Misc.Maybe + +import Data.Ratio +import Data.Maybe + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class Convertible t1 t2 where + type ConvertEffortIndicator t1 t2 + convertDefaultEffort :: t1 -> t2 -> ConvertEffortIndicator t1 t2 + convertUpEff :: ConvertEffortIndicator t1 t2 -> t1 -> Maybe t2 + convertDnEff :: ConvertEffortIndicator t1 t2 -> t1 -> Maybe t2 + +propConvertMonotone :: + (Convertible t1 t2, + NumOrd.ArbitraryOrderedTuple t1, + NumOrd.PartialComparison t2) => + t1 -> t2 -> + (ConvertEffortIndicator t1 t2, + NumOrd.PartialCompareEffortIndicator t2) -> + NumOrd.LEPair t1 -> Bool +propConvertMonotone sample1 sample2 (effortConvert, effortComp2) (NumOrd.LEPair (a1, a2)) = + (defined ma1Dn && defined ma2Up) ===> + (trueOrNothing $ + let ?pCompareEffort = effortComp2 in + a1Dn <=? a2Up) + where + ma1Dn = convertDnEff effortConvert a1 + ma2Up = convertUpEff effortConvert a2 + a1Dn = fromJust ma1Dn + a2Up = fromJust ma2Up + _ = [sample2, a1Dn, a2Up] + +propConvertRoundTrip :: + (Convertible t1 t2, Convertible t2 t1, NumOrd.PartialComparison t1) => + t1 -> t2 -> + (NumOrd.PartialCompareEffortIndicator t1, + ConvertEffortIndicator t2 t1, + ConvertEffortIndicator t1 t2) -> + t1 -> Bool +propConvertRoundTrip _ sample2 (effortComp, effortFrom2, effortTo2) a = + (defined maDn2 && defined maDn && defined maUp2 && defined maUp) ===> + let ?pCompareEffort = effortComp in + case (aDn <=? a, a <=? aUp) of + (Just False, _) -> False + (_, Just False) -> False + _ -> True + where + maDn = convertDnEff effortFrom2 aDn2 + aDn = fromJust maDn + maDn2 = convertDnEff effortTo2 a + aDn2 = fromJust maDn2 + maUp = convertUpEff effortFrom2 aUp2 + aUp = fromJust maUp + maUp2 = convertUpEff effortTo2 a + aUp2 = fromJust maUp2 + _ = [sample2, aUp2, aDn2] + +testsConvert (name1, sample1, name2, sample2) = + testGroup (name1 ++ " -> " ++ name2 ++ " conversions") $ + [ + testProperty "monotone" (propConvertMonotone sample1 sample2) + , + testProperty "round trip" (propConvertRoundTrip sample1 sample2) + ] + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/Elementary.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/Elementary.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/Elementary.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary + Description : support for various common elementary functions + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Support for various common elementary functions. + + This module is hidden and reexported via its parent NumericOrderRounding. +-} + +module Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary where + +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception +import Numeric.AERN.Basics.ShowInternals +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import Numeric.AERN.Misc.Debug + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class RoundedExponentiationEffort t where + type ExpEffortIndicator t + expDefaultEffort :: t -> ExpEffortIndicator t + +class (RoundedExponentiationEffort t) => RoundedExponentiation t where + expUpEff :: (ExpEffortIndicator t) -> t -> t + expDnEff :: (ExpEffortIndicator t) -> t -> t + +-- | @e^a*e^(-a) = 1@ +propExpOfNegRecip :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + RoundedExponentiation t, RoundedMultiply t, Neg t, HasOne t, + Show t, HasLegalValues t, + ShowInternals t, + Show (ExpEffortIndicator t), + EffortIndicator (ExpEffortIndicator t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + (ExpEffortIndicator t, MultEffortIndicator t)) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propExpOfNegRecip _ initEffort (NumOrd.UniformlyOrderedSingleton e1) = + equalRoundingUpDn "e^a * e^(-a) = 1" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effExp, effMult) = one + expr1Dn (effExp, effMult) = one + expr2Up (effExp, effMult) = + let (*^) = multUpEff effMult in + let expE1 = expUpEff effExp e1 in + let expNegE1 = expUpEff effExp (neg e1) in + let prod = expE1 *^ expNegE1 in +-- unsafePrintReturn +-- ( +-- "propExpOfNegRecip: expr2Up: e1 = " ++ show e1 +-- ++ "; expE1 = " ++ show expE1 +-- ++ "; expNegE1 = " ++ show expNegE1 +-- ++ "; prod = " ++ showUsingShowInternals prod +-- ++ "; result = " +-- )$ + prod + expr2Dn (effExp, effMult) = + let (*.) = multDnEff effMult in + let expE1 = expDnEff effExp e1 in + let negE1 = (neg e1) in + let expNegE1 = expDnEff effExp negE1 in + let prod = expE1 *. expNegE1 in +-- unsafePrintReturn +-- ( +-- "propExpOfNegRecip: expr2Dn: e1 = " ++ show e1 +-- ++ "; expE1 = " ++ show expE1 +-- ++ "; negE1 = " ++ show negE1 +-- ++ "; expNegE1 = " ++ show expNegE1 +-- ++ "; prod = " ++ showUsingShowInternals prod +-- ++ "; result = " +-- )$ + prod + +-- | @e^(b+c) = e^b * e^c@ +propExpOfAddToMult :: + (NumOrd.PartialComparison t, + RoundedExponentiation t, RoundedMultiply t, RoundedAdd t, + Show t, HasLegalValues t, + Show (ExpEffortIndicator t), + EffortIndicator (ExpEffortIndicator t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + (ExpEffortIndicator t, MultEffortIndicator t, AddEffortIndicator t)) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propExpOfAddToMult _ initEffort (NumOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "e^(a + b) = e^a * e^b" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effExp, effMult, effAdd) = + let (+^) = addUpEff effAdd in + (expUpEff effExp (e1 +^ e2)) + expr1Dn (effExp, effMult, effAdd) = + let (+.) = addDnEff effAdd in + (expDnEff effExp (e1 +. e2)) + expr2Up (effExp, effMult, effAdd) = + let (*^) = multUpEff effMult in + (expUpEff effExp e1) *^ (expUpEff effExp e2) + expr2Dn (effExp, effMult, effAdd) = + let (*.) = multDnEff effMult in + (expDnEff effExp e1) *. (expDnEff effExp e2) + +testsUpDnExp (name, sample) = + testGroup (name ++ " exp up/dn") $ + [ + testProperty "e^a * e^(-a) = 1" (propExpOfNegRecip sample) + , + testProperty "e^(a + b) = e^a * e^b" (propExpOfAddToMult sample) + ] + +class RoundedSquareRootEffort t where + type SqrtEffortIndicator t + sqrtDefaultEffort :: t -> SqrtEffortIndicator t + +class (RoundedSquareRootEffort t) => RoundedSquareRoot t where + sqrtUpEff :: (SqrtEffortIndicator t) -> t -> t + sqrtDnEff :: (SqrtEffortIndicator t) -> t -> t + +propSqrtSquare :: + (NumOrd.PartialComparison t, + RoundedSquareRoot t, RoundedMultiply t, HasZero t, + Show t, HasLegalValues t, + ShowInternals t, + Show (SqrtEffortIndicator t), + EffortIndicator (SqrtEffortIndicator t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + (SqrtEffortIndicator t, MultEffortIndicator t, NumOrd.PartialCompareEffortIndicator t)) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propSqrtSquare _ initEffort (NumOrd.UniformlyOrderedSingleton e1) = + case evalCatchDomViolationExceptions "checking sqrt(x)^2 = x" + (equalRoundingUpDn "sqrt(x)^2 = x" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort) of + Left e -> True -- was unlucky with the params + Right r -> r + where + expr1Up (effSqrt, effMult, effCompare) = + sqrtE1 *^ sqrtE1 + where + (*^) = multUpEff effMult + sqrtE1 = sqrtUpEff effSqrt e1 + expr1Dn (effSqrt, effMult, effCompare) + | sqrtE1DefinitelyPositive = sqrtE1 *. sqrtE1 + | otherwise = zero + where + sqrtE1DefinitelyPositive = + let ?pCompareEffort = effCompare in + case sqrtE1 >=? zero of (Just r) -> r; _ -> False + (*.) = multDnEff effMult + sqrtE1 = sqrtDnEff effSqrt e1 + expr2Up _ = e1 + expr2Dn _ = e1 + +testsUpDnSqrt (name, sample) = + testGroup (name ++ " sqrt up/dn") $ + [ + testProperty "sqrt(e)^2 = e" (propSqrtSquare sample) + ] + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/FieldOps.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/FieldOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/FieldOps.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + Description : rounded basic arithmetic operations + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Rounded basic arithmetical operations. + + This module is hidden and reexported via its parent NumericOrderRounding. +-} +module Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps +( + RoundedAdd(..),RoundedAddEffort(..), RoundedSubtr(..), + testsUpDnAdd, testsUpDnSubtr, + RoundedAbs(..), RoundedAbsEffort(..), + testsUpDnAbs, absUpUsingCompMax, absDnUsingCompMax, + RoundedMultiply(..), RoundedMultiplyEffort(..), testsUpDnMult, + RoundedPowerNonnegToNonnegInt(..), RoundedPowerNonnegToNonnegIntEffort(..), + PowerNonnegToNonnegIntEffortIndicatorFromMult, + powerNonnegToNonnegIntDefaultEffortFromMult, + powerNonnegToNonnegIntUpEffFromMult, + powerNonnegToNonnegIntDnEffFromMult, + RoundedPowerToNonnegInt(..), RoundedPowerToNonnegIntEffort(..), testsUpDnIntPower, + PowerToNonnegIntEffortIndicatorFromMult, + powerToNonnegIntDefaultEffortFromMult, + powerToNonnegIntUpEffFromMult, + powerToNonnegIntDnEffFromMult, + RoundedDivide(..), RoundedDivideEffort(..), testsUpDnDiv, + RoundedRingEffort(..), RoundedFieldEffort(..), + RoundedRing(..), RoundedField(..) +) +where + +import Prelude hiding (EQ, LT, GT) +import Numeric.AERN.Basics.PartialOrdering + +import Numeric.AERN.RealArithmetic.Auxiliary +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception (HasLegalValues) +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Maybe + +class RoundedAddEffort t where + type AddEffortIndicator t + addDefaultEffort :: t -> AddEffortIndicator t + +class (RoundedAddEffort t) => RoundedAdd t where + addUpEff :: AddEffortIndicator t -> t -> t -> t + addDnEff :: AddEffortIndicator t -> t -> t -> t + +propUpDnAddZero :: + (NumOrd.PartialComparison t, RoundedAdd t, HasZero t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnAddZero _ effort (NumOrd.UniformlyOrderedSingleton e) = + roundedUnit zero NumOrd.pLeqEff addUpEff addDnEff effort e + +propUpDnAddCommutative :: + (NumOrd.PartialComparison t, RoundedAdd t, HasZero t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propUpDnAddCommutative _ effort (NumOrd.UniformlyOrderedPair (e1,e2)) = + roundedCommutative NumOrd.pLeqEff addUpEff addDnEff effort e1 e2 + +propUpDnAddAssociative :: + (NumOrd.PartialComparison t, RoundedAdd t, HasZero t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (NumOrd.UniformlyOrderedTriple t) -> + Bool +propUpDnAddAssociative _ effort (NumOrd.UniformlyOrderedTriple (e1,e2,e3)) = + roundedAssociative NumOrd.pLeqEff addUpEff addDnEff effort e1 e2 e3 + +testsUpDnAdd (name, sample) = + testGroup (name ++ " +. +^") $ + [ + testProperty "0 absorbs" (propUpDnAddZero sample) + , + testProperty "commutative" (propUpDnAddCommutative sample) + , + testProperty "associative" (propUpDnAddAssociative sample) + ] + +class (RoundedAdd t, Neg t) => RoundedSubtr t where + subtrUpEff :: (AddEffortIndicator t) -> t -> t -> t + subtrDnEff :: (AddEffortIndicator t) -> t -> t -> t + subtrUpEff effort a b = addUpEff effort a (neg b) + subtrDnEff effort a b = addDnEff effort a (neg b) + +propUpDnSubtrElim :: + (NumOrd.PartialComparison t, RoundedSubtr t, HasZero t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnSubtrElim _ effort (NumOrd.UniformlyOrderedSingleton e) = + roundedReflexiveCollapse zero NumOrd.pLeqEff subtrUpEff subtrDnEff effort e + +propUpDnSubtrNegAdd :: + (NumOrd.PartialComparison t, RoundedSubtr t, Neg t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propUpDnSubtrNegAdd _ initEffort (NumOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "a+b=a-(-b)" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up eff = + let (-^) = subtrUpEff eff in e1 -^ (neg e2) + expr1Dn eff = + let (-.) = subtrDnEff eff in e1 -. (neg e2) + expr2Up eff = + let (+^) = addUpEff eff in e1 +^ e2 + expr2Dn eff = + let (+.) = addDnEff eff in e1 +. e2 + + +testsUpDnSubtr (name, sample) = + testGroup (name ++ " -. -^") $ + [ + testProperty "a-a=0" (propUpDnSubtrElim sample) + , + testProperty "a+b=a-(-b)" (propUpDnSubtrNegAdd sample) + ] + +class RoundedAbsEffort t where + type AbsEffortIndicator t + absDefaultEffort :: t -> AbsEffortIndicator t + +class (RoundedAbsEffort t) => RoundedAbs t where + absUpEff :: (AbsEffortIndicator t) -> t -> t + absDnEff :: (AbsEffortIndicator t) -> t -> t + +absUpUsingCompMax :: + (HasZero t, Neg t, + NumOrd.PartialComparison t, NumOrd.RoundedLattice t) => + (NumOrd.PartialCompareEffortIndicator t, + NumOrd.MinmaxEffortIndicator t) -> + t -> t +absUpUsingCompMax (effortComp, effortMinmax) a = + case NumOrd.pCompareEff effortComp zero a of + Just EQ -> a + Just LT -> a + Just LEE -> a + Just GT -> neg a + Just GEE -> neg a + _ -> zero `max` (a `max` (neg a)) + where + max = NumOrd.maxUpEff effortMinmax + +absDnUsingCompMax :: + (HasZero t, Neg t, + NumOrd.PartialComparison t, NumOrd.RoundedLattice t) => + (NumOrd.PartialCompareEffortIndicator t, + NumOrd.MinmaxEffortIndicator t) -> + t -> t +absDnUsingCompMax (effortComp, effortMinmax) a = + case NumOrd.pCompareEff effortComp zero a of + Just EQ -> a + Just LT -> a + Just LEE -> a + Just GT -> neg a + Just GEE -> neg a + _ -> zero `max` (a `max` (neg a)) + where + max = NumOrd.maxDnEff effortMinmax + +propUpDnAbsNegSymmetric :: + (NumOrd.PartialComparison t, RoundedAbs t, HasZero t, + Show t, Neg t, HasLegalValues t, + Show (AbsEffortIndicator t), + EffortIndicator (AbsEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AbsEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnAbsNegSymmetric _ effort (NumOrd.UniformlyOrderedSingleton e) = + roundedNegSymmetric NumOrd.pLeqEff absUpEff absDnEff effort e + +propUpDnAbsIdempotent :: + (NumOrd.PartialComparison t, RoundedAbs t, HasZero t, + Show t, HasLegalValues t, + Show (AbsEffortIndicator t), + EffortIndicator (AbsEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AbsEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnAbsIdempotent _ effort (NumOrd.UniformlyOrderedSingleton e) = + roundedIdempotent NumOrd.pLeqEff absUpEff absDnEff effort e + +testsUpDnAbs (name, sample) = + testGroup (name ++ " up/dn rounded abs") $ + [ + testProperty "neg -> no change" (propUpDnAbsNegSymmetric sample) + , + testProperty "idempotent" (propUpDnAbsIdempotent sample) + ] + + +class RoundedMultiplyEffort t where + type MultEffortIndicator t + multDefaultEffort :: t -> MultEffortIndicator t + +class (RoundedMultiplyEffort t) => RoundedMultiply t where + multUpEff :: MultEffortIndicator t -> t -> t -> t + multDnEff :: MultEffortIndicator t -> t -> t -> t + +propUpDnMultOne :: + (NumOrd.PartialComparison t, RoundedMultiply t, HasOne t, + Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + MultEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnMultOne _ effort (NumOrd.UniformlyOrderedSingleton e) = + roundedUnit one NumOrd.pLeqEff multUpEff multDnEff effort e + +propUpDnMultCommutative :: + (NumOrd.PartialComparison t, RoundedMultiply t, HasZero t, + Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + MultEffortIndicator t) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propUpDnMultCommutative _ effort (NumOrd.UniformlyOrderedPair (e1,e2)) = + roundedCommutative NumOrd.pLeqEff multUpEff multDnEff effort e1 e2 + +propUpDnMultAssociative :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + Show t, HasLegalValues t, + RoundedMultiply t, HasZero t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.MinmaxEffortIndicator t), + EffortIndicator (NumOrd.MinmaxEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + (MultEffortIndicator t, NumOrd.MinmaxEffortIndicator t)) -> + (NumOrd.UniformlyOrderedTriple t) -> + Bool +propUpDnMultAssociative _ initEffort (NumOrd.UniformlyOrderedTriple (e1, e2, e3)) = + equalRoundingUpDn "associativity" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMult, effMinmax) = + let (*^) = multUpEff effMult; (*.) = multDnEff effMult in + let r1 = e1 *^ (e2 *^ e3) in + let r2 = e1 *^ (e2 *. e3) in + NumOrd.maxUpEff effMinmax r1 r2 + expr1Dn (effMult, effMinmax) = + let (*^) = multUpEff effMult; (*.) = multDnEff effMult in + let r1 = e1 *. (e2 *^ e3) in + let r2 = e1 *. (e2 *. e3) in + NumOrd.minDnEff effMinmax r1 r2 + expr2Up (effMult, effMinmax) = + let (*^) = multUpEff effMult; (*.) = multDnEff effMult in + let r1 = (e1 *^ e2) *^ e3 in + let r2 = (e1 *. e2) *^ e3 in + NumOrd.maxUpEff effMinmax r1 r2 + expr2Dn (effMult, effMinmax) = + let (*^) = multUpEff effMult; (*.) = multDnEff effMult in + let r1 = (e1 *^ e2) *. e3 in + let r2 = (e1 *. e2) *. e3 in + NumOrd.minDnEff effMinmax r1 r2 + +propUpDnMultDistributesOverAdd :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + Show t, HasLegalValues t, + RoundedMultiply t, RoundedAdd t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.MinmaxEffortIndicator t), + EffortIndicator (NumOrd.MinmaxEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + (MultEffortIndicator t, AddEffortIndicator t, NumOrd.MinmaxEffortIndicator t)) -> + (NumOrd.UniformlyOrderedTriple t) -> + Bool +propUpDnMultDistributesOverAdd _ initEffort (NumOrd.UniformlyOrderedTriple (e1, e2, e3)) = + equalRoundingUpDn "distributivity" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMult, effAdd, effMinmax) = + let (*^) = multUpEff effMult in + let (+^) = addUpEff effAdd; (+.) = addDnEff effAdd in + let r1 = e1 *^ (e2 +^ e3) in + let r2 = e1 *^ (e2 +. e3) in + NumOrd.maxUpEff effMinmax r1 r2 + expr1Dn (effMult, effAdd, effMinmax) = + let (*.) = multDnEff effMult in + let (+^) = addUpEff effAdd; (+.) = addDnEff effAdd in + let r1 = e1 *. (e2 +^ e3) in + let r2 = e1 *. (e2 +. e3) in + NumOrd.minDnEff effMinmax r1 r2 + expr2Up (effMult, effAdd, _) = + let (*^) = multUpEff effMult in + let (+^) = addUpEff effAdd in + (e1 *^ e2) +^ (e1 *^ e3) + expr2Dn (effMult, effAdd, _) = + let (*.) = multDnEff effMult in + let (+.) = addDnEff effAdd in + (e1 *. e2) +. (e1 *. e3) + + +testsUpDnMult (name, sample) = + testGroup (name ++ " *. *^") $ + [ + testProperty "1 absorbs" (propUpDnMultOne sample) + , + testProperty "commutative" (propUpDnMultCommutative sample) + , + testProperty "associative" (propUpDnMultAssociative sample) + , + testProperty "distributes over +" (propUpDnMultDistributesOverAdd sample) + ] + +-- simpler versions assuming the argument is non-negative: +class RoundedPowerNonnegToNonnegIntEffort t where + type PowerNonnegToNonnegIntEffortIndicator t + powerNonnegToNonnegIntDefaultEffort :: + t -> PowerNonnegToNonnegIntEffortIndicator t + +class (RoundedPowerNonnegToNonnegIntEffort t) => + RoundedPowerNonnegToNonnegInt t where + powerNonnegToNonnegIntUpEff :: + (PowerNonnegToNonnegIntEffortIndicator t) -> + t {-^ @x@ (assumed >=0) -} -> + Int {-^ @n@ (assumed >=0)-} -> + t {-^ @x^n@ rounded up -} + powerNonnegToNonnegIntDnEff :: + (PowerNonnegToNonnegIntEffortIndicator t) -> + t {-^ @x@ (assumed >=0) -} -> + Int {-^ @n@ (assumed >=0)-} -> + t {-^ @x^n@ rounded down -} + +-- functions providing an implementation derived from rounded multiplication: + +type PowerNonnegToNonnegIntEffortIndicatorFromMult t = + MultEffortIndicator t + +powerNonnegToNonnegIntDefaultEffortFromMult a = + multDefaultEffort a + +powerNonnegToNonnegIntUpEffFromMult :: + (RoundedMultiply t, HasOne t) => + PowerNonnegToNonnegIntEffortIndicatorFromMult t -> + t -> Int -> t +powerNonnegToNonnegIntUpEffFromMult effMult e n = + powerFromMult (multUpEff effMult) e n + +powerNonnegToNonnegIntDnEffFromMult :: + (RoundedMultiply t, HasOne t) => + PowerNonnegToNonnegIntEffortIndicatorFromMult t -> + t -> Int -> t +powerNonnegToNonnegIntDnEffFromMult effMult e n = + powerFromMult (multDnEff effMult) e n + +-- now not assuming the argument is non-negative: +class RoundedPowerToNonnegIntEffort t where + type PowerToNonnegIntEffortIndicator t + powerToNonnegIntDefaultEffort :: + t -> PowerToNonnegIntEffortIndicator t + +class (RoundedPowerToNonnegIntEffort t) => RoundedPowerToNonnegInt t where + powerToNonnegIntUpEff :: + (PowerToNonnegIntEffortIndicator t) -> + t {-^ @x@ -} -> + Int {-^ @n@ (assumed >=0)-} -> + t {-^ @x^n@ rounded up -} + powerToNonnegIntDnEff :: + (PowerToNonnegIntEffortIndicator t) -> + t {-^ @x@ -} -> + Int {-^ @n@ (assumed >=0)-} -> + t {-^ @x^n@ rounded down -} + +-- functions providing an implementation derived from rounded multiplication: + +type PowerToNonnegIntEffortIndicatorFromMult t = + (MultEffortIndicator t, + NumOrd.PartialCompareEffortIndicator t, + NumOrd.MinmaxEffortIndicator t) + +powerToNonnegIntDefaultEffortFromMult a = + (multDefaultEffort a, + NumOrd.pCompareDefaultEffort a, + NumOrd.minmaxDefaultEffort a) + +powerToNonnegIntUpEffFromMult :: + (RoundedMultiply t, HasOne t, + NumOrd.PartialComparison t, HasZero t, + Neg t, NumOrd.RoundedLattice t) => + PowerToNonnegIntEffortIndicatorFromMult t -> + t -> Int -> t +powerToNonnegIntUpEffFromMult (effMult, effComp, effMinmax) e n = + powerToNonnegIntDir + (multUpEff effMult) (multDnEff effMult) + (NumOrd.maxUpEff effMinmax) + effComp e n + +powerToNonnegIntDnEffFromMult :: + (RoundedMultiply t, HasOne t, + NumOrd.PartialComparison t, HasZero t, + Neg t, NumOrd.RoundedLattice t) => + PowerToNonnegIntEffortIndicatorFromMult t -> + t -> Int -> t +powerToNonnegIntDnEffFromMult (effMult, effComp, effMinmax) e n = + powerToNonnegIntDir + (multDnEff effMult) (multUpEff effMult) + (NumOrd.minDnEff effMinmax) + effComp e n + +powerToNonnegIntDir :: + (HasOne t, + NumOrd.PartialComparison t, HasZero t, + Neg t) => + (t -> t -> t) {-^ multiplication rounded in the desired direction -} -> + (t -> t -> t) {-^ multiplication rounded in the opposite direction -} -> + (t -> t -> t) {-^ safe combination of alternative results -} -> + (NumOrd.PartialCompareEffortIndicator t) -> + t -> Int -> t +powerToNonnegIntDir mult1 mult2 combine effComp x n + | n == 0 = one + | n == 1 = x + | otherwise = + case (pNonnegNonposEff effComp x) of + (Just True, _) -> resNonneg + (_, Just True) -> resNonpos + _ -> resNonneg `combine` resNonpos + where + resNonneg = powerFromMult mult1 x n + resNonpos + | even n = + powerFromMult mult1 (neg x) n + | otherwise = + neg $ powerFromMult mult2 (neg x) n + -- switching rounding direction + +propUpDnPowerSumExponents :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + RoundedPowerToNonnegInt t, RoundedMultiply t, + HasOne t, HasZero t, Neg t, + Show t, HasLegalValues t, + Show (PowerToNonnegIntEffortIndicator t), + EffortIndicator (PowerToNonnegIntEffortIndicator t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.MinmaxEffortIndicator t), + EffortIndicator (NumOrd.MinmaxEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + (PowerToNonnegIntEffortIndicator t, + (NumOrd.PartialCompareEffortIndicator t, + MultEffortIndicator t, + NumOrd.MinmaxEffortIndicator t))) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Int -> Int -> Bool +propUpDnPowerSumExponents _ initEffort (NumOrd.UniformlyOrderedSingleton a) nR mR = + equalRoundingUpDn "a^(n+m) = a^n * a^m" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + n = nR `mod` 10 + m = mR `mod` 10 + minusA = neg a + expr1Up (effPower, (effComp, effMult, effMinmax)) = + let (^^) = powerToNonnegIntUpEff effPower in + a ^^ (n + m) + expr1Dn (effPower, (effComp, effMult, effMinmax)) = + let (^.) = powerToNonnegIntDnEff effPower in + a ^. (n + m) + expr2Up (effPower, (effComp, effMult, effMinmax)) = + case pNonnegNonposEff effComp a of + (Just True, _) -> rNonneg + (_, Just True) -> rNonpos + _ -> rNonneg `max` rNonpos + where + max = NumOrd.maxUpEff effMinmax + (^^) = powerToNonnegIntUpEff effPower + (^.) = powerToNonnegIntDnEff effPower + (*^) = multUpEff effMult + (*.) = multDnEff effMult + rNonneg = (a ^^ n) *^ (a ^^ m) + rNonpos = + case (even (n + m)) of + True -> (minusA ^^ n) *^ (minusA ^^ m) + False -> neg $ (minusA ^. n) *. (minusA ^. m) + expr2Dn (effPower, (effComp, effMult, effMinmax)) = + case pNonnegNonposEff effComp a of + (Just True, _) -> rNonneg + (_, Just True) -> rNonpos + _ -> rNonneg `min` rNonpos + where + min = NumOrd.minDnEff effMinmax + (^^) = powerToNonnegIntUpEff effPower + (^.) = powerToNonnegIntDnEff effPower + (*^) = multUpEff effMult + (*.) = multDnEff effMult + rNonneg = (a ^. n) *. (a ^. m) + rNonpos = + case (even (n + m)) of + True -> (minusA ^. n) *. (minusA ^. m) + False -> neg $ (minusA ^^ n) *^ (minusA ^^ m) + +testsUpDnIntPower (name, sample) = + testGroup (name ++ " non-negative integer power") $ + [ + testProperty "a^(n+m) = a^n * a^m" (propUpDnPowerSumExponents sample) +-- , +-- testProperty "a/b=a*(1/b)" (propUpDnDivRecipMult sample) + ] + + +class RoundedDivideEffort t where + type DivEffortIndicator t + divDefaultEffort :: t -> DivEffortIndicator t + +class (HasOne t, RoundedDivideEffort t) => RoundedDivide t where + divUpEff :: DivEffortIndicator t -> t -> t -> t + divDnEff :: DivEffortIndicator t -> t -> t -> t + recipUpEff :: DivEffortIndicator t -> t -> t + recipDnEff :: DivEffortIndicator t -> t -> t + recipUpEff eff = divUpEff eff one + recipDnEff eff = divDnEff eff one + +propUpDnDivElim :: + (NumOrd.PartialComparison t, RoundedDivide t, HasOne t, HasZero t, + Show t, HasLegalValues t, + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + DivEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnDivElim _ efforts2@(effComp, _) (NumOrd.UniformlyOrderedSingleton a) = + roundedReflexiveCollapse + one + NumOrd.pLeqEff + divUpEff divDnEff + efforts2 + a + +propUpDnDivRecipMult :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + Show t, HasLegalValues t, + RoundedMultiply t, RoundedDivide t, HasOne t, HasZero t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (NumOrd.MinmaxEffortIndicator t), + EffortIndicator (NumOrd.MinmaxEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + (MultEffortIndicator t, DivEffortIndicator t, NumOrd.MinmaxEffortIndicator t)) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propUpDnDivRecipMult _ initEffort@(effComp,_) (NumOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "a/b=a*(1/b)" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMult, effDiv, effMinmax) = + let (*^) = multUpEff effMult in + let (/^) = divUpEff effDiv; (/.) = divDnEff effDiv in + let r1 = e1 *^ (one /^ e2) in + let r2 = e1 *^ (one /. e2) in + NumOrd.maxUpEff effMinmax r1 r2 + expr1Dn (effMult, effDiv, effMinmax) = + let (*.) = multDnEff effMult in + let (/^) = divUpEff effDiv; (/.) = divDnEff effDiv in + let r1 = e1 *. (one /^ e2) in + let r2 = e1 *. (one /. e2) in + NumOrd.minDnEff effMinmax r1 r2 + expr2Up (effMult, effDiv, _) = + let (/^) = divUpEff effDiv in + e1 /^ e2 + expr2Dn (effMult, effDiv, _) = + let (/.) = divDnEff effDiv in + e1 /. e2 + +testsUpDnDiv (name, sample) = + testGroup (name ++ " /. /^") $ + [ + testProperty "a/a=1" (propUpDnDivElim sample) + , + testProperty "a/b=a*(1/b)" (propUpDnDivRecipMult sample) + ] + +class (RoundedAddEffort t, + RoundedMultiplyEffort t, + RoundedPowerNonnegToNonnegIntEffort t, + RoundedPowerToNonnegIntEffort t) => + RoundedRingEffort t + where + type RingOpsEffortIndicator t + ringOpsDefaultEffort :: t -> RingOpsEffortIndicator t + ringEffortAdd :: t -> (RingOpsEffortIndicator t) -> (AddEffortIndicator t) + ringEffortMult :: t -> (RingOpsEffortIndicator t) -> (MultEffortIndicator t) + ringEffortPow :: t -> (RingOpsEffortIndicator t) -> (PowerNonnegToNonnegIntEffortIndicator t) + +class (RoundedAdd t, RoundedSubtr t, + RoundedMultiply t, + RoundedPowerNonnegToNonnegInt t, + RoundedPowerToNonnegInt t, + RoundedRingEffort t) => + RoundedRing t + +class (RoundedRingEffort t, RoundedDivideEffort t) => RoundedFieldEffort t + where + type FieldOpsEffortIndicator t + fieldOpsDefaultEffort :: t -> FieldOpsEffortIndicator t + fldEffortAdd :: t -> (FieldOpsEffortIndicator t) -> (AddEffortIndicator t) + fldEffortMult :: t -> (FieldOpsEffortIndicator t) -> (MultEffortIndicator t) + fldEffortPow :: t -> (FieldOpsEffortIndicator t) -> (PowerNonnegToNonnegIntEffortIndicator t) + fldEffortDiv :: t -> (FieldOpsEffortIndicator t) -> (DivEffortIndicator t) + +class (RoundedRing t, RoundedDivide t, RoundedFieldEffort t) => RoundedField t + + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace.hs @@ -0,0 +1,26 @@ +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace + Description : common arithmetical operations rounded up/down + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + In-place versions of common arithmetical operations rounded up/down. + + This module is hidden and reexported via its parent NumericOrderRounding. +-} +module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace +( + module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps, + module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.MixedFieldOps, + module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.Elementary +) +where + +import Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.MixedFieldOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.Elementary + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/Elementary.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/Elementary.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/Elementary.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.Elementary + Description : support for various common elementary functions + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Support for various common elementary functions. + + This module is hidden and reexported via its parent NumericOrderRounding.InPlace. +-} + +module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.Elementary where + +import Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary + +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception (HasLegalValues) +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class (RoundedExponentiation t, CanBeMutable t) => RoundedExponentiationInPlace t where + expUpInPlaceEff :: OpMutable1Eff (ExpEffortIndicator t) t s + expDnInPlaceEff :: OpMutable1Eff (ExpEffortIndicator t) t s + +expUpInPlaceEffFromPure, + expDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedExponentiation t) => + OpMutable1Eff (ExpEffortIndicator t) t s +expUpInPlaceEffFromPure = + pureToMutable1Eff expUpEff +expDnInPlaceEffFromPure = + pureToMutable1Eff expDnEff + +expUpInPlaceEffFromInPlace, + expDnInPlaceEffFromInPlace :: + (RoundedExponentiationInPlace t) => + (ExpEffortIndicator t) -> t -> t +expUpInPlaceEffFromInPlace = + mutable1EffToPure expUpInPlaceEff +expDnInPlaceEffFromInPlace = + mutable1EffToPure expDnInPlaceEff + +propUpDnExpInPlace :: + (NumOrd.PartialComparison t, + RoundedExponentiationInPlace t, + RoundedExponentiation t, + Neg t, + Show t, HasLegalValues t, + Show (ExpEffortIndicator t), + EffortIndicator (ExpEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + ExpEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnExpInPlace sample initEffort (NumOrd.UniformlyOrderedSingleton e1) = + equalRoundingUpDn "in-place rounded exp" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expUpEffViaInPlace = mutable1EffToPure expUpInPlaceEff + expDnEffViaInPlace = mutable1EffToPure expDnInPlaceEff + expr1Up eff = expUpEff eff e1 + expr1Dn eff = expDnEff eff e1 + expr2Up eff = expUpEffViaInPlace eff e1 + expr2Dn eff = expDnEffViaInPlace eff e1 + +testsUpDnExpInPlace (name, sample) = + testGroup (name ++ " in place exp") $ + [ + testProperty "matches pure" (propUpDnExpInPlace sample) + ] + + +class (RoundedSquareRoot t, CanBeMutable t) => RoundedSquareRootInPlace t where + sqrtUpInPlaceEff :: OpMutable1Eff (SqrtEffortIndicator t) t s + sqrtDnInPlaceEff :: OpMutable1Eff (SqrtEffortIndicator t) t s + +sqrtUpInPlaceEffFromPure, + sqrtDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedSquareRoot t) => + OpMutable1Eff (SqrtEffortIndicator t) t s +sqrtUpInPlaceEffFromPure = + pureToMutable1Eff sqrtUpEff +sqrtDnInPlaceEffFromPure = + pureToMutable1Eff sqrtDnEff + +sqrtUpInPlaceEffFromInPlace, + sqrtDnInPlaceEffFromInPlace :: + (RoundedSquareRootInPlace t) => + (SqrtEffortIndicator t) -> t -> t +sqrtUpInPlaceEffFromInPlace = + mutable1EffToPure sqrtUpInPlaceEff +sqrtDnInPlaceEffFromInPlace = + mutable1EffToPure sqrtDnInPlaceEff + +propUpDnSqrtInPlace :: + (NumOrd.PartialComparison t, + RoundedSquareRootInPlace t, + RoundedSquareRoot t, + Neg t, + Show t, HasLegalValues t, + Show (SqrtEffortIndicator t), + EffortIndicator (SqrtEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + SqrtEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnSqrtInPlace sample initEffort (NumOrd.UniformlyOrderedSingleton e1) = + equalRoundingUpDn "in-place rounded sqrt" + sqrtr1Up sqrtr1Dn sqrtr2Up sqrtr2Dn + NumOrd.pLeqEff initEffort + where + sqrtUpEffViaInPlace = mutable1EffToPure sqrtUpInPlaceEff + sqrtDnEffViaInPlace = mutable1EffToPure sqrtDnInPlaceEff + sqrtr1Up eff = sqrtUpEff eff e1 + sqrtr1Dn eff = sqrtDnEff eff e1 + sqrtr2Up eff = sqrtUpEffViaInPlace eff e1 + sqrtr2Dn eff = sqrtDnEffViaInPlace eff e1 + +testsUpDnSqrtInPlace (name, sample) = + testGroup (name ++ " in place sqrt") $ + [ + testProperty "matches pure" (propUpDnSqrtInPlace sample) + ] + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/FieldOps.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/FieldOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/FieldOps.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps + Description : rounded basic arithmetic operations + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + In-place versions of rounded basic arithmetic operations. + + Each operations takes mutable parameters instead of pure parameters + and has one extra mutable parameter before the other parameters, + in which it stores the result. + The mutable parameters can alias arbitrarily, making it possible + to eg add to a number overwriting the original number. + + The operations have as their first paramter a non-mutable sample value + to aid type-checking, ie to help work out which type the mutable parameters + contain. + + This module is hidden and reexported via its parent NumericOrderRounding.InPlace. +-} +module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps +where + +import Prelude hiding (EQ, LT, GT) +import Numeric.AERN.Basics.PartialOrdering + +import Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + +import Numeric.AERN.RealArithmetic.Auxiliary +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception (HasLegalValues) +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Control.Monad.ST +import Data.Maybe + +class (RoundedAddEffort t, CanBeMutable t) => RoundedAddInPlace t where + addUpInPlaceEff :: OpMutable2Eff (AddEffortIndicator t) t s + addDnInPlaceEff :: OpMutable2Eff (AddEffortIndicator t) t s + +addUpInPlaceEffFromPure, + addDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedAdd t) => + OpMutable2Eff (AddEffortIndicator t) t s +addUpInPlaceEffFromPure = pureToMutable2Eff addUpEff +addDnInPlaceEffFromPure = pureToMutable2Eff addDnEff + +addUpInPlaceEffFromInPlace, + addDnInPlaceEffFromInPlace :: + (RoundedAddInPlace t) => + (AddEffortIndicator t) -> t -> t -> t +addUpInPlaceEffFromInPlace = mutable2EffToPure addUpInPlaceEff +addDnInPlaceEffFromInPlace = mutable2EffToPure addDnInPlaceEff + +propUpDnAddInPlace :: + (NumOrd.PartialComparison t, Neg t, + RoundedAddInPlace t, RoundedAdd t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propUpDnAddInPlace sample initEffort (NumOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "in-place rounded addition" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + addUpEffViaInPlace = mutable2EffToPure addUpInPlaceEff + addDnEffViaInPlace = mutable2EffToPure addDnInPlaceEff + expr1Up eff = + let (+^) = addUpEff eff in e1 +^ e2 + expr1Dn eff = + let (+.) = addDnEff eff in e1 +. e2 + expr2Up eff = + let (+^) = addUpEffViaInPlace eff in e1 +^ e2 + expr2Dn eff = + let (+.) = addDnEffViaInPlace eff in e1 +. e2 + +class (RoundedAddInPlace t, NegInPlace t) => RoundedSubtrInPlace t where + subtrUpInPlaceEff :: OpMutable2Eff (AddEffortIndicator t) t s + subtrDnInPlaceEff :: OpMutable2Eff (AddEffortIndicator t) t s + subtrUpInPlaceEff effort rM aM bM = + do + bbM <- cloneMutable bM + negInPlace bbM bM + addUpInPlaceEff effort rM aM bbM + subtrDnInPlaceEff effort rM aM bM = + do + bbM <- cloneMutable bM + negInPlace bbM bM + addDnInPlaceEff effort rM aM bbM + +propUpDnSubtrInPlace :: + (NumOrd.PartialComparison t, + RoundedSubtrInPlace t, RoundedSubtr t, + Neg t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propUpDnSubtrInPlace sample initEffort (NumOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "in-place rounded subtraction" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + subtrUpEffViaInPlace = mutable2EffToPure subtrUpInPlaceEff + subtrDnEffViaInPlace = mutable2EffToPure subtrDnInPlaceEff + expr1Up eff = + let (-^) = subtrUpEff eff in e1 -^ e2 + expr1Dn eff = + let (-.) = subtrDnEff eff in e1 -. e2 + expr2Up eff = + let (-^) = subtrUpEffViaInPlace eff in e1 -^ e2 + expr2Dn eff = + let (-.) = subtrDnEffViaInPlace eff in e1 -. e2 + + +class (RoundedAbsEffort t, CanBeMutable t) => RoundedAbsInPlace t where + absUpInPlaceEff :: OpMutable1Eff (AbsEffortIndicator t) t s + absDnInPlaceEff :: OpMutable1Eff (AbsEffortIndicator t) t s + +absUpInPlaceEffFromPure, + absDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedAbs t) => + OpMutable1Eff (AbsEffortIndicator t) t s +absUpInPlaceEffFromPure = pureToMutable1Eff absUpEff +absDnInPlaceEffFromPure = pureToMutable1Eff absDnEff + +absUpInPlaceEffFromInPlace, + absDnInPlaceEffFromInPlace :: + (RoundedAbsInPlace t) => + (AbsEffortIndicator t) -> t -> t +absUpInPlaceEffFromInPlace = mutable1EffToPure absUpInPlaceEff +absDnInPlaceEffFromInPlace = mutable1EffToPure absDnInPlaceEff + +propUpDnAbsInPlace :: + (NumOrd.PartialComparison t, + RoundedAbsInPlace t, RoundedAbs t, + Neg t, + Show t, HasLegalValues t, + Show (AbsEffortIndicator t), + EffortIndicator (AbsEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + AbsEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Bool +propUpDnAbsInPlace sample initEffort (NumOrd.UniformlyOrderedSingleton e1) = + equalRoundingUpDn "in-place rounded abs" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + absUpEffViaInPlace = mutable1EffToPure absUpInPlaceEff + absDnEffViaInPlace = mutable1EffToPure absDnInPlaceEff + expr1Up eff = absUpEff eff e1 + expr1Dn eff = absDnEff eff e1 + expr2Up eff = absUpEffViaInPlace eff e1 + expr2Dn eff = absDnEffViaInPlace eff e1 + +class (RoundedMultiplyEffort t, CanBeMutable t) => RoundedMultiplyInPlace t where + multUpInPlaceEff :: OpMutable2Eff (MultEffortIndicator t) t s + multDnInPlaceEff :: OpMutable2Eff (MultEffortIndicator t) t s + +multUpInPlaceEffFromPure, + multDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedMultiply t) => + OpMutable2Eff (MultEffortIndicator t) t s +multUpInPlaceEffFromPure = pureToMutable2Eff multUpEff +multDnInPlaceEffFromPure = pureToMutable2Eff multDnEff + +multUpInPlaceEffFromInPlace, + multDnInPlaceEffFromInPlace :: + (RoundedMultiplyInPlace t) => + (MultEffortIndicator t) -> t -> t -> t +multUpInPlaceEffFromInPlace = mutable2EffToPure multUpInPlaceEff +multDnInPlaceEffFromInPlace = mutable2EffToPure multDnInPlaceEff + +propUpDnMultInPlace :: + (NumOrd.PartialComparison t, + RoundedMultiplyInPlace t, RoundedMultiply t, + Neg t, + Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + MultEffortIndicator t) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propUpDnMultInPlace sample initEffort (NumOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "in-place rounded multiplication" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + multUpEffViaInPlace = mutable2EffToPure multUpInPlaceEff + multDnEffViaInPlace = mutable2EffToPure multDnInPlaceEff + expr1Up eff = + let (*^) = multUpEff eff in e1 *^ e2 + expr1Dn eff = + let (*.) = multDnEff eff in e1 *. e2 + expr2Up eff = + let (*^) = multUpEffViaInPlace eff in e1 *^ e2 + expr2Dn eff = + let (*.) = multDnEffViaInPlace eff in e1 *. e2 + +class (RoundedPowerNonnegToNonnegIntEffort t, CanBeMutable t) => + RoundedPowerNonnegToNonnegIntInPlace t + where + powerNonnegToNonnegIntUpInPlaceEff :: + OpMutableNonmutEff (PowerNonnegToNonnegIntEffortIndicator t) t Int s + powerNonnegToNonnegIntDnInPlaceEff :: + OpMutableNonmutEff (PowerNonnegToNonnegIntEffortIndicator t) t Int s + -- default implementations, do not use these if the RoundedPowerNonnegToNonnegInt + -- instance uses the ...fromMult implementation; + -- in such cases override this implementation with the ...fromMult implementation below + -- for improved efficiency + +powerNonnegToNonnegIntUpInPlaceEffFromPure, + powerNonnegToNonnegIntDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedPowerNonnegToNonnegInt t) => + OpMutableNonmutEff (PowerNonnegToNonnegIntEffortIndicator t) t Int s +powerNonnegToNonnegIntUpInPlaceEffFromPure = + pureToMutableNonmutEff powerNonnegToNonnegIntUpEff +powerNonnegToNonnegIntDnInPlaceEffFromPure = + pureToMutableNonmutEff powerNonnegToNonnegIntDnEff + +powerNonnegToNonnegIntUpInPlaceEffFromInPlace, + powerNonnegToNonnegIntDnInPlaceEffFromInPlace :: + (RoundedPowerNonnegToNonnegIntInPlace t) => + (PowerNonnegToNonnegIntEffortIndicator t) -> t -> Int -> t +powerNonnegToNonnegIntUpInPlaceEffFromInPlace = + mutableNonmutEffToPure powerNonnegToNonnegIntUpInPlaceEff +powerNonnegToNonnegIntDnInPlaceEffFromInPlace = + mutableNonmutEffToPure powerNonnegToNonnegIntDnInPlaceEff + +powerNonnegToNonnegIntUpInPlaceEffFromMult :: + (RoundedMultiplyInPlace t, HasOne t) => + OpMutableNonmutEff (PowerNonnegToNonnegIntEffortIndicatorFromMult t) t Int s +powerNonnegToNonnegIntUpInPlaceEffFromMult effMult rM eM n = + powerFromMultInPlace (multUpInPlaceEff effMult) rM eM n + +powerNonnegToNonnegIntDnInPlaceEffFromMult :: + (RoundedMultiplyInPlace t, HasOne t) => + OpMutableNonmutEff (PowerNonnegToNonnegIntEffortIndicatorFromMult t) t Int s +powerNonnegToNonnegIntDnInPlaceEffFromMult effMult rM eM n = + powerFromMultInPlace (multDnInPlaceEff effMult) rM eM n + + +class (RoundedPowerToNonnegIntEffort t, CanBeMutable t) => + RoundedPowerToNonnegIntInPlace t + where + powerToNonnegIntUpInPlaceEff :: + OpMutableNonmutEff (PowerToNonnegIntEffortIndicator t) t Int s + powerToNonnegIntDnInPlaceEff :: + OpMutableNonmutEff (PowerToNonnegIntEffortIndicator t) t Int s + +powerToNonnegIntUpInPlaceEffFromPure, + powerToNonnegIntDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedPowerToNonnegInt t) => + OpMutableNonmutEff (PowerToNonnegIntEffortIndicator t) t Int s +powerToNonnegIntUpInPlaceEffFromPure = + pureToMutableNonmutEff powerToNonnegIntUpEff +powerToNonnegIntDnInPlaceEffFromPure = + pureToMutableNonmutEff powerToNonnegIntDnEff + +powerToNonnegIntUpInPlaceEffFromInPlace, + powerToNonnegIntDnInPlaceEffFromInPlace :: + (RoundedPowerToNonnegIntInPlace t) => + (PowerToNonnegIntEffortIndicator t) -> t -> Int -> t +powerToNonnegIntUpInPlaceEffFromInPlace = + mutableNonmutEffToPure powerToNonnegIntUpInPlaceEff +powerToNonnegIntDnInPlaceEffFromInPlace = + mutableNonmutEffToPure powerToNonnegIntDnInPlaceEff + +propUpDnPowerToNonnegInPlace :: + (NumOrd.PartialComparison t, + RoundedPowerToNonnegIntInPlace t, + RoundedPowerToNonnegInt t, + Neg t, + Show t, HasLegalValues t, + Show (PowerToNonnegIntEffortIndicator t), + EffortIndicator (PowerToNonnegIntEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + PowerToNonnegIntEffortIndicator t) -> + (NumOrd.UniformlyOrderedSingleton t) -> + Int -> Bool +propUpDnPowerToNonnegInPlace sample initEffort + (NumOrd.UniformlyOrderedSingleton e1) n = + equalRoundingUpDn "in-place rounded non-neg integer power" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + powerToNonnegIntUpEffViaInPlace = + mutableNonmutEffToPure powerToNonnegIntUpInPlaceEff + powerToNonnegIntDnEffViaInPlace = + mutableNonmutEffToPure powerToNonnegIntDnInPlaceEff + expr1Up eff = + let (^^) = powerToNonnegIntUpEff eff in e1 ^^ n + expr1Dn eff = + let (^.) = powerToNonnegIntDnEff eff in e1 ^. n + expr2Up eff = + let (^^) = powerToNonnegIntUpEffViaInPlace eff in e1 ^^ n + expr2Dn eff = + let (^.) = powerToNonnegIntDnEffViaInPlace eff in e1 ^. n + +class (HasOne t, RoundedDivideEffort t, CanBeMutable t) => + RoundedDivideInPlace t + where + divUpInPlaceEff :: OpMutable2Eff (DivEffortIndicator t) t s + divDnInPlaceEff :: OpMutable2Eff (DivEffortIndicator t) t s + recipUpInPlaceEff :: OpMutable1Eff (DivEffortIndicator t) t s + recipDnInPlaceEff :: OpMutable1Eff (DivEffortIndicator t) t s + + recipUpInPlaceEff effort resM aM = + do + oneM <- unsafeMakeMutable one + divUpInPlaceEff effort resM oneM aM + recipDnInPlaceEff effort resM aM = + do + oneM <- unsafeMakeMutable one + divDnInPlaceEff effort resM oneM aM + +divUpInPlaceEffFromPure, + divDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedDivide t) => + OpMutable2Eff (DivEffortIndicator t) t s +divUpInPlaceEffFromPure = pureToMutable2Eff divUpEff +divDnInPlaceEffFromPure = pureToMutable2Eff divDnEff + +divUpInPlaceEffFromInPlace, + divDnInPlaceEffFromInPlace :: + (RoundedDivideInPlace t) => + (DivEffortIndicator t) -> t -> t -> t +divUpInPlaceEffFromInPlace = mutable2EffToPure divUpInPlaceEff +divDnInPlaceEffFromInPlace = mutable2EffToPure divDnInPlaceEff + +recipUpInPlaceEffFromPure, + recipDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedDivide t) => + OpMutable1Eff (DivEffortIndicator t) t s +recipUpInPlaceEffFromPure = pureToMutable1Eff recipUpEff +recipDnInPlaceEffFromPure = pureToMutable1Eff recipDnEff + +recipUpInPlaceEffFromInPlace, + recipDnInPlaceEffFromInPlace :: + (RoundedDivideInPlace t) => + (DivEffortIndicator t) -> t -> t +recipUpInPlaceEffFromInPlace = mutable1EffToPure recipUpInPlaceEff +recipDnInPlaceEffFromInPlace = mutable1EffToPure recipDnInPlaceEff + +propUpDnDivInPlace :: + (NumOrd.PartialComparison t, + RoundedDivideInPlace t, RoundedDivide t, + Neg t, + Show t, HasZero t, HasLegalValues t, + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> + (NumOrd.PartialCompareEffortIndicator t, + DivEffortIndicator t) -> + (NumOrd.UniformlyOrderedPair t) -> + Bool +propUpDnDivInPlace sample initEffort@(effComp, _) (NumOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "in-place rounded division" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + divUpEffViaInPlace = mutable2EffToPure divUpInPlaceEff + divDnEffViaInPlace = mutable2EffToPure divDnInPlaceEff + expr1Up eff = + let (/^) = divUpEff eff in e1 /^ e2 + expr1Dn eff = + let (/.) = divDnEff eff in e1 /. e2 + expr2Up eff = + let (/^) = divUpEffViaInPlace eff in e1 /^ e2 + expr2Dn eff = + let (/.) = divDnEffViaInPlace eff in e1 /. e2 + +testsUpDnFieldOpsInPlace (name, sample) = + testGroup (name ++ " in-place up/down rounded ops match pure ops") $ + [ + testProperty "addition" (propUpDnAddInPlace sample) + , + testProperty "subtraction" (propUpDnSubtrInPlace sample) + , + testProperty "absolute value" (propUpDnAbsInPlace sample) + , + testProperty "multiplication" (propUpDnMultInPlace sample) + , + testProperty "integer power" (propUpDnMultInPlace sample) + , + testProperty "division" (propUpDnDivInPlace sample) + ] + + +class + (RoundedSubtrInPlace t, + RoundedMultiplyInPlace t, + RoundedRingEffort t) => + RoundedRingInPlace t + +class + (RoundedRingInPlace t, + RoundedDivideInPlace t, + RoundedFieldEffort t) => + RoundedFieldInPlace t + + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/MixedFieldOps.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/MixedFieldOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/MixedFieldOps.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.MixedFieldOps + Description : rounded basic arithmetic operations mixing 2 types + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + In-place versions of rounded basic arithmetical operations mixing 2 types. + + This module is hidden and reexported via its parent "NumericOrderRounding.InPlace". +-} +module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.MixedFieldOps where + +import Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps + +import Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion +import Numeric.AERN.RealArithmetic.ExactOps + +import Numeric.AERN.Basics.Exception +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.Basics.Effort +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import Control.Monad.ST +import Control.Exception +import Data.Maybe + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class (RoundedMixedAddEffort t tn, CanBeMutable t) => RoundedMixedAddInPlace t tn where + mixedAddUpInPlaceEff :: + OpMutableNonmutEff (MixedAddEffortIndicator t tn) t tn s + mixedAddDnInPlaceEff :: + OpMutableNonmutEff (MixedAddEffortIndicator t tn) t tn s + +mixedAddUpInPlaceEffFromPure, + mixedAddDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedMixedAdd t tn) => + OpMutableNonmutEff (MixedAddEffortIndicator t tn) t tn s +mixedAddUpInPlaceEffFromPure = + pureToMutableNonmutEff mixedAddUpEff +mixedAddDnInPlaceEffFromPure = + pureToMutableNonmutEff mixedAddDnEff + +mixedAddUpInPlaceEffFromInPlace, + mixedAddDnInPlaceEffFromInPlace :: + (RoundedMixedAddInPlace t tn) => + (MixedAddEffortIndicator t tn) -> t -> tn -> t +mixedAddUpInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedAddUpInPlaceEff +mixedAddDnInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedAddDnInPlaceEff + +-- an alternative default implementation using conversion +-- - this could be more efficient + +mixedAddUpInPlaceEffByConversion :: + (Convertible tn t, RoundedAddInPlace t, Show tn) => + OpMutableNonmutEff (AddEffortIndicator t, ConvertEffortIndicator tn t) t tn s +mixedAddUpInPlaceEffByConversion (effAdd, effConv) rM dM n = + do + nUpM <- makeMutable nUp + addUpInPlaceEff effAdd rM dM nUpM + where + nUp = + case convertUpEff effConv n of + (Just nUp) -> nUp + _ -> throw $ AERNException $ + "conversion failed during mixed addition: n = " ++ show n + +mixedAddDnInPlaceEffByConversion :: + (Convertible tn t, RoundedAddInPlace t, Show tn) => + OpMutableNonmutEff (AddEffortIndicator t, ConvertEffortIndicator tn t) t tn s +mixedAddDnInPlaceEffByConversion (effAdd, effConv) rM dM n = + do + nDnM <- makeMutable nDn + addDnInPlaceEff effAdd rM dM nDnM + where + nDn = + case convertDnEff effConv n of + (Just nDn) -> nDn + _ -> throw $ AERNException $ + "conversion failed during mixed addition: n = " ++ show n + + +{- properties of mixed addition -} + +propMixedAddInPlaceEqualsConvert :: + (NumOrd.PartialComparison t, Convertible tn t, + RoundedMixedAddInPlace t tn, + RoundedMixedAdd t tn, + RoundedAdd t, + Show t, HasLegalValues t, + Show (MixedAddEffortIndicator t tn), + EffortIndicator (MixedAddEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (NumOrd.PartialCompareEffortIndicator t, + (MixedAddEffortIndicator t tn, + AddEffortIndicator t, + ConvertEffortIndicator tn t)) -> + (NumOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedAddInPlaceEqualsConvert sample1 sample2 initEffort + (NumOrd.UniformlyOrderedSingleton d) n = + equalRoundingUpDn "in-place rounded mixed addition" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMAdd,_,_) = + let (+^|=) dR = mixedAddUpInPlaceEff effMAdd dR dR in + runST $ + do + dR <- makeMutable d + dR +^|= n + unsafeReadMutable dR + expr1Dn (effMAdd,_,_) = + let (+.|=) dR = mixedAddDnInPlaceEff effMAdd dR dR in + runST $ + do + dR <- makeMutable d + dR +.|= n + unsafeReadMutable dR + expr2Up (_,effAdd,effConv) = + let (+^) = addUpEff effAdd in (fromJust $ convertUpEff effConv n) +^ d + expr2Dn (_,effAdd,effConv) = + let (+.) = addDnEff effAdd in (fromJust $ convertDnEff effConv n) +. d + + + +class (RoundedMixedMultiplyEffort t tn, CanBeMutable t) => RoundedMixedMultiplyInPlace t tn where + mixedMultUpInPlaceEff :: + OpMutableNonmutEff (MixedMultEffortIndicator t tn) t tn s + mixedMultDnInPlaceEff :: + OpMutableNonmutEff (MixedMultEffortIndicator t tn) t tn s + +mixedMultUpInPlaceEffFromPure, + mixedMultDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedMixedMultiply t tn) => + OpMutableNonmutEff (MixedMultEffortIndicator t tn) t tn s +mixedMultUpInPlaceEffFromPure = + pureToMutableNonmutEff mixedMultUpEff +mixedMultDnInPlaceEffFromPure = + pureToMutableNonmutEff mixedMultDnEff + +mixedMultUpInPlaceEffFromInPlace, + mixedMultDnInPlaceEffFromInPlace :: + (RoundedMixedMultiplyInPlace t tn) => + (MixedMultEffortIndicator t tn) -> t -> tn -> t +mixedMultUpInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedMultUpInPlaceEff +mixedMultDnInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedMultDnInPlaceEff + +{- properties of mixed multiplication -} + +propMixedMultInPlaceEqualsConvert :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + Convertible tn t, + RoundedMixedMultiplyInPlace t tn, + RoundedMixedMultiply t tn, + RoundedMultiply t, + Show t, HasLegalValues t, + Show (MixedMultEffortIndicator t tn), + EffortIndicator (MixedMultEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.MinmaxEffortIndicator t), + EffortIndicator (NumOrd.MinmaxEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (NumOrd.PartialCompareEffortIndicator t, + (MixedMultEffortIndicator t tn, + (MultEffortIndicator t, + ConvertEffortIndicator tn t, + NumOrd.MinmaxEffortIndicator t))) -> + (NumOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedMultInPlaceEqualsConvert sample1 sample2 initEffort + (NumOrd.UniformlyOrderedSingleton d) n = + equalRoundingUpDn "in-place rounded mixed multiplication" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMMult,_) = + let (*^|=) dR = mixedMultUpInPlaceEff effMMult dR dR in + runST $ + do + dR <- makeMutable d + dR *^|= n + unsafeReadMutable dR + expr1Dn (effMMult,_) = + let (*.|=) dR = mixedMultDnInPlaceEff effMMult dR dR in + runST $ + do + dR <- makeMutable d + dR *.|= n + unsafeReadMutable dR + expr2Up (_,(effMult,effConv,effMinmax)) = + let (*^) = multUpEff effMult in + NumOrd.maxUpEff effMinmax + (d *^ (fromJust $ convertUpEff effConv n)) + (d *^ (fromJust $ convertDnEff effConv n)) + expr2Dn (_,(effMult,effConv,effMinmax)) = + let (*.) = multDnEff effMult in + NumOrd.minDnEff effMinmax + (d *. (fromJust $ convertUpEff effConv n)) + (d *. (fromJust $ convertDnEff effConv n)) + +class (RoundedMixedDivide t tn, CanBeMutable t) => RoundedMixedDivideInPlace t tn where + mixedDivUpInPlaceEff :: + OpMutableNonmutEff (MixedDivEffortIndicator t tn) t tn s + mixedDivDnInPlaceEff :: + OpMutableNonmutEff (MixedDivEffortIndicator t tn) t tn s + +mixedDivUpInPlaceEffFromPure, + mixedDivDnInPlaceEffFromPure :: + (CanBeMutable t, RoundedMixedDivide t tn) => + OpMutableNonmutEff (MixedDivEffortIndicator t tn) t tn s +mixedDivUpInPlaceEffFromPure = + pureToMutableNonmutEff mixedDivUpEff +mixedDivDnInPlaceEffFromPure = + pureToMutableNonmutEff mixedDivDnEff + +mixedDivUpInPlaceEffFromInPlace, + mixedDivDnInPlaceEffFromInPlace :: + (RoundedMixedDivideInPlace t tn) => + (MixedDivEffortIndicator t tn) -> t -> tn -> t +mixedDivUpInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedDivUpInPlaceEff +mixedDivDnInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedDivDnInPlaceEff + +{- properties of mixed division -} + +propMixedDivInPlaceEqualsConvert :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + Convertible tn t, + RoundedMixedDivideInPlace t tn, + RoundedMixedDivide t tn, + RoundedDivide t, + Show t, HasZero t, HasLegalValues t, + Show (MixedDivEffortIndicator t tn), + EffortIndicator (MixedDivEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (NumOrd.MinmaxEffortIndicator t), + EffortIndicator (NumOrd.MinmaxEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (NumOrd.PartialCompareEffortIndicator t, + (MixedDivEffortIndicator t tn, + (DivEffortIndicator t, + ConvertEffortIndicator tn t, + NumOrd.MinmaxEffortIndicator t))) -> + (NumOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedDivInPlaceEqualsConvert sample1 sample2 + initEffort@(effComp,(_,(_,effConv,_))) + (NumOrd.UniformlyOrderedSingleton d) n + = + equalRoundingUpDn "in-place rounded mixed division" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMDiv,_) = + let (/^|=) dR = mixedDivUpInPlaceEff effMDiv dR dR in + runST $ + do + dR <- makeMutable d + dR /^|= n + unsafeReadMutable dR + expr1Dn (effMDiv,_) = + let (/.|=) dR = mixedDivDnInPlaceEff effMDiv dR dR in + runST $ + do + dR <- makeMutable d + dR /.|= n + unsafeReadMutable dR + expr2Up (_,(effDiv,effConv,effMinmax)) = + let (/^) = divUpEff effDiv in + NumOrd.maxUpEff effMinmax + (d /^ (fromJust $ convertUpEff effConv n)) + (d /^ (fromJust $ convertDnEff effConv n)) + expr2Dn (_,(effDiv,effConv,effMinmax)) = + let (/.) = divDnEff effDiv in + NumOrd.minDnEff effMinmax + (d /. (fromJust $ convertUpEff effConv n)) + (d /. (fromJust $ convertDnEff effConv n)) + +testsUpDnMixedFieldOpsInPlace (name, sample) (nameN, sampleN) = + testGroup (name ++ " with " ++ nameN ++ ": in-place mixed up/dn rounded ops") $ + [ + testProperty "addition" (propMixedAddInPlaceEqualsConvert sample sampleN) + , + testProperty "multiplication" (propMixedMultInPlaceEqualsConvert sample sampleN) + , + testProperty "division" (propMixedDivInPlaceEqualsConvert sample sampleN) + ] + +class + (RoundedMixedAddInPlace t tn, + RoundedMixedMultiplyInPlace t tn, + RoundedMixedRingEffort t tn) => + RoundedMixedRingInPlace t tn + +class + (RoundedMixedRingInPlace t tn, + RoundedMixedDivideInPlace t tn, + RoundedMixedFieldEffort t tn) => + RoundedMixedFieldInPlace t tn + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/OpsDefaultEffort.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/OpsDefaultEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/OpsDefaultEffort.hs @@ -0,0 +1,191 @@ +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.OpsDefaultEffort + Description : convenience in-place operators and functions with default effort + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Convenience in-place operators and functions with default effort. +-} + +module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.OpsDefaultEffort where + +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.NumericOrderRounding + +-- | Upward rounded in-place addition +addUpInPlace :: (RoundedAddInPlace t) => OpMutable2 t s +addUpInPlace = mutable2EffToMutable2 addUpInPlaceEff addDefaultEffort + +-- | Upward rounded addition assignment +(+^=) :: (RoundedAddInPlace t) => OpMutable1 t s +(+^=) = mutable2ToMutable1 addUpInPlace + +-- | Downward rounded in-place addition +addDnInPlace :: (RoundedAddInPlace t) => OpMutable2 t s +addDnInPlace = mutable2EffToMutable2 addDnInPlaceEff addDefaultEffort + +-- | Downward rounded addition assignment +(+.=) :: (RoundedAddInPlace t) => OpMutable1 t s +(+.=) = mutable2ToMutable1 addDnInPlace + +-- | Upward rounded in-place subtraction +subtrUpInPlace :: (RoundedSubtrInPlace t) => OpMutable2 t s +subtrUpInPlace = mutable2EffToMutable2 subtrUpInPlaceEff addDefaultEffort + +-- | Upward rounded subtraction assignment +(-^=) :: (RoundedSubtrInPlace t) => OpMutable1 t s +(-^=) = mutable2ToMutable1 subtrUpInPlace + +-- | Downward rounded in-place subtraction +subtrDnInPlace :: (RoundedSubtrInPlace t) => OpMutable2 t s +subtrDnInPlace = mutable2EffToMutable2 subtrDnInPlaceEff addDefaultEffort + +-- | Downward rounded subtraction assignment +(-.=) :: (RoundedSubtrInPlace t) => OpMutable1 t s +(-.=) = mutable2ToMutable1 subtrDnInPlace + +-- | Upward rounded in-place absolute value +absUpInPlace :: (RoundedAbsInPlace t) => OpMutable1 t s +absUpInPlace = mutable1EffToMutable1 absUpInPlaceEff absDefaultEffort + +-- | Downward rounded in-place absolute value +absDnInPlace :: (RoundedAbsInPlace t) => OpMutable1 t s +absDnInPlace = mutable1EffToMutable1 absDnInPlaceEff absDefaultEffort + +-- | Upward rounded in-place multiplication +multUpInPlace :: (RoundedMultiplyInPlace t) => OpMutable2 t s +multUpInPlace = mutable2EffToMutable2 multUpInPlaceEff multDefaultEffort + +-- | Upward rounded multiplication assignment +(*^=) :: (RoundedMultiplyInPlace t) => OpMutable1 t s +(*^=) = mutable2ToMutable1 multUpInPlace + +-- | Downward rounded in-place multiplication +multDnInPlace :: (RoundedMultiplyInPlace t) => OpMutable2 t s +multDnInPlace = mutable2EffToMutable2 multDnInPlaceEff multDefaultEffort + +-- | Downward rounded multiplication assignment +(*.=) :: (RoundedMultiplyInPlace t) => OpMutable1 t s +(*.=) = mutable2ToMutable1 multDnInPlace + +-- | Upward rounded in-place power +powerToNonnegIntUpInPlace :: (RoundedPowerToNonnegIntInPlace t) => + OpMutableNonmut t Int s +powerToNonnegIntUpInPlace = + mutableNonmutEffToMutableNonmut powerToNonnegIntUpInPlaceEff powerToNonnegIntDefaultEffort + +-- | Upward rounded in-place power assignment +(^^=) :: (RoundedPowerToNonnegIntInPlace t) => OpNonmut t Int s +(^^=) = mutableNonmutToNonmut powerToNonnegIntUpInPlace + +-- | Downward rounded in-place power +powerToNonnegIntDnInPlace :: (RoundedPowerToNonnegIntInPlace t) => + OpMutableNonmut t Int s +powerToNonnegIntDnInPlace = + mutableNonmutEffToMutableNonmut powerToNonnegIntDnInPlaceEff powerToNonnegIntDefaultEffort + +-- | Upward rounded in-place power assignment +(^.=) :: (RoundedPowerToNonnegIntInPlace t) => OpNonmut t Int s +(^.=) = mutableNonmutToNonmut powerToNonnegIntDnInPlace + +-- | Upward rounded in-place division +divUpInPlace :: (RoundedDivideInPlace t) => OpMutable2 t s +divUpInPlace = mutable2EffToMutable2 divUpInPlaceEff divDefaultEffort + +-- | Upward rounded division assignment +(/^=) :: (RoundedDivideInPlace t) => OpMutable1 t s +(/^=) = mutable2ToMutable1 divUpInPlace + +-- | Downward rounded in-place division +divDnInPlace :: (RoundedDivideInPlace t) => OpMutable2 t s +divDnInPlace = mutable2EffToMutable2 divDnInPlaceEff divDefaultEffort + +-- | Downward rounded division assignment +(/.=) :: (RoundedDivideInPlace t) => OpMutable1 t s +(/.=) = mutable2ToMutable1 divDnInPlace + +-- | Upward rounded in-place mixed addition +mixedAddUpInPlace :: (RoundedMixedAddInPlace t tn) => + OpMutableNonmut t tn s +mixedAddUpInPlace = + mixedEffToMutableNonmut mixedAddUpInPlaceEff mixedAddDefaultEffort + +-- | Upward rounded additive scalar action assignment +(+^|=) :: (RoundedMixedAddInPlace t tn) => OpNonmut t tn s +(+^|=) = mutableNonmutToNonmut mixedAddUpInPlace + +-- | Downward rounded in-place mixed addition +mixedAddDnInPlace :: (RoundedMixedAddInPlace t tn) => + OpMutableNonmut t tn s +mixedAddDnInPlace = + mixedEffToMutableNonmut mixedAddDnInPlaceEff mixedAddDefaultEffort + +-- | Downward rounded additive scalar action assignment +(+.|=) :: (RoundedMixedAddInPlace t tn) => OpNonmut t tn s +(+.|=) = mutableNonmutToNonmut mixedAddDnInPlace + +-- | Upward rounded in-place mixed multiplication +mixedMultUpInPlace :: (RoundedMixedMultiplyInPlace t tn) => + OpMutableNonmut t tn s +mixedMultUpInPlace = + mixedEffToMutableNonmut mixedMultUpInPlaceEff mixedMultDefaultEffort + +-- | Upward rounded multiplicative scalar action assignment +(*^|=) :: (RoundedMixedMultiplyInPlace t tn) => OpNonmut t tn s +(*^|=) = mutableNonmutToNonmut mixedMultUpInPlace + +-- | Downward rounded in-place mixed multiplication +mixedMultDnInPlace :: (RoundedMixedMultiplyInPlace t tn) => + OpMutableNonmut t tn s +mixedMultDnInPlace = + mixedEffToMutableNonmut mixedMultDnInPlaceEff mixedMultDefaultEffort + +-- | Downward rounded multiplicative scalar action assignment +(*.|=) :: (RoundedMixedMultiplyInPlace t tn) => OpNonmut t tn s +(*.|=) = mutableNonmutToNonmut mixedMultDnInPlace + +-- | Upward rounded in-place mixed reciprocal action +mixedDivUpInPlace :: (RoundedMixedDivideInPlace t tn) => + OpMutableNonmut t tn s +mixedDivUpInPlace = + mixedEffToMutableNonmut mixedDivUpInPlaceEff mixedDivDefaultEffort + +-- | Upward rounded multiplicative scalar reciprocal action assignment +(/^|=) :: (RoundedMixedDivideInPlace t tn) => OpNonmut t tn s +(/^|=) = mutableNonmutToNonmut mixedDivUpInPlace + +-- | Downward rounded in-place mixed reciprocal action +mixedDivDnInPlace :: (RoundedMixedDivideInPlace t tn) => + OpMutableNonmut t tn s +mixedDivDnInPlace = + mixedEffToMutableNonmut mixedDivDnInPlaceEff mixedDivDefaultEffort + +-- | Downward rounded multiplicative scalar reciprocal action assignment +(/.|=) :: (RoundedMixedDivideInPlace t tn) => OpNonmut t tn s +(/.|=) = mutableNonmutToNonmut mixedDivDnInPlace + +-- | Upward rounded in-place exponential +expUpInPlace :: (RoundedExponentiationInPlace t) => OpMutable1 t s +expUpInPlace = mutable1EffToMutable1 expUpInPlaceEff expDefaultEffort + +-- | Downward rounded in-place exponential +expDnInPlace :: (RoundedExponentiationInPlace t) => OpMutable1 t s +expDnInPlace = mutable1EffToMutable1 expDnInPlaceEff expDefaultEffort + +-- | Upward rounded in-place square root +sqrtUpInPlace :: (RoundedSquareRootInPlace t) => OpMutable1 t s +sqrtUpInPlace = mutable1EffToMutable1 sqrtUpInPlaceEff sqrtDefaultEffort + +-- | Downward rounded in-place square root +sqrtDnInPlace :: (RoundedSquareRootInPlace t) => OpMutable1 t s +sqrtDnInPlace = mutable1EffToMutable1 sqrtDnInPlaceEff sqrtDefaultEffort + + + + + + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/OpsImplicitEffort.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/OpsImplicitEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/InPlace/OpsImplicitEffort.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.OpsImplicitEffort + Description : convenience directed-rounded in-place operators and functions with implicit effort parameters + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Convenience directed-rounded in-place operators and functions with implicit effort parameters. +-} + +module Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.OpsImplicitEffort where + +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.NumericOrderRounding + +-- | Upward rounded in-place addition +addUpInPlace :: + (RoundedAddInPlace t, ?addUpDnEffort :: AddEffortIndicator t) => + OpMutable2 t s +addUpInPlace = addUpInPlaceEff ?addUpDnEffort + +-- | Upward rounded addition assignment +(+^=) :: + (RoundedAddInPlace t, ?addUpDnEffort :: AddEffortIndicator t) => + OpMutable1 t s +(+^=) = mutable2ToMutable1 addUpInPlace + +-- | Downward rounded in-place addition +addDnInPlace :: + (RoundedAddInPlace t, ?addUpDnEffort :: AddEffortIndicator t) => + OpMutable2 t s +addDnInPlace = addDnInPlaceEff ?addUpDnEffort + +-- | Downward rounded addition assignment +(+.=) :: + (RoundedAddInPlace t, ?addUpDnEffort :: AddEffortIndicator t) => + OpMutable1 t s +(+.=) = mutable2ToMutable1 addDnInPlace + +-- | Upward rounded in-place subtraction +subtrUpInPlace :: + (RoundedSubtrInPlace t, ?addUpDnEffort :: AddEffortIndicator t) => + OpMutable2 t s +subtrUpInPlace = subtrUpInPlaceEff ?addUpDnEffort + +-- | Upward rounded subtraction assignment +(-^=) :: + (RoundedSubtrInPlace t, ?addUpDnEffort :: AddEffortIndicator t) => + OpMutable1 t s +(-^=) = mutable2ToMutable1 subtrUpInPlace + +-- | Downward rounded in-place subtraction +subtrDnInPlace :: + (RoundedSubtrInPlace t, ?addUpDnEffort :: AddEffortIndicator t) => + OpMutable2 t s +subtrDnInPlace = subtrDnInPlaceEff ?addUpDnEffort + +-- | Downward rounded subtraction assignment +(-.=) :: + (RoundedSubtrInPlace t, ?addUpDnEffort :: AddEffortIndicator t) => + OpMutable1 t s +(-.=) = mutable2ToMutable1 subtrDnInPlace + +-- | Upward rounded in-place absolute value +absUpInPlace :: + (RoundedAbsInPlace t, ?absUpDnEffort :: AbsEffortIndicator t) => + OpMutable1 t s +absUpInPlace = absUpInPlaceEff ?absUpDnEffort + +-- | Downward rounded in-place absolute value +absDnInPlace :: + (RoundedAbsInPlace t, ?absUpDnEffort :: AbsEffortIndicator t) => + OpMutable1 t s +absDnInPlace = absDnInPlaceEff ?absUpDnEffort + +-- | Upward rounded in-place multiplication +multUpInPlace :: + (RoundedMultiplyInPlace t, ?multUpDnEffort :: MultEffortIndicator t) => + OpMutable2 t s +multUpInPlace = multUpInPlaceEff ?multUpDnEffort + +-- | Upward rounded multiplication assignment +(*^=) :: + (RoundedMultiplyInPlace t, ?multUpDnEffort :: MultEffortIndicator t) => + OpMutable1 t s +(*^=) = mutable2ToMutable1 multUpInPlace + +-- | Downward rounded in-place multiplication +multDnInPlace :: + (RoundedMultiplyInPlace t, ?multUpDnEffort :: MultEffortIndicator t) => + OpMutable2 t s +multDnInPlace = multDnInPlaceEff ?multUpDnEffort + +-- | Downward rounded multiplication assignment +(*.=) :: + (RoundedMultiplyInPlace t, ?multUpDnEffort :: MultEffortIndicator t) => + OpMutable1 t s +(*.=) = mutable2ToMutable1 multDnInPlace + +-- | Upward rounded in-place power +powerToNonnegIntUpInPlace :: + (RoundedPowerToNonnegIntInPlace t, + ?intPowerUpDnEffort :: PowerToNonnegIntEffortIndicator t) => + OpMutableNonmut t Int s +powerToNonnegIntUpInPlace = powerToNonnegIntUpInPlaceEff ?intPowerUpDnEffort + +-- | Upward rounded in-place power assignment +(^^=) :: + (RoundedPowerToNonnegIntInPlace t, + ?intPowerUpDnEffort :: PowerToNonnegIntEffortIndicator t) => + OpNonmut t Int s +(^^=) = mutableNonmutToNonmut powerToNonnegIntUpInPlace + +-- | Downward rounded in-place power +powerToNonnegIntDnInPlace :: + (RoundedPowerToNonnegIntInPlace t, + ?intPowerUpDnEffort :: PowerToNonnegIntEffortIndicator t) => + OpMutableNonmut t Int s +powerToNonnegIntDnInPlace = powerToNonnegIntDnInPlaceEff ?intPowerUpDnEffort + +-- | Upward rounded in-place power assignment +(^.=) :: + (RoundedPowerToNonnegIntInPlace t, + ?intPowerUpDnEffort :: PowerToNonnegIntEffortIndicator t) => + OpNonmut t Int s +(^.=) = mutableNonmutToNonmut powerToNonnegIntDnInPlace + +-- | Upward rounded in-place division +divUpInPlace :: + (RoundedDivideInPlace t, ?divUpDnEffort :: DivEffortIndicator t) => + OpMutable2 t s +divUpInPlace = divUpInPlaceEff ?divUpDnEffort + +-- | Upward rounded division assignment +(/^=) :: + (RoundedDivideInPlace t, ?divUpDnEffort :: DivEffortIndicator t) => + OpMutable1 t s +(/^=) = mutable2ToMutable1 divUpInPlace + +-- | Downward rounded in-place division +divDnInPlace :: + (RoundedDivideInPlace t, ?divUpDnEffort :: DivEffortIndicator t) => + OpMutable2 t s +divDnInPlace = divDnInPlaceEff ?divUpDnEffort + +-- | Downward rounded division assignment +(/.=) :: + (RoundedDivideInPlace t, ?divUpDnEffort :: DivEffortIndicator t) => + OpMutable1 t s +(/.=) = mutable2ToMutable1 divDnInPlace + +-- the following does not work, but is kept here as a template for +-- cut and pasting the "let"s +withFieldOpsEffortIndicator effortField expression = + let ?addUpDnEffort = fldEffortAdd effortField in + let ?multUpDnEffort = fldEffortMult effortField in + let ?intPowerUpDnEffort = fldEffortPow effortField in + let ?divUpDnEffort = fldEffortDiv effortField in + expression + +-- | Upward rounded in-place mixed addition +mixedAddUpInPlace :: + (RoundedMixedAddInPlace t tn, + ?mixedAddUpDnEffort :: MixedAddEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedAddUpInPlace = mixedAddUpInPlaceEff ?mixedAddUpDnEffort + +-- | Upward rounded additive scalar action assignment +(+^|=) :: + (RoundedMixedAddInPlace t tn, + ?mixedAddUpDnEffort :: MixedAddEffortIndicator t tn) => + OpNonmut t tn s +(+^|=) = mutableNonmutToNonmut mixedAddUpInPlace + +-- | Downward rounded in-place mixed addition +mixedAddDnInPlace :: + (RoundedMixedAddInPlace t tn, + ?mixedAddUpDnEffort :: MixedAddEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedAddDnInPlace = mixedAddDnInPlaceEff ?mixedAddUpDnEffort + +-- | Downward rounded additive scalar action assignment +(+.|=) :: + (RoundedMixedAddInPlace t tn, + ?mixedAddUpDnEffort :: MixedAddEffortIndicator t tn) => + OpNonmut t tn s +(+.|=) = mutableNonmutToNonmut mixedAddDnInPlace + +-- | Upward rounded in-place mixed multiplication +mixedMultUpInPlace :: + (RoundedMixedMultiplyInPlace t tn, + ?mixedMultUpDnEffort :: MixedMultEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedMultUpInPlace = mixedMultUpInPlaceEff ?mixedMultUpDnEffort + +-- | Upward rounded multiplicative scalar action assignment +(*^|=) :: + (RoundedMixedMultiplyInPlace t tn, + ?mixedMultUpDnEffort :: MixedMultEffortIndicator t tn) => + OpNonmut t tn s +(*^|=) = mutableNonmutToNonmut mixedMultUpInPlace + +-- | Downward rounded in-place mixed multiplication +mixedMultDnInPlace :: + (RoundedMixedMultiplyInPlace t tn, + ?mixedMultUpDnEffort :: MixedMultEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedMultDnInPlace = mixedMultDnInPlaceEff ?mixedMultUpDnEffort + +-- | Downward rounded multiplicative scalar action assignment +(*.|=) :: + (RoundedMixedMultiplyInPlace t tn, + ?mixedMultUpDnEffort :: MixedMultEffortIndicator t tn) => + OpNonmut t tn s +(*.|=) = mutableNonmutToNonmut mixedMultDnInPlace + +-- | Upward rounded in-place mixed reciprocal action +mixedDivUpInPlace :: + (RoundedMixedDivideInPlace t tn, + ?mixedDivUpDnEffort :: MixedDivEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedDivUpInPlace = mixedDivUpInPlaceEff ?mixedDivUpDnEffort + +-- | Upward rounded multiplicative scalar reciprocal action assignment +(/^|=) :: + (RoundedMixedDivideInPlace t tn, + ?mixedDivUpDnEffort :: MixedDivEffortIndicator t tn) => + OpNonmut t tn s +(/^|=) = mutableNonmutToNonmut mixedDivUpInPlace + +-- | Downward rounded in-place mixed reciprocal action +mixedDivDnInPlace :: + (RoundedMixedDivideInPlace t tn, + ?mixedDivUpDnEffort :: MixedDivEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedDivDnInPlace = mixedDivDnInPlaceEff ?mixedDivUpDnEffort + +-- | Downward rounded multiplicative scalar reciprocal action assignment +(/.|=) :: + (RoundedMixedDivideInPlace t tn, + ?mixedDivUpDnEffort :: MixedDivEffortIndicator t tn) => + OpNonmut t tn s +(/.|=) = mutableNonmutToNonmut mixedDivDnInPlace + +-- the following does not work, but is kept here as a template for +-- cut and pasting the "let"s +withMixedFieldOpsEffortIndicator effortMixedField expression = + let ?mixedAddUpDnEffort = mxfldEffortAdd effortMixedField in + let ?mixedMultUpDnEffort = mxfldEffortMult effortMixedField in + let ?mixedDivUpDnEffort = mxfldEffortDiv effortMixedField in + expression + +-- | Upward rounded in-place exponential +expUpInPlace :: + (RoundedExponentiationInPlace t, ?expUpDnEffort :: ExpEffortIndicator t) => + OpMutable1 t s +expUpInPlace = expUpInPlaceEff ?expUpDnEffort + +-- | Downward rounded in-place exponential +expDnInPlace :: + (RoundedExponentiationInPlace t, ?expUpDnEffort :: ExpEffortIndicator t) => + OpMutable1 t s +expDnInPlace = expDnInPlaceEff ?expUpDnEffort + +-- | Upward rounded in-place square root +sqrtUpInPlace :: + (RoundedSquareRootInPlace t, ?sqrtUpDnEffort :: SqrtEffortIndicator t) => + OpMutable1 t s +sqrtUpInPlace = sqrtUpInPlaceEff ?sqrtUpDnEffort + +-- | Downward rounded in-place square root +sqrtDnInPlace :: + (RoundedSquareRootInPlace t, ?sqrtUpDnEffort :: SqrtEffortIndicator t) => + OpMutable1 t s +sqrtDnInPlace = sqrtDnInPlaceEff ?sqrtUpDnEffort + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/MixedFieldOps.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/MixedFieldOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/MixedFieldOps.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps + Description : rounded basic arithmetic operations mixing 2 types + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Rounded basic arithmetical operations mixing 2 types. + + This module is hidden and reexported via its parent NumericOrderRounding. +-} +module Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps where + +import Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps +import Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion +import Numeric.AERN.RealArithmetic.ExactOps + +import Numeric.AERN.Basics.Exception +import Numeric.AERN.Basics.Effort +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import Control.Exception +import Data.Maybe + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class RoundedMixedAddEffort t tn where + type MixedAddEffortIndicator t tn + mixedAddDefaultEffort :: t -> tn -> MixedAddEffortIndicator t tn + +class (RoundedMixedAddEffort t tn) => RoundedMixedAdd t tn where + mixedAddUpEff :: MixedAddEffortIndicator t tn -> t -> tn -> t + mixedAddDnEff :: MixedAddEffortIndicator t tn -> t -> tn -> t + +{- tools to easily make a RoundedMixedAdd instance + via the composition of conversion and homogeneous addition -} + +type MixedAddEffortIndicatorByConversion t tn = + (AddEffortIndicator t, ConvertEffortIndicator tn t) + +mixedAddDefaultEffortByConversion d n = + (addDefaultEffort d, convertDefaultEffort n d) + +mixedAddUpEffByConversion :: + (Convertible tn t, RoundedAdd t, Show tn) => + (AddEffortIndicator t, ConvertEffortIndicator tn t) -> + t -> tn -> t +mixedAddUpEffByConversion (effAdd, effConv) d n = + addUpEff effAdd nUp d + where + nUp = + case convertUpEff effConv n of + (Just nUp) -> nUp + _ -> throw $ AERNException $ + "conversion failed during mixed addition: n = " ++ show n + +mixedAddDnEffByConversion :: + (Convertible tn t, RoundedAdd t, Show tn) => + (AddEffortIndicator t, ConvertEffortIndicator tn t) -> + t -> tn -> t +mixedAddDnEffByConversion (effAdd, effConv) d n = + addDnEff effAdd nDn d + where + nDn = + case convertDnEff effConv n of + (Just nDn) -> nDn + _ -> throw $ AERNException $ + "conversion failed during mixed addition: n = " ++ show n + +{- properties of mixed addition -} + +propMixedAddEqualsConvert :: + (NumOrd.PartialComparison t, Convertible tn t, + RoundedMixedAdd t tn, RoundedAdd t, + Show t, HasLegalValues t, + Show (MixedAddEffortIndicator t tn), + EffortIndicator (MixedAddEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (NumOrd.PartialCompareEffortIndicator t, + (MixedAddEffortIndicator t tn, + AddEffortIndicator t, + ConvertEffortIndicator tn t)) -> + (NumOrd.UniformlyOrderedSingleton t) -> + tn -> + Bool +propMixedAddEqualsConvert sampleN sample initEffort + (NumOrd.UniformlyOrderedSingleton d) n = + equalRoundingUpDn "mixed addition by conversion" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMAdd,_,_) = + let (+^|) = mixedAddUpEff effMAdd in d +^| n + expr1Dn (effMAdd,_,_) = + let (+.|) = mixedAddDnEff effMAdd in d +.| n + expr2Up (_,effAdd,effConv) = + let (+^) = addUpEff effAdd in d +^ (fromJust $ convertUpEff effConv n) + expr2Dn (_,effAdd,effConv) = + let (+.) = addDnEff effAdd in d +. (fromJust $ convertDnEff effConv n) + +class RoundedMixedMultiplyEffort t tn where + type MixedMultEffortIndicator t tn + mixedMultDefaultEffort :: t -> tn -> MixedMultEffortIndicator t tn + +class (RoundedMixedMultiplyEffort t tn) => RoundedMixedMultiply t tn where + mixedMultUpEff :: MixedMultEffortIndicator t tn -> t -> tn -> t + mixedMultDnEff :: MixedMultEffortIndicator t tn -> t -> tn -> t + +{- tools to easily make a RoundedMixedMultiply instance + via the composition of conversion and homogeneous addition -} + +type MixedMultEffortIndicatorByConversion t tn = + (MultEffortIndicator t, + ConvertEffortIndicator tn t, + NumOrd.MinmaxEffortIndicator t) + +mixedMultDefaultEffortByConversion d n = + (addDefaultEffort d, + convertDefaultEffort n d, + NumOrd.minmaxDefaultEffort d) + +mixedMultUpEffByConversion :: + (Convertible tn t, RoundedMultiply t, NumOrd.RoundedLattice t, Show tn) => + (MultEffortIndicator t, + ConvertEffortIndicator tn t, + NumOrd.MinmaxEffortIndicator t) -> + t -> tn -> t +mixedMultUpEffByConversion (effMult, effConv, effMinmax) d n = + NumOrd.maxUpEff effMinmax + (multUpEff effMult d nDn) + (multUpEff effMult d nUp) + where + (nUp, nDn) = + case (convertUpEff effConv n, convertDnEff effConv n) of + (Just nUp, Just nDn) -> (nUp, nDn) + _ -> throw $ AERNException $ + "conversion failed during mixed multiplication: n = " ++ show n + +mixedMultDnEffByConversion :: + (Convertible tn t, RoundedMultiply t, NumOrd.RoundedLattice t, Show tn) => + (MultEffortIndicator t, + ConvertEffortIndicator tn t, + NumOrd.MinmaxEffortIndicator t) -> + t -> tn -> t +mixedMultDnEffByConversion (effMult, effConv, effMinmax) d n = + NumOrd.minDnEff effMinmax + (multDnEff effMult d nDn) + (multDnEff effMult d nUp) + where + (nUp, nDn) = + case (convertUpEff effConv n, convertDnEff effConv n) of + (Just nUp, Just nDn) -> (nUp, nDn) + _ -> throw $ AERNException $ + "conversion failed during mixed multiplication: n = " ++ show n + + +{- properties of mixed multiplication -} + +propMixedMultEqualsConvert :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + Convertible tn t, + RoundedMixedMultiply t tn, RoundedMultiply t, + Show t, HasLegalValues t, + Show (MixedMultEffortIndicator t tn), + EffortIndicator (MixedMultEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (NumOrd.MinmaxEffortIndicator t), + EffortIndicator (NumOrd.MinmaxEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (NumOrd.PartialCompareEffortIndicator t, + (MixedMultEffortIndicator t tn, + (MultEffortIndicator t, + ConvertEffortIndicator tn t, + NumOrd.MinmaxEffortIndicator t))) -> + (NumOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedMultEqualsConvert sample sampleN initEffort + (NumOrd.UniformlyOrderedSingleton d) n = + equalRoundingUpDn "mixed multiplication by conversion" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMMult,_) = + let (*^|) = mixedMultUpEff effMMult in d *^| n + expr1Dn (effMMult,_) = + let (*.|) = mixedMultDnEff effMMult in d *.| n + expr2Up (_,(effMult,effConv,effMinmax)) = + let (*^) = multUpEff effMult in + NumOrd.maxUpEff effMinmax + (d *^ (fromJust $ convertUpEff effConv n)) + (d *^ (fromJust $ convertDnEff effConv n)) + expr2Dn (_,(effMult,effConv,effMinmax)) = + let (*.) = multDnEff effMult in + NumOrd.minDnEff effMinmax + (d *. (fromJust $ convertUpEff effConv n)) + (d *. (fromJust $ convertDnEff effConv n)) + +class RoundedMixedDivideEffort t tn where + type MixedDivEffortIndicator t tn + mixedDivDefaultEffort :: t -> tn -> MixedDivEffortIndicator t tn + +class (RoundedMixedDivideEffort t tn) => RoundedMixedDivide t tn where + mixedDivUpEff :: MixedDivEffortIndicator t tn -> t -> tn -> t + mixedDivDnEff :: MixedDivEffortIndicator t tn -> t -> tn -> t + +{- tools to easily make a RoundedMixedDivide instance + via the composition of conversion and homogeneous addition -} + +type MixedDivEffortIndicatorByConversion t tn = + (DivEffortIndicator t, + ConvertEffortIndicator tn t, + (NumOrd.MinmaxEffortIndicator t, + NumOrd.PartialCompareEffortIndicator t)) + +mixedDivDefaultEffortByConversion d n = + (addDefaultEffort d, + convertDefaultEffort n d, + (NumOrd.minmaxDefaultEffort d, + NumOrd.pCompareDefaultEffort d)) + +mixedDivUpEffByConversion :: + (Convertible tn t, + RoundedDivide t, + HasZero t, HasInfinities t, + NumOrd.PartialComparison t, + NumOrd.RoundedLattice t, + Show tn) => + (DivEffortIndicator t, + ConvertEffortIndicator tn t, + (NumOrd.MinmaxEffortIndicator t, + NumOrd.PartialCompareEffortIndicator t)) -> + t -> tn -> t +mixedDivUpEffByConversion (effDiv, effConv, (effMinmax, effComp)) d n = + let ?pCompareEffort = effComp in + case (nDn >=? zero, nUp <=? zero) of + (Just True, _) -> normalResult + (_, Just True) -> normalResult + _ -> plusInfinity -- b is too close to zero + where + normalResult = + NumOrd.maxDnEff effMinmax -- we do not know the sign of a + (divUpEff effDiv d nDn) + (divUpEff effDiv d nUp) + (nUp, nDn) = + case (convertUpEff effConv n, convertDnEff effConv n) of + (Just nUp, Just nDn) -> (nUp, nDn) + _ -> throw $ AERNException $ + "conversion failed during mixed division: n = " ++ show n + +mixedDivDnEffByConversion :: + (Convertible tn t, + RoundedDivide t, + HasZero t, HasInfinities t, + NumOrd.PartialComparison t, + NumOrd.RoundedLattice t, + Show tn) => + (DivEffortIndicator t, + ConvertEffortIndicator tn t, + (NumOrd.MinmaxEffortIndicator t, + NumOrd.PartialCompareEffortIndicator t)) -> + t -> tn -> t +mixedDivDnEffByConversion (effDiv, effConv, (effMinmax, effComp)) d n = + let ?pCompareEffort = effComp in + case (nDn >=? zero, nUp <=? zero) of + (Just True, _) -> normalResult + (_, Just True) -> normalResult + _ -> minusInfinity -- b is too close to zero + where + normalResult = + NumOrd.minDnEff effMinmax -- we do not know the sign of a + (divDnEff effDiv d nDn) + (divDnEff effDiv d nUp) + (nUp, nDn) = + case (convertUpEff effConv n, convertDnEff effConv n) of + (Just nUp, Just nDn) -> (nUp, nDn) + _ -> throw $ AERNException $ + "conversion failed during mixed division: n = " ++ show n + +{- properties of mixed multiplication -} + +propMixedDivEqualsConvert :: + (NumOrd.PartialComparison t, NumOrd.RoundedLattice t, + Convertible tn t, + RoundedMixedDivide t tn, RoundedDivide t, + Show t, HasLegalValues t, + HasZero t, + Show (MixedDivEffortIndicator t tn), + EffortIndicator (MixedDivEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (NumOrd.MinmaxEffortIndicator t), + EffortIndicator (NumOrd.MinmaxEffortIndicator t), + Show (NumOrd.PartialCompareEffortIndicator t), + EffortIndicator (NumOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (NumOrd.PartialCompareEffortIndicator t, + (MixedDivEffortIndicator t tn, + (DivEffortIndicator t, + ConvertEffortIndicator tn t, + NumOrd.MinmaxEffortIndicator t))) -> + (NumOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedDivEqualsConvert sample sampleN initEffort@(effComp,(_,(_,effConv,_))) + (NumOrd.UniformlyOrderedSingleton d) n + = + equalRoundingUpDn "mixed division by conversion" + expr1Up expr1Dn expr2Up expr2Dn + NumOrd.pLeqEff initEffort + where + expr1Up (effMDiv,_) = + let (/^|) = mixedDivUpEff effMDiv in d /^| n + expr1Dn (effMDiv,_) = + let (/.|) = mixedDivDnEff effMDiv in d /.| n + expr2Up (_,(effDiv,effConv,effMinmax)) = + let (/^) = divUpEff effDiv in + NumOrd.maxUpEff effMinmax + (d /^ (fromJust $ convertUpEff effConv n)) + (d /^ (fromJust $ convertDnEff effConv n)) + expr2Dn (_,(effDiv,effConv,effMinmax)) = + let (/.) = divDnEff effDiv in + NumOrd.minDnEff effMinmax + (d /. (fromJust $ convertUpEff effConv n)) + (d /. (fromJust $ convertDnEff effConv n)) + +testsUpDnMixedFieldOps (name, sample) (nameN, sampleN) = + testGroup (name ++ " with " ++ nameN ++ ": mixed up/dn rounded ops") $ + [ + testProperty "addition" (propMixedAddEqualsConvert sample sampleN) + , + testProperty "multiplication" (propMixedMultEqualsConvert sample sampleN) + , + testProperty "division" (propMixedDivEqualsConvert sample sampleN) + ] + +class (RoundedMixedAddEffort t tn, RoundedMixedMultiplyEffort t tn) => + RoundedMixedRingEffort t tn + where + type MixedRingOpsEffortIndicator t tn + mixedRingOpsDefaultEffort :: t -> tn -> MixedRingOpsEffortIndicator t tn + mxringEffortAdd :: t -> tn -> MixedRingOpsEffortIndicator t tn -> MixedAddEffortIndicator t tn + mxringEffortMult :: t -> tn -> MixedRingOpsEffortIndicator t tn -> MixedMultEffortIndicator t tn + +class (RoundedMixedAdd t tn, RoundedMixedMultiply t tn, RoundedMixedRingEffort t tn) => + RoundedMixedRing t tn + +class (RoundedMixedRingEffort t tn, RoundedMixedDivideEffort t tn) => + RoundedMixedFieldEffort t tn + where + type MixedFieldOpsEffortIndicator t tn + mixedFieldOpsDefaultEffort :: t -> tn -> MixedFieldOpsEffortIndicator t tn + mxfldEffortAdd :: t -> tn -> MixedFieldOpsEffortIndicator t tn -> MixedAddEffortIndicator t tn + mxfldEffortMult :: t -> tn -> MixedFieldOpsEffortIndicator t tn -> MixedMultEffortIndicator t tn + mxfldEffortDiv :: t -> tn -> MixedFieldOpsEffortIndicator t tn -> MixedDivEffortIndicator t tn + +class (RoundedMixedRing t tn, RoundedMixedDivide t tn, RoundedMixedFieldEffort t tn) => + RoundedMixedField t tn + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/OpsDefaultEffort.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/OpsDefaultEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/OpsDefaultEffort.hs @@ -0,0 +1,131 @@ +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.OpsImplicitEffort + Description : convenience binary infix operators with default effort + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Convenience binary infix operators with default effort. +-} + +module Numeric.AERN.RealArithmetic.NumericOrderRounding.OpsDefaultEffort where + +import Numeric.AERN.RealArithmetic.NumericOrderRounding +import Numeric.AERN.RealArithmetic.ExactOps + +infixl 6 +., +^, -., -^ +infixl 7 *., *^ +infixl 8 ^., ^^ +infixl 7 /., /^ + +infixr 6 |+., |+^ +infixl 6 +.|, +^| +infixr 7 |*., |*^ +infixl 7 *.|, *^| +infixl 7 /.|, /^| + +(+^), (+.) :: + (RoundedAdd t) => + t -> t -> t +(+^) d = addUpEff (addDefaultEffort d) d +(+.) d = addDnEff (addDefaultEffort d) d + +(-^), (-.) :: + (RoundedSubtr t) => + t -> t -> t +(-^) d = subtrUpEff (addDefaultEffort d) d +(-.) d = subtrDnEff (addDefaultEffort d) d + +absUp, absDn :: + (RoundedAbs t) => + t -> t +absUp d = absUpEff (absDefaultEffort d) d +absDn d = absDnEff (absDefaultEffort d) d + +(*^), (*.) :: + (RoundedMultiply t) => + t -> t -> t +(*^) d = multUpEff (multDefaultEffort d) d +(*.) d = multDnEff (multDefaultEffort d) d + +(^^), (^.) :: + (RoundedPowerToNonnegInt t) => + t -> Int -> t +(^^) d = powerToNonnegIntUpEff (powerToNonnegIntDefaultEffort d) d +(^.) d = powerToNonnegIntDnEff (powerToNonnegIntDefaultEffort d) d + +(/^), (/.) :: + (RoundedDivide t) => + t -> t -> t +(/^) d = divUpEff (divDefaultEffort d) d +(/.) d = divDnEff (divDefaultEffort d) d + +(|+^), (|+.) :: + (RoundedMixedAdd t tn) => + tn -> t -> t +(|+^) n d = mixedAddUpEff (mixedAddDefaultEffort d n) d n +(|+.) n d = mixedAddDnEff (mixedAddDefaultEffort d n) d n + +(+^|), (+.|) :: + (RoundedMixedAdd t tn) => + t -> tn -> t +(+^|) d n = mixedAddUpEff (mixedAddDefaultEffort d n) d n +(+.|) d n = mixedAddDnEff (mixedAddDefaultEffort d n) d n + +(|*^), (|*.) :: + (RoundedMixedMultiply t tn) => + tn -> t -> t +(|*^) n d = mixedMultUpEff (mixedMultDefaultEffort d n) d n +(|*.) n d = mixedMultDnEff (mixedMultDefaultEffort d n) d n + +(*^|), (*.|) :: + (RoundedMixedMultiply t tn) => + t -> tn -> t +(*^|) d n = mixedMultUpEff (mixedMultDefaultEffort d n) d n +(*.|) d n = mixedMultDnEff (mixedMultDefaultEffort d n) d n + +(/^|), (/.|) :: + (RoundedMixedDivide t tn) => + t -> tn -> t +(/^|) d n = mixedDivUpEff (mixedDivDefaultEffort d n) d n +(/.|) d n = mixedDivDnEff (mixedDivDefaultEffort d n) d n + +piUp, piDn :: + (RoundedSpecialConst t) => + t +piUp = result + where + result = + piUpEff (specialConstDefaultEffort result) +piDn = result + where + result = + piDnEff (specialConstDefaultEffort result) + +eUp, eDn :: + (RoundedSpecialConst t) => + t +eUp = result + where + result = + eUpEff (specialConstDefaultEffort result) +eDn = result + where + result = + eDnEff (specialConstDefaultEffort result) + +expUp, expDn :: + (RoundedExponentiation t) => + t -> t +expUp d = expUpEff (expDefaultEffort d) d +expDn d = expDnEff (expDefaultEffort d) d + +sqrtUp, sqrtDn :: + (RoundedSquareRoot t) => + t -> t +sqrtUp d = sqrtUpEff (sqrtDefaultEffort d) d +sqrtDn d = sqrtDnEff (sqrtDefaultEffort d) d + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/OpsImplicitEffort.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/OpsImplicitEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/OpsImplicitEffort.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.OpsImplicitEffort + Description : convenience binary infix operators with implicit effort parameters + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Convenience binary infix operators with implicit effort parameters. +-} + +module Numeric.AERN.RealArithmetic.NumericOrderRounding.OpsImplicitEffort where + +import Numeric.AERN.RealArithmetic.NumericOrderRounding + +infixl 6 +., +^, -., -^ +infixl 7 *., *^ +infixl 8 ^., ^^ +infixl 7 /., /^ + +infixr 6 |+., |+^ +infixl 6 +.|, +^| +infixr 7 |*., |*^ +infixl 7 *.|, *^| +infixl 7 /.|, /^| + +(+^), (+.) :: + (RoundedAdd t, ?addUpDnEffort :: AddEffortIndicator t) => + t -> t -> t +(+^) = addUpEff ?addUpDnEffort +(+.) = addDnEff ?addUpDnEffort + +(-^), (-.) :: + (RoundedSubtr t, ?addUpDnEffort :: AddEffortIndicator t) => + t -> t -> t +(-^) = subtrUpEff ?addUpDnEffort +(-.) = subtrDnEff ?addUpDnEffort + +absUp, absDn :: + (RoundedAbs t, ?absUpDnEffort :: AbsEffortIndicator t) => + t -> t +absUp = absUpEff ?absUpDnEffort +absDn = absDnEff ?absUpDnEffort + +(*^), (*.) :: + (RoundedMultiply t, ?multUpDnEffort :: MultEffortIndicator t) => + t -> t -> t +(*^) = multUpEff ?multUpDnEffort +(*.) = multDnEff ?multUpDnEffort + +(^^), (^.) :: + (RoundedPowerToNonnegInt t, ?intPowerUpDnEffort :: PowerToNonnegIntEffortIndicator t) => + t -> Int -> t +(^^) = powerToNonnegIntUpEff ?intPowerUpDnEffort +(^.) = powerToNonnegIntDnEff ?intPowerUpDnEffort + +(/^), (/.) :: + (RoundedDivide t, ?divUpDnEffort :: DivEffortIndicator t) => + t -> t -> t +(/^) = divUpEff ?divUpDnEffort +(/.) = divDnEff ?divUpDnEffort + +(+^|), (+.|) :: + (RoundedMixedAdd t tn, + ?mixedAddUpDnEffort :: MixedAddEffortIndicator t tn) => + t -> tn -> t +(+^|) = mixedAddUpEff ?mixedAddUpDnEffort +(+.|) = mixedAddDnEff ?mixedAddUpDnEffort + +(|+^), (|+.) :: + (RoundedMixedAdd t tn, + ?mixedAddUpDnEffort :: MixedAddEffortIndicator t tn) => + tn -> t -> t +(|+^) n d = mixedAddUpEff ?mixedAddUpDnEffort d n +(|+.) n d = mixedAddDnEff ?mixedAddUpDnEffort d n + +(*^|), (*.|) :: + (RoundedMixedMultiply t tn, + ?mixedMultUpDnEffort :: MixedMultEffortIndicator t tn) => + t -> tn -> t +(*^|) = mixedMultUpEff ?mixedMultUpDnEffort +(*.|) = mixedMultDnEff ?mixedMultUpDnEffort + +(|*^), (|*.) :: + (RoundedMixedMultiply t tn, + ?mixedMultUpDnEffort :: MixedMultEffortIndicator t tn) => + tn -> t -> t +(|*^) n d = mixedMultUpEff ?mixedMultUpDnEffort d n +(|*.) n d = mixedMultDnEff ?mixedMultUpDnEffort d n + +(/^|), (/.|) :: + (RoundedMixedDivide t tn, + ?mixedDivUpDnEffort :: MixedDivEffortIndicator t tn) => + t -> tn -> t +(/^|) = mixedDivUpEff ?mixedDivUpDnEffort +(/.|) = mixedDivDnEff ?mixedDivUpDnEffort + +piUp, piDn :: + (RoundedSpecialConst t, ?specialConstUpDnEffort :: SpecialConstEffortIndicator t) => + t +piUp = piUpEff ?specialConstUpDnEffort +piDn = piDnEff ?specialConstUpDnEffort + +eUp, eDn :: + (RoundedSpecialConst t, ?specialConstUpDnEffort :: SpecialConstEffortIndicator t) => + t +eUp = eUpEff ?specialConstUpDnEffort +eDn = eDnEff ?specialConstUpDnEffort + +expUp, expDn :: + (RoundedExponentiation t, ?expUpDnEffort :: ExpEffortIndicator t) => + t -> t +expUp = expUpEff ?expUpDnEffort +expDn = expDnEff ?expUpDnEffort + +sqrtUp, sqrtDn :: + (RoundedSquareRoot t, ?sqrtUpDnEffort :: SqrtEffortIndicator t) => + t -> t +sqrtUp = sqrtUpEff ?sqrtUpDnEffort +sqrtDn = sqrtDnEff ?sqrtUpDnEffort + diff --git a/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/SpecialConst.hs b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/SpecialConst.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/NumericOrderRounding/SpecialConst.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.NumericOrderRounding.SpecialConst + Description : support for common constants such as pi + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Support for common constants such as pi. + + This module is hidden and reexported via its parent NumericOrderRounding. +-} + +module Numeric.AERN.RealArithmetic.NumericOrderRounding.SpecialConst where + +--import Numeric.AERN.Basics.Effort +--import Numeric.AERN.Basics.Exception +--import Numeric.AERN.Basics.ShowInternals +--import Numeric.AERN.RealArithmetic.Laws +--import Numeric.AERN.RealArithmetic.Measures +--import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +--import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort +-- +--import Numeric.AERN.Misc.Debug +-- +--import Test.QuickCheck +--import Test.Framework (testGroup, Test) +--import Test.Framework.Providers.QuickCheck2 (testProperty) + +class RoundedSpecialConstEffort t where + type SpecialConstEffortIndicator t + specialConstDefaultEffort :: t -> SpecialConstEffortIndicator t + +class (RoundedSpecialConstEffort t) => RoundedSpecialConst t where + piUpEff :: (SpecialConstEffortIndicator t) -> t + piDnEff :: (SpecialConstEffortIndicator t) -> t + eUpEff :: (SpecialConstEffortIndicator t) -> t + eDnEff :: (SpecialConstEffortIndicator t) -> t + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Numeric.AERN.RefinementOrderRounding + Description : common arithmetical operations rounded in/out + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Common arithmetical operations rounded in/out. + + This module is meant to be imported qualified. + It is recommended to use the prefix ArithInOut. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding +( + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion, + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps, + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.MixedFieldOps, + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.SpecialConst, + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.Elementary, + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace, + RoundedReal(..), RoundedRealInPlace +) +where + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.MixedFieldOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.SpecialConst +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.Elementary +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace + +import Numeric.AERN.RealArithmetic.ExactOps + +import qualified Numeric.AERN.RealArithmetic.NumericOrderRounding as ArithUpDn + +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd + +{-| + An aggregate class collecting together all functionality + normally expected from up/down rounded approximations to + real numbers such as the floating point numbers. + + It also provides a single aggregate effort indicator type + from which effort indicators for all the rounded operations can + be extracted. +-} +class + (HasZero t, HasOne t, HasInfinities t, Neg t, + NumOrd.PartialComparison t, NumOrd.RefinementRoundedLattice t, + RefOrd.PartialComparison t, RefOrd.RoundedLattice t, + Convertible Int t, ArithUpDn.Convertible t Int, + Convertible Integer t, ArithUpDn.Convertible t Integer, + Convertible Double t, ArithUpDn.Convertible t Double, + Convertible Rational t, ArithUpDn.Convertible t Rational, + RoundedAbs t, + RoundedField t, + RoundedMixedField t Int, + RoundedMixedField t Integer, + RoundedMixedField t Double, + RoundedMixedField t Rational) => + RoundedReal t + where + type RoundedRealEffortIndicator t + roundedRealDefaultEffort :: t -> RoundedRealEffortIndicator t + rrEffortNumComp :: t -> (RoundedRealEffortIndicator t) -> (NumOrd.PartialCompareEffortIndicator t) + rrEffortMinmax :: t -> (RoundedRealEffortIndicator t) -> (NumOrd.MinmaxEffortIndicator t) + rrEffortComp :: t -> (RoundedRealEffortIndicator t) -> (NumOrd.PartialCompareEffortIndicator t) + rrEffortJoinMeetOut :: t -> (RoundedRealEffortIndicator t) -> (RefOrd.JoinMeetOutEffortIndicator t) + rrEffortJoinMeetIn :: t -> (RoundedRealEffortIndicator t) -> (RefOrd.JoinMeetInEffortIndicator t) + rrEffortToInt :: t -> (RoundedRealEffortIndicator t) -> (ArithUpDn.ConvertEffortIndicator t Int) + rrEffortFromInt :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator Int t) + rrEffortToInteger :: t -> (RoundedRealEffortIndicator t) -> (ArithUpDn.ConvertEffortIndicator t Integer) + rrEffortFromInteger :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator Integer t) + rrEffortToDouble :: t -> (RoundedRealEffortIndicator t) -> (ArithUpDn.ConvertEffortIndicator t Double) + rrEffortFromDouble :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator Double t) + rrEffortToRational :: t -> (RoundedRealEffortIndicator t) -> (ArithUpDn.ConvertEffortIndicator t Rational) + rrEffortFromRational :: t -> (RoundedRealEffortIndicator t) -> (ConvertEffortIndicator Rational t) + rrEffortAbs :: t -> (RoundedRealEffortIndicator t) -> (AbsEffortIndicator t) + rrEffortField :: t -> (RoundedRealEffortIndicator t) -> (FieldOpsEffortIndicator t) + rrEffortIntMixedField :: t -> (RoundedRealEffortIndicator t) -> (MixedFieldOpsEffortIndicator t Int) + rrEffortIntegerMixedField :: t -> (RoundedRealEffortIndicator t) -> (MixedFieldOpsEffortIndicator t Integer) + rrEffortDoubleMixedField :: t -> (RoundedRealEffortIndicator t) -> (MixedFieldOpsEffortIndicator t Double) + rrEffortRationalMixedField :: t -> (RoundedRealEffortIndicator t) -> (MixedFieldOpsEffortIndicator t Rational) + +{-| + A mutable version of 'RoundedReal' with additional support for mutable ops. +-} +class + (RoundedReal t, + NegInPlace t, + RoundedAbsInPlace t, + RoundedFieldInPlace t, + RoundedMixedFieldInPlace t Int, + RoundedMixedFieldInPlace t Integer, + RoundedMixedFieldInPlace t Double, + RoundedMixedFieldInPlace t Rational) => + RoundedRealInPlace t + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/Conversion.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/Conversion.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion + Description : conversion between approximations and other types + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Conversion between approximations and other types. + + This module is hidden and reexported via its parent RefinementOrderRounding. +-} +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion where + +import Prelude hiding (EQ, LT, GT) + +import Numeric.AERN.RealArithmetic.ExactOps + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.PartialOrdering +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort + +import qualified Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion as UpDnConversion + +import Numeric.AERN.Misc.Bool +import Numeric.AERN.Misc.Maybe + +import Data.Ratio +import Data.Maybe + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class Convertible t1 t2 where + type ConvertEffortIndicator t1 t2 + convertDefaultEffort :: t1 -> t2 -> ConvertEffortIndicator t1 t2 + convertInEff :: ConvertEffortIndicator t1 t2 -> t1 -> t2 + convertOutEff :: ConvertEffortIndicator t1 t2 -> t1 -> t2 + +propConvertMonotoneFromNumOrd :: + (Convertible t1 t2, NumOrd.ArbitraryOrderedTuple t1, NumOrd.PartialComparison t2) => + t1 -> t2 -> + (ConvertEffortIndicator t1 t2, NumOrd.PartialCompareEffortIndicator t2) -> + NumOrd.LEPair t1 -> Bool +propConvertMonotoneFromNumOrd sample1 sample2 (effortFrom, effortComp) (NumOrd.LEPair (a, b)) = + (trueOrNothing $ let ?pCompareEffort = effortComp in aOut <=? bOut) + && + (trueOrNothing $ let ?pCompareEffort = effortComp in aIn <=? bIn) + where + aOut = convertOutEff effortFrom a + aIn = convertInEff effortFrom a + bOut = convertOutEff effortFrom b + bIn = convertInEff effortFrom b + _ = [sample2, aOut, aIn] + +propConvertRoundTripNumOrd :: + (UpDnConversion.Convertible t1 t2, Convertible t2 t1, + NumOrd.PartialComparison t1, Show t1, Show t2) => + t1 -> t2 -> + (NumOrd.PartialCompareEffortIndicator t1, + ConvertEffortIndicator t2 t1, + UpDnConversion.ConvertEffortIndicator t1 t2) -> + t1 -> Bool +propConvertRoundTripNumOrd sample1 sample2 (effortComp, effortFrom, effortTo) a = + (defined maDn && defined maUp) ===> + let ?pCompareEffort = effortComp in + case (aDnOut <=? a, a <=? aUpOut) of + (Just False, _) -> printErrorDetail + (_, Just False) -> printErrorDetail + _ -> True + where + aDnOut = convertOutEff effortFrom aDn + maDn = UpDnConversion.convertDnEff effortTo a + aDn = fromJust maDn + aUpOut = convertOutEff effortFrom aUp + maUp = UpDnConversion.convertUpEff effortTo a + aUp = fromJust maUp + _ = [sample2, aDn, aUp] + printErrorDetail = + error $ + "propToFromInteger failed:" + ++ "\n a = " ++ show a + ++ "\n aDnOut = " ++ show aDnOut + ++ "\n aUpOut = " ++ show aUpOut + + +testsConvertNumOrd (name1, sample1, name2, sample2) = + testGroup (name1 ++ " -> " ++ name2 ++ " conversions") $ + [ + testProperty "monotone" (propConvertMonotoneFromNumOrd sample1 sample2) + , + testProperty "round trip" (propConvertRoundTripNumOrd sample2 sample1) + ] + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/Elementary.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/Elementary.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/Elementary.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.Elementary + Description : support for various common elementary functions + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Support for various common elementary functions. + + This module is hidden and reexported via its parent RefinementOrderRounding. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.Elementary where + +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.MixedFieldOps + +import qualified Numeric.AERN.RealArithmetic.NumericOrderRounding.Conversion as UpDnConversion + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception +import Numeric.AERN.Basics.ShowInternals +import Numeric.AERN.Basics.Bench +import Numeric.AERN.Basics.Consistency +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Bench +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd + +import Numeric.AERN.Misc.Debug + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Criterion + +class RoundedExponentiationEffort t where + type ExpEffortIndicator t + expDefaultEffort :: t -> ExpEffortIndicator t + +class (RoundedExponentiationEffort t) => RoundedExponentiation t where + expInEff :: (ExpEffortIndicator t) -> t -> t + expOutEff :: (ExpEffortIndicator t) -> t -> t + +-- | @e^a*e^(-a) = 1@ +propExpOfNegRecip :: + (RefOrd.PartialComparison t, + RoundedExponentiation t, RoundedMultiply t, Neg t, HasOne t, + Show t, HasAntiConsistency t, HasLegalValues t, + Show (ExpEffortIndicator t), + EffortIndicator (ExpEffortIndicator t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (ConsistencyEffortIndicator t) -> + (RefOrd.PartialCompareEffortIndicator t, + (ExpEffortIndicator t, MultEffortIndicator t)) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Bool +propExpOfNegRecip _ effortConsistency initEffort + (RefOrd.UniformlyOrderedSingleton e1) = + thinEqualConsLeqRoundingUpDnImprovement "e^a * e^(-a) ⊑/⊒ 1" [e1] + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff + effortConsistency + initEffort + where + expr1In (effExp, effMult) = +-- unsafePrintReturn ( +-- "propExpOfNegRecip: expr2In: " +-- ++ "\n e1 = " ++ (show e1) +-- ++ "\n expInEff effExp e1 = " ++ (show $ expInEff effExp e1) +-- ++ "\n expInEff effExp (neg e1) = " ++ (show $ expInEff effExp (neg e1)) +-- ++ "\n product of the above = " +-- ) $ + let (>*<) = multInEff effMult in + (expInEff effExp e1) >*< (expInEff effExp (neg e1)) + expr1Out (effExp, effMult) = + let (<*>) = multOutEff effMult in + (expOutEff effExp e1) <*> (expOutEff effExp (neg e1)) + expr2In (effExp, effMult) = one + expr2Out (effExp, effMult) = one + +-- | @e^(b+c) = e^b * e^c@ +propExpOfAddToMult :: + (RefOrd.PartialComparison t, + RoundedExponentiation t, RoundedMultiply t, RoundedAdd t, + Show t, HasLegalValues t, + Show (ExpEffortIndicator t), + EffortIndicator (ExpEffortIndicator t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + (ExpEffortIndicator t, MultEffortIndicator t, AddEffortIndicator t)) -> + (RefOrd.UniformlyOrderedPair t) -> + Bool +propExpOfAddToMult _ initEffort (RefOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "e^(a + b) = e^a * e^b" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + expr1In (effExp, effMult, effAdd) = + let (+^) = addInEff effAdd in + (expInEff effExp (e1 +^ e2)) + expr1Out (effExp, effMult, effAdd) = + let (+.) = addOutEff effAdd in + (expOutEff effExp (e1 +. e2)) + expr2In (effExp, effMult, effAdd) = + let (*^) = multInEff effMult in + (expInEff effExp e1) *^ (expInEff effExp e2) + expr2Out (effExp, effMult, effAdd) = + let (*.) = multOutEff effMult in + (expOutEff effExp e1) *. (expOutEff effExp e2) + +testsInOutExp (name, sample) = + testGroup (name ++ " exp in/out") $ + [ + testProperty "e^a * e^(-a) ⊑/⊒ 1" (propExpOfNegRecip sample) + , + testProperty "e^(a + b) = e^a * e^b" (propExpOfAddToMult sample) + ] + +benchInOutExp (name, sample) areas = + bgroup (name ++ " exp") $ + mkBenchAreasSequences1 (mkCommentImprecision1 expOutEff expInEff) + expOutEff areas 10 (expDefaultEffort sample) sample + +benchExpAreasReal = + [ + ("near 0", NumOrd.AreaLinear (Just $ -1/2) True (Just $ 1/2) True []) + , + ("near -10", NumOrd.AreaLinear (Just $ -10.5) True (Just $ -9.5) True []) + , + ("near 10", NumOrd.AreaLinear (Just $ 9.5) True (Just $ 10.5) True []) + , + ("near 20", NumOrd.AreaLinear (Just $ 19.5) True (Just $ 20.5) True []) + ] + +class RoundedSquareRootEffort t where + type SqrtEffortIndicator t + sqrtDefaultEffort :: t -> SqrtEffortIndicator t + +class (RoundedSquareRootEffort t) => RoundedSquareRoot t where + sqrtInEff :: (SqrtEffortIndicator t) -> t -> t + sqrtOutEff :: (SqrtEffortIndicator t) -> t -> t + +propSqrtSquare :: + (RefOrd.PartialComparison t, + RoundedSquareRoot t, RoundedMultiply t, HasZero t, + UpDnConversion.Convertible t Double, + RoundedMixedAdd t Double, + Show t, HasLegalValues t, +-- ShowInternals t, + Show (UpDnConversion.ConvertEffortIndicator t Double), + EffortIndicator (UpDnConversion.ConvertEffortIndicator t Double), + Show (MixedAddEffortIndicator t Double), + EffortIndicator (MixedAddEffortIndicator t Double), + Show (SqrtEffortIndicator t), + EffortIndicator (SqrtEffortIndicator t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (tInArea -> t) -> + (UpDnConversion.ConvertEffortIndicator t Double, + MixedAddEffortIndicator t Double) -> + (RefOrd.PartialCompareEffortIndicator t, + (SqrtEffortIndicator t, + MultEffortIndicator t, + RefOrd.PartialCompareEffortIndicator t)) -> + tInArea -> Bool +propSqrtSquare _ fromArea (effortToDbl, effortAddDbl) initEffort e1InArea = + equalRoundingUpDn "sqrt(e)^2 = e" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + e1Pos = fromArea e1InArea +-- case maybeE1LowerBoundD of +-- Just e1LowerBoundD +-- | e1LowerBoundD <= (0 :: Double) -> +-- mixedAddOutEff effortAddDbl e1 (0.5 - e1LowerBoundD) +-- | otherwise -> e1 +-- _ -> e1 +-- where +-- maybeE1LowerBoundD = UpDnConversion.convertDnEff effortToDbl e1 + expr1In (effSqrt, effMult, effCompare) = + sqrtE1 >*< sqrtE1 + where + (>*<) = multInEff effMult + sqrtE1 = sqrtInEff effSqrt e1Pos + expr1Out (effSqrt, effMult, effCompare) = + sqrtE1 <*> sqrtE1 + where + (<*>) = multOutEff effMult + sqrtE1 = sqrtOutEff effSqrt e1Pos + expr2In _ = e1Pos + expr2Out _ = e1Pos + +testsInOutSqrt (name, sample) fromArea = + testGroup (name ++ " sqrt in/out") $ + [ + testProperty "sqrt(e)^2 = e" (propSqrtSquare sample fromArea) + ] + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/ElementaryFromFieldOps/Exponentiation.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/ElementaryFromFieldOps/Exponentiation.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/ElementaryFromFieldOps/Exponentiation.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.ElementaryFromFieldOps.Exponentiation + Description : implementation of in/out rounded exponentiation + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Implementation of in/out rounded exponentiation. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.ElementaryFromFieldOps.Exponentiation where + +import qualified Numeric.AERN.RealArithmetic.RefinementOrderRounding as ArithInOut +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.OpsImplicitEffort +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.OpsImplicitEffort + +import qualified Numeric.AERN.RealArithmetic.NumericOrderRounding as ArithUpDn +import Numeric.AERN.RealArithmetic.NumericOrderRounding.OpsImplicitEffort + +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd +import Numeric.AERN.Basics.RefinementOrder.OpsImplicitEffort +import Numeric.AERN.Basics.RefinementOrder.InPlace.OpsImplicitEffort + +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.ExactOps + +import Control.Monad.ST (ST) + +expOutThinArg :: + (HasZero t, HasOne t, HasInfinities t, + RefOrd.PartialComparison t, + NumOrd.PartialComparison t, + RefOrd.OuterRoundedLattice t, + ArithUpDn.Convertible t Int, + ArithInOut.Convertible Double t, + ArithInOut.RoundedMixedField t Int, + ArithInOut.RoundedField t) => + ArithInOut.FieldOpsEffortIndicator t -> + ArithInOut.MixedFieldOpsEffortIndicator t Int -> + RefOrd.JoinMeetOutEffortIndicator t -> + RefOrd.PartialCompareEffortIndicator t -> + NumOrd.PartialCompareEffortIndicator t -> + (ArithUpDn.ConvertEffortIndicator t Int, + ArithInOut.ConvertEffortIndicator Double t) -> + Int {-^ the highest degree to consider in the Taylor expansion -} -> + t {-^ @x@ assumed to be a thin approximation -} -> + t {-^ @exp(x)@ -} +expOutThinArg + effortField + effortMixedField + effortMeet + effortRefinement effortCompare + (effortToInt, effortFromDouble) + degr x = + let ?pCompareEffort = effortRefinement in + let ?joinmeetOutEffort = effortMeet in + let ?divInOutEffort = ArithInOut.fldEffortDiv x effortField in + -- infinities not handled well by the Taylor formula, + -- treat them as special cases, adding also 0 for efficiency: + case (xTooBig, xTooLow, x |>=? zero) of + (True, _, _) -> x plusInfinity -- x almost oo + (_, True, _) -> zero (one (neg x)) -- x almost -oo + (_, _, Just True) -> one -- x = 0 + _ | excludesPlusInfinity x && excludesMinusInfinity x -> + expOutViaTaylorForXScaledNearZero + _ -> -- not equal to infinity but not excluding infinity: + zero plusInfinity + -- this is always a valid outer approx + where + (xUp, xTooBig) = + case ArithUpDn.convertUpEff effortToInt x of + Just xUp -> (xUp :: Int, False) + _ -> (error "internal error in expOutThinArg", True) + (xDn, xTooLow) = + case ArithUpDn.convertDnEff effortToInt x of + Just xDn -> (xDn :: Int, False) + _ -> (error "internal error in expOutThinArg", True) + expOutViaTaylorForXScaledNearZero = + let ?joinmeetOutEffort = effortMeet in + let ?addInOutEffort = ArithInOut.fldEffortAdd x effortField in + let ?multInOutEffort = ArithInOut.fldEffortMult x effortField in + let ?intPowerInOutEffort = ArithInOut.fldEffortPow x effortField in + let ?divInOutEffort = ArithInOut.fldEffortDiv x effortField in + let ?mixedAddInOutEffort = ArithInOut.mxfldEffortAdd x xUp effortMixedField in + let ?mixedMultInOutEffort = ArithInOut.mxfldEffortMult x xUp effortMixedField in + let ?mixedDivInOutEffort = ArithInOut.mxfldEffortDiv x xUp effortMixedField in + (expOutViaTaylor degr (x | n)) <^> n + where + n = -- x / n must fall inside [-1,1] + (abs xUp) `max` (abs xDn) + expOutViaTaylor degr x = -- assuming x inside [-1,1] + oneI |<+> (te degr oneI) + where + oneI :: Int + oneI = 1 + te steps i + | steps > 0 = + (x | i) <*> (oneI |<+> (te (steps - 1) (i + 1))) + | steps == 0 = + errorBound + where + errorBound = + (x | i) <*> ithDerivBound + ithDerivBound = + case (pNonnegNonposEff effortCompare x) of + (Just True, _) -> -- x >= 0: + one eUp + (_, Just True) -> -- x <= 0: + recipEDn one + _ -> -- near or crossing zero: + recipEDn eUp + eUp = + ArithInOut.convertOutEff effortFromDouble (2.718281829 :: Double) + recipEDn = + ArithInOut.convertOutEff effortFromDouble (0.367879440 :: Double) + +expOutThinArgInPlace :: + (CanBeMutable t, + HasZero t, HasOne t, HasInfinities t, + RefOrd.PartialComparison t, + NumOrd.PartialComparison t, + RefOrd.OuterRoundedLattice t, + ArithUpDn.Convertible t Int, + ArithInOut.Convertible Double t, + ArithInOut.RoundedField t, + ArithInOut.RoundedFieldInPlace t, + ArithInOut.RoundedMixedField t Int, + ArithInOut.RoundedMixedFieldInPlace t Int, -- this constraint should be redundant.. + ArithInOut.RoundedPowerToNonnegIntInPlace t) => + ArithInOut.FieldOpsEffortIndicator t -> + ArithInOut.MixedFieldOpsEffortIndicator t Int -> + RefOrd.JoinMeetOutEffortIndicator t -> + RefOrd.PartialCompareEffortIndicator t -> + NumOrd.PartialCompareEffortIndicator t -> + (ArithUpDn.ConvertEffortIndicator t Int, + ArithInOut.ConvertEffortIndicator Double t) -> + Mutable t s -> {-^ out parameter -} + Int {-^ the highest degree to consider in the Taylor expansion -} -> + Mutable t s {-^ @xM@ assumed to be a thin approximation -} -> + ST s () +expOutThinArgInPlace + effortField + effortMixedField + effortMeet + effortRefinement effortCompare + (effortToInt, effortFromDouble) + resM degr xM = + do + -- clone xM to ensure no aliasing with resM: + xMNA <- cloneMutable xM + + -- we need x - a pure version of xM for branching conditions: + x <- unsafeReadMutable xMNA + -- unsafe is OK because we do not write into xMNA while x is in scope + + -- set various effort indicators for the following block using implicit parameters: + let ?pCompareEffort = effortRefinement + let ?joinmeetOutEffort = effortMeet + let ?divInOutEffort = ArithInOut.fldEffortDiv x effortField + let ?multInOutEffort = ArithInOut.fldEffortMult x effortField + let ?intPowerInOutEffort = ArithInOut.fldEffortPow x effortField + let ?mixedAddInOutEffort = ArithInOut.mxfldEffortAdd x degr effortMixedField + let ?mixedDivInOutEffort = ArithInOut.mxfldEffortDiv x degr effortMixedField + + -- compute integer bounds on x if possible: + let (xUp, xTooBig) = + case ArithUpDn.convertUpEff effortToInt x of + Just xUp -> (xUp :: Int, False) + _ -> (error "internal error in expOutThinArg", True) + let (xDn, xTooLow) = + case ArithUpDn.convertDnEff effortToInt x of + Just xDn -> (xDn :: Int, False) + _ -> (error "internal error in expOutThinArg", True) + + -- infinities not handled well by the Taylor formula, + -- treat them as special cases, adding also 0 for efficiency: + case (xTooBig, xTooLow, x |>=? zero) of + (True, _, _) -> unsafeWriteMutable resM (x plusInfinity) -- x almost oo + (_, True, _) -> unsafeWriteMutable resM (zero (one (neg x))) -- x almost -oo + (_, _, Just True) -> unsafeWriteMutable resM one -- x = 0 + _ | excludesPlusInfinity x && excludesMinusInfinity x -> + -- the main case where Taylor is used: + expOutViaTaylorForXScaledNearZero resM xUp xDn xMNA + _ -> -- not equal to infinity but not excluding infinity: + unsafeWriteMutable resM (zero plusInfinity) + -- this is always a valid outer approx + where + expOutViaTaylorForXScaledNearZero resM xUp xDn xM = + -- assuming no aliasing between xM and resM + + -- set various effort indicators for the following block using implicit parameters: + do + xM |= n -- x := x/n + expOutViaTaylor resM degr xM -- res := exp x + resM <^>= n -- res := res^n + where + n = -- x / n must fall inside [-1,1] + (abs xUp) `max` (abs xDn) + expOutViaTaylor resM degr xM = -- assuming x inside [-1,1] + -- assuming no aliasing between xM and resM + + do + -- we need a pure version of xM for constructing the error bound: + x <- unsafeReadMutable xM + -- unsafe is OK because we do not write into xM and it does not alias with resM + + let ?addInOutEffort = ArithInOut.fldEffortAdd x effortField + let ?mixedMultInOutEffort = ArithInOut.mxfldEffortMult x oneI effortMixedField + te resM degr oneI x xM -- res := x + x^2/2 + ... + resM <+>|= oneI -- res := res + 1 + where + oneI :: Int + oneI = 1 + te resM steps i x xM + | steps > 0 = + do + -- (x | i) <*> (oneI |<+> (te (steps - 1) (i + 1))) + te resM (steps - 1) (i + 1) x xM + resM <+>|= oneI + resM |= i + resM <*>= xM + | steps == 0 = + do + -- (x | i) <*> ithDerivBound + unsafeWriteMutable resM ithDerivBound + resM |= i + resM <*>= xM + where + ithDerivBound = + case (pNonnegNonposEff effortCompare x) of + (Just True, _) -> -- x >= 0: + one eUp + (_, Just True) -> -- x <= 0: + recipEDn one + _ -> -- near or crossing zero: + recipEDn eUp + eUp = + ArithInOut.convertOutEff effortFromDouble (2.718281829 :: Double) + recipEDn = + ArithInOut.convertOutEff effortFromDouble (0.367879440 :: Double) diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/FieldOps.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/FieldOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/FieldOps.hs @@ -0,0 +1,680 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE UndecidableInstances #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps + Description : rounded addition and multiplication + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Rounded addition and multiplication. + + This module is hidden and reexported via its parent RefinementOrderRounding. +-} +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps +( + RoundedAdd(..), RoundedAddEffort(..), RoundedSubtr(..), + testsInOutAdd, testsInOutSubtr, + RoundedAbs(..), RoundedAbsEffort(..), + testsInOutAbs, absInUsingCompMax, absOutUsingCompMax, + RoundedMultiply(..), RoundedMultiplyEffort(..), testsInOutMult, + RoundedPowerToNonnegInt(..), RoundedPowerToNonnegIntEffort(..), + testsInOutIntPower, + PowerToNonnegIntEffortIndicatorFromMult, powerToNonnegIntDefaultEffortFromMult, + powerToNonnegIntInEffFromMult, powerToNonnegIntOutEffFromMult, + RoundedDivide(..), RoundedDivideEffort(..), testsInOutDiv, + RoundedRingEffort(..), RoundedFieldEffort(..), + RoundedRing(..), RoundedField(..) +-- , +-- FieldOpsEffortIndicator(..), fieldOpsDefaultEffort +) +where + +import Prelude hiding (EQ, LT, GT) +import Numeric.AERN.Basics.PartialOrdering + +import Numeric.AERN.RealArithmetic.Auxiliary +import Numeric.AERN.RealArithmetic.ExactOps +import qualified Numeric.AERN.RealArithmetic.NumericOrderRounding as ArithUpDn +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception (HasLegalValues) +import Numeric.AERN.Basics.Consistency + +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd +import Numeric.AERN.Basics.RefinementOrder.OpsImplicitEffort +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Maybe + +class RoundedAddEffort t where + type AddEffortIndicator t + addDefaultEffort :: t -> AddEffortIndicator t + +class (RoundedAddEffort t) => RoundedAdd t where + addInEff :: AddEffortIndicator t -> t -> t -> t + addOutEff :: AddEffortIndicator t -> t -> t -> t + +--propAddMonotone _ effortDist + +propInOutAddZero :: + (RefOrd.PartialComparison t, RoundedAdd t, HasZero t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Bool +propInOutAddZero _ effort (RefOrd.UniformlyOrderedSingleton e) = + roundedUnit zero RefOrd.pLeqEff addInEff addOutEff effort e + +propInOutAddCommutative :: + (RefOrd.PartialComparison t, RoundedAdd t, HasZero t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (RefOrd.UniformlyOrderedPair t) -> + Bool +propInOutAddCommutative _ effort (RefOrd.UniformlyOrderedPair (e1,e2)) = + roundedCommutative RefOrd.pLeqEff addInEff addOutEff effort e1 e2 + +propInOutAddAssociative :: + (RefOrd.PartialComparison t, RoundedAdd t, HasZero t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (RefOrd.UniformlyOrderedTriple t) -> + Bool +propInOutAddAssociative _ effort (RefOrd.UniformlyOrderedTriple (e1,e2,e3)) = + roundedAssociative RefOrd.pLeqEff addInEff addOutEff effort e1 e2 e3 + +propInOutAddMonotone :: + (RefOrd.PartialComparison t, RoundedAdd t, + Show t, HasLegalValues t, + RefOrd.ArbitraryOrderedTuple t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (AddEffortIndicator t) -> + (RefOrd.LEPair t) -> (RefOrd.LEPair t) -> + (RefOrd.PartialCompareEffortIndicator t) -> + Bool +propInOutAddMonotone _ = + roundedRefinementMonotone2 "addition" addInEff addOutEff + +testsInOutAdd (name, sample) = + testGroup (name ++ " >+< <+>") $ + [ + testProperty "0 absorbs" (propInOutAddZero sample) + , + testProperty "commutative" (propInOutAddCommutative sample) + , + testProperty "associative" (propInOutAddAssociative sample) + , + testProperty "refinement monotone" (propInOutAddMonotone sample) + ] + + +class (RoundedAdd t, Neg t) => RoundedSubtr t where + subtrInEff :: (AddEffortIndicator t) -> t -> t -> t + subtrOutEff :: (AddEffortIndicator t) -> t -> t -> t + subtrInEff effort a b = addInEff effort a (neg b) + subtrOutEff effort a b = addOutEff effort a (neg b) + +propInOutSubtrElim :: + (RefOrd.PartialComparison t, RoundedSubtr t, HasZero t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Bool +propInOutSubtrElim _ effort (RefOrd.UniformlyOrderedSingleton e) = + roundedReflexiveCollapse zero RefOrd.pLeqEff subtrInEff subtrOutEff effort e + +propInOutSubtrNegAdd :: + (RefOrd.PartialComparison t, RoundedSubtr t, Neg t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (RefOrd.UniformlyOrderedPair t) -> + Bool +propInOutSubtrNegAdd _ initEffort (RefOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDn "a+b=a-(-b)" + expr1Up expr1Dn expr2Up expr2Dn + RefOrd.pLeqEff initEffort + where + expr1Up eff = + let (>-<) = subtrInEff eff in e1 >-< (neg e2) + expr1Dn eff = + let (<->) = subtrOutEff eff in e1 <-> (neg e2) + expr2Up eff = + let (>+<) = addInEff eff in e1 >+< e2 + expr2Dn eff = + let (<+>) = addOutEff eff in e1 <+> e2 + +propInOutSubtrMonotone :: + (RefOrd.PartialComparison t, RoundedSubtr t, + Show t, HasLegalValues t, + RefOrd.ArbitraryOrderedTuple t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (AddEffortIndicator t) -> + (RefOrd.LEPair t) -> (RefOrd.LEPair t) -> + (RefOrd.PartialCompareEffortIndicator t) -> + Bool +propInOutSubtrMonotone _ = + roundedRefinementMonotone2 "subtraction" subtrInEff subtrOutEff + +testsInOutSubtr (name, sample) = + testGroup (name ++ " >-< <->") $ + [ +-- testProperty "a-a=0" (propInOutSubtrElim sample) +-- , + testProperty "a+b=a-(-b)" (propInOutSubtrNegAdd sample) + , + testProperty "refinement monotone" (propInOutSubtrMonotone sample) + ] + + +class RoundedAbsEffort t where + type AbsEffortIndicator t + absDefaultEffort :: t -> AbsEffortIndicator t + +class (RoundedAbsEffort t) => RoundedAbs t where + absInEff :: (AbsEffortIndicator t) -> t -> t + absOutEff :: (AbsEffortIndicator t) -> t -> t + +absOutUsingCompMax :: + (HasZero t, Neg t, + NumOrd.PartialComparison t, NumOrd.OuterRoundedLattice t) => + (NumOrd.PartialCompareEffortIndicator t, + NumOrd.MinmaxOuterEffortIndicator t) -> + t -> t +absOutUsingCompMax (effortComp, effortMinmax) a = + case NumOrd.pCompareEff effortComp zero a of + Just EQ -> a + Just LT -> a + Just LEE -> a + Just GT -> neg a + Just GEE -> neg a + _ -> zero `max` (a `max` (neg a)) + where + max = NumOrd.maxOutEff effortMinmax + +absInUsingCompMax :: + (HasZero t, Neg t, + NumOrd.PartialComparison t, NumOrd.InnerRoundedLattice t) => + (NumOrd.PartialCompareEffortIndicator t, + NumOrd.MinmaxInnerEffortIndicator t) -> + t -> t +absInUsingCompMax (effortComp, effortMinmax) a = + case NumOrd.pCompareEff effortComp zero a of + Just EQ -> a + Just LT -> a + Just LEE -> a + Just GT -> neg a + Just GEE -> neg a + _ -> zero `max` (a `max` (neg a)) + where + max = NumOrd.maxInEff effortMinmax + +propInOutAbsNegSymmetric :: + (RefOrd.PartialComparison t, RoundedAbs t, HasZero t, Neg t, + Show t, HasLegalValues t, + Show (AbsEffortIndicator t), + EffortIndicator (AbsEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AbsEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Bool +propInOutAbsNegSymmetric _ effort (RefOrd.UniformlyOrderedSingleton e) = + roundedNegSymmetric RefOrd.pLeqEff absInEff absOutEff effort e + +propInOutAbsIdempotent :: + (RefOrd.PartialComparison t, RoundedAbs t, HasZero t, + Show t, HasLegalValues t, + Show (AbsEffortIndicator t), + EffortIndicator (AbsEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AbsEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Bool +propInOutAbsIdempotent _ effort (RefOrd.UniformlyOrderedSingleton e) = + roundedIdempotent RefOrd.pLeqEff absInEff absOutEff effort e + +propInOutAbsMonotone :: + (RefOrd.PartialComparison t, RoundedAbs t, + RefOrd.ArbitraryOrderedTuple t, + Show t, HasLegalValues t, + Show (AbsEffortIndicator t), + EffortIndicator (AbsEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (AbsEffortIndicator t) -> + (RefOrd.LEPair t) -> + (RefOrd.PartialCompareEffortIndicator t) -> + Bool +propInOutAbsMonotone _ = + roundedRefinementMonotone1 "abs" absInEff absOutEff + +testsInOutAbs (name, sample) = + testGroup (name ++ " in/out rounded abs") $ + [ + testProperty "neg -> no change" (propInOutAbsNegSymmetric sample) + , + testProperty "idempotent" (propInOutAbsIdempotent sample) + , + testProperty "refinement monotone" (propInOutAbsMonotone sample) + ] + + +class RoundedMultiplyEffort t where + type MultEffortIndicator t + multDefaultEffort :: t -> MultEffortIndicator t + +class (RoundedMultiplyEffort t) => RoundedMultiply t where + multInEff :: MultEffortIndicator t -> t -> t -> t + multOutEff :: MultEffortIndicator t -> t -> t -> t + +propInOutMultMonotone :: + (RefOrd.PartialComparison t, RoundedMultiply t, + Show t, HasLegalValues t, + RefOrd.ArbitraryOrderedTuple t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (MultEffortIndicator t) -> + (RefOrd.LEPair t) -> (RefOrd.LEPair t) -> + (RefOrd.PartialCompareEffortIndicator t) -> + Bool +propInOutMultMonotone _ = + roundedRefinementMonotone2 "multiplication" multInEff multOutEff + +propInOutMultOne :: + (RefOrd.PartialComparison t, RoundedMultiply t, HasOne t, + Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + MultEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Bool +propInOutMultOne _ effort (RefOrd.UniformlyOrderedSingleton e) = + roundedUnit one RefOrd.pLeqEff multInEff multOutEff effort e + +propInOutMultCommutative :: + (RefOrd.PartialComparison t, RoundedMultiply t, HasZero t, + Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + MultEffortIndicator t) -> + (RefOrd.UniformlyOrderedPair t) -> + Bool +propInOutMultCommutative _ effort (RefOrd.UniformlyOrderedPair (e1,e2)) = + roundedCommutative RefOrd.pLeqEff multInEff multOutEff effort e1 e2 + +propInOutMultAssociative :: + (RefOrd.PartialComparison t, + RoundedMultiply t, HasZero t, + Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + MultEffortIndicator t) -> + (RefOrd.UniformlyOrderedTriple t) -> + Bool +propInOutMultAssociative _ effort (RefOrd.UniformlyOrderedTriple (e1,e2,e3)) = + roundedAssociative RefOrd.pLeqEff multInEff multOutEff effort e1 e2 e3 + +propInOutMultDistributesOverAdd :: + (RefOrd.PartialComparison t, + RoundedMultiply t, RoundedAdd t, + HasAntiConsistency t, Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (ConsistencyEffortIndicator t) -> + (RefOrd.PartialCompareEffortIndicator t, + (MultEffortIndicator t, AddEffortIndicator t)) -> + (RefOrd.UniformlyOrderedTriple t) -> + Bool +propInOutMultDistributesOverAdd _ effortConst effort (RefOrd.UniformlyOrderedTriple (e1,e2,e3)) = + roundedDistributive + RefOrd.pLeqEff + multInEff addInEff multOutEff addOutEff + effortConst effort e1 e2 e3 + + +testsInOutMult (name, sample) = + testGroup (name ++ " >*< <*>") $ + [ + testProperty "1 absorbs" (propInOutMultOne sample) + , + testProperty "commutative" (propInOutMultCommutative sample) + , + testProperty "associative" (propInOutMultAssociative sample) + , + testProperty "weakly distributes over +" (propInOutMultDistributesOverAdd sample) + , + testProperty "refinement monotone" (propInOutMultMonotone sample) + ] + +class RoundedPowerToNonnegIntEffort t where + type PowerToNonnegIntEffortIndicator t + powerToNonnegIntDefaultEffort :: + t -> PowerToNonnegIntEffortIndicator t + +class (RoundedPowerToNonnegIntEffort t) => RoundedPowerToNonnegInt t where + powerToNonnegIntInEff :: + (PowerToNonnegIntEffortIndicator t) -> + t {-^ @x@ -} -> + Int {-^ @n@ (assumed >=0)-} -> + t {-^ @x^n@ rounded inwards -} + powerToNonnegIntOutEff :: + (PowerToNonnegIntEffortIndicator t) -> + t {-^ @x@ -} -> + Int {-^ @n@ (assumed >=0)-} -> + t {-^ @x^n@ rounded outwards -} + +-- functions providing an implementation derived from rounded multiplication: + +type PowerToNonnegIntEffortIndicatorFromMult t = + MultEffortIndicator t + +powerToNonnegIntDefaultEffortFromMult a = + multDefaultEffort a + +powerToNonnegIntInEffFromMult :: + (RoundedMultiply t, HasOne t) => + PowerToNonnegIntEffortIndicatorFromMult t -> + t -> Int -> t +powerToNonnegIntInEffFromMult effMult e n = + powerFromMult (multInEff effMult) e n + +powerToNonnegIntOutEffFromMult :: + (RoundedMultiply t, HasOne t) => + PowerToNonnegIntEffortIndicatorFromMult t -> + t -> Int -> t +powerToNonnegIntOutEffFromMult effMult e n = + powerFromMult (multOutEff effMult) e n + +propInOutPowerMonotone :: + (RefOrd.PartialComparison t, RoundedPowerToNonnegInt t, + RefOrd.ArbitraryOrderedTuple t, + Show t, HasLegalValues t, + Show (PowerToNonnegIntEffortIndicator t), + EffortIndicator (PowerToNonnegIntEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + Int -> + (PowerToNonnegIntEffortIndicator t) -> + (RefOrd.LEPair t) -> + (RefOrd.PartialCompareEffortIndicator t) -> + Bool +propInOutPowerMonotone _ nR = + roundedRefinementMonotone1 "non-neg integer power" powerNInEff powerNOutEff + where + n = nR `mod` 10 + powerNInEff eff x = powerToNonnegIntInEff eff x n + powerNOutEff eff x = powerToNonnegIntOutEff eff x n + + +propInOutPowerSumExponents :: + (RefOrd.PartialComparison t, + RoundedPowerToNonnegInt t, RoundedMultiply t, + HasOne t, HasAntiConsistency t, Show t, HasLegalValues t, + Show (PowerToNonnegIntEffortIndicator t), + EffortIndicator (PowerToNonnegIntEffortIndicator t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (ConsistencyEffortIndicator t), + EffortIndicator (ConsistencyEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (ConsistencyEffortIndicator t) -> + (RefOrd.PartialCompareEffortIndicator t, + (PowerToNonnegIntEffortIndicator t, + MultEffortIndicator t)) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Int -> Int -> Bool +propInOutPowerSumExponents _ effortConsistency initEffort + (RefOrd.UniformlyOrderedSingleton a) nR mR = + thinEqualConsLeqRoundingUpDnImprovement "a^n * a^m ⊑/⊒ a^(n+m)" [a] + expr1Up expr1Dn expr2Up expr2Dn + RefOrd.pLeqEff + effortConsistency + initEffort + where + n = nR `mod` 10 + m = mR `mod` 10 + expr1Up (effPower, effMult) = + let (>^<) = powerToNonnegIntInEff effPower in + let (>*<) = multInEff effMult in + (a >^< n) >*< (a >^< m) + expr1Dn (effPower, effMult) = + let (<^>) = powerToNonnegIntOutEff effPower in + let (<*>) = multOutEff effMult in + (a <^> n) <*> (a <^> m) + expr2Up (effPower, effMult) = + let (>^<) = powerToNonnegIntInEff effPower in + a >^< (n + m) + expr2Dn (effPower, effMult) = + let (<^>) = powerToNonnegIntOutEff effPower in + a <^> (n + m) + +testsInOutIntPower (name, sample) = + testGroup (name ++ " non-negative integer power") $ + [ + testProperty "a^n * a^m ⊑/⊒ a^(n+m)" (propInOutPowerSumExponents sample) + , + testProperty "refinement monotone" (propInOutPowerMonotone sample) +-- , +-- testProperty "a/b=a*(1/b)" (propUpDnDivRecipMult sample) + ] + +class RoundedDivideEffort t where + type DivEffortIndicator t + divDefaultEffort :: t -> DivEffortIndicator t + +class (HasOne t, RoundedDivideEffort t) => RoundedDivide t where + divInEff :: DivEffortIndicator t -> t -> t -> t + divOutEff :: DivEffortIndicator t -> t -> t -> t + recipInEff :: DivEffortIndicator t -> t -> t + recipOutEff :: DivEffortIndicator t -> t -> t + recipInEff eff = divInEff eff one + recipOutEff eff = divOutEff eff one + + +propInOutDivMonotone :: + (RefOrd.PartialComparison t, RoundedDivide t, + Show t, HasLegalValues t, + RefOrd.ArbitraryOrderedTuple t, + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (DivEffortIndicator t) -> + (RefOrd.LEPair t) -> (RefOrd.LEPair t) -> + (RefOrd.PartialCompareEffortIndicator t) -> + Bool +propInOutDivMonotone _ = + roundedRefinementMonotone2 "division" divInEff divOutEff + +propInOutDivElim :: + (RefOrd.PartialComparison t, RoundedDivide t, HasOne t, HasZero t, + Show t, HasLegalValues t, + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + DivEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Bool +propInOutDivElim _ efforts2@(effComp, _) (RefOrd.UniformlyOrderedSingleton a) = + roundedReflexiveCollapse + one + RefOrd.pLeqEff + divInEff divOutEff + efforts2 + a + +propInOutDivRecipMult :: + (RefOrd.PartialComparison t, + RoundedMultiply t, RoundedDivide t, HasOne t, HasZero t, + Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + (MultEffortIndicator t, DivEffortIndicator t)) -> + (RefOrd.UniformlyOrderedPair t) -> + Bool +propInOutDivRecipMult _ initEffort@(effComp,_) (RefOrd.UniformlyOrderedPair (e1, e2)) = + equalRoundingUpDnBin2Var2 "a/b=a*(1/b)" + expr1 expr2 RefOrd.pLeqEff + multInEff divInEff + multOutEff divOutEff + initEffort e1 e2 + where + expr1 op1Eff op2Eff (effort1, effort2) e1 e2 = + e1 * (one / e2) + where + (*) = op1Eff effort1 + (/) = op2Eff effort2 + expr2 op1Eff op2Eff (effort1, effort2) e1 e2 = + e1 / e2 + where + (/) = op2Eff effort2 + +testsInOutDiv (name, sample) = + testGroup (name ++ " >/<") $ + [ +-- testProperty "a/a=1" (propInOutDivElim sample) +-- , + testProperty "a/b=a*(1/b)" (propInOutDivRecipMult sample) + , + testProperty "refinement monotone" (propInOutDivMonotone sample) + ] + +class + (RoundedAddEffort t, + RoundedMultiplyEffort t, + RoundedPowerToNonnegIntEffort t) => + RoundedRingEffort t + where + type RingOpsEffortIndicator t + ringOpsDefaultEffort :: t -> RingOpsEffortIndicator t + ringEffortAdd :: t -> (RingOpsEffortIndicator t) -> (AddEffortIndicator t) + ringEffortMult :: t -> (RingOpsEffortIndicator t) -> (MultEffortIndicator t) + ringEffortPow :: t -> (RingOpsEffortIndicator t) -> (PowerToNonnegIntEffortIndicator t) + +class + (RoundedAdd t, + RoundedSubtr t, + RoundedMultiply t, + RoundedPowerToNonnegInt t, + RoundedRingEffort t) => + RoundedRing t + +class (RoundedRingEffort t, RoundedDivideEffort t) => RoundedFieldEffort t where + type FieldOpsEffortIndicator t + fieldOpsDefaultEffort :: t -> FieldOpsEffortIndicator t + fldEffortAdd :: t -> (FieldOpsEffortIndicator t) -> (AddEffortIndicator t) + fldEffortMult :: t -> (FieldOpsEffortIndicator t) -> (MultEffortIndicator t) + fldEffortPow :: t -> (FieldOpsEffortIndicator t) -> (PowerToNonnegIntEffortIndicator t) + fldEffortDiv :: t -> (FieldOpsEffortIndicator t) -> (DivEffortIndicator t) + +class (RoundedRing t, RoundedDivide t, RoundedFieldEffort t) => RoundedField t diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/FieldOps.hs-boot b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/FieldOps.hs-boot new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/FieldOps.hs-boot @@ -0,0 +1,73 @@ +{- + this file is needed to break the following dependency cycles: + + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.Elementary + imports: Numeric.AERN.RealArithmetic.Measures + Numeric.AERN.RealArithmetic.Laws + Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary + Numeric.AERN.RealArithmetic.Measures + imports: Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps + Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps + imports: Numeric.AERN.RealArithmetic.Measures + Numeric.AERN.RealArithmetic.Laws + Numeric.AERN.RealArithmetic.NumericOrderRounding + Numeric.AERN.RealArithmetic.Laws + imports: Numeric.AERN.RealArithmetic.Measures + Numeric.AERN.RealArithmetic.NumericOrderRounding + imports: Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace + Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary + Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace + imports: Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.Elementary + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.MixedFieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.MixedFieldOps + imports: Numeric.AERN.RealArithmetic.Measures + Numeric.AERN.RealArithmetic.Laws + Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + imports: Numeric.AERN.RealArithmetic.Measures + Numeric.AERN.RealArithmetic.Laws + Numeric.AERN.RealArithmetic.NumericOrderRounding.InPlace.FieldOps + imports: Numeric.AERN.RealArithmetic.Measures + Numeric.AERN.RealArithmetic.Laws + Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.MixedFieldOps + imports: Numeric.AERN.RealArithmetic.Measures + Numeric.AERN.RealArithmetic.Laws + Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + Numeric.AERN.RealArithmetic.NumericOrderRounding.Elementary + imports: Numeric.AERN.RealArithmetic.Measures + Numeric.AERN.RealArithmetic.Laws + Numeric.AERN.RealArithmetic.NumericOrderRounding.FieldOps + +-} + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ImplicitParams #-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps where + +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion + +import Numeric.AERN.Basics.Effort +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd + +class RoundedAddEffort t where + type AddEffortIndicator t + addDefaultEffort :: t -> AddEffortIndicator t + +class (RoundedAddEffort t) => RoundedAdd t where + addInEff :: AddEffortIndicator t -> t -> t -> t + addOutEff :: AddEffortIndicator t -> t -> t -> t + +class (RoundedAdd t, Neg t) => RoundedSubtr t where + subtrInEff :: (AddEffortIndicator t) -> t -> t -> t + subtrOutEff :: (AddEffortIndicator t) -> t -> t -> t + subtrInEff effort a b = addInEff effort a (neg b) + subtrOutEff effort a b = addOutEff effort a (neg b) diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace.hs @@ -0,0 +1,25 @@ +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace + Description : common arithmetical operations rounded up/down + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + In-place versions of common arithmetical operations rounded in/out. + + This module is hidden and reexported via its parent RefinementOrderRounding. +-} +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace +( + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.FieldOps, + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.MixedFieldOps, + module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.Elementary, +) +where + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.FieldOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.MixedFieldOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.Elementary diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/Elementary.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/Elementary.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/Elementary.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.Elementary + Description : support for various common elementary functions + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Support for various common elementary functions. + + This module is hidden and reexported via its parent RefinementOrderRounding.InPlace. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.Elementary where + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.Elementary + +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception (HasLegalValues) +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class (RoundedExponentiationEffort t, CanBeMutable t) => + RoundedExponentiationInPlace t + where + expInInPlaceEff :: OpMutable1Eff (ExpEffortIndicator t) t s + expOutInPlaceEff :: OpMutable1Eff (ExpEffortIndicator t) t s + +expInInPlaceEffFromPure, + expOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedExponentiation t) => + OpMutable1Eff (ExpEffortIndicator t) t s +expInInPlaceEffFromPure = + pureToMutable1Eff expInEff +expOutInPlaceEffFromPure = + pureToMutable1Eff expOutEff + +expInInPlaceEffFromInPlace, + expOutInPlaceEffFromInPlace :: + (RoundedExponentiationInPlace t) => + (ExpEffortIndicator t) -> t -> t +expInInPlaceEffFromInPlace = + mutable1EffToPure expInInPlaceEff +expOutInPlaceEffFromInPlace = + mutable1EffToPure expOutInPlaceEff + +propInOutExpInPlace :: + (RefOrd.PartialComparison t, + RoundedExponentiationInPlace t, + RoundedExponentiation t, + Neg t, + Show t, HasLegalValues t, + Show (ExpEffortIndicator t), + EffortIndicator (ExpEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + ExpEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> + Bool +propInOutExpInPlace sample initEffort (RefOrd.UniformlyOrderedSingleton e1) = + equalRoundingUpDn "in-place exp" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + expInEffViaInPlace = mutable1EffToPure expInInPlaceEff + expOutEffViaInPlace = mutable1EffToPure expOutInPlaceEff + expr1In eff = expInEff eff e1 + expr1Out eff = expOutEff eff e1 + expr2In eff = expInEffViaInPlace eff e1 + expr2Out eff = expOutEffViaInPlace eff e1 + +testsInOutExpInPlace (name, sample) = + testGroup (name ++ " in-place exp") $ + [ + testProperty "matches pure" (propInOutExpInPlace sample) + ] + +class (RoundedSquareRootEffort t, CanBeMutable t) => + RoundedSquareRootInPlace t + where + sqrtInInPlaceEff :: OpMutable1Eff (SqrtEffortIndicator t) t s + sqrtOutInPlaceEff :: OpMutable1Eff (SqrtEffortIndicator t) t s + +sqrtInInPlaceEffFromPure, + sqrtOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedSquareRoot t) => + OpMutable1Eff (SqrtEffortIndicator t) t s +sqrtInInPlaceEffFromPure = + pureToMutable1Eff sqrtInEff +sqrtOutInPlaceEffFromPure = + pureToMutable1Eff sqrtOutEff + +sqrtInInPlaceEffFromInPlace, + sqrtOutInPlaceEffFromInPlace :: + (RoundedSquareRootInPlace t) => + (SqrtEffortIndicator t) -> t -> t +sqrtInInPlaceEffFromInPlace = + mutable1EffToPure sqrtInInPlaceEff +sqrtOutInPlaceEffFromInPlace = + mutable1EffToPure sqrtOutInPlaceEff + +propInOutSqrtInPlace :: + (RefOrd.PartialComparison t, + RoundedSquareRootInPlace t, + RoundedSquareRoot t, + Neg t, + Show t, HasLegalValues t, + Show (SqrtEffortIndicator t), + EffortIndicator (SqrtEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (tInArea -> t) -> + (RefOrd.PartialCompareEffortIndicator t, + SqrtEffortIndicator t) -> + tInArea -> + Bool +propInOutSqrtInPlace sample fromArea initEffort e1InArea = + equalRoundingUpDn "in-place sqrt" + sqrtr1In sqrtr1Out sqrtr2In sqrtr2Out + RefOrd.pLeqEff initEffort + where + e1Pos = fromArea e1InArea + sqrtInEffViaInPlace = mutable1EffToPure sqrtInInPlaceEff + sqrtOutEffViaInPlace = mutable1EffToPure sqrtOutInPlaceEff + sqrtr1In eff = sqrtInEff eff e1Pos + sqrtr1Out eff = sqrtOutEff eff e1Pos + sqrtr2In eff = sqrtInEffViaInPlace eff e1Pos + sqrtr2Out eff = sqrtOutEffViaInPlace eff e1Pos + +testsInOutSqrtInPlace (name, sample) fromArea = + testGroup (name ++ " in-place sqrt") $ + [ + testProperty "matches pure" (propInOutSqrtInPlace sample fromArea) + ] + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/FieldOps.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/FieldOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/FieldOps.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.FieldOps + Description : rounded basic arithmetic operations + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + In-place versions of rounded basic arithmetic operations. + + Each operations takes mutable parameters instead of pure parameters + and has one extra mutable parameter before the other parameters, + in which it stores the result. + The mutable parameters can alias arbitrarily, making it possible + to eg add to a number overwriting the original number. + + The operations have as their first paramter a non-mutable sample value + to aid type-checking, ie to help work out which type the mutable parameters + contain. + + This module is hidden and reexported via its parent RefinementOrderRounding.InPlace. +-} +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.FieldOps +where + +import Prelude hiding (EQ, LT, GT) +import Numeric.AERN.Basics.PartialOrdering + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps + +import Numeric.AERN.RealArithmetic.Auxiliary +import Numeric.AERN.RealArithmetic.ExactOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception (HasLegalValues) +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd +import Numeric.AERN.Basics.RefinementOrder.OpsImplicitEffort + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Control.Monad.ST +import Data.Maybe + +class (RoundedAddEffort t, CanBeMutable t) => RoundedAddInPlace t where + addInInPlaceEff :: OpMutable2Eff (AddEffortIndicator t) t s + addOutInPlaceEff :: OpMutable2Eff (AddEffortIndicator t) t s + +addInInPlaceEffFromPure, + addOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedAdd t) => + OpMutable2Eff (AddEffortIndicator t) t s +addInInPlaceEffFromPure = pureToMutable2Eff addInEff +addOutInPlaceEffFromPure = pureToMutable2Eff addOutEff + +addInInPlaceEffFromInPlace, + addOutInPlaceEffFromInPlace :: + (RoundedAddInPlace t) => + (AddEffortIndicator t) -> t -> t -> t +addInInPlaceEffFromInPlace = mutable2EffToPure addInInPlaceEff +addOutInPlaceEffFromInPlace = mutable2EffToPure addOutInPlaceEff + +propInOutAddInPlace :: + (RefOrd.PartialComparison t, + RoundedAddInPlace t, + RoundedAdd t, + Neg t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (RefOrd.UniformlyOrderedPair t) -> Bool +propInOutAddInPlace sample initEffort (RefOrd.UniformlyOrderedPair (e1, e2)) = + roundedInPlace2ConsistentWithPure "addition" + addInInPlaceEff addOutInPlaceEff addInEff addOutEff + RefOrd.pLeqEff initEffort + e1 e2 + +class (RoundedAddInPlace t, NegInPlace t) => RoundedSubtrInPlace t where + subtrInInPlaceEff :: OpMutable2Eff (AddEffortIndicator t) t s + subtrOutInPlaceEff :: OpMutable2Eff (AddEffortIndicator t) t s + subtrInInPlaceEff effort rM aM bM = + do + bbM <- cloneMutable bM + negInPlace bbM bM + addInInPlaceEff effort rM aM bbM + subtrOutInPlaceEff effort rM aM bM = + do + bbM <- cloneMutable bM + negInPlace bbM bM + addOutInPlaceEff effort rM aM bbM + +propInOutSubtrInPlace :: + (RefOrd.PartialComparison t, + RoundedSubtrInPlace t, + RoundedSubtr t, + Neg t, + Show t, HasLegalValues t, + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AddEffortIndicator t) -> + (RefOrd.UniformlyOrderedPair t) -> Bool +propInOutSubtrInPlace sample initEffort (RefOrd.UniformlyOrderedPair (e1, e2)) = + roundedInPlace2ConsistentWithPure "subtraction" + subtrInInPlaceEff subtrOutInPlaceEff subtrInEff subtrOutEff + RefOrd.pLeqEff initEffort + e1 e2 + +class (RoundedAbs t, CanBeMutable t) => RoundedAbsInPlace t where + absInInPlaceEff :: OpMutable1Eff (AbsEffortIndicator t) t s + absOutInPlaceEff :: OpMutable1Eff (AbsEffortIndicator t) t s + absInInPlaceEff = pureToMutable1Eff absInEff + absOutInPlaceEff = pureToMutable1Eff absOutEff + +propInOutAbsInPlace :: + (RefOrd.PartialComparison t, RoundedAbsInPlace t, Neg t, + Show t, HasLegalValues t, + Show (AbsEffortIndicator t), + EffortIndicator (AbsEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + AbsEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> Bool +propInOutAbsInPlace sample initEffort (RefOrd.UniformlyOrderedSingleton e) = + roundedInPlace1ConsistentWithPure "abs" + absInInPlaceEff absOutInPlaceEff absInEff absOutEff + RefOrd.pLeqEff initEffort + e + + +class (RoundedMultiplyEffort t, CanBeMutable t) => RoundedMultiplyInPlace t where + multInInPlaceEff :: OpMutable2Eff (MultEffortIndicator t) t s + multOutInPlaceEff :: OpMutable2Eff (MultEffortIndicator t) t s + +multInInPlaceEffFromPure, + multOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedMultiply t) => + OpMutable2Eff (MultEffortIndicator t) t s +multInInPlaceEffFromPure = pureToMutable2Eff multInEff +multOutInPlaceEffFromPure = pureToMutable2Eff multOutEff + +multInInPlaceEffFromInPlace, + multOutInPlaceEffFromInPlace :: + (RoundedMultiplyInPlace t) => + (MultEffortIndicator t) -> t -> t -> t +multInInPlaceEffFromInPlace = mutable2EffToPure multInInPlaceEff +multOutInPlaceEffFromInPlace = mutable2EffToPure multOutInPlaceEff + +propInOutMultInPlace :: + (RefOrd.PartialComparison t, + RoundedMultiplyInPlace t, + RoundedMultiply t, + Neg t, + Show t, HasLegalValues t, + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + MultEffortIndicator t) -> + (RefOrd.UniformlyOrderedPair t) -> Bool +propInOutMultInPlace sample initEffort (RefOrd.UniformlyOrderedPair (e1, e2)) = + roundedInPlace2ConsistentWithPure "multiplication" + multInInPlaceEff multOutInPlaceEff multInEff multOutEff + RefOrd.pLeqEff initEffort + e1 e2 + +powerToNonnegIntInInPlaceEffFromMult :: + (RoundedMultiplyInPlace t, HasOne t) => + OpMutableNonmutEff (PowerToNonnegIntEffortIndicatorFromMult t) t Int s +powerToNonnegIntInInPlaceEffFromMult effMult rM eM n = + powerFromMultInPlace (multInInPlaceEff effMult) rM eM n + +powerToNonnegIntOutInPlaceEffFromMult :: + (RoundedMultiplyInPlace t, HasOne t) => + OpMutableNonmutEff (PowerToNonnegIntEffortIndicatorFromMult t) t Int s +powerToNonnegIntOutInPlaceEffFromMult effMult rM eM n = + powerFromMultInPlace (multOutInPlaceEff effMult) rM eM n + + +class (RoundedPowerToNonnegIntEffort t, CanBeMutable t) => + RoundedPowerToNonnegIntInPlace t + where + powerToNonnegIntInInPlaceEff :: + OpMutableNonmutEff (PowerToNonnegIntEffortIndicator t) t Int s + powerToNonnegIntOutInPlaceEff :: + OpMutableNonmutEff (PowerToNonnegIntEffortIndicator t) t Int s + +powerToNonnegIntInInPlaceEffFromPure, + powerToNonnegIntOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedPowerToNonnegInt t) => + OpMutableNonmutEff (PowerToNonnegIntEffortIndicator t) t Int s +powerToNonnegIntInInPlaceEffFromPure = + pureToMutableNonmutEff powerToNonnegIntInEff +powerToNonnegIntOutInPlaceEffFromPure = + pureToMutableNonmutEff powerToNonnegIntOutEff + +powerToNonnegIntInInPlaceEffFromInPlace, + powerToNonnegIntOutInPlaceEffFromInPlace :: + (RoundedPowerToNonnegIntInPlace t) => + (PowerToNonnegIntEffortIndicator t) -> t -> Int -> t +powerToNonnegIntInInPlaceEffFromInPlace = + mutableNonmutEffToPure powerToNonnegIntInInPlaceEff +powerToNonnegIntOutInPlaceEffFromInPlace = + mutableNonmutEffToPure powerToNonnegIntOutInPlaceEff + +propInOutPowerToNonnegInPlace :: + (RefOrd.PartialComparison t, + RoundedPowerToNonnegIntInPlace t, + RoundedPowerToNonnegInt t, + Neg t, + Show t, HasLegalValues t, + Show (PowerToNonnegIntEffortIndicator t), + EffortIndicator (PowerToNonnegIntEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + PowerToNonnegIntEffortIndicator t) -> + (RefOrd.UniformlyOrderedSingleton t) -> Int -> Bool +propInOutPowerToNonnegInPlace sample initEffort (RefOrd.UniformlyOrderedSingleton e) n = + roundedInPlace1ConsistentWithPure "non-neg integer power" + (\eff r e -> powerToNonnegIntInInPlaceEff eff r e n) + (\eff r e -> powerToNonnegIntOutInPlaceEff eff r e n) + (\eff e -> powerToNonnegIntInEff eff e n) + (\eff e -> powerToNonnegIntOutEff eff e n) + RefOrd.pLeqEff initEffort + e + +class (HasOne t, RoundedDivideEffort t, CanBeMutable t) => RoundedDivideInPlace t where + divInInPlaceEff :: OpMutable2Eff (DivEffortIndicator t) t s + divOutInPlaceEff :: OpMutable2Eff (DivEffortIndicator t) t s + recipInInPlaceEff :: OpMutable1Eff (DivEffortIndicator t) t s + recipOutInPlaceEff :: OpMutable1Eff (DivEffortIndicator t) t s + + recipInInPlaceEff effort resM aM = + do + oneM <- unsafeMakeMutable one + divInInPlaceEff effort resM oneM aM + recipOutInPlaceEff effort resM aM = + do + oneM <- unsafeMakeMutable one + divOutInPlaceEff effort resM oneM aM + +divInInPlaceEffFromPure, + divOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedDivide t) => + OpMutable2Eff (DivEffortIndicator t) t s +divInInPlaceEffFromPure = pureToMutable2Eff divInEff +divOutInPlaceEffFromPure = pureToMutable2Eff divOutEff + +divInInPlaceEffFromInPlace, + divOutInPlaceEffFromInPlace :: + (RoundedDivideInPlace t) => + (DivEffortIndicator t) -> t -> t -> t +divInInPlaceEffFromInPlace = mutable2EffToPure divInInPlaceEff +divOutInPlaceEffFromInPlace = mutable2EffToPure divOutInPlaceEff + +recipInInPlaceEffFromPure, + recipOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedDivide t) => + OpMutable1Eff (DivEffortIndicator t) t s +recipInInPlaceEffFromPure = pureToMutable1Eff recipInEff +recipOutInPlaceEffFromPure = pureToMutable1Eff recipOutEff + +recipInInPlaceEffFromInPlace, + recipOutInPlaceEffFromInPlace :: + (RoundedDivideInPlace t) => + (DivEffortIndicator t) -> t -> t +recipInInPlaceEffFromInPlace = mutable1EffToPure recipInInPlaceEff +recipOutInPlaceEffFromInPlace = mutable1EffToPure recipOutInPlaceEff + +propInOutDivInPlace :: + (RefOrd.PartialComparison t, + RoundedDivideInPlace t, + RoundedDivide t, + Neg t, + Show t, HasZero t, HasLegalValues t, + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> + (RefOrd.PartialCompareEffortIndicator t, + DivEffortIndicator t) -> + (RefOrd.UniformlyOrderedPair t) -> Bool +propInOutDivInPlace sample initEffort@(effComp, _) (RefOrd.UniformlyOrderedPair (e1, e2)) + = + roundedInPlace2ConsistentWithPure "division" + divInInPlaceEff divOutInPlaceEff divInEff divOutEff + RefOrd.pLeqEff initEffort + e1 e2 + +testsInOutFieldOpsInPlace (name, sample) = + testGroup (name ++ " in-place up/down rounded ops match pure ops") $ + [ + testProperty "addition" (propInOutAddInPlace sample) + , + testProperty "subtraction" (propInOutSubtrInPlace sample) + , + testProperty "absolute value" (propInOutAbsInPlace sample) + , + testProperty "multiplication" (propInOutMultInPlace sample) + , + testProperty "integer power" (propInOutMultInPlace sample) + , + testProperty "division" (propInOutDivInPlace sample) + ] + + +class + (RoundedSubtrInPlace t, + RoundedMultiplyInPlace t, + RoundedRingEffort t) => + RoundedRingInPlace t + +class + (RoundedRingInPlace t, + RoundedDivideInPlace t, + RoundedFieldEffort t) => + RoundedFieldInPlace t + + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/MixedFieldOps.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/MixedFieldOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/MixedFieldOps.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.MixedFieldOps + Description : rounded basic arithmetic operations mixing 2 types + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + In-place versions of rounded basic arithmetical operations mixing 2 types. + + This module is hidden and reexported via its parent "RefinementOrderRounding.InPlace". +-} +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.MixedFieldOps where + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.MixedFieldOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.FieldOps + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion +import Numeric.AERN.RealArithmetic.ExactOps + +import Numeric.AERN.Basics.Exception +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.Basics.Effort +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd +import Numeric.AERN.Basics.RefinementOrder.OpsImplicitEffort + +import Control.Monad.ST +import Control.Exception +import Data.Maybe + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class (RoundedMixedAddEffort t tn, CanBeMutable t) => + RoundedMixedAddInPlace t tn + where + mixedAddInInPlaceEff :: + OpMutableNonmutEff (MixedAddEffortIndicator t tn) t tn s + mixedAddOutInPlaceEff :: + OpMutableNonmutEff (MixedAddEffortIndicator t tn) t tn s + +mixedAddInInPlaceEffFromPure, + mixedAddOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedMixedAdd t tn) => + OpMutableNonmutEff (MixedAddEffortIndicator t tn) t tn s +mixedAddInInPlaceEffFromPure = + pureToMutableNonmutEff mixedAddInEff +mixedAddOutInPlaceEffFromPure = + pureToMutableNonmutEff mixedAddOutEff + +mixedAddInInPlaceEffFromInPlace + ,mixedAddOutInPlaceEffFromInPlace :: + (RoundedMixedAddInPlace t tn) => + (MixedAddEffortIndicator t tn) -> t -> tn -> t +mixedAddInInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedAddInInPlaceEff +mixedAddOutInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedAddOutInPlaceEff + +{- properties of mixed addition -} + +propMixedAddInPlaceEqualsConvert :: + (RefOrd.PartialComparison t, Convertible tn t, + RoundedMixedAddInPlace t tn, + RoundedMixedAdd t tn, + RoundedAdd t, + Show t, HasLegalValues t, + Show (MixedAddEffortIndicator t tn), + EffortIndicator (MixedAddEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (RefOrd.PartialCompareEffortIndicator t, + (MixedAddEffortIndicator t tn, + AddEffortIndicator t, + ConvertEffortIndicator tn t)) -> + (RefOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedAddInPlaceEqualsConvert sample1 sample2 initEffort + (RefOrd.UniformlyOrderedSingleton d) n = + equalRoundingUpDn "mixed in-place addition" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + expr1In (effMAdd,_,_) = + let (>+<|=) dR = mixedAddInInPlaceEff effMAdd dR dR in + runST $ + do + dR <- makeMutable d + dR >+<|= n + unsafeReadMutable dR + expr1Out (effMAdd,_,_) = + let (<+>|=) dR = mixedAddOutInPlaceEff effMAdd dR dR in + runST $ + do + dR <- makeMutable d + dR <+>|= n + unsafeReadMutable dR + expr2In (_,effAdd,effConv) = + let (>+<) = addInEff effAdd in (convertInEff effConv n) >+< d + expr2Out (_,effAdd,effConv) = + let (<+>) = addOutEff effAdd in (convertOutEff effConv n) <+> d + + + +class (RoundedMixedMultiplyEffort t tn, CanBeMutable t) => + RoundedMixedMultiplyInPlace t tn + where + mixedMultInInPlaceEff :: + OpMutableNonmutEff (MixedMultEffortIndicator t tn) t tn s + mixedMultOutInPlaceEff :: + OpMutableNonmutEff (MixedMultEffortIndicator t tn) t tn s + +mixedMultInInPlaceEffFromPure, + mixedMultOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedMixedMultiply t tn) => + OpMutableNonmutEff (MixedMultEffortIndicator t tn) t tn s +mixedMultInInPlaceEffFromPure = + pureToMutableNonmutEff mixedMultInEff +mixedMultOutInPlaceEffFromPure = + pureToMutableNonmutEff mixedMultOutEff + +mixedMultInInPlaceEffFromInPlace, + mixedMultOutInPlaceEffFromInPlace :: + (RoundedMixedMultiplyInPlace t tn) => + (MixedMultEffortIndicator t tn) -> t -> tn -> t +mixedMultInInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedMultInInPlaceEff +mixedMultOutInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedMultOutInPlaceEff + +{- properties of mixed multiplication -} + +propMixedMultInPlaceEqualsConvert :: + (RefOrd.PartialComparison t, Convertible tn t, + RoundedMixedMultiplyInPlace t tn, + RoundedMixedMultiply t tn, + RoundedMultiply t, + Show t, HasLegalValues t, + Show (MixedMultEffortIndicator t tn), + EffortIndicator (MixedMultEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (RefOrd.PartialCompareEffortIndicator t, + (MixedMultEffortIndicator t tn, + MultEffortIndicator t, + ConvertEffortIndicator tn t)) -> + (RefOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedMultInPlaceEqualsConvert sample1 sample2 initEffort + (RefOrd.UniformlyOrderedSingleton d) n = + equalRoundingUpDn "in-place mixed multiplication" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + expr1In (effMMult,_,_) = + let (>*<|=) dR = mixedMultInInPlaceEff effMMult dR dR in + runST $ + do + dR <- makeMutable d + dR >*<|= n + unsafeReadMutable dR + expr1Out (effMMult,_,_) = + let (<*>|=) dR = mixedMultOutInPlaceEff effMMult dR dR in + runST $ + do + dR <- makeMutable d + dR <*>|= n + unsafeReadMutable dR + expr2In (_,effMult,effConv) = + let (>*<) = multInEff effMult in (convertInEff effConv n) >*< d + expr2Out (_,effMult,effConv) = + let (<*>) = multOutEff effMult in (convertOutEff effConv n) <*> d + +class (RoundedMixedDivideEffort t tn, CanBeMutable t) => + RoundedMixedDivideInPlace t tn + where + mixedDivInInPlaceEff :: + OpMutableNonmutEff (MixedDivEffortIndicator t tn) t tn s + mixedDivOutInPlaceEff :: + OpMutableNonmutEff (MixedDivEffortIndicator t tn) t tn s + +mixedDivInInPlaceEffFromPure, + mixedDivOutInPlaceEffFromPure :: + (CanBeMutable t, RoundedMixedDivide t tn) => + OpMutableNonmutEff (MixedDivEffortIndicator t tn) t tn s +mixedDivInInPlaceEffFromPure = + pureToMutableNonmutEff mixedDivInEff +mixedDivOutInPlaceEffFromPure = + pureToMutableNonmutEff mixedDivOutEff + +mixedDivInInPlaceEffFromInPlace, + mixedDivOutInPlaceEffFromInPlace :: + (RoundedMixedDivideInPlace t tn) => + (MixedDivEffortIndicator t tn) -> t -> tn -> t +mixedDivInInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedDivInInPlaceEff +mixedDivOutInPlaceEffFromInPlace = + mutableNonmutEffToPure mixedDivOutInPlaceEff + +mixedDivInInPlaceEffByConversion :: + (Convertible tn t, RoundedDivideInPlace t) => + (DivEffortIndicator t, ConvertEffortIndicator tn t) -> + OpMutableNonmut t tn s +mixedDivInInPlaceEffByConversion (effDiv, effConv) rM dM n = + do + let nConverted = convertInEff effConv n + nM <- unsafeMakeMutable nConverted + divInInPlaceEff effDiv rM dM nM + +mixedDivOutInPlaceEffByConversion :: + (Convertible tn t, RoundedDivideInPlace t) => + (DivEffortIndicator t, ConvertEffortIndicator tn t) -> + OpMutableNonmut t tn s +mixedDivOutInPlaceEffByConversion (effDiv, effConv) rM dM n = + do + let nConverted = convertOutEff effConv n + nM <- unsafeMakeMutable nConverted + divOutInPlaceEff effDiv rM dM nM + +{- properties of mixed division -} + +propMixedDivInPlaceEqualsConvert :: + (RefOrd.PartialComparison t, Convertible tn t, + RoundedMixedDivideInPlace t tn, + RoundedMixedDivide t tn, + RoundedDivide t, + Show t, HasZero t, HasLegalValues t, + Show (MixedDivEffortIndicator t tn), + EffortIndicator (MixedDivEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (RefOrd.PartialCompareEffortIndicator t, + (MixedDivEffortIndicator t tn, + DivEffortIndicator t, + ConvertEffortIndicator tn t)) -> + (RefOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedDivInPlaceEqualsConvert sample1 sample2 + initEffort@(effComp,(_,effConv,_)) + (RefOrd.UniformlyOrderedSingleton d) n + = + equalRoundingUpDn "in-place mixed division" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + expr1In (effMDiv,_,_) = + let (>/<|=) dR = mixedDivInInPlaceEff effMDiv dR dR in + runST $ + do + dR <- makeMutable d + dR >/<|= n + unsafeReadMutable dR + expr1Out (effMDiv,_,_) = + let (|=) dR = mixedDivOutInPlaceEff effMDiv dR dR in + runST $ + do + dR <- makeMutable d + dR |= n + unsafeReadMutable dR + expr2In (_,effDiv,effConv) = + let (>/<) = divInEff effDiv in d >/< (convertInEff effConv n) + expr2Out (_,effDiv,effConv) = + let () = divOutEff effDiv in d (convertOutEff effConv n) + +testsInOutMixedFieldOpsInPlace (name, sample) (nameN, sampleN) = + testGroup (name ++ " with " ++ nameN ++ ": in-place mixed up/dn rounded ops") $ + [ + testProperty "addition" (propMixedAddInPlaceEqualsConvert sample sampleN) + , + testProperty "multiplication" (propMixedMultInPlaceEqualsConvert sample sampleN) + , + testProperty "division" (propMixedDivInPlaceEqualsConvert sample sampleN) + ] + +class + (RoundedMixedAddInPlace t tn, + RoundedMixedMultiplyInPlace t tn, + RoundedMixedRingEffort t tn) => + RoundedMixedRingInPlace t tn + +class + (RoundedMixedRingInPlace t tn, + RoundedMixedDivideInPlace t tn, + RoundedMixedFieldEffort t tn) => + RoundedMixedFieldInPlace t tn + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/OpsDefaultEffort.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/OpsDefaultEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/OpsDefaultEffort.hs @@ -0,0 +1,200 @@ +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.OpsDefaultEffort + Description : convenience in-place operators and functions with default effort + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Convenience in-place operators and functions with default effort. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.OpsDefaultEffort where + +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.RefinementOrderRounding + +infixl 6 <+>=, >+<=, <->=, >-<= +infixl 7 <*>=, >*<= +infixl 8 <^>=, >^<= +infixl 7 =, >/<= + +infixl 6 <+>|=, >+<|= +infixl 7 <*>|=, >*<|= +infixl 7 |=, >/<|= + +-- | Inward rounded in-place addition +addInInPlace :: (RoundedAddInPlace t) => OpMutable2 t s +addInInPlace = mutable2EffToMutable2 addInInPlaceEff addDefaultEffort + +-- | Inward rounded addition assignment +(>+<=) :: (RoundedAddInPlace t) => OpMutable1 t s +(>+<=) = mutable2ToMutable1 addInInPlace + +-- | Outward rounded in-place addition +addOutInPlace :: (RoundedAddInPlace t) => OpMutable2 t s +addOutInPlace = mutable2EffToMutable2 addOutInPlaceEff addDefaultEffort + +-- | Outward rounded addition assignment +(<+>=) :: (RoundedAddInPlace t) => OpMutable1 t s +(<+>=) = mutable2ToMutable1 addOutInPlace + +-- | Inward rounded in-place subtraction +subtrInInPlace :: (RoundedSubtrInPlace t) => OpMutable2 t s +subtrInInPlace = mutable2EffToMutable2 subtrInInPlaceEff addDefaultEffort + +-- | Inward rounded subtraction assignment +(>-<=) :: (RoundedSubtrInPlace t) => OpMutable1 t s +(>-<=) = mutable2ToMutable1 subtrInInPlace + +-- | Outward rounded in-place subtraction +subtrOutInPlace :: (RoundedSubtrInPlace t) => OpMutable2 t s +subtrOutInPlace = mutable2EffToMutable2 subtrOutInPlaceEff addDefaultEffort + +-- | Outward rounded subtraction assignment +(<->=) :: (RoundedSubtrInPlace t) => OpMutable1 t s +(<->=) = mutable2ToMutable1 subtrOutInPlace + +-- | Inward rounded in-place absolute value +absInInPlace :: (RoundedAbsInPlace t) => OpMutable1 t s +absInInPlace = mutable1EffToMutable1 absInInPlaceEff absDefaultEffort + +-- | Outward rounded in-place absolute value +absOutInPlace :: (RoundedAbsInPlace t) => OpMutable1 t s +absOutInPlace = mutable1EffToMutable1 absOutInPlaceEff absDefaultEffort + +-- | Inward rounded in-place multiplication +multInInPlace :: (RoundedMultiplyInPlace t) => OpMutable2 t s +multInInPlace = mutable2EffToMutable2 multInInPlaceEff multDefaultEffort + +-- | Inward rounded multiplication assignment +(>*<=) :: (RoundedMultiplyInPlace t) => OpMutable1 t s +(>*<=) = mutable2ToMutable1 multInInPlace + +-- | Outward rounded in-place multiplication +multOutInPlace :: (RoundedMultiplyInPlace t) => OpMutable2 t s +multOutInPlace = mutable2EffToMutable2 multOutInPlaceEff multDefaultEffort + +-- | Outward rounded multiplication assignment +(<*>=) :: (RoundedMultiplyInPlace t) => OpMutable1 t s +(<*>=) = mutable2ToMutable1 multOutInPlace + +-- | Inward rounded in-place power +powerToNonnegIntInInPlace :: (RoundedPowerToNonnegIntInPlace t) => + OpMutableNonmut t Int s +powerToNonnegIntInInPlace = + mutableNonmutEffToMutableNonmut powerToNonnegIntInInPlaceEff powerToNonnegIntDefaultEffort + +-- | Inward rounded in-place power assignment +(>^<=) :: (RoundedPowerToNonnegIntInPlace t) => OpNonmut t Int s +(>^<=) = mutableNonmutToNonmut powerToNonnegIntInInPlace + +-- | Outward rounded in-place power +powerToNonnegIntOutInPlace :: (RoundedPowerToNonnegIntInPlace t) => + OpMutableNonmut t Int s +powerToNonnegIntOutInPlace = + mutableNonmutEffToMutableNonmut powerToNonnegIntOutInPlaceEff powerToNonnegIntDefaultEffort + +-- | Inward rounded in-place power assignment +(<^>=) :: (RoundedPowerToNonnegIntInPlace t) => OpNonmut t Int s +(<^>=) = mutableNonmutToNonmut powerToNonnegIntOutInPlace + +-- | Inward rounded in-place division +divInInPlace :: (RoundedDivideInPlace t) => OpMutable2 t s +divInInPlace = mutable2EffToMutable2 divInInPlaceEff divDefaultEffort + +-- | Inward rounded division assignment +(>/<=) :: (RoundedDivideInPlace t) => OpMutable1 t s +(>/<=) = mutable2ToMutable1 divInInPlace + +-- | Outward rounded in-place division +divOutInPlace :: (RoundedDivideInPlace t) => OpMutable2 t s +divOutInPlace = mutable2EffToMutable2 divOutInPlaceEff divDefaultEffort + +-- | Outward rounded division assignment +(=) :: (RoundedDivideInPlace t) => OpMutable1 t s +(=) = mutable2ToMutable1 divOutInPlace + +-- | Inward rounded in-place mixed addition +mixedAddInInPlace :: (RoundedMixedAddInPlace t tn) => + OpMutableNonmut t tn s +mixedAddInInPlace = + mixedEffToMutableNonmut mixedAddInInPlaceEff mixedAddDefaultEffort + +-- | Inward rounded additive scalar action assignment +(>+<|=) :: (RoundedMixedAddInPlace t tn) => OpNonmut t tn s +(>+<|=) = mutableNonmutToNonmut mixedAddInInPlace + +-- | Outward rounded in-place mixed addition +mixedAddOutInPlace :: (RoundedMixedAddInPlace t tn) => + OpMutableNonmut t tn s +mixedAddOutInPlace = + mixedEffToMutableNonmut mixedAddOutInPlaceEff mixedAddDefaultEffort + +-- | Outward rounded additive scalar action assignment +(<+>|=) :: (RoundedMixedAddInPlace t tn) => OpNonmut t tn s +(<+>|=) = mutableNonmutToNonmut mixedAddOutInPlace + +-- | Inward rounded in-place mixed multiplication +mixedMultInInPlace :: (RoundedMixedMultiplyInPlace t tn) => + OpMutableNonmut t tn s +mixedMultInInPlace = + mixedEffToMutableNonmut mixedMultInInPlaceEff mixedMultDefaultEffort + +-- | Inward rounded multiplicative scalar action assignment +(>*<|=) :: (RoundedMixedMultiplyInPlace t tn) => OpNonmut t tn s +(>*<|=) = mutableNonmutToNonmut mixedMultInInPlace + +-- | Outward rounded in-place mixed multiplication +mixedMultOutInPlace :: (RoundedMixedMultiplyInPlace t tn) => + OpMutableNonmut t tn s +mixedMultOutInPlace = + mixedEffToMutableNonmut mixedMultOutInPlaceEff mixedMultDefaultEffort + +-- | Outward rounded multiplicative scalar action assignment +(<*>|=) :: (RoundedMixedMultiplyInPlace t tn) => OpNonmut t tn s +(<*>|=) = mutableNonmutToNonmut mixedMultOutInPlace + +-- | Inward rounded in-place mixed reciprocal action +mixedDivInInPlace :: (RoundedMixedDivideInPlace t tn) => + OpMutableNonmut t tn s +mixedDivInInPlace = + mixedEffToMutableNonmut mixedDivInInPlaceEff mixedDivDefaultEffort + +-- | Inward rounded multiplicative scalar reciprocal action assignment +(>/<|=) :: (RoundedMixedDivideInPlace t tn) => OpNonmut t tn s +(>/<|=) = mutableNonmutToNonmut mixedDivOutInPlace + +-- | Outward rounded in-place mixed reciprocal action +mixedDivOutInPlace :: (RoundedMixedDivideInPlace t tn) => + OpMutableNonmut t tn s +mixedDivOutInPlace = + mixedEffToMutableNonmut mixedDivOutInPlaceEff mixedDivDefaultEffort + +-- | Outward rounded multiplicative scalar reciprocal action assignment +(|=) :: (RoundedMixedDivideInPlace t tn) => OpNonmut t tn s +(|=) = mutableNonmutToNonmut mixedDivOutInPlace + +-- | Inward rounded in-place exponential +expInInPlace :: (RoundedExponentiationInPlace t) => OpMutable1 t s +expInInPlace = mutable1EffToMutable1 expInInPlaceEff expDefaultEffort + +-- | Outward rounded in-place exponential +expOutInPlace :: (RoundedExponentiationInPlace t) => OpMutable1 t s +expOutInPlace = mutable1EffToMutable1 expOutInPlaceEff expDefaultEffort + +-- | Inward rounded in-place square root +sqrtInInPlace :: (RoundedSquareRootInPlace t) => OpMutable1 t s +sqrtInInPlace = mutable1EffToMutable1 sqrtInInPlaceEff sqrtDefaultEffort + +-- | Outward rounded in-place square root +sqrtOutInPlace :: (RoundedSquareRootInPlace t) => OpMutable1 t s +sqrtOutInPlace = mutable1EffToMutable1 sqrtOutInPlaceEff sqrtDefaultEffort + + + + + + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/OpsImplicitEffort.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/OpsImplicitEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/InPlace/OpsImplicitEffort.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.OpsImplicitEffort + Description : onvenience directed-rounded in-place operators and functions with implicit effort parameters + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Convenience directed-rounded in-place operators and functions with implicit effort parameters. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.InPlace.OpsImplicitEffort where + +import Numeric.AERN.Basics.Mutable +import Numeric.AERN.RealArithmetic.RefinementOrderRounding + +-- | Inward rounded in-place addition +addInInPlace :: + (RoundedAddInPlace t, ?addInOutEffort :: AddEffortIndicator t) => + OpMutable2 t s +addInInPlace = addInInPlaceEff ?addInOutEffort + +-- | Inward rounded addition assignment +(>+<=) :: + (RoundedAddInPlace t, ?addInOutEffort :: AddEffortIndicator t) => + OpMutable1 t s +(>+<=) = mutable2ToMutable1 addInInPlace + +-- | Outward rounded in-place addition +addOutInPlace :: + (RoundedAddInPlace t, ?addInOutEffort :: AddEffortIndicator t) => + OpMutable2 t s +addOutInPlace = addOutInPlaceEff ?addInOutEffort + +-- | Outward rounded addition assignment +(<+>=) :: + (RoundedAddInPlace t, ?addInOutEffort :: AddEffortIndicator t) => + OpMutable1 t s +(<+>=) = mutable2ToMutable1 addOutInPlace + +-- | Inward rounded in-place subtraction +subtrInInPlace :: + (RoundedSubtrInPlace t, ?addInOutEffort :: AddEffortIndicator t) => + OpMutable2 t s +subtrInInPlace = subtrInInPlaceEff ?addInOutEffort + +-- | Inward rounded subtraction assignment +(>-<=) :: + (RoundedSubtrInPlace t, ?addInOutEffort :: AddEffortIndicator t) => + OpMutable1 t s +(>-<=) = mutable2ToMutable1 subtrInInPlace + +-- | Outward rounded in-place subtraction +subtrOutInPlace :: + (RoundedSubtrInPlace t, ?addInOutEffort :: AddEffortIndicator t) => + OpMutable2 t s +subtrOutInPlace = subtrOutInPlaceEff ?addInOutEffort + +-- | Outward rounded subtraction assignment +(<->=) :: + (RoundedSubtrInPlace t, ?addInOutEffort :: AddEffortIndicator t) => + OpMutable1 t s +(<->=) = mutable2ToMutable1 subtrOutInPlace + +-- | Inward rounded in-place absolute value +absInInPlace :: + (RoundedAbsInPlace t, ?absInOutEffort :: AbsEffortIndicator t) => + OpMutable1 t s +absInInPlace = absInInPlaceEff ?absInOutEffort + +-- | Outward rounded in-place absolute value +absOutInPlace :: + (RoundedAbsInPlace t, ?absInOutEffort :: AbsEffortIndicator t) => + OpMutable1 t s +absOutInPlace = absOutInPlaceEff ?absInOutEffort + +-- | Inward rounded in-place multiplication +multInInPlace :: + (RoundedMultiplyInPlace t, ?multInOutEffort :: MultEffortIndicator t) => + OpMutable2 t s +multInInPlace = multInInPlaceEff ?multInOutEffort + +-- | Inward rounded multiplication assignment +(>*<=) :: + (RoundedMultiplyInPlace t, ?multInOutEffort :: MultEffortIndicator t) => + OpMutable1 t s +(>*<=) = mutable2ToMutable1 multInInPlace + +-- | Outward rounded in-place multiplication +multOutInPlace :: + (RoundedMultiplyInPlace t, ?multInOutEffort :: MultEffortIndicator t) => + OpMutable2 t s +multOutInPlace = multOutInPlaceEff ?multInOutEffort + +-- | Outward rounded multiplication assignment +(<*>=) :: + (RoundedMultiplyInPlace t, ?multInOutEffort :: MultEffortIndicator t) => + OpMutable1 t s +(<*>=) = mutable2ToMutable1 multOutInPlace + +-- | Inward rounded in-place power +powerToNonnegIntInInPlace :: + (RoundedPowerToNonnegIntInPlace t, + ?intPowerInOutEffort :: PowerToNonnegIntEffortIndicator t) => + OpMutableNonmut t Int s +powerToNonnegIntInInPlace = powerToNonnegIntInInPlaceEff ?intPowerInOutEffort + +-- | Inward rounded in-place power assignment +(>^<=) :: + (RoundedPowerToNonnegIntInPlace t, + ?intPowerInOutEffort :: PowerToNonnegIntEffortIndicator t) => + OpNonmut t Int s +(>^<=) = mutableNonmutToNonmut powerToNonnegIntInInPlace + +-- | Outward rounded in-place power +powerToNonnegIntOutInPlace :: + (RoundedPowerToNonnegIntInPlace t, + ?intPowerInOutEffort :: PowerToNonnegIntEffortIndicator t) => + OpMutableNonmut t Int s +powerToNonnegIntOutInPlace = powerToNonnegIntOutInPlaceEff ?intPowerInOutEffort + +-- | Inward rounded in-place power assignment +(<^>=) :: + (RoundedPowerToNonnegIntInPlace t, + ?intPowerInOutEffort :: PowerToNonnegIntEffortIndicator t) => + OpNonmut t Int s +(<^>=) = mutableNonmutToNonmut powerToNonnegIntOutInPlace + +-- | Inward rounded in-place division +divInInPlace :: + (RoundedDivideInPlace t, ?divInOutEffort :: DivEffortIndicator t) => + OpMutable2 t s +divInInPlace = divInInPlaceEff ?divInOutEffort + +-- | Inward rounded division assignment +(>/<=) :: + (RoundedDivideInPlace t, ?divInOutEffort :: DivEffortIndicator t) => + OpMutable1 t s +(>/<=) = mutable2ToMutable1 divInInPlace + +-- | Outward rounded in-place division +divOutInPlace :: + (RoundedDivideInPlace t, ?divInOutEffort :: DivEffortIndicator t) => + OpMutable2 t s +divOutInPlace = divOutInPlaceEff ?divInOutEffort + +-- | Outward rounded division assignment +(=) :: + (RoundedDivideInPlace t, ?divInOutEffort :: DivEffortIndicator t) => + OpMutable1 t s +(=) = mutable2ToMutable1 divOutInPlace + +-- the following does not work, but is kept here as a template for +-- cut and pasting the "let"s +withFieldOpsEffortIndicator effortField expression = + let ?addInOutEffort = fldEffortAdd effortField in + let ?multInOutEffort = fldEffortMult effortField in + let ?intPowerInOutEffort = fldEffortPow effortField in + let ?divInOutEffort = fldEffortDiv effortField in + expression + +-- | Inward rounded in-place mixed addition +mixedAddInInPlace :: + (RoundedMixedAddInPlace t tn, + ?mixedAddInOutEffort :: MixedAddEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedAddInInPlace = mixedAddInInPlaceEff ?mixedAddInOutEffort + +-- | Inward rounded additive scalar action assignment +(>+<|=) :: + (RoundedMixedAddInPlace t tn, + ?mixedAddInOutEffort :: MixedAddEffortIndicator t tn) => + OpNonmut t tn s +(>+<|=) = mutableNonmutToNonmut mixedAddInInPlace + +-- | Outward rounded in-place mixed addition +mixedAddOutInPlace :: + (RoundedMixedAddInPlace t tn, + ?mixedAddInOutEffort :: MixedAddEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedAddOutInPlace = mixedAddOutInPlaceEff ?mixedAddInOutEffort + +-- | Outward rounded additive scalar action assignment +(<+>|=) :: + (RoundedMixedAddInPlace t tn, + ?mixedAddInOutEffort :: MixedAddEffortIndicator t tn) => + OpNonmut t tn s +(<+>|=) = mutableNonmutToNonmut mixedAddOutInPlace + +-- | Inward rounded in-place mixed multiplication +mixedMultInInPlace :: + (RoundedMixedMultiplyInPlace t tn, + ?mixedMultInOutEffort :: MixedMultEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedMultInInPlace = mixedMultInInPlaceEff ?mixedMultInOutEffort + +-- | Inward rounded multiplicative scalar action assignment +(>*<|=) :: + (RoundedMixedMultiplyInPlace t tn, + ?mixedMultInOutEffort :: MixedMultEffortIndicator t tn) => + OpNonmut t tn s +(>*<|=) = mutableNonmutToNonmut mixedMultInInPlace + +-- | Outward rounded in-place mixed multiplication +mixedMultOutInPlace :: + (RoundedMixedMultiplyInPlace t tn, + ?mixedMultInOutEffort :: MixedMultEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedMultOutInPlace = mixedMultOutInPlaceEff ?mixedMultInOutEffort + +-- | Outward rounded multiplicative scalar action assignment +(<*>|=) :: + (RoundedMixedMultiplyInPlace t tn, + ?mixedMultInOutEffort :: MixedMultEffortIndicator t tn) => + OpNonmut t tn s +(<*>|=) = mutableNonmutToNonmut mixedMultOutInPlace + +-- | Inward rounded in-place mixed reciprocal action +mixedDivInInPlace :: + (RoundedMixedDivideInPlace t tn, + ?mixedDivInOutEffort :: MixedDivEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedDivInInPlace = mixedDivInInPlaceEff ?mixedDivInOutEffort + +-- | Inward rounded multiplicative scalar reciprocal action assignment +(>/<|=) :: + (RoundedMixedDivideInPlace t tn, + ?mixedDivInOutEffort :: MixedDivEffortIndicator t tn) => + OpNonmut t tn s +(>/<|=) = mutableNonmutToNonmut mixedDivInInPlace + +-- | Outward rounded in-place mixed reciprocal action +mixedDivOutInPlace :: + (RoundedMixedDivideInPlace t tn, + ?mixedDivInOutEffort :: MixedDivEffortIndicator t tn) => + OpMutableNonmut t tn s +mixedDivOutInPlace = mixedDivOutInPlaceEff ?mixedDivInOutEffort + +-- | Outward rounded multiplicative scalar reciprocal action assignment +(|=) :: + (RoundedMixedDivideInPlace t tn, + ?mixedDivInOutEffort :: MixedDivEffortIndicator t tn) => + OpNonmut t tn s +(|=) = mutableNonmutToNonmut mixedDivOutInPlace + +-- the following does not work, but is kept here as a template for +-- cut and pasting the "let"s +withMixedFieldOpsEffortIndicator effortMixedField expression = + let ?mixedAddInOutEffort = mxfldEffortAdd effortMixedField in + let ?mixedMultInOutEffort = mxfldEffortMult effortMixedField in + let ?mixedDivInOutEffort = mxfldEffortDiv effortMixedField in + expression + +-- | Inward rounded in-place exponential +expInInPlace :: + (RoundedExponentiationInPlace t, ?expInOutEffort :: ExpEffortIndicator t) => + OpMutable1 t s +expInInPlace = expInInPlaceEff ?expInOutEffort + +-- | Outward rounded in-place exponential +expOutInPlace :: + (RoundedExponentiationInPlace t, ?expInOutEffort :: ExpEffortIndicator t) => + OpMutable1 t s +expOutInPlace = expOutInPlaceEff ?expInOutEffort + +-- | Inward rounded in-place square root +sqrtInInPlace :: + (RoundedSquareRootInPlace t, ?sqrtInOutEffort :: SqrtEffortIndicator t) => + OpMutable1 t s +sqrtInInPlace = sqrtInInPlaceEff ?sqrtInOutEffort + +-- | Outward rounded in-place square root +sqrtOutInPlace :: + (RoundedSquareRootInPlace t, ?sqrtInOutEffort :: SqrtEffortIndicator t) => + OpMutable1 t s +sqrtOutInPlace = sqrtOutInPlaceEff ?sqrtInOutEffort diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/MixedFieldOps.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/MixedFieldOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/MixedFieldOps.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RefinementOrderRounding.MixedFieldOps + Description : rounded basic arithmetic operations mixing 2 types + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Rounded basic arithmetical operations mixing 2 types. + + This module is hidden and reexported via its parent RefinementOrderRounding. +-} +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.MixedFieldOps where + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.FieldOps +import Numeric.AERN.RealArithmetic.RefinementOrderRounding.Conversion +import Numeric.AERN.RealArithmetic.ExactOps + +import Numeric.AERN.Basics.Effort +import Numeric.AERN.Basics.Exception (HasLegalValues) +import Numeric.AERN.RealArithmetic.Laws +import Numeric.AERN.RealArithmetic.Measures +import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd +import Numeric.AERN.Basics.RefinementOrder.OpsImplicitEffort + +import Test.QuickCheck +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +class RoundedMixedAddEffort t tn where + type MixedAddEffortIndicator t tn + mixedAddDefaultEffort :: t -> tn -> MixedAddEffortIndicator t tn + +class (RoundedMixedAddEffort t tn) => RoundedMixedAdd t tn where + mixedAddInEff :: MixedAddEffortIndicator t tn -> t -> tn -> t + mixedAddOutEff :: MixedAddEffortIndicator t tn -> t -> tn -> t + +mixedAddDefaultEffortByConversion d n = + (addDefaultEffort d, convertDefaultEffort n d) + +mixedAddInEffByConversion :: + (Convertible tn t, RoundedAdd t) => + (AddEffortIndicator t, ConvertEffortIndicator tn t) -> + t -> tn -> t +mixedAddInEffByConversion (effAdd, effConv) d n = + addInEff effAdd d (convertInEff effConv n) + +mixedAddOutEffByConversion :: + (Convertible tn t, RoundedAdd t) => + (AddEffortIndicator t, ConvertEffortIndicator tn t) -> + t -> tn -> t +mixedAddOutEffByConversion (effAdd, effConv) d n = + addOutEff effAdd d (convertOutEff effConv n) + + +propMixedAddEqualsConvert :: + (RefOrd.PartialComparison t, Convertible tn t, + RoundedMixedAdd t tn, RoundedAdd t, + Show t, HasLegalValues t, + Show (MixedAddEffortIndicator t tn), + EffortIndicator (MixedAddEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (AddEffortIndicator t), + EffortIndicator (AddEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (RefOrd.PartialCompareEffortIndicator t, + (MixedAddEffortIndicator t tn, + AddEffortIndicator t, + ConvertEffortIndicator tn t)) -> + (RefOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedAddEqualsConvert sample sampleN initEffort + (RefOrd.UniformlyOrderedSingleton d) n = + equalRoundingUpDn "mixed addition by conversion" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + expr1In (effMAdd,_,_) = + let (>+<|) = mixedAddInEff effMAdd in d >+<| n + expr1Out (effMAdd,_,_) = + let (<+>|) = mixedAddOutEff effMAdd in d <+>| n + expr2In (_,effAdd,effConv) = + let (>+<) = addInEff effAdd in d >+< (convertInEff effConv n) + expr2Out (_,effAdd,effConv) = + let (<+>) = addOutEff effAdd in d <+> (convertOutEff effConv n) + + +class RoundedMixedMultiplyEffort t tn where + type MixedMultEffortIndicator t tn + mixedMultDefaultEffort :: t -> tn -> MixedMultEffortIndicator t tn + +class (RoundedMixedMultiplyEffort t tn) => RoundedMixedMultiply t tn where + mixedMultInEff :: MixedMultEffortIndicator t tn -> t -> tn -> t + mixedMultOutEff :: MixedMultEffortIndicator t tn -> t -> tn -> t + +mixedMultDefaultEffortByConversion d n = + (multDefaultEffort d, convertDefaultEffort n d) + +mixedMultInEffByConversion :: + (Convertible tn t, RoundedMultiply t) => + (MultEffortIndicator t, ConvertEffortIndicator tn t) -> + t -> tn -> t +mixedMultInEffByConversion (effMult, effConv) d n = + multInEff effMult d (convertInEff effConv n) + +mixedMultOutEffByConversion :: + (Convertible tn t, RoundedMultiply t) => + (MultEffortIndicator t, ConvertEffortIndicator tn t) -> + t -> tn -> t +mixedMultOutEffByConversion (effMult, effConv) d n = + multOutEff effMult d (convertOutEff effConv n) + + +propMixedMultEqualsConvert :: + (RefOrd.PartialComparison t, Convertible tn t, + RoundedMixedMultiply t tn, RoundedMultiply t, + Show t, HasLegalValues t, + Show (MixedMultEffortIndicator t tn), + EffortIndicator (MixedMultEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (MultEffortIndicator t), + EffortIndicator (MultEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (RefOrd.PartialCompareEffortIndicator t, + (MixedMultEffortIndicator t tn, + MultEffortIndicator t, + ConvertEffortIndicator tn t)) -> + (RefOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedMultEqualsConvert sample sampleN initEffort + (RefOrd.UniformlyOrderedSingleton d) n = + equalRoundingUpDn "mixed multiplication by conversion" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + expr1In (effMMult,_,_) = + let (>*<|) = mixedMultInEff effMMult in d >*<| n + expr1Out (effMMult,_,_) = + let (<*>|) = mixedMultOutEff effMMult in d <*>| n + expr2In (_,effMult,effConv) = + let (>*<) = multInEff effMult in d >*< (convertInEff effConv n) + expr2Out (_,effMult,effConv) = + let (<*>) = multOutEff effMult in d <*> (convertOutEff effConv n) + +class RoundedMixedDivideEffort t tn where + type MixedDivEffortIndicator t tn + mixedDivDefaultEffort :: t -> tn -> MixedDivEffortIndicator t tn + +class (RoundedMixedDivideEffort t tn) => RoundedMixedDivide t tn where + mixedDivInEff :: MixedDivEffortIndicator t tn -> t -> tn -> t + mixedDivOutEff :: MixedDivEffortIndicator t tn -> t -> tn -> t + +mixedDivDefaultEffortByConversion d n = + (divDefaultEffort d, convertDefaultEffort n d) + +mixedDivInEffByConversion :: + (Convertible tn t, RoundedDivide t) => + (DivEffortIndicator t, ConvertEffortIndicator tn t) -> + t -> tn -> t +mixedDivInEffByConversion (effDiv, effConv) d n = + divInEff effDiv d (convertInEff effConv n) + +mixedDivOutEffByConversion :: + (Convertible tn t, RoundedDivide t) => + (DivEffortIndicator t, ConvertEffortIndicator tn t) -> + t -> tn -> t +mixedDivOutEffByConversion (effDiv, effConv) d n = + divOutEff effDiv d (convertOutEff effConv n) + + +propMixedDivEqualsConvert :: + (RefOrd.PartialComparison t, Convertible tn t, + RoundedMixedDivide t tn, RoundedDivide t, + Show t, HasZero t, HasLegalValues t, + Show (MixedDivEffortIndicator t tn), + EffortIndicator (MixedDivEffortIndicator t tn), + Show (ConvertEffortIndicator tn t), + EffortIndicator (ConvertEffortIndicator tn t), + Show (DivEffortIndicator t), + EffortIndicator (DivEffortIndicator t), + Show (RefOrd.PartialCompareEffortIndicator t), + EffortIndicator (RefOrd.PartialCompareEffortIndicator t) + ) => + t -> tn -> + (RefOrd.PartialCompareEffortIndicator t, + (MixedDivEffortIndicator t tn, + DivEffortIndicator t, + ConvertEffortIndicator tn t)) -> + (RefOrd.UniformlyOrderedSingleton t) -> + tn -> Bool +propMixedDivEqualsConvert sample sampleN initEffort@(effComp,(_,_,effConv)) + (RefOrd.UniformlyOrderedSingleton d) n + = + equalRoundingUpDn "mixed division by conversion" + expr1In expr1Out expr2In expr2Out + RefOrd.pLeqEff initEffort + where + expr1In (effMDiv,_,_) = + let (>/<|) = mixedDivInEff effMDiv in d >/<| n + expr1Out (effMDiv,_,_) = + let (|) = mixedDivOutEff effMDiv in d | n + expr2In (_,effDiv,effConv) = + let (>/<) = divInEff effDiv in d >/< (convertInEff effConv n) + expr2Out (_,effDiv,effConv) = + let () = divOutEff effDiv in d (convertOutEff effConv n) + + +testsInOutMixedFieldOps (name, sample) (nameN, sampleN) = + testGroup (name ++ " with " ++ nameN ++ ": mixed in/out rounded ops") $ + [ + testProperty "addition" (propMixedAddEqualsConvert sample sampleN) + , + testProperty "multiplication" (propMixedMultEqualsConvert sample sampleN) + , + testProperty "division" (propMixedDivEqualsConvert sample sampleN) + ] + +class (RoundedMixedAddEffort t tn, RoundedMixedMultiplyEffort t tn) => + RoundedMixedRingEffort t tn + where + type MixedRingOpsEffortIndicator t tn + mixedRingOpsDefaultEffort :: t -> tn -> MixedRingOpsEffortIndicator t tn + mxringEffortAdd :: t -> tn -> MixedRingOpsEffortIndicator t tn -> MixedAddEffortIndicator t tn + mxringEffortMult :: t -> tn -> MixedRingOpsEffortIndicator t tn -> MixedMultEffortIndicator t tn + +class (RoundedMixedAdd t tn, RoundedMixedMultiply t tn) => + RoundedMixedRing t tn + +class (RoundedMixedRingEffort t tn, RoundedMixedDivideEffort t tn) => + RoundedMixedFieldEffort t tn + where + type MixedFieldOpsEffortIndicator t tn + mixedFieldOpsDefaultEffort :: t -> tn -> MixedFieldOpsEffortIndicator t tn + mxfldEffortAdd :: t -> tn -> MixedFieldOpsEffortIndicator t tn -> MixedAddEffortIndicator t tn + mxfldEffortMult :: t -> tn -> MixedFieldOpsEffortIndicator t tn -> MixedMultEffortIndicator t tn + mxfldEffortDiv :: t -> tn -> MixedFieldOpsEffortIndicator t tn -> MixedDivEffortIndicator t tn + +class (RoundedMixedRing t tn, RoundedMixedDivide t tn, RoundedMixedFieldEffort t tn) => + RoundedMixedField t tn + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/OpsDefaultEffort.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/OpsDefaultEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/OpsDefaultEffort.hs @@ -0,0 +1,159 @@ +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.OpsDefaultEffort + Description : convenience operators and functions with default effort + Copyright : (c) Michal Konecny, Jan Duracz + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Convenience operators and functions with default effort. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.OpsDefaultEffort where + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding + +infixl 6 <+>, >+<, <->, >-< +infixl 7 <*>, >*< +infixl 8 <^>, >^< +infixl 7 , >/< + +infixr 6 |<+>, |>+< +infixl 6 <+>|, >+<| +infixr 7 |<*>, |>*< +infixl 7 <*>|, >*<| +infixl 7 |, >/<| + +-- | Inward rounded addition +(>+<) :: (RoundedAdd t) => t -> t -> t +(>+<) d = addInEff (addDefaultEffort d) d + +-- | Outward rounded addition +(<+>) :: (RoundedAdd t) => t -> t -> t +(<+>) d = addOutEff (addDefaultEffort d) d + +-- | Inward rounded subtraction +(>-<) :: (RoundedSubtr t) => t -> t -> t +(>-<) d = subtrInEff (addDefaultEffort d) d + +-- | Outward rounded subtraction +(<->) :: (RoundedSubtr t) => t -> t -> t +(<->) d = subtrOutEff (addDefaultEffort d) d + +-- | Inward rounded absolute value +absIn :: (RoundedAbs t) => t -> t +absIn d = absInEff (absDefaultEffort d) d + +-- | Outward rounded absolute value +absOut :: (RoundedAbs t) => t -> t +absOut d = absOutEff (absDefaultEffort d) d + +-- | Inward rounded multiplication +(>*<) :: (RoundedMultiply t) => t -> t -> t +(>*<) d = multInEff (multDefaultEffort d) d + +-- | Outward rounded multiplication +(<*>) :: (RoundedMultiply t) => t -> t -> t +(<*>) d = multOutEff (multDefaultEffort d) d + +-- | Inward rounded power +(>^<) :: (RoundedPowerToNonnegInt t) => t -> Int -> t +(>^<) d = powerToNonnegIntInEff (powerToNonnegIntDefaultEffort d) d + +-- | Outward rounded power +(<^>) :: (RoundedPowerToNonnegInt t) => t -> Int -> t +(<^>) d = powerToNonnegIntOutEff (powerToNonnegIntDefaultEffort d) d + +-- | Inward rounded division +(>/<) :: (RoundedDivide t) => t -> t -> t +(>/<) d = divInEff (divDefaultEffort d) d + +-- | Outward rounded division +() :: (RoundedDivide t) => t -> t -> t +() d = divOutEff (divDefaultEffort d) d + +-- | Inward rounded additive scalar left action +(|>+<) :: (RoundedMixedAdd t tn) => tn -> t -> t +(|>+<) n d = mixedAddInEff (mixedAddDefaultEffort d n) d n + +-- | Outward rounded additive scalar left action +(|<+>) :: (RoundedMixedAdd t tn) => tn -> t -> t +(|<+>) n d = mixedAddOutEff (mixedAddDefaultEffort d n) d n + +-- | Inward rounded additive scalar right action +(>+<|) :: (RoundedMixedAdd t tn) => t -> tn -> t +(>+<|) d n = mixedAddInEff (mixedAddDefaultEffort d n) d n + +-- | Outward rounded additive scalar right action +(<+>|) :: (RoundedMixedAdd t tn) => t -> tn -> t +(<+>|) d n = mixedAddOutEff (mixedAddDefaultEffort d n) d n + +-- | Inward rounded multiplicative scalar left action +(|>*<) :: (RoundedMixedMultiply t tn) => tn -> t -> t +(|>*<) n d = mixedMultInEff (mixedMultDefaultEffort d n) d n + +-- | Outward rounded multiplicative scalar left action +(|<*>) :: (RoundedMixedMultiply t tn) => tn -> t -> t +(|<*>) n d = mixedMultOutEff (mixedMultDefaultEffort d n) d n + +-- | Inward rounded multiplicative scalar right action +(>*<|) :: (RoundedMixedMultiply t tn) => t -> tn -> t +(>*<|) d n = mixedMultInEff (mixedMultDefaultEffort d n) d n + +-- | Outward rounded multiplicative scalar right action +(<*>|) :: (RoundedMixedMultiply t tn) => t -> tn -> t +(<*>|) d n = mixedMultOutEff (mixedMultDefaultEffort d n) d n + +-- | Inward rounded multiplicative scalar reciprocal right action +(>/<|) :: (RoundedMixedDivide t tn) => t -> tn -> t +(>/<|) d n = mixedDivInEff (mixedDivDefaultEffort d n) d n + +-- | Outward rounded multiplicative scalar reciprocal right action +(|) :: (RoundedMixedDivide t tn) => t -> tn -> t +(|) d n = mixedDivOutEff (mixedDivDefaultEffort d n) d n + +-- | Inward rounded pi +piIn :: (RoundedSpecialConst t) => t +piIn = result + where + result = + piInEff (specialConstDefaultEffort result) + +-- | Outward rounded pi +piOut :: (RoundedSpecialConst t) => t +piOut = result + where + result = + piOutEff (specialConstDefaultEffort result) + +-- | Inward rounded e +eIn :: (RoundedSpecialConst t) => t +eIn = result + where + result = + eInEff (specialConstDefaultEffort result) + +-- | Outward rounded e +eOut :: (RoundedSpecialConst t) => t +eOut = result + where + result = + eOutEff (specialConstDefaultEffort result) + +-- | Inward rounded exponential +expIn :: (RoundedExponentiation t) => t -> t +expIn d = expInEff (expDefaultEffort d) d + +-- | Outward rounded exponential +expOut :: (RoundedExponentiation t) => t -> t +expOut d = expOutEff (expDefaultEffort d) d + +-- | Inward rounded square root +sqrtIn :: (RoundedSquareRoot t) => t -> t +sqrtIn d = sqrtInEff (sqrtDefaultEffort d) d + +-- | Outward rounded square root +sqrtOut :: (RoundedSquareRoot t) => t -> t +sqrtOut d = sqrtOutEff (sqrtDefaultEffort d) d diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/OpsImplicitEffort.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/OpsImplicitEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/OpsImplicitEffort.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.OpsImplicitEffort + Description : convenience binary infix operators with implicit effort parameters + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Convenience binary infix operators with implicit effort parameters. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.OpsImplicitEffort where + +import Numeric.AERN.RealArithmetic.RefinementOrderRounding + +infixl 6 <+>, >+<, <->, >-< +infixl 7 <*>, >*< +infixl 8 <^>, >^< +infixl 7 , >/< + +infixr 6 |<+>, |>+< +infixl 6 <+>|, >+<| +infixr 7 |<*>, |>*< +infixl 7 <*>|, >*<| +infixl 7 |, >/<| + + +(>+<), (<+>) :: + (RoundedAdd t, ?addInOutEffort :: AddEffortIndicator t) => + t -> t -> t +(>+<) = addInEff ?addInOutEffort +(<+>) = addOutEff ?addInOutEffort + +(>-<), (<->) :: + (RoundedSubtr t, ?addInOutEffort :: AddEffortIndicator t) => + t -> t -> t +(>-<) = subtrInEff ?addInOutEffort +(<->) = subtrOutEff ?addInOutEffort + +absIn, absOut :: + (RoundedAbs t, ?absInOutEffort :: AbsEffortIndicator t) => + t -> t +absIn = absInEff ?absInOutEffort +absOut = absOutEff ?absInOutEffort + +(>*<), (<*>) :: + (RoundedMultiply t, ?multInOutEffort :: MultEffortIndicator t) => + t -> t -> t +(>*<) = multInEff ?multInOutEffort +(<*>) = multOutEff ?multInOutEffort + +(>^<), (<^>) :: + (RoundedPowerToNonnegInt t, ?intPowerInOutEffort :: PowerToNonnegIntEffortIndicator t) => + t -> Int -> t +(>^<) = powerToNonnegIntInEff ?intPowerInOutEffort +(<^>) = powerToNonnegIntOutEff ?intPowerInOutEffort + +(>/<), () :: + (RoundedDivide t, ?divInOutEffort :: DivEffortIndicator t) => + t -> t -> t +(>/<) = divInEff ?divInOutEffort +() = divOutEff ?divInOutEffort + +-- the following does not work, but is kept here as a template for +-- cut and pasting the "let"s +withFieldOpsEffortIndicator effortField expression = + let ?addInOutEffort = fldEffortAdd effortField in + let ?multInOutEffort = fldEffortMult effortField in + let ?intPowerInOutEffort = fldEffortPow effortField in + let ?divInOutEffort = fldEffortDiv effortField in + expression + +(|>+<), (|<+>) :: + (RoundedMixedAdd t tn, + ?mixedAddInOutEffort :: MixedAddEffortIndicator t tn) => + tn -> t -> t +(|>+<) n d = mixedAddInEff ?mixedAddInOutEffort d n +(|<+>) n d = mixedAddOutEff ?mixedAddInOutEffort d n + +(>+<|), (<+>|) :: + (RoundedMixedAdd t tn, + ?mixedAddInOutEffort :: MixedAddEffortIndicator t tn) => + t -> tn -> t +(>+<|) = mixedAddInEff ?mixedAddInOutEffort +(<+>|) = mixedAddOutEff ?mixedAddInOutEffort + +(|>*<), (|<*>) :: + (RoundedMixedMultiply t tn, + ?mixedMultInOutEffort :: MixedMultEffortIndicator t tn) => + tn -> t -> t +(|>*<) n d = mixedMultInEff ?mixedMultInOutEffort d n +(|<*>) n d = mixedMultOutEff ?mixedMultInOutEffort d n + +(>*<|), (<*>|) :: + (RoundedMixedMultiply t tn, + ?mixedMultInOutEffort :: MixedMultEffortIndicator t tn) => + t -> tn -> t +(>*<|) = mixedMultInEff ?mixedMultInOutEffort +(<*>|) = mixedMultOutEff ?mixedMultInOutEffort + +(>/<|), (|) :: + (RoundedMixedDivide t tn, + ?mixedDivInOutEffort :: MixedDivEffortIndicator t tn) => + t -> tn -> t +(>/<|) = mixedDivInEff ?mixedDivInOutEffort +(|) = mixedDivOutEff ?mixedDivInOutEffort + +-- the following does not work, but is kept here as a template for +-- cut and pasting the "let"s +withMixedFieldOpsEffortIndicator effortMixedField expression = + let ?mixedAddInOutEffort = mxfldEffortAdd effortMixedField in + let ?mixedMultInOutEffort = mxfldEffortMult effortMixedField in + let ?mixedDivInOutEffort = mxfldEffortDiv effortMixedField in + expression + + +piIn, piOut :: + (RoundedSpecialConst t, ?specialConstInOutEffort :: SpecialConstEffortIndicator t) => + t +piIn = piInEff ?specialConstInOutEffort +piOut = piOutEff ?specialConstInOutEffort + +eIn, eOut :: + (RoundedSpecialConst t, ?specialConstInOutEffort :: SpecialConstEffortIndicator t) => + t +eIn = eInEff ?specialConstInOutEffort +eOut = eOutEff ?specialConstInOutEffort + +expIn, expOut :: + (RoundedExponentiation t, ?expInOutEffort :: ExpEffortIndicator t) => + t -> t +expIn = expInEff ?expInOutEffort +expOut = expOutEff ?expInOutEffort + +sqrtIn, sqrtOut :: + (RoundedSquareRoot t, ?sqrtInOutEffort :: SqrtEffortIndicator t) => + t -> t +sqrtIn = sqrtInEff ?sqrtInOutEffort +sqrtOut = sqrtOutEff ?sqrtInOutEffort + diff --git a/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/SpecialConst.hs b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/SpecialConst.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/RealArithmetic/RefinementOrderRounding/SpecialConst.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-| + Module : Numeric.AERN.RealArithmetic.RefinementOrderRounding.SpecialConst + Description : support for common constants such as pi + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Support for common constants such as pi. + + This module is hidden and reexported via its parent RefinementOrderRounding. +-} + +module Numeric.AERN.RealArithmetic.RefinementOrderRounding.SpecialConst where + +--import Numeric.AERN.Basics.Effort +--import Numeric.AERN.Basics.Exception +--import Numeric.AERN.Basics.ShowInternals +--import Numeric.AERN.RealArithmetic.Laws +--import Numeric.AERN.RealArithmetic.Measures +--import qualified Numeric.AERN.Basics.NumericOrder as NumOrd +--import Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort +-- +--import Numeric.AERN.Misc.Debug +-- +--import Test.QuickCheck +--import Test.Framework (testGroup, Test) +--import Test.Framework.Providers.QuickCheck2 (testProperty) + +class RoundedSpecialConstEffort t where + type SpecialConstEffortIndicator t + specialConstDefaultEffort :: t -> SpecialConstEffortIndicator t + +class (RoundedSpecialConstEffort t) => RoundedSpecialConst t where + piInEff :: (SpecialConstEffortIndicator t) -> t + piOutEff :: (SpecialConstEffortIndicator t) -> t + eInEff :: (SpecialConstEffortIndicator t) -> t + eOutEff :: (SpecialConstEffortIndicator t) -> t + + diff --git a/tests/RunERIntervalTests.hs b/tests/RunERIntervalTests.hs deleted file mode 100644 --- a/tests/RunERIntervalTests.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| - Module : Main - Description : laucher for approximated exact real arithmetic tests - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mik@konecny.aow.cz - Stability : experimental - Portability : portable - - An executable for easy automated launch of tests - of approximated exact real arithmetic. --} -module Main where - -import qualified Data.Number.ER.Real.Approx as RA -import Data.Number.ER.Real.Approx.Tests.Run -import Data.Number.ER.Real.DefaultRepr - ---import Data.Number.ER.Real.Approx.Tests.Properties ---import Data.Number.ER.Real.Approx.Tests.Generate - -main = - do - runRATests "interval-double" sampleRABM (RA.initialiseBaseArithmetic sampleRABM) - runRATests "interval-haskell" sampleRABM (RA.initialiseBaseArithmetic sampleRABAP) - runRATests "interval-haskell-double" sampleRABM (RA.initialiseBaseArithmetic sampleRABMAP) -#ifdef USE_MPFR - runRATests "interval-mpfr" sampleRABM (RA.initialiseBaseArithmetic sampleRABMPFR) -#endif - -sampleRABM :: RA BM -sampleRABAP :: RA BAP -sampleRABMAP :: RA BMAP -sampleRABM = 0 -sampleRABAP = 0 -sampleRABMAP = 0 - -#ifdef USE_MPFR -sampleRABMPFR :: RA BMPFR -sampleRABMPFR = 0 -#endif