diff --git a/AERN-Basics.cabal b/AERN-Basics.cabal new file mode 100644 --- /dev/null +++ b/AERN-Basics.cabal @@ -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 (⊑) 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 + + diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +2011.1: 6th May 2011 + * initial release of AERN-Basics + diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Numeric/AERN/Basics/Bench.hs b/src/Numeric/AERN/Basics/Bench.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Bench.hs @@ -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 + + diff --git a/src/Numeric/AERN/Basics/Consistency.hs b/src/Numeric/AERN/Basics/Consistency.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Consistency.hs @@ -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) + ] diff --git a/src/Numeric/AERN/Basics/Effort.hs b/src/Numeric/AERN/Basics/Effort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Effort.hs @@ -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 + + diff --git a/src/Numeric/AERN/Basics/Exception.hs b/src/Numeric/AERN/Basics/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Exception.hs @@ -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 +∞ or down to -∞; 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 +∞ or -∞ +-} +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 + diff --git a/src/Numeric/AERN/Basics/Laws/Operation.hs b/src/Numeric/AERN/Basics/Laws/Operation.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Laws/Operation.hs @@ -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 + + diff --git a/src/Numeric/AERN/Basics/Laws/OperationRelation.hs b/src/Numeric/AERN/Basics/Laws/OperationRelation.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Laws/OperationRelation.hs @@ -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 diff --git a/src/Numeric/AERN/Basics/Laws/PartialRelation.hs b/src/Numeric/AERN/Basics/Laws/PartialRelation.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Laws/PartialRelation.hs @@ -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) diff --git a/src/Numeric/AERN/Basics/Laws/Relation.hs b/src/Numeric/AERN/Basics/Laws/Relation.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Laws/Relation.hs @@ -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 + diff --git a/src/Numeric/AERN/Basics/Laws/RoundedOpInPlace.hs b/src/Numeric/AERN/Basics/Laws/RoundedOpInPlace.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Laws/RoundedOpInPlace.hs @@ -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 + diff --git a/src/Numeric/AERN/Basics/Laws/RoundedOperation.hs b/src/Numeric/AERN/Basics/Laws/RoundedOperation.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Laws/RoundedOperation.hs @@ -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 (<=?) + + diff --git a/src/Numeric/AERN/Basics/Laws/Utilities.hs b/src/Numeric/AERN/Basics/Laws/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Laws/Utilities.hs @@ -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 diff --git a/src/Numeric/AERN/Basics/Mutable.hs b/src/Numeric/AERN/Basics/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/Mutable.hs @@ -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 :: diff --git a/src/Numeric/AERN/Basics/NumericOrder.hs b/src/Numeric/AERN/Basics/NumericOrder.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder.hs @@ -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 diff --git a/src/Numeric/AERN/Basics/NumericOrder/Arbitrary.hs b/src/Numeric/AERN/Basics/NumericOrder/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/Arbitrary.hs @@ -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) + ] diff --git a/src/Numeric/AERN/Basics/NumericOrder/Extrema.hs b/src/Numeric/AERN/Basics/NumericOrder/Extrema.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/Extrema.hs @@ -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 + diff --git a/src/Numeric/AERN/Basics/NumericOrder/InPlace/OpsDefaultEffort.hs b/src/Numeric/AERN/Basics/NumericOrder/InPlace/OpsDefaultEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/InPlace/OpsDefaultEffort.hs @@ -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 + + diff --git a/src/Numeric/AERN/Basics/NumericOrder/InPlace/OpsImplicitEffort.hs b/src/Numeric/AERN/Basics/NumericOrder/InPlace/OpsImplicitEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/InPlace/OpsImplicitEffort.hs @@ -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 diff --git a/src/Numeric/AERN/Basics/NumericOrder/InPlace/RefinementRoundedLattice.hs b/src/Numeric/AERN/Basics/NumericOrder/InPlace/RefinementRoundedLattice.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/InPlace/RefinementRoundedLattice.hs @@ -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) + ] + diff --git a/src/Numeric/AERN/Basics/NumericOrder/InPlace/RoundedLattice.hs b/src/Numeric/AERN/Basics/NumericOrder/InPlace/RoundedLattice.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/InPlace/RoundedLattice.hs @@ -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) + ] + diff --git a/src/Numeric/AERN/Basics/NumericOrder/OpsDefaultEffort.hs b/src/Numeric/AERN/Basics/NumericOrder/OpsDefaultEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/OpsDefaultEffort.hs @@ -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` +( t -> t -> Maybe Bool +( 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 + + diff --git a/src/Numeric/AERN/Basics/NumericOrder/OpsImplicitEffort.hs b/src/Numeric/AERN/Basics/NumericOrder/OpsImplicitEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/OpsImplicitEffort.hs @@ -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` +( + t -> t -> Maybe Bool +( + 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 diff --git a/src/Numeric/AERN/Basics/NumericOrder/PartialComparison.hs b/src/Numeric/AERN/Basics/NumericOrder/PartialComparison.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/PartialComparison.hs @@ -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) + ] + diff --git a/src/Numeric/AERN/Basics/NumericOrder/RefinementRoundedLattice.hs b/src/Numeric/AERN/Basics/NumericOrder/RefinementRoundedLattice.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/RefinementRoundedLattice.hs @@ -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) + ] + diff --git a/src/Numeric/AERN/Basics/NumericOrder/RoundedLattice.hs b/src/Numeric/AERN/Basics/NumericOrder/RoundedLattice.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/NumericOrder/RoundedLattice.hs @@ -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) + ] diff --git a/src/Numeric/AERN/Basics/PartialOrdering.hs b/src/Numeric/AERN/Basics/PartialOrdering.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/PartialOrdering.hs @@ -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 + + diff --git a/src/Numeric/AERN/Basics/RefinementOrder.hs b/src/Numeric/AERN/Basics/RefinementOrder.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder.hs @@ -0,0 +1,36 @@ +{-| + Module : Numeric.AERN.Basics.RefinementOrder + Description : classical and approximate domain bases and lattices (⊑⊑,⊓⊓,⊔⊔) + 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 + (⊑,⊓,⊔). + + 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 diff --git a/src/Numeric/AERN/Basics/RefinementOrder/Arbitrary.hs b/src/Numeric/AERN/Basics/RefinementOrder/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/Arbitrary.hs @@ -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) + ] diff --git a/src/Numeric/AERN/Basics/RefinementOrder/Extrema.hs b/src/Numeric/AERN/Basics/RefinementOrder/Extrema.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/Extrema.hs @@ -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 diff --git a/src/Numeric/AERN/Basics/RefinementOrder/InPlace/OpsDefaultEffort.hs b/src/Numeric/AERN/Basics/RefinementOrder/InPlace/OpsDefaultEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/InPlace/OpsDefaultEffort.hs @@ -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 +(>⊓<=) = (>/\<=) diff --git a/src/Numeric/AERN/Basics/RefinementOrder/InPlace/OpsImplicitEffort.hs b/src/Numeric/AERN/Basics/RefinementOrder/InPlace/OpsImplicitEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/InPlace/OpsImplicitEffort.hs @@ -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 +(>⊓<=) = (>/\<=) diff --git a/src/Numeric/AERN/Basics/RefinementOrder/InPlace/RoundedBasis.hs b/src/Numeric/AERN/Basics/RefinementOrder/InPlace/RoundedBasis.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/InPlace/RoundedBasis.hs @@ -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) + ] diff --git a/src/Numeric/AERN/Basics/RefinementOrder/InPlace/RoundedLattice.hs b/src/Numeric/AERN/Basics/RefinementOrder/InPlace/RoundedLattice.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/InPlace/RoundedLattice.hs @@ -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) + ] + diff --git a/src/Numeric/AERN/Basics/RefinementOrder/OpsDefaultEffort.hs b/src/Numeric/AERN/Basics/RefinementOrder/OpsDefaultEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/OpsDefaultEffort.hs @@ -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` +(| t -> t -> Maybe Bool +(| 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 '| t -> t -> Maybe Bool +(⊏?) = (| 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 +(>\/ t -> t -> Maybe t +(>\/) :: (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 '>\/⊔ t -> t -> Maybe t +(>⊔\/' -} +(<⊔>) :: (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 +(>⊓<) = (>/\<) diff --git a/src/Numeric/AERN/Basics/RefinementOrder/OpsImplicitEffort.hs b/src/Numeric/AERN/Basics/RefinementOrder/OpsImplicitEffort.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/OpsImplicitEffort.hs @@ -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 2 <\/>, <⊔>, >\/<, >⊔< + + +(|==?), (|<==>?), (|?), (|?), (|<=?), (|>=?) :: + (PartialComparison t, + ?pCompareEffort :: PartialCompareEffortIndicator t) => + t -> t -> Maybe Bool + +(|==?) = pEqualEff ?pCompareEffort +(|<==>?) = pComparableEff ?pCompareEffort +(|?) = pIncomparableEff ?pCompareEffort +(|?) = pGreaterEff ?pCompareEffort +(|<=?) = pLeqEff ?pCompareEffort +(|>=?) = pGeqEff ?pCompareEffort + + +(<\/>?) :: + (OuterRoundedBasis t, ?partialJoinOutEffort :: PartialJoinOutEffortIndicator t) => + t -> t -> Maybe t +(<\/>?) = partialJoinOutEff ?partialJoinOutEffort + +(>\/ + t -> t -> Maybe t + +(>\/), () :: + (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 '>\/⊔ + t -> t -> Maybe t +(>⊔\/' -} +(<⊔>) :: + (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 +(>⊓<) = (>/\<) diff --git a/src/Numeric/AERN/Basics/RefinementOrder/PartialComparison.hs b/src/Numeric/AERN/Basics/RefinementOrder/PartialComparison.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/PartialComparison.hs @@ -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) + ] diff --git a/src/Numeric/AERN/Basics/RefinementOrder/RoundedBasis.hs b/src/Numeric/AERN/Basics/RefinementOrder/RoundedBasis.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/RefinementOrder/RoundedBasis.hs @@ -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 ++ " (<⊔>?, >⊔ 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) diff --git a/src/Numeric/AERN/Basics/ShowInternals.hs b/src/Numeric/AERN/Basics/ShowInternals.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Basics/ShowInternals.hs @@ -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 + + diff --git a/src/Numeric/AERN/Misc/Bool.hs b/src/Numeric/AERN/Misc/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Misc/Bool.hs @@ -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 diff --git a/src/Numeric/AERN/Misc/Debug.hs b/src/Numeric/AERN/Misc/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Misc/Debug.hs @@ -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 diff --git a/src/Numeric/AERN/Misc/List.hs b/src/Numeric/AERN/Misc/List.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Misc/List.hs @@ -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) + + diff --git a/src/Numeric/AERN/Misc/Maybe.hs b/src/Numeric/AERN/Misc/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Misc/Maybe.hs @@ -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 + + diff --git a/src/Numeric/AERN/Misc/QuickCheck.hs b/src/Numeric/AERN/Misc/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/AERN/Misc/QuickCheck.hs @@ -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 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 diff --git a/tools/BenchCsvToGnuplot.hs b/tools/BenchCsvToGnuplot.hs new file mode 100644 --- /dev/null +++ b/tools/BenchCsvToGnuplot.hs @@ -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 ++ " .csv [.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