1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
module Data.IntervalSet
( IntSet
, null
, empty
, insert
, delete
, interval
, toIntervals
, nearestOutsider
, Data.IntervalSet.lookup
) where
import Prelude hiding (null)
import qualified Data.IntMap.Strict as IntMap
;import Data.IntMap.Strict (IntMap)
import qualified Data.List as List
import Data.Ord
-- A set of integers.
newtype IntSet = IntSet (IntMap Interval)
deriving Show
-- Note: the intervalMin is not stored here but is the lookup key in an IntMap.
data Interval = Interval
{ intervalMax :: {-# UNPACK #-} !Int -- ^ Maximum value contained in this interval.
, intervalNext :: {-# UNPACK #-} !Int -- ^ Minimum value in next interval if there is one.
}
deriving Show
null :: IntSet -> Bool
null (IntSet m) = IntMap.null m
empty :: IntSet
empty = IntSet IntMap.empty
insert :: Int -> IntSet -> IntSet
insert x (IntSet m) = IntSet $ case IntMap.lookupLE x m of
Just (lb,Interval mx ub)
| x <= mx -> m
| otherwise -> case ub == maxBound of
True | x == mx + 1 -> IntMap.insert lb (Interval x maxBound) m
| otherwise -> IntMap.insert lb (Interval mx x)
$ IntMap.insert x (Interval x maxBound) m
False | mx + 2 == ub -> let (Just v', m')
= IntMap.updateLookupWithKey (\_ _ -> Nothing) ub m
in IntMap.insert lb v' m'
| mx + 1 == x -> IntMap.insert lb (Interval x ub) m
| otherwise -> IntMap.insert lb (Interval mx x)
$ if ub == x + 1
then let (Just v', m')
= IntMap.updateLookupWithKey
(\_ _ -> Nothing) ub m
in IntMap.insert x v' m'
else IntMap.insert x (Interval x ub) m
Nothing -> case IntMap.minViewWithKey m of
Just ((ub,v),m')
| x + 1 == ub -> IntMap.insert x v m'
| otherwise -> IntMap.insert x (Interval x ub) m
Nothing -> IntMap.singleton x (Interval x maxBound)
member :: Int -> IntSet -> Bool
member x (IntSet m) = case IntMap.lookupLE x m of
Just (lb,Interval mx _) -> x <= mx
Nothing -> False
nearestOutsider :: Int -> IntSet -> Maybe Int
nearestOutsider x (IntSet m)
| List.null xs = Nothing -- There are no integers outside the set!
| otherwise = Just $ List.minimumBy (comparing (\y -> abs (x - y))) xs
where
xs = case IntMap.lookupLE x m of
Nothing -> [x]
Just (lb,Interval mx ub)
-> if ub < maxBound
then case () of
() | x > mx -> [x]
| minBound < lb -> [lb-1, mx+1, ub-1]
| otherwise -> [mx+1, ub-1]
else case () of
() | x > mx -> [x]
| minBound < lb && mx < maxBound -> [lb-1, mx+1]
| minBound < lb -> [lb-1]
| mx < maxBound -> [mx+1]
| otherwise -> []
-- Note this could possibly benefit from a intervalPrev field.
delete :: Int -> IntSet -> IntSet
delete x (IntSet m) = IntSet $ case IntMap.lookupLE x m of
Nothing -> m
Just (lb,Interval mx nxt) -> case compare x mx of
GT -> m
EQ | lb < mx -> IntMap.insert lb (Interval (mx - 1) nxt) m
| otherwise -> case IntMap.lookupLE (x-1) m of -- no intervalPrev
Just (lb',Interval mx' _) -> IntMap.insert lb' (Interval mx' nxt)
$ IntMap.delete lb m
Nothing -> IntMap.delete lb m
LT -> let m' = IntMap.insert (x+1) (Interval mx nxt) m
in if lb < x
then IntMap.insert lb (Interval (x - 1) (x+1)) m'
else if x == minBound
then IntMap.delete minBound m'
else case IntMap.lookupLE (x-1) m' of -- no intervalPrev
Just (lb',Interval mx' _) -> IntMap.insert lb' (Interval mx' (x+1))
$ IntMap.delete lb m'
Nothing -> IntMap.delete lb m'
toIntervals :: IntSet -> [(Int,Int)]
toIntervals (IntSet m) = List.map (\(lb,(Interval mx _)) -> (lb,mx))
$ IntMap.toList m
interval :: Int -> Int -> IntSet
interval lb mx
| lb <= mx = IntSet $ IntMap.singleton lb (Interval mx maxBound)
| otherwise = IntSet IntMap.empty
lookup :: Int -> IntSet -> Maybe (Int,Int)
lookup k (IntSet m) = case IntMap.lookupLE k m of
Nothing -> Nothing
Just (lb,Interval mx _) -> Just (lb,mx)
|
