diff --git a/data-interval.cabal b/data-interval.cabal index 2e2a9fe..385bb66 100644 --- a/data-interval.cabal +++ b/data-interval.cabal @@ -44,7 +44,7 @@ Library , containers >= 0.5.8 && < 0.9 , deepseq < 1.6 , hashable >=1.1.2.5 && <1.6 - , extended-reals >=0.2 && <1.0 + , extended-reals >=0.2.7 && <1.0 if flag(lattices) build-depends: lattices >=2 && <2.3 @@ -64,6 +64,7 @@ Library Data.IntervalRelation Data.IntervalSet Data.IntegerInterval + Data.RealFloatInterval Other-Modules: Data.Interval.Internal Data.IntegerInterval.Internal diff --git a/src/Data/RealFloatInterval.hs b/src/Data/RealFloatInterval.hs new file mode 100644 index 0000000..a64b973 --- /dev/null +++ b/src/Data/RealFloatInterval.hs @@ -0,0 +1,173 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE RoleAnnotations #-} +-- | +-- Module : Data.RealFloatInterval +-- Copyright : (c) Masahiro Sakai 2011-2013, Andrew Lelechenko 2020 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (CPP, ScopedTypeVariables, DeriveDataTypeable) +-- +module Data.RealFloatInterval + ( + -- * Interval type + Interval + , Boundary(..) + + -- * Construction + , interval + , (<=..<=) + , (<..<=) + , (<=..<) + , (<..<) + , whole + , empty + , singleton + + -- * Query + , null + , isSingleton + , extractSingleton + , member + , notMember + , isSubsetOf + , isProperSubsetOf + , isConnected + , lowerBound + , upperBound + , lowerBound' + , upperBound' + , width + + -- * Universal comparison operators + , (=!), (>!), (/=!) + + -- * Existential comparison operators + , (=?), (>?), (/=?) + + -- * Existential comparison operators that produce witnesses (experimental) + , (=??), (>??), (/=??) + + -- * Combine + , intersection + , intersections + , hull + , hulls + + -- * Map + , mapMonotonic + + -- * Operations + , pickup + , simplestRationalWithin + + -- * Intervals relation + , relate + ) where + +import Data.ExtendedReal +import Data.Interval (null, isSingleton, extractSingleton, isSubsetOf, isProperSubsetOf, isConnected, (=!), (>!), (/=!), (=?), (>?), (/=?), (=??), (>??), (/=??), intersection, intersections, hull, hulls, pickup, simplestRationalWithin, relate) +import Data.Interval.Internal (Boundary(..), Interval, empty) +import qualified Data.Interval.Internal as Internal +import Prelude hiding (null) +import Control.Arrow (first) + +infix 5 <=..<= +infix 5 <..<= +infix 5 <=..< +infix 5 <..< + +lowerBound' :: RealFloat r => Interval r -> (r, Boundary) +lowerBound' = first toRealFloat . Internal.lowerBound' + +upperBound' :: RealFloat r => Interval r -> (r, Boundary) +upperBound' = first toRealFloat . Internal.upperBound' + +-- | Lower endpoint (/i.e./ greatest lower bound) of the interval. +lowerBound :: RealFloat r => Interval r -> r +lowerBound = fst . lowerBound' + +-- | Upper endpoint (/i.e./ least upper bound) of the interval. +upperBound :: RealFloat r => Interval r -> r +upperBound = fst . upperBound' + +interval :: RealFloat r => (r, Boundary) -> (r, Boundary) -> Interval r +interval lb ub = Internal.interval (first fromRealFloat lb) (first fromRealFloat ub) + +-- | closed interval [@l@,@u@] +(<=..<=) + :: (Ord r, RealFloat r) + => r -- ^ lower bound @l@ + -> r -- ^ upper bound @u@ + -> Interval r +(<=..<=) lb ub = interval (lb, Closed) (ub, Closed) + +-- | left-open right-closed interval (@l@,@u@] +(<..<=) + :: (Ord r, RealFloat r) + => r -- ^ lower bound @l@ + -> r -- ^ upper bound @u@ + -> Interval r +(<..<=) lb ub = interval (lb, Open) (ub, Closed) + +-- | left-closed right-open interval [@l@, @u@) +(<=..<) + :: (Ord r, RealFloat r) + => r -- ^ lower bound @l@ + -> r -- ^ upper bound @u@ + -> Interval r +(<=..<) lb ub = interval (lb, Closed) (ub, Open) + +-- | open interval (@l@, @u@) +(<..<) + :: (Ord r, RealFloat r) + => r -- ^ lower bound @l@ + -> r -- ^ upper bound @u@ + -> Interval r +(<..<) lb ub = interval (lb, Open) (ub, Open) + +-- | whole real number line (-∞, ∞) +whole :: Ord r => Interval r +whole = Internal.interval (NegInf, Open) (PosInf, Open) + +-- | singleton set [x,x] +singleton :: (Ord r, RealFloat r) => r -> Interval r +singleton x = interval (x, Closed) (x, Closed) + +-- | Is the element finite and in the interval? +member :: (Ord r, RealFloat r) => r -> Interval r -> Bool +member x i = condLB && condUB + where + (x1, in1) = lowerBound' i + (x2, in2) = upperBound' i + condLB = case in1 of + Open -> x1 < x + Closed -> x1 <= x + condUB = case in2 of + Open -> x < x2 + Closed -> x <= x2 + +-- | Is the element infinite or not in the interval? +notMember :: (Ord r, RealFloat r) => r -> Interval r -> Bool +notMember a i = not $ member a i + +-- | Width of a interval. Width of an unbounded interval is infinite. +width :: (Num r, Ord r, RealFloat r) => Interval r -> r +width x + | null x = 0 + | otherwise = fst (upperBound' x) - fst (lowerBound' x) + +-- | @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function, +-- preserving negative and positive infinities. +mapMonotonic :: (Ord a, Ord b, RealFloat a, RealFloat b) => (a -> b) -> Interval a -> Interval b +mapMonotonic f i = Internal.interval (applyF lb, in1) (applyF ub, in2) + where + (lb, in1) = Internal.lowerBound' i + (ub, in2) = Internal.upperBound' i + applyF = \case + PosInf -> PosInf + NegInf -> NegInf + Finite r -> fromRealFloat $ f r