packages feed

aern2-real 0.1.2 → 0.2.0.0

raw patch · 45 files changed

+1698/−5515 lines, 45 filesdep +collect-errorsdep +integer-logarithmsdep −aern2-realdep −aesondep −bytestringdep ~QuickCheckdep ~aern2-mpdep ~hspec

Dependencies added: collect-errors, integer-logarithms

Dependencies removed: aern2-real, aeson, bytestring, containers, convertible, lens, random, stm, transformers

Dependency ranges changed: QuickCheck, aern2-mp, hspec, mixed-types-num

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015-2017 Michal Konecny+Copyright (c) 2015-2021 Michal Konecny All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+ README.md view
@@ -0,0 +1,110 @@+# aern2-real++Exact real arithmetic++## Numeric data types++This package provides the following two data types:++* `CReal`:  Exact real numbers via lazy sequences of interval approximations+  +* `CKleenean`: Lazy Kleeneans, naturally arising from comparisons of `CReal`s+  +The type `CReal` has instances of both [mixed-types-num](https://hackage.haskell.org/package/mixed-types-num) type classes such as `CanAdd`, `CanSqrt` as well as with traditional Prelude type classes such as `Ord`, `Num` and `Floating`.+The type `CKleenean` supports the usual Boolean operations.++### Examples++First, let us test exact real arithmetic with Prelude operations:++    $ stack ghci aern2-real:lib --no-load --ghci-options AERN2.Real+    *AERN2.MP> import Prelude hiding (pi)+    *AERN2.MP Prelude>++    ...> pi+    {?(prec 36): [3.141592653584666550159454345703125 ± ~1.4552e-11 ~2^(-36)]}++    ...> pi ? (bits 1000)+    [3.141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117... ± ~0.0000 ~2^(-1230)]++    ...> pi ? (bits 1000000)+    [3.141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117... ± ~0.0000 ~2^(-1028468)]+    (4.12 secs, 270,972,152 bytes)++    ...> pi ^ 2+    [9.8696044010893586188344909998725639610631902560... ± ~8.1120e-30 ~2^(-96)]+    {?(prec 36): [9.8696044009993784129619598388671875 ± ~1.4964e-10 ~2^(-32)]}++    ...> pi ^ pi+    <interactive>:18:1: error:+        • No instance for (Integral CReal) arising from a use of ‘^’++    ...> sin pi+    {?(prec 36): [0.000000000005126565838509122841060161590576171875 ± ~1.4559e-11 ~2^(-35)]}++    ...> (sin pi) ? (bits 10000) -- guaranteed accuracy at least 10000+    [-0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000... ± ~0.0000 ~2^(-13539)]+    (0.21 secs, 196,580,192 bytes)++    ...> (sin pi) ? (prec 10000) -- no guaranteed accuracy+    [-0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000... ± ~0.0000 ~2^(-13539)]+    (0.13 secs, 107,844,784 bytes)++    ...> pi > 0+    True++    ...> pi == pi+    *** Exception: Failed to decide equality of Sequences.  If you switch to MixedTypesNumPrelude instead of Prelude, comparison of Sequences returns CSequence Kleenean or similar instead of Bool.++Some things do not work with Prelude. Let us try using MixedTypesNumPrelude operations:++    $ stack ghci aern2-real:lib --no-load --ghci-options AERN2.Real+    *AERN2.MP> import MixedTypesNumPrelude+    *AERN2.MP MixedTypesNumPrelude>++    ...> pi ^ pi+    {?(prec 36): [36.462159605538498632520418490483602438877178488347481362195878876490337527904728176508797332644462... ± ~2.7112e-9 ~2^(-28)]}++    ...> (pi ^ pi) ? (bits 10000)+    [36.462159607207911770990826022692123666365508402228818738709335922934074368881699904620079875706774... ± ~0.0000 ~2^(-13532)]+    (0.81 secs, 631,865,912 bytes)++    ...> pi > 0+    {?(prec 36): CertainTrue}++    ...> pi == pi+    {?(prec 36): TrueOrFalse}++    ...> pi == pi + 2^(-100)+    {?(prec 36): TrueOrFalse}++    ...> (pi == pi + 2^(-100)) ? (prec 1000)+    CertainFalse++    ...> 2^0.5+    {?(prec 36): [1.414213562371930730340852514178195642186126256312482171419747717302107387071785637999710161238908... ± ~1.0305e-11 ~2^(-36)]}++## Partial functions and error handling++Errors due to invalid input, such as division by zero or logarithm of a negative number can be only semi-detected in the same way as comparisons can be only semi-decided.+Therefore, an invalid input gives a `CReal` leads to errors or potential errors only when extracting an approximation:++    ...> bad1 = pi/0+    ...> bad1 ? (prec 100)+    {{ERROR: division by 0}}}++    ...> bad2 = 1/(pi-pi)+    ...> bad2 ? (prec 100)+    {{POTENTIAL ERROR: division by 0}}++When we are sure that potential errors are harmless, we can clear them:++    ...> ok3 = sqrt (pi-pi)+    ...> ok3 ? (prec 10)+    [0.022097086912079610143710452219156792352805496193468570709228515625 ± ~2.2097e-2 ~2^(-5)]{{POTENTIAL ERROR: out of domain: negative sqrt argument}}+    ...> clearPotentialErrors $ ok3 ? (prec 10)+    [0.022097086912079610143710452219156792352805496193468570709228515625 ± ~2.2097e-2 ~2^(-5)]++## Specification and tests++The approximations obtained using `? (bits n)` or `? (prec p)` are intervals of type `CN MPBall` from package [aern2-mp](../aern2-mp/README.md).  This type is also used internally for all `CReal` arithmetic.  The `MPBall` arithmetic is tested against a fairly complete hspec/QuickCheck specification of algebraic properties.
aern2-real.cabal view
@@ -1,154 +1,56 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: b57c88210a794528b882a16827029297ad35afce7480417eae1b92b8862d8853+ name:           aern2-real-version:        0.1.2-cabal-version:  >= 1.9.2-build-type:     Simple-homepage:       https://github.com/michalkonecny/aern2+version:        0.2.0.0+synopsis:       Real numbers as sequences of MPBalls+description:    Please see the README on GitHub at <https://github.com/michalkonecny/aern2/#readme>+category:       Math+homepage:       https://github.com/michalkonecny/aern2#readme+bug-reports:    https://github.com/michalkonecny/aern2/issues author:         Michal Konecny-maintainer:     Michal Konecny <mikkonecny@gmail.com>-copyright:      (c) 2015-2019 Michal Konecny+maintainer:     mikkonecny@gmail.com+copyright:      2015-2021 Michal Konecny license:        BSD3 license-file:   LICENSE-extra-source-files:  changelog.md-stability:      experimental-category:       Math-synopsis:       Exact real numbers via Cauchy sequences and MPFR-Description:-  Exact real numbers as Cauchy sequences of MPFR approximations.-  .-  See module "AERN2.Real" for further documentation.-+build-type:     Simple+extra-source-files:+    README.md+    changelog.md  source-repository head-  type:     git-  location: https://github.com/mikkonecny/aern2.git-  subdir: aern2-real+  type: git+  location: https://github.com/michalkonecny/aern2  library-  hs-source-dirs:  src-  build-depends:-    base == 4.*-    , containers >= 0.5-    , convertible >= 1.1.1.0-    , hspec >= 2.1-    -- , hspec-smallcheck >= 0.3 && < 0.5-    , QuickCheck >= 2.7-    , transformers >= 0.4-    , lens >= 4.13-    , stm >= 2.4-    , bytestring >= 0.10-    , aeson >= 0.11-    , mixed-types-num >= 0.3.2-    , aern2-mp >= 0.1.4-  ghc-options:     -Wall -fno-warn-orphans-  extensions:-    RebindableSyntax,-    PostfixOperators,-    ScopedTypeVariables,-    TypeFamilies,-    TypeOperators,-    ConstraintKinds,-    DefaultSignatures,-    MultiParamTypeClasses,-    FlexibleContexts,-    FlexibleInstances,-    UndecidableInstances,-    Arrows   exposed-modules:-    AERN2.Utils.Arrows-    AERN2.QA.Protocol-    AERN2.QA.NetLog-    AERN2.QA.Strategy.CachedUnsafe-    AERN2.QA.Strategy.Cached.NetState-    AERN2.QA.Strategy.Cached.Arrow-    AERN2.QA.Strategy.Cached-    AERN2.QA.Strategy.Parallel-    AERN2.AccuracySG-    AERN2.WithGlobalParam.Type-    AERN2.WithGlobalParam.Helpers-    AERN2.WithGlobalParam.Comparison-    AERN2.WithGlobalParam.Branching-    AERN2.WithGlobalParam.Ring-    AERN2.WithGlobalParam.Field-    AERN2.WithGlobalParam.Elementary-    AERN2.WithGlobalParam-    AERN2.MPBallWithGlobalPrec-    AERN2.Sequence.Type-    AERN2.Sequence.Helpers-    AERN2.Sequence.Comparison-    AERN2.Sequence.Branching-    AERN2.Sequence.Ring-    AERN2.Sequence.Field-    AERN2.Sequence.Elementary-    AERN2.Sequence.PreludeOps-    AERN2.Sequence-    AERN2.Real.Type-    AERN2.Real.Arithmetic-    AERN2.Real.Tests-    AERN2.Real-    AERN2.Limit--test-suite spec-  type:-      exitcode-stdio-1.0-  ghc-options:-      -Wall-  extensions:-    RebindableSyntax,-    PostfixOperators,-    ScopedTypeVariables,-    FlexibleContexts-  hs-source-dirs:-      test-  main-is:-      Spec.hs+      AERN2.Complex+      AERN2.Real+      AERN2.Real.CKleenean+      AERN2.Real.Comparisons+      AERN2.Real.Elementary+      AERN2.Real.Field+      AERN2.Real.Limit+      AERN2.Real.Tests+      AERN2.Real.Type   other-modules:-    AERN2.RealSpec-  build-depends:-    base == 4.*-    -- , mixed-types-num >= 0.3.1 && < 0.4-    -- , aern2-mp-    , aern2-real-    , hspec >= 2.1-    -- , hspec-smallcheck >= 0.3 && < 0.5-    , QuickCheck >= 2.7--executable aern2-real-benchOp-  ghc-options:-      -Wall-  extensions:-    RebindableSyntax,-    PostfixOperators,-    ScopedTypeVariables,-    FlexibleContexts,-    TypeSynonymInstances+      Paths_aern2_real   hs-source-dirs:-      bench-  main-is:-      aern2-real-benchOp.hs+      src+  default-extensions: RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, ConstraintKinds, DefaultSignatures, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances+  other-extensions: TemplateHaskell+  ghc-options: -Wall   build-depends:-    base == 4.*-    , mixed-types-num >= 0.3.1-    , aern2-mp == 0.1.*-    , aern2-real-    , random-    , QuickCheck---- executable aern2-generate-netlog-elm---   ghc-options:---       -Wall---   extensions:---     RebindableSyntax,---     PostfixOperators,---     ScopedTypeVariables,---     FlexibleContexts,---     TypeSynonymInstances---   hs-source-dirs:---       tools---   main-is:---       aern2-generate-netlog.hs---   build-depends:---     base == 4.*---     , elm-bridge---     , mixed-types-num >= 0.3.1---     , aern2-mp == 0.1.*---     , aern2-real+      QuickCheck+    , aern2-mp >=0.2+    , base ==4.*+    , collect-errors >=0.1+    , hspec+    , integer-logarithms+    , mixed-types-num >=0.5.1+  default-language: Haskell2010
− bench/aern2-real-benchOp.hs 
@@ -1,126 +0,0 @@-{-|-    Module      :  Main (file aern2-real-benchOp)-    Description :  execute a CR operation for benchmarking-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--}-module Main where--import MixedTypesNumPrelude--- import Prelude--import Text.Printf--import System.Environment--import System.IO.Unsafe (unsafePerformIO)-import System.Random (randomRIO)--import Test.QuickCheck--import AERN2.Utils.Bench--import AERN2.MP-import AERN2.Real-import AERN2.Real.Tests () -- instance Arbitrary CauchyReal--main :: IO ()-main =-    do-    args <- getArgs-    (computationDescription, results) <- processArgs args-    putStrLn $ computationDescription-    putStrLn $ "accuracies = " ++ show (map getAccuracy results)--processArgs ::-    [String] ->-    IO (String, [MPBall])-processArgs [op, countS, accuracyS] =-    return (computationDescription, results)-    where-    computationDescription =-        printf "computing %s (%d times) using accuracy %d" op count ac-    ac :: Integer-    ac = read accuracyS-    count :: Integer-    count = read countS--    results =-      case op of-        "exp" ->-          map ((? (bitsS ac)) . exp) $-            unsafePerformIO $ pickValues valuesSmall count-        "log" ->-          map ((~!) . (? (bitsS ac)) . log) $-            unsafePerformIO $ pickValues valuesPositive count-        "sqrt" ->-          map ((~!) . (? (bitsS ac)) . sqrt) $-            unsafePerformIO $ pickValues valuesPositive count-        "cos" ->-          map ((? (bitsS ac)) . cos) $-            unsafePerformIO $ pickValues values count-        "add" ->-          map ((? (bitsS ac)) . (uncurry (+))) $-            unsafePerformIO $ pickValues2 values values count-        "mul" ->-          map ((? (bitsS ac)) . (uncurry (*))) $-            unsafePerformIO $ pickValues2 values values count-        "div" ->-          map ((~!) . (? (bitsS ac)) . (uncurry (/))) $-            unsafePerformIO $ pickValues2 values valuesPositive count-        "logistic" ->-          map ((? (bitsS ac)) . (logistic 3.82 count)) $-            [real 0.125]-        _ -> error $ "unknown op " ++ op-processArgs _ =-    error "expecting arguments: <operation> <count> <precision>"--logistic :: Rational -> Integer -> CauchyReal -> CauchyReal-logistic c n x-  | n == 0 = x-  | otherwise = logistic c (n-1) $ c * x * (1-x)--pickValues2 :: [CauchyReal] -> [CauchyReal] -> Integer -> IO [(CauchyReal, CauchyReal)]-pickValues2 vals1 vals2 count =-  do-  p1 <- pickValues vals1 count-  p2 <- pickValues vals2 count-  return $ zip p1 p2--pickValues :: [CauchyReal] -> Integer -> IO [CauchyReal]-pickValues vals count =-  sequence $-  [-    do-    i1 <- randomRIO (1,maxIndex)-    let x = vals !! i1-    return x-  | _j <- [1..count]-  ]--maxIndex :: Integer-maxIndex = 1000--valuesSmall :: [CauchyReal]-valuesSmall = map makeSmall values-  where-  makeSmall :: CauchyReal -> CauchyReal-  makeSmall x-    | abs (getBall x) !<! 1000000 = x-    | otherwise = 1000000 * (x/!(1000000+(abs x)))-    where-    getBall :: CauchyReal -> MPBall-    getBall xx = xx ? (bitsS 53)--valuesPositive :: [CauchyReal]-valuesPositive = filter ((!>! 0) . getBall) values-    where-    getBall :: CauchyReal -> MPBall-    getBall x = x ? (bitsS 53)--values :: [CauchyReal]-values = listFromGen (real <$> (arbitrary :: Gen Rational))
changelog.md view
@@ -1,3 +1,11 @@+# Change log for aern2-real++* v 0.2.0 2021-05-17+  * moving Arrow-based functionality to package aern2-net+  * replacing Arrow-based sequences by list-based sequences+  * switch to new simplified collect-errors, mixed-types-num 0.5.0+    * got rid of EnsureCE etc.+    * not introducing CN wrapper unless at least one parameter is already CN * v 0.1.2 2019-03-19   * adapts to mixed-types-num 0.3.2 (new divI, mod) * v 0.1.1.0 2017-12-06@@ -12,3 +20,4 @@   * arrow-based networks of nodes communicating via query-answer protocols   * networks executable with cached and parallel strategies   * network execution can be visualised in browser using an Elm frontend+
− src/AERN2/AccuracySG.hs 
@@ -1,136 +0,0 @@-{-# LANGUAGE Arrows #-}-{-|-    Module      :  AERN2.AccuracySG-    Description :  strict and guide accuracy pairs-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    strict and guide accuracy pairs--}-module AERN2.AccuracySG-(-  AccuracySG(..), acSG0, default_acSG, accuracySG, bitsS, bitsSG-, accuracySGdefaultTolerance-, CanAdjustToAccuracySG(..)-)-where--import MixedTypesNumPrelude-import qualified Prelude as P--import Control.Arrow---- import qualified Control.CollectErrors as CE-import Control.CollectErrors (CollectErrors) --, EnsureCE, CanEnsureCE, ensureCE)--import AERN2.MP.Accuracy-import AERN2.MP.Ball--{-| An accuracy specification which includes a soft target "guide" accuracy-    in addition to the usual string accuracy requirement. -}-data AccuracySG =-  AccuracySG { _acStrict :: Accuracy, _acGuide :: Accuracy }-  deriving (P.Eq)--instance Show AccuracySG where-  show (AccuracySG acS acG) =-    "bitsSG " ++ (show $ fromAccuracy acS) ++ " " ++ (show $ fromAccuracy acG)--instance ConvertibleExactly AccuracySG Accuracy where-  safeConvertExactly (AccuracySG acS acG) = Right $ acS `max` acG--accuracySGdefaultTolerance :: Integer-accuracySGdefaultTolerance = 20--accuracySG :: Accuracy -> AccuracySG-accuracySG ac = AccuracySG ac (ac + accuracySGdefaultTolerance)--bitsSG :: Integer -> Integer -> AccuracySG-bitsSG acS acG = AccuracySG (bits acS) (bits acG)--bitsS :: Integer -> AccuracySG-bitsS = accuracySG . bits--acSG0 :: AccuracySG-acSG0 = bitsS 0--default_acSG :: AccuracySG-default_acSG = bitsS 100--instance HasEqAsymmetric AccuracySG AccuracySG-instance HasOrderAsymmetric AccuracySG AccuracySG where-  geq (AccuracySG acS1 acG1) (AccuracySG acS2 acG2) =-    acS1 >= acS2 && acG1 >= acG2-  greaterThan acSG1 acSG2 =-    acSG1 >= acSG2 && acSG1 /= acSG2-  leq = flip geq-  lessThan = flip greaterThan--instance HasOrderAsymmetric Accuracy AccuracySG where-  greaterThan ac (AccuracySG acS acG) =-    ac > acS && ac > acG - accuracySGdefaultTolerance-  geq ac (AccuracySG acS acG) =-    ac >= acS && ac >= acG - accuracySGdefaultTolerance-  leq ac (AccuracySG acS _acG) =-    ac <= acS-  lessThan ac (AccuracySG acS _acG) =-    ac < acS--instance HasOrderAsymmetric AccuracySG Accuracy where-  greaterThan = flip lessThan-  lessThan = flip greaterThan-  leq = flip leq-  geq = flip geq--instance CanMinMaxAsymmetric AccuracySG AccuracySG where-  min = lift2 min-  max = lift2 max--lift2 ::-  (Accuracy -> Accuracy -> Accuracy)-  -> (AccuracySG -> AccuracySG -> AccuracySG)-lift2 op (AccuracySG acS1 acG1) (AccuracySG acS2 acG2) =-   AccuracySG (acS1 `op` acS2) (acG1 `op` acG2)--instance CanAddAsymmetric AccuracySG Integer where-  add (AccuracySG acS acG) n = AccuracySG (acS + n) (acG + n)-instance CanAddAsymmetric Integer AccuracySG where-  type AddType Integer AccuracySG = AccuracySG-  add = flip add-instance CanSub AccuracySG Integer where---class CanAdjustToAccuracySG t where-  adjustToAccuracySG :: AccuracySG -> t -> t--instance CanAdjustToAccuracySG MPBall where-  adjustToAccuracySG (AccuracySG acS acG) =-    setPrecisionAtLeastAccuracy acS . reduceSizeUsingAccuracyGuide acG--instance CanAdjustToAccuracySG Bool where-  adjustToAccuracySG _ = id--instance CanAdjustToAccuracySG t => CanAdjustToAccuracySG (Maybe t) where-  adjustToAccuracySG acSG = fmap (adjustToAccuracySG acSG)--instance CanAdjustToAccuracySG t => CanAdjustToAccuracySG (CollectErrors es t) where-  adjustToAccuracySG acSG = fmap (adjustToAccuracySG acSG)--instance-  (Arrow to, CanUnionAsymmetric e1 e2)-  =>-  CanUnionAsymmetric (to AccuracySG e1) (to AccuracySG e2)-  -- this instance is important for "parallel if"-  where-  type UnionType (to AccuracySG e1) (to AccuracySG e2) =-    to AccuracySG (UnionType e1 e2)-  union xA yA =-    proc ac ->-      do-      x <- xA -< ac-      y <- yA -< ac-      returnA -< union x y
+ src/AERN2/Complex.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-|+    Module      :  AERN2.Complex+    Description :  Exact complex numbers+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++    Exact complex numbers represented by Cauchy sequences of (Complex MPBall)'s.+-}+module AERN2.Complex+(+   -- * complex numbers and conversions+   CComplex, ccomplex, HasCComplex, CanBeCComplex,+)+where++import MixedTypesNumPrelude+-- -- import qualified Prelude as P++import Data.Complex++import AERN2.Real++type CComplex = Complex CReal++type CanBeCComplex t = ConvertibleExactly t CComplex++type HasCComplex t = ConvertibleExactly CComplex t++ccomplex :: (CanBeCComplex t) => t -> CComplex+ccomplex = convertExactly++instance (HasCReals t, HasIntegers t) => (ConvertibleExactly CReal (Complex t))+  where+  safeConvertExactly n =+    do+    nT <- safeConvertExactly n+    zT <- safeConvertExactly 0+    return $ nT :+ zT++-- {- reals mixed with complex -}++-- instance+--   (CanAddAsymmetric CReal t)+--   =>+--   CanAddAsymmetric CReal (Complex t)+--   where+--   type AddType CReal (Complex t) = Complex (AddType CReal t)+--   add r (a :+ i) = (r + a) :+ (z + i)+--     where+--     z = realA 0+--     _ = [z,r]++-- instance+--   (CanAddAsymmetric t CReal)+--   =>+--   CanAddAsymmetric (Complex t) CReal+--   where+--   type AddType (Complex t) CReal = Complex (AddType t CReal)+--   add (a :+ i) r = (a + r) :+ (i + z)+--     where+--     z = realA 0+--     _ = [z,r]++-- instance+--   (CanAdd CReal t, CanNegSameType t)+--   =>+--   CanSub CReal (Complex t)++-- instance+--   (CanAdd t CReal)+--   =>+--   CanSub (Complex t) CReal++-- instance+--   (CanMulAsymmetric CReal t)+--   =>+--   CanMulAsymmetric CReal (Complex t)+--   where+--   type MulType CReal (Complex t) = Complex (MulType CReal t)+--   mul r (a :+ i) = (r * a) :+ (r * i)++-- instance+--   (CanMulAsymmetric t CReal)+--   =>+--   CanMulAsymmetric (Complex t) CReal+--   where+--   type MulType (Complex t) CReal = Complex (MulType t CReal)+--   mul (a :+ i) r = (a * r) :+ (i * r)+++_test1 :: CComplex+_test1 = ccomplex 1.0++_test2 :: CComplex+_test2 = ccomplex $ creal 1+
− src/AERN2/Limit.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE CPP #-}--- #define DEBUG--module AERN2.Limit where--#ifdef DEBUG-import Debug.Trace (trace)-#define maybeTrace trace-#define maybeTraceIO putStrLn-#else-#define maybeTrace (\ (_ :: String) t -> t)-#define maybeTraceIO (\ (_ :: String) -> return ())-#endif--import MixedTypesNumPrelude--import Control.CollectErrors--import AERN2.QA.Protocol-import AERN2.Real-------------- limit------------class HasLimits ix s where-  type LimitType ix s-  limit :: (ix -> s) -> LimitType ix s--instance HasLimits Rational CauchyReal where-  type LimitType Rational CauchyReal = CauchyReal-  limit s = newCR "limit" [] makeQ-    where-    makeQ (me, _src) ac@(AccuracySG acS _acG) =-      updateRadius (+ (errorBound e)) $ (s e ?<- me) (ac + 1)-      where-      e = 0.5^!(fromAccuracy acS + 1)--instance HasLimits Rational CauchyRealCN where-  type LimitType Rational CauchyRealCN = CauchyRealCN-  limit s = newCRCN "limit" [] makeQ-    where-    makeQ (me, _src) ac@(AccuracySG acS _acG) =-      lift1CE (updateRadius (+ (errorBound e))) $ (s e ?<- me) (ac + 1)-      where-      e = 0.5^!(fromAccuracy acS + 1)--instance HasLimits Rational (CauchyReal -> CauchyRealCN) where-  type LimitType Rational (CauchyReal -> CauchyRealCN) = (CauchyReal -> CauchyRealCN)-  limit fs x = newCRCN "limit" [AnyProtocolQA x] makeQ-    where-    makeQ (me, _src) ac@(AccuracySG acS _acG) =-      maybeTrace ("limit (CauchyReal -> CauchyRealCN): ac = " ++ show ac ) $-      lift1CE (updateRadius (+ (errorBound e))) $ (fx ?<- me) (ac + 1)-      where-      fx = fs e x-      e = 0.5^!(fromAccuracy acS + 1)--{--  The following strategies are inspired by-  Mueller: The iRRAM: Exact Arithmetic in C++, Section 10.1-  https://link.springer.com/chapter/10.1007/3-540-45335-0_14--}--instance HasLimits Rational (MPBall -> CN MPBall) where-  type LimitType Rational (MPBall -> CN MPBall) = (MPBall -> CN MPBall)-  limit fs x =-    maybeTrace ("limit (MPBall -> CN MPBall): x = " ++ show x) $-    maybeTrace ("limit (MPBall -> CN MPBall): xPNext = " ++ show xPNext) $-    maybeTrace ("limit (MPBall -> CN MPBall): accuracies = " ++ show accuracies) $-    tryAccuracies accuracies-    where-    acX = getFiniteAccuracy x-    accuracies = aux (fromAccuracy acX)-      where-      aux a-        | a >= 4 = bits a : aux ((100 * a) `divINoCN` 105)-        | otherwise = [bits a]-    xPNext = setPrecision (increaseP $ getPrecision x) x-    increaseP p =-      prec $ (integer p) + 10-      -- prec $ ((101 * (integer p)) `div` 100) + 1--    tryAccuracies [] =-      noValueNumErrorPotentialECN (Nothing :: Maybe MPBall) $-        NumError "limit (MPBall -> CN MPBall) failed"-    tryAccuracies (ac : rest) =-      let result = withAccuracy ac in-      case getErrorsCN result of-        [] -> result-        _ -> tryAccuracies rest--    withAccuracy ac =-      maybeTrace ("limit (MPBall -> CN MPBall): withAccuracy: ac = " ++ show ac) $-      lift1CE (updateRadius (+ (errorBound e))) (fs e xPNext)-      where-      e = 0.5^!(fromAccuracy ac)--data WithLipschitz f = WithLipschitz f f--instance HasLimits Rational (WithLipschitz (MPBall -> CN MPBall)) where-  type LimitType Rational (WithLipschitz (MPBall -> CN MPBall)) = (MPBall -> CN MPBall)-  limit ffs xPre =-    maybeTrace ("limit (MPBall -> CN MPBall): x = " ++ show x) $-    maybeTrace ("limit (MPBall -> CN MPBall): xC = " ++ show xC) $-    maybeTrace ("limit (MPBall -> CN MPBall): xE = " ++ show xE) $-    maybeTrace ("limit (MPBall -> CN MPBall): accuracies = " ++ show accuracies) $-    tryAccuracies accuracies-    where-    acX = getFiniteAccuracy x-    accuracies = aux (fromAccuracy acX)-      where-      aux a-        | a >= 4 = bits a : aux ((100 * a) `divINoCN` 105)-        | otherwise = [bits a]-    x = increasePrec xPre-      where-      increasePrec z = setPrecision (inc $ getPrecision xPre) z-      inc p =-          prec $ (integer p) + 10-          -- prec $ ((101 * (integer p)) `div` 100) + 1-    xC = centreAsBall x-    xE = radius x--    tryAccuracies [] =-      noValueNumErrorPotentialECN (Nothing :: Maybe MPBall) $-        NumError "limit (MPBall -> CN MPBall) failed"-    tryAccuracies (ac : rest) =-      let result = withAccuracy ac in-      case getErrorsCN result of-        [] -> result-        _ -> tryAccuracies rest--    withAccuracy ac =-      maybeTrace ("limit (MPBall -> CN MPBall): withAccuracy: ac = " ++ show ac) $-      lift1CE (updateRadius (+ (errorBound e))) fx-      where-      e = 0.5^!(fromAccuracy ac)-      WithLipschitz f f' = ffs e-      fxC_CN = f xC-      f'x_CN = f' x-      fx :: CN MPBall-      fx =-          case (ensureNoCN fxC_CN, ensureNoCN f'x_CN) of-            ((Just fxC, []), (Just f'x, [])) ->-              cn $ updateRadius (+ (xE * (errorBound f'x))) fxC-            _ ->-              f x -- fallback--instance HasLimits Rational (WithLipschitz (CauchyReal -> CauchyRealCN)) where-  type LimitType Rational (WithLipschitz (CauchyReal -> CauchyRealCN)) = (CauchyReal -> CauchyRealCN)-  limit ffs x = limit fs x-    where-    fs e = f-      where-      WithLipschitz f _ = ffs e
− src/AERN2/MPBallWithGlobalPrec.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.MPBallWithGlobalPrec-    Description :  MPBall parametrised by a global precision-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    This type is useful for iRRAM-style arrow-generic computation-    over MPBall with a global precision.--}-module AERN2.MPBallWithGlobalPrec-(-  -- * The protocol and type of objects depending on a global parameter-  MPBallWithGlobalPrecP, pMPBallWGPrec-  , wgprmName, wgprmId, wgprmSources, wgprmRename-  , wgprmQuery, (?), wgprmQueryA, wgprmListQueryA-  , MPBallWithGlobalPrecA, MPBallWithGlobalPrec-  , newMPBallWGPrec, newMPBallWGPrecSimple-)-where--import MixedTypesNumPrelude--- import qualified Prelude as P--import Control.Arrow--import AERN2.MP-import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.Real-import AERN2.WithGlobalParam--type MPBallWithGlobalPrecP = WithGlobalParamP Precision MPBall--pMPBallWGPrec :: MPBallWithGlobalPrecP-pMPBallWGPrec = pWGParam Nothing (mpBall 0)--type MPBallWithGlobalPrecA to = WithGlobalParamA to Precision MPBall-type MPBallWithGlobalPrec = MPBallWithGlobalPrecA (->)--newMPBallWGPrec ::-  (QAArrow to)-  =>-  String -> [AnyProtocolQA to] -> ((Maybe (QAId to), Maybe (QAId to)) -> Precision `to` MPBall) -> MPBallWithGlobalPrecA to-newMPBallWGPrec = newWGParam Nothing (mpBall 0)--newMPBallWGPrecSimple ::-  (QAArrow to)-  =>-  ((Maybe (QAId to), Maybe (QAId to)) -> Precision `to` MPBall) -> MPBallWithGlobalPrecA to-newMPBallWGPrecSimple = newMPBallWGPrec "simple" []---$(declForTypes-  [[t| Integer |], [t| Int |], [t| Dyadic |], [t| Rational |], [t| CauchyReal |]]-  (\ t -> [d|--    instance-      (QAArrow to)-      =>-      ConvertibleExactly $t (MPBallWithGlobalPrecA to)-      where-      safeConvertExactly x =-        Right $ newMPBallWGPrec (show x) [] (\_src -> arr $ p2a)-        where-        p2a p = convertP p x--  |]))
− src/AERN2/QA/NetLog.hs 
@@ -1,120 +0,0 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass, GeneralizedNewtypeDeriving #-}-{-|-    Module      :  AERN2.QA.NetLog-    Description :  QA network log data structure-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    QA network log data structure--}-module AERN2.QA.NetLog-(ValueId(..), QANetLogItem(..), QANetLog-, formatQALog, printQALog, printQANetLogThenResult-, formatQALogJSON, printQALogJSON, writeNetLogJSON)-where--import MixedTypesNumPrelude-import qualified Prelude as P--import Text.Printf--import GHC.Generics-import qualified Data.ByteString.Lazy.Char8 as BS-import Data.Aeson as J-import Data.Aeson.Types as JT--type QANetLog = [QANetLogItem]--data QANetLogItem-    = QANetLogCreate-      {-        qaLogCreate_newId :: ValueId-      , qaLogCreate_sources :: [ValueId]-      , qaLogCreate_name :: String-      }-    | QANetLogQuery-      {-        qaLogQuery_client :: (Maybe ValueId)-      , qaLogQuery_provider :: ValueId-      , qaLogQuery_description :: String-      }-    | QANetLogAnswer-      {-        qaLogAnswer_client :: (Maybe ValueId)-      , qaLogAnswer_provider :: ValueId-      , qaLogAnswer_cacheUseDescription :: String-      , qaLogAnswer_description :: String-      }-    deriving (Generic)--instance ToJSON QANetLogItem where-  toJSON = J.genericToJSON customOptions-    where-    customOptions = J.defaultOptions-        { JT.sumEncoding = JT.ObjectWithSingleField }---instance Show QANetLogItem where-  show (QANetLogCreate valId sources name) =-    printf "new (%s) %s <- %s"-      (show valId) name (show sources)-  show (QANetLogQuery mSrcId valId queryS) =-    printf "(%s)<-(%s): ? %s"-      (show valId) (showSrc mSrcId) queryS-  show (QANetLogAnswer mSrcId valId cacheInfoS answerS) =-    printf "(%s)->(%s): ! %s (%s)"-      (show valId) (showSrc mSrcId) answerS cacheInfoS--showSrc :: (Show a) => Maybe a -> String-showSrc (Just srcId) = show srcId-showSrc Nothing = ""--data ValueId = ValueId Integer-    deriving (Show, P.Eq, P.Ord, Generic, ToJSON)--instance Enum ValueId where-  toEnum = ValueId . toEnum-  fromEnum (ValueId n) = fromEnum n--printQANetLogThenResult :: (Show a) =>(QANetLog, a) -> IO ()-printQANetLogThenResult (lg, result) =-    do-    printQALog lg-    putStrLn $ show result--printQALog :: QANetLog -> IO ()-printQALog = putStrLn . formatQALog 0--formatQALog :: Integer -> QANetLog -> String-formatQALog = aux-    where-    aux _ [] = ""-    aux level (item : rest) =-        (indent ++ show item ++ "\n") ++-        (aux level' rest)-        where-        indent = replicate levelNow ' '-        (levelNow, level') =-            case item of-                QANetLogQuery _ _ _ -> (level + 1, level + 1)-                QANetLogAnswer _ _ _ _ -> (level, level - 1)-                _ -> (level, level)--formatQALogJSON :: QANetLog -> String-formatQALogJSON = BS.unpack . J.encode--printQALogJSON :: QANetLog -> IO ()-printQALogJSON =-  BS.putStrLn . J.encode--writeNetLogJSON :: QANetLog -> IO ()-writeNetLogJSON netlog =-  writeFile "netlog.js" $-    "netlog='" ++  (filter goodChar $ formatQALogJSON netlog) ++ "'"-  where-  goodChar 'Â' = False-  goodChar _ = True
− src/AERN2/QA/Protocol.hs 
@@ -1,277 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-|-    Module      :  AERN2.QA.Protocol-    Description :  Cacheable question-answer protocols-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Cacheable question-answer protocols--}-module AERN2.QA.Protocol-(-  -- * QA protocols and objects-  QAProtocol(..), QAProtocolCacheable(..)-  , QA(..), QAPromiseA, (?..)-  , qaRename-  , mapQA, mapQAsameQ-  -- * QAArrows-  , AnyProtocolQA(..)-  , QAArrow(..), defaultNewQA, QARegOption(..)-  , qaMakeQuery, qaMakeQueryA, qaMakeQueriesA, qaMakeQueryOnManyA-  , (?<-), (?)-  , (-:-), (-:-|), (-:-||)-  , (-?<-), (-?-), (-?..<-), (-?..-), (-???<-), (-<?<->-)-  , qaMake2Queries, (??<-)-  , qaMake3Queries-)-where--import MixedTypesNumPrelude-import qualified Prelude as P--- import Text.Printf--import Control.Arrow-import AERN2.Utils.Arrows---- import Data.Maybe-import Data.List--import Control.CollectErrors--{-| A QA protocol at this level is simply a pair of types. -}-class (Show p, Show (Q p), Show (A p)) => QAProtocol p where-  type Q p -- a type of queries-  type A p -- a type of answers--{-| A QA protocol with a caching method. -}-class (QAProtocol p, HasOrderCertainly (Q p) (Q p)) => QAProtocolCacheable p where-  type QACache p-  newQACache :: p -> QACache p-  lookupQACache :: p -> QACache p -> Q p -> (Maybe (A p), Maybe String) -- ^ the String is a log message-  updateQACache :: p -> Q p -> A p -> QACache p -> QACache p--instance (QAProtocol p, SuitableForCE es) => (QAProtocol (CollectErrors es p)) where-  type Q (CollectErrors es p) = Q p-  type A (CollectErrors es p) = CollectErrors es (A p)--{-| An object we can ask queries about.  Queries can be asked in some Arrow @to@. -}-data QA to p = QA__-  {-    qaName :: String,-    qaId :: Maybe (QAId to),-    qaSources :: [QAId to],-    qaProtocol :: p,-    qaSampleQ :: Maybe (Q p),-    qaMakeQueryGetPromise ::-      (Maybe (QAId to), Maybe (QAId to)) -- this node id, source of query-      ->-      (Q p) `to` (QAPromiseA to (A p))-  }--type QAPromiseA to a = () `to` a--{-| An infix synonym of 'qaMakeQuery'. -}-(?..) :: QA to p -> (Q p) `to` (QAPromiseA to (A p))-(?..) qa = qaMakeQueryGetPromise qa (Nothing, Nothing)--infix 1 ?..--qaRename :: (String -> String) -> QA to p -> QA to p-qaRename f qa = qa {  qaName = f (qaName qa)  }--mapQA ::-  (Arrow to) =>-  (p1 -> p2) ->-  (Q p1 -> Q p2) ->-  (Q p2 -> Q p1) ->-  (A p1 -> A p2) ->-  QA to p1 -> QA to p2-mapQA-    translateP translateQ translateBackQ translateA-    (QA__ name qaid sources p sampleQ makeQ) =-  QA__ name qaid sources (translateP p) (fmap translateQ sampleQ) $-    \ source -> (arr $ ((arr translateA) <<<) ) <<< makeQ source <<< arr translateBackQ--mapQAsameQ ::-  (Arrow to, Q p1 ~ Q p2) =>-  (p1 -> p2) ->-  (A p1 -> A p2) ->-  QA to p1 -> QA to p2-mapQAsameQ translateP = mapQA translateP id id--data AnyProtocolQA to =-  forall p. (QAProtocolCacheable p) => AnyProtocolQA (QA to p)--anyPqaId :: AnyProtocolQA to -> (Maybe (QAId to))-anyPqaId (AnyProtocolQA qa) = qaId qa--anyPqaSources :: AnyProtocolQA to -> [QAId to]-anyPqaSources (AnyProtocolQA qa) = qaSources qa--data QARegOption =-  QARegPreferParallel | QARegPreferSerial-  deriving (P.Eq)--{-|-  A class of Arrows suitable for use in QA objects.--}-class (ArrowChoice to, P.Eq (QAId to)) => QAArrow to where-  type QAId to-  {-|-    Register a QA object, which leads to a change in its-    query processing mechanism so that, eg, answers can be cached-    or computations assigned to different threads/processes.--    The "sources" component of the incoming QA object can be-    used to record the dependency graph among QA objects.-    After registration, the QA object should have its list-    of dependencies **empty**-    as the registration has recorded them elsewhere.-  -}-  qaRegister :: (QAProtocolCacheable p) => [QARegOption] -> (QA to p) `to` (QA to p)-  {-|-    Create a qa object.  The object is not "registered" automatically.-    Invoking this function does not lead to any `to'-arrow computation.-    The function is an operation of 'QAArrow' so that for some arrows,-    the question-answer mechanism can be automatically altered.-    In particular, this is used to make all objects in the (->) arrow-    automatically (unsafely) caching their answers.-    For most arrows, the default implementation is sufficient.-  -}-  newQA :: (QAProtocolCacheable p) =>-    String -> [AnyProtocolQA to] -> p -> Maybe (Q p) -> ((Maybe (QAId to), Maybe (QAId to)) -> (Q p) `to` (A p)) -> QA to p-  newQA = defaultNewQA-  qaFulfilPromiseA :: (QAPromiseA to a) `to` a-  qaMakeQueryGetPromiseA :: Maybe (QAId to) -> (QA to p, Q p) `to` (QAPromiseA to (A p))--defaultNewQA ::-  (QAArrow to, QAProtocolCacheable p) =>-  String -> [AnyProtocolQA to] -> p -> Maybe (Q p) ->-  ((Maybe (QAId to), Maybe (QAId to)) -> (Q p) `to` (A p)) -> QA to p-defaultNewQA name sources p sampleQ makeQ =-  QA__ name Nothing (nub $ concat $ map getSourceIds sources) p sampleQ makeQPromise-  where-  getSourceIds source =-    case anyPqaId source of-      Just id1 -> [id1]-      Nothing -> anyPqaSources source-  makeQPromise me_src =-    proc acSG ->-      returnA -< promise acSG-    where-    promise acSG =-      proc () ->-        do-        a <- makeQ me_src -< acSG-        returnA -< a--qaMakeQuery :: (QAArrow to) => (QA to p) -> (Maybe (QAId to)) -> (Q p) `to` (A p)-  -- ^ composition of qaMakeQueryGetPromise and the execution of the promise-qaMakeQuery qa src = (qaMakeQueryGetPromise qa (me, src)) >>> qaFulfilPromiseA-  where-  me = case qaId qa of Nothing -> src; me2 -> me2--qaMakeQueryA :: (QAArrow to) => Maybe (QAId to) -> (QA to p, Q p) `to` (A p)-qaMakeQueryA src = qaMakeQueryGetPromiseA src >>> qaFulfilPromiseA--qaMakeQueriesA :: (QAArrow to) => Maybe (QAId to) -> [(QA to p, Q p)] `to` [A p]-qaMakeQueriesA src = (mapA (qaMakeQueryGetPromiseA src)) >>> (mapA qaFulfilPromiseA)--qaMakeQueryOnManyA :: (QAArrow to) => Maybe (QAId to) -> ([QA to p], Q p) `to` [A p]-qaMakeQueryOnManyA src =-  proc (qas, q) -> qaMakeQueriesA src -< map (flip (,) q) qas--{-| An infix synonym of 'qaMakeQuery' -}-(?<-) :: (QAArrow to) => QA to p -> Maybe (QAId to) -> (Q p) `to` (A p)-(?<-) = qaMakeQuery--{-| An infix synonym of 'qaMakeQuery' with no source -}-(?) :: (QAArrow to) => QA to p -> (Q p) `to` (A p)-(?) = \qa -> qaMakeQuery qa Nothing--infix 1 ?, ?<---{-| An infix synonym of 'qaRegister' -}-(-:-) :: (QAArrow to, QAProtocolCacheable p) => (QA to p) `to` (QA to p)-(-:-) = qaRegister []--{-| An infix synonym of 'qaRegister' -}-(-:-||) :: (QAArrow to, QAProtocolCacheable p) => (QA to p) `to` (QA to p)-(-:-||) = qaRegister [QARegPreferParallel]--{-| An infix synonym of 'qaRegister' -}-(-:-|) :: (QAArrow to, QAProtocolCacheable p) => (QA to p) `to` (QA to p)-(-:-|) = qaRegister [QARegPreferSerial]--{-| An infix synonym of 'qaMakeQueryGetPromiseA' -}-(-?..<-) :: (QAArrow to) => Maybe (QAId to) -> (QA to p, Q p) `to` (QAPromiseA to (A p))-(-?..<-) = qaMakeQueryGetPromiseA--{-| An infix synonym of 'qaMakeQueryGetPromiseA' with no source -}-(-?..-) :: (QAArrow to) => (QA to p, Q p) `to` (QAPromiseA to (A p))-(-?..-) = qaMakeQueryGetPromiseA Nothing--{-| An infix synonym of 'qaMakeQueryA' -}-(-?<-) :: (QAArrow to) => Maybe (QAId to) -> (QA to p, Q p) `to` (A p)-(-?<-) = qaMakeQueryA--{-| An infix synonym of 'qaMakeQueryA' with no source -}-(-?-) :: (QAArrow to) => (QA to p, Q p) `to` (A p)-(-?-) = qaMakeQueryA Nothing--{-| An infix synonym of 'qaMakeQueryOnManyA' -}-(-<?<->-) :: (QAArrow to) => Maybe (QAId to) -> ([QA to p], Q p) `to` [A p]-(-<?<->-) = qaMakeQueryOnManyA--{-| An infix synonym of 'qaMakeQueriesA' -}-(-???<-) :: (QAArrow to) => Maybe (QAId to) -> [(QA to p, Q p)] `to` [A p]-(-???<-) = qaMakeQueriesA--infix 0 -?<-, -?..<-, -???<-, -<?<->--infix 0 -:-, -:-|, -:-||--{-| An infix synonym of 'qaMake2Queries'. -}-(??<-) :: (QAArrow to) => (QA to p1, QA to p2) -> Maybe (QAId to) -> (Q p1, Q p2) `to` (A p1, A p2)-(??<-) = qaMake2Queries--infix 0 ??<---{-| Run two queries in an interleaving manner, enabling parallelism. -}-qaMake2Queries :: (QAArrow to) => (QA to p1, QA to p2) -> Maybe (QAId to) -> (Q p1, Q p2) `to` (A p1, A p2)-qaMake2Queries (qa1, qa2) src =-  proc (q1,q2) ->-    do-    ap1 <- (-?..<-) src -< (qa1, q1)-    ap2 <- (-?..<-) src -< (qa2, q2)-    a1 <- qaFulfilPromiseA -< ap1-    a2 <- qaFulfilPromiseA -< ap2-    returnA -< (a1,a2)--{-| Run two queries in an interleaving manner, enabling parallelism. -}-qaMake3Queries ::-  (QAArrow to) =>-  (QA to p1, QA to p2, QA to p3) -> Maybe (QAId to) -> (Q p1, Q p2, Q p3) `to` (A p1, A p2, A p3)-qaMake3Queries (qa1, qa2, qa3) src =-  proc (q1,q2,q3) ->-    do-    ap1 <- (-?..<-) src -< (qa1, q1)-    ap2 <- (-?..<-) src -< (qa2, q2)-    ap3 <- (-?..<-) src -< (qa3, q3)-    a1 <- qaFulfilPromiseA -< ap1-    a2 <- qaFulfilPromiseA -< ap2-    a3 <- qaFulfilPromiseA -< ap3-    returnA -< (a1,a2,a3)--{- arrow conversions -}--instance-  (CanSwitchArrow to1 to2, QAArrow to1, QAArrow to2, QAProtocolCacheable p)-  =>-  ConvertibleExactly (QA to1 p) (QA to2 p)-  where-  safeConvertExactly qa =-    Right $ defaultNewQA (qaName qa) [] (qaProtocol qa) (qaSampleQ qa) (\ _src -> switchArrow (qaMakeQuery qa Nothing))
− src/AERN2/QA/Strategy/Cached.hs 
@@ -1,23 +0,0 @@-{-|-    Module      :  AERN2.QA.Strategy.Cached-    Description :  QA net evaluation with answer caching-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    QA net evaluation with answer caching--}-module AERN2.QA.Strategy.Cached-(-  module AERN2.QA.NetLog-  , module AERN2.QA.Strategy.Cached.NetState-  , module AERN2.QA.Strategy.Cached.Arrow-)-where--import AERN2.QA.NetLog-import AERN2.QA.Strategy.Cached.NetState-import AERN2.QA.Strategy.Cached.Arrow
− src/AERN2/QA/Strategy/Cached/Arrow.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE CPP #-}--- #define DEBUG-{-|-    Module      :  AERN2.QA.Strategy.Cached.Arrow-    Description :  QA net evaluation with answer caching-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    QA net evaluation with answer caching--}-module AERN2.QA.Strategy.Cached.Arrow-(-  module AERN2.QA.NetLog-  , module AERN2.QA.Strategy.Cached.NetState-  , QACachedA-  , executeQACachedA, executeQAUncachedA-)-where--#ifdef DEBUG-import Debug.Trace (trace)-#define maybeTrace trace-#else-#define maybeTrace (\ (_ :: String) t -> t)-#endif--import MixedTypesNumPrelude--- import qualified Prelude as P--- import Text.Printf--import Control.Arrow--import Control.Monad.Trans.State--import AERN2.QA.Protocol-import AERN2.QA.NetLog-import AERN2.QA.Strategy.Cached.NetState--type QACachedA = Kleisli QACachedM--data QACachedM a =-  QACachedM { unQACachedM :: (State (QANetState QACachedM) a) }--instance Functor QACachedM where-  fmap f (QACachedM ma) = QACachedM (fmap f ma)-instance Applicative QACachedM where-  pure a = QACachedM (pure a)-  (QACachedM f) <*> (QACachedM a) = QACachedM (f <*> a)-instance Monad QACachedM where-  (QACachedM ma) >>= f =-    QACachedM $ ma >>= (unQACachedM . f)--instance QAArrow QACachedA where-  type QAId QACachedA = ValueId-  qaRegister _ = Kleisli qaRegisterM-    where-    qaRegisterM (QA__ name Nothing sourceIds p sampleQ q2paA) =-      do-      valueId <- newId-      return $ QA__ name (Just valueId) [] p sampleQ (\me_src -> (Kleisli $ makeQCached me_src valueId))-      where-      sq2pa me_src = q2pa-        where-        (Kleisli q2pa) = q2paA me_src-      newId =-        maybeTrace ("newId: " ++ show name) $-        QACachedM $-          do-          ns <- get-          let (i, ns') = insertNode p name sourceIds sq2pa ns-          put ns'-          return i-      makeQCached (_me,src) valueId q =-        maybeTrace ("makeQCached: q = " ++ show q) $-        QACachedM $-          do-          ns <- get-          let ns' = logQuery ns src valueId (show q)-          put ns'-          aAndCachePromise <- unQACachedM $ getAnswerPromise ns' p src valueId q-          return $ Kleisli (aPromise aAndCachePromise)-        where-        aPromise aAndCachePromise () =-          QACachedM $-            do-            (a, usedCache, cache') <- unQACachedM $ aAndCachePromise ()-            ns2 <- get-            let ns2' = logAnswerUpdateCache ns2 p src valueId (show a, usedCache, cache')-            put ns2'-            return $-                maybeTrace ("makeQCached: a = " ++ show a)-                    a-    qaRegisterM _ =-      error "internal error in AERN2.QA.Strategy.Cached: qaRegister called with an existing id"--  qaFulfilPromiseA = Kleisli qaFulfilPromiseM-    where-    qaFulfilPromiseM promiseA =-      runKleisli promiseA ()-  qaMakeQueryGetPromiseA src = Kleisli qaMakeQueryGetPromiseM-    where-    qaMakeQueryGetPromiseM (qa, q) =-      runKleisli (qaMakeQueryGetPromise qa (me, src)) q-      where-      me = case qaId qa of Nothing -> src; me2 -> me2--executeQACachedA :: (QACachedA () a) -> (QANetLog, a)-executeQACachedA code =-  (net_log ns, result)-  where-  (result, ns) = (runState $ unQACachedM $ runKleisli code ()) (initQANetState True)--executeQAUncachedA :: (QACachedA () a) -> (QANetLog, a)-executeQAUncachedA code =-  (net_log ns, result)-  where-  (result, ns) = (runState $ unQACachedM $ runKleisli code ()) (initQANetState False)
− src/AERN2/QA/Strategy/Cached/NetState.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-|-    Module      :  AERN2.QA.Strategy.Cached.NetState-    Description :  state of a QA net-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    A monad-generic state of a QA net.--}-module AERN2.QA.Strategy.Cached.NetState-(-  QANetState(..), initQANetState-  , AnyQAComputation(..), QAComputation(..)-  , insertNode, logQuery, logAnswerUpdateCache, getAnswerPromise-)-where--import MixedTypesNumPrelude--- import qualified Prelude as P--- import Text.Printf--import Control.Arrow--import Unsafe.Coerce---- import Data.Maybe--- import Data.List-import qualified Data.Map as Map--import AERN2.QA.Protocol-import AERN2.QA.NetLog--data QANetState m =-  QANetState-  {-    net_id2value :: Map.Map ValueId (AnyQAComputation m)-    , net_log :: QANetLog-    , net_should_cache :: Bool-  }--data AnyQAComputation m =-    forall p . (QAProtocolCacheable p) => -- existentially quantified type-        AnyQAComputation (QAComputation m p)--data QAComputation m p =-    QAComputation-        p-        (QACache p)-        ((Maybe ValueId, Maybe ValueId) -> Q p -> m (QAPromiseA (Kleisli m) (A p))) -- ^ used only if a suitable answer is not in the above cache--initQANetState :: Bool -> QANetState m-initQANetState should_cache =-    QANetState-    {-        net_id2value = Map.empty-        , net_log = []-        , net_should_cache = should_cache-    }--insertNode ::-  (QAProtocolCacheable p) =>-  p ->-  String ->-  [ValueId] ->-  ((Maybe ValueId, Maybe ValueId) -> Q p -> m (QAPromiseA (Kleisli m) (A p))) ->-  QANetState m ->-  (ValueId, QANetState m)-insertNode p name sourceIds q2pa ns =-  (i, ns { net_id2value = id2value', net_log = net_log' } )-  where-  id2value = net_id2value ns-  lg = net_log ns-  i | Map.null id2value = (ValueId 1)-    | otherwise = succ $ fst (Map.findMax id2value)-  id2value' = Map.insert i (AnyQAComputation (QAComputation p (newQACache p) q2pa)) id2value-  net_log' = lg ++ [logItem]-  logItem =-    QANetLogCreate i sourceIds name---logQuery ::-  QANetState m -> Maybe ValueId -> ValueId -> String -> QANetState m-logQuery ns src valueId qS =-  ns { net_log = (net_log ns) ++ [logItem] }-  where-  logItem = QANetLogQuery src valueId qS--logAnswerUpdateCache ::-  (QAProtocolCacheable p)-  =>-  QANetState m -> p -> Maybe ValueId -> ValueId -> (String, String, QACache p) -> QANetState m-logAnswerUpdateCache ns (p :: p) src valueId (aS, usedCacheS, cache') =-  ns-  {-      net_id2value = id2value',-      net_log = (net_log ns) ++ [logItem]-  }-  where-  logItem = QANetLogAnswer src valueId usedCacheS aS-  id2value' =-      Map.insert valueId-          (AnyQAComputation (QAComputation p cache' q2a))-          (net_id2value ns)-  id2value = net_id2value ns-  qaComputation :: (QAComputation m p)-  qaComputation = case Map.lookup valueId id2value of-      Just (AnyQAComputation comp) -> unsafeCoerce comp-      Nothing -> error $ "unknown valueId " ++ show valueId-  QAComputation _ _ q2a = qaComputation--getAnswerPromise ::-  (QAProtocolCacheable p, Monad m)-  =>-  QANetState m -> p -> Maybe ValueId -> ValueId -> Q p -> m (() -> m (A p, [Char], QACache p))-getAnswerPromise ns (p :: p) src valueId q =-  do-  case lookupQACache p cache q of-    (Just a, mLogMsg) ->-      return $ \() -> return (a, logMsg, cache)-      where logMsg = "used cache" ++ case mLogMsg of Nothing -> ""; (Just m) -> " (" ++ m ++ ")"-    (_, mLogMsg) ->-      do-      pa <- q2pa (Just valueId, src) q-      a <- runKleisli pa ()-      let cache' = updateQACache p q a cache-      let a' = case lookupQACache p cache' q of (Just aa, _) -> aa; _ -> a-      if should_cache-        then return $ \() -> return (a', logMsg, cache')-        else return $ \() -> return (a, logMsg, cache)-      where logMsg = "not used cache" ++ case mLogMsg of Nothing -> ""; (Just m) -> " (" ++ m ++ ")"-  where-  id2value = net_id2value ns-  should_cache = net_should_cache ns-  qaComputation :: (QAComputation m p)-  qaComputation = case Map.lookup valueId id2value of-      Just (AnyQAComputation comp) -> unsafeCoerce comp-      Nothing -> error $ "unknown valueId " ++ show valueId-  QAComputation _ cache q2pa = qaComputation
− src/AERN2/QA/Strategy/CachedUnsafe.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE CPP #-}--- #define DEBUG-{-|-    Module      :  AERN2.QA.Strategy.CachedUnsafe-    Description :  QA net plain evaluation with unsafe IO caching-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    QA net plain evaluation with unsafe IO caching--}-module AERN2.QA.Strategy.CachedUnsafe-(-  qaUnsafeCachingMV-)-where--#ifdef DEBUG-import Debug.Trace (trace)-#define maybeTrace trace-#define maybeTraceIO putStrLn-#else-#define maybeTrace (\ (_ :: String) t -> t)-#define maybeTraceIO  (\ (_ :: String)-> return ())-#endif--import MixedTypesNumPrelude--- import qualified Prelude as P--- import Text.Printf--import System.IO.Unsafe (unsafePerformIO)--import Control.Concurrent.MVar--import AERN2.QA.Protocol--{-|-  Normal Haskell functions are a trivial QAArrow instance-  where registration has no effect.--}-instance QAArrow (->) where-  type QAId (->) = ()-  qaRegister _ = id-  newQA name sources p sampleQ makeQ =-    addUnsafeMemoisation $-      defaultNewQA name sources p sampleQ makeQ-  qaMakeQueryGetPromiseA src (qa,q) = qaMakeQueryGetPromise qa (qaId qa, src) q-  qaFulfilPromiseA promise = promise ()--{-| A global variable controlling whether unsafe caching is used in QA objects in the (->) arrow -}-qaUnsafeCachingMV :: MVar Bool-qaUnsafeCachingMV = unsafePerformIO (newMVar True)--{-|-  Add caching to pure (->) QA objects via unsafe memoization, inspired by-  https://hackage.haskell.org/package/ireal-0.2.3/docs/src/Data-Number-IReal-UnsafeMemo.html#unsafeMemo,-  which, in turn, is inspired by Lennart Augustsson's uglymemo.--}-addUnsafeMemoisation :: (QAProtocolCacheable p) => QA (->) p -> QA (->) p-addUnsafeMemoisation qa = qa { qaMakeQueryGetPromise = \ _src -> unsafeMemo }-  where-  unsafeMemo = (unsafePerformIO .) . unsafePerformIO memoIO-  p = qaProtocol qa-  -- name = qaName qa-  memoIO =-    do-    -- putStrLn $ "memoIO starting for " ++ name-    cacheVar <- newMVar $ newQACache p-    return $ useMVar cacheVar-    where-    useMVar cacheVar q () =-      do-      shouldCache <- readMVar qaUnsafeCachingMV-      if not shouldCache then return $ qaMakeQueryGetPromise qa (Nothing, Nothing) q ()-        else-          do-          -- putStrLn $ "memoIO: q = " ++ (show q)-          cache <- readMVar cacheVar-          -- putStrLn $ "memoIO: got cache"-          case lookupQACache p cache q of-            (Just a, _logMsg) ->-              do-              -- putStrLn $ printf "memoIO %s: using cache: ? %s -> ! %s" name (show q) (show a)-              return a-            _ ->-              do-              let a = qaMakeQueryGetPromise qa (Nothing, Nothing) q ()-              modifyMVar_ cacheVar (const (return (updateQACache p q a cache)))-              -- putStrLn $ printf "memoIO  %s: updated cache: ? %s -> ! %s" name (show q) (show a)-              cache' <- readMVar cacheVar-              case lookupQACache p cache' q of-                (Just a', _) -> return a'-                -- this arranges that any size reductions specified in lookupQACache are applied even when the cache was not used-                _ -> return a
− src/AERN2/QA/Strategy/Parallel.hs 
@@ -1,227 +0,0 @@-{-# LANGUAGE CPP #-}--- #define DEBUG-{-|-    Module      :  AERN2.QA.Strategy.Parallel-    Description :  QA net parallel evaluation-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    QA net parallel evaluation--}-module AERN2.QA.Strategy.Parallel-(-  QAParA-  , executeQAParA, executeQAParAwithLog-)-where--#ifdef DEBUG-import Debug.Trace (trace)-#define maybeTrace trace-#define maybeTraceIO putStrLn-#else-#define maybeTrace (\ (_ :: String) t -> t)-#define maybeTraceIO  (\ (_ :: String)-> return ())-#endif--import MixedTypesNumPrelude--- import qualified Prelude as P-import Text.Printf--import Control.Arrow--import qualified Data.IntMap as IntMap--import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad.IO.Class--import AERN2.QA.Protocol-import AERN2.QA.NetLog--data QANetState =-  QANetState-  {-    net_nextId :: ValueId-  , net_log :: QANetLog-  }--initQANetState :: QANetState-initQANetState =-    QANetState-    {-      net_nextId = ValueId 1-    , net_log = []-    }--getValueId :: QANetState -> [ValueId] -> String -> (QANetState, ValueId)-getValueId ns sources name =-  (ns2, vId)-  where-  ns2 =-    ns-    {-      net_nextId = succ vId-    , net_log = (net_log ns) ++ [logItem]-    }-  vId = net_nextId ns-  logItem = QANetLogCreate vId sources name--logQuery ::-  QANetState -> Maybe ValueId -> ValueId -> String -> QANetState-logQuery ns src valueId qS =-  ns { net_log = (net_log ns) ++ [logItem] }-  where-  logItem = QANetLogQuery src valueId qS--logAnswer ::-  QANetState -> Maybe ValueId -> ValueId -> (String, String) -> QANetState-logAnswer ns src valueId (aS, usedCacheS) =-  ns-  {-      net_log = (net_log ns) ++ [logItem]-  }-  where-  logItem = QANetLogAnswer src valueId usedCacheS aS--type QAParA = Kleisli QAParM--data QAParM a = QAParM { unQAParM :: Maybe (TVar QANetState) -> IO a }--instance Functor QAParM where-  -- fmap f (QAParM tv2ma) = QAParM (\nsTV -> fmap f (tv2ma nsTV))-  fmap f (QAParM tv2ma) = QAParM (fmap (fmap f) tv2ma)-instance Applicative QAParM where-  pure a = QAParM (pure . pure a)-  (QAParM tv2f) <*> (QAParM tv2a) =-    QAParM (\nsTV -> (tv2f nsTV <*> tv2a nsTV))-instance Monad QAParM where-  (QAParM tv2ma) >>= f =-    QAParM $ \nsTV -> tv2ma nsTV >>= ($ nsTV) . unQAParM . f-instance MonadIO QAParM where-  liftIO = QAParM . const--instance QAArrow QAParA where-  type QAId QAParA = ValueId-  qaRegister options = Kleisli qaRegisterM-    where-    isParallel = not (QARegPreferSerial `elem` options)-    qaRegisterM qa@(QA__ name Nothing sourceIds (p :: p) sampleQ _) =-      QAParM $ \m_nsTV ->-        do-        vId <- case m_nsTV of-          Nothing -> pure (ValueId 0)-          Just nsTV ->-            atomically $-              do-              ns <- readTVar nsTV-              let (ns2,i) = getValueId ns sourceIds name-              writeTVar nsTV ns2-              pure i-        activeQsTV <- atomically $ newTVar initActiveQs-        cacheTV <- atomically $ newTVar $ newQACache p-        return $ QA__ name (Just vId) [] p sampleQ (\me_src -> Kleisli $ makeQPar vId activeQsTV cacheTV me_src)-      where-      initActiveQs = IntMap.empty :: IntMap.IntMap (Q p)-      nextActiveQId activeQs-        | IntMap.null activeQs = int 1-        | otherwise =-            int $ 1 + (fst $ IntMap.findMax activeQs)-      makeQPar vId activeQsTV cacheTV (_, src) q =-        QAParM $ \m_nsTV ->-          do-          maybeTraceIO $ printf "[%s]: q = %s" name (show q)-          case m_nsTV of-            Nothing -> pure ()-            Just nsTV ->-              atomically $ do -- log query-                ns <- readTVar nsTV-                writeTVar nsTV $ logQuery ns src vId (show q)--          -- consult the cache and index of active queries in an atomic transaction:-          (maybeAnswer, mLogMsg, maybeComputeId) <- atomically $-            do-            cache <- readTVar cacheTV-            case lookupQACache p cache q of-              (Just a, mLogMsg) -> return (Just a, mLogMsg, Nothing)-              (_, mLogMsg) ->-                do-                activeQs <- readTVar activeQsTV-                let alreadyActive = or $ map (!>=! q) $ IntMap.elems activeQs-                if alreadyActive then return (Nothing, mLogMsg, Nothing) else-                  do-                  let computeId = nextActiveQId activeQs-                  writeTVar activeQsTV $ IntMap.insert computeId q activeQs-                  return (Nothing, mLogMsg, Just computeId)-          -- act based on the cache and actity consultation:-          case (maybeAnswer, maybeComputeId) of-            (Just a, _) -> -- got cached answer, just return it:-              pure $ promise mLogMsg (pure a)-            (_, Just computeId) ->-              -- no cached answer, no pending computation:-              do-              _ <- forkComputation m_nsTV computeId -- start a new computation-              pure $ promise mLogMsg waitForAnwer -- and wait for the answer-            _ -> -- no cached answer but there is a pending computation:-              pure $ promise mLogMsg waitForAnwer -- wait for a pending computation-        where-        promise mLogMsg answerIO =-          Kleisli $ const $ QAParM $ \m_nsTV ->-            case m_nsTV of-              Nothing -> answerIO-              Just nsTV -> do-                a <- answerIO-                atomically $ do-                  ns <- readTVar nsTV-                  writeTVar nsTV $ logAnswer ns src vId (show a,  logMsg)-                pure a-          where-          logMsg = case mLogMsg of Just m -> m; _ -> ""-        waitForAnwer = atomically $-          do-          cache <- readTVar cacheTV-          case lookupQACache p cache q of-            (Just a, _mLogMsg) -> return a-            (_, _mLogMsg) -> retry-        forkComputation nsTV computeId-          | isParallel = do { _ <- forkIO computation; return () }-          | otherwise = do { computation; return () }-          where-          computation =-            do-            -- compute an answer:-            a <- (unQAParM $ runKleisli (qaMakeQuery qa src) q) nsTV-            -- update the cache with this answer:-            atomically $ modifyTVar cacheTV (updateQACache p q a)-            -- remove computeId from active queries:-            atomically $ modifyTVar activeQsTV (IntMap.delete computeId)-    qaRegisterM _ =-      error "internal error in AERN2.QA.Strategy.Par: qaRegister called with an existing id"--  qaFulfilPromiseA = Kleisli qaFulfilPromiseM-    where-    qaFulfilPromiseM promiseA =-      runKleisli promiseA ()-  qaMakeQueryGetPromiseA src = Kleisli qaMakeQueryGetPromiseM-    where-    qaMakeQueryGetPromiseM (qa, q) =-      runKleisli (qaMakeQueryGetPromise qa (me, src)) q-      where-      me = case qaId qa of Nothing -> src; me2 -> me2--executeQAParA :: (QAParA () a) -> IO a-executeQAParA code =-  do-  (unQAParM $ runKleisli code ()) Nothing--executeQAParAwithLog :: (QAParA () a) -> IO (QANetLog, a)-executeQAParAwithLog code =-  do-  nsTV <- atomically $ newTVar initQANetState-  result <- (unQAParM $ runKleisli code ()) (Just nsTV)-  ns <- atomically $ readTVar nsTV-  return (net_log ns, result)
src/AERN2/Real.hs view
@@ -8,167 +8,87 @@     Stability   :  experimental     Portability :  portable -    Exact real numbers represented by fast-converging Cauchy sequences of MPBalls.+    Exact real numbers represented by Cauchy sequences of MPBalls. -} module AERN2.Real (-  -- * Re-exported dependencies-  module AERN2.MP-  , module AERN2.AccuracySG-  -- * The type of real numbers-  , CauchyRealP, pCR-  , CauchyRealA, CauchyReal, newCR-  , CauchyRealCNA, CauchyRealCN, newCRCN-  -- * Sequence ops specialised to reals-  , realName, realId, realSources, realRename-  , realWithAccuracy, (?), realWithAccuracyA, realsWithAccuracyA-  , (-:-)-  , convergentList2CauchyRealA-  , seqByPrecision2CauchyRealA-  -- * Conversions-  , CanBeReal, real, CanBeRealA, realA-  , CanBeComplex, complex, CanBeComplexA, complexA-  -- * Constants-  , pi, piA-  -- * Mini demos-  , _addslACachedPrint-  , _addslAParPrint-  , _example_pif-  , _nsection+   -- * real numbers and conversions+   CReal, +   CSequence (..), +   creal, HasCReals, CanBeCReal,+   cseqPrecisions, cseqIndexForPrecision,+   pi,+   -- * limits+   HasLimits(..),+   -- * lazy Kleeneans+   CKleenean, CanBeCKleenean, ckleenean, CanSelect(..),+   -- * extracting approximations+   CanExtractApproximation(..), (?), realWithAccuracy, bits, prec ) where -import AERN2.MP-import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Sequence ()+import AERN2.MP ( bits, prec )+import AERN2.Limit import AERN2.Real.Type-import AERN2.Real.Arithmetic (pi, piA)-import AERN2.Real.Tests ()+import AERN2.Real.Comparisons ()+import AERN2.Real.CKleenean+import AERN2.Real.Field ()+import AERN2.Real.Limit ()+import AERN2.Real.Elementary (pi)+-- import AERN2.Real.Tests ()  -- imports used in examples below: -import MixedTypesNumPrelude--- import qualified Prelude as P--import Control.Arrow--import AERN2.QA.NetLog-import AERN2.QA.Strategy.Cached-import AERN2.QA.Strategy.Parallel+-- import MixedTypesNumPrelude+-- -- import qualified Prelude as P -import Text.Printf--- import AERN2.MP.Dyadic-import AERN2.Sequence+-- import Text.Printf+-- -- import AERN2.MP.Dyadic  -{-|-  Example arrow-generic real number computation--}-_addA :: (QAArrow to) => (CauchyRealA to, CauchyRealA to) `to` CauchyRealA to-_addA =-  -- using -XArrows syntax:-  proc (x,y) ->-    (-:-)-< x + y-      -- -:- is a shorcut for qaRegister--_CRone :: (QAArrow to) => CauchyRealA to-_CRone = realA 1--_addApure :: CauchyReal-_addApure =-  _addA (_CRone, pi)-  -- equivalent to @_CRonePure + _CRonePure@ since registration does nothing--_addAcached :: QACachedA () (CauchyRealA QACachedA)-_addAcached =-  proc () ->-    do-    xReg <-(-:-)-< _CRone-    _addA -< (xReg,piA)-    -- equivalent to @(-:-)-< xReg + piA //.. [xReg,xReg]@-    -- not equivalent to @returnA -< xR + xR@ since there is no registration--_addAcachedPrint :: IO ()-_addAcachedPrint =-  printQANetLogThenResult $ executeQACachedA $-    proc () ->-      do-      x <-_addAcached -< ()-      (-?-) -< (x, bitsS 10)--_addslA :: (QAArrow to) => (CauchyRealA to) `to` (CauchyRealCNA to)-_addslA =-  proc x ->-    do-    xReg <-(-:-)-< x-    lx <-(-:-)-< log xReg-    sx <-(-:-)-< sqrt xReg-    a1 <- (-:-)-< sx + lx-    a2 <- (-:-)-< sx - lx-    (-:-) -< a1 * a2--_addslACachedPrint :: IO ()-_addslACachedPrint =-  printQANetLogThenResult $ executeQACachedA $-    proc () ->-      do-      x <-_addslA -< realA 2-      (-?-) -< (x, bitsS 100)--_addslAParPrint :: IO ()-_addslAParPrint =-  do-  r <- executeQAParA $-    proc () ->-      do-      x <-_addslA -< realA 2-      (-?-) -< (x, bitsS 100)-  print r--{- parallel branching -}+-- {- parallel branching -} -_example_pif :: CauchyReal -> CauchyRealCN-_example_pif r =-  if r < 0 then -r else r -- abs via parallel if+-- _example_pif :: CauchyReal -> CauchyRealCN+-- _example_pif r =+--   if r < 0 then -r else r -- abs via parallel if -_example_pif0 :: MPBall -> CN MPBall-_example_pif0 r =-  if r < 0 then -r else r -- abs via parallel if+-- _example_pif0 :: MPBall -> CN MPBall+-- _example_pif0 r =+--   if r < 0 then -r else r -- abs via parallel if -_nsection ::-  Integer ->-  (Rational -> CauchyReal) ->-  (Rational,Rational) ->-  CauchyRealCN-_nsection n f (l,r) =-  newSeqSimple (cn $ mpBall 0) $ withAccuracy-  where-  withAccuracy (me,_) ac@(AccuracySG _ acG) =-    onSegment (l,r)-    where-    onSegment (a,b) =-      let ab = mpBallP p ((a+b)/!2, (b-a)/!2) in-      if getAccuracy ab >= ac-        then cn ab-        else pick me (map withMidpoint midpoints)-      where-      midpoints = [ (i*a + (n-i)*b)/!n | i <- [1..n-1] ]-      withMidpoint :: Rational -> Sequence (Maybe (CN MPBall))-      withMidpoint m = newSeqSimple Nothing withAC-        where-        withAC (meF, _) acF-          | fa * fm !<! 0 = Just $ onSegment (a, m)-          | fm * fb !<! 0 = Just $ onSegment (m, b)-          | fa * fb !>=! 0 = Just $ err-          | otherwise = Nothing-          where-          fa = ((f a) ?<- meF) acF-          fm = ((f m) ?<- meF) acF-          fb = ((f b) ?<- meF) acF-      err :: CN MPBall-      err =-        noValueNumErrorCertainCN $-          NumError $-            printf "n-section: function does not have opposite signs on points %s %s" (show a) (show b)-    p = prec $ fromAccuracy acG + 8+-- _nsection ::+--   Integer ->+--   (Rational -> CauchyReal) ->+--   (Rational,Rational) ->+--   CauchyRealCN+-- _nsection n f (l,r) =+--   newSeqSimple (cn $ mpBall 0) $ withAccuracy+--   where+--   withAccuracy (me,_) ac@(AccuracySG _ acG) =+--     onSegment (l,r)+--     where+--     onSegment (a,b) =+--       let ab = mpBallP p ((a+b)/!2, (b-a)/!2) in+--       if getAccuracy ab >= ac+--         then cn ab+--         else pick me (map withMidpoint midpoints)+--       where+--       midpoints = [ (i*a + (n-i)*b)/!n | i <- [1..n-1] ]+--       withMidpoint :: Rational -> Sequence (Maybe (CN MPBall))+--       withMidpoint m = newSeqSimple Nothing withAC+--         where+--         withAC (meF, _) acF+--           | fa * fm !<! 0 = Just $ onSegment (a, m)+--           | fm * fb !<! 0 = Just $ onSegment (m, b)+--           | fa * fb !>=! 0 = Just $ err+--           | otherwise = Nothing+--           where+--           fa = ((f a) ?<- meF) acF+--           fm = ((f m) ?<- meF) acF+--           fb = ((f b) ?<- meF) acF+--       err :: CN MPBall+--       err =+--         noValueNumErrorCertainCN $+--           NumError $+--             printf "n-section: function does not have opposite signs on points %s %s" (show a) (show b)+--     p = prec $ fromAccuracy acG + 8
− src/AERN2/Real/Arithmetic.hs 
@@ -1,306 +0,0 @@-{-|-    Module      :  AERN2.Real.Arithmetic-    Description :  arithmetic operations on CR-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Arithmetic operations on Cauchy Real numbers,-    except those that are defined for more general sequences--}-module AERN2.Real.Arithmetic-(-  pi, piA-)-where--import MixedTypesNumPrelude-import qualified Prelude as P--import Data.Convertible--import Data.Complex--import AERN2.MP.Ball-import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Real.Type--instance (QAArrow to) => Ring (CauchyRealA to)-instance (QAArrow to) => OrderedRing (CauchyRealA to)-instance (QAArrow to) => Field (CauchyRealA to)-instance (QAArrow to) => OrderedField (CauchyRealA to)--instance P.Floating CauchyReal where-    pi = pi-    sqrt = (~!) . sqrt-    exp = exp-    sin = sin-    cos = cos-    log = (~!) . log-    (**) = (^!)-    atan = error "CauchyReal: atan not implemented yet"-    atanh = error "CauchyReal: atanh not implemented yet"-    asin = error "CauchyReal: asin not implemented yet"-    acos = error "CauchyReal: acos not implemented yet"-    sinh = error "CauchyReal: sinh not implemented yet"-    cosh = error "CauchyReal: cosh not implemented yet"-    asinh = error "CauchyReal: asinh not implemented yet"-    acosh = error "CauchyReal: acosh not implemented yet"--instance P.Floating CauchyRealCN where-    pi = cn pi-    sqrt = sqrt-    exp = exp-    sin = sin-    cos = cos-    log = log-    -- (**) = (^)-    atan = error "CauchyReal: atan not implemented yet"-    atanh = error "CauchyReal: atanh not implemented yet"-    asin = error "CauchyReal: asin not implemented yet"-    acos = error "CauchyReal: acos not implemented yet"-    sinh = error "CauchyReal: sinh not implemented yet"-    cosh = error "CauchyReal: cosh not implemented yet"-    asinh = error "CauchyReal: asinh not implemented yet"-    acosh = error "CauchyReal: acosh not implemented yet"--{-|-  To get @pi@ in an arbitrary arrow, use 'piA'.--}-pi :: CauchyReal-pi = newCR "pi" [] (\_me_src -> (seqByPrecision2CauchySeq piBallP . _acGuide))--piA :: (QAArrow to) => CauchyRealA to-piA = realA pi---{- sine, cosine of finite values -}--instance CanSinCos Integer where-  type SinCosType Integer = CauchyReal-  cos = cos . real-  sin = sin . real--instance CanSinCos Int where-  type SinCosType Int = CauchyReal-  cos = cos . real-  sin = sin . real--instance CanSinCos Dyadic where-  type SinCosType Dyadic = CauchyReal-  cos = cos . real-  sin = sin . real--instance CanSinCos Rational where-  type SinCosType Rational = CauchyReal-  cos = cos . real-  sin = sin . real--{- sqrt of finite values -}--instance CanSqrt Integer where-  type SqrtType Integer = CauchyRealCN-  sqrt = sqrt . real--instance CanSqrt Int where-  type SqrtType Int = CauchyRealCN-  sqrt = sqrt . real--instance CanSqrt Dyadic where-  type SqrtType Dyadic = CauchyRealCN-  sqrt = sqrt . real--instance CanSqrt Rational where-  type SqrtType Rational = CauchyRealCN-  sqrt = sqrt . real--{- exp of finite values -}--instance CanExp Integer where-  type ExpType Integer = CauchyReal-  exp = exp . real--instance CanExp Int where-  type ExpType Int = CauchyReal-  exp = exp . real--instance CanExp Dyadic where-  type ExpType Dyadic = CauchyReal-  exp = exp . real--instance CanExp Rational where-  type ExpType Rational = CauchyReal-  exp = exp . real--{- log of finite values -}--instance CanLog Integer where-  type LogType Integer = CauchyRealCN-  log = log . real--instance CanLog Int where-  type LogType Int = CauchyRealCN-  log = log . real--instance CanLog Dyadic where-  type LogType Dyadic = CauchyRealCN-  log = log . real--instance CanLog Rational where-  type LogType Rational = CauchyRealCN-  log = log . real--{- non-integer power of finite values -}--instance CanPow Integer Dyadic where-  type PowTypeNoCN Integer Dyadic = CauchyReal-  powNoCN b e = powNoCN (real b) (real e)-  pow b e = pow (real b) (real e)--instance CanPow Int Dyadic where-  type PowTypeNoCN Int Dyadic = CauchyReal-  powNoCN b e = powNoCN (real b) (real e)-  pow b e = pow (real b) (real e)--instance CanPow Dyadic Dyadic where-  type PowTypeNoCN Dyadic Dyadic = CauchyReal-  powNoCN b e = powNoCN (real b) (real e)-  pow b e = pow (real b) (real e)--instance CanPow Rational Dyadic where-  type PowTypeNoCN Rational Dyadic = CauchyReal-  powNoCN b e = powNoCN (real b) (real e)-  pow b e = pow (real b) (real e)--instance CanPow Integer Rational where-  type PowTypeNoCN Integer Rational = CauchyReal-  powNoCN b e = powNoCN (real b) (real e)-  pow b e = pow (real b) (real e)--instance CanPow Int Rational where-  type PowTypeNoCN Int Rational = CauchyReal-  powNoCN b e = powNoCN (real b) (real e)-  pow b e = pow (real b) (real e)--instance CanPow Dyadic Rational where-  type PowTypeNoCN Dyadic Rational = CauchyReal-  powNoCN b e = powNoCN (real b) (real e)-  pow b e = pow (real b) (real e)--instance CanPow Rational Rational where-  type PowTypeNoCN Rational Rational = CauchyReal-  powNoCN b e = powNoCN (real b) (real e)-  pow b e = pow (real b) (real e)--{- reals mixed with Double -}--instance Convertible CauchyReal Double where-  safeConvert r =-    safeConvert (centre (r ? (bitsS 53)))--binaryWithDouble :: (Double -> Double -> Double) -> CauchyReal -> Double -> Double-binaryWithDouble op r d =-  op (convert r) d--instance CanAddAsymmetric CauchyReal Double where-  type AddType CauchyReal Double = Double-  add = binaryWithDouble add--instance CanAddAsymmetric Double CauchyReal where-  type AddType Double CauchyReal = Double-  add = flip add--instance CanSub CauchyReal Double where-  type SubType CauchyReal Double = Double-  sub = binaryWithDouble sub--instance CanSub Double CauchyReal where-  type SubType Double CauchyReal = Double-  sub = flip $ binaryWithDouble (flip sub)--instance CanMulAsymmetric CauchyReal Double where-  type MulType CauchyReal Double = Double-  mul = binaryWithDouble mul--instance CanMulAsymmetric Double CauchyReal where-  type MulType Double CauchyReal = Double-  mul = flip mul--instance CanDiv CauchyReal Double where-  type DivType CauchyReal Double = Double-  divide = binaryWithDouble divide-  type DivTypeNoCN CauchyReal Double = Double-  divideNoCN = binaryWithDouble divideNoCN--instance CanDiv Double CauchyReal where-  type DivType Double CauchyReal = Double-  divide = flip $ binaryWithDouble (flip divide)-  type DivTypeNoCN Double CauchyReal = Double-  divideNoCN = flip $ binaryWithDouble (flip divideNoCN)--instance CanPow CauchyReal Double where-  type PowTypeNoCN CauchyReal Double = Double-  type PowType CauchyReal Double = Double-  powNoCN = binaryWithDouble pow-  pow = binaryWithDouble pow--instance CanPow Double CauchyReal where-  powNoCN = flip $ binaryWithDouble (flip pow)-  type PowType Double CauchyReal = Double-  pow = flip $ binaryWithDouble (flip pow)--{- reals mixed with complex -}--instance-  (QAArrow to, CanAddAsymmetric (CauchyRealA to) t)-  =>-  CanAddAsymmetric (CauchyRealA to) (Complex t)-  where-  type AddType (CauchyRealA to) (Complex t) = Complex (AddType (CauchyRealA to) t)-  add r (a :+ i) = (r + a) :+ (z + i)-    where-    z = realA 0-    _ = [z,r]--instance-  (QAArrow to, CanAddAsymmetric t (CauchyRealA to))-  =>-  CanAddAsymmetric (Complex t) (CauchyRealA to)-  where-  type AddType (Complex t) (CauchyRealA to) = Complex (AddType t (CauchyRealA to))-  add (a :+ i) r = (a + r) :+ (i + z)-    where-    z = realA 0-    _ = [z,r]--instance-  (QAArrow to, CanAdd (CauchyRealA to) t, CanNegSameType t)-  =>-  CanSub (CauchyRealA to) (Complex t)--instance-  (QAArrow to, CanAdd t (CauchyRealA to))-  =>-  CanSub (Complex t) (CauchyRealA to)--instance-  (CanMulAsymmetric (CauchyRealA to) t)-  =>-  CanMulAsymmetric (CauchyRealA to) (Complex t)-  where-  type MulType (CauchyRealA to) (Complex t) = Complex (MulType (CauchyRealA to) t)-  mul r (a :+ i) = (r * a) :+ (r * i)--instance-  (CanMulAsymmetric t (CauchyRealA to))-  =>-  CanMulAsymmetric (Complex t) (CauchyRealA to)-  where-  type MulType (Complex t) (CauchyRealA to) = Complex (MulType t (CauchyRealA to))-  mul (a :+ i) r = (a * r) :+ (i * r)
+ src/AERN2/Real/CKleenean.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-|+    Module      :  AERN2.Real.CKleenean+    Description :  lazy Kleenean+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++    Lazy Kleenean, ie a sequence of Kleeneans, usually indexed by increasing precisions.+-}+module AERN2.Real.CKleenean+(+  CKleenean, CanBeCKleenean, ckleenean+  , CanSelect(..)+)+where++import MixedTypesNumPrelude++import qualified Numeric.CollectErrors as CN++-- import Data.Complex++import qualified Data.List as List++import AERN2.MP++import AERN2.Real.Type++type CKleenean = CSequence Kleenean++type CanBeCKleenean t = ConvertibleExactly t CKleenean++ckleenean :: (CanBeCKleenean t) => t -> CKleenean+ckleenean = convertExactly++-- IsBool CKleenean:++instance (ConvertibleExactly t Kleenean) => ConvertibleExactly t CKleenean where+  safeConvertExactly b = Right $ CSequence $ List.repeat $ cn $ kleenean b++instance (CanNeg t) => CanNeg (CSequence t) where+  type NegType (CSequence t) = CSequence (NegType t)+  negate = lift1 negate++instance (CanAndOrAsymmetric t1 t2) => CanAndOrAsymmetric (CSequence t1) (CSequence t2) where+  type AndOrType (CSequence t1)  (CSequence t2) = CSequence (AndOrType t1 t2)+  and2 = lift2 and2+  or2 = lift2 or2++-- select:++class (IsBool (SelectType k)) => CanSelect k where+  {-| Must be Bool or similar -}+  type SelectType k +  {-|+    Execute two lazy computations "in parallel" until one of them succeeds. +  -}+  select :: k -> k -> (SelectType k) {-^ True means that the first computation succeeded. -}++instance CanSelect CKleenean where+  type SelectType CKleenean = Bool+  select (CSequence s1) (CSequence s2) = aux s1 s2+    where+    aux (k1 : rest1) (k2 : rest2) =+      case (CN.toEither k1, CN.toEither k2) of+        (Right CertainTrue, _) -> True +        (_, Right CertainTrue) -> False+        (Right CertainFalse, Right CertainFalse) -> error "select: Both branches failed!"+        _ -> aux rest1 rest2+    aux _ _ = error "select: internal error"++instance CanSelect Kleenean where+  type SelectType Kleenean = CN Bool+  select CertainTrue _ = cn True+  select _ CertainTrue = cn False+  select CertainFalse CertainFalse =+    CN.noValueNumErrorPotential $ +      CN.NumError "select (Kleenean): Both branches failed!"+  select _ _ = +    CN.noValueNumErrorPotential $ +      CN.NumError "select (Kleenean): Insufficient information to determine selection."++instance CanSelect (CN Kleenean) where+  type SelectType (CN Kleenean) = CN Bool+  select cnk1 cnk2 =+    do+    k1 <- cnk1+    k2 <- cnk2+    select k1 k2++instance (CanUnionCNSameType t) =>+  HasIfThenElse CKleenean (CSequence t)+  where+  type IfThenElseType CKleenean (CSequence t) = (CSequence t)+  ifThenElse (CSequence sc) (CSequence s1) (CSequence s2) = (CSequence r)+    where+    r = zipWith3 ifThenElse sc s1 s2
+ src/AERN2/Real/Comparisons.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-|+    Module      :  AERN2.Real.Comparisons+    Description :  comparison  on CReal+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++    Comparison relations over Cauchy Real numbers.+-}+module AERN2.Real.Comparisons+()+where++import MixedTypesNumPrelude+import qualified Prelude as P++-- import Data.Complex++import AERN2.MP.Ball+import AERN2.MP.Dyadic++import AERN2.Real.Type+import AERN2.Real.CKleenean ()++-- equality:++instance+  (HasEqAsymmetric t1 t2, IsBool (CSequence (EqCompareType t1 t2)))+  => +  HasEqAsymmetric (CSequence t1) (CSequence t2) +  where+  type EqCompareType (CSequence t1) (CSequence t2) = CSequence (EqCompareType t1 t2)+  equalTo = lift2 equalTo++-- order:++instance +  (HasOrderAsymmetric t1 t2, IsBool (CSequence (OrderCompareType t1 t2)))+  => +  HasOrderAsymmetric (CSequence t1) (CSequence t2) +  where+  type OrderCompareType (CSequence t1) (CSequence t2) = CSequence (OrderCompareType t1 t2)+  lessThan  = lift2 lessThan+  greaterThan = lift2 greaterThan+  leq = lift2 leq+  geq = lift2 geq++-- abs:++instance+  (CanAbs t1)+  => +  CanAbs (CSequence t1)+  where+  type AbsType (CSequence t1) = CSequence (AbsType t1)+  abs = lift1 abs++-- min / max:++instance+  (CanMinMaxAsymmetric t1 t2)+  => +  CanMinMaxAsymmetric (CSequence t1) (CSequence t2) +  where+  type MinMaxType (CSequence t1) (CSequence t2) = CSequence (MinMaxType t1 t2)+  min = lift2 min+  max = lift2 max++-- mixed type instances:++instance+  (CanMinMaxAsymmetric a MPBall)+  => +  CanMinMaxAsymmetric (CSequence a) MPBall+  where+  type MinMaxType (CSequence a) MPBall = MinMaxType (CN a) (CN MPBall)+  min s a = min (s ? (getPrecision a)) (cn a)+  max s a = max (s ? (getPrecision a)) (cn a)++instance+  (CanMinMaxAsymmetric a MPBall)+  => +  CanMinMaxAsymmetric (CSequence a) (CN MPBall)+  where+  type MinMaxType (CSequence a) (CN MPBall) = MinMaxType (CN a) (CN MPBall)+  min s a = min (s ? (getPrecision a)) a+  max s a = max (s ? (getPrecision a)) a++instance+  (CanMinMaxAsymmetric MPBall a)+  => +  CanMinMaxAsymmetric MPBall (CSequence a)+  where+  type MinMaxType MPBall (CSequence a) = MinMaxType (CN MPBall) (CN a)+  min a s = min (cn a) (s ? (getPrecision a))+  max a s = max (cn a) (s ? (getPrecision a))++instance+  (CanMinMaxAsymmetric MPBall a)+  => +  CanMinMaxAsymmetric (CN MPBall) (CSequence a)+  where+  type MinMaxType (CN MPBall) (CSequence a) = MinMaxType (CN MPBall) (CN a)+  min a s = min a (s ? (getPrecision a))+  max a s = max a (s ? (getPrecision a))+++instance+  (HasEqAsymmetric a MPBall)+  => +  HasEqAsymmetric (CSequence a) MPBall+  where+  type EqCompareType (CSequence a) MPBall = EqCompareType (CN a) (CN MPBall)+  equalTo s a = equalTo (s ? (getPrecision a)) (cn a)+  notEqualTo s a = notEqualTo (s ? (getPrecision a)) (cn a)++instance+  (HasEqAsymmetric a MPBall)+  => +  HasEqAsymmetric (CSequence a) (CN MPBall)+  where+  type EqCompareType (CSequence a) (CN MPBall) = EqCompareType (CN a) (CN MPBall)+  equalTo s a = equalTo (s ? (getPrecision a)) a+  notEqualTo s a = notEqualTo (s ? (getPrecision a)) a++instance+  (HasEqAsymmetric MPBall b)+  => +  HasEqAsymmetric MPBall (CSequence b)+  where+  type EqCompareType MPBall (CSequence b) = EqCompareType (CN MPBall) (CN b)+  equalTo a s = equalTo (cn a) (s ? (getPrecision a))+  notEqualTo a s = notEqualTo (cn a) (s ? (getPrecision a))++instance+  (HasEqAsymmetric MPBall b)+  => +  HasEqAsymmetric (CN MPBall) (CSequence b)+  where+  type EqCompareType (CN MPBall) (CSequence b) = EqCompareType (CN MPBall) (CN b)+  equalTo a s = equalTo a (s ? (getPrecision a))+  notEqualTo a s = notEqualTo a (s ? (getPrecision a))++instance+  (HasOrderAsymmetric a MPBall)+  => +  HasOrderAsymmetric (CSequence a) MPBall+  where+  type OrderCompareType (CSequence a) MPBall = OrderCompareType (CN a) (CN MPBall)+  lessThan s a = lessThan (s ? (getPrecision a)) (cn a)+  greaterThan s a = greaterThan (s ? (getPrecision a)) (cn a)+  leq s a = leq (s ? (getPrecision a)) (cn a)+  geq s a = geq (s ? (getPrecision a)) (cn a)++instance+  (HasOrderAsymmetric a MPBall)+  => +  HasOrderAsymmetric (CSequence a) (CN MPBall)+  where+  type OrderCompareType (CSequence a) (CN MPBall) = OrderCompareType (CN a) (CN MPBall)+  lessThan s a = lessThan (s ? (getPrecision a)) a+  greaterThan s a = greaterThan (s ? (getPrecision a)) a+  leq s a = leq (s ? (getPrecision a)) a+  geq s a = geq (s ? (getPrecision a)) a++instance+  (HasOrderAsymmetric MPBall b)+  => +  HasOrderAsymmetric MPBall (CSequence b)+  where+  type OrderCompareType MPBall (CSequence b) = OrderCompareType (CN MPBall) (CN b)+  lessThan a s = lessThan (cn a) (s ? (getPrecision a))+  greaterThan a s = greaterThan (cn a) (s ? (getPrecision a))+  leq a s = leq (cn a) (s ? (getPrecision a))+  geq a s = geq (cn a) (s ? (getPrecision a))++instance+  (HasOrderAsymmetric MPBall b)+  => +  HasOrderAsymmetric (CN MPBall) (CSequence b)+  where+  type OrderCompareType (CN MPBall) (CSequence b) = OrderCompareType (CN MPBall) (CN b)+  lessThan a s = lessThan a (s ? (getPrecision a))+  greaterThan a s = greaterThan a (s ? (getPrecision a))+  leq a s = leq a (s ? (getPrecision a))+  geq a s = geq a (s ? (getPrecision a))++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]+  (\ t -> [d|++    instance+      (CanMinMaxAsymmetric a $t)+      => +      CanMinMaxAsymmetric (CSequence a) $t+      where+      type MinMaxType (CSequence a) $t = CSequence (MinMaxType a $t)+      min = lift1T min+      max = lift1T max++    instance+      (CanMinMaxAsymmetric a $t)+      => +      CanMinMaxAsymmetric (CSequence a) (CN $t)+      where+      type MinMaxType (CSequence a) (CN $t) = CSequence (MinMaxType a $t)+      min = lift1T min+      max = lift1T max++    instance+      (CanMinMaxAsymmetric $t a)+      => +      CanMinMaxAsymmetric $t (CSequence a)+      where+      type MinMaxType $t (CSequence a) = CSequence (MinMaxType $t a)+      min = liftT1 min+      max = liftT1 max++    instance+      (CanMinMaxAsymmetric $t a)+      => +      CanMinMaxAsymmetric (CN $t) (CSequence a)+      where+      type MinMaxType (CN $t) (CSequence a) = CSequence (MinMaxType $t a)+      min = liftT1 min+      max = liftT1 max++    instance+      (HasEqAsymmetric a $t, IsBool (CSequence (EqCompareType a $t)))+      => +      HasEqAsymmetric (CSequence a) $t+      where+      type EqCompareType (CSequence a) $t = CSequence (EqCompareType a $t)+      equalTo = lift1T (==)+      notEqualTo = lift1T (/=)++    instance+      (HasEqAsymmetric a $t, IsBool (CSequence (EqCompareType a $t)))+      => +      HasEqAsymmetric (CSequence a) (CN $t)+      where+      type EqCompareType (CSequence a) (CN $t) = CSequence (EqCompareType a $t)+      equalTo = lift1T (==)+      notEqualTo = lift1T (/=)++    instance+      (HasEqAsymmetric $t a, IsBool (CSequence (EqCompareType $t a)))+      =>+      HasEqAsymmetric $t (CSequence a)+      where+      type EqCompareType $t (CSequence a) = CSequence (EqCompareType $t a)+      equalTo = liftT1 (==)+      notEqualTo = liftT1 (/=)++    instance+      (HasEqAsymmetric $t a, IsBool (CSequence (EqCompareType $t a)))+      =>+      HasEqAsymmetric (CN $t) (CSequence a)+      where+      type EqCompareType (CN $t) (CSequence a) = CSequence (EqCompareType $t a)+      equalTo = liftT1 (==)+      notEqualTo = liftT1 (/=)++    instance+      (HasOrderAsymmetric a $t, IsBool (CSequence (OrderCompareType a $t)))+      => +      HasOrderAsymmetric (CSequence a) $t+      where+      type OrderCompareType (CSequence a) $t = CSequence (OrderCompareType a $t)+      lessThan = lift1T lessThan+      greaterThan = lift1T greaterThan+      leq = lift1T leq+      geq = lift1T geq++    instance+      (HasOrderAsymmetric a $t, IsBool (CSequence (OrderCompareType a $t)))+      => +      HasOrderAsymmetric (CSequence a) (CN $t)+      where+      type OrderCompareType (CSequence a) (CN $t) = CSequence (OrderCompareType a $t)+      lessThan = lift1T lessThan+      greaterThan = lift1T greaterThan+      leq = lift1T leq+      geq = lift1T geq++    instance+      (HasOrderAsymmetric $t a, IsBool (CSequence (OrderCompareType $t a)))+      =>+      HasOrderAsymmetric $t (CSequence a)+      where+      type OrderCompareType $t (CSequence a) = CSequence (OrderCompareType $t a)+      lessThan = liftT1 lessThan+      greaterThan = liftT1 greaterThan+      leq = liftT1 leq+      geq = liftT1 geq++    instance+      (HasOrderAsymmetric $t a, IsBool (CSequence (OrderCompareType $t a)))+      =>+      HasOrderAsymmetric (CN $t) (CSequence a)+      where+      type OrderCompareType (CN $t) (CSequence a) = CSequence (OrderCompareType $t a)+      lessThan = liftT1 lessThan+      greaterThan = liftT1 greaterThan+      leq = liftT1 leq+      geq = liftT1 geq++  |]))+++{- Prelude Eq, Ord instances -}++instance+  (HasEqCertainly a a)+  =>+  P.Eq (CSequence a)+  where+  a == b+    | aD !==! bD = True+    | aD !/=! bD = False+    | otherwise =+        error "Failed to decide equality of Sequences.  If you switch to MixedTypesNumPrelude instead of Prelude, comparison of Sequences returns CSequence Kleenean or similar instead of Bool."+    where+    aD = a ? defaultPrecision+    bD = b ? defaultPrecision ++instance+  (HasEqCertainly a a, HasOrderCertainly a a)+  =>+  P.Ord (CSequence a)+  where+  compare a b+    | aD !==! bD = P.EQ+    | aD !<! bD = P.LT+    | aD !>! bD = P.GT+    | otherwise =+        error "Failed to decide order of Sequences.  If you switch to MixedTypesNumPrelude instead of Prelude, comparison of Sequences returns CSequence Kleenean or similar instead of Bool."+    where+    aD = a ? defaultPrecision+    bD = b ? defaultPrecision
+ src/AERN2/Real/Elementary.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-|+    Module      :  AERN2.Real.Elementary+    Description :  selected elementary operations on CReal+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++    Selected elementary operations on Cauchy Real numbers.+-}+module AERN2.Real.Elementary+(+  pi+)+where++import MixedTypesNumPrelude+import qualified Prelude as P++import AERN2.MP.Ball+import AERN2.MP.Dyadic++import AERN2.Real.Type+import AERN2.Real.Field ()++{- Examples of use:++*AERN2.Real MixedTypesNumPrelude> sin 1+{?(prec 36): [0.841470984814804978668689727783203125 ± ~1.5621e-10 ~2^(-32)]}+(0.06 secs, 722,440 bytes)+*AERN2.Real MixedTypesNumPrelude> sin 1 ? (bits 1000)+[0.8414709848078965066525023216302989996225630607... ± ~0.0000 ~2^(-1222)]++*AERN2.Real MixedTypesNumPrelude> exp 2 ? (prec 100)+[7.3890560989306502272304274605750078131770241145... ± ~4.7020e-38 ~2^(-124)]+(0.01 secs, 691,448 bytes)+*AERN2.Real MixedTypesNumPrelude> exp 2 ? (prec 1000)+[7.3890560989306502272304274605750078131803155705... ± ~0.0000 ~2^(-1422)]+(0.01 secs, 1,402,832 bytes)+*AERN2.Real MixedTypesNumPrelude> exp 2 ? (prec 10000)+[7.3890560989306502272304274605750078131803155705... ± ~0.0000 ~2^(-16086)]+(0.02 secs, 17,478,648 bytes)+*AERN2.Real MixedTypesNumPrelude> exp 2 ? (prec 100000)+[7.3890560989306502272304274605750078131803155705... ± ~0.0000 ~2^(-179557)]+(0.61 secs, 576,337,656 bytes)+*AERN2.Real MixedTypesNumPrelude> exp 2 ? (prec 1000000)+[7.3890560989306502272304274605750078131803155705... ± ~0.0000 ~2^(-1232830)]+(14.98 secs, 10,234,710,976 bytes)++*AERN2.Real MixedTypesNumPrelude> 2^0.5 ? (prec 100)+[1.4142135623730950488016887242096980779395106418... ± ~1.3299e-36 ~2^(-119)]+(0.01 secs, 1,128,824 bytes)+*AERN2.Real MixedTypesNumPrelude> 2^0.5 ? (prec 1000)+[1.4142135623730950488016887242096980785696718753... ± ~0.0000 ~2^(-1229)]+(0.02 secs, 6,903,360 bytes)+*AERN2.Real MixedTypesNumPrelude> 2^0.5 ? (prec 10000)+[1.4142135623730950488016887242096980785696718753... ± ~0.0000 ~2^(-13539)]+(0.38 secs, 282,175,336 bytes)++*AERN2.Real MixedTypesNumPrelude> 2^(1/3) ? (prec 1000)+[1.2599210498948731647672106072782283505702514647... ± ~0.0000 ~2^(-1229)]+(0.01 secs, 6,946,896 bytes)+*AERN2.Real MixedTypesNumPrelude> 2^(1/3) ? (prec 10000)+[1.2599210498948731647672106072782283505702514647... ± ~0.0000 ~2^(-13539)]+(0.40 secs, 281,994,312 bytes)++-}++{- common elementary operations -}++pi :: CReal+pi = CSequence $ map (cn . piBallP) cseqPrecisions++{- sine, cosine -}++instance CanSinCos CReal where+  cos = lift1 cos+  sin = lift1 sin++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]+  (\ t -> [d|++  instance CanSinCos $t where+    type SinCosType $t = CReal+    cos = cos . creal+    sin = sin . creal++  |]))++{- sqrt -}++instance CanSqrt CReal where+  sqrt = lift1 sqrt++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]+  (\ t -> [d|++  instance CanSqrt $t where+    type SqrtType $t = CReal+    sqrt = sqrt . creal++  |]))++{- exp -}++instance CanExp CReal where+  exp = lift1 exp++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]+  (\ t -> [d|++  instance CanExp $t where+    type ExpType $t = CReal+    exp = exp . creal++  |]))++{- log  -}++instance CanLog CReal where+  log = lift1 log++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]+  (\ t -> [d|++  instance CanLog $t where+    type LogType $t = CReal+    log = log . creal++  |]))++{- power -}++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]+  (\ t -> [d|++  instance CanPow $t Dyadic where+    type PowType $t Dyadic = CReal+    pow b e = pow (creal b) (creal e)++  |]))++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]+  (\ t -> [d|++  instance CanPow $t Rational where+    type PowType $t Rational = CReal+    pow b e = pow (creal b) (creal e)++  |]))++-- {- reals mixed with Double -}++-- instance Convertible CReal Double where+--   safeConvert r =+--     safeConvert (centre (r ? (bitsS 53)))++-- binaryWithDouble :: (Double -> Double -> Double) -> CReal -> Double -> Double+-- binaryWithDouble op r d =+--   op (convert r) d++-- instance CanAddAsymmetric CReal Double where+--   type AddType CReal Double = Double+--   add = binaryWithDouble add++-- instance CanAddAsymmetric Double CReal where+--   type AddType Double CReal = Double+--   add = flip add++-- instance CanSub CReal Double where+--   type SubType CReal Double = Double+--   sub = binaryWithDouble sub++-- instance CanSub Double CReal where+--   type SubType Double CReal = Double+--   sub = flip $ binaryWithDouble (flip sub)++-- instance CanMulAsymmetric CReal Double where+--   type MulType CReal Double = Double+--   mul = binaryWithDouble mul++-- instance CanMulAsymmetric Double CReal where+--   type MulType Double CReal = Double+--   mul = flip mul++-- instance CanDiv CReal Double where+--   type DivType CReal Double = Double+--   divide = binaryWithDouble divide++-- instance CanDiv Double CReal where+--   type DivType Double CReal = Double+--   divide = flip $ binaryWithDouble (flip divide)++-- instance CanPow CReal Double where+--   type PowType CReal Double = Double+--   pow = binaryWithDouble pow++-- instance CanPow Double CReal where+--   type PowType Double CReal = Double+--   pow = flip $ binaryWithDouble (flip pow)++instance P.Floating CReal where+    pi = pi+    sqrt = sqrt+    exp = exp+    sin = sin+    cos = cos+    log = log+    -- (**) = (^)+    atan = error "CReal: atan not implemented yet"+    atanh = error "CReal: atanh not implemented yet"+    asin = error "CReal: asin not implemented yet"+    acos = error "CReal: acos not implemented yet"+    sinh = error "CReal: sinh not implemented yet"+    cosh = error "CReal: cosh not implemented yet"+    asinh = error "CReal: asinh not implemented yet"+    acosh = error "CReal: acosh not implemented yet"
+ src/AERN2/Real/Field.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-|+    Module      :  AERN2.Real.Field+    Description :  field operations on CReal+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++    Field operations on Cauchy Real numbers.+-}+module AERN2.Real.Field+(+-- * field ops (`add`, `sub`, `mul`, `div`) for `CReal -> CReal -> CReal`+-- * field ops for `CReal -> t -> CReal` and `t -> CReal -> CReal` where `t` is `Int`, `Integer`, `Rational`, `Dyadic`+-- * field ops for `CReal -> MPBall -> MPBall` and `CReal -> CN MPBall -> CN MPBall`+)+where++import MixedTypesNumPrelude+import qualified Prelude as P++import AERN2.MP.Ball+import AERN2.MP.Dyadic++import AERN2.Real.Type+import AERN2.Real.Comparisons ()++{- field operations -}++instance Ring CReal+instance OrderedRing CReal+instance Field CReal+instance OrderedField CReal++instance+  (CanAddAsymmetric t1 t2)+  => +  CanAddAsymmetric (CSequence t1) (CSequence t2) +  where+  type AddType (CSequence t1) (CSequence t2) = CSequence (AddType t1 t2)+  add = lift2 add++instance+  (CanSub t1 t2)+  => +  CanSub (CSequence t1) (CSequence t2) +  where+  type SubType (CSequence t1) (CSequence t2) = CSequence (SubType t1 t2)+  sub = lift2 sub++instance+  (CanMulAsymmetric t1 t2, CanGiveUpIfVeryInaccurate (MulType t1 t2))+  => +  CanMulAsymmetric (CSequence t1) (CSequence t2) +  where+  type MulType (CSequence t1) (CSequence t2) = CSequence (MulType t1 t2)+  mul = lift2 mul++instance+  (CanDiv t1 t2, CanTestZero t2)+  => +  CanDiv (CSequence t1) (CSequence t2) +  where+  type DivType (CSequence t1) (CSequence t2) = CSequence (DivType t1 t2)+  divide = lift2 divide++instance+  (CanPow b e, HasOrderCertainly b Integer, HasOrderCertainly e Integer,+   HasEqCertainly b Integer, CanTestInteger e) +  =>+  CanPow (CSequence b) (CSequence e) +  where+  type PowType (CSequence b) (CSequence e) = CSequence (PowType b e)+  pow = lift2 pow++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |]]+  (\ e -> [d|++  instance +    (CanPow b $e, HasOrderCertainly b Integer, HasEqCertainly b Integer)+    =>+    CanPow (CSequence b) $e +    where+    type PowType (CSequence b) $e = CSequence (PowType b $e)+    pow = lift1T pow++  |]))++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |]]+  (\ b -> [d|++  instance +    (CanPow $b e, HasOrderCertainly e Integer, CanTestInteger e)+    =>+    CanPow $b (CSequence e) +    where+    type PowType $b (CSequence e) = CSequence (PowType $b e)+    pow = liftT1 pow+  |]))++---------------------------------------------------+---------------------------------------------------+-- MPBall and CN MPBall mixed-type arithmetic+---------------------------------------------------+---------------------------------------------------++instance+  (CanAddAsymmetric MPBall b)+  => +  CanAddAsymmetric MPBall (CSequence b)+  where+  type AddType MPBall (CSequence b) = AddType MPBall b+  add a s = add a (unCN $ s ? (getPrecision a))++instance+  (CanAddAsymmetric b MPBall)+  => +  CanAddAsymmetric (CSequence b) MPBall+  where+  type AddType (CSequence b) MPBall = AddType b MPBall+  add s b = add (unCN $ s ? (getPrecision b)) b++instance+  (CanAddAsymmetric MPBall b)+  => +  CanAddAsymmetric (CN MPBall) (CSequence b)+  where+  type AddType (CN MPBall) (CSequence b) = AddType (CN MPBall) (CN b)+  add a s = add a (s ? (getPrecision a))++instance+  (CanAddAsymmetric b MPBall)+  => +  CanAddAsymmetric (CSequence b) (CN MPBall)+  where+  type AddType (CSequence b) (CN MPBall) = AddType (CN b) (CN MPBall)+  add s b = add (s ? (getPrecision b)) b++instance+  (CanSub MPBall b)+  => +  CanSub MPBall (CSequence b)+  where+  type SubType MPBall (CSequence b) = SubType MPBall b+  sub a s = sub a (unCN $ s ? (getPrecision a))++instance+  (CanSub b MPBall)+  => +  CanSub (CSequence b) MPBall+  where+  type SubType (CSequence b) MPBall = SubType b MPBall+  sub s b = sub (unCN $ s ? (getPrecision b)) b++instance+  (CanSub MPBall b)+  => +  CanSub (CN MPBall) (CSequence b)+  where+  type SubType (CN MPBall) (CSequence b) = SubType (CN MPBall) (CN b)+  sub a s = sub a (s ? (getPrecision a))++instance+  (CanSub b MPBall)+  => +  CanSub (CSequence b) (CN MPBall)+  where+  type SubType (CSequence b) (CN MPBall) = SubType (CN b) (CN MPBall)+  sub s b = sub (s ? (getPrecision b)) b++instance+  (CanMulAsymmetric MPBall b)+  => +  CanMulAsymmetric MPBall (CSequence b)+  where+  type MulType MPBall (CSequence b) = MulType MPBall b+  mul a s = mul a (unCN $ s ? (getPrecision a))++instance+  (CanMulAsymmetric b MPBall)+  => +  CanMulAsymmetric (CSequence b) MPBall+  where+  type MulType (CSequence b) MPBall = MulType b MPBall+  mul s b = mul (unCN $ s ? (getPrecision b)) b++instance+  (CanMulAsymmetric MPBall b, CanGiveUpIfVeryInaccurate (MulType MPBall b))+  => +  CanMulAsymmetric (CN MPBall) (CSequence b)+  where+  type MulType (CN MPBall) (CSequence b) = MulType (CN MPBall) (CN b)+  mul a s = mul a (s ? (getPrecision a))++instance+  (CanMulAsymmetric b MPBall, CanGiveUpIfVeryInaccurate (MulType b MPBall))+  => +  CanMulAsymmetric (CSequence b) (CN MPBall)+  where+  type MulType (CSequence b) (CN MPBall) = MulType (CN b) (CN MPBall)+  mul s b = mul (s ? (getPrecision b)) b++instance+  (CanDiv MPBall b, CanTestZero b)+  => +  CanDiv MPBall (CSequence b)+  where+  type DivType MPBall (CSequence b) = DivType MPBall b+  divide a s = divide a (unCN $ s ? (getPrecision a))++instance+  (CanDiv b MPBall)+  => +  CanDiv (CSequence b) MPBall+  where+  type DivType (CSequence b) MPBall = DivType b MPBall+  divide s b = divide (unCN $ s ? (getPrecision b)) b++instance+  (CanDiv MPBall b, CanTestZero b)+  => +  CanDiv (CN MPBall) (CSequence b)+  where+  type DivType (CN MPBall) (CSequence b) = DivType (CN MPBall) (CN b)+  divide a s = divide a (s ? (getPrecision a))++instance+  (CanDiv b MPBall)+  => +  CanDiv (CSequence b) (CN MPBall)+  where+  type DivType (CSequence b) (CN MPBall) = DivType (CN b) (CN MPBall)+  divide s b = divide (s ? (getPrecision b)) b++---------------------------------------------------+---------------------------------------------------+-- Integer, Rational etc. mixed-type arithmetic+---------------------------------------------------+---------------------------------------------------+++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]+  (\ t -> [d|++    instance+      (CanAddAsymmetric a $t)+      => +      CanAddAsymmetric (CSequence a) $t+      where+      type AddType (CSequence a) $t = CSequence (AddType a $t)+      add = lift1T add++    instance+      (CanAddAsymmetric a $t)+      => +      CanAddAsymmetric (CSequence a) (CN $t)+      where+      type AddType (CSequence a) (CN $t) = CSequence (AddType a $t)+      add = lift1T add++    instance+      (CanAddAsymmetric $t a)+      => +      CanAddAsymmetric $t (CSequence a)+      where+      type AddType $t (CSequence a) = CSequence (AddType $t a)+      add = liftT1 add++    instance+      (CanAddAsymmetric $t a)+      => +      CanAddAsymmetric (CN $t) (CSequence a)+      where+      type AddType (CN $t) (CSequence a) = CSequence (AddType $t a)+      add = liftT1 add++    instance+      (CanSub a $t)+      => +      CanSub (CSequence a) $t+      where+      type SubType (CSequence a) $t = CSequence (SubType a $t)+      sub = lift1T sub++    instance+      (CanSub a $t)+      => +      CanSub (CSequence a) (CN $t)+      where+      type SubType (CSequence a) (CN $t) = CSequence (SubType a $t)+      sub = lift1T sub++    instance+      (CanSub $t a)+      => +      CanSub $t (CSequence a)+      where+      type SubType $t (CSequence a) = CSequence (SubType $t a)+      sub = liftT1 sub++    instance+      (CanSub $t a)+      => +      CanSub (CN $t) (CSequence a)+      where+      type SubType (CN $t) (CSequence a) = CSequence (SubType $t a)+      sub = liftT1 sub++    instance+      (CanMulAsymmetric a $t, CanGiveUpIfVeryInaccurate (MulType a $t))+      => +      CanMulAsymmetric (CSequence a) $t+      where+      type MulType (CSequence a) $t = CSequence (MulType a $t)+      mul = lift1T mul++    instance+      (CanMulAsymmetric a $t, CanGiveUpIfVeryInaccurate (MulType a $t))+      => +      CanMulAsymmetric (CSequence a) (CN $t)+      where+      type MulType (CSequence a) (CN $t) = CSequence (MulType a $t)+      mul = lift1T mul++    instance+      (CanMulAsymmetric $t a, CanGiveUpIfVeryInaccurate (MulType $t a))+      => +      CanMulAsymmetric $t (CSequence a)+      where+      type MulType $t (CSequence a) = CSequence (MulType $t a)+      mul = liftT1 mul++    instance+      (CanMulAsymmetric $t a, CanGiveUpIfVeryInaccurate (MulType $t a))+      => +      CanMulAsymmetric (CN $t) (CSequence a)+      where+      type MulType (CN $t) (CSequence a) = CSequence (MulType $t a)+      mul = liftT1 mul++    instance+      (CanDiv a $t)+      => +      CanDiv (CSequence a) $t+      where+      type DivType (CSequence a) $t = CSequence (DivType a $t)+      divide = lift1T divide++    instance+      (CanDiv a $t)+      => +      CanDiv (CSequence a) (CN $t)+      where+      type DivType (CSequence a) (CN $t) = CSequence (DivType a $t)+      divide = lift1T divide++    instance+      (CanDiv $t a, CanTestZero a)+      => +      CanDiv $t (CSequence a)+      where+      type DivType $t (CSequence a) = CSequence (DivType $t a)+      divide = liftT1 divide++    instance+      (CanDiv $t a, CanTestZero a)+      => +      CanDiv (CN $t) (CSequence a)+      where+      type DivType (CN $t) (CSequence a) = CSequence (DivType $t a)+      divide = liftT1 divide++  |]))++{- Prelude Num, Real, Fractional instance -}++instance+  P.Num CReal+  where+  fromInteger = convertExactly+  negate = negate+  (+) = (+)+  (*) = (*)+  abs = abs+  signum = error "Prelude.signum not implemented for Sequence"++instance+  P.Fractional CReal+  where+  fromRational = convertExactly+  recip = recip+  (/) = (/)
+ src/AERN2/Real/Limit.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-|+    Module      :  AERN2.Real.Limit+    Description :  limits of CReal sequences+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++    Limits of Cauchy Real sequences.+-}+module AERN2.Real.Limit where++import MixedTypesNumPrelude++-- import qualified Numeric.CollectErrors as CN++-- import Math.NumberTheory.Logarithms (integerLog2)++import AERN2.Real.Type+import AERN2.Limit+import AERN2.MP ( (+-) )++---------+-- limit+---------++instance HasLimits Rational CReal where+  type LimitType Rational CReal = CReal+  limit s = crealFromPrecFunction withPrec+    where+    withPrec p = ((s epsilon) ? p) +- epsilon+      where+      epsilon = 0.5 ^ (integer p)+    +instance HasLimits Integer CReal where+  type LimitType Integer CReal = CReal+  limit s = crealFromPrecFunction withPrec+    where+    withPrec p = ((s (integer p)) ? p) +- epsilon+      where+      epsilon = 0.5 ^ (integer p)++instance HasLimits Int CReal where+  type LimitType Int CReal = CReal+  limit s = limit (s . c)+    where+    c :: Integer -> Int+    c = int++instance HasLimits Rational (CReal -> CReal) where+  type LimitType Rational (CReal -> CReal) = (CReal -> CReal)+  limit fs x = crealFromPrecFunction withPrec+    where+    withPrec p = ((fs epsilon x) ? p) +- epsilon+      where+      epsilon = 0.5 ^ (integer p)
src/AERN2/Real/Tests.hs view
@@ -1,6 +1,7 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-|     Module      :  AERN2.Real.Tests-    Description :  Tests for operations on cauchy real numbers+    Description :  Tests for operations on Cauchy real numbers     Copyright   :  (c) Michal Konecny     License     :  BSD3 @@ -8,7 +9,7 @@     Stability   :  experimental     Portability :  portable -    Tests for operations on cauchy real numbers.+    Tests for operations on Cauchy real numbers.      To run the tests using stack, execute: @@ -16,10 +17,9 @@     stack test aern2-real --test-arguments "-a 1000 -m Real"     @ -}- module AERN2.Real.Tests   (-    specCauchyReal, tCauchyReal, tCauchyRealAtAccuracy+    -- specCauchyReal, tCReal   ) where @@ -28,6 +28,8 @@ -- import Data.Ratio -- import Text.Printf +import qualified Numeric.CollectErrors as CN+ import Test.Hspec import Test.QuickCheck -- import qualified Test.Hspec.SmallCheck as SC@@ -38,33 +40,21 @@ import AERN2.MP import AERN2.MP.Dyadic -import AERN2.QA.Protocol-import AERN2.AccuracySG- import AERN2.Real.Type--instance Arbitrary CauchyRealAtAccuracy where-  arbitrary =-    cauchyRealAtAccuracy <$>-      arbitrary <*>-      ((accuracySG . bits) <$> (arbitrarySmall 1000 :: Gen Integer))+import AERN2.Real.Field () -instance Arbitrary CauchyReal where+instance Arbitrary CReal where   arbitrary =     frequency-      [(int 1, real <$> (arbitrarySmall 1000000 :: Gen Integer)),-       (int 1, real <$> (arbitrarySmall 1000000 :: Gen Rational)),+      [(int 1, creal <$> (arbitrarySmall 1000000 :: Gen Integer)),+       (int 1, creal <$> (arbitrarySmall 1000000 :: Gen Rational)),        (int 2, (*) <$> (arbitrarySmall 1000000 :: Gen Integer) <*> arbitrarySignedBinary)       ]       where       arbitrarySignedBinary =         signedBinary2Real <$> infiniteListOf (elements [-1,0,1])       signedBinary2Real sbits =-        newCR "random" [] $ \ _ (AccuracySG _ acG) ->-          case acG of-            NoInformation -> balls !! 0-            Exact -> error "signedBinary2Real: cannot request the number Exactly"-            _ -> balls !! (fromAccuracy acG + 1)+        crealFromPrecFunction $ \ p -> cn $ balls !! p         where         balls = nextBit (mpBall (0,1)) $ zip sbits (map prec [10..])         nextBit ball ((sbit, p):rest) =@@ -72,17 +62,17 @@           where           newBall =             case sbit of-              (-1) -> fromEndpoints l m-              0 -> fromEndpoints l2 r2-              1 -> fromEndpoints m r-              _ -> error "in Arbitrary CauchyReal"-          (l_,r_) = endpoints ball :: (MPBall, MPBall)+              (-1) -> fromEndpointsAsIntervals l m+              0 -> fromEndpointsAsIntervals l2 r2+              1 -> fromEndpointsAsIntervals m r+              _ -> error "in Arbitrary CReal"+          (l_,r_) = endpointsAsIntervals ball           l = setPrecision p l_           r = setPrecision p r_           m = (l + r) * (dyadic 0.5)           l2 = (l + m) * (dyadic 0.5)           r2 = (r + m) * (dyadic 0.5)-        nextBit _ _ = error "in Arbitrary CauchyReal"+        nextBit _ _ = error "in Arbitrary CReal"  arbitrarySmall :: (Arbitrary a, HasOrderCertainly a Integer) => Integer -> Gen a arbitrarySmall limit = aux@@ -96,110 +86,101 @@   {-|-  A runtime representative of type @CauchyReal@.+  A runtime representative of type @CReal@.   Used for specialising polymorphic tests to concrete types. -}-tCauchyReal :: T CauchyReal-tCauchyReal = T "CauchyReal"+tCReal :: T CReal+tCReal = T "CReal" -tCauchyRealAtAccuracy :: T CauchyRealAtAccuracy-tCauchyRealAtAccuracy = T "CauchyReal(ac)"+-- tCauchyRealAtAccuracy :: T CauchyRealAtAccuracy+-- tCauchyRealAtAccuracy = T "CReal(ac)"  specCRrespectsAccuracy1 ::   String ->-  (CauchyReal -> CauchyReal) ->-  (CauchyReal -> AccuracySG -> Bool) ->-  Spec-specCRrespectsAccuracy1 opName op =-  specCRrespectsAccuracy1CN opName (\ a -> cn (op a))--specCRrespectsAccuracy1CN ::-  String ->-  (CauchyReal -> CauchyRealCN) ->-  (CauchyReal -> AccuracySG -> Bool) ->+  (CReal -> CReal) ->+  (CReal -> Accuracy -> Bool) ->   Spec-specCRrespectsAccuracy1CN opName op precond =+specCRrespectsAccuracy1 opName op precond =   it (opName ++ " respects accuracy requests") $ do     property $-      \ (x :: CauchyReal) (ac :: Accuracy) ->-        let acSG = accuracySG ac in-        ac < (bits 1000) && precond x acSG ==>-        case getMaybeValueCN ((op x) ? acSG) of-          Just v -> getAccuracy v >=$ ac+      \ (x :: CReal) (ac :: Accuracy) ->+        ac < (bits 1000) && precond x ac ==>+        case CN.toEither ((op x) ? ac) of+          Right v -> getAccuracy v >=$ ac           _ -> property True  (>=$) :: Accuracy -> Accuracy -> Property (>=$) = printArgsIfFails2 ">=" (>=) -precondAnyReal :: CauchyReal -> AccuracySG -> Bool+precondAnyReal :: CReal -> Accuracy -> Bool precondAnyReal _x _ac = True -precondPositiveReal :: CauchyReal -> AccuracySG -> Bool+precondPositiveReal :: CReal -> Accuracy -> Bool precondPositiveReal x ac = (x ? ac) !>! 0 -precondNonZeroReal :: CauchyReal -> AccuracySG -> Bool+precondNonZeroReal :: CReal -> Accuracy -> Bool precondNonZeroReal x ac = (x ? ac) !/=! 0 -precondSmallReal :: CauchyReal -> AccuracySG -> Bool+precondSmallReal :: CReal -> Accuracy -> Bool precondSmallReal x ac = abs (x ? ac) !<! 1000 -precondPositiveSmallReal :: CauchyReal -> AccuracySG -> Bool+precondPositiveSmallReal :: CReal -> Accuracy -> Bool precondPositiveSmallReal x ac = 0 !<! b && b !<! 1000   where b = x ? ac -specCRrespectsAccuracy2 ::-  String ->-  (CauchyReal -> CauchyReal -> CauchyReal) ->-  (CauchyReal -> AccuracySG -> Bool) ->-  (CauchyReal -> AccuracySG -> Bool) ->-  Spec-specCRrespectsAccuracy2 opName op =-  specCRrespectsAccuracy2CN opName (\ a b -> cn (op a b))+-- specCRrespectsAccuracy2 ::+--   String ->+--   (CReal -> CReal -> CReal) ->+--   (CReal -> Accuracy -> Bool) ->+--   (CReal -> Accuracy -> Bool) ->+--   Spec+-- specCRrespectsAccuracy2 opName op =+--   specCRrespectsAccuracy2CN opName (\ a b -> cn (op a b)) -specCRrespectsAccuracy2CN ::-  String ->-  (CauchyReal -> CauchyReal -> CauchyRealCN) ->-  (CauchyReal -> AccuracySG -> Bool) ->-  (CauchyReal -> AccuracySG -> Bool) ->-  Spec-specCRrespectsAccuracy2CN opName op precond1 precond2 =-  it (opName ++ " respects accuracy requests") $ do-    property $-      \ (x :: CauchyReal) (y :: CauchyReal) (ac :: Accuracy) ->-        let acSG = accuracySG ac in-        ac < (bits 1000) && precond1 x acSG && precond2 y acSG  ==>-        case getMaybeValueCN ((op x y) ? acSG) of-          Just v -> getAccuracy v >=$ ac-          _ -> property True+-- specCRrespectsAccuracy2CN ::+--   String ->+--   (CReal -> CReal -> CauchyRealCN) ->+--   (CReal -> Accuracy -> Bool) ->+--   (CReal -> Accuracy -> Bool) ->+--   Spec+-- specCRrespectsAccuracy2CN opName op precond1 precond2 =+--   it (opName ++ " respects accuracy requests") $ do+--     property $+--       \ (x :: CReal) (y :: CReal) (ac :: Accuracy) ->+--         let acSG = accuracySG ac in+--         ac < (bits 1000) && precond1 x acSG && precond2 y acSG  ==>+--         case getMaybeValueCN ((op x y) ? acSG) of+--           Just v -> getAccuracy v >=$ ac+          -- _ -> property True -specCRrespectsAccuracy2T ::-  (Arbitrary t, Show t) =>-  T t ->-  String ->-  (CauchyReal -> t -> CauchyReal) ->-  (CauchyReal -> AccuracySG -> Bool) ->-  (t -> Bool) ->-  Spec-specCRrespectsAccuracy2T tt opName op =-  specCRrespectsAccuracy2TCN tt opName (\ a b -> cn (op a b))+-- specCRrespectsAccuracy2T ::+--   (Arbitrary t, Show t) =>+--   T t ->+--   String ->+--   (CReal -> t -> CReal) ->+--   (CReal -> Accuracy -> Bool) ->+--   (t -> Bool) ->+--   Spec+-- specCRrespectsAccuracy2T tt opName op =+--   specCRrespectsAccuracy2TCN tt opName (\ a b -> cn (op a b)) -specCRrespectsAccuracy2TCN ::-  (Arbitrary t, Show t) =>-  T t ->-  String ->-  (CauchyReal -> t -> CauchyRealCN) ->-  (CauchyReal -> AccuracySG -> Bool) ->-  (t -> Bool) ->-  Spec-specCRrespectsAccuracy2TCN (T tName :: T t) opName op precond1 precond2 =-  it (opName ++ " with " ++ tName ++ " respects accuracy requests") $ do-    property $-      \ (x :: CauchyReal) (t :: t) (ac :: Accuracy) ->-        let acSG = accuracySG ac in-        ac < (bits 1000) && precond1 x acSG && precond2 t  ==>-        case getMaybeValueCN ((op x t) ? acSG) of-          Just v -> getAccuracy v >=$ ac-          _ -> property True+-- specCRrespectsAccuracy2TCN ::+--   (Arbitrary t, Show t) =>+--   T t ->+--   String ->+--   (CReal -> t -> CauchyRealCN) ->+--   (CReal -> Accuracy -> Bool) ->+--   (t -> Bool) ->+--   Spec+-- specCRrespectsAccuracy2TCN (T tName :: T t) opName op precond1 precond2 =+--   it (opName ++ " with " ++ tName ++ " respects accuracy requests") $ do+--     property $+--       \ (x :: CReal) (t :: t) (ac :: Accuracy) ->+--         let acSG = accuracySG ac in+--         ac < (bits 1000) && precond1 x acSG && precond2 t  ==>+--         case getMaybeValueCN ((op x t) ? acSG) of+--           Just v -> getAccuracy v >=$ ac+--           _ -> property True  precondAnyT :: t -> Bool precondAnyT _t = True@@ -210,46 +191,46 @@ precondSmallT :: (HasOrderCertainly t Integer) => t -> Bool precondSmallT t = -1000 !<=! t && t !<=! 1000 -specCauchyReal :: Spec-specCauchyReal =-  describe ("CauchyReal") $ do-    -- specConversion tInteger tCauchyReal real (fst . integerBounds)-    describe "order" $ do-      specHasEqNotMixed tCauchyRealAtAccuracy-      -- specHasEq tInt tCauchyRealAtAccuracy tRational-      -- specCanPickNonZero tCauchyRealAtAccuracy-      specHasOrderNotMixed tCauchyRealAtAccuracy-      -- specHasOrder tInt tCauchyRealAtAccuracy tRational-    describe "min/max/abs" $ do-      specCRrespectsAccuracy1 "abs" abs precondAnyReal-      specCRrespectsAccuracy2 "max" max precondAnyReal precondAnyReal-      specCRrespectsAccuracy2 "min" min precondAnyReal precondAnyReal-    describe "ring" $ do-      specCRrespectsAccuracy1 "negate" negate precondAnyReal-      specCRrespectsAccuracy2 "+" add precondAnyReal precondAnyReal-      specCRrespectsAccuracy2T tInteger "+" add precondAnyReal precondAnyT-      specCRrespectsAccuracy2T tRational "+" add precondAnyReal precondAnyT-      specCRrespectsAccuracy2T tDyadic "+" add precondAnyReal precondAnyT-      specCRrespectsAccuracy2 "a-b" sub precondAnyReal precondAnyReal-      specCRrespectsAccuracy2T tInteger "a-b" sub precondAnyReal precondAnyT-      specCRrespectsAccuracy2T tRational "a-b" sub precondAnyReal precondAnyT-      specCRrespectsAccuracy2T tDyadic "a-b" sub precondAnyReal precondAnyT-      specCRrespectsAccuracy2 "*" mul precondAnyReal precondAnyReal-      specCRrespectsAccuracy2T tInteger "*" mul precondAnyReal precondAnyT-      specCRrespectsAccuracy2T tRational "*" mul precondAnyReal precondAnyT-      specCRrespectsAccuracy2T tDyadic "*" mul precondAnyReal precondAnyT-    describe "field" $ do-      specCRrespectsAccuracy2CN "/" divide precondAnyReal precondNonZeroReal-      specCRrespectsAccuracy2TCN tInteger "/" divide precondAnyReal precondNonZeroT-      specCRrespectsAccuracy2TCN tRational "/" divide precondAnyReal precondNonZeroT-      specCRrespectsAccuracy2TCN tDyadic "/" divide precondAnyReal precondNonZeroT-    describe "elementary" $ do-      specCRrespectsAccuracy1CN "sqrt" sqrt precondPositiveReal-      specCRrespectsAccuracy1 "exp" exp precondSmallReal-      specCRrespectsAccuracy1CN "log" log precondPositiveSmallReal-      specCRrespectsAccuracy2CN "pow" pow precondPositiveSmallReal precondSmallReal-      specCRrespectsAccuracy2TCN tInteger "pow" pow precondNonZeroReal precondSmallT-      specCRrespectsAccuracy2TCN tRational "pow" pow precondPositiveSmallReal precondSmallT-      specCRrespectsAccuracy2TCN tDyadic "pow" pow precondPositiveSmallReal precondSmallT-      specCRrespectsAccuracy1 "cos" cos precondAnyReal-      specCRrespectsAccuracy1 "sine" sin precondAnyReal+-- specCauchyReal :: Spec+-- specCauchyReal =+--   describe ("CReal") $ do+--     -- specConversion tInteger tCauchyReal real (fst . integerBounds)+--     describe "order" $ do+--       specHasEqNotMixed tCReal+--       -- specHasEq tInt tCReal tRational+--       -- specCanPickNonZero tCReal+--       specHasOrderNotMixed tCReal+--       -- specHasOrder tInt tCReal tRational+    -- describe "min/max/abs" $ do+    --   specCRrespectsAccuracy1 "abs" abs precondAnyReal+    --   specCRrespectsAccuracy2 "max" max precondAnyReal precondAnyReal+    --   specCRrespectsAccuracy2 "min" min precondAnyReal precondAnyReal+    -- describe "ring" $ do+    --   specCRrespectsAccuracy1 "negate" negate precondAnyReal+    --   specCRrespectsAccuracy2 "+" add precondAnyReal precondAnyReal+    --   specCRrespectsAccuracy2T tInteger "+" add precondAnyReal precondAnyT+    --   specCRrespectsAccuracy2T tRational "+" add precondAnyReal precondAnyT+    --   specCRrespectsAccuracy2T tDyadic "+" add precondAnyReal precondAnyT+    --   specCRrespectsAccuracy2 "a-b" sub precondAnyReal precondAnyReal+    --   specCRrespectsAccuracy2T tInteger "a-b" sub precondAnyReal precondAnyT+    --   specCRrespectsAccuracy2T tRational "a-b" sub precondAnyReal precondAnyT+    --   specCRrespectsAccuracy2T tDyadic "a-b" sub precondAnyReal precondAnyT+    --   specCRrespectsAccuracy2 "*" mul precondAnyReal precondAnyReal+    --   specCRrespectsAccuracy2T tInteger "*" mul precondAnyReal precondAnyT+    --   specCRrespectsAccuracy2T tRational "*" mul precondAnyReal precondAnyT+    --   specCRrespectsAccuracy2T tDyadic "*" mul precondAnyReal precondAnyT+    -- describe "field" $ do+    --   specCRrespectsAccuracy2CN "/" divide precondAnyReal precondNonZeroReal+    --   specCRrespectsAccuracy2TCN tInteger "/" divide precondAnyReal precondNonZeroT+    --   specCRrespectsAccuracy2TCN tRational "/" divide precondAnyReal precondNonZeroT+    --   specCRrespectsAccuracy2TCN tDyadic "/" divide precondAnyReal precondNonZeroT+    -- describe "elementary" $ do+    --   specCRrespectsAccuracy1CN "sqrt" sqrt precondPositiveReal+    --   specCRrespectsAccuracy1 "exp" exp precondSmallReal+    --   specCRrespectsAccuracy1CN "log" log precondPositiveSmallReal+    --   specCRrespectsAccuracy2CN "pow" pow precondPositiveSmallReal precondSmallReal+    --   specCRrespectsAccuracy2TCN tInteger "pow" pow precondNonZeroReal precondSmallT+    --   specCRrespectsAccuracy2TCN tRational "pow" pow precondPositiveSmallReal precondSmallT+    --   specCRrespectsAccuracy2TCN tDyadic "pow" pow precondPositiveSmallReal precondSmallT+    --   specCRrespectsAccuracy1 "cos" cos precondAnyReal+    --   specCRrespectsAccuracy1 "sine" sin precondAnyReal
src/AERN2/Real/Type.hs view
@@ -1,3 +1,7 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-|     Module      :  AERN2.Real.Type     Description :  The type of Cauchy real numbers@@ -10,123 +14,143 @@      The type of Cauchy real numbers -}-module AERN2.Real.Type-(-  CauchyRealP, pCR, CauchyRealCNP, pCRCN-  , CauchyRealA, CauchyReal, newCR-  , CauchyRealCNA, CauchyRealCN, newCRCN-  , CauchyRealAtAccuracy, cauchyRealAtAccuracy-  , realName, realId, realSources, realRename-  , realWithAccuracy, realWithAccuracyA, realsWithAccuracyA-  , convergentList2CauchyRealA-  , seqByPrecision2CauchyRealA-  , CanBeReal, real, CanBeRealA, realA-  , CanBeComplex, complex, CanBeComplexA, complexA-)-where+module AERN2.Real.Type where  import MixedTypesNumPrelude -- import qualified Prelude as P --- import qualified Control.CollectErrors as CE-import Control.Arrow--- import Text.Printf+import qualified Numeric.CollectErrors as CN -import Data.Complex+import qualified Data.List as List  import AERN2.MP+import AERN2.MP.Dyadic -import AERN2.QA.Protocol-import AERN2.QA.Strategy.CachedUnsafe ()+import AERN2.MP.WithCurrentPrec+import GHC.TypeNats -import AERN2.AccuracySG+-- import AERN2.MP.Accuracy -import AERN2.Sequence+{- Convergent partial sequences -} -{- Cauchy real numbers -}+newtype CSequence t = CSequence [CN t] -type CauchyRealP = SequenceP MPBall-type CauchyRealCNP = SequenceP (CN MPBall)+instance Show t => Show (CSequence t) where+  show (CSequence s) = +    "{?(prec " <> (show $ integer p) <> "): " +    <> (show $ s !! cseqShowDefaultIndex) <> "}"+    where+    p = cseqPrecisions !! cseqShowDefaultIndex -pCR :: CauchyRealP-pCR = SequenceP (mpBall 0)+cseqShowDefaultIndex :: Integer+cseqShowDefaultIndex = 7 -pCRCN :: CauchyRealCNP-pCRCN = SequenceP (cn $ mpBall 0)+lift1 :: (CN t1 -> CN t2) -> CSequence t1 -> CSequence t2+lift1 f (CSequence a1) = CSequence (map f a1) -type CauchyRealA to = SequenceA to MPBall-type CauchyReal = CauchyRealA (->)+lift2 :: (CN t1 -> CN t2 -> CN t3) -> CSequence t1 -> CSequence t2 -> CSequence t3+lift2 f (CSequence a1) (CSequence a2) = CSequence (zipWith f a1 a2) -type CauchyRealCNA to = SequenceA to (CN MPBall)-type CauchyRealCN = CauchyRealCNA (->)+lift1T :: (CN t1 -> t2 -> CN t3) -> CSequence t1 -> t2 -> CSequence t3+lift1T f (CSequence a1) a2 = CSequence (map (flip f a2) a1) -type CauchyRealAtAccuracy = SequenceAtAccuracy MPBall-cauchyRealAtAccuracy :: CauchyReal -> AccuracySG -> CauchyRealAtAccuracy-cauchyRealAtAccuracy = SequenceAtAccuracy+liftT1 :: (t1 -> CN t2 -> CN t3) -> t1 -> CSequence t2 -> CSequence t3+liftT1 f a1 (CSequence a2) = CSequence (map (f a1) a2) -realName :: SequenceA to a -> String-realName = seqName+cseqPrecisions :: [Precision]+cseqPrecisions = standardPrecisions (prec 10) -realRename :: (String -> String) -> SequenceA to a -> SequenceA to a-realRename = seqRename+cseqIndexForPrecision :: Precision -> Integer+cseqIndexForPrecision p =+  case List.findIndex (>= p) cseqPrecisions of+    Nothing -> error $ "unable to find index for precision " ++ show p+    Just i -> integer i -realId :: QA to p -> Maybe (QAId to)-realId = qaId+cseqFromPrecFunction :: (Precision -> CN b) -> CSequence b+cseqFromPrecFunction withP = CSequence $ map withP cseqPrecisions -realSources :: QA to p -> [QAId to]-realSources = qaSources+cseqFromWithCurrentPrec :: (forall p. (KnownNat p) => WithCurrentPrec (CN b) p) -> CSequence b+cseqFromWithCurrentPrec (withCurrentP :: (forall p. (KnownNat p) => WithCurrentPrec (CN b) p)) = +  CSequence $ map withP cseqPrecisions+  where+  withP p = runWithPrec p withCurrentP :: CN b -{-| Get a ball approximation of the real number with at least the specified accuracy.-   (A specialisation of 'qaMakeQuery' for Cauchy reals.) -}-realWithAccuracy :: (QAArrow to) => CauchyRealA to -> AccuracySG `to` MPBall-realWithAccuracy = (?)+crealFromWithCurrentPrec :: (forall p. (KnownNat p) => WithCurrentPrec (CN MPBall) p) -> CReal+crealFromWithCurrentPrec = cseqFromWithCurrentPrec -realWithAccuracyA :: (QAArrow to) => (Maybe (QAId to)) -> (CauchyRealA to, AccuracySG) `to` MPBall-realWithAccuracyA = qaMakeQueryA+{- Cauchy real numbers -} -realsWithAccuracyA :: (QAArrow to) => (Maybe (QAId to)) -> ([CauchyRealA to], AccuracySG) `to` [MPBall]-realsWithAccuracyA = qaMakeQueryOnManyA+type CReal = CSequence MPBall -{- constructions -}+type HasCReals t = ConvertibleExactly CReal t -newCR :: (QAArrow to) => String -> [AnyProtocolQA to] -> ((Maybe (QAId to), Maybe (QAId to)) -> AccuracySG `to` MPBall) -> CauchyRealA to-newCR = newSeq (mpBall 0)+type CanBeCReal t = ConvertibleExactly t CReal -newCRCN :: (QAArrow to) => String -> [AnyProtocolQA to] -> ((Maybe (QAId to), Maybe (QAId to)) -> AccuracySG `to` CN MPBall) -> CauchyRealCNA to-newCRCN = newSeq (cn $ mpBall 0)+creal :: (CanBeCReal t) => t -> CReal+creal = convertExactly -convergentList2CauchyRealA :: (QAArrow to) => String -> [MPBall] -> (CauchyRealA to)-convergentList2CauchyRealA = convergentList2SequenceA+crealFromPrecFunction :: (Precision -> CN MPBall) -> CReal+crealFromPrecFunction = cseqFromPrecFunction -seqByPrecision2CauchyRealA :: (QAArrow to) => String -> (Precision -> MPBall) -> (CauchyRealA to)-seqByPrecision2CauchyRealA = seqByPrecision2SequenceA+{- Extracting approximations -} -{- conversions -}+class CanExtractApproximation e q where+  type ExtractedApproximation e q+  {-| Get an approximation of an exact value using the given query -}+  extractApproximation :: e {-^ exact value -} -> q {-^ query -} -> ExtractedApproximation e q -type CanBeRealA to t = ConvertibleExactly t (CauchyRealA to)-type CanBeReal t = CanBeRealA (->) t+infix 1 ? -real :: (CanBeRealA (->) t) => t -> CauchyReal-real = convertExactly+(?) :: CanExtractApproximation e q => e -> q -> ExtractedApproximation e q+(?) = extractApproximation -realA :: (CanBeRealA to t) => t -> CauchyRealA to-realA = convertExactly+instance (HasAccuracy t) => CanExtractApproximation (CSequence t) Accuracy where+  type ExtractedApproximation (CSequence t) Accuracy = CN t+  extractApproximation (CSequence s) ac = aux s+    where+    aux (bCN : rest) +      | CN.hasCertainError bCN = bCN+      | getAccuracy bCN >= ac = bCN+      | otherwise = aux rest+    aux [] =+        CN.noValueNumErrorPotential $ +          CN.NumError "failed to find an approximation with sufficient accuracy"+  +{-| Get a ball approximation of the real number with at least the specified accuracy -}+realWithAccuracy :: CReal -> Accuracy -> CN MPBall+realWithAccuracy = extractApproximation -type CanBeComplexA to t = ConvertibleExactly t (Complex (CauchyRealA to))-type CanBeComplex t = CanBeComplexA (->) t+instance CanExtractApproximation (CSequence t) Precision where+  type ExtractedApproximation (CSequence t) Precision = CN t+  extractApproximation (CSequence s) p =+    s !! (cseqIndexForPrecision p) -complex :: (CanBeComplexA (->) t) => t -> Complex CauchyReal-complex = convertExactly+instance ConvertibleWithPrecision CReal (CN MPBall) where+  safeConvertP p r = Right $ r ? p -complexA :: (CanBeComplexA to t) => t -> Complex (CauchyRealA to)-complexA = convertExactly+-- {- exact conversions -} --- instance (QAArrow to) => ConvertibleExactly Rational (CauchyRealA to) where---   safeConvertExactly x =---     Right $ newCR (show x) [] (\me_src -> arr (makeQ me_src))---     where---     makeQ _ = seqByPrecision2CauchySeq (flip mpBallP x) . bits+instance ConvertibleExactly CReal CReal where+  safeConvertExactly = Right -instance ConvertibleWithPrecision CauchyReal MPBall where-  safeConvertP p r =-    Right $ setPrecision p $ r ? (accuracySG $ bits p + 10)+instance ConvertibleExactly Rational CReal where+  safeConvertExactly x =+    Right $ crealFromPrecFunction (cn . flip mpBallP x)++instance ConvertibleExactly Integer CReal where+  safeConvertExactly = safeConvertExactly . rational++instance ConvertibleExactly Int CReal where+  safeConvertExactly = safeConvertExactly . rational++instance ConvertibleExactly Dyadic CReal where+  safeConvertExactly = safeConvertExactly . rational++_example1 :: CReal+_example1 = creal 1.0++_example2 :: CN MPBall+_example2 = (creal $ 1/3) ? (bits 100)++_example3 :: CN MPBall+_example3 = convertP (prec 100) (creal $ 1/3)
− src/AERN2/Sequence.hs 
@@ -1,67 +0,0 @@-{-|-    Module      :  AERN2.Sequence-    Description :  fast convergent sequences-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    A type of fast convergent sequences parametrised by the arrow in which the elements of the-    sequence are queried--}-module AERN2.Sequence-(-  module AERN2.AccuracySG-  -- * The protocol and type of fast converging sequences-  , SequenceP(..), pSeq-  , SuitableForSeq-  , SequenceA, Sequence, newSeq, newSeqSimple-  , fmapSeq-  , seqName, seqId, seqSources, seqRename-  , seqWithAccuracy, (?), seqWithAccuracyA, seqsWithAccuracyA-  , (-:-), (-:-||), (-:-|)-  , SequenceAtAccuracy(..)-  , convergentList2SequenceA-  , seqByPrecision2SequenceA-  -- * selecting one of several staged computations-  , pick-  -- * auxiliary functions for making new sequence operations-  , unaryOp, binaryOp, binaryOpWithPureArg-  , getSeqFnNormLog-  , getInitQ1FromSimple, getInitQ1TFromSimple, getInitQ1Q2FromSimple-  -- , binaryWithBall-)-where--import MixedTypesNumPrelude--- import qualified Prelude as P---- import Control.Arrow---- import AERN2.Norm--- import AERN2.MP.Precision--import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Sequence.Type-import AERN2.Sequence.Helpers-import AERN2.Sequence.Comparison-import AERN2.Sequence.Branching-import AERN2.Sequence.Ring ()-import AERN2.Sequence.Field ()-import AERN2.Sequence.Elementary ()-import AERN2.Sequence.PreludeOps ()---- instance---   (QAArrow to---   , OrderedRing a---   , SuitableForSeq a---   , SuitableForSeq (EqCompareType a a)---   , SuitableForSeq (EqCompareType a Int)---   , SuitableForSeq (EqCompareType a Integer)---   , HasNorm (EnsureNoCN a)---   , CanSetPrecision a, CanSetPrecision (EnsureCN a))---   =>---   Ring (SequenceA to a)
− src/AERN2/Sequence/Branching.hs 
@@ -1,161 +0,0 @@-{-|-    Module      :  AERN2.Sequence.Branching-    Description :  branching operations for sequences-    Copyright   :  (c) Michal Konecny, Eike Neumann-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Branching operations for sequences--}-module AERN2.Sequence.Branching-(-  SeqBoolP, SeqBoolA, SeqBool, pBool-  , SequenceAtAccuracy(..)-  , pickNonZeroSeqA, pick-)-where--import MixedTypesNumPrelude hiding (id)--- import qualified Prelude as P--import Control.Arrow--import Data.Maybe (catMaybes)--import AERN2.MP--import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Sequence.Type--- import AERN2.Sequence.Helpers (ensureAccuracyA)-import AERN2.Sequence.Comparison--{- non-zero picking -}--{-|-  Given a list @[(a1,b1),(a2,b2),...]@ and assuming that-  at least one of @a1,a2,...@ is non-zero, pick one of them-  and return the corresponding pair @(ai,bi)@.--  If none of @a1,a2,...@ is zero, either throw an exception-  or loop forever.- -}-pickNonZeroSeqA ::-  (QAArrow to, CanPickNonZero a)-  =>-  Maybe (QAId to) ->-  [(SequenceA to a, s)] `to` Maybe (SequenceA to a, s)-pickNonZeroSeqA src =-  startFromAccuracy (bits 0)-  where-  startFromAccuracy ac =-    proc seqsAndS -> do-      balls <- seqsWithAccuracyA src -< (map fst seqsAndS, accuracySG ac)-      let maybeNonZero = pickNonZero $ zip balls seqsAndS-      case maybeNonZero of-        Just (_,result) -> returnA -< Just result-        _ -> startFromAccuracy (ac + 1) -< seqsAndS--instance (CanPickNonZero a) => CanPickNonZero (Sequence a) where-  pickNonZero = pickNonZeroSeqA Nothing--{-| "parallel if" -}-instance-  (QAArrow to, ArrowApply to-  , HasIfThenElse b t-  , HasIfThenElse b (to AccuracySG t)-  , IfThenElseType b (to AccuracySG t) ~ to AccuracySG (IfThenElseType b t)-  , SuitableForSeq b, SuitableForSeq t, SuitableForSeq (IfThenElseType b t))-  =>-  HasIfThenElse (SequenceA to b) (SequenceA to t)-  where-  type IfThenElseType (SequenceA to b) (SequenceA to t) = (SequenceA to (IfThenElseType b t))-  ifThenElse (b::SequenceA to b) (e1::SequenceA to t) e2 =-    newSeq sampleT "pif" [AnyProtocolQA b, AnyProtocolQA e1, AnyProtocolQA e2] makeQ-    where-    sampleT = undefined :: (IfThenElseType b t)-    makeQ (me,_src) =-      proc ac ->-        do-        bAC <- (-?<-) me -< (b, ac)-        app -< (if bAC then (e1 ?<- me) else (e2 ?<- me), (ac+1))---- -- "parallel if" for lists of sequences:--- instance---   (QAArrow to, ArrowApply to---   , HasIfThenElse b t---   , HasIfThenElse b (to AccuracySG t)---   -- , IfThenElseType b (to AccuracySG t) ~ to AccuracySG (IfThenElseType b t)---   , IfThenElseType b (([Maybe (QAId to)], [t])) ~ (([Maybe (QAId to)], [IfThenElseType b t]))---   , IfThenElseType b (to AccuracySG ([Maybe (QAId to)], [t])) ~ to AccuracySG (IfThenElseType b ([Maybe (QAId to)], [t]))---   , SuitableForSeq b, SuitableForSeq t, SuitableForSeq (IfThenElseType b t))---   =>---   HasIfThenElse (SequenceA to b) [(SequenceA to t)]---   where---   type IfThenElseType (SequenceA to b) [(SequenceA to t)] = () `to` [(SequenceA to (IfThenElseType b t))]---   ifThenElse (b::SequenceA to b) (e1::[SequenceA to t]) e2 =---     sequence2list $---       newSeq sampleT "pifList" [AnyProtocolQA b] makeQ---       where---       sampleT = undefined :: ([Maybe (QAId to)], [IfThenElseType b t])---       makeQ (me,_src) =---         proc ac ->---           do---           bAC <- (-?-) -< (b, ac)---           let eS = if bAC---                       then (list2sequence e1 ?<- me)---                       else (list2sequence e2 ?<- me)---           app -< (eS, (ac+1))------ list2sequence ::---   (QAArrow to, SuitableForSeq ([Maybe (QAId to)], [t]))---   =>---   [SequenceA to t] -> SequenceA to ([Maybe (QAId to)], [t])--- list2sequence (list :: [SequenceA to t]) =---   newSeq sampleT "list" [] makeQ---   where---   sampleT = undefined :: ([Maybe (QAId to)], [t])---   makeQ (me,_src) =---     proc ac ->---       do---       ts <- qaMakeQueryOnManyA me -< (list,ac)---       returnA -< (map seqId list, ts)------ sequence2list ::---   (QAArrow to, SuitableForSeq t)---   =>---   SequenceA to ([Maybe (QAId to)], [t]) -> () `to` [SequenceA to t]--- sequence2list (s :: SequenceA to ([Maybe (QAId to)], [t])) =---   proc () ->---     do---     (sources, _) <- (-?-) -< (s, acSG0)---     returnA -< (map forSource $ zip [0..] sources)---   where---   forSource (i,_src) =---     -- newSeq sampleT "list" [AnyProtocolQA src] makeQ---     newSeq sampleT "list" [] makeQ---     where---     sampleT = undefined :: t---     makeQ (me, _src) =---       proc ac ->---         do---         (_, ts) <- (-?<-) me -< (s, ac)---         returnA -< ts !! i--pick ::-  (QAArrow to)-  =>-  (Maybe (QAId to)) ->-  [(SequenceA to (Maybe a))] `to` a-pick src = aux (bitsS 0)-  where-  aux ac =-    proc options ->-      do-      mas <- qaMakeQueryOnManyA src -< (options, ac)-      case catMaybes mas of-        [] -> aux (ac + 1) -< options-        (a : _) -> returnA -< a
− src/AERN2/Sequence/Comparison.hs 
@@ -1,360 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.Sequence.Comparison-    Description :  comparison operations on sequences-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Comparison operations on convergent sequences.--}-module AERN2.Sequence.Comparison-(-  SeqBoolP, SeqBoolA, SeqBool, pBool-  , SequenceAtAccuracy(..)-)-where--import MixedTypesNumPrelude hiding (id)--- import qualified Prelude as P--import Control.Category (id)-import Control.Arrow--import Control.CollectErrors--import AERN2.MP.Ball-import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Sequence.Type-import AERN2.Sequence.Helpers--{- "Sequenced/Staged" Boolean -}--type SeqBoolP = SequenceP (Maybe Bool)--pBool :: SeqBoolP-pBool = SequenceP Nothing--type SeqBoolA to = SequenceA to (Maybe Bool)-type SeqBool = SeqBoolA (->)--{- Boolean ops on sequences -}--instance (QAArrow to, HasBools b, SuitableForSeq b) => ConvertibleExactly Bool (SequenceA to b) where-  safeConvertExactly bool =-    do-    b <- safeConvertExactly bool-    Right $ newSeq b (show b) [] $ \_me_src -> arr $ const b--instance-  (QAArrow to, CanNeg a, SuitableForSeq a, SuitableForSeq (NegType a))-  =>-  CanNeg (SequenceA to a)-  where-  type NegType (SequenceA to a) = SequenceA to (NegType a)-  negate = unaryOp "neg" negate (getInitQ1FromSimple $ arr id)--instance-  (QAArrow to, CanAndOrAsymmetric a b-  , SuitableForSeq a, SuitableForSeq b, SuitableForSeq (AndOrType a b))-  =>-  CanAndOrAsymmetric (SequenceA to a) (SequenceA to b)-  where-  type AndOrType (SequenceA to a) (SequenceA to b) = SequenceA to (AndOrType a b)-  and2 = binaryOp "and" and2 (getInitQ1Q2FromSimple $ arr $ \q -> (q,q))-  or2 = binaryOp "or" or2 (getInitQ1Q2FromSimple $ arr $ \q -> (q,q))--{- equality & order -}--instance-  (QAArrow to, HasEqAsymmetric a b-  , SuitableForSeq a, SuitableForSeq b, SuitableForSeq (EqCompareType a b))-  =>-  HasEqAsymmetric (SequenceA to a) (SequenceA to b)-  where-  type EqCompareType (SequenceA to a) (SequenceA to b) = SequenceA to (EqCompareType a b)-  equalTo = lift2 "==" (==)-  notEqualTo = lift2 "/=" (/=)--instance-  (QAArrow to, HasOrderAsymmetric a b-  , SuitableForSeq a, SuitableForSeq b, SuitableForSeq (OrderCompareType a b))-  =>-  HasOrderAsymmetric (SequenceA to a) (SequenceA to b)-  where-  type OrderCompareType (SequenceA to a) (SequenceA to b) = SequenceA to (OrderCompareType a b)-  lessThan = lift2 "<" (<)-  leq = lift2 "<=" (<=)-  greaterThan = lift2 ">" (>)-  geq = lift2 ">=" (>=)--{- comparing CollectErrors and Sequences -}--instance-  (HasEqAsymmetric (SequenceA to a) b-  , CanEnsureCE es b-  , CanEnsureCE es (EqCompareType (SequenceA to a) b)-  , IsBool (EnsureCE es (EqCompareType (SequenceA to a) b))-  , SuitableForCE es)-  =>-  HasEqAsymmetric (SequenceA to a) (CollectErrors es b)-  where-  type EqCompareType (SequenceA to a) (CollectErrors es b) =-    EnsureCE es (EqCompareType (SequenceA to a) b)-  equalTo = lift2TLCE equalTo--instance-  (HasEqAsymmetric a (SequenceA to b)-  , CanEnsureCE es a-  , CanEnsureCE es (EqCompareType a (SequenceA to b))-  , IsBool (EnsureCE es (EqCompareType a (SequenceA to b)))-  , SuitableForCE es)-  =>-  HasEqAsymmetric (CollectErrors es a) (SequenceA to b)-  where-  type EqCompareType (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (EqCompareType a (SequenceA to b))-  equalTo = lift2TCE equalTo--instance-  (HasOrderAsymmetric (SequenceA to a) b-  , CanEnsureCE es b-  , CanEnsureCE es (OrderCompareType (SequenceA to a) b)-  , IsBool (EnsureCE es (OrderCompareType (SequenceA to a) b))-  , SuitableForCE es)-  =>-  HasOrderAsymmetric (SequenceA to a) (CollectErrors es  b)-  where-  type OrderCompareType (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (OrderCompareType (SequenceA to a) b)-  lessThan = lift2TLCE lessThan-  leq = lift2TLCE leq-  greaterThan = lift2TLCE greaterThan-  geq = lift2TLCE geq--instance-  (HasOrderAsymmetric a (SequenceA to b)-  , CanEnsureCE es a-  , CanEnsureCE es (OrderCompareType a (SequenceA to b))-  , IsBool (EnsureCE es (OrderCompareType a (SequenceA to b)))-  , SuitableForCE es)-  =>-  HasOrderAsymmetric (CollectErrors es a) (SequenceA to b)-  where-  type OrderCompareType (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (OrderCompareType a (SequenceA to b))-  lessThan = lift2TCE lessThan-  leq = lift2TCE leq-  greaterThan = lift2TCE greaterThan-  geq = lift2TCE geq---{- comparisons of SequenceAtAccuracy -}--{-| SequenceAtAccuracy exists only so that we can QuickCheck that-   Sequence satisfies properties whose statement relies on an instance of HasEqCertainly.-   Sequence is not an instance but SequenceAtAccuracy is.--}-data SequenceAtAccuracy a = SequenceAtAccuracy (Sequence a) AccuracySG-  deriving (Show)--instance-  (HasEqAsymmetric a b, SuitableForSeq a, SuitableForSeq b, SuitableForSeq (EqCompareType a b))-  =>-  HasEqAsymmetric (SequenceAtAccuracy a) (SequenceAtAccuracy b)-  where-  type EqCompareType (SequenceAtAccuracy a) (SequenceAtAccuracy b) = EqCompareType a b-  equalTo = delift2 (==)--instance-  (HasOrderAsymmetric a b, SuitableForSeq a, SuitableForSeq b, SuitableForSeq (OrderCompareType a b))-  =>-  HasOrderAsymmetric (SequenceAtAccuracy a) (SequenceAtAccuracy b)-  where-  type OrderCompareType (SequenceAtAccuracy a) (SequenceAtAccuracy b) = OrderCompareType a b-  lessThan = delift2 (<)-  leq = delift2 (<=)-  greaterThan = delift2 (>)-  geq = delift2 (>=)----delift2 ::-  (Sequence a -> Sequence b -> Sequence c) ->-  SequenceAtAccuracy a -> SequenceAtAccuracy b -> c-delift2 rel (SequenceAtAccuracy x1 ac1) (SequenceAtAccuracy x2 ac2) =-  (rel x1 x2) ? (max ac1 ac2)--{- abs -}--instance-  (QAArrow to, CanAbs a, SuitableForSeq a, SuitableForSeq (AbsType a))-  =>-  CanAbs (SequenceA to a)-  where-  type AbsType (SequenceA to a) = SequenceA to (AbsType a)-  abs = unaryOp "abs" abs (getInitQ1FromSimple $ arr id)--{- min/max -}--instance-  (QAArrow to-  , CanMinMaxAsymmetric a b, SuitableForSeq a, SuitableForSeq b, SuitableForSeq (MinMaxType a b))-  =>-  CanMinMaxAsymmetric (SequenceA to a) (SequenceA to b)-  where-  type MinMaxType (SequenceA to a) (SequenceA to b) = SequenceA to (MinMaxType a b)-  min = lift2 "min" min-  max = lift2 "max" max---instance-  (CanMinMaxAsymmetric a MPBall, SuitableForSeq a-  , CanSetPrecision (MinMaxType a MPBall))-  =>-  CanMinMaxAsymmetric (Sequence a) MPBall-  where-  type MinMaxType (Sequence a) MPBall = MinMaxType a MPBall-  min = binaryWithEncl min-  max = binaryWithEncl max----instance-  (CanMinMaxAsymmetric MPBall b, SuitableForSeq b-  , CanSetPrecision (MinMaxType MPBall b))-  =>-  CanMinMaxAsymmetric MPBall (Sequence b)-  where-  type MinMaxType MPBall (Sequence b) = MinMaxType MPBall b-  min = flip $ binaryWithEncl (flip min)-  max = flip $ binaryWithEncl (flip max)--instance-  (CanMinMaxAsymmetric (SequenceA to a) b-  , CanEnsureCE es b-  , CanEnsureCE es (MinMaxType (SequenceA to a) b)-  , SuitableForCE es)-  =>-  CanMinMaxAsymmetric (SequenceA to a) (CollectErrors es  b)-  where-  type MinMaxType (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (MinMaxType (SequenceA to a) b)-  min = lift2TLCE min-  max = lift2TLCE max--instance-  (CanMinMaxAsymmetric a (SequenceA to b)-  , CanEnsureCE es a-  , CanEnsureCE es (MinMaxType a (SequenceA to b))-  , SuitableForCE es)-  =>-  CanMinMaxAsymmetric (CollectErrors es a) (SequenceA to b)-  where-  type MinMaxType (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (MinMaxType a (SequenceA to b))-  min = lift2TCE min-  max = lift2TCE max---lift2 ::-  (QAArrow to, SuitableForSeq a, SuitableForSeq b, SuitableForSeq c)-  =>-  String -> (a -> b -> c) -> SequenceA to a -> SequenceA to b -> SequenceA to c-lift2 name op aSeq bSeq =-  newSeq (op sampleA sampleB) name [AnyProtocolQA aSeq, AnyProtocolQA bSeq] makeQ-  where-  SequenceP sampleA = qaProtocol aSeq-  SequenceP sampleB = qaProtocol bSeq-  makeQ (me, _src) =-    proc ac ->-      do-      a <- seqWithAccuracy aSeq me -< ac-      b <- seqWithAccuracy bSeq me -< ac-      returnA -< op a b--lift2T ::-  (QAArrow to, SuitableForSeq a, SuitableForSeq c)-  =>-  String -> (a -> t -> c) -> SequenceA to a -> t -> SequenceA to c-lift2T name op aSeq b =-  newSeq (op sampleA b) name [AnyProtocolQA aSeq] makeQ-  where-  SequenceP sampleA = qaProtocol aSeq-  makeQ (me, _src) =-    proc ac ->-      do-      a <- seqWithAccuracy aSeq me -< ac-      returnA -< op a b--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--    instance-      (QAArrow to-      , CanMinMaxAsymmetric a $t, SuitableForSeq a, SuitableForSeq (MinMaxType a $t))-      =>-      CanMinMaxAsymmetric (SequenceA to a) $t-      where-      type MinMaxType (SequenceA to a) $t = SequenceA to (MinMaxType a $t)-      min = binaryOpWithPureArg "min" min (getInitQ1TFromSimple id)-      max = binaryOpWithPureArg "max" max (getInitQ1TFromSimple id)--    instance-      (QAArrow to-      , CanMinMaxAsymmetric $t b, SuitableForSeq b, SuitableForSeq (MinMaxType $t b))-      =>-      CanMinMaxAsymmetric $t (SequenceA to b)-      where-      type MinMaxType $t (SequenceA to b) = SequenceA to (MinMaxType $t b)-      min = flip $ binaryOpWithPureArg "min" (flip min) (getInitQ1TFromSimple id)-      max = flip $ binaryOpWithPureArg "max" (flip max) (getInitQ1TFromSimple id)--    instance-      (QAArrow to, HasEqAsymmetric a $t-      , SuitableForSeq a, SuitableForSeq (EqCompareType a $t))-      =>-      HasEqAsymmetric (SequenceA to a) $t-      where-      type EqCompareType (SequenceA to a) $t = SequenceA to (EqCompareType a $t)-      equalTo = lift2T "==" (==)-      notEqualTo = lift2T "/=" (/=)--    instance-      (QAArrow to, HasEqAsymmetric $t a-      , SuitableForSeq a, SuitableForSeq (EqCompareType $t a))-      =>-      HasEqAsymmetric $t (SequenceA to a)-      where-      type EqCompareType $t (SequenceA to a) = SequenceA to (EqCompareType $t a)-      equalTo = flip $ lift2T "==" (flip (==))-      notEqualTo = flip $ lift2T "/=" (flip (/=))--    instance-      (QAArrow to, HasOrderAsymmetric a $t-      , SuitableForSeq a, SuitableForSeq (OrderCompareType a $t))-      =>-      HasOrderAsymmetric (SequenceA to a) $t-      where-      type OrderCompareType (SequenceA to a) $t = SequenceA to (OrderCompareType a $t)-      lessThan = lift2T "<" (<)-      leq = lift2T "<=" (<=)-      greaterThan = lift2T ">" (>)-      geq = lift2T ">=" (>=)--    instance-      (QAArrow to, HasOrderAsymmetric $t a-      , SuitableForSeq a, SuitableForSeq (OrderCompareType $t a))-      =>-      HasOrderAsymmetric $t (SequenceA to a)-      where-      type OrderCompareType $t (SequenceA to a) = SequenceA to (OrderCompareType $t a)-      lessThan = flip $ lift2T "<" (flip (<))-      leq = flip $ lift2T "<=" (flip (<=))-      greaterThan = flip $ lift2T ">" (flip (>))-      geq = flip $ lift2T ">=" (flip (>=))--  |]))
− src/AERN2/Sequence/Elementary.hs 
@@ -1,307 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.Sequence.Elementary-    Description :  elementary functions on sequences-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Elementary functions on fast converging sequences.--}-module AERN2.Sequence.Elementary-()-where--import MixedTypesNumPrelude--- import qualified Prelude as P--import Control.Arrow--import Control.CollectErrors--import AERN2.MP.Ball-import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Sequence.Type-import AERN2.Sequence.Helpers-import AERN2.Sequence.Ring ()-import AERN2.Sequence.Field ()--{- exp -}--instance-  (QAArrow to, CanExp a-  , CanEnsureCN (ExpType a), HasNorm (EnsureNoCN (ExpType a))-  , SuitableForSeq a, SuitableForSeq (ExpType a))-  =>-  CanExp (SequenceA to a)-  where-  type ExpType (SequenceA to a) = SequenceA to (ExpType a)-  exp = unaryOp "exp" exp expGetInitQ1-    where-    expGetInitQ1 me a1 =-      proc q ->-        do-        (m_a1NormLog, b) <- getSeqFnNormLog me a1 exp -< q-        let jInit = case m_a1NormLog of-                Just expNL -> q + expNL-                _ -> q-        returnA -< (jInit, Just b)--{- log -}--instance-  (QAArrow to, CanLog a, CanSetPrecision a-  , CanEnsureCN a, HasNorm (EnsureNoCN a)-  , SuitableForSeq a, SuitableForSeq (LogType a))-  =>-  CanLog (SequenceA to a)-  where-  type LogType (SequenceA to a) = SequenceA to (LogType a)-  log = unaryOp "log" log logGetInitQ1-    where-    logGetInitQ1 me a1 =-      proc q ->-        do-        (m_a1NormLog, b) <- getSeqFnNormLog me a1 id -< q-        let jInit = case m_a1NormLog of-                Just a1normLog -> q - a1normLog-                _ -> q-        returnA -< (jInit, Just $ setPrecisionAtLeastAccuracy ((_acGuide q)+5) b)-        -- the @setPrecisionAtLeastAccuracy (q+5)@ above improves-        -- efficiency for exact low-precision arguments--{- power -}--instance-  (QAArrow to, CanPow a e-  , CanEnsureCN a, HasNorm (EnsureNoCN a)-  , HasIntegerBounds e-  , SuitableForSeq a, SuitableForSeq e-  , SuitableForSeq (PowTypeNoCN a e)-  , SuitableForSeq (PowType a e))-  =>-  CanPow (SequenceA to a) (SequenceA to e)-  where-  type PowTypeNoCN (SequenceA to a) (SequenceA to e) = SequenceA to (PowTypeNoCN a e)-  powNoCN = binaryOp "^" powNoCN powGetInitQ1Q2-  type PowType (SequenceA to a) (SequenceA to e) = SequenceA to (PowType a e)-  pow = binaryOp "^" pow powGetInitQ1Q2--powGetInitQ1Q2 ::-  (QAArrow to-  , HasNorm (EnsureNoCN b), CanEnsureCN b, HasIntegerBounds e)-  =>-  Maybe (QAId to) -> SequenceA to b -> SequenceA to e ->-  AccuracySG `to` ((AccuracySG, Maybe b), (AccuracySG, Maybe e))-powGetInitQ1Q2 me base e =-  proc q ->-    do-    baseB <- seqWithAccuracy base me -< q-    eB <- seqWithAccuracy e me -< q-    let jInit1 = powGetInitAC1 baseB eB q-    let jInit2 = powGetInitAC2 baseB eB q-    returnA -< ((jInit1, Just baseB), (jInit2, Just eB))--powGetInitAC1 ::-  (HasNorm (EnsureNoCN base), CanEnsureCN base, HasIntegerBounds e)-  =>-  base -> e -> AccuracySG -> AccuracySG-powGetInitAC1 base e acSG =-  let eI = snd (integerBounds e) + 1 in-  case ensureNoCN base of-    (Just baseNoCN, _) ->-      case getNormLog baseNoCN of-        NormBits baseNL -> acSG + (baseNL * (eI - 1))-        NormZero -> acSG0  -- base == 0, the query does not matter-    _ -> acSG0--powGetInitAC2 ::-  (HasNorm (EnsureNoCN base), CanEnsureCN base, HasIntegerBounds e)-  =>-  base -> e -> AccuracySG -> AccuracySG-powGetInitAC2 base e acSG =-  let eI = snd (integerBounds e) + 1 in-  case ensureNoCN base of-    (Just baseNoCN, _) ->-      case getNormLog baseNoCN of-        NormBits baseNL -> acSG + baseNL * eI-        NormZero -> acSG0  -- base == 0, the query does not matter-    _ -> acSG0---powGetInitQ1T ::-  (QAArrow to, HasNorm (EnsureNoCN base), CanEnsureCN base, HasIntegerBounds e)-  =>-  (Maybe (QAId to)) -> SequenceA to base -> e -> AccuracySG `to` (AccuracySG, Maybe base)-powGetInitQ1T me baseSeq e =-  proc q ->-    do-    base <- seqWithAccuracy baseSeq me -< q-    returnA -< (powGetInitAC1 base e q, Just base)--powGetInitQ2T ::-  (QAArrow to, HasNorm (EnsureNoCN base), CanEnsureCN base, HasIntegerBounds e)-  =>-  (Maybe (QAId to)) -> base -> SequenceA to e -> AccuracySG `to` (AccuracySG, Maybe e)-powGetInitQ2T me base eSeq =-  proc q ->-    do-    e <- seqWithAccuracy eSeq me -< q-    returnA -< (powGetInitAC1 base e q, Just e)--instance-  (CanPow a MPBall, SuitableForSeq a-  , HasNorm (EnsureNoCN a), CanEnsureCN a-  , CanSetPrecision (PowTypeNoCN a MPBall)-  , CanSetPrecision (PowType a MPBall))-  =>-  CanPow (Sequence a) MPBall-  where-  type PowTypeNoCN (Sequence a) MPBall = PowTypeNoCN a MPBall-  powNoCN base e = binaryWithEnclTranslateAC powGetInitAC1 powNoCN base e-  type PowType (Sequence a) MPBall = PowType a MPBall-  pow base e = binaryWithEnclTranslateAC powGetInitAC1 pow base e--instance-  (CanPow MPBall e, SuitableForSeq e-  , HasIntegerBounds e-  , CanSetPrecision (PowTypeNoCN MPBall e)-  , CanSetPrecision (PowType MPBall e))-  =>-  CanPow MPBall (Sequence e)-  where-  type PowTypeNoCN MPBall (Sequence e) = PowTypeNoCN MPBall e-  powNoCN =-    flip (binaryWithEnclTranslateAC (flip powGetInitAC2) (flip powNoCN))-  type PowType MPBall (Sequence e) = PowType MPBall e-  pow =-    flip (binaryWithEnclTranslateAC (flip powGetInitAC2) (flip pow))--instance-  (CanPow (SequenceA to a) b-  , CanEnsureCE es b-  , CanEnsureCE es (PowTypeNoCN (SequenceA to a) b)-  , CanEnsureCE es (PowType (SequenceA to a) b)-  , SuitableForCE es)-  =>-  CanPow (SequenceA to a) (CollectErrors es  b)-  where-  type PowTypeNoCN (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (PowTypeNoCN (SequenceA to a) b)-  powNoCN = lift2TLCE powNoCN-  type PowType (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (PowType (SequenceA to a) b)-  pow = lift2TLCE pow--instance-  (CanPow a (SequenceA to b)-  , CanEnsureCE es a-  , CanEnsureCE es (PowType a (SequenceA to b))-  , CanEnsureCE es (PowTypeNoCN a (SequenceA to b))-  , SuitableForCE es)-  =>-  CanPow (CollectErrors es a) (SequenceA to b)-  where-  type PowTypeNoCN (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (PowTypeNoCN a (SequenceA to b))-  powNoCN = lift2TCE powNoCN-  type PowType (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (PowType a (SequenceA to b))-  pow = lift2TCE pow--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Dyadic |], [t| Rational |]]-  (\ t -> [d|--    instance-      (QAArrow to, CanPow a $t-      , CanSetPrecision a-      , CanEnsureCN a, HasNorm (EnsureNoCN a)-      , SuitableForSeq a-      , SuitableForSeq (PowTypeNoCN a $t)-      , SuitableForSeq (PowType a $t))-      =>-      CanPow (SequenceA to a) $t where-      type PowTypeNoCN (SequenceA to a) $t = SequenceA to (PowTypeNoCN a $t)-      powNoCN = binaryOpWithPureArg "^" powNoCN powGetInitQ1T-      type PowType (SequenceA to a) $t = SequenceA to (PowType a $t)-      pow = binaryOpWithPureArg "^" pow powGetInitQ1T--    instance-      (QAArrow to, CanPow $t a-      , CanSetPrecision a-      , HasIntegerBounds a-      , SuitableForSeq a-      , SuitableForSeq (PowType $t a)-      , SuitableForSeq (PowTypeNoCN $t a))-      =>-      CanPow $t (SequenceA to a) where-      type PowTypeNoCN $t (SequenceA to a) = SequenceA to (PowTypeNoCN $t a)-      powNoCN = flip $ binaryOpWithPureArg "^" (flip powNoCN) (\me -> flip (powGetInitQ2T me))-      type PowType $t (SequenceA to a) = SequenceA to (PowType $t a)-      pow = flip $ binaryOpWithPureArg "^" (flip pow) (\me -> flip (powGetInitQ2T me))--  |]))--{- sqrt -}--instance-  (QAArrow to, CanSqrt a-  , CanMinMaxThis a Integer-  , CanEnsureCN (SqrtType a), HasNorm (EnsureNoCN (SqrtType a))-  , SuitableForSeq a, SuitableForSeq (SqrtType a))-  =>-  CanSqrt (SequenceA to a)-  where-  type SqrtType (SequenceA to a) = SequenceA to (SqrtType a)-  sqrt = unaryOp "sqrt" sqrt sqrtGetInitQ1-    where-    sqrtGetInitQ1 me a1 =-      proc q ->-        do-        (m_a1NormLog, b) <- getSeqFnNormLog me a1 sqrtSafe -< q-        let jInit = case m_a1NormLog of-                Just sqrtNormLog-                  | sqrtNormLog < 0 -> max acSG0 (q - 1 - 2*sqrtNormLog) -- nearer 0-                  | otherwise -> max acSG0 (q - 1 - sqrtNormLog)-                _ -> acSG0-        returnA -< (jInit, Just b)-    sqrtSafe x =-      sqrt (max 0 x)--{- sine, cosine -}--instance-  (QAArrow to, CanSinCos a-  , CanEnsureCN (SinCosType a), HasNorm (EnsureNoCN (SinCosType a))-  , SuitableForSeq a, SuitableForSeq (SinCosType a))-  =>-  CanSinCos (SequenceA to a)-  where-  type SinCosType (SequenceA to a) = SequenceA to (SinCosType a)-  cos = unaryOp "cos" cos cosGetInitQ1-    where-    cosGetInitQ1 me a1 =-      proc q ->-        do-        (m_a1NormLog, b) <- getSeqFnNormLog me a1 sin -< q-        let jInit = case m_a1NormLog of-                Just sinNormLog -> q + sinNormLog-                _ -> acSG0 -- this should never happen-        returnA -< (jInit, Just b)-  sin = unaryOp "sin" sin sinGetInitQ1-    where-    sinGetInitQ1 me a1 =-      proc q ->-        do-        (m_a1NormLog, b) <- getSeqFnNormLog me a1 cos -< q-        let jInit = case m_a1NormLog of-                Just cosNormLog -> q + cosNormLog-                _ -> acSG0 -- this should never happen-        returnA -< (jInit, Just b)
− src/AERN2/Sequence/Field.hs 
@@ -1,197 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.Sequence.Field-    Description :  field operations on sequences-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Field operations on convergent sequences.--}-module AERN2.Sequence.Field-(-)-where--import MixedTypesNumPrelude--- import qualified Prelude as P--import Control.Arrow--import Control.CollectErrors--import AERN2.MP.Ball-import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Sequence.Type-import AERN2.Sequence.Helpers-import AERN2.Sequence.Ring (mulGetInitAC)--{- division -}--instance-  (QAArrow to, CanDiv a b, HasNorm (EnsureNoCN a), HasNorm (EnsureNoCN b)-  , SuitableForSeq a, SuitableForSeq b-  , SuitableForSeq (DivType a b), SuitableForSeq (DivTypeNoCN a b))-  =>-  CanDiv (SequenceA to a) (SequenceA to b)-  where-  type DivType (SequenceA to a) (SequenceA to b) = SequenceA to (DivType a b)-  divide = binaryOp "/" divide divGetInitQ1Q2-  type DivTypeNoCN (SequenceA to a) (SequenceA to b) = SequenceA to (DivTypeNoCN a b)-  divideNoCN = binaryOp "/" divideNoCN divGetInitQ1Q2--divGetInitQ1Q2 ::-  (QAArrow to-  , HasNorm (EnsureNoCN a), HasNorm (EnsureNoCN b)-  , SuitableForSeq a, SuitableForSeq b)-  =>-  Maybe (QAId to) -> SequenceA to a -> SequenceA to b -> AccuracySG `to` ((AccuracySG, Maybe a), (AccuracySG, Maybe b))-divGetInitQ1Q2 me a1 a2 =-  proc q ->-    do-    -- In a Fractional instance, optimising 3/x and not optimising x/3 etc.-    -- In a Fractional instance, x/3 should be replaced by (1/3)*x etc.-    b1 <- seqWithAccuracy a1 me -< q-    let jPre2 = mulGetInitAC b1 q-    b2 <- seqWithAccuracy a2 me -< jPre2-    let jInit1 = divGetInitAC1 b2 q-    let jInit2 = divGetInitAC2 b1 b2 q-    returnA -< ((jInit1, Just b1), (jInit2, Just b2))--divGetInitAC1 ::-  (HasNorm (EnsureNoCN denom), CanEnsureCN denom)-  =>-  denom -> AccuracySG -> AccuracySG-divGetInitAC1 denom acSG =-  case ensureNoCN denom of-    (Just denomNoCN, _) ->-      case getNormLog denomNoCN of-        NormBits denomNL -> max acSG0 (acSG - denomNL)-        NormZero -> acSG0 -- denominator == 0, we have no chance...-    _ -> acSG0--divGetInitAC2 ::-  (HasNorm (EnsureNoCN numer), CanEnsureCN numer-  , HasNorm (EnsureNoCN denom), CanEnsureCN denom)-  =>-  numer -> denom -> AccuracySG -> AccuracySG-divGetInitAC2 numer denom acSG =-  case (ensureNoCN numer, ensureNoCN denom) of-    ((Just numerNoCN, _), (Just denomNoCN, _)) ->-      case (getNormLog numerNoCN, getNormLog denomNoCN) of-        (_, NormZero) -> acSG0 -- denominator == 0, we have no chance...-        (NormZero, _) -> acSG0 -- numerator == 0, it does not matter-        (NormBits numerNL, NormBits denomNL) -> max acSG0 (acSG + numerNL - 2 * denomNL)-    _ -> acSG0---instance-  (CanDiv a MPBall, SuitableForSeq a-  , CanSetPrecision (DivType a MPBall), CanSetPrecision (DivTypeNoCN a MPBall))-  =>-  CanDiv (Sequence a) MPBall-  where-  type DivType (Sequence a) MPBall = DivType a MPBall-  divide = binaryWithEnclTranslateAC (\ _ -> divGetInitAC1) divide-  type DivTypeNoCN (Sequence a) MPBall = DivTypeNoCN a MPBall-  divideNoCN = binaryWithEnclTranslateAC (\ _ -> divGetInitAC1) divideNoCN--instance-  (CanDiv MPBall b, SuitableForSeq b-  , HasNorm (EnsureNoCN b), CanEnsureCN b-  , CanSetPrecision (DivType MPBall b)-  , CanSetPrecision (DivTypeNoCN MPBall b))-  =>-  CanDiv MPBall (Sequence b)-  where-  type DivType MPBall (Sequence b) = DivType MPBall b-  divide = flip (binaryWithEnclTranslateAC (flip divGetInitAC2) (flip divide))-  type DivTypeNoCN MPBall (Sequence b) = DivTypeNoCN MPBall b-  divideNoCN = flip (binaryWithEnclTranslateAC (flip divGetInitAC2) (flip divideNoCN))--instance-  (CanDiv (SequenceA to a) b-  , CanEnsureCE es b-  , CanEnsureCE es (DivType (SequenceA to a) b)-  , CanEnsureCE es (DivTypeNoCN (SequenceA to a) b)-  , SuitableForCE es)-  =>-  CanDiv (SequenceA to a) (CollectErrors es  b)-  where-  type DivType (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (DivType (SequenceA to a) b)-  divide = lift2TLCE divide-  type DivTypeNoCN (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (DivTypeNoCN (SequenceA to a) b)-  divideNoCN = lift2TLCE divideNoCN--instance-  (CanDiv a (SequenceA to b)-  , CanEnsureCE es a-  , CanEnsureCE es (DivType a (SequenceA to b))-  , CanEnsureCE es (DivTypeNoCN a (SequenceA to b))-  , SuitableForCE es)-  =>-  CanDiv (CollectErrors es a) (SequenceA to b)-  where-  type DivType (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (DivType a (SequenceA to b))-  divide = lift2TCE divide-  type DivTypeNoCN (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (DivTypeNoCN a (SequenceA to b))-  divideNoCN = lift2TCE divideNoCN--divGetInitQ1T ::-  (Arrow to, HasNorm (EnsureNoCN denom), CanEnsureCN denom)-  =>-  Maybe (QAId to) -> SequenceA to numer -> denom -> AccuracySG `to` (AccuracySG, Maybe numer)-divGetInitQ1T _me _numerSeq denom =-  arr $ \q -> (divGetInitAC1 denom q, Nothing)--divGetInitQ2T ::-  (QAArrow to-  , HasNorm (EnsureNoCN numer), CanEnsureCN numer-  , HasNorm (EnsureNoCN denom), CanEnsureCN denom)-  =>-  Maybe (QAId to) -> numer -> SequenceA to denom -> AccuracySG `to` (AccuracySG, Maybe denom)-divGetInitQ2T me numer denomSeq =-  proc q ->-    do-    denom <- seqWithAccuracy denomSeq me -< q-    returnA -< (divGetInitAC2 numer denom q, Just denom)--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--  instance-    (QAArrow to, CanDiv a $t, SuitableForSeq a-    , SuitableForSeq (DivType a $t), SuitableForSeq (DivTypeNoCN a $t))-    =>-    CanDiv (SequenceA to a) $t-    where-    type DivType (SequenceA to a) $t = SequenceA to (DivType a $t)-    divide = binaryOpWithPureArg "/" divide divGetInitQ1T-    type DivTypeNoCN (SequenceA to a) $t = SequenceA to (DivTypeNoCN a $t)-    divideNoCN = binaryOpWithPureArg "/" divideNoCN divGetInitQ1T--  instance-    (QAArrow to, CanDiv $t b, SuitableForSeq b-    , SuitableForSeq (DivType $t b)-    , SuitableForSeq (DivTypeNoCN $t b)-    , HasNorm (EnsureNoCN b))-    =>-    CanDiv $t (SequenceA to b)-    where-    type DivType $t (SequenceA to b) = SequenceA to (DivType $t b)-    divide = flip $ binaryOpWithPureArg "/" (flip divide) (\ me -> flip (divGetInitQ2T me))-    type DivTypeNoCN $t (SequenceA to b) = SequenceA to (DivTypeNoCN $t b)-    divideNoCN = flip $ binaryOpWithPureArg "/" (flip divideNoCN) (\ me -> flip (divGetInitQ2T me))--  |]))
− src/AERN2/Sequence/Helpers.hs 
@@ -1,246 +0,0 @@-{-# LANGUAGE CPP #-}--- #define DEBUG-{-|-    Module      :  AERN2.Sequence.Helpers-    Description :  helper functions for sequence operations-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Helper functions for sequence operations.--}-module AERN2.Sequence.Helpers-(-  -- Operations returning Seq-  unaryOp, binaryOp, binaryOpWithPureArg-  -- Construction of initial queries-  , getInitQ1FromSimple, getInitQ1TFromSimple, getInitQ1Q2FromSimple-  -- Operations returning an enclosure (eg MPBall)-  , binaryWithEncl, binaryWithEnclTranslateAC-  , seqElementSimilarToEncl-  -- misc-  ,getSeqFnNormLog-  ,ensureAccuracyA-)-where--#ifdef DEBUG-import Debug.Trace (trace)-#define maybeTrace trace-#define maybeTraceIO putStrLn-#else-#define maybeTrace (\ (_ :: String) t -> t)-#define maybeTraceIO (\ (_ :: String) -> return ())-#endif--import MixedTypesNumPrelude--- import qualified Prelude as P--import Control.Arrow--import AERN2.MP--import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Sequence.Type--{- generic implementations of operations of different arity -}--unaryOp ::-  (QAArrow to, SuitableForSeq a, SuitableForSeq b)-  =>-  String ->-  (a -> b) ->-  (Maybe (QAId to) {- my id -} -> SequenceA to a -> (AccuracySG `to` (AccuracySG, Maybe a))) ->-  SequenceA to a -> SequenceA to b-unaryOp name op getInitQ1 r1 =-  newSeq (op sampleA1) name [AnyProtocolQA r1] makeQ-  where-  SequenceP sampleA1 = qaProtocol r1-  makeQ (me, _src) =-    proc ac ->-      do-      (q1Init, mb1) <- getInitQ1 me r1 -< ac-      ensureAccuracyA (proc [q1] -> (r1 ?<- me) -< q1) op -< (ac, ([q1Init], mb1))--binaryOpWithPureArg ::-  (QAArrow to, SuitableForSeq a, SuitableForSeq b)-  =>-  String ->-  (a -> t -> b) ->-  (Maybe (QAId to) {- my id -} -> SequenceA to a -> t -> (AccuracySG `to` (AccuracySG, Maybe a))) ->-  SequenceA to a -> t -> SequenceA to b-binaryOpWithPureArg name op getInitQ1T r1 t =-  newSeq (op sampleA t) name [AnyProtocolQA r1] makeQ-  where-  SequenceP sampleA = qaProtocol r1-  makeQ (me, _src) =-    proc ac ->-      do-      (q1Init, mb1) <- getInitQ1T me r1 t -< ac-      ensureAccuracyA (proc [q1] -> (r1 ?<- me) -< q1) (flip op t) -< (ac, ([q1Init], mb1))--binaryOp ::-  (QAArrow to, SuitableForSeq a, SuitableForSeq b, SuitableForSeq c)-  =>-  String ->-  (a -> b -> c) ->-  (Maybe (QAId to) {- my id -} -> SequenceA to a -> SequenceA to b ->-    (AccuracySG `to` ((AccuracySG, Maybe a), (AccuracySG, Maybe b)))) ->-  SequenceA to a -> SequenceA to b -> SequenceA to c-binaryOp name op getInitQ1Q2 r1 r2 =-  newSeq (op sampleA sampleB) name [AnyProtocolQA r1, AnyProtocolQA r2] makeQ-  where-  SequenceP sampleA = qaProtocol r1-  SequenceP sampleB = qaProtocol r2-  makeQ (me,_src) =-    proc ac ->-      do-      ((q1Init, mb1), (q2Init, mb2)) <- getInitQ1Q2 me r1 r2 -< ac-      ensureAccuracyA-        (proc [q1,q2] -> ((r1,r2) ??<- me) -< (q1,q2))-        (uncurry op)-          -< (ac, ([q1Init, q2Init], do {b1<-mb1;b2<-mb2;Just (b1,b2)}))--{- functions to help determine initial queries -}--getInitQ1FromSimple ::-  (Arrow to)-  =>-  AccuracySG `to` q ->-  Maybe (QAId to) {-^ my id -} -> r1 -> AccuracySG `to` (q, Maybe a)-getInitQ1FromSimple simpleA _ _ =-  proc q ->-    do-    initQ1 <- simpleA -< q-    returnA -< (initQ1, Nothing)--getInitQ1TFromSimple ::-  (Arrow to)-  =>-  AccuracySG `to` q ->-  Maybe (QAId to) {-^ my id -} -> r1 -> t -> AccuracySG `to` (q, Maybe a)-getInitQ1TFromSimple simpleA _ _ _ =-  proc q ->-    do-    initQ1 <- simpleA -< q-    returnA -< (initQ1, Nothing)--getInitQ1Q2FromSimple ::-  (Arrow to)-  =>-  AccuracySG `to` (q,q) ->-  Maybe (QAId to) {-^ my id -} -> r1 -> r2 -> AccuracySG `to` ((q, Maybe a), (q, Maybe b))-getInitQ1Q2FromSimple simpleA _ _ _ =-  proc q ->-    do-    (initQ1, initQ2) <- simpleA -< q-    returnA -< ((initQ1, Nothing), (initQ2, Nothing))--{--  functions for iterative querying of operands-  until the result is of a sufficient accuracy--}--ensureAccuracyA ::-  (ArrowChoice to, Show a, Show b-  , HasAccuracy b-  , CanEnsureCN b, HasAccuracy (EnsureNoCN b), Show (EnsureNoCN b))-  =>-  ([AccuracySG] `to` a) ->-  (a -> b) ->-  ((AccuracySG, ([AccuracySG], Maybe a)) `to` b)-ensureAccuracyA getA op =-    proc (q,(js, aPrelim)) ->-        case fmap op aPrelim of-          Just resultPrelim | getAccuracy resultPrelim >= q ->-            returnA -<-                maybeTrace (-                    "ensureAccuracyA: Pre-computed result sufficient. (q = " ++ show q ++-                    "; js = " ++ show js ++-                    "; result accuracy = " ++ (show $ getAccuracy resultPrelim) ++ ")"-                ) $-                resultPrelim-          _ ->-            aux -< (q,js)-    where-    aux =-        proc (q,js) ->-            do-            a <- getA -< js-            let result =-                    -- maybeTrace ("op a = " ++ show (op a)) $-                    -- maybeTrace ("ac (op a) = " ++ show (getAccuracy (op a))) $-                    op a-            case ensureNoCN result of-              (Just _resultNoCN, es) | not (hasCertainError es) ->-                if getAccuracy result >= _acStrict q-                  then-                  returnA -<-                      maybeTrace (-                          "ensureAccuracyA: Succeeded. (q = " ++ show q ++-                          "; js = " ++ show js ++-                          "; result accuracy = " ++ (show $ getAccuracy result) ++ ")"-                      ) $-                      result-                  else-                  aux -<-                      maybeTrace (-                          "ensureAccuracyA: Not enough ... (q = " ++ show q ++-                          "; js = " ++ show js ++-                          "; a = " ++ show a ++-                          "; result = " ++ show result ++-                          "; result accuracy = " ++ (show $ getAccuracy result) ++ ")"-                      ) $-                      (q, map (+1) js)-              _ -> returnA -< result -- certain error, give up improving---{- MPBall + CauchyReal = MPBall, only allowed in the (->) arrow  -}--binaryWithEncl ::-  (HasAccuracy b, HasPrecision b, CanSetPrecision t)-  =>-  (a -> b -> t) -> Sequence a -> b -> t-binaryWithEncl = binaryWithEnclTranslateAC (\ _ _ -> id)--binaryWithEnclTranslateAC ::-  (HasAccuracy b, HasPrecision b, CanSetPrecision t)-  =>-  (a -> b -> AccuracySG -> AccuracySG) ->-  (a -> b -> t) -> Sequence a -> b -> t-binaryWithEnclTranslateAC accuracyTranslationForB op sa b =-  lowerPrecisionIfAbove (getPrecision b) $-    op (seqElementSimilarToEncl (flip accuracyTranslationForB b) b sa) b--seqElementSimilarToEncl ::-  (HasAccuracy b, HasPrecision b) =>-  (a -> AccuracySG -> AccuracySG) ->-  b -> Sequence a -> a-seqElementSimilarToEncl accuracyTranslation b sa =-  sa ? (accuracyTranslation a $ accuracySG $ getFiniteAccuracy b)-  where-  a = sa ? acSG0--{- miscellaneous -}--getSeqFnNormLog ::-  (QAArrow to, CanEnsureCN v, HasNorm (EnsureNoCN v))-  =>-  Maybe (QAId to) -> SequenceA to a -> (a -> v) -> AccuracySG `to` (Maybe Integer, a)-getSeqFnNormLog src a f =-  proc q ->-    do-    aq <- seqWithAccuracy a src -< q-    returnA -< (aux aq, aq)-  where-  aux aq =-    case ensureNoCN (f aq) of-      (Just faqNoCN, es) | not (hasCertainError es) ->-        case getNormLog faqNoCN of-          NormBits faqNL -> Just faqNL-          NormZero -> Nothing-      _ -> Nothing
− src/AERN2/Sequence/PreludeOps.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE CPP #-}-{-|-    Module      :  AERN2.Sequence.PreludeOps-    Description :  Instances of Prelude.Num etc-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Instances of Prelude classes Eq, Ord, Num etc--}-module AERN2.Sequence.PreludeOps-(-)-where--import MixedTypesNumPrelude-import qualified Prelude as P--import AERN2.Norm--import AERN2.MP.Precision-import AERN2.MP.Enclosure-import AERN2.MP.Dyadic--import AERN2.QA.Protocol--import AERN2.AccuracySG-import AERN2.Sequence.Type-import AERN2.Sequence.Comparison ()-import AERN2.Sequence.Ring ()-import AERN2.Sequence.Field ()-import AERN2.Sequence.Elementary ()--{- Instances of Prelude numerical classes provided for convenient use outside AERN2-   and also because Template Haskell translates (-x) to (Prelude.negate x) -}--instance-  (HasEqCertainly a a)-  =>-  P.Eq (Sequence a)-  where-  a == b-    | aD !==! bD = True-    | aD !/=! bD = False-    | otherwise =-        error "Failed to decide equality of Sequences.  If you switch to MixedTypesNumPrelude instead of Prelude, comparison of Sequences returns Sequence (Maybe Bool) or similar instead of Bool."-    where-    aD = a ? default_acSG-    bD = b ? default_acSG--instance-  (HasEqCertainly a a, HasOrderCertainly a a)-  =>-  P.Ord (Sequence a)-  where-  compare a b-    | aD !==! bD = P.EQ-    | aD !<! bD = P.LT-    | aD !>! bD = P.GT-    | otherwise =-        error "Failed to decide order of Sequences.  If you switch to MixedTypesNumPrelude instead of Prelude, comparison of Sequences returns Sequence (Maybe Bool) or similar instead of Bool."-    where-    aD = a ? default_acSG-    bD = b ? default_acSG--instance-  (Ring a, CanAbsSameType a-  , SuitableForSeq a, CanSetPrecision a, HasNorm (EnsureNoCN a), CanEnsureCN a)-  =>-  P.Num (Sequence a)-  where-  fromInteger = convertExactly-  negate = negate-  (+) = (+)-  (*) = (*)-  abs = abs-  signum = error "Prelude.signum not implemented for Sequence"--instance-  (Field a, CanAbsSameType a, ConvertibleWithPrecision Rational a-  , SuitableForSeq a, SuitableForSeq (EnsureCN a), CanSetPrecision a-  , HasNorm (EnsureNoCN a), CanEnsureCN a-  , CanIntersectCNSameType a)-  =>-  P.Fractional (Sequence a)-  where-  fromRational = convertExactly-  recip a =-    case deEnsureCN (recip a) of-      Right r -> r-      Left es -> error $ show es-  (/) = (/!)
− src/AERN2/Sequence/Ring.hs 
@@ -1,289 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.Sequence.Ring-    Description :  ring operations on sequences-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Ring operations on convergent sequences--}-module AERN2.Sequence.Ring-(-  mulGetInitAC-)-where--import MixedTypesNumPrelude hiding (id)--- import qualified Prelude as P--import Control.Category (id)-import Control.Arrow--import Control.CollectErrors--import AERN2.MP.Ball-import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.AccuracySG-import AERN2.Sequence.Type-import AERN2.Sequence.Helpers--{- addition -}--instance-  (QAArrow to, CanAddAsymmetric a b, SuitableForSeq a, SuitableForSeq b, SuitableForSeq (AddType a b))-  =>-  CanAddAsymmetric (SequenceA to a) (SequenceA to b)-  where-  type AddType (SequenceA to a) (SequenceA to b) = SequenceA to (AddType a b)-  add = binaryOp "+" add (getInitQ1Q2FromSimple $ proc q -> returnA -< (q,q))--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--  instance-    (QAArrow to, CanAddAsymmetric a $t, SuitableForSeq a, SuitableForSeq (AddType a $t))-    =>-    CanAddAsymmetric (SequenceA to a) $t-    where-    type AddType (SequenceA to a) $t = SequenceA to (AddType a $t)-    add = binaryOpWithPureArg "+" add (getInitQ1TFromSimple id)--  instance-    (QAArrow to, CanAddAsymmetric $t b, SuitableForSeq b, SuitableForSeq (AddType $t b))-    =>-    CanAddAsymmetric $t (SequenceA to b)-    where-    type AddType $t (SequenceA to b) = SequenceA to (AddType $t b)-    add = flip $ binaryOpWithPureArg "+" (flip add) (getInitQ1TFromSimple id)--  |]))--instance-  (CanAddAsymmetric a MPBall, SuitableForSeq a-  , CanSetPrecision (AddType a MPBall))-  =>-  CanAddAsymmetric (Sequence a) MPBall-  where-  type AddType (Sequence a) MPBall = AddType a MPBall-  add = binaryWithEncl add--instance-  (CanAddAsymmetric MPBall b, SuitableForSeq b-  , CanSetPrecision (AddType MPBall b))-  =>-  CanAddAsymmetric MPBall (Sequence b)-  where-  type AddType MPBall (Sequence b) = AddType MPBall b-  add = flip $ binaryWithEncl (flip add)--instance-  (CanAddAsymmetric (SequenceA to a) b-  , CanEnsureCE es b-  , CanEnsureCE es (AddType (SequenceA to a) b)-  , SuitableForCE es)-  =>-  CanAddAsymmetric (SequenceA to a) (CollectErrors es  b)-  where-  type AddType (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (AddType (SequenceA to a) b)-  add = lift2TLCE add--instance-  (CanAddAsymmetric a (SequenceA to b)-  , CanEnsureCE es a-  , CanEnsureCE es (AddType a (SequenceA to b))-  , SuitableForCE es)-  =>-  CanAddAsymmetric (CollectErrors es a) (SequenceA to b)-  where-  type AddType (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (AddType a (SequenceA to b))-  add = lift2TCE add---{- subtraction -}--instance-  (QAArrow to, CanSub a b, SuitableForSeq a, SuitableForSeq b, SuitableForSeq (SubType a b))-  =>-  CanSub (SequenceA to a) (SequenceA to b)-  where-  type SubType (SequenceA to a) (SequenceA to b) = SequenceA to (SubType a b)-  sub = binaryOp "-" sub (getInitQ1Q2FromSimple $ proc q -> returnA -< (q,q))---$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--  instance-    (QAArrow to, CanSub a $t, SuitableForSeq a, SuitableForSeq (SubType a $t))-    =>-    CanSub (SequenceA to a) $t-    where-    type SubType (SequenceA to a) $t = SequenceA to (SubType a $t)-    sub = binaryOpWithPureArg "-" sub (getInitQ1TFromSimple id)--  instance-    (QAArrow to, CanSub $t b, SuitableForSeq b, SuitableForSeq (SubType $t b))-    =>-    CanSub $t (SequenceA to b)-    where-    type SubType $t (SequenceA to b) = SequenceA to (SubType $t b)-    sub = flip $ binaryOpWithPureArg "-" (flip sub) (getInitQ1TFromSimple id)--  |]))--instance-  (CanSub a MPBall, SuitableForSeq a, CanSetPrecision (SubType a MPBall))-  =>-  CanSub (Sequence a) MPBall-  where-  type SubType (Sequence a) MPBall = SubType a MPBall-  sub = binaryWithEncl sub--instance-  (CanSub MPBall b, SuitableForSeq b, CanSetPrecision (SubType MPBall b))-  =>-  CanSub MPBall (Sequence b)-  where-  type SubType MPBall (Sequence b) = SubType MPBall b-  sub = flip $ binaryWithEncl (flip sub)--instance-  (CanSub (SequenceA to a) b-  , CanEnsureCE es b-  , CanEnsureCE es (SubType (SequenceA to a) b)-  , SuitableForCE es)-  =>-  CanSub (SequenceA to a) (CollectErrors es  b)-  where-  type SubType (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (SubType (SequenceA to a) b)-  sub = lift2TLCE sub--instance-  (CanSub a (SequenceA to b)-  , CanEnsureCE es a-  , CanEnsureCE es (SubType a (SequenceA to b))-  , SuitableForCE es)-  =>-  CanSub (CollectErrors es a) (SequenceA to b)-  where-  type SubType (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (SubType a (SequenceA to b))-  sub = lift2TCE sub---{- multiplication -}--instance-  (QAArrow to, CanMulAsymmetric a b, HasNorm (EnsureNoCN a), HasNorm (EnsureNoCN b)-  , SuitableForSeq a, SuitableForSeq b, SuitableForSeq (MulType a b))-  =>-  CanMulAsymmetric (SequenceA to a) (SequenceA to b)-  where-  type MulType (SequenceA to a) (SequenceA to b) = SequenceA to (MulType a b)-  mul =-    binaryOp "*" mul getInitQ1Q2-    where-    getInitQ1Q2 me a1 a2 =-      proc q ->-        do-        b1 <- seqWithAccuracy a1 me -< q-        let jInit2 = mulGetInitAC b1 q-        -- favouring 2*x over x*2 in a Num instance-        b2 <- seqWithAccuracy a2 me -< jInit2-        let jInit1 = mulGetInitAC b2 q-        returnA -< ((jInit1, Just b1), (jInit2, Just b2))--mulGetInitAC ::-  (HasNorm (EnsureNoCN other), CanEnsureCN other)-  =>-  other -> AccuracySG -> AccuracySG-mulGetInitAC other acSG =-  case ensureNoCN other of-    (Just otherNoCN, _) ->-      case getNormLog otherNoCN of-        NormBits otherNL -> max acSG0 (acSG + otherNL)-        NormZero -> acSG0-    _ -> acSG--instance-  (CanMulAsymmetric a MPBall, SuitableForSeq a-  , CanSetPrecision (MulType a MPBall))-  =>-  CanMulAsymmetric (Sequence a) MPBall-  where-  type MulType (Sequence a) MPBall = MulType a MPBall-  mul = binaryWithEnclTranslateAC (\_ -> mulGetInitAC) mul--instance-  (CanMulAsymmetric MPBall b, SuitableForSeq b-  , CanSetPrecision (MulType MPBall b))-  =>-  CanMulAsymmetric MPBall (Sequence b)-  where-  type MulType MPBall (Sequence b) = MulType MPBall b-  mul = flip $ binaryWithEnclTranslateAC (\ _ -> mulGetInitAC) (flip mul)--instance-  (CanMulAsymmetric (SequenceA to a) b-  , CanEnsureCE es b-  , CanEnsureCE es (MulType (SequenceA to a) b)-  , SuitableForCE es)-  =>-  CanMulAsymmetric (SequenceA to a) (CollectErrors es  b)-  where-  type MulType (SequenceA to a) (CollectErrors es  b) =-    EnsureCE es (MulType (SequenceA to a) b)-  mul = lift2TLCE mul--instance-  (CanMulAsymmetric a (SequenceA to b)-  , CanEnsureCE es a-  , CanEnsureCE es (MulType a (SequenceA to b))-  , SuitableForCE es)-  =>-  CanMulAsymmetric (CollectErrors es a) (SequenceA to b)-  where-  type MulType (CollectErrors es  a) (SequenceA to b) =-    EnsureCE es (MulType a (SequenceA to b))-  mul = lift2TCE mul---mulGetInitQ1T ::-  (Arrow to, HasNorm (EnsureNoCN other), CanEnsureCN other)-  =>-  Maybe (QAId to) {-^ my id -} -> SequenceA to t -> other -> AccuracySG `to` (AccuracySG, Maybe t)-mulGetInitQ1T _me _seq other =-  arr $ \q -> (mulGetInitAC other q, Nothing)--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--  instance-    (QAArrow to, CanMulAsymmetric a $t, SuitableForSeq a, SuitableForSeq (MulType a $t))-    =>-    CanMulAsymmetric (SequenceA to a) $t-    where-    type MulType (SequenceA to a) $t = SequenceA to (MulType a $t)-    mul = binaryOpWithPureArg "*" mul mulGetInitQ1T--  instance-    (QAArrow to, CanMulAsymmetric $t b, SuitableForSeq b, SuitableForSeq (MulType $t b))-    =>-    CanMulAsymmetric $t (SequenceA to b)-    where-    type MulType $t (SequenceA to b) = SequenceA to (MulType $t b)-    mul = flip $ binaryOpWithPureArg "*" (flip mul) mulGetInitQ1T--  |]))
− src/AERN2/Sequence/Type.hs 
@@ -1,265 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}--- #define DEBUG-{-|-    Module      :  AERN2.Sequence.Type-    Description :  The type of fast convergent sequences-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    The type of fast convergent sequences--}-module AERN2.Sequence.Type-(-  SequenceP(..), pSeq-  , FastConvSeqP, EffortConvSeqP-  , SuitableForSeq-  , seqName, seqId, seqSources, seqRename-  , seqWithAccuracy, seqWithAccuracyA, seqsWithAccuracyA-  , SequenceA, Sequence-  , FastConvSeqA, EffortConvSeqA, FastConvSeq, EffortConvSeq-  , newSeq, newSeqSimple-  , convergentList2SequenceA-  , seqByPrecision2SequenceA-  , fmapSeq-)-where--#ifdef DEBUG-import Debug.Trace (trace)-#define maybeTrace trace-#define maybeTraceIO putStrLn-#else-#define maybeTrace (\ (_ :: String) t -> t)-#define maybeTraceIO (\ (_ :: String) -> return ())-#endif--import MixedTypesNumPrelude--- import qualified Prelude as P--import Control.Arrow--import Text.Printf--import Control.CollectErrors--import AERN2.MP-import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.QA.Strategy.CachedUnsafe ()--import AERN2.AccuracySG--{- QA protocol -}--data SequenceP a = SequenceP { unSequenceP :: a} deriving (Show)-type FastConvSeqP a = SequenceP a -- synonym, emphasising stric accuracy requirement-type EffortConvSeqP a = SequenceP a -- synonym, emphasising accuracy guide--pSeq :: a -> SequenceP a-pSeq a = SequenceP a--instance (Show a) => QAProtocol (SequenceP a) where-  type Q (SequenceP a) = AccuracySG-  type A (SequenceP a) = a-  -- sampleQ _ = AccuracySG NoInformation NoInformation--class-  (Show a, Show (EnsureNoCN a), Show (EnsureCN a), HasAccuracy a, CanAdjustToAccuracySG a-  , CanEnsureCN a, CanEnsureCN (EnsureCN a), HasAccuracy (EnsureNoCN a), CanIntersectCNSameType a)-  =>-  SuitableForSeq a--instance SuitableForSeq MPBall-instance SuitableForSeq (CN MPBall)-instance SuitableForSeq Bool-instance SuitableForSeq (CN Bool)-instance SuitableForSeq t => SuitableForSeq (Maybe t)--instance-  SuitableForSeq a-  =>-  QAProtocolCacheable (SequenceP a)-  where-  type QACache (SequenceP a) = (Maybe (a, AccuracySG))-  newQACache _ = Nothing-  lookupQACache _ cache acSG@(AccuracySG acS acG) =-    case cache of-      Just (b, AccuracySG _ bAG)-        | getAccuracy b >= acS && (getAccuracy b >= acG || bAG >= acG - tol) ->-          (Just (adjustToAccuracySG acSG b),-           Just (logMsg b))-      Just (b, _) -> (Nothing, Just (logMsg b))-      Nothing -> (Nothing, Just ("cache empty"))-    where-    tol = accuracySGdefaultTolerance-    logMsg b = printf "query: %s; cache: (ac=%s) %s" (show acSG) (show (getAccuracy b))  (show cache)-  updateQACache _ q b Nothing = Just (b,q)-  updateQACache _ q2 b2 (Just (b1,q1)) =-    Just (b, q1 `max` q2)-    where-    b12 = b1 `intersect` b2-    b =-      case deEnsureCN b12 of-        Right b' -> b'-        Left es ->-          error $-            printf "Sequence: updateQACache: problem computing intersection: %s /\\ %s: %s"-              (show b1) (show b2) (show es)--instance Functor SequenceP where-  fmap f (SequenceP a) = SequenceP (f a)--{- Seqeuences -}--type SequenceA to a = QA to (SequenceP a)-type Sequence a = SequenceA (->) a--type FastConvSeqA to a = SequenceA to a -- synonym, emphasising stric accuracy requirement-type EffortConvSeqA to a = SequenceA to a -- synonym, emphasising accuracy guide-type FastConvSeq a = Sequence a -- synonym, emphasising stric accuracy requirement-type EffortConvSeq a = Sequence a -- synonym, emphasising accuracy guide--instance (Show a) => Show (Sequence a) where-  show r = show $ r ? default_acSG--fmapSeq ::-  (Arrow to) =>-  (a -> b) -> (SequenceA to a) -> (SequenceA to b)-fmapSeq f = mapQAsameQ (fmap f) f--seqName :: SequenceA to a -> String-seqName = qaName----seqRename :: (String -> String) -> SequenceA to a -> SequenceA to a-seqRename = qaRename--seqId :: SequenceA to a -> Maybe (QAId to)-seqId = qaId--seqSources :: SequenceA to a -> [QAId to]-seqSources = qaSources--{-| Get an approximation of the limit with at least the specified accuracy.-   (A specialisation of 'qaMakeQuery' for Cauchy sequences.) -}-seqWithAccuracy :: (QAArrow to) => SequenceA to a -> Maybe (QAId to) -> AccuracySG `to` a-seqWithAccuracy = (?<-)--seqWithAccuracyA :: (QAArrow to) => (Maybe (QAId to)) -> (SequenceA to a, AccuracySG) `to` a-seqWithAccuracyA = qaMakeQueryA--seqsWithAccuracyA :: (QAArrow to) => (Maybe (QAId to)) -> ([SequenceA to a], AccuracySG) `to` [a]-seqsWithAccuracyA = qaMakeQueryOnManyA--{- constructions -}--newSeq ::-  (QAArrow to, SuitableForSeq a)-  =>-  a -> String -> [AnyProtocolQA to] -> ((Maybe (QAId to), Maybe (QAId to)) -> AccuracySG `to` a) -> SequenceA to a-newSeq sampleA name sources makeQ =-  newQA name sources (pSeq sampleA) Nothing makeQ--newSeqSimple ::-  (QAArrow to, SuitableForSeq a)-  =>-  a -> ((Maybe (QAId to), Maybe (QAId to)) -> AccuracySG `to` a) -> SequenceA to a-newSeqSimple sampleA = newSeq sampleA "simple" []--convergentList2SequenceA ::-  (QAArrow to, SuitableForSeq a) =>-  String -> [a] -> (SequenceA to a)-convergentList2SequenceA name balls@(sampleA : _) =-  newSeq sampleA name [] (\_src -> arr $ convergentList2CauchySeq balls . bits)-convergentList2SequenceA name [] =-  error $ "convergentList2SequenceA: empty sequence " ++ name--seqByPrecision2SequenceA :: (QAArrow to, SuitableForSeq a) => String -> (Precision -> a) -> (SequenceA to a)-seqByPrecision2SequenceA name byPrec =-  newSeq sampleA name [] (\_src -> arr $ seqByPrecision2CauchySeq byPrec . bits)-    where-    sampleA = byPrec (prec 0)--{- CollectErrors instances -}--instance-  (SuitableForCE es, CanEnsureCE es a)-  =>-  CanEnsureCE es (SequenceP a)-  where-  type EnsureCE es (SequenceP a) = SequenceP (EnsureCE es a)-  type EnsureNoCE es (SequenceP a) = SequenceP (EnsureNoCE es a)--  ensureCE sample_es = fmap (ensureCE sample_es)-  deEnsureCE sample_es (SequenceP a) = fmap SequenceP (deEnsureCE sample_es a)-  ensureNoCE sample_es (SequenceP a) =-    (\(ma,es) -> (fmap SequenceP ma, es)) (ensureNoCE sample_es a)--  noValueECE sample_vCE es = SequenceP (noValueECE (fmap unSequenceP sample_vCE) es)-  prependErrorsECE sample_vCE es1 = fmap (prependErrorsECE (fmap unSequenceP sample_vCE) es1)--  -- getMaybeValueECE sample_es (SequenceP a) = fmap SequenceP (getMaybeValueECE sample_es a)-  -- getErrorsECE sample_vCE (SequenceP a) = getErrorsECE (fmap unSequenceP sample_vCE) a--instance-  (Arrow to, SuitableForCE es, CanEnsureCE es a)-  =>-  CanEnsureCE es (SequenceA to a)-  where-  type EnsureCE es (SequenceA to a) = SequenceA to (EnsureCE es a)-  type EnsureNoCE es (SequenceA to a) = SequenceA to (EnsureNoCE es a)--  ensureCE sample_es = fmapSeq (ensureCE sample_es)-  deEnsureCE sample_es = Right . fmapSeq (removeEither . deEnsureCE sample_es)-    where-    removeEither (Right a) = a-    removeEither (Left es) = error $ "Sequence deEnsureCE: " ++ show es-  ensureNoCE sample_es = (\v -> (Just v, mempty)) . fmapSeq (removeES . ensureNoCE sample_es)-    where-    removeES (Just a, es) | not (hasCertainError es) = a-    removeES (_, es) = error $ "WithGlobalParam ensureNoCE: " ++ show es-    -- es =--  noValueECE _sample_vCE _es =-    error "noValueECE not implemented for Sequence yet"--  prependErrorsECE (_sample_vCE :: Maybe (SequenceA to a)) es1 =-    fmapSeq (prependErrorsECE (Nothing :: Maybe a) es1)--  -- getMaybeValueECE sample_es = Just . fmapSeq (removeJust . getMaybeValueECE sample_es)-  --   where-  --   removeJust (Just a) = a-  --   removeJust _ = error "getMaybeValueECE failed for a Sequence"-  -- getErrorsECE _sample_mv _s =-  --   error "getErrorsECE not implemented for Sequence yet"--instance-  (QAArrow to, ConvertibleWithPrecision Rational a, CanSetPrecision a, SuitableForSeq a)-  =>-  ConvertibleExactly Rational (SequenceA to a)-  where-  safeConvertExactly x =-    Right $ newSeq a (show x) [] (\_src -> arr $ seqByPrecision2CauchySeq (flip convertP x) . bits)-    where-    a = convertP (prec 2) x--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Dyadic |]]-  (\ t -> [d|--    instance-      (QAArrow to, ConvertibleExactly $t a, CanSetPrecision a, SuitableForSeq a)-      =>-      ConvertibleExactly $t (SequenceA to a)-      where-      safeConvertExactly x =-        Right $ newSeq a (show x) [] (\_src -> arr $ flip setPrecisionAtLeastAccuracy a . bits)-        where-        a = convertExactly x--  |]))
− src/AERN2/Utils/Arrows.hs 
@@ -1,58 +0,0 @@-{-|-    Module      :  AERN2.Utils.Arrows-    Description :  Miscellaneous arrow-generic functions-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Miscellaneous arrow-generic functions--}-module AERN2.Utils.Arrows-(-  mapA, mapWithIndexA-  , CanSwitchArrow(..)-)-where--import MixedTypesNumPrelude--- import qualified Prelude as P--- import Text.Printf--import Control.Arrow--{- Arrow swiching mechanism and application to QA arrow conversion -}--class CanSwitchArrow to1 to2 where-  switchArrow :: (a `to1` b) -> (a `to2` b)-  -- switchArrow2 :: (a `to1` (b `to1` c)) -> (a `to2` (b `to2` c))--instance (Arrow to) => CanSwitchArrow (->) to where-  switchArrow = arr-  -- switchArrow2 = arr . (arr .)--{-| Apply an arrow morphism on all elements of a list -}-mapA :: (ArrowChoice to) => (t1 `to` t2) -> ([t1] `to` [t2])-mapA fA =-  proc list -> do-    case list of-      [] -> returnA -< []-      (x : xs) -> do-        y <- fA -< x-        ys <-mapA fA -< xs-        returnA -< y : ys--{-| Apply an arrow morphism on all elements of a list -}-mapWithIndexA :: (ArrowChoice to) => (Integer -> t1 `to` t2) -> ([t1] `to` [t2])-mapWithIndexA fA = aux 0-  where-  aux i =-    proc list -> do-      case list of-        [] -> returnA -< []-        (x : xs) -> do-          y <- fA i -< x-          ys <- aux (i+1) -< xs-          returnA -< y : ys
− src/AERN2/WithGlobalParam.hs 
@@ -1,40 +0,0 @@-{-|-    Module      :  AERN2.WithGlobalParam-    Description :  adding a global parameter to a type-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable----}-module AERN2.WithGlobalParam-(-  -- * The protocol and type of objects depending on a global parameter-  WithGlobalParamP(..), pWGParam-  , SuitableForWGParam-  , wgprmName, wgprmId, wgprmSources, wgprmRename-  , wgprmQuery, (?), wgprmQueryA, wgprmListQueryA-  , WithGlobalParamA, WithGlobalParam-  , newWGParam, newWGParamSimple-  , fmapWGParam-  -- * auxiliary functions for making new operations-  , unaryOp, binaryOp, binaryOpWithPureArg-)-where---- import MixedTypesNumPrelude--- import qualified Prelude as P---- import Control.Arrow--import AERN2.QA.Protocol-import AERN2.WithGlobalParam.Type-import AERN2.WithGlobalParam.Helpers-import AERN2.WithGlobalParam.Comparison ()-import AERN2.WithGlobalParam.Branching ()-import AERN2.WithGlobalParam.Ring ()-import AERN2.WithGlobalParam.Field ()-import AERN2.WithGlobalParam.Elementary ()
− src/AERN2/WithGlobalParam/Branching.hs 
@@ -1,73 +0,0 @@-{-|-    Module      :  AERN2.WithGlobalParam.Branching-    Description :  branching operations-    Copyright   :  (c) Michal Konecny, Eike Neumann-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Branching operations for WithGlobalParam objects.--}-module AERN2.WithGlobalParam.Branching-(-  -- pickNonZeroWGParamA-)-where--import MixedTypesNumPrelude hiding (id)--- import qualified Prelude as P--import Control.Arrow--import AERN2.QA.Protocol-import AERN2.WithGlobalParam.Type--- import AERN2.WithGlobalParam.Comparison ()---- {- non-zero picking -}------ {-|---   Given a list @[(a1,b1),(a2,b2),...]@ and assuming that---   at least one of @a1,a2,...@ is non-zero, pick one of them---   and return the corresponding pair @(ai,bi)@.------   If none of @a1,a2,...@ is zero, either throw an exception---   or loop forever.---  -}--- pickNonZeroWGParamA ::---   (QAArrow to, CanPickNonZero a)---   =>---   Maybe (QAId to) ->---   [(WithGlobalParamA to prm a, s)] `to` Maybe (WithGlobalParamA to prm a, s)--- pickNonZeroWGParamA src =---     proc seqsAndS -> do---       balls <- wgprmQueryA src -< (map fst seqsAndS, prm)---       let maybeNonZero = pickNonZero $ zip balls seqsAndS---       case maybeNonZero of---         Just (_,result) -> returnA -< Just result---         _ -> startFromAccuracy (ac + 1) -< seqsAndS------ instance (CanPickNonZero a) => CanPickNonZero (WithGlobalParam prm a) where---   pickNonZero = pickNonZeroWGParamA Nothing--{-| lifted if-then-else -}-instance-  (QAArrow to, HasIfThenElse b t-  , SuitableForWGParam prm b, SuitableForWGParam prm t, SuitableForWGParam prm (IfThenElseType b t))-  =>-  HasIfThenElse (WithGlobalParamA to prm b) (WithGlobalParamA to prm t)-  where-  type IfThenElseType (WithGlobalParamA to prm b) (WithGlobalParamA to prm t) = (WithGlobalParamA to prm (IfThenElseType b t))-  ifThenElse (b::WithGlobalParamA to prm b) (e1::WithGlobalParamA to prm t) e2 =-    newWGParam samplePrm sampleT "pif" [AnyProtocolQA b, AnyProtocolQA e1, AnyProtocolQA e2] makeQ-    where-    sampleT = undefined :: (IfThenElseType b t)-    samplePrm = undefined :: Maybe prm-    makeQ (me,_src) =-      proc prm ->-        do-        bP <- wgprmQueryA me -< (b, prm)-        e1P <- wgprmQueryA me -< (e1, prm)-        e2P <- wgprmQueryA me -< (e2, prm)-        returnA -< if bP then e1P else e2P
− src/AERN2/WithGlobalParam/Comparison.hs 
@@ -1,261 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.WithGlobalParam.Comparison-    Description :  comparison operations-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Comparison operations on WithGlobalParam objects.--}-module AERN2.WithGlobalParam.Comparison-(-)-where--import MixedTypesNumPrelude hiding (id)--- import qualified Prelude as P---- import Control.Category (id)-import Control.Arrow--import Control.CollectErrors---- import AERN2.MP.Ball-import AERN2.MP.Dyadic--import AERN2.QA.Protocol--import AERN2.WithGlobalParam.Type-import AERN2.WithGlobalParam.Helpers--{- Boolean ops -}--instance (QAArrow to, HasBools b, SuitableForWGParam prm b) => ConvertibleExactly Bool (WithGlobalParamA to prm b) where-  safeConvertExactly bool =-    do-    b <- safeConvertExactly bool-    Right $ newWGParam Nothing b (show b) [] $ \_me_src -> arr $ const b--instance-  (QAArrow to, CanNeg a, SuitableForWGParam prm a, SuitableForWGParam prm (NegType a))-  =>-  CanNeg (WithGlobalParamA to prm a)-  where-  type NegType (WithGlobalParamA to prm a) = WithGlobalParamA to prm (NegType a)-  negate = unaryOp "neg" negate--instance-  (QAArrow to, CanAndOrAsymmetric a b-  , SuitableForWGParam prm a, SuitableForWGParam prm b, SuitableForWGParam prm (AndOrType a b))-  =>-  CanAndOrAsymmetric (WithGlobalParamA to prm a) (WithGlobalParamA to prm b)-  where-  type AndOrType (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (AndOrType a b)-  and2 = binaryOp "and" and2-  or2 = binaryOp "or" or2--{- equality & order -}--instance-  (QAArrow to, HasEqAsymmetric a b-  , SuitableForWGParam prm a, SuitableForWGParam prm b, SuitableForWGParam prm (EqCompareType a b))-  =>-  HasEqAsymmetric (WithGlobalParamA to prm a) (WithGlobalParamA to prm b)-  where-  type EqCompareType (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (EqCompareType a b)-  equalTo = binaryOp "==" (==)-  notEqualTo = binaryOp "/=" (/=)--instance-  (QAArrow to, HasOrderAsymmetric a b-  , SuitableForWGParam prm a, SuitableForWGParam prm b, SuitableForWGParam prm (OrderCompareType a b))-  =>-  HasOrderAsymmetric (WithGlobalParamA to prm a) (WithGlobalParamA to prm b)-  where-  type OrderCompareType (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (OrderCompareType a b)-  lessThan = binaryOp "<" (<)-  leq = binaryOp "<=" (<=)-  greaterThan = binaryOp ">" (>)-  geq = binaryOp ">=" (>=)--{- comparing CollectErrors and WithGlobalParams -}--instance-  (HasEqAsymmetric (WithGlobalParamA to prm a) b-  , CanEnsureCE es b-  , CanEnsureCE es (EqCompareType (WithGlobalParamA to prm a) b)-  , IsBool (EnsureCE es (EqCompareType (WithGlobalParamA to prm a) b))-  , SuitableForCE es)-  =>-  HasEqAsymmetric (WithGlobalParamA to prm a) (CollectErrors es b)-  where-  type EqCompareType (WithGlobalParamA to prm a) (CollectErrors es b) =-    EnsureCE es (EqCompareType (WithGlobalParamA to prm a) b)-  equalTo = lift2TLCE equalTo--instance-  (HasEqAsymmetric a (WithGlobalParamA to prm b)-  , CanEnsureCE es a-  , CanEnsureCE es (EqCompareType a (WithGlobalParamA to prm b))-  , IsBool (EnsureCE es (EqCompareType a (WithGlobalParamA to prm b)))-  , SuitableForCE es)-  =>-  HasEqAsymmetric (CollectErrors es a) (WithGlobalParamA to prm b)-  where-  type EqCompareType (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (EqCompareType a (WithGlobalParamA to prm b))-  equalTo = lift2TCE equalTo--instance-  (HasOrderAsymmetric (WithGlobalParamA to prm a) b-  , CanEnsureCE es b-  , CanEnsureCE es (OrderCompareType (WithGlobalParamA to prm a) b)-  , IsBool (EnsureCE es (OrderCompareType (WithGlobalParamA to prm a) b))-  , SuitableForCE es)-  =>-  HasOrderAsymmetric (WithGlobalParamA to prm a) (CollectErrors es  b)-  where-  type OrderCompareType (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (OrderCompareType (WithGlobalParamA to prm a) b)-  lessThan = lift2TLCE lessThan-  leq = lift2TLCE leq-  greaterThan = lift2TLCE greaterThan-  geq = lift2TLCE geq--instance-  (HasOrderAsymmetric a (WithGlobalParamA to prm b)-  , CanEnsureCE es a-  , CanEnsureCE es (OrderCompareType a (WithGlobalParamA to prm b))-  , IsBool (EnsureCE es (OrderCompareType a (WithGlobalParamA to prm b)))-  , SuitableForCE es)-  =>-  HasOrderAsymmetric (CollectErrors es a) (WithGlobalParamA to prm b)-  where-  type OrderCompareType (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (OrderCompareType a (WithGlobalParamA to prm b))-  lessThan = lift2TCE lessThan-  leq = lift2TCE leq-  greaterThan = lift2TCE greaterThan-  geq = lift2TCE geq--{- abs -}--instance-  (QAArrow to, CanAbs a, SuitableForWGParam prm a, SuitableForWGParam prm (AbsType a))-  =>-  CanAbs (WithGlobalParamA to prm a)-  where-  type AbsType (WithGlobalParamA to prm a) = WithGlobalParamA to prm (AbsType a)-  abs = unaryOp "abs" abs--{- min/max -}--instance-  (QAArrow to-  , CanMinMaxAsymmetric a b, SuitableForWGParam prm a, SuitableForWGParam prm b, SuitableForWGParam prm (MinMaxType a b))-  =>-  CanMinMaxAsymmetric (WithGlobalParamA to prm a) (WithGlobalParamA to prm b)-  where-  type MinMaxType (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (MinMaxType a b)-  min = binaryOp "min" min-  max = binaryOp "max" max--instance-  (CanMinMaxAsymmetric (WithGlobalParamA to prm a) b-  , CanEnsureCE es b-  , CanEnsureCE es (MinMaxType (WithGlobalParamA to prm a) b)-  , SuitableForCE es)-  =>-  CanMinMaxAsymmetric (WithGlobalParamA to prm a) (CollectErrors es  b)-  where-  type MinMaxType (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (MinMaxType (WithGlobalParamA to prm a) b)-  min = lift2TLCE min-  max = lift2TLCE max--instance-  (CanMinMaxAsymmetric a (WithGlobalParamA to prm b)-  , CanEnsureCE es a-  , CanEnsureCE es (MinMaxType a (WithGlobalParamA to prm b))-  , SuitableForCE es)-  =>-  CanMinMaxAsymmetric (CollectErrors es a) (WithGlobalParamA to prm b)-  where-  type MinMaxType (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (MinMaxType a (WithGlobalParamA to prm b))-  min = lift2TCE min-  max = lift2TCE max--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--    instance-      (QAArrow to-      , CanMinMaxAsymmetric a $t, SuitableForWGParam prm a, SuitableForWGParam prm (MinMaxType a $t))-      =>-      CanMinMaxAsymmetric (WithGlobalParamA to prm a) $t-      where-      type MinMaxType (WithGlobalParamA to prm a) $t = WithGlobalParamA to prm (MinMaxType a $t)-      min = binaryOpWithPureArg "min" min-      max = binaryOpWithPureArg "max" max--    instance-      (QAArrow to-      , CanMinMaxAsymmetric $t b, SuitableForWGParam prm b, SuitableForWGParam prm (MinMaxType $t b))-      =>-      CanMinMaxAsymmetric $t (WithGlobalParamA to prm b)-      where-      type MinMaxType $t (WithGlobalParamA to prm b) = WithGlobalParamA to prm (MinMaxType $t b)-      min = flip $ binaryOpWithPureArg "min" (flip min)-      max = flip $ binaryOpWithPureArg "max" (flip max)--    instance-      (QAArrow to, HasEqAsymmetric a $t-      , SuitableForWGParam prm a, SuitableForWGParam prm (EqCompareType a $t))-      =>-      HasEqAsymmetric (WithGlobalParamA to prm a) $t-      where-      type EqCompareType (WithGlobalParamA to prm a) $t = WithGlobalParamA to prm (EqCompareType a $t)-      equalTo = binaryOpWithPureArg "==" (==)-      notEqualTo = binaryOpWithPureArg "/=" (/=)--    instance-      (QAArrow to, HasEqAsymmetric $t a-      , SuitableForWGParam prm a, SuitableForWGParam prm (EqCompareType $t a))-      =>-      HasEqAsymmetric $t (WithGlobalParamA to prm a)-      where-      type EqCompareType $t (WithGlobalParamA to prm a) = WithGlobalParamA to prm (EqCompareType $t a)-      equalTo = flip $ binaryOpWithPureArg "==" (flip (==))-      notEqualTo = flip $ binaryOpWithPureArg "/=" (flip (/=))--    instance-      (QAArrow to, HasOrderAsymmetric a $t-      , SuitableForWGParam prm a, SuitableForWGParam prm (OrderCompareType a $t))-      =>-      HasOrderAsymmetric (WithGlobalParamA to prm a) $t-      where-      type OrderCompareType (WithGlobalParamA to prm a) $t = WithGlobalParamA to prm (OrderCompareType a $t)-      lessThan = binaryOpWithPureArg "<" (<)-      leq = binaryOpWithPureArg "<=" (<=)-      greaterThan = binaryOpWithPureArg ">" (>)-      geq = binaryOpWithPureArg ">=" (>=)--    instance-      (QAArrow to, HasOrderAsymmetric $t a-      , SuitableForWGParam prm a, SuitableForWGParam prm (OrderCompareType $t a))-      =>-      HasOrderAsymmetric $t (WithGlobalParamA to prm a)-      where-      type OrderCompareType $t (WithGlobalParamA to prm a) = WithGlobalParamA to prm (OrderCompareType $t a)-      lessThan = flip $ binaryOpWithPureArg "<" (flip (<))-      leq = flip $ binaryOpWithPureArg "<=" (flip (<=))-      greaterThan = flip $ binaryOpWithPureArg ">" (flip (>))-      geq = flip $ binaryOpWithPureArg ">=" (flip (>=))--  |]))
− src/AERN2/WithGlobalParam/Elementary.hs 
@@ -1,158 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.WithGlobalParam.Elementary-    Description :  elementary functions on sequences-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Elementary functions on fast converging sequences.--}-module AERN2.WithGlobalParam.Elementary-()-where--import MixedTypesNumPrelude--- import qualified Prelude as P---- import Control.Arrow--import Control.CollectErrors--import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.WithGlobalParam.Type-import AERN2.WithGlobalParam.Helpers-import AERN2.WithGlobalParam.Ring ()-import AERN2.WithGlobalParam.Field ()--{- exp -}--instance-  (QAArrow to, CanExp a-  , SuitableForWGParam prm  a, SuitableForWGParam prm  (ExpType a))-  =>-  CanExp (WithGlobalParamA to prm a)-  where-  type ExpType (WithGlobalParamA to prm a) = WithGlobalParamA to prm (ExpType a)-  exp = unaryOp "exp" exp--{- log -}--instance-  (QAArrow to, CanLog a-  , SuitableForWGParam prm  a, SuitableForWGParam prm  (LogType a))-  =>-  CanLog (WithGlobalParamA to prm a)-  where-  type LogType (WithGlobalParamA to prm a) = WithGlobalParamA to prm (LogType a)-  log = unaryOp "log" log--{- power -}--instance-  (QAArrow to, CanPow a e-  , SuitableForWGParam prm  a, SuitableForWGParam prm  e-  , SuitableForWGParam prm  (PowTypeNoCN a e)-  , SuitableForWGParam prm  (PowType a e))-  =>-  CanPow (WithGlobalParamA to prm a) (WithGlobalParamA to prm e)-  where-  type PowTypeNoCN (WithGlobalParamA to prm a) (WithGlobalParamA to prm e) = WithGlobalParamA to prm (PowTypeNoCN a e)-  powNoCN = binaryOp "^!" powNoCN-  type PowType (WithGlobalParamA to prm a) (WithGlobalParamA to prm e) = WithGlobalParamA to prm (PowType a e)-  pow = binaryOp "^" pow--instance-  (CanPow (WithGlobalParamA to prm a) b-  , CanEnsureCE es b-  , CanEnsureCE es (PowTypeNoCN (WithGlobalParamA to prm a) b)-  , CanEnsureCE es (PowType (WithGlobalParamA to prm a) b)-  , SuitableForCE es)-  =>-  CanPow (WithGlobalParamA to prm a) (CollectErrors es  b)-  where-  type PowTypeNoCN (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (PowTypeNoCN (WithGlobalParamA to prm a) b)-  powNoCN = lift2TLCE powNoCN-  type PowType (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (PowType (WithGlobalParamA to prm a) b)-  pow = lift2TLCE pow--instance-  (CanPow a (WithGlobalParamA to prm b)-  , CanEnsureCE es a-  , CanEnsureCE es (PowType a (WithGlobalParamA to prm b))-  , CanEnsureCE es (PowTypeNoCN a (WithGlobalParamA to prm b))-  , SuitableForCE es)-  =>-  CanPow (CollectErrors es a) (WithGlobalParamA to prm b)-  where-  type PowTypeNoCN (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (PowTypeNoCN a (WithGlobalParamA to prm b))-  powNoCN = lift2TCE powNoCN-  type PowType (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (PowType a (WithGlobalParamA to prm b))-  pow = lift2TCE pow--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Dyadic |], [t| Rational |]]-  (\ t -> [d|--    instance-      (QAArrow to, CanPow a $t-      , SuitableForWGParam prm  a-      , SuitableForWGParam prm  (PowTypeNoCN a $t)-      , SuitableForWGParam prm  (PowType a $t))-      =>-      CanPow (WithGlobalParamA to prm a) $t where-      type PowTypeNoCN (WithGlobalParamA to prm a) $t =-        WithGlobalParamA to prm (PowTypeNoCN a $t)-      powNoCN = binaryOpWithPureArg "^" powNoCN-      type PowType (WithGlobalParamA to prm a) $t =-        WithGlobalParamA to prm (PowType a $t)-      pow = binaryOpWithPureArg "^" pow--    instance-      (QAArrow to, CanPow $t a-      , SuitableForWGParam prm  a-      , SuitableForWGParam prm  (PowTypeNoCN $t a)-      , SuitableForWGParam prm  (PowType $t a))-      =>-      CanPow $t (WithGlobalParamA to prm a) where-      type PowTypeNoCN $t (WithGlobalParamA to prm a) =-        WithGlobalParamA to prm (PowTypeNoCN $t a)-      powNoCN = flip $ binaryOpWithPureArg "^" (flip powNoCN)-      type PowType $t (WithGlobalParamA to prm a) =-        WithGlobalParamA to prm (PowType $t a)-      pow = flip $ binaryOpWithPureArg "^" (flip pow)--  |]))--{- sqrt -}--instance-  (QAArrow to, CanSqrt a-  , CanMinMaxThis a Integer-  , SuitableForWGParam prm  a, SuitableForWGParam prm  (SqrtType a))-  =>-  CanSqrt (WithGlobalParamA to prm a)-  where-  type SqrtType (WithGlobalParamA to prm a) = WithGlobalParamA to prm (SqrtType a)-  sqrt = unaryOp "sqrt" sqrt--{- sine, cosine -}--instance-  (QAArrow to, CanSinCos a-  , SuitableForWGParam prm  a, SuitableForWGParam prm  (SinCosType a))-  =>-  CanSinCos (WithGlobalParamA to prm a)-  where-  type SinCosType (WithGlobalParamA to prm a) = WithGlobalParamA to prm (SinCosType a)-  cos = unaryOp "cos" cos-  sin = unaryOp "sin" sin
− src/AERN2/WithGlobalParam/Field.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.WithGlobalParam.Field-    Description :  field operations-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Field operations on WithGlobalParam objects.--}-module AERN2.WithGlobalParam.Field-(-)-where--import MixedTypesNumPrelude--- import qualified Prelude as P---- import Control.Arrow--import Control.CollectErrors--import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.WithGlobalParam.Type-import AERN2.WithGlobalParam.Helpers--- import AERN2.WithGlobalParam.Ring--{- division -}--instance-  (QAArrow to, CanDiv a b-  , SuitableForWGParam prm  a, SuitableForWGParam prm  b-  , SuitableForWGParam prm  (DivType a b), SuitableForWGParam prm  (DivTypeNoCN a b))-  =>-  CanDiv (WithGlobalParamA to prm a) (WithGlobalParamA to prm b)-  where-  type DivType (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (DivType a b)-  divide = binaryOp "/" divide-  type DivTypeNoCN (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (DivTypeNoCN a b)-  divideNoCN = binaryOp "/" divideNoCN--instance-  (CanDiv (WithGlobalParamA to prm a) b-  , CanEnsureCE es b-  , CanEnsureCE es (DivType (WithGlobalParamA to prm a) b)-  , CanEnsureCE es (DivTypeNoCN (WithGlobalParamA to prm a) b)-  , SuitableForCE es)-  =>-  CanDiv (WithGlobalParamA to prm a) (CollectErrors es  b)-  where-  type DivType (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (DivType (WithGlobalParamA to prm a) b)-  divide = lift2TLCE divide-  type DivTypeNoCN (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (DivTypeNoCN (WithGlobalParamA to prm a) b)-  divideNoCN = lift2TLCE divideNoCN--instance-  (CanDiv a (WithGlobalParamA to prm b)-  , CanEnsureCE es a-  , CanEnsureCE es (DivType a (WithGlobalParamA to prm b))-  , CanEnsureCE es (DivTypeNoCN a (WithGlobalParamA to prm b))-  , SuitableForCE es)-  =>-  CanDiv (CollectErrors es a) (WithGlobalParamA to prm b)-  where-  type DivType (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (DivType a (WithGlobalParamA to prm b))-  divide = lift2TCE divide-  type DivTypeNoCN (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (DivTypeNoCN a (WithGlobalParamA to prm b))-  divideNoCN = lift2TCE divideNoCN--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--  instance-    (QAArrow to, CanDiv a $t, SuitableForWGParam prm  a-    , SuitableForWGParam prm  (DivType a $t), SuitableForWGParam prm  (DivTypeNoCN a $t))-    =>-    CanDiv (WithGlobalParamA to prm a) $t-    where-    type DivType (WithGlobalParamA to prm a) $t = WithGlobalParamA to prm (DivType a $t)-    divide = binaryOpWithPureArg "/" divide-    type DivTypeNoCN (WithGlobalParamA to prm a) $t = WithGlobalParamA to prm (DivTypeNoCN a $t)-    divideNoCN = binaryOpWithPureArg "/" divideNoCN--  instance-    (QAArrow to, CanDiv $t b, SuitableForWGParam prm  b-    , SuitableForWGParam prm  (DivType $t b)-    , SuitableForWGParam prm  (DivTypeNoCN $t b))-    =>-    CanDiv $t (WithGlobalParamA to prm b)-    where-    type DivType $t (WithGlobalParamA to prm b) = WithGlobalParamA to prm (DivType $t b)-    divide = flip $ binaryOpWithPureArg "/" (flip divide)-    type DivTypeNoCN $t (WithGlobalParamA to prm b) = WithGlobalParamA to prm (DivTypeNoCN $t b)-    divideNoCN = flip $ binaryOpWithPureArg "/" (flip divideNoCN)--  |]))
− src/AERN2/WithGlobalParam/Helpers.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE CPP #-}--- #define DEBUG-{-|-    Module      :  AERN2.WithGlobalParam.Helpers-    Description :  helper functions for operations-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Helper functions for defining operations over WithGlobalParam objects.--}-module AERN2.WithGlobalParam.Helpers-(-  -- Operations returning WithGlobalParam-  unaryOp, binaryOp, binaryOpWithPureArg-)-where--#ifdef DEBUG-import Debug.Trace (trace)-#define maybeTrace trace-#define maybeTraceIO putStrLn-#else-#define maybeTrace (\ (_ :: String) t -> t)-#define maybeTraceIO (\ (_ :: String) -> return ())-#endif--import MixedTypesNumPrelude--- import qualified Prelude as P--import Control.Arrow--import AERN2.QA.Protocol-import AERN2.WithGlobalParam.Type--{- generic implementations of operations of different arity -}--unaryOp ::-  (QAArrow to, SuitableForWGParam prm a, SuitableForWGParam prm b)-  =>-  String ->-  (a -> b) ->-  WithGlobalParamA to prm a -> WithGlobalParamA to prm b-unaryOp name op aWGPrm =-  newWGParam samplePrm (op sampleA) name [AnyProtocolQA aWGPrm] makeQ-  where-  WithGlobalParamP samplePrm sampleA = qaProtocol aWGPrm-  makeQ (me, _src) =-    proc ac ->-      do-      a <- wgprmQuery aWGPrm me -< ac-      returnA -< op a--binaryOpWithPureArg ::-  (QAArrow to, SuitableForWGParam prm a, SuitableForWGParam prm c)-  =>-  String -> (a -> t -> c) -> WithGlobalParamA to prm a -> t -> WithGlobalParamA to prm c-binaryOpWithPureArg name op aWGPrm b =-  newWGParam samplePrm (op sampleA b) name [AnyProtocolQA aWGPrm] makeQ-  where-  WithGlobalParamP samplePrm sampleA = qaProtocol aWGPrm-  makeQ (me, _src) =-    proc ac ->-      do-      a <- wgprmQuery aWGPrm me -< ac-      returnA -< op a b--binaryOp ::-  (QAArrow to, SuitableForWGParam prm a, SuitableForWGParam prm b, SuitableForWGParam prm c)-  =>-  String -> (a -> b -> c) -> WithGlobalParamA to prm a -> WithGlobalParamA to prm b -> WithGlobalParamA to prm c-binaryOp name op aWGPrm bWGPrm =-  newWGParam samplePrm (op sampleA sampleB) name [AnyProtocolQA aWGPrm, AnyProtocolQA bWGPrm] makeQ-  where-  WithGlobalParamP samplePrm sampleA = qaProtocol aWGPrm-  WithGlobalParamP _ sampleB = qaProtocol bWGPrm-  makeQ (me, _src) =-    proc ac ->-      do-      a <- wgprmQuery aWGPrm me -< ac-      b <- wgprmQuery bWGPrm me -< ac-      returnA -< op a b
− src/AERN2/WithGlobalParam/Ring.hs 
@@ -1,203 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-    Module      :  AERN2.WithGlobalParam.Ring-    Description :  ring operations-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    Ring operations on WithGlobalParam objects.--}-module AERN2.WithGlobalParam.Ring-(-)-where--import MixedTypesNumPrelude hiding (id)--- import qualified Prelude as P---- import Control.Arrow--import Control.CollectErrors--import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.WithGlobalParam.Type-import AERN2.WithGlobalParam.Helpers--{- addition -}--instance-  (QAArrow to, CanAddAsymmetric a b, SuitableForWGParam prm a, SuitableForWGParam prm b, SuitableForWGParam prm (AddType a b))-  =>-  CanAddAsymmetric (WithGlobalParamA to prm a) (WithGlobalParamA to prm b)-  where-  type AddType (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (AddType a b)-  add = binaryOp "+" add--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--  instance-    (QAArrow to, CanAddAsymmetric a $t, SuitableForWGParam prm a, SuitableForWGParam prm (AddType a $t))-    =>-    CanAddAsymmetric (WithGlobalParamA to prm a) $t-    where-    type AddType (WithGlobalParamA to prm a) $t = WithGlobalParamA to prm (AddType a $t)-    add = binaryOpWithPureArg "+" add--  instance-    (QAArrow to, CanAddAsymmetric $t b, SuitableForWGParam prm b, SuitableForWGParam prm (AddType $t b))-    =>-    CanAddAsymmetric $t (WithGlobalParamA to prm b)-    where-    type AddType $t (WithGlobalParamA to prm b) = WithGlobalParamA to prm (AddType $t b)-    add = flip $ binaryOpWithPureArg "+" (flip add)--  |]))--instance-  (CanAddAsymmetric (WithGlobalParamA to prm a) b-  , CanEnsureCE es b-  , CanEnsureCE es (AddType (WithGlobalParamA to prm a) b)-  , SuitableForCE es)-  =>-  CanAddAsymmetric (WithGlobalParamA to prm a) (CollectErrors es  b)-  where-  type AddType (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (AddType (WithGlobalParamA to prm a) b)-  add = lift2TLCE add--instance-  (CanAddAsymmetric a (WithGlobalParamA to prm b)-  , CanEnsureCE es a-  , CanEnsureCE es (AddType a (WithGlobalParamA to prm b))-  , SuitableForCE es)-  =>-  CanAddAsymmetric (CollectErrors es a) (WithGlobalParamA to prm b)-  where-  type AddType (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (AddType a (WithGlobalParamA to prm b))-  add = lift2TCE add---{- subtraction -}--instance-  (QAArrow to, CanSub a b, SuitableForWGParam prm a, SuitableForWGParam prm b, SuitableForWGParam prm (SubType a b))-  =>-  CanSub (WithGlobalParamA to prm a) (WithGlobalParamA to prm b)-  where-  type SubType (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (SubType a b)-  sub = binaryOp "-" sub---$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--  instance-    (QAArrow to, CanSub a $t, SuitableForWGParam prm a, SuitableForWGParam prm (SubType a $t))-    =>-    CanSub (WithGlobalParamA to prm a) $t-    where-    type SubType (WithGlobalParamA to prm a) $t = WithGlobalParamA to prm (SubType a $t)-    sub = binaryOpWithPureArg "-" sub--  instance-    (QAArrow to, CanSub $t b, SuitableForWGParam prm b, SuitableForWGParam prm (SubType $t b))-    =>-    CanSub $t (WithGlobalParamA to prm b)-    where-    type SubType $t (WithGlobalParamA to prm b) = WithGlobalParamA to prm (SubType $t b)-    sub = flip $ binaryOpWithPureArg "-" (flip sub)--  |]))--instance-  (CanSub (WithGlobalParamA to prm a) b-  , CanEnsureCE es b-  , CanEnsureCE es (SubType (WithGlobalParamA to prm a) b)-  , SuitableForCE es)-  =>-  CanSub (WithGlobalParamA to prm a) (CollectErrors es  b)-  where-  type SubType (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (SubType (WithGlobalParamA to prm a) b)-  sub = lift2TLCE sub--instance-  (CanSub a (WithGlobalParamA to prm b)-  , CanEnsureCE es a-  , CanEnsureCE es (SubType a (WithGlobalParamA to prm b))-  , SuitableForCE es)-  =>-  CanSub (CollectErrors es a) (WithGlobalParamA to prm b)-  where-  type SubType (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (SubType a (WithGlobalParamA to prm b))-  sub = lift2TCE sub---{- multiplication -}--instance-  (QAArrow to, CanMulAsymmetric a b-  , SuitableForWGParam prm a, SuitableForWGParam prm b, SuitableForWGParam prm (MulType a b))-  =>-  CanMulAsymmetric (WithGlobalParamA to prm a) (WithGlobalParamA to prm b)-  where-  type MulType (WithGlobalParamA to prm a) (WithGlobalParamA to prm b) = WithGlobalParamA to prm (MulType a b)-  mul =-    binaryOp "*" mul--instance-  (CanMulAsymmetric (WithGlobalParamA to prm a) b-  , CanEnsureCE es b-  , CanEnsureCE es (MulType (WithGlobalParamA to prm a) b)-  , SuitableForCE es)-  =>-  CanMulAsymmetric (WithGlobalParamA to prm a) (CollectErrors es  b)-  where-  type MulType (WithGlobalParamA to prm a) (CollectErrors es  b) =-    EnsureCE es (MulType (WithGlobalParamA to prm a) b)-  mul = lift2TLCE mul--instance-  (CanMulAsymmetric a (WithGlobalParamA to prm b)-  , CanEnsureCE es a-  , CanEnsureCE es (MulType a (WithGlobalParamA to prm b))-  , SuitableForCE es)-  =>-  CanMulAsymmetric (CollectErrors es a) (WithGlobalParamA to prm b)-  where-  type MulType (CollectErrors es  a) (WithGlobalParamA to prm b) =-    EnsureCE es (MulType a (WithGlobalParamA to prm b))-  mul = lift2TCE mul--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Dyadic |]]-  (\ t -> [d|--  instance-    (QAArrow to, CanMulAsymmetric a $t, SuitableForWGParam prm a, SuitableForWGParam prm (MulType a $t))-    =>-    CanMulAsymmetric (WithGlobalParamA to prm a) $t-    where-    type MulType (WithGlobalParamA to prm a) $t = WithGlobalParamA to prm (MulType a $t)-    mul = binaryOpWithPureArg "*" mul--  instance-    (QAArrow to, CanMulAsymmetric $t b, SuitableForWGParam prm b, SuitableForWGParam prm (MulType $t b))-    =>-    CanMulAsymmetric $t (WithGlobalParamA to prm b)-    where-    type MulType $t (WithGlobalParamA to prm b) = WithGlobalParamA to prm (MulType $t b)-    mul = flip $ binaryOpWithPureArg "*" (flip mul)--  |]))
− src/AERN2/WithGlobalParam/Type.hs 
@@ -1,200 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}--- #define DEBUG-{-|-    Module      :  AERN2.WithGlobalParam.Type-    Description :  Values that depend on a globale state-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    The type of values that depends on an immutable gloabal parameter,-    such as FP precision.--}-module AERN2.WithGlobalParam.Type-(-  -- * The protocol and type of fast converging sequences-  WithGlobalParamP(..), pWGParam-  , SuitableForWGParam-  , wgprmName, wgprmId, wgprmSources, wgprmRename-  , wgprmQuery, wgprmQueryA, wgprmListQueryA-  , WithGlobalParamA, WithGlobalParam-  , newWGParam, newWGParamSimple-  , fmapWGParam-)-where--#ifdef DEBUG-import Debug.Trace (trace)-#define maybeTrace trace-#define maybeTraceIO putStrLn-#else-#define maybeTrace (\ (_ :: String) t -> t)-#define maybeTraceIO (\ (_ :: String) -> return ())-#endif--import MixedTypesNumPrelude--- import qualified Prelude as P--import Control.Arrow-import Control.Monad (join)--import Text.Printf--import Control.CollectErrors---- import AERN2.MP--- import AERN2.MP.Dyadic--import AERN2.QA.Protocol-import AERN2.QA.Strategy.CachedUnsafe ()--{- QA protocol -}--data WithGlobalParamP prm a =-  WithGlobalParamP { withGlobalState_s :: Maybe prm, withGlobalState_a :: a} deriving (Show)--pWGParam :: Maybe prm -> a -> WithGlobalParamP prm a-pWGParam prm a = WithGlobalParamP prm a--instance (Show a, Show prm) => QAProtocol (WithGlobalParamP prm a) where-  type Q (WithGlobalParamP prm a) = prm-  type A (WithGlobalParamP prm a) = a--type SuitableForWGParam prm a = (Show a, Show prm, HasOrderCertainly prm prm)--instance-  SuitableForWGParam prm a-  =>-  QAProtocolCacheable (WithGlobalParamP prm a)-  where-  type QACache (WithGlobalParamP prm a) = Maybe (a, prm)-  newQACache _ = Nothing-  lookupQACache _ cache prm =-    case cache of-      Just (b, prmC) | prm !<=! prmC -> (Just b, Just (logMsg b))-      Just (b, _) -> (Nothing, Just (logMsg b))-      Nothing -> (Nothing, Just ("cache empty"))-    where-    logMsg _b = printf "query: %s; cache: %s" (show prm) (show cache)-  updateQACache _ prm b _ = Just (b, prm)--instance Functor (WithGlobalParamP prm) where-  fmap f (WithGlobalParamP prm a) = WithGlobalParamP prm (f a)--{- Objects -}--type WithGlobalParamA to prm a = QA to (WithGlobalParamP prm a)-type WithGlobalParam prm a = WithGlobalParamA (->) prm a--fmapWGParam ::-  (Arrow to) =>-  (a -> b) -> (WithGlobalParamA to prm a) -> (WithGlobalParamA to prm b)-fmapWGParam f = mapQAsameQ (fmap f) f--wgprmName :: WithGlobalParamA to prm a -> String-wgprmName = qaName----wgprmRename :: (String -> String) -> WithGlobalParamA to prm a -> WithGlobalParamA to prm a-wgprmRename = qaRename--wgprmId :: WithGlobalParamA to prm a -> Maybe (QAId to)-wgprmId = qaId--wgprmSources :: WithGlobalParamA to prm a -> [QAId to]-wgprmSources = qaSources--{-| Get an approximation of the limit with at least the specified accuracy.-   (A specialisation of 'qaMakeQuery' for values with global state.) -}-wgprmQuery :: (QAArrow to) => WithGlobalParamA to prm a -> Maybe (QAId to) -> prm `to` a-wgprmQuery = (?<-)--wgprmQueryA :: (QAArrow to) => (Maybe (QAId to)) -> (WithGlobalParamA to prm a, prm) `to` a-wgprmQueryA = qaMakeQueryA--wgprmListQueryA :: (QAArrow to) => (Maybe (QAId to)) -> ([WithGlobalParamA to prm a], prm) `to` [a]-wgprmListQueryA = qaMakeQueryOnManyA--{- constructions -}--newWGParam ::-  (QAArrow to, SuitableForWGParam prm a)-  =>-  Maybe prm -> a -> String -> [AnyProtocolQA to] -> ((Maybe (QAId to), Maybe (QAId to)) -> prm `to` a) -> WithGlobalParamA to prm a-newWGParam samplePrm sampleA name sources makeQ =-  newQA name sources (pWGParam samplePrm sampleA) samplePrm makeQ--newWGParamSimple ::-  (QAArrow to, SuitableForWGParam prm a)-  =>-  Maybe prm -> a -> ((Maybe (QAId to), Maybe (QAId to)) -> prm `to` a) -> WithGlobalParamA to prm a-newWGParamSimple samplePrm sampleA = newWGParam samplePrm sampleA "simple" []--{- CollectErrors instances -}--instance-  (SuitableForCE es, CanEnsureCE es a)-  =>-  CanEnsureCE es (WithGlobalParamP prm a)-  where-  type EnsureCE es (WithGlobalParamP prm a) = WithGlobalParamP prm (EnsureCE es a)-  type EnsureNoCE es (WithGlobalParamP prm a) = WithGlobalParamP prm (EnsureNoCE es a)--  ensureCE sample_es = fmap (ensureCE sample_es)-  deEnsureCE sample_es (WithGlobalParamP prm a) = fmap (WithGlobalParamP prm) (deEnsureCE sample_es a)-  ensureNoCE sample_es (WithGlobalParamP prm a) =-    (\(ma,es) -> (fmap (WithGlobalParamP prm) ma, es)) (ensureNoCE sample_es a)--  noValueECE sample_vCE es =-    WithGlobalParamP (join $ fmap withGlobalState_s sample_vCE)-      (noValueECE (fmap withGlobalState_a sample_vCE) es)--  prependErrorsECE sample_vCE es (WithGlobalParamP prm aCE) =-    (WithGlobalParamP prm (prependErrorsECE (fmap withGlobalState_a sample_vCE) es aCE))--instance-  (Arrow to, SuitableForCE es, CanEnsureCE es a)-  =>-  CanEnsureCE es (WithGlobalParamA to prm a)-  where-  type EnsureCE es (WithGlobalParamA to prm a) = WithGlobalParamA to prm (EnsureCE es a)-  type EnsureNoCE es (WithGlobalParamA to prm a) = WithGlobalParamA to prm (EnsureNoCE es a)--  ensureCE sample_es = fmapWGParam (ensureCE sample_es)-  deEnsureCE sample_es = Right . fmapWGParam (removeEither . deEnsureCE sample_es)-    where-    removeEither (Right a) = a-    removeEither (Left es) = error $ "WithGlobalParam deEnsureCE: " ++ show es-  ensureNoCE sample_es = (\v -> (Just v, mempty)) . fmapWGParam (removeES . ensureNoCE sample_es)-    where-    removeES (Just a, es) | not (hasCertainError es) = a-    removeES (_, es) = error $ "WithGlobalParam ensureNoCE: " ++ show es-    -- es =--  noValueECE _sample_vCE _es =-    error "noValueECE not implemented for WithGlobalParam yet"--  prependErrorsECE (_sample_vCE :: Maybe (WithGlobalParamA to prm a)) es =-    fmapWGParam (prependErrorsECE (Nothing :: Maybe a) es)---- The following has to be made specific to specific prm and a types--- so that the dependency on the parameter can be expressed------ $(declForTypes---   [[t| Integer |], [t| Int |], [t| Dyadic |]]---   (\ t -> [d|------     instance---       (QAArrow to, ConvertibleExactly $t a, CanSetPrecision a, SuitableForWGParam prm a)---       =>---       ConvertibleExactly $t (WithGlobalParamA to prm a)---       where---       safeConvertExactly x =---         Right $ newWGParam Nothing a (show x) [] (\_src -> arr $ \_prm -> a)---         where---         a = convertExactly x------   |]))
− test/AERN2/RealSpec.hs 
@@ -1,20 +0,0 @@-{-|-    Module      :  AERN2.RealSpec-    Description :  hspec tests for CauchyReal-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--}--module AERN2.RealSpec (spec) where---- import MixedTypesNumPrelude-import AERN2.Real.Tests--import Test.Hspec--spec :: Spec-spec = specCauchyReal
− test/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}