-
Notifications
You must be signed in to change notification settings - Fork 20
/
interval-set.lisp
249 lines (231 loc) · 10.3 KB
/
interval-set.lisp
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
(defpackage :cp/interval-set
(:use :cl)
(:export #:interval-set #:interval-set-p #:iset-map #:iset-find #:iset-find>=
#:iset-insert #:iset-push #:iset-push1 #:iset-delete #:iset-pop #:iset-pop1)
(:documentation "Provides ordered set of half-open intervals."))
(in-package :cp/interval-set)
;; TODO: more rich operations
(defstruct (interval-set (:constructor %make-interval-set
(lkey rkey lnode rnode
&aux (priority (random (+ 1 most-positive-fixnum)))))
(:conc-name %iset-)
(:copier nil))
"This structure maintains an ordered set of half-open intervals with a
balanced binary search tree (aka treap). Every fundamental operation takes
expected O(log(n)) time.
NOTE: For every destructive operation, you cannot rely on a side effect but have
to use a returned value. (i.e. same as destructive operations to cons)
"
(lkey 0 :type fixnum)
(rkey 0 :type fixnum)
(priority 0 :type fixnum)
(lnode nil :type (or null interval-set))
(rnode nil :type (or null interval-set)))
(declaim (inline iset-map))
(defun iset-map (function iset)
"Applies function to each (maximal) interval [L, R) in ISET in ascending
order."
(labels ((recur (node)
(when node
(recur (%iset-lnode node))
(funcall function (%iset-lkey node) (%iset-rkey node))
(recur (%iset-rnode node)))))
(recur iset)))
(defmethod print-object ((object interval-set) stream)
(print-unreadable-object (object stream :type t)
(let ((init t))
(iset-map (lambda (l r)
(if init
(setq init nil)
(write-char #\ stream))
(format stream "[~A ~A)" l r))
object))))
(declaim (ftype (function * (values (or null interval-set) &optional)) %iset-concat))
(defun %iset-concat (left right)
(declare (optimize (speed 3)))
(cond ((null left) right)
((null right) left)
((> (%iset-priority left) (%iset-priority right))
(setf (%iset-rnode left)
(%iset-concat (%iset-rnode left) right))
left)
(t
(setf (%iset-lnode right)
(%iset-concat left (%iset-lnode right)))
right)))
(declaim (ftype (function * (values (or null interval-set)
(or null interval-set)
&optional))
%iset-split))
(defun %iset-split (iset lkey)
"Splits ISET by LKEY. Returns two interval-sets: LEFT and RIGHT. LEFT contains
all the intervals whose left end smaller than LKEY, and RIGHT contains all the
intervals whose left end is equal to or greater than LKEY."
(declare (optimize (speed 3))
(fixnum lkey))
(labels ((recur (node)
(cond ((null node) (values nil nil))
((< (%iset-lkey node) lkey)
(multiple-value-bind (lnode rnode)
(recur (%iset-rnode node))
(setf (%iset-rnode node) lnode)
(values node rnode)))
(t
(multiple-value-bind (lnode rnode)
(recur (%iset-lnode node))
(setf (%iset-lnode node) rnode)
(values lnode node))))))
(recur iset)))
(declaim (ftype (function * (values (or null interval-set) &optional)) %iset-insert))
(defun %iset-insert (iset lkey rkey)
(declare (optimize (speed 3))
(fixnum lkey rkey))
(let ((new-node (%make-interval-set lkey rkey nil nil)))
(labels ((recur (node)
(cond ((null node) new-node)
((> (%iset-priority new-node) (%iset-priority node))
(setf (values (%iset-lnode new-node) (%iset-rnode new-node))
(%iset-split node (%iset-lkey new-node)))
new-node)
(t
(if (< (%iset-lkey new-node) (%iset-lkey node))
(setf (%iset-lnode node) (recur (%iset-lnode node)))
(setf (%iset-rnode node) (recur (%iset-rnode node))))
node))))
(recur iset))))
(declaim (ftype (function * (values fixnum &optional)) %iset-leftmost-key))
(defun %iset-leftmost-key (iset)
(declare (optimize (speed 3)))
(loop (setq iset (or (%iset-lnode iset)
(return (%iset-lkey iset))))))
(declaim (ftype (function * (values fixnum &optional)) %iset-rightmost-key))
(defun %iset-rightmost-key (iset)
(declare (optimize (speed 3)))
(loop (setq iset (or (%iset-rnode iset)
(return (%iset-rkey iset))))))
(defun iset-insert (iset lkey rkey)
"Inserts an interval [LKEY, RKEY) to ISET."
(declare (optimize (speed 3))
(fixnum lkey rkey))
(assert (<= lkey rkey))
(labels ((lsplit (node)
(cond ((null node) (values nil nil))
((< (%iset-rkey node) lkey)
(multiple-value-bind (lnode rnode)
(lsplit (%iset-rnode node))
(setf (%iset-rnode node) lnode)
(values node rnode)))
(t
(multiple-value-bind (lnode rnode)
(lsplit (%iset-lnode node))
(setf (%iset-lnode node) rnode)
(values lnode node)))))
(rsplit (node)
(cond ((null node) (values nil nil))
((< rkey (%iset-lkey node))
(multiple-value-bind (lnode rnode)
(rsplit (%iset-lnode node))
(setf (%iset-lnode node) rnode)
(values lnode node)))
(t
(multiple-value-bind (lnode rnode)
(rsplit (%iset-rnode node))
(setf (%iset-rnode node) lnode)
(values node rnode))))))
(if (= lkey rkey)
iset
(multiple-value-bind (left tmp) (lsplit iset)
(multiple-value-bind (mid right) (rsplit tmp)
(let* ((base (%iset-concat left right))
(new-lkey (if mid (min (%iset-leftmost-key mid) lkey) lkey))
(new-rkey (if mid (max (%iset-rightmost-key mid) rkey) rkey)))
(declare (fixnum new-lkey new-rkey))
(%iset-insert base new-lkey new-rkey)))))))
;; TODO: Use setf-expander
(defmacro iset-push (lkey rkey iset)
"PUSH-style macro for ISET-INSERT."
`(setf ,iset (iset-insert ,iset ,lkey ,rkey)))
(defmacro iset-push1 (key iset)
"Adds an interval [KEY, KEY+1) to ISET."
(let ((tmp (gensym)))
`(let ((,tmp ,key))
(setf ,iset (iset-insert ,iset ,tmp (+ ,tmp 1))))))
(defun iset-delete (iset lkey rkey)
"Removes an interval [LKEY, RKEY) from ISET."
(declare (optimize (speed 3))
(fixnum lkey rkey))
(assert (<= lkey rkey))
(if (= lkey rkey)
iset
(labels ((lsplit (node)
(cond ((null node) (values nil nil))
((< (%iset-rkey node) lkey)
(multiple-value-bind (lnode rnode)
(lsplit (%iset-rnode node))
(setf (%iset-rnode node) lnode)
(values node rnode)))
(t
(multiple-value-bind (lnode rnode)
(lsplit (%iset-lnode node))
(setf (%iset-lnode node) rnode)
(values lnode node)))))
(rsplit (node)
(cond ((null node) (values nil nil))
((< rkey (%iset-lkey node))
(multiple-value-bind (lnode rnode)
(rsplit (%iset-lnode node))
(setf (%iset-lnode node) rnode)
(values lnode node)))
(t
(multiple-value-bind (lnode rnode)
(rsplit (%iset-rnode node))
(setf (%iset-rnode node) lnode)
(values node rnode))))))
(multiple-value-bind (left tmp) (lsplit iset)
(multiple-value-bind (mid right) (rsplit tmp)
(let ((base (%iset-concat left right))
(new-lkey (if mid (min (%iset-leftmost-key mid) lkey) lkey))
(new-rkey (if mid (max (%iset-rightmost-key mid) rkey) rkey)))
(iset-insert (iset-insert base new-lkey lkey)
rkey new-rkey)))))))
(defmacro iset-pop (lkey rkey iset)
"POP-style macro for ISET-INSERT."
`(setf ,iset (iset-delete ,iset ,lkey ,rkey)))
(defmacro iset-pop1 (key iset)
"Deletes an interval [KEY, KEY+1) from ISET (if it exists)."
(let ((tmp (gensym)))
`(let ((,tmp ,key))
(setf ,iset (iset-delete ,iset ,tmp (+ ,tmp 1))))))
(declaim (ftype (function * (values (or null fixnum) (or null fixnum) &optional))
iset-find))
(defun iset-find (iset key)
"Returns the half-open interval that contains KEY if it exists, otherwise
returns (VALUES NIL NIL)."
(declare (optimize (speed 3))
(fixnum key))
(labels ((recur (node)
(cond ((null node) (values nil nil))
((< key (%iset-lkey node))
(recur (%iset-lnode node)))
((< key (%iset-rkey node))
(values (%iset-lkey node) (%iset-rkey node)))
(t (recur (%iset-rnode node))))))
(recur iset)))
(declaim (ftype (function * (values (or null fixnum) (or null fixnum) &optional))
iset-find>=))
(defun iset-find>= (iset key)
"Returns the nearest half-open interval that contains KEY or is located on the
larger side of it. Returns (VALUES NIL NIL) if neither of them exist."
(declare (optimize (speed 3))
(fixnum key))
(labels ((recur (node)
(cond ((null node) (values nil nil))
((<= (%iset-rkey node) key)
(recur (%iset-rnode node)))
((<= (%iset-lkey node) key)
(values (%iset-lkey node) (%iset-rkey node)))
(t (multiple-value-bind (lkey rkey) (recur (%iset-lnode node))
(if lkey
(values lkey rkey)
(values (%iset-lkey node) (%iset-rkey node))))))))
(recur iset)))