packages feed

AERN-Basics (empty) → 2011.1

raw patch · 48 files changed

+5699/−0 lines, 48 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, criterion, deepseq, directory, random, test-framework, test-framework-quickcheck2

Files

+ AERN-Basics.cabal view
@@ -0,0 +1,101 @@+Name:           AERN-Basics+Version:        2011.1+Cabal-Version:  >= 1.2+Build-Type:     Simple+License:        BSD3+License-File:   LICENCE+Author:         Michal Konecny (Aston University)+Copyright:      (c) 2010 Michal Konecny, Jan Duracz+Maintainer:     mikkonecny@gmail.com+Homepage:       http://code.google.com/p/aern/+Stability:      experimental+Category:       Data, Math+Synopsis:       foundational type classes for approximating exact real numbers+Tested-with:    GHC ==6.12.3+Description:+ Type-classes abstracting various kinds of approximations for exact entities:+ .   +    * those that are /near/ to the exact value due to limited granularity +      (eg floating point numbers with fixed granularity (aka precision) +       approximating real numbers or bounded-degree polynomials with floating point coefficients+       approximating continuous functions)+ .   +    * those that somehow /enclose/ the exact entity, usually using a pair of /endpoints/ + .+ Type classes are provided to capture:+ .   +    * the partial, sometimes semidecidable, natural ordering (<=) used in relation to /nearness/+ .   +    * the partial, sometimes semidecidable, refinement ordering (&#8849;) used in relation to /enclosure/+ .   ++Extra-Source-Files:+    CHANGES++Library+  hs-source-dirs: src+  ghc-options:     -O2+  Build-Depends:+        base >= 4 && < 5,+        containers >= 0.3 && < 0.4,+        QuickCheck >= 2.1 && < 3,+        criterion >= 0.5 && < 0.6,+        deepseq >= 1.1.0.0 && < 1.2,+        random >= 1.0 && < 2.0,+        test-framework >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4+  Exposed-modules:+    Numeric.AERN.Basics.ShowInternals, +    Numeric.AERN.Basics.Exception, +    Numeric.AERN.Basics.Effort, +    Numeric.AERN.Basics.Mutable, +    Numeric.AERN.Basics.Bench, +    Numeric.AERN.Basics.PartialOrdering, +    Numeric.AERN.Basics.NumericOrder, +    Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort, +    Numeric.AERN.Basics.NumericOrder.OpsDefaultEffort, +    Numeric.AERN.Basics.NumericOrder.InPlace.OpsImplicitEffort, +    Numeric.AERN.Basics.NumericOrder.InPlace.OpsDefaultEffort, +    Numeric.AERN.Basics.RefinementOrder, +    Numeric.AERN.Basics.RefinementOrder.OpsImplicitEffort, +    Numeric.AERN.Basics.RefinementOrder.OpsDefaultEffort, +    Numeric.AERN.Basics.RefinementOrder.InPlace.OpsImplicitEffort, +    Numeric.AERN.Basics.RefinementOrder.InPlace.OpsDefaultEffort, +    Numeric.AERN.Basics.Consistency, +    Numeric.AERN.Basics.Laws.Utilities, +    Numeric.AERN.Basics.Laws.Relation, +    Numeric.AERN.Basics.Laws.PartialRelation, +    Numeric.AERN.Basics.Laws.Operation, +    Numeric.AERN.Basics.Laws.RoundedOperation, +    Numeric.AERN.Basics.Laws.OperationRelation, +    Numeric.AERN.Basics.Laws.RoundedOpInPlace, +    Numeric.AERN.Misc.Bool, +    Numeric.AERN.Misc.List, +    Numeric.AERN.Misc.Maybe, +    Numeric.AERN.Misc.QuickCheck, +    Numeric.AERN.Misc.Debug+    +  Other-modules:+    Numeric.AERN.Basics.NumericOrder.PartialComparison+    Numeric.AERN.Basics.NumericOrder.Arbitrary+    Numeric.AERN.Basics.NumericOrder.Extrema+    Numeric.AERN.Basics.NumericOrder.RoundedLattice+    Numeric.AERN.Basics.NumericOrder.RefinementRoundedLattice+    Numeric.AERN.Basics.NumericOrder.InPlace.RoundedLattice+    Numeric.AERN.Basics.NumericOrder.InPlace.RefinementRoundedLattice+    Numeric.AERN.Basics.RefinementOrder.PartialComparison+    Numeric.AERN.Basics.RefinementOrder.Arbitrary+    Numeric.AERN.Basics.RefinementOrder.Extrema+    Numeric.AERN.Basics.RefinementOrder.RoundedBasis+    Numeric.AERN.Basics.RefinementOrder.RoundedLattice+    Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedBasis +    Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedLattice++Executable toolAERN-bench-csv-to-gnuplot+  hs-source-dirs: tools+  ghc-options: -O2+  main-is: BenchCsvToGnuplot.hs+  build-depends:+        base >= 4 && < 5,+        directory >= 1 && < 2++
+ CHANGES view
@@ -0,0 +1,3 @@+2011.1: 6th May 2011+    * initial release of AERN-Basics+
+ LICENCE view
@@ -0,0 +1,30 @@+Copyright (c) 2010 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:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Numeric/AERN/Basics/Bench.hs view
@@ -0,0 +1,123 @@+{-|+    Module      :  Numeric.AERN.Basics.Bench+    Description :  miscellaneous utilities for benchmarking  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Miscellaneous utilities for benchmarking using Criterion.+-}+module Numeric.AERN.Basics.Bench where++import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd++import Numeric.AERN.Basics.Effort ++import Control.DeepSeq+import Criterion+import Criterion.Config+import qualified Criterion.MultiMap as M+import Test.QuickCheck+import Test.QuickCheck.Gen+import System.Random++--runBenchmarksQ ::+--    [(Benchmark, q)] -> [(Double,q)]+--runBenchmarksQ++criterionConfig name samples =+    defaultConfig +    { +        cfgSummaryFile = ljust $ name ++ ".csv", +        cfgSamples = ljust samples, +        cfgResamples = ljust 200, +        cfgPlotSameAxis = ljust True,+        cfgPerformGC = ljust True+--        ,+--        cfgPlot = M.singleton KernelDensity (PDF 1024 780) +    }++mkBenchAreasSequences1 ::+    (RefOrd.ArbitraryOrderedTuple t, EffortIndicator ei, NFData t) =>+    (ei -> t -> String) {-^ function constructing benchmark names -} ->+    (ei -> t -> t) {-^ function to benchmark -} ->+    [(String, RefOrd.Area t)] {-^ areas in the input space and their descriptions; empty means whole space only -} ->+    Int {-^ how many benchmarks to generate -} ->+    ei -> t -> [Benchmark]+mkBenchAreasSequences1 mkComment fnEff [] n initEffort sample =+    mkBenchSequence1 mkComment fnEff Nothing n initEffort sample+mkBenchAreasSequences1 mkComment fnEff areas n initEffort sample =+    map areaSequence areas+    where+    areaSequence (descr, area) = +       bgroup descr $ mkBenchSequence1 mkComment fnEff (Just area) n initEffort sample++mkBenchSequence1 ::+    (RefOrd.ArbitraryOrderedTuple t, EffortIndicator ei, NFData t) =>+    (ei -> t -> String) {-^ function constructing benchmark names -} ->+    (ei -> t -> t) {-^ function to benchmark -} ->+    (Maybe (RefOrd.Area t))  {-^ area in the input space; Nothing means whole space only -} ->+    Int {-^ how many benchmarks to generate -} ->+    ei -> t -> [Benchmark]+mkBenchSequence1 mkComment fnEff maybeArea n initEffort sample =+    map mkBench $ zip3 [1..n] efforts inputs+    where+    mkBench (n, effort, [input]) =+        bench name (nf (\(e,i) -> fnEff e i) (effort, input))+        where+        name =+--           "" ++ showPad 2 n ++ ":" ++ +           mkComment effort input ++ ""+    showPad l n = +        replicate (max 0 (l - (length sn))) '0' ++ sn +        where sn = show n+    _ = [sample] : inputs+    inputs = +        map (\(g, size) -> unGen arbitraryInArea g size) $ zip gs sizes+        -- get a sample sequence (always the same!)+    gs = +        iterate (snd . next) $ mkStdGen 111111321+        -- sequence of random generators+    arbitraryInArea =+       case case maybeArea of+            Nothing -> RefOrd.arbitraryTupleRelatedBy [1] [] []+            (Just area) -> RefOrd.arbitraryTupleInAreaRelatedBy area [1] [] []+       of Just gen -> gen+    sizes = +        concat $ map (replicate 1) $ scanl1 (*) [2,2..] +        -- ie [2,4,8,16..]+--        -- ie [2,2,2,4,4,4,8,8,8..]+    efforts = +        concat $ map (replicate 1) $ effortIncrementSequence initEffort++mkBenchSequence2 mkComment fnEff initEffort sample1 sample2 =+    map mkBench $ zip3 [1..20] efforts inputs+    where+    mkBench (n, effort, (input1, input2)) =+        bench name (nf (\(e,i1,i2) -> fnEff e i1 i2) (effort, input1, input2))+        where+        name =+           "(" ++ showPad 2 n ++ ": " ++ mkComment effort input1 input2 ++ ")"+    showPad l n = +        replicate (max 0 (l - (length sn))) '0' ++ sn +        where sn = show n+    inputs = zip inputs1 inputs2+    _ = sample1 : inputs1+    inputs1 = +        map (\(g, size) -> unGen arbitrary g size) $ zip gs1 sizes+    gs1 = +        iterate (snd . next) $ mkStdGen 1587346765+    _ = sample2 : inputs2+    inputs2 = +        map (\(g, size) -> unGen arbitrary g size) $ zip gs2 sizes+    gs2 = +        iterate (snd . next) $ mkStdGen 658246234+    sizes = +        concat $ map (replicate 3) $ scanl1 (*) [2,2..] +    efforts = +        concat $ map (replicate 10) $ effortIncrementSequence initEffort ++
+ src/Numeric/AERN/Basics/Consistency.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+    Module      :  Numeric.AERN.Basics.Consistency+    Description :  types with consistent and inconsistent values+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Types with consistent and inconsistent values.+-}++module Numeric.AERN.Basics.Consistency where++import Numeric.AERN.Misc.Bool+import Numeric.AERN.Misc.Maybe++import Data.Maybe++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++class HasConsistency t where+    type ConsistencyEffortIndicator t+    consistencyDefaultEffort :: t -> ConsistencyEffortIndicator t+    isConsistentEff :: (ConsistencyEffortIndicator t) -> t -> Maybe Bool+    +class (HasConsistency t) => HasAntiConsistency t where+    isAntiConsistentEff :: (ConsistencyEffortIndicator t) -> t -> Maybe Bool+    flipConsistency :: t -> t+    +class HasThinRepresentative t where+    -- get a value that is both consistent and anticonsistent +    -- as well as close to the argument value+    getThinRepresentative :: t -> t+    +propFlipConsistency :: +    (HasAntiConsistency t, Eq t) => t -> (ConsistencyEffortIndicator t) -> t -> Bool+propFlipConsistency _ effort e =+    (defined eConsistent && defined eFAntiConsistent)+    ===>+    (fromJust eConsistent <===> fromJust eFAntiConsistent)+    where+    eF = flipConsistency e+    eConsistent = isConsistentEff effort e+    eFAntiConsistent =  isAntiConsistentEff effort eF++propConsistencyFlipSelfInverse :: +    (HasAntiConsistency t, Eq t) => t -> t -> Bool+propConsistencyFlipSelfInverse _ e =+    e == (flipConsistency $ flipConsistency e)++testsConsistency :: +    (Arbitrary t, Show t, Eq t,+     HasAntiConsistency t,+     Arbitrary (ConsistencyEffortIndicator t),+     Show (ConsistencyEffortIndicator t)) => +    (String, t) -> Test+testsConsistency (name, sample) =+    testGroup (name ++ " consistency flip")+        [+         testProperty "con<->anticon" (propFlipConsistency sample)+        ,+         testProperty "self inverse" (propConsistencyFlipSelfInverse sample)+        ]
+ src/Numeric/AERN/Basics/Effort.hs view
@@ -0,0 +1,184 @@+{-|+    Module      :  Numeric.AERN.Basics.Effort+    Description :  indicating computational effort for approximate computations+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Indicating computational effort for approximate computations.+-}+module Numeric.AERN.Basics.Effort where++import Numeric.AERN.Misc.List++import Test.QuickCheck++class EffortIndicator t where+    {-| get a range of independent increments to a given effort indicator (may be empty) -}+    effortIncrementVariants :: t -> [t]+    {-| repeat the increment present in the given pair for the larger effort indicator -}+    effortRepeatIncrement :: (t,t) -> t+    {-| get an increasing sequence of effort indicators of the same type +        as long as possible, ideally infinite -}+    effortIncrementSequence :: t -> [t]++newtype Int1To5 = Int1To5 { fromInt1To5 :: Int }+newtype Int1To10 = Int1To10 { fromInt1To10 :: Int }+newtype Int1To20 = Int1To20 { fromInt1To20 :: Int }+newtype Int1To50 = Int1To50 { fromInt1To50 :: Int }+newtype Int1To100 = Int1To100 { fromInt1To100 :: Int }+newtype Int1To1000 = Int1To1000 { fromInt1To1000 :: Int }++instance Show Int1To5 where+    show (Int1To5 i) = show i++instance Show Int1To10 where+    show (Int1To10 i) = show i++instance Show Int1To20 where+    show (Int1To20 i) = show i++instance Show Int1To50 where+    show (Int1To50 i) = show i++instance Show Int1To100 where+    show (Int1To100 i) = show i++instance Show Int1To1000 where+    show (Int1To1000 i) = show i++instance Arbitrary Int1To5 where+    arbitrary =+        do+        i <- choose (1, 5)+        return $ Int1To5 i++instance Arbitrary Int1To10 where+    arbitrary =+        do+        i <- choose (1, 10)+        return $ Int1To10 i++instance Arbitrary Int1To20 where+    arbitrary =+        do+        i <- choose (1, 20)+        return $ Int1To20 i++instance Arbitrary Int1To50 where+    arbitrary =+        do+        i <- choose (1, 50)+        return $ Int1To50 i++instance Arbitrary Int1To100 where+    arbitrary =+        do+        i <- choose (1, 100)+        return $ Int1To100 i++instance Arbitrary Int1To1000 where+    arbitrary =+        do+        i <- choose (1, 1000)+        return $ Int1To1000 i++instance EffortIndicator Int1To5 where+    effortIncrementVariants (Int1To5 i) = [Int1To5 $ i + 1]+    effortRepeatIncrement (Int1To5 i1, Int1To5 i2) = Int1To5 $ i2 + (i2 - i1)+    effortIncrementSequence (Int1To5 i) =+        map Int1To5 $ map (i +) $ fibs12+        where+        fibs12 = scanl (+) 1 (1:fibs12)++instance EffortIndicator Int1To10 where+    effortIncrementVariants (Int1To10 i) = [Int1To10 $ i + 1]+    effortRepeatIncrement (Int1To10 i1, Int1To10 i2) = Int1To10 $ i2 + (i2 - i1)+    effortIncrementSequence (Int1To10 i) =+        map Int1To10 $ map (i +) $ fibs12+        where+        fibs12 = scanl (+) 1 (1:fibs12)++instance EffortIndicator Int1To20 where+    effortIncrementVariants (Int1To20 i) = [Int1To20 $ i + 1]+    effortRepeatIncrement (Int1To20 i1, Int1To20 i2) = Int1To20 $ i2 + (i2 - i1)+    effortIncrementSequence (Int1To20 i) =+        map Int1To20 $ map (i +) $ fibs12+        where+        fibs12 = scanl (+) 1 (1:fibs12)++instance EffortIndicator Int1To50 where+    effortIncrementVariants (Int1To50 i) = [Int1To50 $ i + 1]+    effortRepeatIncrement (Int1To50 i1, Int1To50 i2) = Int1To50 $ i2 + (i2 - i1)+    effortIncrementSequence (Int1To50 i) =+        map Int1To50 $ map (i +) $ fibs12+        where+        fibs12 = scanl (+) 1 (1:fibs12)++instance EffortIndicator Int1To100 where+    effortIncrementVariants (Int1To100 i) = [Int1To100 $ i + 1]+    effortRepeatIncrement (Int1To100 i1, Int1To100 i2) = Int1To100 $ i2 + (i2 - i1)+    effortIncrementSequence (Int1To100 i) =+        map Int1To100 $ map (i +) $ fibs12+        where+        fibs12 = scanl (+) 1 (1:fibs12)++instance EffortIndicator Int1To1000 where+    effortIncrementVariants (Int1To1000 i) = [Int1To1000 $ i + 1]+    effortRepeatIncrement (Int1To1000 i1, Int1To1000 i2) = Int1To1000 $ i2 + (i2 - i1)+    effortIncrementSequence (Int1To1000 i) =+        map Int1To1000 $ map (i +) $ fibs12+        where+        fibs12 = scanl (+) 1 (1:fibs12)++instance EffortIndicator () where+    effortIncrementVariants _ = []+    effortRepeatIncrement _ = ()+    effortIncrementSequence i = []++instance (EffortIndicator t1, EffortIndicator t2) => EffortIndicator (t1, t2)+    where+    effortIncrementVariants (i1, i2) = +        i1Variants ++ i2Variants+        where+        i1Variants =+            map (\i -> (i, i2)) (effortIncrementVariants i1)+        i2Variants =+            map (\i -> (i1, i)) (effortIncrementVariants i2)+    effortRepeatIncrement ((i1, i2), (j1, j2)) = +        (effortRepeatIncrement (i1, j1), effortRepeatIncrement (i2, j2)) +    effortIncrementSequence (i1, i2) =+        case (effortIncrementSequence i1, effortIncrementSequence i2) of+            ([], []) -> []+            (s1, []) -> map (\e -> (e, i2)) s1 +            ([], s2) -> map (\e -> (i1, e)) s2+            (s1, s2) -> zipFill s1 s2+        +instance (EffortIndicator t1, EffortIndicator t2, EffortIndicator t3) => EffortIndicator (t1, t2, t3)+    where+    effortIncrementVariants (i1, i2, i3) = +        i1Variants ++ i2Variants ++ i3Variants+        where+        i1Variants =+            map (\i -> (i, i2, i3)) (effortIncrementVariants i1)+        i2Variants =+            map (\i -> (i1, i, i3)) (effortIncrementVariants i2)+        i3Variants =+            map (\i -> (i1, i2, i)) (effortIncrementVariants i3)+    effortRepeatIncrement ((i1, i2, i3), (j1, j2, j3)) = +        (effortRepeatIncrement (i1, j1), effortRepeatIncrement (i2, j2), effortRepeatIncrement (i3, j3)) +    effortIncrementSequence (i1, i2, i3) =+        case (effortIncrementSequence i1, effortIncrementSequence i2, effortIncrementSequence i3) of+            ([], [], []) -> []+            (s1, [], []) -> map (\e -> (e, i2, i3)) s1 +            ([], s2, []) -> map (\e -> (i1, e, i3)) s2+            ([], [], s3) -> map (\e -> (i1, i2, e)) s3+            (s1, s2, []) -> map (\(e1,e2) -> (e1, e2, i3)) $ zipFill s1 s2 +            (s1, [], s3) -> map (\(e1,e3) -> (e1, i2, e3)) $ zipFill s1 s3 +            ([], s2, s3) -> map (\(e2,e3) -> (i1, e2, e3)) $ zipFill s2 s3 +            (s1, s2, s3) -> zipFill3 s1 s2 s3+        +
+ src/Numeric/AERN/Basics/Exception.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-|+    Module      :  Numeric.AERN.Basics.Exception+    Description :  exception type to signal AERN specific errors  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    An exception type to be thrown on various arithmetic exceptions+    whose proper pure handling would be inefficient.+    'Control.Exception.ArithmeticException' is not+    flexible enough, eg because often we will not be checking+    overflows but DomViolations instead.+    +    The default exeception policy is:+    +    * no operation should ever return DomViolation; when a DomViolation represents "any value"/bottom+      (eg with 0/0 or &infin - &infin),+      it should be rounded up to +&infin; or down to -&infin;; when a DomViolation represent+      an illegal argument exception (eg with log(-1)), an AERN DomViolation exception should+      be thrown with an appropriate message+    +    * intervals support infinite endpoints+    +    * polynomial coefficients must be finite, overflows of coefficients detected+      and result in a special polynomial denoting the constant function +&infin; or -&infin;+-}+module Numeric.AERN.Basics.Exception where++import Prelude hiding (catch)++import Control.Exception+import Data.Typeable+import System.IO.Unsafe++data AERNException =+    AERNException String+    | AERNIllegalValue String+    | AERNDomViolationException String+    | AERNMaybeDomViolationException String+    deriving (Show, Typeable)++instance Exception AERNException++evalCatchAERNExceptions :: String -> t -> Either AERNException t+evalCatchAERNExceptions contextDescription a =+    unsafePerformIO $ catch (evaluateEmbed a) handler+    where+    handler e@(AERNException msg) =+        do+        putStrLn $ "caught AERN exception: " ++ msg+        return (Left e)+    handler e@(AERNIllegalValue msg) =+        do +        putStrLn $ "caught AERN illegal value exception: " ++ msg+        return (Left e)+    handler e@(AERNDomViolationException msg) =+        do +        putStrLn $ "caught AERN operation domain violation exception: " ++ msg+        return (Left e)+    handler e@(AERNMaybeDomViolationException msg) =+        do +        putStrLn $ "caught AERN potential operation domain violation exception: " ++ msg+        return (Left e)+    evaluateEmbed a =+        do+        aa <- evaluate a+        return $ Right aa++evalCatchDomViolationExceptions :: String -> t -> Either AERNException t+evalCatchDomViolationExceptions contextDescription a =+    case evalCatchAERNExceptions contextDescription a of+        Left e@(AERNDomViolationException _) -> Left e+        Left e@(AERNMaybeDomViolationException _) -> Left e+        Left e ->+            unsafePerformIO $+            do+            putStrLn $ contextDescription ++ ": rethrowing" +            throw e+        r -> r++raisesAERNException :: String -> t -> Bool+raisesAERNException contextDescription a =+    case (evalCatchAERNExceptions contextDescription a) of+        (Left _) -> True+        _ -> False++raisesDomViolationException :: String -> t -> Bool+raisesDomViolationException contextDescription a =+    case (evalCatchDomViolationExceptions contextDescription a) of+        (Left _) -> True+        _ -> False++class HasLegalValues t where+  isLegal :: t -> Bool+  +detectIllegalValues :: (HasLegalValues t, Show t) => String -> t -> t+detectIllegalValues contextDescription value +    | isLegal value = value+    | otherwise = +        throw $ AERNIllegalValue $ +            contextDescription ++ ": " ++ show value+
+ src/Numeric/AERN/Basics/Laws/Operation.hs view
@@ -0,0 +1,70 @@+{-|+    Module      :  Numeric.AERN.Basics.Laws.Relation+    Description :  common properties of binary operations +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Common properties of binary operations.+-}+module Numeric.AERN.Basics.Laws.Operation+(+    idempotent, commutative, associative, +    partialIdempotent, partialCommutative, partialAssociative, +    modular, leftDistributive,  rightDistributive+)+where++import Numeric.AERN.Basics.Laws.Utilities++--import qualified Algebra.Laws as NP -- numeric-prelude++idempotent :: (Rel t) -> (Op t) -> t -> Bool+idempotent (==) (*) e = +    (e * e) == e+    +commutative :: (Rel t) -> (Op t) -> t -> t -> Bool+commutative (==) (*) e1 e2 = +    (e1 * e2) == (e2 * e1)++associative :: (Rel t) -> (Op t) -> t -> t -> t -> Bool+associative (==) (*) e1 e2 e3 = +    ((e1 * e2) * e3) == (e1 * (e2 * e3))++modular :: (Rel t) -> (Op t) -> (Op t) -> t -> t -> t -> Bool+modular (==) (/\) (\/) e1 e2 e3 =+    ((e1 /\ e3) \/ (e2 /\ e3)) == (((e1 /\ e3) \/ e2) /\ e3)++leftDistributive :: (Rel t) -> (Op t) -> (Op t) -> t -> t -> t -> Bool+leftDistributive (==) (/\) (\/) e1 e2 e3 =+    (e1 \/ (e2 /\ e3)) == ((e1 \/ e2) /\ (e1 \/ e3))++rightDistributive :: (Rel t) -> (Op t) -> (Op t) -> t -> t -> t -> Bool+rightDistributive (==) (/\) (\/) e1 e2 e3 =+    ((e2 /\ e3) \/ e1) == ((e2 \/ e1) /\ (e3 \/ e1))++partialIdempotent :: (Rel t) -> (PartOp t) -> t -> Bool+partialIdempotent (==) (*?) e = +    case e *? e of +        Just r -> r == e+        _ -> True++partialCommutative :: (Rel t) -> (PartOp t) -> t -> t -> Bool+partialCommutative (==) (*?) e1 e2 = +    case (e1 *? e2, e2 *? e1) of +        (Just e12, Just e21) -> e12 == e21 +        _ -> True++partialAssociative :: (Rel t) -> (PartOp t) -> t -> t -> t -> Bool+partialAssociative (==) (*?) e1 e2 e3 = +    case (e1 *? e2, e2 *? e3) of +        (Just e12, Just e23) -> +            case (e12 *? e3, e1 *? e23) of+                (Just eLR, Just eRL) -> eLR == eRL +                _ -> True+        _ -> True++
+ src/Numeric/AERN/Basics/Laws/OperationRelation.hs view
@@ -0,0 +1,111 @@+{-|+    Module      :  Numeric.AERN.Basics.Laws.OperationRelation+    Description :  common properties linking binary operations with relations +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Common properties linking binary operations with relations.+-}+module Numeric.AERN.Basics.Laws.OperationRelation +(+--    joinOfOrderedPairNonReflexive, meetOfOrderedPairNonReflexive, +    joinOfOrderedPair, meetOfOrderedPair, +    joinAboveOperands, meetBelowOperands,+    partialJoinOfOrderedPair, partialJoinAboveOperands,+    downRoundedJoinOfOrderedPair, upRoundedMeetOfOrderedPair,+    downRoundedPartialJoinOfOrderedPair+)+where++import Numeric.AERN.Basics.Laws.Utilities++import Numeric.AERN.Misc.Bool+import Numeric.AERN.Misc.Maybe++--joinOfOrderedPairNonReflexive ::+--    (PRel t) -> (PRel t) -> (Op t) -> t -> t -> Bool    +--joinOfOrderedPairNonReflexive (==) (<=) (\/) e1 e2 =+--    (e1 <= e2) ===> ((e1 \/ e2) == e2)+--+--meetOfOrderedPairNonReflexive ::+--    (PRel t) -> (PRel t) -> (Op t) -> t -> t -> Bool    +--meetOfOrderedPairNonReflexive (==) (<=) (/\) e1 e2 =+--    (e1 <= e2) ===> ((e1 /\ e2) == e1)++joinOfOrderedPair ::+    (Rel t) -> (PRel t) -> (Op t) -> t -> t -> Bool    +joinOfOrderedPair (==) (<=?) (\/) e1 e2 =+    (defined (e1 <=? e2))+    ===>+    ((e1 <= e2) <===> ((e1 \/ e2) == e2))+    where+    (<=) = assumeTotal2 (<=?)++meetOfOrderedPair ::+    (Rel t) -> (PRel t) -> (Op t) -> t -> t -> Bool    +meetOfOrderedPair (==) (<=?) (/\) e1 e2 =+    (defined (e1 <=? e2)) +    ===>+    ((e1 <= e2) <===> ((e1 /\ e2) == e1))+    where+    (<=) = assumeTotal2 (<=?)++joinAboveOperands ::+    (PRel t) -> (Op t) -> t -> t -> Bool+joinAboveOperands (<=?) (\/) e1 e2 =+    (defined (e1 <=? (e1 \/ e2)) && defined (e2 <=? (e1 \/ e2))) +    ===>+    ((e1 <= (e1 \/ e2)) && (e2 <= (e1 \/ e2)))+    where+    (<=) = assumeTotal2 (<=?)++meetBelowOperands ::+    (PRel t) -> (Op t) -> t -> t -> Bool    +meetBelowOperands (<=?) (/\) e1 e2 =+    (defined ((e1 /\ e2) <=? e1) && defined ((e1 /\ e2) <=? e2)) +    ===>+    (((e1 /\ e2) <= e1) && ((e1 /\ e2) <= e2))+    where+    (<=) = assumeTotal2 (<=?)++partialJoinOfOrderedPair ::+    (Rel t) -> (PRel t) -> (PartOp t) -> t -> t -> Bool    +partialJoinOfOrderedPair (==) (<=?) (\/?) e1 e2 =+    (defined (e1 \/? e2)) ===>+    joinOfOrderedPair (==) (<=?) (assumeTotal2 (\/?)) e1 e2 ++partialJoinAboveOperands ::+    (PRel t) -> (PartOp t) -> t -> t -> Bool    +partialJoinAboveOperands (<=?) (\/?) e1 e2 =+    (defined (e1 \/? e2)) ===>+    joinAboveOperands (<=?) (assumeTotal2 (\/?)) e1 e2++++downRoundedJoinOfOrderedPair ::+    (PRel t) -> (Op t) -> t -> t -> Bool    +downRoundedJoinOfOrderedPair (<=?) (\/.) e1 e2 =+    (defined (e1 <=? e2) && defined (e1 \/. e2 <=? e2)) +    ===>+    ((e1 <= e2) ===> (e1 \/. e2 <= e2))+    where+    (<=) = assumeTotal2 (<=?)++upRoundedMeetOfOrderedPair ::+    (PRel t) -> (Op t) -> t -> t -> Bool    +upRoundedMeetOfOrderedPair (<=?) (/\^) e1 e2 =+    (defined (e1 <=? e2) && defined (e1 <=? (e1 /\^ e2))) +    ===>+    ((e1 <= e2) ===> (e1 <= (e1 /\^ e2)))+    where+    (<=) = assumeTotal2 (<=?)++downRoundedPartialJoinOfOrderedPair ::+    (PRel t) -> (PartOp t) -> t -> t -> Bool    +downRoundedPartialJoinOfOrderedPair (<=?) (\/.?) e1 e2 =+    (defined (e1 \/.? e2)) ===>+    downRoundedJoinOfOrderedPair (<=?) (assumeTotal2 (\/.?)) e1 e2
+ src/Numeric/AERN/Basics/Laws/PartialRelation.hs view
@@ -0,0 +1,46 @@+{-|+    Module      :  Numeric.AERN.Basics.Laws.PartialRelation+    Description :  common properties of partial relations  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Common properties of partial relations.+-}+module Numeric.AERN.Basics.Laws.PartialRelation+(+    partialReflexive, partialTransitive, partialSymmetric,+    partialOrderExtrema+)+where++import Numeric.AERN.Misc.Bool+import Numeric.AERN.Misc.Maybe+import Numeric.AERN.Basics.Laws.Operation+import Numeric.AERN.Basics.Laws.Relation+import Data.Maybe (isNothing)++--import qualified Algebra.Laws as NP -- numeric-prelude++partialReflexive :: (t -> t -> Maybe Bool) -> t -> Bool+partialReflexive (~~?) e = +    trueOrNothing $ e ~~? e +    ++partialTransitive :: (t -> t -> Maybe Bool) -> t -> t -> t -> Bool+partialTransitive (~~?) e1 e2 e3 =+    (and $ map defined [e1 ~~? e2, e2 ~~? e3, e1 ~~? e3]) ===>+    transitive (assumeTotal2 (~~?)) e1 e2 e3++partialSymmetric :: (t -> t -> Maybe Bool) -> t -> t -> Bool+partialSymmetric (~~?) e1 e2 =+    (and $ map defined [e1 ~~? e2, e2 ~~? e1]) ===>+    symmetric (assumeTotal2 (~~?)) e1 e2++partialOrderExtrema (<=?) bottom top e =+    (trueOrNothing $ bottom <=? e) +    && +    (trueOrNothing $ e <=? top)
+ src/Numeric/AERN/Basics/Laws/Relation.hs view
@@ -0,0 +1,38 @@+{-|+    Module      :  Numeric.AERN.Basics.Laws.Relation+    Description :  common properties of relations  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Common properties of binary relations.+-}+module Numeric.AERN.Basics.Laws.Relation+(+    reflexive, transitive, symmetric,+    extrema+)+where++import Numeric.AERN.Misc.Bool++--import qualified Algebra.Laws as NP -- numeric-prelude++reflexive :: (t -> t -> Bool) -> t -> Bool+reflexive (~~) e = +    e ~~ e == True++symmetric :: (t -> t -> Bool) -> t -> t -> Bool+symmetric (~~) e1 e2 = +    e1 ~~ e2 == e2 ~~ e1++transitive :: (t -> t -> Bool) -> t -> t -> t -> Bool+transitive (~~) e1 e2 e3 = +    ((e1 ~~ e2) && (e2 ~~ e3)) ===> (e1 ~~ e3)++extrema (<=) bottom top e =+    bottom <= e && e <= top+
+ src/Numeric/AERN/Basics/Laws/RoundedOpInPlace.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE RankNTypes #-}+{-|+    Module      :  Numeric.AERN.Basics.Laws.InPlace+    Description :  common properties of in-place operations +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Common properties of in-place operations, mainly consistency with +    pure operations.+-}++module Numeric.AERN.Basics.Laws.RoundedOpInPlace where++import Numeric.AERN.Basics.Laws.Utilities+import Numeric.AERN.Basics.Mutable++import Numeric.AERN.Misc.Maybe+import Numeric.AERN.Misc.Bool++import Data.Maybe++inPlaceConsistentWithPure2 ::+    (CanBeMutable t) =>+    (PRel t) ->+    (forall s.OpMutable2 t s) ->+    (forall s.OpMutable2 t s) ->+    (Op t) ->+    (Op t) ->+    t ->+    t ->+    Bool+inPlaceConsistentWithPure2 (<=?)+        opDnInPlace opUpInPlace+        opDnPure opUpPure+        e1 e2 =+    (defined (e1 `opDnInPlacePurified` e2 <=? (e1 `opUpPure` e2)) +        ===> (e1 `opDnInPlacePurified` e2 <= (e1 `opUpPure` e2))) +    && +    (defined (e1 `opDnPure` e2 <=? (e1 `opUpInPlacePurified` e2)) +        ===> (e1 `opDnPure` e2 <= (e1 `opUpInPlacePurified` e2))) +    where+    (<=) = assumeTotal2 (<=?)+    opDnInPlacePurified = mutable2ToPure opDnInPlace+    opUpInPlacePurified = mutable2ToPure opUpInPlace++inPlaceConsistentWithPurePartial2 ::+    (CanBeMutable t) =>+    (PRel t) ->+    (forall s.OpPartialMutable2 t s) ->+    (forall s.OpPartialMutable2 t s) ->+    (PartOp t) ->+    (PartOp t) ->+    t ->+    t ->+    Bool+inPlaceConsistentWithPurePartial2 (<=?)+        opDnInPlace opUpInPlace+        opDnPure opUpPure+        e1 e2 =+    (and $ map isJust $+        [e1OpDnInPlacePurifiedE2,  e1OpUpPureE2, e1OpDnInPlacePurifiedE2, e1OpUpPureE2])+    ===>+    ((defined (fromJust e1OpDnInPlacePurifiedE2 <=? (fromJust e1OpUpPureE2)) +        ===> (fromJust e1OpDnInPlacePurifiedE2 <= (fromJust e1OpUpPureE2))) +    && +    (defined (fromJust e1OpDnPureE2 <=? (fromJust e1OpUpInPlacePurifiedE2)) +        ===> (fromJust e1OpDnPureE2 <= (fromJust e1OpUpInPlacePurifiedE2)))) +    where+    e1OpDnInPlacePurifiedE2 = e1 `opDnInPlacePurified` e2+    e1OpUpInPlacePurifiedE2 = e1 `opUpInPlacePurified` e2+    e1OpDnPureE2 = e1 `opDnPure` e2+    e1OpUpPureE2 = e1 `opUpPure` e2+    (<=) = assumeTotal2 (<=?)+    opDnInPlacePurified = mutablePartial2ToPure opDnInPlace+    opUpInPlacePurified = mutablePartial2ToPure opUpInPlace+
+ src/Numeric/AERN/Basics/Laws/RoundedOperation.hs view
@@ -0,0 +1,170 @@+{-|+    Module      :  Numeric.AERN.Basics.Laws.Relation+    Description :  common properties of rounded binary operations +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Common properties of rounded binary operations.+-}++module Numeric.AERN.Basics.Laws.RoundedOperation where++import Numeric.AERN.Basics.Laws.Utilities+import Numeric.AERN.Basics.Exception++import Numeric.AERN.Misc.Maybe+import Numeric.AERN.Misc.Bool++partialRoundedIdempotent :: +    (Show t, HasLegalValues t) => +    (PRel t) -> +    (PartOp t) -> (PartOp t) -> +    t -> Bool+partialRoundedIdempotent (<=?) (*^?) (*.?) e =+    (defined (e *.? e) && defined (e *^? e))+    ===>+    (roundedIdempotent  (<=?) (*^) (*.) e)+    where+    (*.) = assumeTotal2 (*.?)+    (*^) = assumeTotal2 (*^?)++partialRoundedCommutative :: +    (Show t, HasLegalValues t) => +    (PRel t) -> +    (PartOp t) -> (PartOp t) -> +    t -> t -> Bool+partialRoundedCommutative (<=?) (*^?) (*.?) e1 e2 =+    (and $ map defined [e1 *.? e2, e2 *.? e1, e1 *^? e2, e2 *^? e1])+    ===>+    (roundedCommutative (<=?) (*^) (*.) e1 e2)+    where+    (*.) = assumeTotal2 (*.?)+    (*^) = assumeTotal2 (*^?)++partialRoundedAssociative :: +    (Show t, HasLegalValues t) => +    (PRel t) -> +    (PartOp t) -> (PartOp t) -> +    t -> t -> t -> Bool+partialRoundedAssociative (<=?) (*^?) (*.?) e1 e2 e3 =+    (and $ map defined [e1 *.? e2, (e1 *. e2) *.? e3, e2 *.? e3, e1 *.? (e2 *. e3), +                        e1 *^? e2, (e1 *^ e2) *^? e3, e2 *^? e3, e1 *^? (e2 *^ e3)])+    ===>+    (roundedAssociative (<=?) (*^) (*.) e1 e2 e3)+    where+    (*.) = assumeTotal2 (*.?)+    (*^) = assumeTotal2 (*^?)++roundedUnit :: +    (Show t, HasLegalValues t) => +    t -> (PRel t) -> +    (Op t) -> (Op t) -> +    t -> Bool+roundedUnit unit =+    equalRoundingUpDn11 "roundedUnit" +        (\(*) e -> e) (\(*) e -> unit * e)  ++roundedIdempotent :: +    (Show t, HasLegalValues t) => +    (PRel t) -> +    (Op t) -> (Op t) -> +    t -> Bool+roundedIdempotent =+    equalRoundingUpDn11 "roundedIdempotent" +        (\(*) e -> e) (\(*) e -> e * e)  ++roundedCommutative :: +    (Show t, HasLegalValues t) => +    (PRel t) -> +    (Op t) -> (Op t) -> +    t -> t -> Bool+roundedCommutative = +    equalRoundingUpDn12 "roundedCommutative" +        (\(*) e1 e2 -> e1 * e2) (\(*) e1 e2 -> e2 * e1)  +++roundedAssociative :: +    (Show t, HasLegalValues t) => +    (PRel t) -> +    (Op t) -> (Op t) -> +    t -> t -> t -> Bool+roundedAssociative = +    equalRoundingUpDn13 "roundedAssociative"+        (\(*) e1 e2 e3 -> (e1 * e2) * e3) +        (\(*) e1 e2 e3 -> e1 * (e2 * e3))  ++roundedModular :: +    (Show t, HasLegalValues t) => +    (PRel t) -> (Op t) -> (Op t) -> (Op t) -> (Op t) -> t -> t -> t -> Bool+roundedModular = +    equalRoundingUpDn23 "roundedModular"+        (\(/\) (\/) e1 e2 e3 -> (e1 /\ e3) \/ (e2 /\ e3)) +        (\(/\) (\/) e1 e2 e3 -> ((e1 /\ e3) \/ e2) /\ e3)  ++roundedLeftDistributive :: +    (Show t, HasLegalValues t) => +    (PRel t) -> +    (Op t) -> (Op t) -> (Op t) -> (Op t) -> +    t -> t -> t -> Bool+roundedLeftDistributive = +    equalRoundingUpDn23 "roundedLeftDistributive"+        (\(/\) (\/) e1 e2 e3 -> e1 \/ (e2 /\ e3)) +        (\(/\) (\/) e1 e2 e3 -> (e1 \/ e2) /\ (e1 \/ e3))     ++equalRoundingUpDn11 :: +    (Show t, HasLegalValues t) => +    String ->+    (Expr1Op1 t) -> (Expr1Op1 t) -> (PRel t) -> +    (Op t) -> (Op t) -> +    t -> Bool+equalRoundingUpDn11 contextDescription expr1 expr2  (<=?) (*^) (*.) e =+    leqIfDefined contextDescription (<=?) (expr1 (*.) e) (expr2 (*^) e) +    && +    leqIfDefined contextDescription (<=?) (expr2 (*.) e) (expr1 (*^) e) +    +equalRoundingUpDn12 :: +    (Show t, HasLegalValues t) => +    String ->+    (Expr1Op2 t) -> (Expr1Op2 t) -> (PRel t) -> +    (Op t) -> (Op t) -> +    t -> t -> Bool+equalRoundingUpDn12 contextDescription expr1 expr2  (<=?) (*^) (*.) e1 e2 =+    leqIfDefined contextDescription (<=?) (expr1 (*.) e1 e2) (expr2 (*^) e1 e2) +    && +    leqIfDefined contextDescription (<=?) (expr2 (*.) e1 e2) (expr1 (*^) e1 e2) +    +equalRoundingUpDn13 :: +    (Show t, HasLegalValues t) => +    String ->+    (Expr1Op3 t) -> (Expr1Op3 t) -> (PRel t) -> +    (Op t) -> (Op t) -> +    t -> t -> t -> Bool+equalRoundingUpDn13 contextDescription expr1 expr2  (<=?) (*^) (*.) e1 e2 e3 =+    leqIfDefined contextDescription (<=?) (expr1 (*.) e1 e2 e3) (expr2 (*^) e1 e2 e3)+    && +    leqIfDefined contextDescription (<=?) (expr2 (*.) e1 e2 e3) (expr1 (*^) e1 e2 e3) +    +equalRoundingUpDn23 :: +    (Show t, HasLegalValues t) => +    String ->+    (Expr2Op3 t) -> (Expr2Op3 t) -> (PRel t) -> +    (Op t) -> (Op t) -> (Op t) -> (Op t) -> +    t -> t -> t -> Bool+equalRoundingUpDn23 contextDescription expr1 expr2  (<=?) (*^) (**^) (*.) (**.) e1 e2 e3 =+    leqIfDefined contextDescription (<=?) (expr1 (*.) (**.) e1 e2 e3) (expr2 (*^) (**^) e1 e2 e3)+    && +    leqIfDefined contextDescription (<=?) (expr2 (*.) (**.) e1 e2 e3) (expr1 (*^) (**^) e1 e2 e3) +    +leqIfDefined contextDescription (<=?) val1 val2 =+    (defined (val1OK <=? val2OK) ===> (val1OK <= val2OK))+    where+    val1OK = check val1+    val2OK = check val2+    check = detectIllegalValues contextDescription+    (<=) = assumeTotal2 (<=?)+    +
+ src/Numeric/AERN/Basics/Laws/Utilities.hs view
@@ -0,0 +1,50 @@+{-|+    Module      :  Numeric.AERN.Basics.Laws.Utilities+    Description :  utilities for easier definitions of algebraic laws +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Utilities for easier definitions of algebraic laws.+-}+module Numeric.AERN.Basics.Laws.Utilities where++import Numeric.AERN.Basics.Effort++type Expr1 t = t -> t+type Expr2 t = t -> t -> t+type Expr3 t = t -> t -> t -> t++type Expr1Eff ei t = ei -> t -> t+type Expr2Eff ei t = ei -> t -> t -> t+type Expr3Eff ei t = ei -> t -> t -> t -> t++type UnaryOp t = t -> t+type Op t = t -> t -> t+type PartOp t = t -> t -> Maybe t++type UnaryOpEff ei t = ei -> t -> t+type OpEff ei t = ei -> t -> t -> t+type PartOpEff ei t = ei -> t -> t -> Maybe t++type Rel t = t -> t -> Bool+type PRel t = t -> t -> Maybe Bool+type PRelEff ei t = ei -> t -> t -> Maybe Bool++type Expr1Op1 t = (Op t) -> Expr1 t+type Expr1Op2 t = (Op t) -> Expr2 t+type Expr1Op3 t = (Op t) -> Expr3 t+type Expr2Op1 t = (Op t) -> (Op t) -> Expr1 t+type Expr2Op2 t = (Op t) -> (Op t) -> Expr2 t+type Expr2Op3 t = (Op t) -> (Op t) -> Expr3 t++type Expr1UnaryOp1Eff ei t = (UnaryOpEff ei t) -> Expr1Eff ei t+type Expr1Op1Eff ei t = (OpEff ei t) -> Expr1Eff ei t+type Expr1Op2Eff ei t = (OpEff ei t) -> Expr2Eff ei t+type Expr1Op3Eff ei t = (OpEff ei t) -> Expr3Eff ei t+type Expr2Op1Eff ei1 ei2 t = (OpEff ei1 t) -> (OpEff ei2 t) -> Expr1Eff (ei1, ei2) t+type Expr2Op2Eff ei1 ei2 t = (OpEff ei1 t) -> (OpEff ei2 t) -> Expr2Eff (ei1, ei2) t+type Expr2Op3Eff ei1 ei2 t = (OpEff ei1 t) -> (OpEff ei2 t) -> Expr3Eff (ei1, ei2) t
+ src/Numeric/AERN/Basics/Mutable.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-|+    Module      :  Numeric.AERN.Basics.Mutable+    Description :  a type class for ST mutable structures +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    A type class for ST mutable structures.+-}+module Numeric.AERN.Basics.Mutable where++import Control.Monad.ST (ST, runST)+import Data.STRef++class CanBeMutable t where+    {-| +      A mutable version of the type t. The extra parameter is the state of the ST monad run. -}+    data Mutable t :: * -> *++    {-| +      Helper method for extracting the underlying type of a mutable value. Intended only for type inference, +      throws error when evaluated. -}+    getDummySample :: Mutable t s -> t+    getDummySample _ =+        error "AERN internal error: getDummySample should never be evaluated, it serves only type inference"++    {-| Safely create a new mutable variable with the given value -}+    makeMutable :: t -> ST s (Mutable t s)+    {-| Create a new mutable variable with the given value, making the value volatile -}+    unsafeMakeMutable :: t -> ST s (Mutable t s)+    {-| A safe write/update operation -}+    writeMutable :: Mutable t s -> t -> ST s ()+    {-| An unsafe write/update operation; it makes the second argument volatile -}+    unsafeWriteMutable :: Mutable t s -> t -> ST s ()+    {-| A safe read operation, yielding an immutable value -}+    readMutable :: Mutable t s -> ST s t+    {-| An unsafe read operation, yielding an immutable value that may be volatile -}+    unsafeReadMutable :: Mutable t s -> ST s t+    {-| Assign a value from one mutable variable to another  -}+    assignMutable :: Mutable t s -> Mutable t s -> ST s ()+    assignMutable rM aM =+        do+        a <- unsafeReadMutable aM+        writeMutable rM a +    {-| Swap the values of two mutable variables  -}+    swapMutable :: Mutable t s -> Mutable t s -> ST s ()+    swapMutable aM bM =+        do+        a <- unsafeReadMutable aM+        b <- unsafeReadMutable bM+        writeMutable aM b +        writeMutable bM a +    {-| Clone a mutable variable, the first parameter only aids type checking  -}+    cloneMutable :: Mutable t s -> ST s (Mutable t s)+    cloneMutable aM =+        do+        a <- unsafeReadMutable aM+        makeMutable a ++instance (CanBeMutable t) => CanBeMutable (Maybe t) where+    data Mutable (Maybe t) s =+        MMaybe { unMMaybe :: STRef s (Maybe t) }+    makeMutable a = +        do+        v <- newSTRef a+        return $ MMaybe v+    unsafeMakeMutable = makeMutable+    writeMutable (MMaybe v) a = writeSTRef v a  +    unsafeWriteMutable = writeMutable+    readMutable (MMaybe v) = readSTRef v  +    unsafeReadMutable = readMutable ++type OpMutable1 t s = +    (Mutable t s) -> (Mutable t s) -> ST s () ++type OpMutable1Eff ei t s = +    ei -> (Mutable t s) -> (Mutable t s) -> ST s () ++type OpMutable2 t s = +    (Mutable t s) -> (Mutable t s) -> (Mutable t s) -> ST s () ++type OpMutable2Eff ei t s = +    ei -> (Mutable t s) -> (Mutable t s) -> (Mutable t s) -> ST s () ++type OpPartialMutable1 t s = +    (Mutable t s) -> (Mutable t s) -> ST s Bool ++type OpPartialMutable2 t s = +    (Mutable t s) -> (Mutable t s) -> (Mutable t s) -> ST s Bool ++type OpPartialMutable2Eff ei t s = +    ei -> (Mutable t s) -> (Mutable t s) -> (Mutable t s) -> ST s Bool ++type OpMutableNonmut t nonmut s = +    (Mutable t s) -> (Mutable t s) -> nonmut -> ST s () ++type OpNonmut t nonmut s = +    (Mutable t s) -> nonmut -> ST s () ++type OpMutableNonmutEff ei t nonmut s = +    ei -> (Mutable t s) -> (Mutable t s) -> nonmut -> ST s () ++mutable2ToMutable1 ::+    (CanBeMutable t) =>+    OpMutable2 t s -> OpMutable1 t s+mutable2ToMutable1 mutOp aM bM =+    mutOp aM aM bM++--partial2ToPartial1 ::+--    (CanBeMutable t) =>+--    OpPartialMutable2 t s -> OpPartialMutable1 t s+--partial2ToPartial1 mutOp aM bM =+--    -- TODO not clear what the result type should be when result of binary op is Nothing++mutableNonmutToNonmut ::+    (CanBeMutable t) =>+    OpMutableNonmut t tn s -> OpNonmut t tn s+mutableNonmutToNonmut mutOp aM b =+    mutOp aM aM b++mutable1ToPure ::+    (CanBeMutable t) =>+    (forall s . OpMutable1 t s) ->+    (t -> t)+mutable1ToPure mutableFn a =+    runST $+        do+        aM <- makeMutable a+        mutableFn aM aM+        unsafeReadMutable aM++mutable1EffToPure ::+    (CanBeMutable t) =>+    (forall s . OpMutable1Eff eff t s) ->+    (eff -> t -> t)+mutable1EffToPure mutableFn eff a =+    runST $+        do+        aM <- makeMutable a+        mutableFn eff aM aM+        unsafeReadMutable aM++mutable2ToPure ::+    (CanBeMutable t) =>+    (forall s . OpMutable2 t s) ->+    (t -> t -> t)+mutable2ToPure mutableFn a b =+    runST $+        do+        aM <- makeMutable a+        bM <- makeMutable b+        mutableFn aM aM bM+        unsafeReadMutable aM++mutable2EffToPure ::+    (CanBeMutable t) =>+    (forall s . OpMutable2Eff eff t s) ->+    (eff -> t -> t -> t)+mutable2EffToPure mutableFn eff a b =+    runST $+        do+        aM <- makeMutable a+        bM <- unsafeMakeMutable b +        -- TODO is this^ safe?+        -- If so then all similar makes should be made unsafe as well!+        mutableFn eff aM aM bM+        unsafeReadMutable aM++mutablePartial2ToPure :: +    (CanBeMutable t) =>+    (forall s .  OpPartialMutable2 t s) ->+    (t -> t -> Maybe t)+mutablePartial2ToPure mutableFn a b =+    runST $+        do+        resM <- makeMutable a+        aM <- unsafeMakeMutable a+        bM <- unsafeMakeMutable b+        defined <- mutableFn resM aM bM+        case defined of+            False -> return Nothing+            True -> +                do+                res <- unsafeReadMutable resM+                return $ Just res++mutablePartial2EffToPure :: +    (CanBeMutable t) =>+    (forall s .  OpPartialMutable2Eff eff t s) ->+    (eff -> t -> t -> Maybe t)+mutablePartial2EffToPure mutableFn eff =+    mutablePartial2ToPure (mutableFn eff)++mutableNonmutEffToPure ::+    (CanBeMutable t) =>+    (forall s . OpMutableNonmutEff eff t nonmut s) ->+    (eff -> t -> nonmut -> t)+mutableNonmutEffToPure mutableFn eff a b =+    runST $+        do+        aM <- makeMutable a+        mutableFn eff aM aM b+        unsafeReadMutable aM++pureToMutable1 ::+    (CanBeMutable t) =>+    (t -> t) ->+    OpMutable1 t s+pureToMutable1 pureFn resM aM =+    do+    a <- readMutable aM+    unsafeWriteMutable resM (pureFn a)++pureToMutable2 ::+    (CanBeMutable t) =>+    (t -> t -> t) ->+    OpMutable2 t s+pureToMutable2 pureFn resM aM bM =+    do+    a <- readMutable aM+    b <- readMutable bM+    unsafeWriteMutable resM (pureFn a b)++pureToMutable1Eff ::+    (CanBeMutable t) =>+    (eff -> t -> t) ->+    OpMutable1Eff eff t s+pureToMutable1Eff pureFn eff resM aM =+    do+    a <- readMutable aM+    unsafeWriteMutable resM (pureFn eff a)++pureToMutable2Eff ::+    (CanBeMutable t) =>+    (eff -> t -> t -> t) ->+    OpMutable2Eff eff t s+pureToMutable2Eff pureFn eff resM aM bM =+    do+    a <- readMutable aM+    b <- readMutable bM+    unsafeWriteMutable resM (pureFn eff a b)++pureToPartial2Eff ::+    (CanBeMutable t) =>+    (eff -> t -> t -> Maybe t) ->+    OpPartialMutable2Eff eff t s+pureToPartial2Eff pureFn eff resM aM bM =+    do+    a <- readMutable aM+    b <- readMutable bM+    case pureFn eff a b of+        Nothing -> return False+        Just res ->+            do+            unsafeWriteMutable resM res+            return True++pureToMutableNonmutEff ::+    (CanBeMutable t) =>+    (eff -> t -> nonmut -> t) ->+    OpMutableNonmutEff eff t nonmut s+pureToMutableNonmutEff pureFn eff resM aM b =+    do+    a <- readMutable aM+    unsafeWriteMutable resM (pureFn eff a b)++mutable1EffToMutable1 ::+    (CanBeMutable t) =>+    (forall s . OpMutable1Eff eff t s) -> +    (t -> eff) ->+    (forall s . OpMutable1 t s)+mutable1EffToMutable1 op defEff resM aM =+    do+    a <- unsafeReadMutable aM+    op (defEff a) resM aM++mutable2EffToMutable2 ::+    (CanBeMutable t) =>+    (forall s . OpMutable2Eff eff t s) -> +    (t -> eff) ->+    (forall s . OpMutable2 t s)+mutable2EffToMutable2 op defEff resM aM bM =+    do+    a <- unsafeReadMutable aM+    op (defEff a) resM aM bM++partialMutable2EffToPartialMutable2 ::+    (CanBeMutable t) =>+    (forall s . OpPartialMutable2Eff eff t s) -> +    (t -> eff) ->+    (forall s . OpPartialMutable2 t s)+partialMutable2EffToPartialMutable2 op defEff resM aM bM =+    do+    a <- unsafeReadMutable aM+    op (defEff a) resM aM bM++mutableNonmutEffToMutableNonmut ::+    (CanBeMutable t) =>+    (forall s . OpMutableNonmutEff eff t nonmut s) -> +    (t -> eff) ->+    (forall s . OpMutableNonmut t nonmut s)+mutableNonmutEffToMutableNonmut op defEff resM aM b =+    do+    a <- unsafeReadMutable aM+    op (defEff a) resM aM b++mixedEffToMutableNonmut ::+    (CanBeMutable t) =>+    (forall s . OpMutableNonmutEff eff t nonmut s) -> +    (t -> nonmut -> eff) ->+    (forall s . OpMutableNonmut t nonmut s)+mixedEffToMutableNonmut op defEff resM aM b =+    do+    a <- unsafeReadMutable aM+    op (defEff a b) resM aM b++--pureEffToMutable1 ::+--    (CanBeMutable t) =>+--    (eff -> t -> t) ->+--    (t -> eff) ->+--    OpMutable1 t s+--pureEffToMutable1 pureEffFn defEff resM aM =+--    do+--    a <- readMutable aM+--    unsafeWriteMutable resM (pureEffFn (defEff a) a)+--+--pureEffToMutable2 ::+--    (CanBeMutable t) =>+--    (eff -> t -> t -> t) ->+--    (t -> eff) ->+--    OpMutable2 t s+--pureEffToMutable2 pureEffFn defEff resM aM bM =+--    do+--    a <- readMutable aM+--    b <- readMutable bM+--    unsafeWriteMutable resM (pureEffFn (defEff a) a b)+--+--pureEffToMutableNonmut ::+--    (CanBeMutable t) =>+--    (eff -> t -> nonmut -> t) ->+--    (t -> eff) ->+--    OpMutableNonmut t nonmut s+--pureEffToMutableNonmut pureEffFn defEff resM aM b =+--    do+--    a <- readMutable aM+--    unsafeWriteMutable resM (pureEffFn (defEff a) a b)+--+--pureMixedEffToMutableNonmut ::+--    (CanBeMutable t) =>+--    (eff -> t -> nonmut -> t) ->+--    (t -> nonmut -> eff) ->+--    OpMutableNonmut t nonmut s+--pureMixedEffToMutableNonmut pureEffFn defEff resM aM b =+--    do+--    a <- readMutable aM+--    unsafeWriteMutable resM (pureEffFn (defEff a b) a b)++--propWriteRead :: +--propWriteWriteRead ::+--propWriteWriteReadConcurrent ::
+ src/Numeric/AERN/Basics/NumericOrder.hs view
@@ -0,0 +1,35 @@+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder+    Description :  classical and approximate lattices (<,max,min)  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Type classes representing classical as well as approximate +    Comparisons and lattices with the numerical order notation (<,max,min).+    +    This module is meant to be imported qualified.+    It is recommended to use the prefix NumOrd.+-}+module Numeric.AERN.Basics.NumericOrder +(+    module Numeric.AERN.Basics.NumericOrder.PartialComparison,+    module Numeric.AERN.Basics.NumericOrder.Arbitrary,+    module Numeric.AERN.Basics.NumericOrder.Extrema,+    module Numeric.AERN.Basics.NumericOrder.RoundedLattice,+    module Numeric.AERN.Basics.NumericOrder.InPlace.RoundedLattice,+    module Numeric.AERN.Basics.NumericOrder.RefinementRoundedLattice,+    module Numeric.AERN.Basics.NumericOrder.InPlace.RefinementRoundedLattice+)+where++import Numeric.AERN.Basics.NumericOrder.PartialComparison+import Numeric.AERN.Basics.NumericOrder.Arbitrary+import Numeric.AERN.Basics.NumericOrder.Extrema+import Numeric.AERN.Basics.NumericOrder.RoundedLattice+import Numeric.AERN.Basics.NumericOrder.InPlace.RoundedLattice+import Numeric.AERN.Basics.NumericOrder.RefinementRoundedLattice+import Numeric.AERN.Basics.NumericOrder.InPlace.RefinementRoundedLattice
+ src/Numeric/AERN/Basics/NumericOrder/Arbitrary.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.Arbitrary+    Description :  random generation of tuples with various relation constraints  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Random generation of tuples with various relation constraints.+    +    This module is hidden and reexported via its parent NumericOrder. +-}+module Numeric.AERN.Basics.NumericOrder.Arbitrary where++import Prelude hiding (EQ, LT, GT)++import Numeric.AERN.Basics.PartialOrdering++import Numeric.AERN.Misc.Debug++import Data.Maybe+import Data.Ratio+import qualified Data.Map as Map +import qualified Data.Set as Set +++import Test.QuickCheck+import System.Random+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Numeric.AERN.Misc.QuickCheck++import Numeric.AERN.Misc.List+import qualified Data.List as List+import System.IO.Unsafe++{-|+    Comparison with the ability to randomly generate+    pairs and triples of its own elements that are in +    a specific order relation (eg LT or NC).+    +    This is to help with checking properties that+    make sense only for pairs in a certain relation+    where such pairs are rare.+-}+class ArbitraryOrderedTuple t where+    {-| a type of meaningful constraints to place on generation of arbitrary values -}+    type Area t+    {-| a special area that puts no constaints on the values -}+    areaWhole :: t -> Area t+    {-| generator of tuples that satisfy the given relation requirements+        and area restriction, +        nothing if in this structure there are no tuples satisfying these requirements -}+    arbitraryTupleInAreaRelatedBy ::+        (Ord ix, Show ix) =>+        (Area t) -> +        [ix] {-^ how many elements should be generated and with what names -} -> +        [((ix, ix),[PartialOrdering])]+           {-^ required orderings for some pairs of elements -} -> +        Maybe (Gen [t]) {-^ generator for tuples if the requirements make sense -}   +    {-| generator of tuples that satisfy the given relation requirements, +        nothing if in this structure there are no tuples satisfying these requirements -}+    arbitraryTupleRelatedBy ::+        (Ord ix, Show ix) => +        [ix] {-^ how many elements should be generated and with what names -} -> +        [((ix, ix),[PartialOrdering])]+           {-^ required orderings for some pairs of elements -} -> +        Maybe (Gen [t]) {-^ generator for tuples if the requirements make sense -}   +    arbitraryTuple ::   +        Int {-^ how many elements should be generated -} -> +        Maybe (Gen [t]) {-^ generator for tuples if the requirements make sense -}+    arbitraryTuple n = arbitraryTupleRelatedBy [1..n] [] ++data AreaWholeOnly t =+    AreaWholeOnly +    {+        areaWholeSpecialValues :: [t]+    }++arbitraryWhole ::+    (Arbitrary t) =>+    AreaWholeOnly t ->+    Gen t+arbitraryWhole (AreaWholeOnly []) = incrSize arbitrary+arbitraryWhole (AreaWholeOnly specialValues) =+    incrSize $ -- at size 0 we get only 0s...+    do+    useSpecial <- elements [False, True, False, False] +                        -- 1 in 4 values should be special+    case useSpecial of+        True -> elements specialValues+        False -> arbitrary++data AreaLinear t = +    AreaLinear+    {+        areaLinLowerBound :: Maybe t,+        areaLinLowerBoundStrict :: Bool,+        areaLinUpperBound :: Maybe t,+        areaLinUpperBoundStrict :: Bool,+        areaLinSpecialValues :: [t]+    } ++areaLinearWhole :: [t] -> AreaLinear t+areaLinearWhole = AreaLinear Nothing True Nothing True ++arbitraryLinear ::+    (Arbitrary t) =>+    (t,t) {-^ least and greatest element -} -> +    (t -> t) {-^ successor function -} ->+    (t -> t) {-^ predecessor function -} ->+    ((t,t) -> Gen t) {-^ choose function -} -> +    AreaLinear t ->+    Gen t+arbitraryLinear (least, greatest) succ pred choose +        (AreaLinear mlb lbStrict mub ubStrict specialValues) =+    incrSize $ -- at size 0 we get only 0s...+    do+    useSpecial <-+        case specialValues of+            [] -> return False+            _ -> elements [False, True, False, False] +                 -- 1 in 4 values should be special+    case useSpecial of+        True -> elements specialValues+        False -> +            case (mlb, mub) of +                (Nothing, Nothing) -> arbitrary+                _ -> choose (lb, ub) +    where+    lb = +        case (mlb, lbStrict) of+            (Nothing, _) -> least+            (Just lb, True) -> lb+            (Just lb, False) -> succ lb+    ub = +        case (mub, ubStrict) of+            (Nothing, _) -> greatest+            (Just ub, True) -> ub+            (Just ub, False) -> pred ub+++instance ArbitraryOrderedTuple Int where+    type (Area Int) = AreaWholeOnly Int+    areaWhole _ = AreaWholeOnly [-1,0,1]+    arbitraryTupleInAreaRelatedBy area = +        linearArbitraryTupleRelatedBy $ arbitraryWhole area+    arbitraryTupleRelatedBy =+        linearArbitraryTupleRelatedBy $ incrSize arbitrary++instance ArbitraryOrderedTuple Integer where+    type (Area Integer) = AreaWholeOnly Integer+    areaWhole _ = AreaWholeOnly [-1,0,1]+    arbitraryTupleInAreaRelatedBy area = +        linearArbitraryTupleRelatedBy $ arbitraryWhole area+    arbitraryTupleRelatedBy =+        linearArbitraryTupleRelatedBy $ incrSize arbitrary++instance ArbitraryOrderedTuple Rational where+    type (Area Rational) = (AreaLinear Int, AreaLinear Int)+    areaWhole _ = (areaLinearWhole [-1,0,1], areaLinearWhole [0])+    arbitraryTupleInAreaRelatedBy (numeratorArea, preDenominatorArea) = +        linearArbitraryTupleRelatedBy chooseRational+        where+        chooseRational = +            do+            num <- arbitraryIntInArea numeratorArea+            preDenom <- arbitraryIntInArea preDenominatorArea+            return $ (toInteger num) % (1 + (abs $ toInteger preDenom))+        arbitraryIntInArea = arbitraryLinear (minInt, maxInt) succ pred choose  +        maxInt = maxBound+        minInt = minBound+    arbitraryTupleRelatedBy =+        linearArbitraryTupleRelatedBy $ incrSize arbitrary++--data AreaDouble =+--    AreaDouble+--    {+--        areaDblExp :: AreaLinear Int,+--        areaDblEncourageOne :: Bool,+--        areaDblAllowPos :: Bool,+--        areaDblAllowNeg :: Bool+--    }+    +areaDoubleSmall :: AreaLinear Double+areaDoubleSmall =+    AreaLinear (Just $ -256) False (Just 256) False [0,-1,1]++instance ArbitraryOrderedTuple Double where+    type (Area Double) = AreaLinear Double+    areaWhole _ = areaLinearWhole [-1/0,-1,0,1,1/0]+    arbitraryTupleInAreaRelatedBy area = +        linearArbitraryTupleRelatedBy +                (arbitraryLinear (-maxDbl, maxDbl) id id chooseDbl area)+        where+        maxDbl = encodeFloat 1 (maxExp - 1)+        chooseDbl (lb, ub) =+            do+            exp <- chooseNearerZero (expLb, expUb)+            case exp == expUb of+                True -> choose (lb, ub)+                False -> chooseWithExp exp+            where+            chooseNearerZero (lo, hi) =+--                unsafePrint ("chooseNearerZero: "+--                    ++ "\n loDT = " ++ show loDT+--                    ++ "\n hiDT = " ++ show hiDT+--                ) $+                do+                eDT <- choose (loDT, hiDT)+                return $ round $ transform eDT +                where+                loDT = transformInv loD+                hiDT = transformInv hiD+                transform :: Double -> Double+                transform x = x*x*x/1000000 -- 100^3 = 1000000+                transformInv x +                    | x > 0 = 100 * exp ((log x)/3)+                    | x < 0 = - (transformInv (-x))+                    | otherwise = 0+                loD = fromInteger $ toInteger lo+                hiD = fromInteger $ toInteger hi+            expLb = +                case (lb <= 0 && ub >= 0) of+                    True -> minExp+                    False -> min lbExp ubExp+            expUb = max lbExp ubExp+            lbExp = case lb == 0 of True -> minExp; False -> exponent lb+            ubExp = case ub == 0 of True -> minExp; False -> exponent ub+            chooseWithExp exp =+                do+                signif <- choose (0.5,2)+                let validCandidates = deriveValidCandidates $ signif * (encodeFloat 1 exp)+                case validCandidates of+                    [] -> chooseWithExp exp+                    _ -> elements validCandidates+            deriveValidCandidates d =+                filter valid [d,-d]+                where+                valid d = lb <= d && d <= ub+        (minExp, maxExp) = floatRange (0 :: Double)+    arbitraryTupleRelatedBy =+        arbitraryTupleInAreaRelatedBy areaDoubleSmall+       -- When generating Double numbers for testing, try to avoid overflows+       -- as we cannot usually overcome overflows when we cannot increase +       -- the granularity (aka precision) of the floating point type.+       -- Exp overflows at around 700.++--        where+--        AreaLinear mmin minStrict mmax maxStrict = bounds+--        min = +--            case mmin of +--                Nothing -> +--                Just m -> +--                    case expMinStrict of+--                        True -> m+1+--                        False -> m+--        expMax = +--            case mexpMax of +--                Nothing -> 480; -- encourage infinity +--                Just m -> +--                    case expMaxStrict of+--                        True -> m-1+--                        False -> m+--        arbitaryBoundedDouble =+--           do+--           d <- arbitrary+--           e <- case (expMin < 0 && expMax > 0) of+--               True -> +--                   do +--                   e1 <- choose (0,expMax)+--                   e2 <- choose (-380,-1)+--                   elements [e1,e2]+--               False -> choose (expMin, expMax)+--           s <- elements $ case (encourage [1,1,1,1,0]+--           a <- elements $ case (encourageZero, encourageOne) [-1,0,1]+--           return (buildDouble d e s a)+--        buildDouble d e s a =+--           (s * dE + a)+--           where+--           dE = encodeFloat m (e - 53)+--           (m,_) = decodeFloat (d :: Double)+--           ++{-| Default implementation of linearArbitraryTupleRelatedBy for Ord instances -}   +linearArbitraryTupleRelatedBy ::+    (Ord ix, Show ix, Ord a) =>+    (Gen a) ->+    [ix] ->+    [((ix,ix),[PartialOrdering])] ->+    Maybe (Gen [a])+linearArbitraryTupleRelatedBy givenArbitrary indices constraints =   +       case consistentUnambiguousConstraints of+          [] -> Nothing+          _ -> Just $+              do+              unambiguousConstraints <- elements consistentUnambiguousConstraints+              let cMap = Map.fromList unambiguousConstraints+              let sortedIndices = List.sortBy (turnIntoOrdering cMap) indices+              let sortedIndicesGrouped = List.groupBy (turnIntoEquality cMap) sortedIndices+              ds <- vectorOf (3 * (length sortedIndicesGrouped)) givenArbitrary+              seed <- arbitrary+              let dsDistinctSorted = getNDistinctSorted seed (length sortedIndicesGrouped) ds+                                      -- here we rely on the following property:+                                      -- it is very unlikely to get less than n distinct+                                      -- elements among 3*n elements generated by givenArbitrary +              return $ +                  map snd $ +                      List.sort $ +                          concat $ +                              zipWith zip sortedIndicesGrouped $ +                                  map repeat dsDistinctSorted+       where+       consistentUnambiguousConstraints =+           pickConsistentOrderings permittedInLinearOrder indices constraints+       turnIntoOrdering cMap a b =+           case (Map.lookup (a,b) cMap, Map.lookup (b,a) cMap) of+               (Just pord, _) -> fromPartialOrdering pord+               (_, Just pord) -> fromPartialOrdering $ partialOrderingTranspose pord+       turnIntoEquality cMap a b =+           case (Map.lookup (a,b) cMap, Map.lookup (b,a) cMap) of+               (Just pord, _) -> pord == EQ+               (_, Just pord) -> pord == EQ++arbitraryPairRelatedBy ::+    (ArbitraryOrderedTuple t) => +    PartialOrdering -> +    Maybe (Gen (t,t))+arbitraryPairRelatedBy rel =+    case arbitraryTupleRelatedBy [1,2] [((1,2),[rel])] of+        Nothing -> Nothing+        Just gen -> Just $+            do+            [e1,e2] <- gen +            return (e1,e2)++arbitraryTripleRelatedBy ::+    (ArbitraryOrderedTuple t) => +    (PartialOrdering, PartialOrdering, PartialOrdering) -> +    Maybe (Gen (t,t,t))+arbitraryTripleRelatedBy (r1, r2, r3) =+    case arbitraryTupleRelatedBy [1,2,3] constraints of+        Nothing -> Nothing+        Just gen -> Just $+            do+            [e1,e2,e3] <- gen+            return (e1, e2, e3)+    where+    constraints = [((1,2),[r1]), ((2,3),[r2]), ((1,3),[r3])]++newtype UniformlyOrderedSingleton t = UniformlyOrderedSingleton t deriving (Show)++{-| type for generating pairs distributed in such a way that all ordering relations +    permitted by this structure have similar probabilities of occurrence -}+data UniformlyOrderedPair t = UniformlyOrderedPair (t,t) deriving (Show)+data LTPair t = LTPair (t,t) deriving (Show)+data LEPair t = LEPair (t,t) deriving (Show)+data NCPair t = NCPair (t,t) deriving (Show)++{-| type for generating triples distributed in such a way that all ordering relation combinations +    permitted by this structure have similar probabilities of occurrence -}+data UniformlyOrderedTriple t = UniformlyOrderedTriple (t,t,t) deriving (Show)+data LTLTLTTriple t = LTLTLTTriple (t,t,t) deriving (Show)+data LELELETriple t = LELELETriple (t,t,t) deriving (Show)+data NCLTLTTriple t = NCLTLTTriple (t,t,t) deriving (Show)+data NCGTGTTriple t = NCGTGTTriple (t,t,t) deriving (Show)+data NCLTNCTriple t = NCLTNCTriple (t,t,t) deriving (Show)++instance (ArbitraryOrderedTuple t) => Arbitrary (UniformlyOrderedSingleton t) where+    arbitrary =+        do+        [elem] <- gen+        return $ UniformlyOrderedSingleton elem+        where+        Just gen = arbitraryTupleRelatedBy [1] []++instance (ArbitraryOrderedTuple t) => Arbitrary (UniformlyOrderedPair t) where+    arbitrary =+        do+        gen <- elements gens+        pair <- gen+        return $ UniformlyOrderedPair pair+        where+        gens = catMaybes $ map arbitraryPairRelatedBy partialOrderingVariants  ++instance (ArbitraryOrderedTuple t) => Arbitrary (LEPair t) where+    arbitrary =+        do+        gen <- elements gens+        pair <- gen+        return $ LEPair pair+        where+        gens = catMaybes $ map arbitraryPairRelatedBy [LT, LT, LT, EQ]  ++instance (ArbitraryOrderedTuple t) => Arbitrary (LTPair t) where+    arbitrary =+        case arbitraryPairRelatedBy LT of+            Nothing -> error $ "LTPair used with an incompatible type"+            Just gen ->+                do+                pair <- gen+                return $ LTPair pair++instance (ArbitraryOrderedTuple t) => Arbitrary (NCPair t) where+    arbitrary =+        case arbitraryPairRelatedBy NC of+            Nothing -> error $ "NCPair used with an incompatible type"+            Just gen ->+                do+                pair <- gen+                return $ NCPair pair++instance (ArbitraryOrderedTuple t) => Arbitrary (UniformlyOrderedTriple t) where+    arbitrary = +        do+        gen <- elements gens+        triple <- gen+        return $ UniformlyOrderedTriple triple+        where+        gens = catMaybes $ map arbitraryTripleRelatedBy partialOrderingVariantsTriples++instance (ArbitraryOrderedTuple t) => Arbitrary (LELELETriple t) where+    arbitrary =+        do+        gen <- elements gens+        triple <- gen+        return $ LELELETriple triple+        where+        gens = +            catMaybes $ +                map arbitraryTripleRelatedBy +                    [(LT,LT,LT), (LT,LT,LT), (LT,LT,LT), (LT,LT,LT), (LT,LT,LT), +                     (EQ,LT,LT), (EQ,LT,LT),+                     (LT,EQ,LT), (LT,EQ,LT),+                     (EQ,EQ,EQ)]  ++instance (ArbitraryOrderedTuple t) => Arbitrary (LTLTLTTriple t) where+    arbitrary =+        case arbitraryTripleRelatedBy (LT, LT, LT) of+            Nothing -> error $ "LTLTLTTriple used with an incompatible type"+            Just gen ->+                do+                triple <- gen+                return $ LTLTLTTriple triple+++propArbitraryOrderedPair ::+    (ArbitraryOrderedTuple t) =>+    (t -> t -> PartialOrdering) -> PartialOrdering -> Bool +propArbitraryOrderedPair compare rel =+     case arbitraryPairRelatedBy rel of+        Nothing -> True+        Just gen ->+             and $ map relOK theSample +             where+             theSample = unsafePerformIO $ sample' gen +             relOK (e1, e2) = compare e1 e2 == rel++propArbitraryOrderedTriple ::+    (ArbitraryOrderedTuple t) =>+    (t -> t -> PartialOrdering) -> (PartialOrdering, PartialOrdering, PartialOrdering) -> Bool +propArbitraryOrderedTriple compare rels@(r1,r2,r3) =+     case arbitraryTripleRelatedBy rels of+        Nothing -> True+        Just gen ->+             and $ map relOK theSample +             where+             theSample = unsafePerformIO $ sample' $ gen+             relOK (e1, e2, e3) = +                and [compare e1 e2 == r1, compare e2 e3 == r2, compare e1 e3 == r3]+++testsArbitraryTuple ::+    (Arbitrary t,+     ArbitraryOrderedTuple t) =>+    (String, t, t -> t -> PartialOrdering) -> Test+testsArbitraryTuple (name, sample, compare)  =+    testGroup (name ++ " arbitrary ordered") $ +        [+         testProperty "pairs" (propArbitraryOrderedPair compare)+        ,+         testProperty "triples" (propArbitraryOrderedTriple compare)+        ]
+ src/Numeric/AERN/Basics/NumericOrder/Extrema.hs view
@@ -0,0 +1,33 @@+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.Extrema+    Description :  types that have least and greatest elements  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Types that have least and greatest elements.+    +    This module is hidden and reexported via its parent NumericOrder. +-}+module Numeric.AERN.Basics.NumericOrder.Extrema where++{-|+    A type with extrema.+-}+class (HasLeast t, HasGreatest t) => HasExtrema t++{-|+    A type with a least element.+-}+class HasLeast t where+    least :: t++{-|+    A type with a greatest element.+-}+class HasGreatest t where+    greatest :: t+
+ src/Numeric/AERN/Basics/NumericOrder/InPlace/OpsDefaultEffort.hs view
@@ -0,0 +1,51 @@+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.InPlace.OpsDefaultEffort+    Description :  convenience directed-rounded in-place lattice operations with default effort parameters  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Convenience directed-rounded in-place lattice operations with default effort parameters.+-}++module Numeric.AERN.Basics.NumericOrder.InPlace.OpsDefaultEffort where++import Numeric.AERN.Basics.Mutable+import Numeric.AERN.Basics.NumericOrder++-- | Downward rounded in-place minimum+minDnInPlace :: (RoundedLatticeInPlace t) => OpMutable2 t s+minDnInPlace = mutable2EffToMutable2 minDnInPlaceEff minmaxDefaultEffort++-- | Upward rounded in-place minimum+minUpInPlace :: (RoundedLatticeInPlace t) => OpMutable2 t s+minUpInPlace = mutable2EffToMutable2 minUpInPlaceEff minmaxDefaultEffort++-- | Downward rounded in-place maximum+maxDnInPlace :: (RoundedLatticeInPlace t) => OpMutable2 t s+maxDnInPlace = mutable2EffToMutable2 maxDnInPlaceEff minmaxDefaultEffort++-- | Upward rounded in-place maximum+maxUpInPlace :: (RoundedLatticeInPlace t) => OpMutable2 t s+maxUpInPlace = mutable2EffToMutable2 maxUpInPlaceEff minmaxDefaultEffort++-- | Outward rounded in-place minimum+minOutInPlace :: (OuterRoundedLatticeInPlace t) => OpMutable2 t s+minOutInPlace = mutable2EffToMutable2 minOutInPlaceEff minmaxOuterDefaultEffort++-- | Outward rounded in-place maximum+maxOutInPlace :: (OuterRoundedLatticeInPlace t) => OpMutable2 t s+maxOutInPlace = mutable2EffToMutable2 maxOutInPlaceEff minmaxOuterDefaultEffort++-- | Inward rounded in-place minimum+minInInPlace :: (InnerRoundedLatticeInPlace t) => OpMutable2 t s+minInInPlace = mutable2EffToMutable2 minInInPlaceEff minmaxInnerDefaultEffort++-- | Inward rounded in-place maximum+maxInInPlace :: (InnerRoundedLatticeInPlace t) => OpMutable2 t s+maxInInPlace = mutable2EffToMutable2 maxInInPlaceEff minmaxInnerDefaultEffort++
+ src/Numeric/AERN/Basics/NumericOrder/InPlace/OpsImplicitEffort.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE ImplicitParams #-}+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.InPlace.OpsImplicitEffort+    Description :  convenience directed-rounded in-place lattice operations with implicit effort parameters  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Convenience directed-rounded in-place lattice operations with implicit effort parameters.+-}++module Numeric.AERN.Basics.NumericOrder.InPlace.OpsImplicitEffort where++import Numeric.AERN.Basics.Mutable+import Numeric.AERN.Basics.NumericOrder++-- | Downward rounded in-place minimum+minDnInPlace ::+    (RoundedLatticeInPlace t, +     ?minmaxEffort :: MinmaxEffortIndicator t) =>+    OpMutable2 t s+minDnInPlace = minDnInPlaceEff ?minmaxEffort++-- | Upward rounded in-place minimum+minUpInPlace ::+    (RoundedLatticeInPlace t, +     ?minmaxEffort :: MinmaxEffortIndicator t) =>+    OpMutable2 t s+minUpInPlace = minUpInPlaceEff ?minmaxEffort++-- | Downward rounded in-place maximum+maxDnInPlace ::+    (RoundedLatticeInPlace t, +     ?minmaxEffort :: MinmaxEffortIndicator t) =>+    OpMutable2 t s+maxDnInPlace = maxDnInPlaceEff ?minmaxEffort++-- | Upward rounded in-place maximum+maxUpInPlace ::+    (RoundedLatticeInPlace t, +     ?minmaxEffort :: MinmaxEffortIndicator t) =>+    OpMutable2 t s+maxUpInPlace = maxUpInPlaceEff ?minmaxEffort++-- | Outward rounded in-place minimum+minOutInPlace :: +    (OuterRoundedLatticeInPlace t, +     ?minmaxOuterEffort :: MinmaxOuterEffortIndicator t) =>+    OpMutable2 t s+minOutInPlace = minOutInPlaceEff ?minmaxOuterEffort++-- | Outward rounded in-place maximum+maxOutInPlace :: +    (OuterRoundedLatticeInPlace t, +     ?minmaxOuterEffort :: MinmaxOuterEffortIndicator t) =>+    OpMutable2 t s+maxOutInPlace = maxOutInPlaceEff ?minmaxOuterEffort++-- | Inward rounded in-place minimum+minInInPlace ::+    (InnerRoundedLatticeInPlace t,+     ?minmaxInnerEffort :: MinmaxInnerEffortIndicator t) =>+    OpMutable2 t s+minInInPlace = minInInPlaceEff ?minmaxInnerEffort++-- | Inward rounded in-place maximum+maxInInPlace ::+    (InnerRoundedLatticeInPlace t,+     ?minmaxInnerEffort :: MinmaxInnerEffortIndicator t) =>+    OpMutable2 t s+maxInInPlace = maxInInPlaceEff ?minmaxInnerEffort
+ src/Numeric/AERN/Basics/NumericOrder/InPlace/RefinementRoundedLattice.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.InPlace.RefinementRoundedLattice+    Description :  numeric-order lattices with refinement-rounded in-place operations  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Numeric-order lattices with refinement-rounded in-place operations.+    +    This module is hidden and reexported via its grand-parent NumericOrder. +-}+module Numeric.AERN.Basics.NumericOrder.InPlace.RefinementRoundedLattice +where++import Prelude hiding ((<=))++import Numeric.AERN.Basics.Exception++import Numeric.AERN.Basics.Mutable+import Control.Monad.ST (ST)++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.NumericOrder.Arbitrary+import Numeric.AERN.Basics.NumericOrder.PartialComparison +import Numeric.AERN.Basics.NumericOrder.Extrema+import Numeric.AERN.Basics.NumericOrder.RefinementRoundedLattice++import Numeric.AERN.Basics.Laws.RoundedOpInPlace++import Numeric.AERN.Misc.Maybe++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++{-|+    A type with refinement-outer-rounding numerical-order-lattice operations.+-}+class (OuterRoundedLatticeEffort t, CanBeMutable t) => +    OuterRoundedLatticeInPlace t +    where+    maxOutInPlaceEff :: OpMutable2Eff (MinmaxOuterEffortIndicator t) t s +    minOutInPlaceEff :: OpMutable2Eff (MinmaxOuterEffortIndicator t) t s++maxOutInPlaceEffFromPure,+ minOutInPlaceEffFromPure ::+    (CanBeMutable t, OuterRoundedLattice t) => +    OpMutable2Eff (MinmaxOuterEffortIndicator t) t s  +maxOutInPlaceEffFromPure = pureToMutable2Eff maxOutEff+minOutInPlaceEffFromPure = pureToMutable2Eff minOutEff++maxOutEffFromInPlace,+ minOutEffFromInPlace ::+ (CanBeMutable t, OuterRoundedLatticeInPlace t) =>+ (MinmaxOuterEffortIndicator t) -> t -> t -> t+maxOutEffFromInPlace = mutable2EffToPure maxOutInPlaceEff +minOutEffFromInPlace = mutable2EffToPure minOutInPlaceEff ++{-|+    A type with refinement-inner-rounding numerical-order-lattice operations.+-}+class (InnerRoundedLatticeEffort t, CanBeMutable t) => +    InnerRoundedLatticeInPlace t +    where+    maxInInPlaceEff :: OpMutable2Eff (MinmaxInnerEffortIndicator t) t s +    minInInPlaceEff :: OpMutable2Eff (MinmaxInnerEffortIndicator t) t s+    +maxInInPlaceEffFromPure,+ minInInPlaceEffFromPure ::+    (CanBeMutable t, InnerRoundedLattice t) => +    OpMutable2Eff (MinmaxInnerEffortIndicator t) t s  +maxInInPlaceEffFromPure = pureToMutable2Eff maxInEff+minInInPlaceEffFromPure = pureToMutable2Eff minInEff++maxInEffFromInPlace,+ minInEffFromInPlace ::+ (CanBeMutable t, InnerRoundedLatticeInPlace t) =>+ (MinmaxInnerEffortIndicator t) -> t -> t -> t+maxInEffFromInPlace = mutable2EffToPure maxInInPlaceEff +minInEffFromInPlace = mutable2EffToPure minInInPlaceEff ++class (OuterRoundedLatticeInPlace t, InnerRoundedLatticeInPlace t) => +    RefinementRoundedLatticeInPlace t++propRefinementRoundedLatticeJoinInPlaceConsistentWithPure ::+    (PartialComparison t, +     RefinementRoundedLatticeInPlace t, RefinementRoundedLattice t, +     CanBeMutable t) => +    t -> +    (MinmaxOuterEffortIndicator t, MinmaxInnerEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRefinementRoundedLatticeJoinInPlaceConsistentWithPure sample (minmaxOutEffort, minmaxInEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) =+    inPlaceConsistentWithPure2 (pLeqEff effortComp) +        (maxOutInPlaceEff minmaxOutEffort)  +        (maxInInPlaceEff minmaxInEffort)+        (maxOutEff minmaxOutEffort) +        (maxInEff minmaxInEffort) +        e1 e2  ++propRefinementRoundedLatticeMeetInPlaceConsistentWithPure ::+    (PartialComparison t, +     RefinementRoundedLatticeInPlace t, RefinementRoundedLattice t, +     CanBeMutable t) => +    t -> +    (MinmaxOuterEffortIndicator t, MinmaxInnerEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRefinementRoundedLatticeMeetInPlaceConsistentWithPure sample (minmaxOutEffort, minmaxInEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) =+    inPlaceConsistentWithPure2 (pLeqEff effortComp) +        (minOutInPlaceEff minmaxOutEffort)  +        (minInInPlaceEff minmaxInEffort)+        (minOutEff minmaxOutEffort) +        (minInEff minmaxInEffort) +        e1 e2  ++testsRefinementRoundedLatticeInPlace :: +    (PartialComparison t,+     RefinementRoundedLatticeInPlace t, RefinementRoundedLattice t, +     CanBeMutable t,+     Arbitrary t, Show t, +     Arbitrary (MinmaxOuterEffortIndicator t), Show (MinmaxOuterEffortIndicator t), +     Arbitrary (MinmaxInnerEffortIndicator t), Show (MinmaxInnerEffortIndicator t), +     Arbitrary (PartialCompareEffortIndicator t), Show (PartialCompareEffortIndicator t), +     ArbitraryOrderedTuple t,+     Eq t+     ) => +    (String, t) -> Test+testsRefinementRoundedLatticeInPlace (name, sample) =+    testGroup (name ++ " (min,max) refinement-rounded in-place") $+        [+         testProperty "join in-place=pure"+             (propRefinementRoundedLatticeJoinInPlaceConsistentWithPure sample)+        ,+         testProperty "meet in-place=pure"+             (propRefinementRoundedLatticeMeetInPlaceConsistentWithPure sample)+        ]+
+ src/Numeric/AERN/Basics/NumericOrder/InPlace/RoundedLattice.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.InPlace.RoundedLattice+    Description :  lattices with directed-rounded in-place operations  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Lattices with directed-rounded in-place operations.+    +    This module is hidden and reexported via its grand-parent NumericOrder. +-}+module Numeric.AERN.Basics.NumericOrder.InPlace.RoundedLattice +where++import Prelude hiding ((<=))++import Numeric.AERN.Basics.Exception++import Numeric.AERN.Basics.Mutable+import Control.Monad.ST (ST)++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.NumericOrder.Arbitrary+import Numeric.AERN.Basics.NumericOrder.PartialComparison +import Numeric.AERN.Basics.NumericOrder.Extrema+import Numeric.AERN.Basics.NumericOrder.RoundedLattice++import Numeric.AERN.Basics.Laws.RoundedOpInPlace++import Numeric.AERN.Misc.Maybe++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++{-|+    A type with directed-rounding lattice operations.+-}+class +    (RoundedLatticeEffort t, CanBeMutable t) => +    RoundedLatticeInPlace t +    where+    maxUpInPlaceEff :: OpMutable2Eff (MinmaxEffortIndicator t) t s+    maxDnInPlaceEff :: OpMutable2Eff (MinmaxEffortIndicator t) t s+    minUpInPlaceEff :: OpMutable2Eff (MinmaxEffortIndicator t) t s+    minDnInPlaceEff :: OpMutable2Eff (MinmaxEffortIndicator t) t s+    +maxUpInPlaceEffFromPure, + maxDnInPlaceEffFromPure, + minUpInPlaceEffFromPure,+ minDnInPlaceEffFromPure :: +    (CanBeMutable t, RoundedLattice t) => +    OpMutable2Eff (MinmaxEffortIndicator t) t s  +maxUpInPlaceEffFromPure = pureToMutable2Eff maxUpEff +maxDnInPlaceEffFromPure = pureToMutable2Eff maxDnEff +minUpInPlaceEffFromPure = pureToMutable2Eff minUpEff +minDnInPlaceEffFromPure = pureToMutable2Eff minDnEff ++maxUpEffFromInPlace,+ maxDnEffFromInPlace,+ minUpEffFromInPlace,+ minDnEffFromInPlace ::+ (CanBeMutable t, RoundedLatticeInPlace t) =>+ (MinmaxEffortIndicator t) -> t -> t -> t+maxUpEffFromInPlace = mutable2EffToPure $ maxUpInPlaceEff +maxDnEffFromInPlace = mutable2EffToPure $ maxDnInPlaceEff +minUpEffFromInPlace = mutable2EffToPure $ minUpInPlaceEff +minDnEffFromInPlace = mutable2EffToPure $ minDnInPlaceEff ++propRoundedLatticeJoinInPlaceConsistentWithPure ::+    (PartialComparison t, +     RoundedLatticeInPlace t, RoundedLattice t, +     CanBeMutable t) =>+    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeJoinInPlaceConsistentWithPure _ (minmaxEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) =+    inPlaceConsistentWithPure2 (pLeqEff effortComp) +        (maxDnInPlaceEff minmaxEffort)  +        (maxUpInPlaceEff minmaxEffort)+        (maxDnEff minmaxEffort) +        (maxUpEff minmaxEffort) +        e1 e2  ++propRoundedLatticeMeetInPlaceConsistentWithPure ::+    (PartialComparison t, +     RoundedLatticeInPlace t, RoundedLattice t, +     CanBeMutable t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeMeetInPlaceConsistentWithPure _ (minmaxEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) =+    inPlaceConsistentWithPure2 (pLeqEff effortComp) +        (minDnInPlaceEff minmaxEffort)  +        (minUpInPlaceEff minmaxEffort)+        (minDnEff minmaxEffort) +        (minUpEff minmaxEffort) +        e1 e2  ++testsRoundedLatticeInPlace :: +    (PartialComparison t,+     RoundedLatticeInPlace t, RoundedLattice t, +     CanBeMutable t,+     Arbitrary t, Show t, +     Arbitrary (MinmaxEffortIndicator t), Show (MinmaxEffortIndicator t), +     Arbitrary (PartialCompareEffortIndicator t), Show (PartialCompareEffortIndicator t), +     ArbitraryOrderedTuple t,+     Eq t+     ) => +    (String, t) -> Test+testsRoundedLatticeInPlace (name, sample) =+    testGroup (name ++ " (min,max) rounded in-place") $+        [+         testProperty "join in-place=pure"+             (propRoundedLatticeJoinInPlaceConsistentWithPure sample)+        ,+         testProperty "meet in-place=pure"+             (propRoundedLatticeMeetInPlaceConsistentWithPure sample)+        ]+
+ src/Numeric/AERN/Basics/NumericOrder/OpsDefaultEffort.hs view
@@ -0,0 +1,80 @@+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.OpsDefaultEffort+    Description :  convenience binary infix operators with default effort parameters  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Convenience binary infix operators with default effort parameters.+-}++module Numeric.AERN.Basics.NumericOrder.OpsDefaultEffort where++import Numeric.AERN.Basics.NumericOrder++-- | Partial equality+infix 4 ==?, <==>?, </=>?, <?, <=?, >=?, >?++(==?) :: (PartialComparison t) => t -> t -> Maybe Bool+(==?) a = pEqualEff (pCompareDefaultEffort a) a++-- | Partial `is comparable to`+(<==>?) :: (PartialComparison t) => t -> t -> Maybe Bool+(<==>?) a = pComparableEff (pCompareDefaultEffort a) a++-- | Partial `is not comparable to`+(</=>?) :: (PartialComparison t) => t -> t -> Maybe Bool+(</=>?) a = pIncomparableEff (pCompareDefaultEffort a) a++-- | Partial `strictly less than`+(<?) :: (PartialComparison t) => t -> t -> Maybe Bool+(<?) a = pLessEff (pCompareDefaultEffort a) a++-- | Partial `less than or equal to`+(<=?) :: (PartialComparison t) => t -> t -> Maybe Bool+(<=?) a = pLeqEff (pCompareDefaultEffort a) a++-- | Partial `greater than or equal to`+(>=?) :: (PartialComparison t) => t -> t -> Maybe Bool+(>=?) a = pGeqEff (pCompareDefaultEffort a) a++-- | Partial `strictly greater than`+(>?) :: (PartialComparison t) => t -> t -> Maybe Bool+(>?) a = pGreaterEff (pCompareDefaultEffort a) a++-- | Downward rounded minimum+minDn :: (RoundedLattice t) => t -> t -> t+minDn a = minDnEff (minmaxDefaultEffort a) a++-- | Upward rounded minimum+minUp :: (RoundedLattice t) => t -> t -> t+minUp a = minUpEff (minmaxDefaultEffort a) a++-- | Downward rounded maximum+maxDn :: (RoundedLattice t) => t -> t -> t+maxDn a = maxDnEff (minmaxDefaultEffort a) a++-- | Upward rounded maximum+maxUp :: (RoundedLattice t) => t -> t -> t+maxUp a = maxUpEff (minmaxDefaultEffort a) a++-- | Outward rounded minimum+minOut :: (OuterRoundedLattice t) => t -> t -> t+minOut a = minOutEff (minmaxOuterDefaultEffort a) a++-- | Outward rounded maximum+maxOut :: (OuterRoundedLattice t) => t -> t -> t+maxOut a = maxOutEff (minmaxOuterDefaultEffort a) a++-- | Inward rounded minimum+minIn :: (InnerRoundedLattice t) => t -> t -> t+minIn a = minInEff (minmaxInnerDefaultEffort a) a++-- | Inward rounded maximum+maxIn :: (InnerRoundedLattice t) => t -> t -> t+maxIn a = maxInEff (minmaxInnerDefaultEffort a) a++
+ src/Numeric/AERN/Basics/NumericOrder/OpsImplicitEffort.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE ImplicitParams #-}+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort+    Description :  convenience binary infix operators with implicit effort parameters  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Convenience binary infix operators with implicit effort parameters.+-}++module Numeric.AERN.Basics.NumericOrder.OpsImplicitEffort where++import Numeric.AERN.Basics.NumericOrder++infix 4 ==?, <==>?, </=>?, <?, <=?, >=?, >?++-- | Partial equality+(==?) :: +    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool+(==?) = pEqualEff ?pCompareEffort++-- | Partial `is comparable to`.+(<==>?) :: +    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool +(<==>?) = pComparableEff ?pCompareEffort++-- | Partial `is not comparable to`.+(</=>?) :: +    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool +(</=>?) = pIncomparableEff ?pCompareEffort++-- | Partial `strictly less than`+(<?) :: +    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool +(<?) = pLessEff ?pCompareEffort++-- | Partial `less than or equal to`+(<=?) :: +    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool +(<=?) = pLeqEff ?pCompareEffort++-- | Partial `greater than or equal to`+(>=?) :: +    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool +(>=?) = pGeqEff ?pCompareEffort++-- | Partial `strictly greater than`+(>?) :: +    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool+(>?) = pGreaterEff ?pCompareEffort++-- | Downward rounded minimum+minDn :: +    (RoundedLattice t, ?minmaxEffort :: MinmaxEffortIndicator t) =>+    t -> t -> t+minDn = minDnEff ?minmaxEffort++-- | Upward rounded minimum+minUp ::+    (RoundedLattice t, ?minmaxEffort :: MinmaxEffortIndicator t) =>+    t -> t -> t+minUp = minUpEff ?minmaxEffort++-- | Downward rounded maximum+maxDn ::+    (RoundedLattice t, ?minmaxEffort :: MinmaxEffortIndicator t) =>+    t -> t -> t+maxDn = maxDnEff ?minmaxEffort++-- | Upward rounded maximum+maxUp ::+    (RoundedLattice t, ?minmaxEffort :: MinmaxEffortIndicator t) =>+    t -> t -> t+maxUp = maxUpEff ?minmaxEffort++-- | Outward rounded minimum+minOut :: +    (OuterRoundedLattice t, +     ?minmaxOuterEffort :: MinmaxOuterEffortIndicator t) =>+    t -> t -> t+minOut = minOutEff ?minmaxOuterEffort++-- | Outward rounded maximum+maxOut :: +    (OuterRoundedLattice t, +     ?minmaxOuterEffort :: MinmaxOuterEffortIndicator t) =>+    t -> t -> t+maxOut = maxOutEff ?minmaxOuterEffort++-- | Inward rounded minimum+minIn ::+    (InnerRoundedLattice t,+     ?minmaxInnerEffort :: MinmaxInnerEffortIndicator t) =>+    t -> t -> t+minIn = minInEff ?minmaxInnerEffort++-- | Outward rounded maximum+maxIn ::+    (InnerRoundedLattice t,+     ?minmaxInnerEffort :: MinmaxInnerEffortIndicator t) =>+    t -> t -> t+maxIn = maxInEff ?minmaxInnerEffort
+ src/Numeric/AERN/Basics/NumericOrder/PartialComparison.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.ApproxOrder+    Description :  Comparisons in a semidecidable order  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Comparisons in a semidecidable order.+    +    This module is hidden and reexported via its parent NumericOrder. +-}++module Numeric.AERN.Basics.NumericOrder.PartialComparison +where++import Prelude hiding (EQ, LT, GT)++import Numeric.AERN.Basics.NumericOrder.Extrema+import Numeric.AERN.Basics.NumericOrder.Arbitrary++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.Laws.PartialRelation++import Numeric.AERN.Misc.Maybe+import Numeric.AERN.Misc.Bool++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++{-|+    A type with semi-decidable equality and partial order+-}+class PartialComparison t where+    type PartialCompareEffortIndicator t+    pCompareEff :: PartialCompareEffortIndicator t -> t -> t -> Maybe PartialOrdering+    pCompareDefaultEffort :: t -> PartialCompareEffortIndicator t+    +    -- | Partial equality+    pEqualEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    -- | Partial `is comparable to`.+    pComparableEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    -- | Partial `is not comparable to`.+    pIncomparableEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    pLessEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    pLeqEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    pGeqEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    pGreaterEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    +    -- defaults for all convenience operations:+    pEqualEff effort a b = fmap (== EQ) (pCompareEff effort a b)+    pLessEff effort a b = fmap (== LT) (pCompareEff effort a b)+    pGreaterEff effort a b = fmap (== GT) (pCompareEff effort a b)+    pComparableEff effort a b = fmap (/= NC) (pCompareEff effort a b)+    pIncomparableEff effort a b = fmap (== NC) (pCompareEff effort a b)+    pLeqEff effort a b = fmap (`elem` [EQ,LT,LEE]) (pCompareEff effort a b)+    pGeqEff effort a b = fmap (`elem` [EQ,GT,GEE]) (pCompareEff effort a b)+++instance PartialComparison Int where+    type PartialCompareEffortIndicator Int = ()+    pCompareDefaultEffort _ = ()+    pCompareEff = pComparePreludeCompare    +    +instance PartialComparison Integer where+    type PartialCompareEffortIndicator Integer = ()+    pCompareDefaultEffort _ = ()+    pCompareEff = pComparePreludeCompare    +    +instance PartialComparison Rational where+    type PartialCompareEffortIndicator Rational = ()+    pCompareDefaultEffort _ = ()+    pCompareEff = pComparePreludeCompare    ++instance PartialComparison Double where+    type PartialCompareEffortIndicator Double = ()+    pCompareEff _ a b = Just $ toPartialOrdering $ Prelude.compare a b+--        case (isNaN a, isNaN b) of+--           (False, False) -> Just $ toPartialOrdering $ Prelude.compare a b  +--           (True, True) -> Just EQ+--           _ -> Just NC +    pCompareDefaultEffort _ = ()+    +pComparePreludeCompare _ a b =+    Just $ toPartialOrdering $ Prelude.compare a b++propPartialComparisonReflexiveEQ :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    (UniformlyOrderedSingleton t) -> +    Bool+propPartialComparisonReflexiveEQ _ effort (UniformlyOrderedSingleton e) = +    case pCompareEff effort e e of Just EQ -> True; Nothing -> True; _ -> False ++propPartialComparisonAntiSymmetric :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> +    Bool+propPartialComparisonAntiSymmetric _ effort (UniformlyOrderedPair (e1,e2)) =+    case (pCompareEff effort e2 e1, pCompareEff effort e1 e2) of+        (Just b1, Just b2) -> b1 == partialOrderingTranspose b2+        _ -> True ++propPartialComparisonTransitiveEQ :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> +    Bool+propPartialComparisonTransitiveEQ _ effort +        (UniformlyOrderedTriple (e1,e2,e3)) = +    partialTransitive (pEqualEff effort) e1 e2 e3++propPartialComparisonTransitiveLT :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> +    Bool+propPartialComparisonTransitiveLT _ effort +        (UniformlyOrderedTriple (e1,e2,e3)) = +    partialTransitive (pLessEff effort) e1 e2 e3++propPartialComparisonTransitiveLE :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> +    Bool+propPartialComparisonTransitiveLE _ effort+        (UniformlyOrderedTriple (e1,e2,e3)) = +    partialTransitive (pLeqEff effort) e1 e2 e3++propExtremaInPartialComparison :: +    (PartialComparison t, HasExtrema t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedSingleton t -> +    Bool+propExtremaInPartialComparison _ effort +        (UniformlyOrderedSingleton e) = +    partialOrderExtrema (pLeqEff effort) least greatest e++testsPartialComparison :: +    (PartialComparison t,+     HasExtrema t,+     ArbitraryOrderedTuple t, Show t,+     Arbitrary (PartialCompareEffortIndicator t),+     Show (PartialCompareEffortIndicator t)) => +    (String, t) -> Test+testsPartialComparison (name, sample) =+    testGroup (name ++ " (>=?)")+        [+         testProperty "anti symmetric" (propPartialComparisonAntiSymmetric sample)+        ,+         testProperty "transitive EQ" (propPartialComparisonTransitiveEQ sample)+        ,+         testProperty "transitive LE" (propPartialComparisonTransitiveLE sample)+        ,+         testProperty "transitive LT" (propPartialComparisonTransitiveLT sample)+        ,+         testProperty "extrema" (propExtremaInPartialComparison sample)+        ]+
+ src/Numeric/AERN/Basics/NumericOrder/RefinementRoundedLattice.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.RefinementRoundedLattice+    Description :  lattices over numerical order but with refinement order rounding  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Lattices over numerical order but with refinement order rounding.+    +    This module is hidden and reexported via its parent NumericOrder. +-}+module Numeric.AERN.Basics.NumericOrder.RefinementRoundedLattice +(+    OuterRoundedLattice(..),+    OuterRoundedLatticeEffort(..),+    InnerRoundedLattice(..),+    InnerRoundedLatticeEffort(..),+    RefinementRoundedLattice(..),+    testsRefinementRoundedLattice, +    testsRefinementRoundedLatticeDistributive,+    testsRefinementRoundedLatticeDistributiveMonotone+)+where++import Prelude hiding ((<=))++import Numeric.AERN.Basics.Exception ++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.NumericOrder.Arbitrary +import Numeric.AERN.Basics.NumericOrder.PartialComparison +import Numeric.AERN.Basics.NumericOrder.Extrema++import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd++import Numeric.AERN.Basics.Laws.PartialRelation+import Numeric.AERN.Basics.Laws.RoundedOperation+import Numeric.AERN.Basics.Laws.OperationRelation++import Numeric.AERN.Misc.Maybe++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++{-|+    A type with refinement-outer-rounding numerical-order-lattice operations.+-}+class (OuterRoundedLatticeEffort t) => OuterRoundedLattice t where+    maxOutEff :: MinmaxOuterEffortIndicator t -> t -> t -> t+    minOutEff :: MinmaxOuterEffortIndicator t -> t -> t -> t++class OuterRoundedLatticeEffort t where+    type MinmaxOuterEffortIndicator t+    minmaxOuterDefaultEffort :: t -> MinmaxOuterEffortIndicator t++{-|+    A type with refinement-inner-rounding numerical-order-lattice operations.+-}+class (InnerRoundedLatticeEffort t) => InnerRoundedLattice t where+    maxInEff :: MinmaxInnerEffortIndicator t -> t -> t -> t+    minInEff :: MinmaxInnerEffortIndicator t -> t -> t -> t++class InnerRoundedLatticeEffort t where+    type MinmaxInnerEffortIndicator t+    minmaxInnerDefaultEffort :: t -> MinmaxInnerEffortIndicator t++class (OuterRoundedLattice t, InnerRoundedLattice t) => RefinementRoundedLattice t++propRefinementRoundedLatticeJoinIdempotent :: +    (RefOrd.PartialComparison t, RefinementRoundedLattice t, Show t, HasLegalValues t) => +    t ->+    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    (UniformlyOrderedSingleton t) -> Bool+propRefinementRoundedLatticeJoinIdempotent _ (effortComp, effortIn, effortOut) +        (UniformlyOrderedSingleton e) =+    roundedIdempotent (RefOrd.pLeqEff effortComp) +        (maxInEff effortIn) (maxOutEff effortOut) e++propRefinementRoundedLatticeJoinCommutative :: +    (RefOrd.PartialComparison t, RefinementRoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRefinementRoundedLatticeJoinCommutative _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedPair (e1,e2)) = +    roundedCommutative (RefOrd.pLeqEff effortComp) +        (maxInEff effortIn) (maxOutEff effortOut) e1 e2++propRefinementRoundedLatticeJoinAssocative :: +    (RefOrd.PartialComparison t, RefinementRoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRefinementRoundedLatticeJoinAssocative _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedAssociative (RefOrd.pLeqEff effortComp) +        (maxInEff effortIn) (maxOutEff effortOut) e1 e2 e3++propRefinementRoundedLatticeMeetIdempotent :: +    (RefOrd.PartialComparison t, RefinementRoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    (UniformlyOrderedSingleton t) -> Bool+propRefinementRoundedLatticeMeetIdempotent _ (effortComp, effortIn, effortOut) +        (UniformlyOrderedSingleton e) = +    roundedIdempotent (RefOrd.pLeqEff effortComp) +        (minInEff effortIn) (minOutEff effortOut) e++propRefinementRoundedLatticeMeetCommutative :: +    (RefOrd.PartialComparison t, RefinementRoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRefinementRoundedLatticeMeetCommutative _  (effortComp, effortIn, effortOut)+        (UniformlyOrderedPair (e1,e2)) = +    roundedCommutative (RefOrd.pLeqEff effortComp) +        (minInEff effortIn) (minOutEff effortOut) e1 e2++propRefinementRoundedLatticeMeetAssocative :: +    (RefOrd.PartialComparison t, RefinementRoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRefinementRoundedLatticeMeetAssocative _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedAssociative  (RefOrd.pLeqEff effortComp) +        (minInEff effortIn) (minOutEff effortOut) e1 e2 e3++{- optional properties: -}+propRefinementRoundedLatticeModular :: +    (RefOrd.PartialComparison t, RefinementRoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRefinementRoundedLatticeModular _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedModular (RefOrd.pLeqEff effortComp) +        (maxInEff effortIn) (minInEff effortIn)+        (maxOutEff effortOut) (minOutEff effortOut)+        e1 e2 e3++propRefinementRoundedLatticeDistributive :: +    (RefOrd.PartialComparison t, RefinementRoundedLattice t,+     Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRefinementRoundedLatticeDistributive _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    (roundedModular (RefOrd.pLeqEff effortComp) +        (maxInEff effortIn) (minInEff effortIn)+        (maxOutEff effortOut) (minOutEff effortOut)+        e1 e2 e3)+    && +    (roundedModular (RefOrd.pLeqEff effortComp) +        (minInEff effortIn) (maxInEff effortIn)+        (minOutEff effortOut) (maxOutEff effortOut)+        e1 e2 e3)+    +propRefinementRoundedLatticeJoinMonotone ::+    (Eq t, RefinementRoundedLattice t, RefOrd.PartialComparison t, +     Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    RefOrd.LEPair t -> +    RefOrd.LEPair t ->+    Bool+propRefinementRoundedLatticeJoinMonotone _ (effortComp, effortIn, effortOut)+        (RefOrd.LEPair (e1Lower,e1)) +        (RefOrd.LEPair (e2Lower,e2)) =+    case RefOrd.pLeqEff effortComp rLower r of+        Just b -> b+        Nothing -> True+    where+    rLower = maxOutEff effortOut e1Lower e2Lower +    r = maxInEff effortIn e1 e2 +    +propRefinementRoundedLatticeMeetMonotone ::+    (Eq t, RefinementRoundedLattice t, RefOrd.PartialComparison t, +     Show t, HasLegalValues t) => +    t -> +    (RefOrd.PartialCompareEffortIndicator t, +     MinmaxInnerEffortIndicator t, +     MinmaxOuterEffortIndicator t) -> +    RefOrd.LEPair t -> +    RefOrd.LEPair t ->+    Bool+propRefinementRoundedLatticeMeetMonotone _ (effortComp, effortIn, effortOut)+        (RefOrd.LEPair (e1Lower,e1)) +        (RefOrd.LEPair (e2Lower,e2)) =+    case RefOrd.pLeqEff effortComp rLower r of+        Just b -> b+        Nothing -> True+    where+    rLower = minOutEff effortOut e1Lower e2Lower +    r = minInEff effortIn e1 e2 +    +mkTestGroupLattice name = testGroup (name ++ " (min,max) treated as refinement rounded")+    +testsRefinementRoundedLattice :: +    (RefOrd.PartialComparison t,+     RefOrd.ArbitraryOrderedTuple t,+     HasExtrema t,+     RefinementRoundedLattice t,+     ArbitraryOrderedTuple t,+     Arbitrary t, Show t, HasLegalValues t,+     Arbitrary (RefOrd.PartialCompareEffortIndicator t), Show (RefOrd.PartialCompareEffortIndicator t), +     Arbitrary (MinmaxInnerEffortIndicator t), Show (MinmaxInnerEffortIndicator t), +     Arbitrary (MinmaxOuterEffortIndicator t), Show (MinmaxOuterEffortIndicator t), +     Eq t +     ) => +    (String, t) -> Test+testsRefinementRoundedLattice (name, sample) =+    mkTestGroupLattice name (testsRefinementRoundedLatticeL sample)++testsRefinementRoundedLatticeDistributive :: +    (RefOrd.PartialComparison t,+     RefOrd.ArbitraryOrderedTuple t,+     HasExtrema t,+     RefinementRoundedLattice t,+     ArbitraryOrderedTuple t,+     Arbitrary t, Show t, HasLegalValues t, +     Arbitrary (RefOrd.PartialCompareEffortIndicator t), Show (RefOrd.PartialCompareEffortIndicator t), +     Arbitrary (MinmaxInnerEffortIndicator t), Show (MinmaxInnerEffortIndicator t), +     Arbitrary (MinmaxOuterEffortIndicator t), Show (MinmaxOuterEffortIndicator t), +     Eq t +     ) => +    (String, t) -> Test+testsRefinementRoundedLatticeDistributive (name, sample) =+    mkTestGroupLattice name (testsRefinementRoundedLatticeDistributiveL sample)++testsRefinementRoundedLatticeDistributiveMonotone :: +    (RefOrd.PartialComparison t,+     RefOrd.ArbitraryOrderedTuple t,+     HasExtrema t,+     RefinementRoundedLattice t,+     ArbitraryOrderedTuple t,+     Arbitrary t, Show t, HasLegalValues t, +     Arbitrary (RefOrd.PartialCompareEffortIndicator t), Show (RefOrd.PartialCompareEffortIndicator t), +     Arbitrary (MinmaxInnerEffortIndicator t), Show (MinmaxInnerEffortIndicator t), +     Arbitrary (MinmaxOuterEffortIndicator t), Show (MinmaxOuterEffortIndicator t), +     Eq t +     ) => +    (String, t) -> Test+testsRefinementRoundedLatticeDistributiveMonotone (name, sample) =+    mkTestGroupLattice name (testsRefinementRoundedLatticeDistributiveMonotoneL sample)++testsRefinementRoundedLatticeL sample =    +        [+         testProperty "join idempotent" (propRefinementRoundedLatticeJoinIdempotent sample)+        ,+         testProperty "join commutative" (propRefinementRoundedLatticeJoinCommutative sample)+        ,+         testProperty "join associative" (propRefinementRoundedLatticeJoinAssocative sample)+        ,+         testProperty "meet idempotent" (propRefinementRoundedLatticeMeetIdempotent sample)+        ,+         testProperty "meet commutative" (propRefinementRoundedLatticeMeetCommutative sample)+        ,+         testProperty "meet associative" (propRefinementRoundedLatticeMeetAssocative sample)+        ]+        +testsRefinementRoundedLatticeDistributiveL sample =+    testsRefinementRoundedLatticeL sample +++        [    +         testProperty "distributive" (propRefinementRoundedLatticeDistributive sample)+        ]+        +testsRefinementRoundedLatticeDistributiveMonotoneL sample =+    testsRefinementRoundedLatticeDistributiveL sample +++        [    +         testProperty "join monotone" (propRefinementRoundedLatticeJoinMonotone sample)+        ,+         testProperty "meet monotone" (propRefinementRoundedLatticeMeetMonotone sample)+        ]+
+ src/Numeric/AERN/Basics/NumericOrder/RoundedLattice.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-|+    Module      :  Numeric.AERN.Basics.NumericOrder.RoundedLattice+    Description :  lattices with directed-rounded operations  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Lattices with directed-rounded operations.+    +    This module is hidden and reexported via its parent NumericOrder. +-}+module Numeric.AERN.Basics.NumericOrder.RoundedLattice +where++import Prelude hiding ((<=))++import Numeric.AERN.Basics.Exception++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.NumericOrder.Arbitrary +import Numeric.AERN.Basics.NumericOrder.PartialComparison +import Numeric.AERN.Basics.NumericOrder.Extrema++import Numeric.AERN.Basics.Laws.PartialRelation+import Numeric.AERN.Basics.Laws.RoundedOperation+import Numeric.AERN.Basics.Laws.OperationRelation++import Numeric.AERN.Misc.Maybe++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++{-|+    A type with directed-rounding lattice operations.+-}+class (RoundedLatticeEffort t) => RoundedLattice t where+    maxUpEff :: MinmaxEffortIndicator t -> t -> t -> t+    maxDnEff :: MinmaxEffortIndicator t -> t -> t -> t+    minUpEff :: MinmaxEffortIndicator t -> t -> t -> t+    minDnEff :: MinmaxEffortIndicator t -> t -> t -> t++class RoundedLatticeEffort t where+    type MinmaxEffortIndicator t+    minmaxDefaultEffort :: t -> MinmaxEffortIndicator t++propRoundedLatticeComparisonCompatible :: +    (PartialComparison t, RoundedLattice t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeComparisonCompatible _ (minmaxEffort, effortComp) +        (UniformlyOrderedPair (e1,e2)) =+    (downRoundedJoinOfOrderedPair (pLeqEff effortComp) (minDnEff minmaxEffort) e1 e2)+    && +    (upRoundedMeetOfOrderedPair (pLeqEff effortComp) (maxUpEff minmaxEffort) e1 e2)++propRoundedLatticeJoinAboveBoth :: +    (PartialComparison t, RoundedLattice t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeJoinAboveBoth _ (minmaxEffort, effortComp) +        (UniformlyOrderedPair (e1,e2)) = +    joinAboveOperands (pLeqEff effortComp) (maxUpEff minmaxEffort) e1 e2++propRoundedLatticeMeetBelowBoth :: +    (PartialComparison t, RoundedLattice t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeMeetBelowBoth _ (minmaxEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) = +    meetBelowOperands (pLeqEff effortComp) (minDnEff minmaxEffort) e1 e2++propRoundedLatticeJoinIdempotent :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    t -> Bool+propRoundedLatticeJoinIdempotent _ (minmaxEffort, effortComp) = +    roundedIdempotent (pLeqEff effortComp) (maxUpEff minmaxEffort) (maxDnEff minmaxEffort)++propRoundedLatticeJoinCommutative :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeJoinCommutative _ (minmaxEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) = +    roundedCommutative (pLeqEff effortComp) (maxUpEff minmaxEffort) (maxDnEff minmaxEffort) e1 e2++propRoundedLatticeJoinAssocative :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRoundedLatticeJoinAssocative _ (minmaxEffort, effortComp)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedAssociative (pLeqEff effortComp) (maxUpEff minmaxEffort) (maxDnEff minmaxEffort) e1 e2 e3++propRoundedLatticeMeetIdempotent :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedSingleton t -> +    Bool+propRoundedLatticeMeetIdempotent _ (minmaxEffort, effortComp) +        (UniformlyOrderedSingleton e) = +    roundedIdempotent (pLeqEff effortComp) (minUpEff minmaxEffort) (minDnEff minmaxEffort) e++propRoundedLatticeMeetCommutative :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeMeetCommutative _ (minmaxEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) = +    roundedCommutative (pLeqEff effortComp) (minUpEff minmaxEffort) (minDnEff minmaxEffort) e1 e2++propRoundedLatticeMeetAssocative :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRoundedLatticeMeetAssocative _ (minmaxEffort, effortComp)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedAssociative (pLeqEff effortComp) (minUpEff minmaxEffort) (minDnEff minmaxEffort) e1 e2 e3++{- optional properties: -}+propRoundedLatticeModular :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRoundedLatticeModular _ (minmaxEffort, effortComp)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedModular (pLeqEff effortComp) +        (maxUpEff minmaxEffort) (minUpEff minmaxEffort) +        (maxDnEff minmaxEffort) (minDnEff minmaxEffort) +        e1 e2 e3++propRoundedLatticeDistributive :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (MinmaxEffortIndicator t, PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRoundedLatticeDistributive _ (minmaxEffort, effortComp)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    (roundedLeftDistributive (pLeqEff effortComp) +        (maxUpEff minmaxEffort) (minUpEff minmaxEffort) +        (maxDnEff minmaxEffort) (minDnEff minmaxEffort) +        e1 e2 e3)+    && +    (roundedLeftDistributive (pLeqEff effortComp) +        (minUpEff minmaxEffort) (maxUpEff minmaxEffort) +        (minDnEff minmaxEffort) (maxDnEff minmaxEffort) +        e1 e2 e3)++testsRoundedLatticeDistributive :: +    (PartialComparison t,+     RoundedLattice t,+     Arbitrary t, Show t, HasLegalValues t, +     Arbitrary (MinmaxEffortIndicator t), Show (MinmaxEffortIndicator t), +     Arbitrary (PartialCompareEffortIndicator t), Show (PartialCompareEffortIndicator t), +     ArbitraryOrderedTuple t,+     Eq t+     ) => +    (String, t) -> Test+testsRoundedLatticeDistributive (name, sample) =+    testGroup (name ++ " (min,max) rounded") $+        [+         testProperty "Comparison compatible" (propRoundedLatticeComparisonCompatible sample)+        ,+         testProperty "join above" (propRoundedLatticeJoinAboveBoth sample)+        ,+         testProperty "meet below" (propRoundedLatticeMeetBelowBoth sample)+        ,+         testProperty "join idempotent" (propRoundedLatticeJoinIdempotent sample)+        ,+         testProperty "join commutative" (propRoundedLatticeJoinCommutative sample)+        ,+         testProperty "join associative" (propRoundedLatticeJoinAssocative sample)+        ,+         testProperty "meet idempotent" (propRoundedLatticeMeetIdempotent sample)+        ,+         testProperty "meet commutative" (propRoundedLatticeMeetCommutative sample)+        ,+         testProperty "meet associative" (propRoundedLatticeMeetAssocative sample)+        ,+         testProperty "distributive" (propRoundedLatticeDistributive sample)+        ]
+ src/Numeric/AERN/Basics/PartialOrdering.hs view
@@ -0,0 +1,244 @@+{-|+    Module      :  Numeric.AERN.Basics.PartialOrdering+    Description :  extension of Prelude.Ordering with non-comparable variant  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Extension of 'Prelude.Ordering' with non-comparable variant.+-}+module Numeric.AERN.Basics.PartialOrdering where++import qualified Prelude+import Prelude hiding (EQ, LT, GT)+import Test.QuickCheck++import Data.Maybe+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List as List+++{-| Like 'Prelude.Ordering' but with a non-comparable option+      + LE does not imply LT or EQ, thus has to be separately available + -}+data PartialOrdering = +        EQ -- equal +      | LT -- less than+      | LEE -- less-than-or-equal exclusive, ie not equal and not less than +      | GT -- greater than +      | GEE -- greater-than-or-equal exclusive, ie not equal and not greater than+      | NC -- not comparable+    deriving (Eq, Ord, Show, Enum, Bounded)+    +instance Arbitrary PartialOrdering+    where+    arbitrary = elements partialOrderingVariants++partialOrderingVariants :: [PartialOrdering]+partialOrderingVariants = [minBound..maxBound]++partialOrderingVariantsSet :: Set.Set PartialOrdering+partialOrderingVariantsSet = Set.fromList partialOrderingVariants+        +permittedInReflexiveOrder :: PartialOrdering -> Bool+permittedInReflexiveOrder GEE = False+permittedInReflexiveOrder LEE = False+permittedInReflexiveOrder _ = True++partialOrderingVariantsReflexive = [EQ, LT, GT, NC]+    +permittedInLinearOrder :: PartialOrdering -> Bool+permittedInLinearOrder GEE = False+permittedInLinearOrder LEE = False+permittedInLinearOrder NC = False+permittedInLinearOrder _ = True++partialOrderingVariantsLinear = [EQ, LT, GT]+    +toPartialOrdering :: Ordering -> PartialOrdering+toPartialOrdering Prelude.EQ = EQ +toPartialOrdering Prelude.LT = LT +toPartialOrdering Prelude.GT = GT ++fromPartialOrdering :: PartialOrdering -> Ordering+fromPartialOrdering EQ = Prelude.EQ +fromPartialOrdering LT = Prelude.LT +fromPartialOrdering GT = Prelude.GT+fromPartialOrdering rel = error $ "cannot convert " ++ show rel ++ " to Prelude.Ordering" ++{-| flip an ordering relation -}+partialOrderingTranspose :: PartialOrdering -> PartialOrdering+partialOrderingTranspose LT = GT+partialOrderingTranspose LEE = GEE+partialOrderingTranspose GT = LT+partialOrderingTranspose GEE = LEE+partialOrderingTranspose a = a++{-+   From ambiguous contraints on the ordering of elements of a tuple of some size+   produce all consistent unambiguous orderings of all pairs in such tuples.+-}+pickConsistentOrderings ::+    (Eq ix, Ord ix, Show ix) =>+    (PartialOrdering -> Bool) {-^ filter of permissible orderings -} ->+    [ix] {-^ indices for elements of the resulting tuples -} ->+    [((ix, ix), [PartialOrdering])] {-^ constraints on the ordering of the tuples -} ->+    [[((ix, ix), PartialOrdering)]]+pickConsistentOrderings orderingsFilter indices constraints =+    depthFirst Map.empty [] allPairsAndTriples +    where+    allPairsAndTriples = -- eg [((3,4),[]),((2,4),[]),((2,3),[4]),((1,4),[]),((1,3),[4]),((1,2),[3,4])]+        reverse $+        [((head postfix1, head postfix2), tail postfix2) | +            postfix1 <- init (List.tails indices), -- eg [[1,2,3,4],[2,3,4],[3,4],[4]] +            postfix2 <- init (List.tails (tail postfix1))]+    depthFirst pairLookupMap setPairs [] = [setPairs] +    depthFirst pairLookupMap setPairs ((pair@(i1,i2), i3s) : remainingPairs) =+        concat $ map recurse allowedOrderings +        where+        recurse ordering =+           depthFirst updatedPairLookupMap ((pair, ordering) : setPairs) remainingPairs   +           where+           updatedPairLookupMap =+               Map.insert (i2,i1) (partialOrderingTranspose ordering) $ +               Map.insert (i1,i2) ordering pairLookupMap+        allowedOrderings =+            Set.toList $+                Set.intersection (lkConstraints pair) transitivityConstraints+        transitivityConstraints =+            foldl Set.intersection partialOrderingVariantsSet $ +                map transitivityConstraint i3s+        transitivityConstraint i3 =+            case (Map.lookup (i1,i3) pairLookupMap, Map.lookup (i3,i2) pairLookupMap) of+                (Just rel13, Just rel32) -> transitivityConsequences rel13 rel32+                _ -> error $+                       "pickConsistentOrderings: transitivityConstraint:" +                       ++ "\n pairLookupMap = " ++ show pairLookupMap+                       ++ "\n i1 = " ++ show i1 ++ "; i2 = " ++ show i2 ++ "; i3 = " ++ show i3+        constraintsMap = +            Map.map (Set.fromList . filter orderingsFilter) $ Map.fromList $ constraints+        lkConstraints pair@(i1, i2) =+            case (Map.lookup pair constraintsMap, Map.lookup (i2,i1) constraintsMap) of+                (Just options, Just optionsT) ->+                    Set.intersection options $ Set.map partialOrderingTranspose optionsT+                (Just options, Nothing) ->+                    options+                (Nothing, Just optionsT) ->+                    Set.map partialOrderingTranspose optionsT+                (Nothing, Nothing) ->+                    Set.fromList $ filter orderingsFilter partialOrderingVariants++transitivityConsequences :: PartialOrdering -> PartialOrdering -> Set.Set PartialOrdering+transitivityConsequences rel12 rel23 = +    case (rel12, rel23) of+        (EQ, rel23) -> Set.singleton rel23+        (rel12, EQ) -> Set.singleton rel12+        (LT, LT) -> Set.singleton LT+        (LEE, LT) -> Set.singleton LT +        (LT, LEE) -> Set.singleton LT+        (LEE, LEE) -> Set.fromList [LEE, LT]+        (GT, GT) -> Set.singleton GT+        (GEE, GT) -> Set.singleton GT+        (GT, GEE) -> Set.singleton GT+        (GEE, GEE) -> Set.fromList [GEE, GT]+        (LEE, GEE) -> noneOf [GT, LT]+        (GEE, LEE) -> noneOf [GT, LT]+        (LT, NC) -> noneOf [GT, GEE, EQ]+        (LEE, NC) -> noneOf [GT, GEE, EQ]+        (GT, NC) -> noneOf [LT, LEE, EQ]+        (GEE, NC) -> noneOf [LT, LEE, EQ]+        (NC, LT) -> noneOf [GT, GEE, EQ]+        (NC, LEE) -> noneOf [GT, GEE, EQ]+        (NC, GT) -> noneOf [LT, LEE, EQ]+        (NC, GEE) -> noneOf [LT, LEE, EQ]+        _ -> partialOrderingVariantsSet+    where+    noneOf list = partialOrderingVariantsSet `Set.difference` (Set.fromList list) ++{-|+    All 29 triples of Comparison orderings @(r1, r2, r3)@ for which+    there could be elements satisfying+    @e1 `r1` e2 && e2 `r2` e3 && e1 `r3` e3@+    (ie not breaking transitivity).+-}+partialOrderingVariantsTriples :: [(PartialOrdering, PartialOrdering, PartialOrdering)]+partialOrderingVariantsTriples =+    map convertToTriple $+        pickConsistentOrderings (const True) [1,2,3] []+    where+    convertToTriple [((1,2),rel12), ((1,3),rel13), ((2,3),rel23)] = (rel12,rel23,rel13)++{- The following is useful for some manual testing -}++++--allConsistentTriples = pickConsistentOrderings (const True) [1,2,3] [] +--+--allConsistentTriplesReflexiveOrder = +--    pickConsistentOrderings permittedInReflexiveOrder [1,2,3] [] +--+--allConsistentTriplesLinearOrder = +--    pickConsistentOrderings permittedInLinearOrder [1,2,3] [] ++--test =+--    Set.difference +--        (Set.fromList partialOrderingVariantsTriples)+--        (Set.fromList partialOrderingVariantsTriples2)+--    where+--    convertToTriple assocList =+--        (rel12, rel23, rel13)+--        where+--        rel12 = fromJust $ Map.lookup (1,2) orderingMap+--        rel23 = fromJust $ Map.lookup (2,3) orderingMap+--        rel13 = fromJust $ Map.lookup (1,3) orderingMap+--        orderingMap = Map.fromList assocList+--+--{-|+--    All 29 triples of Comparison orderings @(r1, r2, r3)@ for which+--    there could be elements satisfying+--    @e1 `r1` e2 && e2 `r2` e3 && e1 `r3` e3@+--    (ie not breaking transitivity).+---}+--partialOrderingVariantsTriples2 :: [(PartialOrdering, PartialOrdering, PartialOrdering)]+--partialOrderingVariantsTriples2 =+--    [(r1,r2,r3)| +--        r1 <- partialOrderingVariantsReflexive, +--        r2 <- partialOrderingVariantsReflexive, +--        r3 <- partialOrderingVariantsReflexive,+--        respectsTransitivity (r1, r2, r3)]+--+--{-|+--    Are there any elements satisfying+--    @e1 `r1` e2 && e2 `r2` e3 && e1 `r3` e3@+--    assuming equality and order are transitive.+---}+--respectsTransitivity :: +--    (PartialOrdering, PartialOrdering, PartialOrdering) {-^ @(r1,r2,r3)@ -} -> +--    Bool +--respectsTransitivity rels =+--    case rels of+--        -- when a pair is equal:+--        (EQ,r2,r3) -> r2 == r3 -- e1 = e2+--        (r1,EQ,r3) -> r1 == r3 -- e2 = e3+--        (r1,r2,EQ) -> r1 == partialOrderingTranspose r2 -- e1 = e3+--        -- 6 permutations of strict inequalities:+--        (LT,LT,LT) -> True -- e1 < e2 < e3 (1)+--        (LT,LT,_ ) -> False -- but not e1 < e3+--        (LT,GT,LT) -> True -- e1 < e3 < e2 (2)+--        (_ ,GT,LT) -> False -- but not e1 < e2+--        (GT,LT,LT) -> True -- e2 < e1 < e3 (3)+--        (GT,_ ,LT) -> False -- but not e2 < e3+--        (GT,LT,GT) -> True -- e2 < e3 < e1 (4)+--        (_ ,LT,GT) -> False -- but not e2 < e1+--        (LT,GT,GT) -> True -- e3 < e1 < e2 (5)+--        (LT,_ ,GT) -> False -- but not e3 < e2+--        (GT,GT,GT) -> True -- e3 < e2 < e1 (6)+--        (GT,GT,_ ) -> False -- but not e3 < e1+--        --+--        _ -> True -- all else is OK++
+ src/Numeric/AERN/Basics/RefinementOrder.hs view
@@ -0,0 +1,36 @@+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder+    Description :  classical and approximate domain bases and lattices (&#8849;⊑,&#8851;⊓,&#8852;⊔)  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Type classes representing classical as well as approximate +    Comparisons, domain bases and lattices with the refinement order notation +    (&#8849;,&#8851;,&#8852;).+    +    This module is meant to be imported qualified.+    It is recommended to use the prefix RefOrd.+-}+module Numeric.AERN.Basics.RefinementOrder +(+    module Numeric.AERN.Basics.RefinementOrder.PartialComparison,+    module Numeric.AERN.Basics.RefinementOrder.Arbitrary,+    module Numeric.AERN.Basics.RefinementOrder.RoundedBasis,+    module Numeric.AERN.Basics.RefinementOrder.RoundedLattice,+    module Numeric.AERN.Basics.RefinementOrder.Extrema,+    module Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedBasis, +    module Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedLattice+)+where++import Numeric.AERN.Basics.RefinementOrder.PartialComparison+import Numeric.AERN.Basics.RefinementOrder.Arbitrary+import Numeric.AERN.Basics.RefinementOrder.RoundedBasis+import Numeric.AERN.Basics.RefinementOrder.RoundedLattice+import Numeric.AERN.Basics.RefinementOrder.Extrema+import Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedBasis+import Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedLattice
+ src/Numeric/AERN/Basics/RefinementOrder/Arbitrary.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.Arbitrary+    Description :  random generation of tuples with various relation constraints  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Random generation of tuples with various relation constraints.+    +    This module is hidden and reexported via its parent RefinementOrder. +-}+module Numeric.AERN.Basics.RefinementOrder.Arbitrary where++import Prelude hiding (EQ, LT, GT)++import Numeric.AERN.Basics.PartialOrdering++import Data.Maybe+import qualified Data.Map as Map +import qualified Data.Set as Set ++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import System.IO.Unsafe++{-|+    Comparison with the ability to randomly generate+    pairs and triples of its own elements that are in +    a specific order relation (eg LT or NC).+    +    This is to help with checking properties that+    make sense only for pairs in a certain relation+    where such pairs are rare.+-}+class ArbitraryOrderedTuple t where+    {-| a type of meaningful constraints to place on generation of arbitrary values -}+    type Area t+    {-| a special area that puts no constaints on the values -}+    areaWhole :: t -> Area t+    {-| generator of tuples that satisfy the given relation requirements+        and area restriction, +        nothing if in this structure there are no tuples satisfying these requirements -}+    arbitraryTupleInAreaRelatedBy ::+        (Ord ix, Show ix) =>+        (Area t) -> +        [ix] +           {-^ how many elements should be generated and with what names -} -> +        [ix]+           {-^ a subset of elements that have to be thin approximations -} -> +        [((ix, ix),[PartialOrdering])]+           {-^ required orderings for some pairs of elements -} -> +        Maybe (Gen [t]) {-^ generator for tuples if the requirements make sense -}   +    {-| generator of tuples that satisfy the given relation requirements, +        nothing if in this structure there are no tuples satisfying these requirements -}+    arbitraryTupleRelatedBy ::+        (Ord ix, Show ix) => +        [ix]+           {-^ how many elements should be generated and with what names -} -> +        [ix]+           {-^ a subset of elements that have to be thin approximations -} -> +        [((ix, ix),[PartialOrdering])]+           {-^ required orderings for some pairs of elements -} -> +        Maybe (Gen [t]) {-^ generator for tuples if the requirements make sense -}+    arbitraryTuple ::   +        Int {-^ how many elements should be generated -} -> +        Maybe (Gen [t]) {-^ generator for tuples if the requirements make sense -}+    arbitraryTuple n = arbitraryTupleRelatedBy [1..n] [] [] ++arbitraryPairRelatedBy ::+    (ArbitraryOrderedTuple t) => PartialOrdering -> Maybe (Gen (t,t))+arbitraryPairRelatedBy rel =+    case arbitraryTupleRelatedBy [1,2] [] [((1,2),[rel])] of+        Nothing -> Nothing+        Just gen -> Just $+            do+            [e1,e2] <- gen +            return (e1,e2)++arbitraryTripleRelatedBy ::+    (ArbitraryOrderedTuple t) => +    (PartialOrdering, PartialOrdering, PartialOrdering) -> Maybe (Gen (t,t,t))+arbitraryTripleRelatedBy (r1, r2, r3) =+    case arbitraryTupleRelatedBy [1,2,3] [] constraints of+        Nothing -> Nothing+        Just gen -> Just $+            do+            [e1,e2,e3] <- gen+            return (e1, e2, e3)+    where+    constraints = [((1,2),[r1]), ((2,3),[r2]), ((1,3),[r3])]++{-| type for generating random thin elements -}+newtype Thin t = Thin t deriving (Show)++newtype UniformlyOrderedSingleton t = UniformlyOrderedSingleton t deriving (Show)++{-| type for generating pairs distributed in such a way that all ordering relations +    permitted by this structure have similar probabilities of occurrence -}+data UniformlyOrderedPair t = UniformlyOrderedPair (t,t) deriving (Show)+data LTPair t = LTPair (t,t) deriving (Show)+data LEPair t = LEPair (t,t) deriving (Show)+data NCPair t = NCPair (t,t) deriving (Show)++{-| type for generating triples distributed in such a way that all ordering relation combinations +    permitted by this structure have similar probabilities of occurrence -}+data UniformlyOrderedTriple t = UniformlyOrderedTriple (t,t,t) deriving (Show)+data LTLTLTTriple t = LTLTLTTriple (t,t,t) deriving (Show)+data LELELETriple t = LELELETriple (t,t,t) deriving (Show)+data NCLTLTTriple t = NCLTLTTriple (t,t,t) deriving (Show)+data NCGTGTTriple t = NCGTGTTriple (t,t,t) deriving (Show)+data NCLTNCTriple t = NCLTNCTriple (t,t,t) deriving (Show)++instance (ArbitraryOrderedTuple t) => Arbitrary (Thin t) where+    arbitrary =+        do+        [thinElement] <- gen +        return $ Thin thinElement+        where+        Just gen = arbitraryTupleRelatedBy [1] [1] []++instance (ArbitraryOrderedTuple t) => Arbitrary (UniformlyOrderedSingleton t) where+    arbitrary =+        do+        [elem] <- gen+        return $ UniformlyOrderedSingleton elem+        where+        Just gen = arbitraryTupleRelatedBy [1] [] []++instance (ArbitraryOrderedTuple t) => Arbitrary (UniformlyOrderedPair t) where+    arbitrary =+        do+        gen <- elements gens+        pair <- gen+        return $ UniformlyOrderedPair pair+        where+        gens = catMaybes $ map arbitraryPairRelatedBy partialOrderingVariants  ++instance (ArbitraryOrderedTuple t) => Arbitrary (LEPair t) where+    arbitrary =+        do+        gen <- elements gens+        pair <- gen+        return $ LEPair pair+        where+        gens = catMaybes $ map arbitraryPairRelatedBy [LT, LT, LT, EQ]  ++instance (ArbitraryOrderedTuple t) => Arbitrary (LTPair t) where+    arbitrary =+        case arbitraryPairRelatedBy LT of+            Nothing -> error $ "LTPair used with an incompatible type"+            Just gen ->+                do+                pair <- gen+                return $ LTPair pair++instance (ArbitraryOrderedTuple t) => Arbitrary (NCPair t) where+    arbitrary =+        case arbitraryPairRelatedBy NC of+            Nothing -> error $ "NCPair used with an incompatible type"+            Just gen ->+                do+                pair <- gen+                return $ NCPair pair++instance (ArbitraryOrderedTuple t) => Arbitrary (UniformlyOrderedTriple t) where+    arbitrary = +        do+        gen <- elements gens+        triple <- gen+        return $ UniformlyOrderedTriple triple+        where+        gens = catMaybes $ map arbitraryTripleRelatedBy partialOrderingVariantsTriples++instance (ArbitraryOrderedTuple t) => Arbitrary (LELELETriple t) where+    arbitrary =+        do+        gen <- elements gens+        triple <- gen+        return $ LELELETriple triple+        where+        gens = +            catMaybes $ +                map arbitraryTripleRelatedBy +                    [(LT,LT,LT), (LT,LT,LT), (LT,LT,LT), (LT,LT,LT), (LT,LT,LT), +                     (EQ,LT,LT), (EQ,LT,LT),+                     (LT,EQ,LT), (LT,EQ,LT),+                     (EQ,EQ,EQ)]  ++instance (ArbitraryOrderedTuple t) => Arbitrary (LTLTLTTriple t) where+    arbitrary =+        case arbitraryTripleRelatedBy (LT, LT, LT) of+            Nothing -> error $ "LTLTLTTriple used with an incompatible type"+            Just gen ->+                do+                triple <- gen+                return $ LTLTLTTriple triple+++propArbitraryOrderedPair ::+    (ArbitraryOrderedTuple t) =>+    (t -> t -> PartialOrdering) -> PartialOrdering -> Bool +propArbitraryOrderedPair compare rel =+     case arbitraryPairRelatedBy rel of+        Nothing -> True+        Just gen ->+             and $ map relOK theSample +             where+             theSample = unsafePerformIO $ sample' gen +             relOK (e1, e2) = compare e1 e2 == rel++propArbitraryOrderedTriple ::+    (ArbitraryOrderedTuple t) =>+    (t -> t -> PartialOrdering) -> (PartialOrdering, PartialOrdering, PartialOrdering) -> Bool +propArbitraryOrderedTriple compare rels@(r1,r2,r3) =+     case arbitraryTripleRelatedBy rels of+        Nothing -> True+        Just gen ->+             and $ map relOK theSample +             where+             theSample = unsafePerformIO $ sample' $ gen+             relOK (e1, e2, e3) = +                and [compare e1 e2 == r1, compare e2 e3 == r2, compare e1 e3 == r3]++testsArbitraryTuple ::+    (Arbitrary t,+     ArbitraryOrderedTuple t) =>+    (String, t, t -> t -> PartialOrdering) -> Test+testsArbitraryTuple (name, sample, compare)  =+    testGroup (name ++ " arbitrary ordered") $ +        [+         testProperty "pairs" (propArbitraryOrderedPair compare)+        ,+         testProperty "triples" (propArbitraryOrderedTriple compare)+        ]
+ src/Numeric/AERN/Basics/RefinementOrder/Extrema.hs view
@@ -0,0 +1,40 @@+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.Extrema+    Description :  types that have top and bottom  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Types that have top and bottom.+    +    This module is hidden and reexported via its parent RefinementOrder. +-}+module Numeric.AERN.Basics.RefinementOrder.Extrema where++{-|+    A type with extrema.+-}+class (HasTop t, HasBottom t) => HasExtrema t++{-|+    A type with a top element.+-}+class HasTop t where+    top :: t++{-|+    A type with a top element.+-}+class HasBottom t where+    bottom :: t++-- | Convenience Unicode notation for 'top'+(⊤) :: (HasTop t) => t   +(⊤) = top++-- | Convenience Unicode notation for 'bottom'+(⊥) :: (HasBottom t) => t   +(⊥) = bottom
+ src/Numeric/AERN/Basics/RefinementOrder/InPlace/OpsDefaultEffort.hs view
@@ -0,0 +1,78 @@+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.InPlace.OpsDefaultEffort+    Description :  Convenience directed-rounded in-place lattice operations with default effort parameters +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Convenience directed-rounded in-place lattice operations with default effort parameters.+-}++module Numeric.AERN.Basics.RefinementOrder.InPlace.OpsDefaultEffort where++import Numeric.AERN.Basics.Mutable+import Numeric.AERN.Basics.RefinementOrder++infixr 3 </\>=, >/\<=, <⊓>=, >⊓<= +infixr 2 <\/>=, >\/<=, <⊔>=, >⊔<= ++-- | Outward rounded in-place meet+meetOutInPlace :: (OuterRoundedLatticeInPlace t) => OpMutable2 t s+meetOutInPlace = mutable2EffToMutable2 meetOutInPlaceEff joinmeetOutDefaultEffort ++-- | Outward rounded meet assignment+(</\>=) :: (OuterRoundedLatticeInPlace t) => OpMutable1 t s+(</\>=) = mutable2ToMutable1 meetOutInPlace++-- | Inward rounded in-place meet+meetInInPlace :: (InnerRoundedLatticeInPlace t) => OpMutable2 t s+meetInInPlace = mutable2EffToMutable2 meetInInPlaceEff joinmeetInDefaultEffort ++-- | Inward rounded meet assignment+(>/\<=) :: (InnerRoundedLatticeInPlace t) => OpMutable1 t s+(>/\<=) = mutable2ToMutable1 meetInInPlace++-- | Outward rounded in-place join+joinOutInPlace :: (OuterRoundedLatticeInPlace t) => OpMutable2 t s+joinOutInPlace = mutable2EffToMutable2 joinOutInPlaceEff joinmeetOutDefaultEffort ++-- | Outward rounded join assignment+(<\/>=) :: (OuterRoundedLatticeInPlace t) => OpMutable1 t s+(<\/>=) = mutable2ToMutable1 joinOutInPlace++-- | Inward rounded in-place join+joinInInPlace :: (InnerRoundedLatticeInPlace t) => OpMutable2 t s+joinInInPlace = mutable2EffToMutable2 joinInInPlaceEff joinmeetInDefaultEffort ++-- | Inward rounded join assignment+(>\/<=) :: (InnerRoundedLatticeInPlace t) => OpMutable1 t s+(>\/<=) = mutable2ToMutable1 joinInInPlace++-- | Partial outward rounded in-place join+partialJoinOutInPlace :: (OuterRoundedBasisInPlace t) => OpPartialMutable2 t s+partialJoinOutInPlace = +    partialMutable2EffToPartialMutable2 partialJoinOutInPlaceEff partialJoinOutDefaultEffort ++-- | Partial inward rounded in-place join+partialJoinInInPlace :: (InnerRoundedBasisInPlace t) => OpPartialMutable2 t s+partialJoinInInPlace = +    partialMutable2EffToPartialMutable2 partialJoinInInPlaceEff partialJoinInDefaultEffort++{-| Convenience Unicode notation for '<\/>=' -}+(<⊔>=) :: (OuterRoundedLatticeInPlace t) => OpMutable1 t s+(<⊔>=) = (<\/>=)++{-| Convenience Unicode notation for '</\>=' -}+(<⊓>=) :: (OuterRoundedLatticeInPlace t) => OpMutable1 t s+(<⊓>=) = (</\>=)++{-| Convenience Unicode notation for '>\/<=' -}+(>⊔<=) :: (InnerRoundedLatticeInPlace t) => OpMutable1 t s+(>⊔<=) = (>\/<=)++{-| Convenience Unicode notation for '>/\<=' -}+(>⊓<=) :: (InnerRoundedLatticeInPlace t) => OpMutable1 t s+(>⊓<=) = (>/\<=)
+ src/Numeric/AERN/Basics/RefinementOrder/InPlace/OpsImplicitEffort.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE ImplicitParams #-}+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.InPlace.OpsImplicitEffort+    Description :  onvenience directed-rounded in-place lattice operations with implicit effort parameters +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Convenience directed-rounded in-place lattice operations with implicit effort parameters.+-}++module Numeric.AERN.Basics.RefinementOrder.InPlace.OpsImplicitEffort where++import Numeric.AERN.Basics.Mutable+import Numeric.AERN.Basics.RefinementOrder++infixr 3 </\>=, <⊓>=, >/\<=, >⊓<= +infixr 2 <\/>=, <⊔>=, >\/<=, >⊔<= ++-- | Outward rounded in-place join+joinOutInPlace :: +    (OuterRoundedLatticeInPlace t, +     ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    OpMutable2 t s+joinOutInPlace = joinOutInPlaceEff ?joinmeetOutEffort ++-- | Outward rounded join assignment +(<\/>=) :: +    (OuterRoundedLatticeInPlace t, +     ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    OpMutable1 t s+(<\/>=) = mutable2ToMutable1 joinOutInPlace ++-- | Outward rounded in-place meet+meetOutInPlace :: +    (OuterRoundedLatticeInPlace t, +     ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    OpMutable2 t s    +meetOutInPlace = meetOutInPlaceEff ?joinmeetOutEffort ++-- | Outward rounded meet assignment +(</\>=) :: +    (OuterRoundedLatticeInPlace t, +     ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    OpMutable1 t s    +(</\>=) = mutable2ToMutable1 meetOutInPlace ++-- | Inward rounded in-place join+joinInInPlace :: +    (InnerRoundedLatticeInPlace t, +     ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    OpMutable2 t s+joinInInPlace = joinInInPlaceEff ?joinmeetInEffort ++-- | Inward rounded join assignment +(>\/<=) :: +    (InnerRoundedLatticeInPlace t, +     ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    OpMutable1 t s+(>\/<=) = mutable2ToMutable1 joinInInPlace ++-- | Inward rounded in-place meet+meetInInPlace :: +    (InnerRoundedLatticeInPlace t, +     ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    OpMutable2 t s    +meetInInPlace = meetInInPlaceEff ?joinmeetInEffort ++-- | Inward rounded meet assignment +(>/\<=) :: +    (InnerRoundedLatticeInPlace t, +     ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    OpMutable1 t s    +(>/\<=) = mutable2ToMutable1 meetInInPlace ++{-| convenience Unicode notation for '<\/>=' -}+(<⊔>=) :: +    (OuterRoundedLatticeInPlace t, +     ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    OpMutable1 t s+(<⊔>=) = (<\/>=)+{-| convenience Unicode notation for '</\>=' -}+(<⊓>=) :: +    (OuterRoundedLatticeInPlace t, +     ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    OpMutable1 t s+(<⊓>=) = (</\>=)++{-| convenience Unicode notation for '>\/<=' -}+(>⊔<=) :: +    (InnerRoundedLatticeInPlace t, +     ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    OpMutable1 t s+(>⊔<=) = (>\/<=)+{-| convenience Unicode notation for '>/\<=' -}+(>⊓<=) :: +    (InnerRoundedLatticeInPlace t, +     ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    OpMutable1 t s+(>⊓<=) = (>/\<=)
+ src/Numeric/AERN/Basics/RefinementOrder/InPlace/RoundedBasis.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedBasis+    Description :  domain bases with outwards and inwards rounded operations  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Domain bases with outwards and inwards rounded in-place operations.+    +    This module is hidden and reexported via its grand-parent RefinementOrder. +-}+module Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedBasis +where++import Numeric.AERN.Basics.Mutable+import Control.Monad.ST (ST)++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Basics.Exception+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.RefinementOrder.PartialComparison+import Numeric.AERN.Basics.RefinementOrder.Arbitrary+import Numeric.AERN.Basics.RefinementOrder.RoundedBasis++import Numeric.AERN.Basics.Laws.OperationRelation+import Numeric.AERN.Basics.Laws.RoundedOperation++import Numeric.AERN.Basics.Laws.RoundedOpInPlace++import Numeric.AERN.Misc.Maybe++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)+++{-|+    A type with outward-rounding lattice operations.+-}+class (OuterRoundedBasisEffort t, CanBeMutable t) =>+    OuterRoundedBasisInPlace t+    where+    partialJoinOutInPlaceEff :: OpPartialMutable2Eff (PartialJoinOutEffortIndicator t) t s ++partialJoinOutInPlaceEffFromPure :: +    (CanBeMutable t, OuterRoundedBasis t) => +    OpPartialMutable2Eff (PartialJoinOutEffortIndicator t) t s  +partialJoinOutInPlaceEffFromPure = pureToPartial2Eff partialJoinOutEff ++partialJoinOutEffFromInPlace ::+ (CanBeMutable t, OuterRoundedBasisInPlace t) =>+ (PartialJoinOutEffortIndicator t) -> t -> t -> Maybe t+partialJoinOutEffFromInPlace = mutablePartial2EffToPure partialJoinOutInPlaceEff ++{-|+    A type with inward-rounding lattice operations.+-}+class (InnerRoundedBasisEffort t, CanBeMutable t) =>+    InnerRoundedBasisInPlace t+    where+    partialJoinInInPlaceEff :: OpPartialMutable2Eff (PartialJoinInEffortIndicator t) t s ++class (OuterRoundedBasisInPlace t, InnerRoundedBasisInPlace t) => RoundedBasisInPlace t ++partialJoinInInPlaceEffFromPure :: +    (CanBeMutable t, InnerRoundedBasis t) => +    OpPartialMutable2Eff (PartialJoinInEffortIndicator t) t s  +partialJoinInInPlaceEffFromPure = pureToPartial2Eff partialJoinInEff ++partialJoinInEffFromInPlace ::+ (CanBeMutable t, InnerRoundedBasisInPlace t) =>+ (PartialJoinInEffortIndicator t) -> t -> t -> Maybe t+partialJoinInEffFromInPlace = mutablePartial2EffToPure partialJoinInInPlaceEff ++propOuterInnerRoundedBasisJoinInPlaceConsistentWithPure ::+    (PartialComparison t, +     OuterRoundedBasisInPlace t, InnerRoundedBasisInPlace t, +     RoundedBasis t, +     CanBeMutable t) =>+    t -> +    (PartialJoinOutEffortIndicator t, PartialJoinInEffortIndicator t, +     PartialCompareEffortIndicator t) -> +     UniformlyOrderedPair t -> Bool+propOuterInnerRoundedBasisJoinInPlaceConsistentWithPure +    _ (partialjoinOutEffort, partialjoinInEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) =+    inPlaceConsistentWithPurePartial2 (pLeqEff effortComp) +        (partialJoinOutInPlaceEff partialjoinOutEffort)  +        (partialJoinInInPlaceEff partialjoinInEffort)+        (partialJoinOutEff partialjoinOutEffort) +        (partialJoinInEff partialjoinInEffort) +        e1 e2  ++testsOuterInnerRoundedBasisInPlace :: +    (PartialComparison t,+     OuterRoundedBasisInPlace t, InnerRoundedBasisInPlace t, +     RoundedBasis t, +     CanBeMutable t,+     Arbitrary t, Show t, +     Arbitrary (PartialJoinOutEffortIndicator t), Show (PartialJoinOutEffortIndicator t), +     Arbitrary (PartialJoinInEffortIndicator t), Show (PartialJoinInEffortIndicator t), +     Arbitrary (PartialCompareEffortIndicator t), Show (PartialCompareEffortIndicator t), +     ArbitraryOrderedTuple t,+     Eq t+     ) => +    (String, t) -> Test+testsOuterInnerRoundedBasisInPlace (name, sample) =+    testGroup (name ++ " partial join rounded in-place") $+        [+         testProperty "partial join in-place=pure"+             (propOuterInnerRoundedBasisJoinInPlaceConsistentWithPure sample)+        ]
+ src/Numeric/AERN/Basics/RefinementOrder/InPlace/RoundedLattice.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedLattice+    Description :  lattices with directed-rounded in-place operations  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Lattices with directed-rounded in-place operations.+    +    This module is hidden and reexported via its grand-parent RefinementOrder. +-}+module Numeric.AERN.Basics.RefinementOrder.InPlace.RoundedLattice +where++import Prelude hiding ((<=))++import Numeric.AERN.Basics.Exception++import Numeric.AERN.Basics.Mutable+import Control.Monad.ST (ST)++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.RefinementOrder.Arbitrary+import Numeric.AERN.Basics.RefinementOrder.PartialComparison +import Numeric.AERN.Basics.RefinementOrder.Extrema+import Numeric.AERN.Basics.RefinementOrder.RoundedLattice++import Numeric.AERN.Basics.Laws.RoundedOpInPlace++import Numeric.AERN.Misc.Maybe++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++{-|+    A type with directed-rounding lattice operations.+-}+class +    (OuterRoundedLatticeEffort t, CanBeMutable t) => +    OuterRoundedLatticeInPlace t +    where+    joinOutInPlaceEff :: OpMutable2Eff (JoinMeetOutEffortIndicator t) t s+    meetOutInPlaceEff :: OpMutable2Eff (JoinMeetOutEffortIndicator t) t s+    +joinOutInPlaceEffFromPure, + meetOutInPlaceEffFromPure :: +    (CanBeMutable t, OuterRoundedLattice t) => +    OpMutable2Eff (JoinMeetOutEffortIndicator t) t s  +joinOutInPlaceEffFromPure = pureToMutable2Eff joinOutEff +meetOutInPlaceEffFromPure = pureToMutable2Eff meetOutEff ++joinOutEffFromInPlace,+ meetOutEffFromInPlace ::+ (CanBeMutable t, OuterRoundedLatticeInPlace t) =>+ (JoinMeetOutEffortIndicator t) -> t -> t -> t+joinOutEffFromInPlace = mutable2EffToPure joinOutInPlaceEff +meetOutEffFromInPlace = mutable2EffToPure meetOutInPlaceEff ++class +    (InnerRoundedLatticeEffort t, CanBeMutable t) => +    InnerRoundedLatticeInPlace t +    where+    joinInInPlaceEff :: OpMutable2Eff (JoinMeetInEffortIndicator t) t s+    meetInInPlaceEff :: OpMutable2Eff (JoinMeetInEffortIndicator t) t s+    +joinInInPlaceEffFromPure, + meetInInPlaceEffFromPure :: +    (CanBeMutable t, InnerRoundedLattice t) => +    OpMutable2Eff (JoinMeetInEffortIndicator t) t s  +joinInInPlaceEffFromPure = pureToMutable2Eff joinInEff +meetInInPlaceEffFromPure = pureToMutable2Eff meetInEff ++joinInEffFromInPlace,+ meetInEffFromInPlace ::+ (CanBeMutable t, InnerRoundedLatticeInPlace t) =>+ (JoinMeetInEffortIndicator t) -> t -> t -> t+joinInEffFromInPlace = mutable2EffToPure joinInInPlaceEff +meetInEffFromInPlace = mutable2EffToPure meetInInPlaceEff ++propOuterInnerRoundedLatticeJoinInPlaceConsistentWithPure ::+    (PartialComparison t, +     OuterRoundedLatticeInPlace t, InnerRoundedLatticeInPlace t, +     RoundedLattice t, +     CanBeMutable t) =>+    t -> +    (JoinMeetOutEffortIndicator t, JoinMeetInEffortIndicator t, +     PartialCompareEffortIndicator t) -> +     UniformlyOrderedPair t -> Bool+propOuterInnerRoundedLatticeJoinInPlaceConsistentWithPure +    _ (joinmeetOutEffort, joinmeetInEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) =+    inPlaceConsistentWithPure2 (pLeqEff effortComp) +        (joinOutInPlaceEff joinmeetOutEffort)  +        (joinInInPlaceEff joinmeetInEffort)+        (joinOutEff joinmeetOutEffort) +        (joinInEff joinmeetInEffort) +        e1 e2  ++propOuterInnerRoundedLatticeMeetInPlaceConsistentWithPure ::+    (PartialComparison t, +     OuterRoundedLatticeInPlace t, InnerRoundedLatticeInPlace t,+     RoundedLattice t, +     CanBeMutable t) => +    t -> +    (JoinMeetOutEffortIndicator t, JoinMeetInEffortIndicator t, +     PartialCompareEffortIndicator t) -> +     UniformlyOrderedPair t -> Bool+propOuterInnerRoundedLatticeMeetInPlaceConsistentWithPure +    _ (joinmeetOutEffort, joinmeetInEffort, effortComp)+        (UniformlyOrderedPair (e1,e2)) =+    inPlaceConsistentWithPure2 (pLeqEff effortComp) +        (meetOutInPlaceEff joinmeetOutEffort)  +        (meetInInPlaceEff joinmeetInEffort)+        (meetOutEff joinmeetOutEffort) +        (meetInEff joinmeetInEffort) +        e1 e2  ++testsOuterInnerRoundedLatticeInPlace :: +    (PartialComparison t,+     OuterRoundedLatticeInPlace t, InnerRoundedLatticeInPlace t, +     RoundedLattice t, +     CanBeMutable t,+     Arbitrary t, Show t, +     Arbitrary (JoinMeetOutEffortIndicator t), Show (JoinMeetOutEffortIndicator t), +     Arbitrary (JoinMeetInEffortIndicator t), Show (JoinMeetInEffortIndicator t), +     Arbitrary (PartialCompareEffortIndicator t), Show (PartialCompareEffortIndicator t), +     ArbitraryOrderedTuple t,+     Eq t+     ) => +    (String, t) -> Test+testsOuterInnerRoundedLatticeInPlace (name, sample) =+    testGroup (name ++ " (join,meet) rounded in-place") $+        [+         testProperty "join in-place=pure"+             (propOuterInnerRoundedLatticeJoinInPlaceConsistentWithPure sample)+        ,+         testProperty "meet in-place=pure"+             (propOuterInnerRoundedLatticeMeetInPlaceConsistentWithPure sample)+        ]+
+ src/Numeric/AERN/Basics/RefinementOrder/OpsDefaultEffort.hs view
@@ -0,0 +1,112 @@+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.OpsDefaultEffort+    Description :  Convenience binary infix operators with default effort parameters  +    Copyright   :  (c) Michal Konecny, Jan Duracz+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Convenience binary infix operators with default effort parameters.+-}++module Numeric.AERN.Basics.RefinementOrder.OpsDefaultEffort where++import Numeric.AERN.Basics.RefinementOrder++infix 4 |==?, |<==>?, |</=>?, |<?, |<=?, |>=?, |>?, ⊏?, ⊑?, ⊒?, ⊐?+infixr 3 </\>, >/\<, <⊓>, >⊓< +infixr 2 <\/>?, >\/<?, <\/>, >\/<, <⊔>?, >⊔<?, <⊔>, >⊔< ++-- | Partial equality+(|==?) :: (PartialComparison t) => t -> t -> Maybe Bool+(|==?) a = pEqualEff (pCompareDefaultEffort a) a++-- | Partial `is comparable to`+(|<==>?) :: (PartialComparison t) => t -> t -> Maybe Bool+(|<==>?) a = pComparableEff (pCompareDefaultEffort a) a++-- | Partial `is not comparable to`+(|</=>?) :: (PartialComparison t) => t -> t -> Maybe Bool+(|</=>?) a = pIncomparableEff (pCompareDefaultEffort a) a++-- | Partial `strictly below`+(|<?) :: (PartialComparison t) => t -> t -> Maybe Bool+(|<?) a = pLessEff (pCompareDefaultEffort a) a++-- | Partial `below or equal to`+(|<=?) :: (PartialComparison t) => t -> t -> Maybe Bool +(|<=?) a = pLeqEff (pCompareDefaultEffort a) a++-- | Partial `above or equal to`+(|>=?) :: (PartialComparison t) => t -> t -> Maybe Bool +(|>=?) a = pGeqEff (pCompareDefaultEffort a) a++-- | Partial `strictly above`+(|>?) :: (PartialComparison t) => t -> t -> Maybe Bool +(|>?) a = pGreaterEff (pCompareDefaultEffort a) a++{-| Convenience Unicode notation for '|<?' -}+(⊏?) :: (PartialComparison t) => t -> t -> Maybe Bool+(⊏?) = (|<?)++{-| Convenience Unicode notation for '|<=?' -}+(⊑?) :: (PartialComparison t) => t -> t -> Maybe Bool+(⊑?) = (|<=?)++{-| Convenience Unicode notation for '|>=?' -}+(⊒?) :: (PartialComparison t) => t -> t -> Maybe Bool+(⊒?) = (|>=?)++{-| Convenience Unicode notation for '|>?' -}+(⊐?) :: (PartialComparison t) => t -> t -> Maybe Bool+(⊐?) = (|>?)++-- | Outward rounded meet+(</\>) :: (OuterRoundedLattice t) => t -> t -> t+(</\>) a = meetOutEff (joinmeetOutDefaultEffort a) a ++-- | Inward rounded meet+(>/\<) :: (InnerRoundedLattice t) => t -> t -> t+(>/\<) a = meetInEff (joinmeetInDefaultEffort a) a ++-- | Partial outward rounded join+(<\/>?) :: (OuterRoundedBasis t) => t -> t -> Maybe t+(<\/>?) a = partialJoinOutEff (partialJoinOutDefaultEffort a) a ++-- | Partial inward rounded join+(>\/<?) :: (InnerRoundedBasis t) => t -> t -> Maybe t+(>\/<?) a = partialJoinInEff (partialJoinInDefaultEffort a) a ++-- | Outward rounded join+(<\/>) :: (OuterRoundedLattice t) => t -> t -> t +(<\/>) a = joinOutEff (joinmeetOutDefaultEffort a) a ++-- | Inward rounded join+(>\/<) :: (InnerRoundedLattice t) => t -> t -> t+(>\/<) a = joinInEff (joinmeetInDefaultEffort a) a ++{-| Convenience Unicode notation for '<\/>?' -}+(<⊔>?) :: (OuterRoundedBasis t) => t -> t -> Maybe t +(<⊔>?) = (<\/>?)++{-| Convenience Unicode notation for '>\/<?' -}+(>⊔<?) :: (InnerRoundedBasis t) => t -> t -> Maybe t+(>⊔<?) = (>\/<?)++{-| Convenience Unicode notation for '<\/>' -}+(<⊔>) :: (OuterRoundedLattice t) => t -> t -> t+(<⊔>) = (<\/>)++{-| Convenience Unicode notation for '</\>' -}+(<⊓>) :: (OuterRoundedLattice t) => t -> t -> t+(<⊓>) = (</\>)++{-| Convenience Unicode notation for '>\/<' -}+(>⊔<) :: (InnerRoundedLattice t) => t -> t -> t+(>⊔<) = (>\/<)++{-| Convenience Unicode notation for '>/\<' -}+(>⊓<) :: (InnerRoundedLattice t) => t -> t -> t+(>⊓<) = (>/\<)
+ src/Numeric/AERN/Basics/RefinementOrder/OpsImplicitEffort.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ImplicitParams #-}+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.OpsImplicitEffort+    Description :  convenience binary infix operators with implicit effort parameters  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Convenience binary infix operators with implicit effort parameters.+-}++module Numeric.AERN.Basics.RefinementOrder.OpsImplicitEffort where++import Numeric.AERN.Basics.RefinementOrder++infix 4 |==?, |<==>?, |</=>?, |<?, |<=?, |>=?, |>? +infix 4 ⊏?, ⊑?, ⊒?, ⊐?++infixr 2 <\/>?, <⊔>?, >\/<?, >⊔<?++infixr 3 </\>, <⊓>, >/\<, >⊓< +infixr 2 <\/>, <⊔>, >\/<, >⊔< +++(|==?), (|<==>?), (|</=>?), (|<?), (|>?), (|<=?), (|>=?) ::+    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool++(|==?) = pEqualEff ?pCompareEffort+(|<==>?) = pComparableEff ?pCompareEffort+(|</=>?) = pIncomparableEff ?pCompareEffort+(|<?) = pLessEff ?pCompareEffort+(|>?) = pGreaterEff ?pCompareEffort+(|<=?) = pLeqEff ?pCompareEffort+(|>=?) = pGeqEff ?pCompareEffort+++(<\/>?) ::+    (OuterRoundedBasis t, ?partialJoinOutEffort :: PartialJoinOutEffortIndicator t) => +    t -> t -> Maybe t+(<\/>?) = partialJoinOutEff ?partialJoinOutEffort ++(>\/<?) ::+    (InnerRoundedBasis t, ?partialJoinInEffort :: PartialJoinInEffortIndicator t) => +    t -> t -> Maybe t+    +(>\/<?) = partialJoinInEff ?partialJoinInEffort +++(<\/>), (</\>) :: +    (OuterRoundedLattice t, +     ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    t -> t -> t+    +(<\/>) = joinOutEff ?joinmeetOutEffort +(</\>) = meetOutEff ?joinmeetOutEffort +++(>\/<), (>/\<) :: +    (InnerRoundedLattice t, +     ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    t -> t -> t+    +(>\/<) = joinInEff ?joinmeetInEffort +(>/\<) = meetInEff ?joinmeetInEffort ++++-- convenience Unicode operator notation for order:+(⊏?), (⊑?), (⊒?), (⊐?) :: +    (PartialComparison t, +     ?pCompareEffort :: PartialCompareEffortIndicator t) => +    t -> t -> Maybe Bool++(⊏?) = (|<?)+(⊑?) = (|<=?)+(⊒?) = (|>=?)+(⊐?) = (|>?)++{-| convenience Unicode notation for '<\/>?' -}+(<⊔>?) :: +    (OuterRoundedBasis t, ?partialJoinOutEffort :: PartialJoinOutEffortIndicator t) => +    t -> t -> Maybe t+(<⊔>?) = (<\/>?)++{-| convenience Unicode notation for '>\/<?' -}+(>⊔<?) :: +    (InnerRoundedBasis t, ?partialJoinInEffort :: PartialJoinInEffortIndicator t) => +    t -> t -> Maybe t+(>⊔<?) = (>\/<?)++{-| convenience Unicode notation for '<\/>' -}+(<⊔>) :: +    (OuterRoundedLattice t, ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    t -> t -> t+(<⊔>) = (<\/>)+{-| convenience Unicode notation for '</\>' -}+(<⊓>) :: +    (OuterRoundedLattice t, ?joinmeetOutEffort :: JoinMeetOutEffortIndicator t) => +    t -> t -> t+(<⊓>) = (</\>)++{-| convenience Unicode notation for '>\/<' -}+(>⊔<) :: +    (InnerRoundedLattice t, ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    t -> t -> t+(>⊔<) = (>\/<)+{-| convenience Unicode notation for '>/\<' -}+(>⊓<) :: +    (InnerRoundedLattice t, ?joinmeetInEffort :: JoinMeetInEffortIndicator t) => +    t -> t -> t+(>⊓<) = (>/\<)
+ src/Numeric/AERN/Basics/RefinementOrder/PartialComparison.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.ApproxOrder+    Description :  Comparisons with semidecidable order  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Comparisons with semidecidable order.+    +    This module is hidden and reexported via its parent RefinementOrder. +-}++module Numeric.AERN.Basics.RefinementOrder.PartialComparison +where++import Prelude hiding (EQ, LT, GT)++import Numeric.AERN.Basics.RefinementOrder.Extrema+import Numeric.AERN.Basics.RefinementOrder.Arbitrary++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Misc.Maybe+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.Laws.PartialRelation++import Numeric.AERN.Misc.Maybe+import Numeric.AERN.Misc.Bool++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++{-|+    A type with semi-decidable equality and partial order+-}+class PartialComparison t where+    type PartialCompareEffortIndicator t+    pCompareEff :: PartialCompareEffortIndicator t -> t -> t -> Maybe PartialOrdering+    pCompareDefaultEffort :: t -> PartialCompareEffortIndicator t+    +    -- | Partial equality+    pEqualEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    -- | Partial `is comparable to`.+    pComparableEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    -- | Partial `is not comparable to`.+    pIncomparableEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    pLessEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    pLeqEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    pGeqEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    pGreaterEff :: (PartialCompareEffortIndicator t) -> t -> t -> Maybe Bool+    +    -- defaults for all convenience operations:+    pEqualEff effort a b = fmap (== EQ) (pCompareEff effort a b)+    pLessEff effort a b = fmap (== LT) (pCompareEff effort a b)+    pGreaterEff effort a b = fmap (== GT) (pCompareEff effort a b)+    pComparableEff effort a b = fmap (/= NC) (pCompareEff effort a b)+    pIncomparableEff effort a b = fmap (== NC) (pCompareEff effort a b)+    pLeqEff effort a b = fmap (`elem` [EQ,LT,LEE]) (pCompareEff effort a b)+    pGeqEff effort a b = fmap (`elem` [EQ,GT,GEE]) (pCompareEff effort a b)+++propPartialComparisonReflexiveEQ :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    (UniformlyOrderedSingleton t) -> +    Bool+propPartialComparisonReflexiveEQ _ effort (UniformlyOrderedSingleton e) = +    case pCompareEff effort e e of Just EQ -> True; Nothing -> True; _ -> False ++propPartialComparisonAntiSymmetric :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedPair t -> +    Bool+propPartialComparisonAntiSymmetric _ effort (UniformlyOrderedPair (e1, e2)) =+    case (pCompareEff effort e2 e1, pCompareEff effort e1 e2) of+        (Just b1, Just b2) -> b1 == partialOrderingTranspose b2+        _ -> True ++propPartialComparisonTransitiveEQ :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> +    Bool+propPartialComparisonTransitiveEQ _ effort +        (UniformlyOrderedTriple (e1,e2,e3)) = +    partialTransitive (pEqualEff effort) e1 e2 e3++propPartialComparisonTransitiveLT :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> +    Bool+propPartialComparisonTransitiveLT _ effort +        (UniformlyOrderedTriple (e1,e2,e3)) = +    partialTransitive (pLessEff effort) e1 e2 e3++propPartialComparisonTransitiveLE :: +    (PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t) -> +    UniformlyOrderedTriple t -> +    Bool+propPartialComparisonTransitiveLE _ effort+        (UniformlyOrderedTriple (e1,e2,e3)) = +    partialTransitive (pLeqEff effort) e1 e2 e3++propExtremaInPartialComparison :: +    (PartialComparison t, HasExtrema t) => +    t -> (PartialCompareEffortIndicator t) -> +    (UniformlyOrderedSingleton t) -> Bool+propExtremaInPartialComparison _ effort (UniformlyOrderedSingleton e) = +    partialOrderExtrema (pLeqEff effort) bottom top e++testsPartialComparison :: +    (PartialComparison t,+     HasExtrema t,+     ArbitraryOrderedTuple t, Show t,+     Arbitrary (PartialCompareEffortIndicator t),+     Show (PartialCompareEffortIndicator t)) => +    (String, t) -> Test+testsPartialComparison (name, sample) =+    testGroup (name ++ " (⊑?)")+        [+         testProperty "anti symmetric" (propPartialComparisonAntiSymmetric sample)+        ,+         testProperty "transitive EQ" (propPartialComparisonTransitiveEQ sample)+        ,+         testProperty "transitive LE" (propPartialComparisonTransitiveLE sample)+        ,+         testProperty "transitive LT" (propPartialComparisonTransitiveLT sample)+        ,+         testProperty "extrema" (propExtremaInPartialComparison sample)+        ]
+ src/Numeric/AERN/Basics/RefinementOrder/RoundedBasis.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.RoundedBasis+    Description :  domain bases with outwards and inwards rounded operations  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Domain bases with outwards and inwards rounded operations.+    +    This module is hidden and reexported via its parent RefinementOrder. +-}+module Numeric.AERN.Basics.RefinementOrder.RoundedBasis +where++import Numeric.AERN.Basics.Mutable+import Control.Monad.ST (ST)++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Basics.Exception+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.RefinementOrder.PartialComparison+import Numeric.AERN.Basics.RefinementOrder.Arbitrary++import Numeric.AERN.Basics.Laws.OperationRelation+import Numeric.AERN.Basics.Laws.RoundedOperation++import Numeric.AERN.Misc.Maybe++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)+++{-|+    A type with outward-rounding lattice operations.+-}+class OuterRoundedBasisEffort t where+    type PartialJoinOutEffortIndicator t+    partialJoinOutDefaultEffort :: t -> PartialJoinOutEffortIndicator t++class (OuterRoundedBasisEffort t) => OuterRoundedBasis t where+    partialJoinOutEff :: PartialJoinOutEffortIndicator t -> t -> t -> Maybe t++{-|+    A type with inward-rounding lattice operations.+-}+class InnerRoundedBasisEffort t where+    type PartialJoinInEffortIndicator t+    partialJoinInDefaultEffort :: t -> PartialJoinInEffortIndicator t++class (InnerRoundedBasisEffort t) => InnerRoundedBasis t where+    partialJoinInEff :: PartialJoinInEffortIndicator t -> t -> t -> Maybe t++class (OuterRoundedBasis t, InnerRoundedBasis t) => RoundedBasis t ++-- properties of OuterRoundedBasis+propOuterRoundedBasisComparisonCompatible :: +    (PartialComparison t, OuterRoundedBasis t) => +    t -> +    (PartialCompareEffortIndicator t, PartialJoinOutEffortIndicator t) ->+    t -> t -> Bool+propOuterRoundedBasisComparisonCompatible _ (effortComp, effortJoin) =+    downRoundedPartialJoinOfOrderedPair (pLeqEff effortComp) +        (partialJoinOutEff effortJoin)++-- properties of InnerRoundedBasis:+propInnerRoundedBasisJoinAboveBoth :: +    (PartialComparison t, InnerRoundedBasis t) => +    t -> +    (PartialCompareEffortIndicator t, PartialJoinInEffortIndicator t) ->+    t -> t -> Bool+propInnerRoundedBasisJoinAboveBoth _ (effortComp, effortJoin) = +    partialJoinAboveOperands (pLeqEff effortComp) (partialJoinInEff effortJoin)++-- properties of RoundedBasis:+propRoundedBasisJoinIdempotent :: +    (PartialComparison t, RoundedBasis t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     PartialJoinInEffortIndicator t, +     PartialJoinOutEffortIndicator t) ->+    (UniformlyOrderedSingleton t) -> +    Bool+propRoundedBasisJoinIdempotent _ (effortComp, effortJoinIn, effortJoinOut) +        (UniformlyOrderedSingleton e) = +    partialRoundedIdempotent (pLeqEff effortComp) +        (partialJoinInEff effortJoinIn) (partialJoinOutEff effortJoinOut) e++propRoundedBasisJoinCommutative :: +    (PartialComparison t, RoundedBasis t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     PartialJoinInEffortIndicator t, +     PartialJoinOutEffortIndicator t) ->+    UniformlyOrderedPair t -> Bool+propRoundedBasisJoinCommutative _ (effortComp, effortJoinIn, effortJoinOut)+        (UniformlyOrderedPair (e1,e2)) = +    partialRoundedCommutative (pLeqEff effortComp) +        (partialJoinInEff effortJoinIn) (partialJoinOutEff effortJoinOut) +        e1 e2++propRoundedBasisJoinAssociative :: +    (PartialComparison t, RoundedBasis t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     PartialJoinInEffortIndicator t, +     PartialJoinOutEffortIndicator t) ->+    UniformlyOrderedTriple t -> Bool+propRoundedBasisJoinAssociative _ (effortComp, effortJoinIn, effortJoinOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    partialRoundedAssociative (pLeqEff effortComp) +        (partialJoinInEff effortJoinIn) (partialJoinOutEff effortJoinOut) +        e1 e2 e3+++propRoundedBasisJoinMonotone ::+    (Eq t, RoundedBasis t, PartialComparison t) => +    t -> +    (PartialCompareEffortIndicator t, +     PartialJoinOutEffortIndicator t, +     PartialJoinInEffortIndicator t) -> +    LEPair t -> +    LEPair t ->+    Bool+propRoundedBasisJoinMonotone _ (effortComp, effortOut, effortIn)+        (LEPair (e1Lower,e1)) +        (LEPair (e2Lower,e2)) =+    case (maybeRLower, maybeR) of+        (Just rLower, Just r) ->+            case pLeqEff effortComp rLower r of+                Just b -> b+                Nothing -> True+        (_, _) -> True+    where+    maybeRLower = partialJoinOutEff effortOut e1Lower e2Lower +    maybeR = partialJoinInEff effortIn e1 e2 ++testsRoundedBasis ::+    (PartialComparison t,+     RoundedBasis t,+     Arbitrary t, Show t, HasLegalValues t,+     Arbitrary (PartialCompareEffortIndicator t), Show (PartialCompareEffortIndicator t), +     Arbitrary (PartialJoinOutEffortIndicator t), Show (PartialJoinOutEffortIndicator t), +     Arbitrary (PartialJoinInEffortIndicator t), Show (PartialJoinInEffortIndicator t), +     ArbitraryOrderedTuple t,+     Eq t) => +    (String, t) -> Test+testsRoundedBasis (name, sample) =+    testGroup (name ++ " (<⊔>?, >⊔<?)") $+        [+         testProperty "rounded join comparison compatible"  (propOuterRoundedBasisComparisonCompatible sample),+         testProperty "rounded join above both"  (propInnerRoundedBasisJoinAboveBoth sample),+         testProperty "rounded join idempotent" (propRoundedBasisJoinIdempotent sample),+         testProperty "rounded join commutative" (propRoundedBasisJoinCommutative sample),+         testProperty "rounded join associative" (propRoundedBasisJoinAssociative sample),+         testProperty "rounded join monotone" (propRoundedBasisJoinMonotone sample)+        ]+
+ src/Numeric/AERN/Basics/RefinementOrder/RoundedLattice.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+    Module      :  Numeric.AERN.Basics.RefinementOrder.RoundedLattice+    Description :  lattices with outwards and inwards rounded operations  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Lattices with outwards and inwards rounded operations.+    +    This module is hidden and reexported via its parent RefinementOrder. +-}+module Numeric.AERN.Basics.RefinementOrder.RoundedLattice +where++import Numeric.AERN.Basics.Exception++import Numeric.AERN.Basics.Mutable+import Control.Monad.ST (ST)++import Numeric.AERN.Basics.Effort+import Numeric.AERN.Misc.Maybe+import Numeric.AERN.Basics.PartialOrdering+import Numeric.AERN.Basics.RefinementOrder.Arbitrary+import Numeric.AERN.Basics.RefinementOrder.PartialComparison++import Numeric.AERN.Basics.Laws.RoundedOperation+import Numeric.AERN.Basics.Laws.OperationRelation++import Test.QuickCheck+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++{-|+    A type with outward-rounding lattice operations.+-}+class OuterRoundedLatticeEffort t where+    type JoinMeetOutEffortIndicator t+    joinmeetOutDefaultEffort :: t -> JoinMeetOutEffortIndicator t++class (OuterRoundedLatticeEffort t) => OuterRoundedLattice t where+    joinOutEff :: JoinMeetOutEffortIndicator t -> t -> t -> t+    meetOutEff :: JoinMeetOutEffortIndicator t -> t -> t -> t++{-|+    A type with inward-rounding lattice operations.+-}+class InnerRoundedLatticeEffort t where+    type JoinMeetInEffortIndicator t+    joinmeetInDefaultEffort :: t -> JoinMeetInEffortIndicator t+    +class (InnerRoundedLatticeEffort t) => InnerRoundedLattice t where+    joinInEff :: JoinMeetInEffortIndicator t -> t -> t -> t+    meetInEff :: JoinMeetInEffortIndicator t -> t -> t -> t++class (InnerRoundedLattice t, OuterRoundedLattice t) => RoundedLattice t++-- properties of RoundedLattice++propRoundedLatticeComparisonCompatible :: +    (PartialComparison t, RoundedLattice t) => +    t ->+    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeComparisonCompatible _ (effortComp, effortIn, effortOut) +        (UniformlyOrderedPair (e1,e2)) =+    (downRoundedJoinOfOrderedPair (pLeqEff effortComp) (joinOutEff effortOut) e1 e2)+    && +    (upRoundedMeetOfOrderedPair (pLeqEff effortComp) (meetInEff effortIn) e1 e2)++propRoundedLatticeJoinAboveBoth :: +    (PartialComparison t, RoundedLattice t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeJoinAboveBoth _ (effortComp, effortIn)+        (UniformlyOrderedPair (e1,e2)) = +    joinAboveOperands (pLeqEff effortComp) (joinInEff effortIn) e1 e2++propRoundedLatticeMeetBelowBoth :: +    (PartialComparison t, RoundedLattice t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeMeetBelowBoth _ (effortComp, effortOut)+        (UniformlyOrderedPair (e1,e2)) = +    meetBelowOperands (pLeqEff effortComp) (meetOutEff effortOut) e1 e2++propRoundedLatticeJoinIdempotent :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    (UniformlyOrderedSingleton t) -> +    Bool+propRoundedLatticeJoinIdempotent _ (effortComp, effortIn, effortOut) +        (UniformlyOrderedSingleton e) = +    roundedIdempotent (pLeqEff effortComp) (joinInEff effortIn) (joinOutEff effortOut) e++propRoundedLatticeJoinCommutative :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeJoinCommutative _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedPair (e1,e2)) = +    roundedCommutative (pLeqEff effortComp) (joinInEff effortIn) (joinOutEff effortOut) e1 e2++propRoundedLatticeJoinAssocative :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRoundedLatticeJoinAssocative _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedAssociative (pLeqEff effortComp) (joinInEff effortIn) (joinOutEff effortOut) e1 e2 e3++propRoundedLatticeJoinMonotone ::+    (Eq t, RoundedLattice t, PartialComparison t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetOutEffortIndicator t, +     JoinMeetInEffortIndicator t) -> +    LEPair t -> +    LEPair t ->+    Bool+propRoundedLatticeJoinMonotone _ (effortComp, effortOut, effortIn)+        (LEPair (e1Lower,e1)) +        (LEPair (e2Lower,e2)) =+    case pLeqEff effortComp rLower r of+        Just b -> b+        Nothing -> True+   where+    rLower = joinOutEff effortOut e1Lower e2Lower +    r = joinInEff effortIn e1 e2 ++propRoundedLatticeMeetIdempotent :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    (UniformlyOrderedSingleton t) -> +    Bool+propRoundedLatticeMeetIdempotent _ (effortComp, effortIn, effortOut) +        (UniformlyOrderedSingleton e) = +    roundedIdempotent (pLeqEff effortComp) (meetInEff effortIn) (meetOutEff effortOut) e++propRoundedLatticeMeetCommutative :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    UniformlyOrderedPair t -> Bool+propRoundedLatticeMeetCommutative _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedPair (e1,e2)) = +    roundedCommutative (pLeqEff effortComp) (meetInEff effortIn) (meetOutEff effortOut) e1 e2++propRoundedLatticeMeetAssocative :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRoundedLatticeMeetAssocative _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedAssociative (pLeqEff effortComp) (meetInEff effortIn) (meetOutEff effortOut) e1 e2 e3++{- optional properties: -}+propRoundedLatticeModular :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRoundedLatticeModular _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    roundedModular (pLeqEff effortComp) (meetInEff effortIn) (joinInEff effortIn) (meetOutEff effortOut) (joinOutEff effortOut) e1 e2 e3++propRoundedLatticeMeetMonotone ::+    (Eq t, RoundedLattice t, PartialComparison t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetOutEffortIndicator t, +     JoinMeetInEffortIndicator t) -> +    LEPair t -> +    LEPair t ->+    Bool+propRoundedLatticeMeetMonotone _ (effortComp, effortOut, effortIn)+        (LEPair (e1Lower,e1)) +        (LEPair (e2Lower,e2)) =+    case pLeqEff effortComp rLower r of+        Just b -> b+        Nothing -> True+   where+    rLower = meetOutEff effortOut e1Lower e2Lower +    r = meetInEff effortIn e1 e2 ++propRoundedLatticeDistributive :: +    (PartialComparison t, RoundedLattice t, Show t, HasLegalValues t) => +    t -> +    (PartialCompareEffortIndicator t, +     JoinMeetInEffortIndicator t, +     JoinMeetOutEffortIndicator t) -> +    UniformlyOrderedTriple t -> Bool+propRoundedLatticeDistributive _ (effortComp, effortIn, effortOut)+        (UniformlyOrderedTriple (e1,e2,e3)) = +    (roundedLeftDistributive  (pLeqEff effortComp) (meetInEff effortIn) (joinInEff effortIn) (meetOutEff effortOut) (joinOutEff effortOut) e1 e2 e3)+    && +    (roundedLeftDistributive  (pLeqEff effortComp) (joinInEff effortIn) (meetInEff effortIn) (joinOutEff effortOut) (meetOutEff effortOut) e1 e2 e3)+++testsRoundedLatticeDistributive :: +    (PartialComparison t,+     RoundedLattice t,+     Arbitrary t, Show t, HasLegalValues t,+     Arbitrary (PartialCompareEffortIndicator t), Show (PartialCompareEffortIndicator t), +     Arbitrary (JoinMeetOutEffortIndicator t), Show (JoinMeetOutEffortIndicator t), +     Arbitrary (JoinMeetInEffortIndicator t), Show (JoinMeetInEffortIndicator t), +     ArbitraryOrderedTuple t,+     Eq t) => +    (String, t) -> Test+testsRoundedLatticeDistributive (name, sample) =+    testGroup (name ++ " (⊓,⊔) rounded") $+        [+         testProperty "Comparison compatible" (propRoundedLatticeComparisonCompatible sample)+        ,+         testProperty "join above" (propRoundedLatticeJoinAboveBoth sample)+        ,+         testProperty "meet below" (propRoundedLatticeMeetBelowBoth sample)+        ,+         testProperty "join idempotent" (propRoundedLatticeJoinIdempotent sample)+        ,+         testProperty "join commutative" (propRoundedLatticeJoinCommutative sample)+        ,+         testProperty "join associative" (propRoundedLatticeJoinAssocative sample)+        ,+         testProperty "join monotone" (propRoundedLatticeJoinMonotone sample)+        ,+         testProperty "meet idempotent" (propRoundedLatticeMeetIdempotent sample)+        ,+         testProperty "meet commutative" (propRoundedLatticeMeetCommutative sample)+        ,+         testProperty "meet associative" (propRoundedLatticeMeetAssocative sample)+        ,+         testProperty "meet monotone" (propRoundedLatticeMeetMonotone sample)+        ,+         testProperty "distributive" (propRoundedLatticeDistributive sample)+        ]+    +-- mutable versions (TODO)
+ src/Numeric/AERN/Basics/ShowInternals.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TypeFamilies #-}+{-|+    Module      :  Numeric.AERN.Basics.Exception+    Description :  formatting with optional display of internal components   +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Formatting with optional display of internal components.+-}++module Numeric.AERN.Basics.ShowInternals where++class ShowInternals t where+    type ShowInternalsIndicator t+    defaultShowIndicator :: t -> ShowInternalsIndicator t+    showInternals :: (ShowInternalsIndicator t) -> t -> String++showUsingShowInternals :: (ShowInternals t) => t -> String+showUsingShowInternals a =+    showInternals (defaultShowIndicator a) a+    +
+ src/Numeric/AERN/Misc/Bool.hs view
@@ -0,0 +1,19 @@+{-|+    Module      :  Numeric.AERN.Misc.Bool+    Description :  miscellaneous boolean functions  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Miscellaneous boolean functions.+-}+module Numeric.AERN.Misc.Bool where++(===>) :: Bool -> Bool -> Bool+a ===> b = not a || b ++(<===>) :: Bool -> Bool -> Bool+a <===> b = a == b
+ src/Numeric/AERN/Misc/Debug.hs view
@@ -0,0 +1,49 @@+{-|+    Module      :  Numeric.AERN.Misc.Debug+    Description :  miscellaneous debugging functions  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Miscellaneous debugging functions.+-}++module Numeric.AERN.Misc.Debug where++import System.IO.Unsafe++unsafePrint msg val =+    unsafePerformIO $+        do+        putStrLn $ "unsafe: " ++ msg+        return val++unsafePrintReturn msg a =+    unsafePrint (msg ++ show a) a++{-| Like 'and' except each boolean parameter has a message+   associated with it and if one of the parameters+   is false, its message is unsafely printed to the console. + -}+andUnsafeReportFirstFalse :: [(Bool, String)] -> Bool+andUnsafeReportFirstFalse [] = True+andUnsafeReportFirstFalse ((True, _) : rest) = andUnsafeReportFirstFalse rest+andUnsafeReportFirstFalse ((False, msg) : _) =+   unsafePrint msg False+   +{-| Like 'or' except each parameter has a message+   associated with it and if all of the parameters+   are false, all their messages are unsafely printed to the console. + -}+orUnsafeReportFalse :: [(Bool, String)] -> Bool+orUnsafeReportFalse boolMsgList+    | notAllFalse = True +    | otherwise =+        unsafePrint allMessages False+    where+    notAllFalse = or boolList+    allMessages = unlines $ messageList+    (boolList, messageList) = unzip boolMsgList
+ src/Numeric/AERN/Misc/List.hs view
@@ -0,0 +1,116 @@+{-|+    Module      :  Numeric.AERN.Misc.List+    Description :  miscellaneous list functions  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Miscellaneous list functions.+-}+module Numeric.AERN.Misc.List where++import qualified System.Random as R++import qualified Data.List as List+import qualified Data.Set as Set+import qualified Data.Map as Map++sortUsing :: (Ord b) => (a -> b) -> [a] -> [a]+sortUsing f =+    List.sortBy compareF+    where+    compareF a b = compare (f a) (f b)++{-|+    Eg: @combinations [[1,2,3],[4,5],[7]] = [[1,4,7], [1,5,7], [2,4,7], [2,5,7], [3,4,7], [3,5,7]]@+-}+combinations :: [[a]] -> [[a]]+combinations [] = [[]]+combinations (options : rest) =+    concat $ map addHeadToAll options +    where+    addHeadToAll h = map (h :) restDone+    restDone = combinations rest +    +{-|+   Eg: @mergeManyLists [[1,2,3],[4,5],[7]] = [1,4,7,2,5,3]@+-}    +mergeManyLists :: [[a]] -> [a]+mergeManyLists lists +    | null listsNonempty = []+    | otherwise =+        heads ++ (mergeManyLists tails)+    where+    (heads, tails) = unzip $ map (\(h:t) -> (h,t)) listsNonempty +    listsNonempty = filter (not . null) lists++getNDistinctSorted :: (Ord a) => Int -> Int -> [a] -> [a]  +getNDistinctSorted seed n xs =+    Set.toAscList $ pickUsingIndices n xsMap randomIndices+    where+    pickUsingIndices _ _ [] = Set.empty+    pickUsingIndices n esMap (i : is)+        | Map.null esMap = Set.empty+        | n > 0 =+            case Map.lookup i esMap of+                Nothing -> pickUsingIndices n esMap is+                Just e -> Set.insert e $ (pickUsingIndices (n-1) (Map.delete i esMap) is)+        | otherwise = Set.empty+    randomIndices = +        map (`mod` (Map.size xsMap)) $ +            map fst $ +                drop 13 $ iterate (R.next . snd) (0,g)+    g = R.mkStdGen seed+    xsMap = Map.fromAscList $ zip [0..] $ Set.toList $ Set.fromList xs++nubSorted :: (Eq a) => [a] -> [a]+nubSorted [] = []+nubSorted (x : xs) =+   aux x xs+   where+   aux x [] = [x]+   aux x (y : ys) +       | x == y = aux x ys+       | otherwise = x : (aux y ys)++{-|+   Like 'zip' except if the lists are non-empty and of different length,+   fill the shorter list with sufficient copies of+   its last element to make the lists of equal length.+   +   Eg @zipFill [1,2,3] [4] = [(1,4),(2,4),(3,4)]@+-}+zipFill :: [a] -> [b] -> [(a,b)] +zipFill [] list2 = []+zipFill list1 [] = []+zipFill [h1] list2 = map (\h2 -> (h1,h2)) list2+zipFill list1 [h2] = map (\h1 -> (h1,h2)) list1+zipFill (h1:t1) (h2:t2) = (h1,h2) : (zipFill t1 t2)++{-|+   Like 'zip' except if the lists are non-empty and of different lengths,+   fill each of the shorter lists with sufficient copies of+   its last element to make all the lists of equal length.+   +   Eg: @zipFill3 [1,2,3] [4,5] [6] = [(1,4,6),(2,5,6),(3,5,6)]@+-}+zipFill3 :: [a] -> [b] -> [c] -> [(a,b,c)] ++zipFill3 [] list2 list3 = []+zipFill3 list1 [] list3 = []+zipFill3 list1 list2 [] = []++zipFill3 [h1] [h2] list3 = map (\h3 -> (h1,h2,h3)) list3+zipFill3 [h1] list2 [h3] = map (\h2 -> (h1,h2,h3)) list2+zipFill3 list1 [h2] [h3] = map (\h1 -> (h1,h2,h3)) list1++zipFill3 [h1] list2 list3 = map (\(h2,h3) -> (h1,h2,h3)) $ zipFill list2 list3+zipFill3 list1 [h2] list3 = map (\(h1,h3) -> (h1,h2,h3)) $ zipFill list1 list3+zipFill3 list1 list2 [h3] = map (\(h1,h2) -> (h1,h2,h3)) $ zipFill list1 list2++zipFill3 (h1:t1) (h2:t2) (h3:t3) = (h1,h2,h3) : (zipFill3 t1 t2 t3)++
+ src/Numeric/AERN/Misc/Maybe.hs view
@@ -0,0 +1,58 @@+{-|+    Module      :  Numeric.AERN.Misc.Maybe+    Description :  utilities for partial predicates and partial operations+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    Utilities for partial predicates and partial operations.+-}+module Numeric.AERN.Misc.Maybe where++import Data.Maybe++defined :: (Maybe t) -> Bool+defined = isJust++assumeTotal1 :: (t1 -> Maybe t) -> (t1 -> t)+assumeTotal1 f a =+    case f a of Just res -> res++assumeTotal2 :: (t2 -> t1 -> Maybe t) -> (t2 -> t1 -> t)+assumeTotal2 f a b =+    case f a b of Just res -> res++completeWith :: t -> (t2 -> t1 -> Maybe t) -> (t2 -> t1 -> t)+completeWith e (*?) e2 e1 =+    case e2 *? e1 of Just r -> r; Nothing -> e  ++trueOrNothing :: Maybe Bool -> Bool +trueOrNothing = nothingOr True++falseOrNothing :: Maybe Bool -> Bool+falseOrNothing = nothingOr False++nothingOr :: (Eq a) => a -> Maybe a -> Bool +nothingOr _ Nothing = True+nothingOr e1 (Just e2) = e1 == e2     ++justButNot :: (Eq a) => a -> Maybe a -> Bool+justButNot _ Nothing = False+justButNot e1 (Just e2) = e1 /= e2 ++(||?) :: Maybe Bool -> Maybe Bool -> Maybe Bool +(||?) b1@(Just True) _ = b1 +(||?) _ b2@(Just True) = b2+(||?) b1@(Just False) b2@(Just False) = b1+(||?) _ _ = Nothing++(&&?) :: Maybe Bool -> Maybe Bool -> Maybe Bool +(&&?) b1@(Just False) _ = b1 +(&&?) _ b2@(Just False) = b2+(&&?) b1@(Just True) b2@(Just True) = b1+(&&?) _ _ = Nothing++
+ src/Numeric/AERN/Misc/QuickCheck.hs view
@@ -0,0 +1,40 @@+{-|+    Module      :  Numeric.AERN.Misc.QuickCheck+    Description :  miscellaneous utilities for QuickCheck  +    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable+    +    miscellaneous utilities for QuickCheck+-}+module Numeric.AERN.Misc.QuickCheck where++import qualified Data.List as List+import Test.QuickCheck++{-| Run the generator with size increased by 1 (useful for avoiding +    too narrow selection at size 0 - in particular Double "randomly" generates +    0 with probability 1 at size 0. +-}+incrSize :: Gen t -> Gen t+incrSize gen = sized (\size -> resize (size + 1) gen)++{-|+    Probability of True is @n/m@.  Precondition: @0<n<m@    +-}+arbitraryBoolRatio :: Int {-^ @n@ -} -> Int {-^ @m@ -} -> Gen Bool +arbitraryBoolRatio n m | 0 < n && n < m =+    frequency [(n, return True), (m - n, return False)]++    +arbitraryOrder :: (Ord t) => [t] -> Gen [t]+arbitraryOrder elems =+    do+    nums <- mapM (const arbitrary) elems+    return $ permuteBy (nums :: [Int]) elems+    where+    permuteBy nums elems =+        map snd $ List.sort $ zip nums elems
+ tools/BenchCsvToGnuplot.hs view
@@ -0,0 +1,206 @@+module Main where++import System.Environment+import System.Exit+import System.Directory+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List as List ++main =+    do+    args <- getArgs+    inFileNames <- checkArgs args+    recordLists <- mapM readCSV inFileNames+    let benchRecords = concat $ map snd recordLists+    let outputData = processData $ map separateImprecision benchRecords+    let outFileNames = map makeOutFileName $ map fst outputData +    mapM_ writeOutputFile $ zip outFileNames outputData+    writeFile "plotAll.gnuplot" $ makeGnuplot inFileNames outFileNames++checkArgs [] = usageAndQuit+checkArgs inFileNames =+    do+    results <- mapM doesFileExist inFileNames+    case and results of+        True -> return inFileNames+        False -> usageAndQuit+        +usageAndQuit =+     do+     progName <- getProgName+     putStrLn $ "usage: " ++ progName ++ " <file1>.csv [<file2>.csv ...]"+     exitFailure++slash2dash '/' = '-'+slash2dash c = c++writeOutputFile (outFileName, (name, benchRecords)) =+    do+    putStrLn outFileName+    writeCSV outFileName (["Imprecision", "Mean"], benchRecords)+    +makeOutFileName name =+    (map space2underscore name) ++ ".csv"+    +space2underscore ' ' = '_'+space2underscore c = c++separateImprecision record =    +    Map.insert "Name" name $+    Map.insert "Imprecision" imprecision $+    record+    where+    name = map slash2dash nameSlashes+    imprecision = tail slashImprecision+    (nameSlashes, slashImprecision) = splitAt slashIndex nameSlashImprecision+    slashIndex = last $ List.elemIndices '/' nameSlashImprecision+    nameSlashImprecision = lookupKey record "Name" +    +processData benchRecords =+    map extractName names+    where+    names = Set.toList $ Set.fromList $ map (\r -> lookupKey r "Name") benchRecords+    extractName name =+        (name, +         filter (\r -> lookupKey r "Name" == name) benchRecords)+    +makeGnuplot inFileNames outFileNames =+    unlines $+        [+         "# AUTO GENERATED FROM " ++ (List.intercalate ", " inFileNames)+         ,"set term postscript eps enhanced"+         ,"set output \"plotAll.eps\""+         ,"set title 'computation time based on result imprecision'"+         ,"set key right bottom"+         ,"set key box linestyle 1"+         ,"set key spacing 1.5"+         ,"set logscale x"+         ,"set logscale y"+         ,"set xlabel 'imprecision'"+         ,"set ylabel 'time'"+         ,"set datafile separator \",\""+        ]+        +++        [makePlotLine outFileNames]+    where+    makePlotLine outFileNames =+        "plot" ++ (List.intercalate "," (map makePlotImport outFileNames))+    makePlotImport outFileName = +        " \"" ++ outFileName ++ "\" using 1:2"+    +type Record = Map.Map String String+type Sheet = ([String], [Record])++lookupKey :: Record -> String -> String+lookupKey record key =+    case Map.lookup key record of+        Nothing -> "" -- error $ "key " ++ show key ++ " not found in record " ++ show record+        Just value -> value+++writeCSV :: FilePath -> Sheet -> IO ()+writeCSV filePath (keys, records) =+    do+    writeFile filePath $ unlines $ map formatLine $ (keys : dataLists)+    where+    dataLists =+        map makeDataItems records+    makeDataItems record =+        [lookupKey record key | key <- keys ]+    formatLine items =+        separateWith "," $ map show items -- must not contain a comma++separateWith sep [] = ""+separateWith sep [a] = a+separateWith sep (h:t) = h ++ sep ++ (separateWith sep t)+++readCSV :: FilePath -> IO Sheet+readCSV filePath =+    do+    contents <- readFile filePath+    return $ processContents contents+    where+    processContents contents =+        (header, recordMaps)+        where+        hdrRecords@(header : records) = parseCSV contents+        recordMaps = +            map snd $+               indexRecordsByKeysAndHeader [] hdrRecords   ++indexRecordsByKeysAndHeader keys (header : records) =+    map getKeysAndMap records+    where+    getKeysAndMap record =+        (getKeys record, getMap record)+    getKeys record =+        map getKey keyIndices+        where+        getKey keyIx = record !! keyIx+    keyIndices =+        map keyIndex keys+    keyIndex key =+        case List.elemIndex key header of+            Nothing -> error $ "key " ++ show key ++ " not found in the header " ++ show header+            Just ix -> ix+    getMap record =+        Map.fromList $ zip header record++-- | parse records and their fields from the contents of a CSV file+parseCSV :: String -> [[String]]+parseCSV contents =+    records+    where+    records =+        map parseLine $ lines contents+    parseLine line =+        state1 0 [] "" line+        where+        -- expecting new field or end of line; initial state+        state1 pos revPrevItems revPrevOutput [] =+            reverse $ reverse revPrevOutput : revPrevItems+        state1 pos revPrevItems revPrevOutput "\x0D" = -- DOS end of line+            reverse $ reverse revPrevOutput : revPrevItems+        state1 pos revPrevItems revPrevOutput (',' : cs) =+            state1 (pos + 1) (reverse revPrevOutput : revPrevItems) "" cs+        state1 pos revPrevItems revPrevOutput ('"' : cs) =+            state3 (pos + 1) revPrevItems revPrevOutput cs+        state1 pos revPrevItems revPrevOutput (c : cs) =+            state2 (pos + 1) revPrevItems (c : revPrevOutput) cs++        -- reading a field with no double quotes+        state2 pos revPrevItems revPrevOutput [] =+            reverse $ reverse revPrevOutput : revPrevItems+        state2 pos revPrevItems revPrevOutput "\x0D" = -- DOS end of line+            reverse $ reverse revPrevOutput : revPrevItems+        state2 pos revPrevItems revPrevOutput (',' : cs) =+            state1 (pos + 1) (reverse revPrevOutput : revPrevItems) "" cs+        state2 pos revPrevItems revPrevOutput (c : cs) =+            state2 (pos + 1) revPrevItems (c : revPrevOutput) cs++        -- reading a field in double quotes+        state3 pos revPrevItems revPrevOutput [] =+            parseerror pos+        state3 pos revPrevItems revPrevOutput ('"' : cs) =+            state4 (pos + 1) revPrevItems revPrevOutput cs+        state3 pos revPrevItems revPrevOutput (c : cs) =+            state3 (pos + 1) revPrevItems (c : revPrevOutput) cs++        -- reading a field in double quotes and just found a double quote+        -- that could be the closing one or an inner one+        state4 pos revPrevItems revPrevOutput [] =+            reverse $ reverse revPrevOutput : revPrevItems+        state4 pos revPrevItems revPrevOutput "\x0D" = -- DOS end of line+            reverse $ reverse revPrevOutput : revPrevItems+        state4 pos revPrevItems revPrevOutput (',' : cs) =+            state1 (pos + 1) (reverse revPrevOutput : revPrevItems) "" cs+        state4 pos revPrevItems revPrevOutput (c : cs) =+            state3 (pos + 1) revPrevItems (c : revPrevOutput) cs++        parseerror pos =+            error $+                "parse error in CVS file at pos:\n"+                ++ take pos line ++ "\n"+                ++ replicate pos ' ' ++ drop pos line