Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Abstract away the interface of Interval from the rest of the module #2

Merged
merged 3 commits into from Mar 6, 2019
Merged

Abstract away the interface of Interval from the rest of the module #2

Changes from 1 commit
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
67c6af0
Abstract away the interface of Interval from the rest of the module
Bodigrim Feb 11, 2019
d997377
Move Interval to its own internal module
Bodigrim Mar 4, 2019
35017d6
Revert automatic deriving of Data and Generic
Bodigrim Mar 4, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
182 changes: 90 additions & 92 deletions src/Data/Interval.hs
View file
Open in desktop
@@ -1,5 +1,5 @@
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}
{-# LANGUAGE Safe #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE RoleAnnotations #-}
Expand Down Expand Up @@ -89,6 +89,7 @@ import Data.List hiding (null)
import Data.Maybe
import Data.Monoid
import Data.Ratio
import GHC.Generics (Generic)
import Prelude hiding (null)

infix 5 <=..<=
Expand All @@ -115,48 +116,22 @@ infix 4 >??
infix 4 /=??

-- | The intervals (/i.e./ connected and convex subsets) over real numbers __R__.
data Interval r = Interval !(Extended r, Bool) !(Extended r, Bool)
deriving (Eq, Typeable)
data Interval r = Interval
{ -- | 'lowerBound' of the interval and whether it is included in the interval.
-- The result is convenient to use as an argument for 'interval'.
lowerBound' :: !(Extended r, Bool)
, -- | 'upperBound' of the interval and whether it is included in the interval.
-- The result is convenient to use as an argument for 'interval'.
upperBound' :: !(Extended r, Bool)
} deriving (Eq, Generic, Data, Typeable)
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This PR replaces hand-written Data instance with the one generated by GHC.
But doesn’t the generated one allow constructing unnormalized interval value (e.g. through gmapT)?

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I confirmed that following y becomes unnormalized interval where lower bounds is Finite (-1) while upper bound is Finite 0.

{-# LANGUAGE ScopedTypeVariables #-}
import qualified Data.Interval as Interval
import Data.Data
import Data.Maybe

f :: Data a => a -> a
f x = fromJust $ do
  (x' :: Interval.Extended Integer, b::Bool) <- cast x
  cast (fmap negate x', b)

x :: Interval.Interval Integer
x = 0 Interval.<=..<= 1

y :: Interval.Interval Integer
y = gmapT f x

So could you revert this change?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Done, my bad.


#if __GLASGOW_HASKELL__ >= 708
type role Interval nominal
#endif

-- | Lower endpoint (/i.e./ greatest lower bound) of the interval.
--
-- * 'lowerBound' of the empty interval is 'PosInf'.
--
-- * 'lowerBound' of a left unbounded interval is 'NegInf'.
--
-- * 'lowerBound' of an interval may or may not be a member of the interval.
lowerBound :: Interval r -> Extended r
lowerBound (Interval (lb,_) _) = lb

-- | Upper endpoint (/i.e./ least upper bound) of the interval.
--
-- * 'upperBound' of the empty interval is 'NegInf'.
--
-- * 'upperBound' of a right unbounded interval is 'PosInf'.
--
-- * 'upperBound' of an interval may or may not be a member of the interval.
upperBound :: Interval r -> Extended r
upperBound (Interval _ (ub,_)) = ub

-- | 'lowerBound' of the interval and whether it is included in the interval.
-- The result is convenient to use as an argument for 'interval'.
lowerBound' :: Interval r -> (Extended r, Bool)
lowerBound' (Interval lb _) = lb

-- | 'upperBound' of the interval and whether it is included in the interval.
-- The result is convenient to use as an argument for 'interval'.
upperBound' :: Interval r -> (Extended r, Bool)
upperBound' (Interval _ ub) = ub

instance NFData r => NFData (Interval r) where
rnf (Interval lb ub) = rnf lb `seq` rnf ub
instance NFData r => NFData (Interval r)

instance Hashable r => Hashable (Interval r) where
hashWithSalt s (Interval lb ub) = s `hashWithSalt` lb `hashWithSalt` ub
instance Hashable r => Hashable (Interval r)

instance (Ord r) => JoinSemiLattice (Interval r) where
join = hull
Expand All @@ -176,12 +151,14 @@ instance (Ord r) => BoundedLattice (Interval r)

instance (Ord r, Show r) => Show (Interval r) where
showsPrec _ x | null x = showString "empty"
showsPrec p (Interval (lb,in1) (ub,in2)) =
showsPrec p i =
showParen (p > rangeOpPrec) $
showsPrec (rangeOpPrec+1) lb .
showsPrec (rangeOpPrec+1) lb .
showChar ' ' . showString op . showChar ' ' .
showsPrec (rangeOpPrec+1) ub
where
(lb, in1) = lowerBound' i
(ub, in2) = upperBound' i
op = (if in1 then "<=" else "<") ++ ".." ++ (if in2 then "<=" else "<")

instance (Ord r, Read r) => Read (Interval r) where
Expand All @@ -208,23 +185,9 @@ instance (Ord r, Read r) => Read (Interval r) where
(do ("empty", s) <- lex r
return (empty, s))

-- This instance preserves data abstraction at the cost of inefficiency.
-- We provide limited reflection services for the sake of data abstraction.

instance (Ord r, Data r) => Data (Interval r) where
gfoldl k z x = z interval `k` lowerBound' x `k` upperBound' x
toConstr _ = intervalConstr
gunfold k z c = case constrIndex c of
1 -> k (k (z interval))
_ -> error "gunfold"
dataTypeOf _ = intervalDataType
dataCast1 f = gcast1 f

intervalConstr :: Constr
intervalConstr = mkConstr intervalDataType "interval" [] Prefix

intervalDataType :: DataType
intervalDataType = mkDataType "Data.Interval.Interval" [intervalConstr]
-- | empty (contradicting) interval
empty :: Ord r => Interval r
empty = Interval (PosInf, False) (NegInf, False)

-- | smart constructor for 'Interval'
interval
Expand All @@ -241,6 +204,26 @@ interval lb@(x1,in1) ub@(x2,in2) =
normalize x@(Finite _, _) = x
normalize (x, _) = (x, False)

-- | Lower endpoint (/i.e./ greatest lower bound) of the interval.
--
-- * 'lowerBound' of the empty interval is 'PosInf'.
--
-- * 'lowerBound' of a left unbounded interval is 'NegInf'.
--
-- * 'lowerBound' of an interval may or may not be a member of the interval.
lowerBound :: Interval r -> Extended r
lowerBound = fst . lowerBound'

-- | Upper endpoint (/i.e./ least upper bound) of the interval.
--
-- * 'upperBound' of the empty interval is 'NegInf'.
--
-- * 'upperBound' of a right unbounded interval is 'PosInf'.
--
-- * 'upperBound' of an interval may or may not be a member of the interval.
upperBound :: Interval r -> Extended r
upperBound = fst . upperBound'

-- | closed interval [@l@,@u@]
(<=..<=)
:: (Ord r)
Expand Down Expand Up @@ -275,19 +258,17 @@ interval lb@(x1,in1) ub@(x2,in2) =

-- | whole real number line (-∞, ∞)
whole :: Ord r => Interval r
whole = Interval (NegInf, False) (PosInf, False)

-- | empty (contradicting) interval
empty :: Ord r => Interval r
empty = Interval (PosInf, False) (NegInf, False)
whole = interval (NegInf, False) (PosInf, False)

-- | singleton set \[x,x\]
singleton :: Ord r => r -> Interval r
singleton x = interval (Finite x, True) (Finite x, True)

-- | intersection of two intervals
intersection :: forall r. Ord r => Interval r -> Interval r -> Interval r
intersection (Interval l1 u1) (Interval l2 u2) = interval (maxLB l1 l2) (minUB u1 u2)
intersection i1 i2 = interval
(maxLB (lowerBound' i1) (lowerBound' i2))
(minUB (upperBound' i1) (upperBound' i2))
where
maxLB :: (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)
maxLB (x1,in1) (x2,in2) =
Expand Down Expand Up @@ -317,7 +298,9 @@ hull :: forall r. Ord r => Interval r -> Interval r -> Interval r
hull x1 x2
| null x1 = x2
| null x2 = x1
hull (Interval l1 u1) (Interval l2 u2) = interval (minLB l1 l2) (maxUB u1 u2)
hull i1 i2 = interval
(minLB (lowerBound' i1) (lowerBound' i2))
(maxUB (upperBound' i1) (upperBound' i2))
where
maxUB :: (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)
maxUB (x1,in1) (x2,in2) =
Expand All @@ -344,20 +327,26 @@ hulls = foldl' hull empty

-- | Is the interval empty?
null :: Ord r => Interval r -> Bool
null (Interval (x1,in1) (x2,in2)) =
null i =
case x1 `compare` x2 of
EQ -> assert (in1 && in2) False
LT -> False
GT -> True
where
(x1, in1) = lowerBound' i
(x2, in2) = upperBound' i

isSingleton :: Ord r => Interval r -> Bool
isSingleton (Interval (Finite l, True) (Finite u, True)) = l==u
isSingleton _ = False
isSingleton i = case (lowerBound' i, upperBound' i) of
((Finite l, True), (Finite u, True)) -> l==u
_ -> False

-- | Is the element in the interval?
member :: Ord r => r -> Interval r -> Bool
member x (Interval (x1,in1) (x2,in2)) = condLB && condUB
member x i = condLB && condUB
where
(x1, in1) = lowerBound' i
(x2, in2) = upperBound' i
condLB = if in1 then x1 <= Finite x else x1 < Finite x
condUB = if in2 then Finite x <= x2 else Finite x < x2

Expand All @@ -368,7 +357,7 @@ notMember a i = not $ member a i
-- | Is this a subset?
-- @(i1 \``isSubsetOf`\` i2)@ tells whether @i1@ is a subset of @i2@.
isSubsetOf :: Ord r => Interval r -> Interval r -> Bool
isSubsetOf (Interval lb1 ub1) (Interval lb2 ub2) = testLB lb1 lb2 && testUB ub1 ub2
isSubsetOf i1 i2 = testLB (lowerBound' i1) (lowerBound' i2) && testUB (upperBound' i1) (upperBound' i2)
where
testLB (x1,in1) (x2,in2) =
case x1 `compare` x2 of
Expand Down Expand Up @@ -401,21 +390,24 @@ isConnected x y

-- | Width of a interval. Width of an unbounded interval is @undefined@.
width :: (Num r, Ord r) => Interval r -> r
width x | null x = 0
width (Interval (Finite l, _) (Finite u, _)) = u - l
width _ = error "Data.Interval.width: unbounded interval"
width x
| null x = 0
| otherwise = case (fst (lowerBound' x), fst (upperBound' x)) of
(Finite l, Finite u) -> u - l
_ -> error "Data.Interval.width: unbounded interval"

-- | pick up an element from the interval if the interval is not empty.
pickup :: (Real r, Fractional r) => Interval r -> Maybe r
pickup (Interval (NegInf,_) (PosInf,_)) = Just 0
pickup (Interval (Finite x1, in1) (PosInf,_)) = Just $ if in1 then x1 else x1+1
pickup (Interval (NegInf,_) (Finite x2, in2)) = Just $ if in2 then x2 else x2-1
pickup (Interval (Finite x1, in1) (Finite x2, in2)) =
case x1 `compare` x2 of
GT -> Nothing
LT -> Just $ (x1+x2) / 2
EQ -> if in1 && in2 then Just x1 else Nothing
pickup _ = Nothing
pickup i = case (lowerBound' i, upperBound' i) of
((NegInf,_), (PosInf,_)) -> Just 0
((Finite x1, in1), (PosInf,_)) -> Just $ if in1 then x1 else x1+1
((NegInf,_), (Finite x2, in2)) -> Just $ if in2 then x2 else x2-1
((Finite x1, in1), (Finite x2, in2)) ->
case x1 `compare` x2 of
GT -> Nothing
LT -> Just $ (x1+x2) / 2
EQ -> if in1 && in2 then Just x1 else Nothing
_ -> Nothing

-- | 'simplestRationalWithin' returns the simplest rational number within the interval.
--
Expand Down Expand Up @@ -605,16 +597,20 @@ rangeOpPrec :: Int
rangeOpPrec = 5

scaleInterval :: (Num r, Ord r) => r -> Interval r -> Interval r
scaleInterval _ x | null x = empty
scaleInterval c (Interval lb ub) =
case compare c 0 of
scaleInterval c x
| null x = empty
| otherwise = case compare c 0 of
EQ -> singleton 0
LT -> interval (scaleInf' c ub) (scaleInf' c lb)
GT -> interval (scaleInf' c lb) (scaleInf' c ub)
where
lb = lowerBound' x
ub = upperBound' x

instance (Num r, Ord r) => Num (Interval r) where
a + b | null a || null b = empty
Interval lb1 ub1 + Interval lb2 ub2 = interval (f lb1 lb2) (g ub1 ub2)
a + b
| null a || null b = empty
| otherwise = interval (f (lowerBound' a) (lowerBound' b)) (g (upperBound' a) (upperBound' b))
where
f (Finite x1, in1) (Finite x2, in2) = (Finite (x1+x2), in1 && in2)
f (NegInf,_) _ = (-inf, False)
Expand Down Expand Up @@ -644,22 +640,24 @@ instance (Num r, Ord r) => Num (Interval r) where
then empty
else singleton (-1)

a * b | null a || null b = empty
Interval lb1 ub1 * Interval lb2 ub2 = interval lb3 ub3
a * b
| null a || null b = empty
| otherwise = interval lb3 ub3
where
xs = [ mulInf' x1 x2 | x1 <- [lb1, ub1], x2 <- [lb2, ub2] ]
xs = [ mulInf' x1 x2 | x1 <- [lowerBound' a, upperBound' a], x2 <- [lowerBound' b, upperBound' b] ]
ub3 = maximumBy cmpUB xs
lb3 = minimumBy cmpLB xs

instance forall r. (Real r, Fractional r) => Fractional (Interval r) where
fromRational r = singleton (fromRational r)
recip a | null a = empty
recip i | 0 `member` i = whole -- should be error?
recip (Interval lb ub) = interval lb3 ub3
recip a
| null a = empty
| 0 `member` a = whole -- should be error?
| otherwise = interval lb3 ub3
where
ub3 = maximumBy cmpUB xs
lb3 = minimumBy cmpLB xs
xs = [recipLB lb, recipUB ub]
xs = [recipLB (lowerBound' a), recipUB (upperBound' a)]

cmpUB, cmpLB :: Ord r => (Extended r, Bool) -> (Extended r, Bool) -> Ordering
cmpUB (x1,in1) (x2,in2) = compare x1 x2 `mappend` compare in1 in2
Expand Down