-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathrange.lisp
232 lines (220 loc) · 9.95 KB
/
range.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
(in-package #:ctype)
(defmethod ctypep (object (ct range))
(and (range-kindp object (range-kind ct))
(let ((low (range-low ct)))
(or (not low)
(if (range-low-exclusive-p ct)
(< low object)
(<= low object))))
(let ((high (range-high ct)))
(or (not high)
(if (range-high-exclusive-p ct)
(< object high)
(<= object high))))))
(defmethod subctypep ((ct1 range) (ct2 range))
(values
(and (eq (range-kind ct1) (range-kind ct2))
(let ((low1 (range-low ct1)) (low2 (range-low ct2)))
(or (not low2)
(and low1
(or (< low2 low1)
(and (= low2 low1)
(or (range-low-exclusive-p ct1)
(not (range-low-exclusive-p ct2))))))))
(let ((high1 (range-high ct1)) (high2 (range-high ct2)))
(or (not high2)
(and high1
(or (< high1 high2)
(and (= high1 high2)
(or (range-high-exclusive-p ct1)
(not (range-high-exclusive-p ct2)))))))))
t))
(defmethod ctype= ((ct1 range) (ct2 range))
(values (and (eq (range-kind ct1) (range-kind ct2))
(let ((low1 (range-low ct1)) (low2 (range-low ct2)))
(if low1
(and low2 (= low1 low2))
(not low2)))
(eql (range-low-exclusive-p ct1) (range-low-exclusive-p ct2))
(let ((high1 (range-high ct1)) (high2 (range-high ct2)))
(if high1
(and high2 (= high1 high2))
(not high2)))
(eql (range-high-exclusive-p ct1) (range-high-exclusive-p ct2)))
t))
(defun ranges-disjoint-p (low1 lxp1 high1 hxp1 low2 lxp2 high2 hxp2)
(or (and high1 low2
(or (< high1 low2) (and (= high1 low2) (or hxp1 lxp2))))
(and high2 low1
(or (< high2 low1) (and (= high2 low1) (or hxp2 lxp1))))))
(defmethod disjointp ((ct1 range) (ct2 range))
(let ((rk1 (range-kind ct1)) (rk2 (range-kind ct2))
(low1 (range-low ct1)) (low2 (range-low ct2))
(lxp1 (range-low-exclusive-p ct1))
(lxp2 (range-low-exclusive-p ct2))
(high1 (range-high ct1)) (high2 (range-high ct2))
(hxp1 (range-high-exclusive-p ct1))
(hxp2 (range-high-exclusive-p ct2)))
(values
(or (not (eq rk1 rk2))
(ranges-disjoint-p low1 lxp1 high1 hxp1 low2 lxp2 high2 hxp2))
t)))
(defmethod conjointp ((ct1 range) (ct2 range)) (values nil t))
(defmethod cofinitep ((ct range)) (values nil t))
(defmethod negate ((ct range))
;; (not (real x (y))) = (or (not real) (real * (x)) (real y *))
(let* ((kind (range-kind ct))
(negk (negation (range kind nil nil nil nil)))
(low (range-low ct)) (high (range-high ct))
(lxp (range-low-exclusive-p ct)) (hxp (range-high-exclusive-p ct)))
(cond ((and low high)
(disjunction negk (range kind nil nil low (not lxp))
(range kind high (not hxp) nil nil)))
(low (disjunction negk (range kind nil nil low (not lxp))))
(high (disjunction negk (range kind high (not hxp) nil nil)))
(t negk))))
(defmethod conjoin/2 ((ct1 range) (ct2 range))
(if (eq (range-kind ct1) (range-kind ct2))
(multiple-value-bind (low lxp)
(let ((low1 (range-low ct1)) (low2 (range-low ct2))
(lxp1 (range-low-exclusive-p ct1))
(lxp2 (range-low-exclusive-p ct2)))
(cond ((not low1) (values low2 lxp2))
((not low2) (values low1 lxp1))
((< low1 low2) (values low2 lxp2))
((< low2 low1) (values low1 lxp1))
(t (values low1 (or lxp1 lxp2)))))
(multiple-value-bind (high hxp)
(let ((high1 (range-high ct1)) (high2 (range-high ct2))
(hxp1 (range-high-exclusive-p ct1))
(hxp2 (range-high-exclusive-p ct2)))
(cond ((not high1) (values high2 hxp2))
((not high2) (values high1 hxp1))
((< high1 high2) (values high1 hxp1))
((< high2 high1) (values high2 hxp2))
(t (values high1 (or hxp1 hxp2)))))
(range (range-kind ct1) low lxp high hxp)))
;; Different kinds of range - conjunction is empty
(bot)))
(defmethod disjoin/2 ((ct1 range) (ct2 range))
(let ((rk1 (range-kind ct1)) (rk2 (range-kind ct2))
(low1 (range-low ct1)) (low2 (range-low ct2))
(lxp1 (range-low-exclusive-p ct1))
(lxp2 (range-low-exclusive-p ct2))
(high1 (range-high ct1)) (high2 (range-high ct2))
(hxp1 (range-high-exclusive-p ct1))
(hxp2 (range-high-exclusive-p ct2)))
;; If the range kinds don't match, give up.
(unless (eq rk1 rk2) (return-from disjoin/2 nil))
;; If ct2 has a lesser infinum, swap.
(when (or (not low2)
(and low1 (< low2 low1)))
(rotatef low1 low2) (rotatef lxp1 lxp2)
(rotatef high1 high2) (rotatef hxp1 hxp2))
;; Actually try to merge ranges.
(cond
((or (not high1) (not low2)
(> high1 low2)
(and (= high1 low2)
(or (not hxp1) (not lxp2))))
(multiple-value-bind (low lxp)
(cond ((not low1) (values low1 lxp1))
((not low2) (values low2 lxp2))
((< low1 low2) (values low1 lxp1))
((< low2 low1) (values low2 lxp2))
(t (values low1 (and lxp1 lxp2))))
(multiple-value-bind (high hxp)
(cond ((not high1) (values high1 hxp1))
((not high2) (values high2 hxp2))
((< high1 high2) (values high2 hxp2))
((< high2 high1) (values high1 hxp1))
(t (values high1 (and hxp1 hxp2))))
(range rk1 low lxp high hxp))))
;; We can merge integer ranges that are off by one,
;; e.g. (or (integer 1 5) (integer 6 10)) = (integer 1 10).
((and (eq rk1 'integer)
high1 low2 ; already covered by the above, but let's be clear
(not hxp1) (not lxp2)
(= (1+ high1) low2))
(range rk1 low1 lxp1 high2 hxp2))
(t ;; Ranges are not contiguous - give up
nil))))
(defmethod subtract ((ct1 range) (ct2 range))
(let ((rk1 (range-kind ct1)) (rk2 (range-kind ct2))
(low1 (range-low ct1)) (low2 (range-low ct2))
(lxp1 (range-low-exclusive-p ct1))
(lxp2 (range-low-exclusive-p ct2))
(high1 (range-high ct1)) (high2 (range-high ct2))
(hxp1 (range-high-exclusive-p ct1))
(hxp2 (range-high-exclusive-p ct2)))
(cond ((not (eq rk1 rk2)) ct1)
((and low1 high2
(or (< high2 low1) (and (= high2 low1) (or hxp2 lxp1))))
;; ct2 is too negative to overlap with ct1
ct1)
((and high1 low2
(or (> low2 high1) (and (= low2 high1) (or lxp2 hxp1))))
;; ct2 is too positive to overlap with ct1
ct1)
;; ct2 overlaps ct1, so we actually need to do something here.
((or (not low2)
(and low1 (or (< low2 low1)
(and (= low2 low1) (or lxp1 (not lxp2))))))
(if (or (not high2)
(and high1 (or (> high2 high1)
(and (= high2 high1) (or hxp1 (not hxp2))))))
;; ct1 is a strict subrange of ct1
(bot)
;; ct2's low is <= that of ct1, so chop off the low end of ct1.
(range rk1 high2 (not hxp2) high1 hxp1)))
((or (not high2)
(and high1 (or (> high2 high1)
(and (= high2 high1) (or hxp1 (not hxp2))))))
;; ct2's high is >= that of ct1, so chop off the high end of ct1.
(range rk1 low1 lxp1 low2 (not lxp2)))
(t
;; ct2 is a strict subrange of ct1
(disjunction (range rk1 low1 lxp1 low2 (not lxp2))
(range rk1 high2 (not hxp2) high1 hxp1))))))
(defmethod unparse ((ct range))
(let ((kind (range-kind ct))
(low (range-low ct)) (high (range-high ct)))
(case kind
((integer)
(cond ((and low high)
;; we should have normalized out exclusivities and stuff.
(assert (integerp low)) (assert (integerp high))
(assert (>= high low))
;; sbcl crib
(let ((high-count (logcount high))
(high-length (integer-length high)))
(cond ((zerop low)
(cond ((zerop high) '(integer 0 0))
((= high 1) 'bit)
((= high-count high-length)
`(unsigned-byte ,high-length))
(t `(mod ,(1+ high)))))
((and (= low most-negative-fixnum)
(= high most-positive-fixnum))
'fixnum)
((and (= low (lognot high))
(= high-count high-length))
`(signed-byte ,(1+ high-length)))
(t `(integer ,low ,high)))))
(high `(,kind ,(or low '*) ,high))
(low (if (zerop low) 'unsigned-byte `(,kind ,low)))
(t kind)))
((ratio)
(if (or low high)
(let ((low (if (range-low-exclusive-p ct) (list low) low))
(high (if (range-high-exclusive-p ct) (list high) high)))
`(and (not integer)
,(if high `(rational ,(or low '*) ,high) `(rational ,low))))
'ratio))
(otherwise
(let ((low (if (and low (range-low-exclusive-p ct)) (list low) low))
(high
(if (and high (range-high-exclusive-p ct)) (list high) high)))
(cond (high `(,kind ,(or low '*) ,high))
(low `(,kind ,low))
(t kind)))))))