source: project/release/5/cis/trunk/cis.scm @ 37361

Last change on this file since 37361 was 37361, checked in by Ivan Raikov, 3 years ago

cis: bug fixes in difference [thanks to Andre Sa]

File size: 13.6 KB
Line 
1;;
2;;  Cis : compact integer sets
3;;
4;;  This module implements compact integer sets, represented as a list
5;;  of integer intervals. The usual set operations are provided.  The
6;;  advantage compared to ordered lists is that the actual size may be
7;;  smaller than the cardinal of a set when many elements are
8;;  contiguous. Most set operations are linear w.r.t. the size, not
9;;  the cardinal.
10;;
11;;  Based on the Ocaml Cis library by Sébastien Ferré <ferre@irisa.fr>.
12;;  Ported to Chicken Scheme by Ivan Raikov.
13;; 
14;;  Copyright 2010-2018 Ivan Raikov.
15;;
16;;  This program is free software: you can redistribute it and/or
17;;  modify it under the terms of the GNU Lesser General Public License
18;;  as published by the Free Software Foundation, either version 3 of
19;;  the License, or (at your option) any later version.
20;;
21;;  This program is distributed in the hope that it will be useful,
22;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
23;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
24;;  Lesser General Public License for more details.
25;;
26;;  A full copy of the Lesser GPL license can be found at
27;;  <http://www.gnu.org/licenses/>.
28;;
29
30
31(module cis
32
33
34        (cis? empty? empty 
35         subset? cardinal in?
36         singleton interval add shift remove 
37         get-min get-max union intersection difference 
38         foreach fold-left fold-right elements 
39         )
40
41        (import scheme (chicken base))
42
43
44;; Variant types
45
46(define-syntax define-datatype
47  (syntax-rules ()
48    [(_ type (name field ...) ...)
49     (begin
50       (define-constructors type ((name field ...) ...)))]))
51
52
53(define-syntax define-constructors
54  (syntax-rules ()
55    [(define-constructors type ((name field ...) ...))
56     (define-constructors type ((name field ...) ...) (name ...))]
57    [(define-constructors type ((name field ...) ...) names)
58     (begin
59       (define-constructor type (name field ...) names)
60       ...)]))
61
62
63(define-syntax define-constructor
64  (syntax-rules ()
65    [(_ type (name field ...) names)
66     (define (name field ...)
67       (cons 'type
68             (lambda names
69               (name field ...))))]))
70
71
72(define-syntax cases
73  (syntax-rules ()
74    [(_ type x [(name field ...) exp]
75          ...)
76     ((cdr x) (lambda (field ...) exp)
77              ...)]))
78
79
80(define (fold-for f a b e)
81  (if (< b a) (fold-for f b a e)
82      (let recur ((i a) (res e))
83        (if (<= i b) (recur (+ 1 i) (f i res))
84            res))))
85
86       
87(define (fold-for-down f a b e)
88  (if (< a b) (fold-for-down f b a e)
89      (let recur ((i a) (res e))
90        (if (>= i b) (recur (- i 1) (f i res))
91            res))))
92
93
94;; integers in decreasing order
95(define-datatype cis
96  (Nil)
97  (Single i t)
98  (Interv i j t))
99
100(define (cis? x) (and (pair? x) (eq? 'cis (car x))))
101
102(define (empty? x)
103  (cases cis x 
104         ((Nil) #t)
105         ((Single _ _) #f)
106         ((Interv _ _ _) #f)))
107 
108
109(define empty (Nil))
110
111(define (subset? t1 t2)
112  (cases cis t1
113         ((Nil)  #t)
114         ((Single x1 t1-tail) 
115          (cases cis t2
116                 ((Nil)  #f)
117                 ((Single x2 t2-tail)
118                  (cond ((> x1 x2)  #f)
119                        ((> x2 x1)  (subset? t1 t2-tail))
120                        (else (subset? t1-tail t2-tail))))
121                 ((Interv xmax2 xmin2 t2-tail)
122                  (cond ((> x1 xmax2)  #f)
123                        ((> xmin2 x1)  (subset? t1 t2-tail))
124                        (else (subset? t1-tail t2))))))
125         ((Interv xmax1 xmin1 t1-tail)
126          (cases cis t2
127                 ((Nil)  #f)
128                 ((Single x2 t2-tail)
129                  (cond ((> x2 xmax1)  (subset? t1 t2-tail))
130                        ((> xmin1 x2)  #f)
131                        (else #f)))
132                 ((Interv xmax2 xmin2 t2-tail)
133                  (cond ((> xmin2 xmax1)  (subset? t1 t2-tail))
134                        ((> xmin1 xmax2)  #f)
135                        (else (and (>= xmax2 xmax1) (>= xmin1 xmin2) (subset? t1-tail t2)))))
136                 ))
137         ))
138
139
140(define (get-max t)
141  (cases cis t
142         ((Nil)  (error 'get-max "set is empty"))
143         ((Single x _)  x)
144         ((Interv xmax _ _)  xmax)))
145
146
147(define (get-min t)
148  (cases cis t
149         ((Nil) (error 'get-min "set is empty"))
150         ((Single x t1) (if (empty? t1) x (get-min t1)))
151         ((Interv xmax xmin t1) (if (empty? t1) xmin (get-min t1)))))
152
153
154(define (cons-single x t)
155  (cases cis t
156         ((Nil) 
157          (Single x (Nil)))
158         ((Single x1 t1) 
159          (if (= x (+ 1 x1)) (Interv x x1 t1) (Single x t)))
160         ((Interv xmax1 xmin1 t1) 
161          (if (= x (+ 1 xmax1)) (Interv x xmin1 t1) (Single x t)))
162         ))
163
164
165(define (cons-interval xmax xmin t)
166  (cond ((< xmax xmin) t)
167        ((= xmax xmin) (cons-single xmin t))
168        (else
169         (cases cis t
170                ((Nil) 
171                 (Interv xmax xmin (Nil)))
172                ((Single x1 t1) 
173                 (if (= xmin (+ 1 x1)) (Interv xmax x1 t1) (Interv xmax xmin t)))
174                ((Interv xmax1 xmin1 t1) 
175                 (if (= xmin (+ 1 xmax1)) (Interv xmax xmin1 t1) (Interv xmax xmin t)))
176                ))
177        ))
178
179
180(define (cardinal t)
181  (let recur ((t t) (ax 0))
182    (cases cis t
183           ((Nil) ax)
184           ((Single x1 t1) (recur t1 (+ 1 ax)))
185           ((Interv xmax1 xmin1 t1) (recur t1 (+ ax (+ 1 (- xmax1 xmin1)))))
186           )))
187
188
189(define (in? x t)
190  (cases cis t
191         ((Nil) #f)
192         ((Single x1 t1) 
193          (or (= x x1) (and (> x1 x) (in? x t1))))
194         ((Interv xmax xmin t1) 
195          (or (and (>= xmax x) (>= x xmin))
196              (and (> xmin x) (in? x t1))))
197         ))
198
199
200(define (singleton x)
201  (Single x (Nil)))
202
203
204(define (interval xmin xmax)
205  (cond ((> xmin xmax) (interval xmax xmin))
206        ((= xmin xmax) (singleton xmin))
207        (else
208         (Interv xmax xmin (Nil)))))
209
210
211(define (add x t)
212  (cases cis t
213         ((Nil) (cons-single x t))
214         ((Single x1 t1) (cond ((> x x1) (cons-single x t))
215                               ((= x x1) t)
216                               (else (cons-single x1 (add x t1)))))
217         ((Interv xmax1 xmin1 t1) (cond ((> x xmax1) (cons-single x t))
218                                        ((and (>= xmax1 x) (>= x xmin1)) t)
219                                        (else (cons-interval xmax1 xmin1 (add x t1)))))
220         
221         ))
222
223
224
225(define (remove x t)
226  (cases cis t
227         ((Nil) empty)
228         ((Single x1 t1) 
229          (cond ((> x x1) t)
230                ((= x x1) t1)
231                (else (cons-single x1 (remove x t1)))))
232         ((Interv xmax1 xmin1 t1) 
233          (cond ((> x xmax1) t)
234                ((= x xmin1)
235                 (cons-interval xmax1 (+ 1 xmin1) t1))
236                ((= x xmax1)
237                 (cons-interval (- xmax1 1) xmin1 t1))
238                ((and (> xmax1 x) (> x xmin1)) 
239                 (cons-interval xmax1 (+ 1 x) (cons-interval (- x 1) xmin1 t1)))
240                (else (cons-interval xmax1 xmin1 (remove x t1)))))
241         
242         ))
243
244
245(define (shift n t)
246  (if (empty? t) t
247      (let ((m (get-min t)))
248        (and (<= 0 (+ m n))
249             (cases cis t
250                    ((Nil) (Nil))
251                    ((Single x1 t1)  (Single (+ x1 n) (shift n t1)))
252                    ((Interv xmax1 xmin1 t1) 
253                     (Interv (+ xmax1 n) (+ xmin1 n) (shift n t1)))
254                    )))))
255
256
257
258(define (union t1 t2)
259  (cases cis t1
260         ((Nil) t2)
261         ((Single x1 t1-tail) 
262          (begin
263            (cases cis t2
264                   ((Nil) t1)
265                   ((Single x2 t2-tail) 
266                    (cond ((> x1 (+ 1 x2))
267                           (cons-single x1 (union t1-tail t2)))
268                          ((> x2 (+ 1 x1))
269                           (cons-single x2 (union t1 t2-tail)))
270                          ((= x1 (+ 1 x2))
271                           (cons-interval x1 x2 (union t1-tail t2-tail)))
272                          ((= x2 (+ 1 x1))
273                           (cons-interval x2 x1 (union t1-tail t2-tail)))
274                          (else
275                           (cons-single x1 (union t1-tail t2-tail)))
276                          ))
277                   ((Interv xmax2 xmin2 t2-tail) 
278                    (cond ((> x1 xmax2) (cons-single x1 (union t1-tail t2)))
279                          ((> xmin2 (+ 1 x1)) (cons-interval xmax2 xmin2 (union t1 t2-tail)))
280                          ((= xmin2 (+ 1 x1)) (cons-interval xmax2 x1 (union t1-tail t2-tail)))
281                          (else (cons-interval xmax2 x1 (union t1-tail (cons-interval (- x1 1) xmin2 t2-tail))))))
282                   )))
283
284         ((Interv xmax1 xmin1 t1-tail) 
285          (cases cis t2
286                 ((Nil) t1)
287                 ((Single x2 t2-tail) 
288                  (cond ((> x2 xmax1) (cons-single x2 (union t1 t2-tail)))
289                        ((> xmin1 (+ 1 x2)) (cons-interval xmax1 xmin1 (union t1-tail t2)))
290                        ((= xmin1 (+ 1 x2)) (cons-interval xmax1 x2 (union t1-tail t2-tail)))
291                        (else (cons-interval xmax1 x2 (union (cons-interval (- x2 1) xmin1 t1-tail) t2-tail)))))
292                 ((Interv xmax2 xmin2 t2-tail) 
293                  (cond ((> xmin2 xmax1) (cons-interval xmax2 xmin2 (union t1 t2-tail)))
294                        ((> xmin1 xmax2) (cons-interval xmax1 xmin1 (union t1-tail t2)))
295                        (else (cons-interval (max xmax1 xmax2) (max xmin1 xmin2)
296                                             (cond ((= xmin1 xmin2) 
297                                                    (union t1-tail t2-tail))
298                                                   ((> xmin1 xmin2) 
299                                                    (union t1-tail (cons-interval (- xmin1 1) xmin2 t2-tail)))
300                                                   (else
301                                                    (union (cons-interval (- xmin2 1) xmin1 t1-tail) t2-tail)))))
302                        ))
303                 ))
304         ))
305
306
307(define (intersection t1 t2)
308  (cases cis t1
309         ((Nil) empty)
310         ((Single x1 t1-tail) 
311          (cases cis t2
312                 ((Nil) empty)
313                 ((Single x2 t2-tail) 
314                  (cond ((> x1 (+ 1 x2))
315                         (intersection t1-tail t2))
316                        ((> x2 (+ 1 x1))
317                         (intersection t1 t2-tail))
318                        ((= x1 (+ 1 x2))
319                         (intersection t1-tail t2-tail))
320                        ((= x2 (+ 1 x1))
321                         (intersection t1-tail t2-tail))
322                        (else
323                         (cons-single x1 (intersection t1-tail t2-tail)))
324                        ))
325                 ((Interv xmax2 xmin2 t2-tail) 
326                  (cond ((> x1 xmax2) (intersection t1-tail t2))
327                        ((> xmin2 x1) (intersection t1 t2-tail))
328                        (else (cons-single x1 (intersection t1-tail t2)))))
329                 ))
330         ((Interv xmax1 xmin1 t1-tail) 
331          (cases cis t2
332                 ((Nil)  empty)
333                 ((Single x2 t2-tail)
334                  (cond ((> x2 xmax1)  (intersection t1 t2-tail))
335                        ((> xmin1 x2)  (intersection t1-tail t2))
336                        (else (cons-single x2 (intersection t1 t2-tail)))))
337                 ((Interv xmax2 xmin2 t2-tail)
338                  (cond ((> xmin2 xmax1) (intersection t1 t2-tail))
339                        ((> xmin1 xmax2) (intersection t1-tail t2))
340                        (else (cons-interval (min xmax1 xmax2) (max xmin1 xmin2)
341                                             (if (>= xmin1 xmin2) 
342                                                 (intersection t1-tail t2)
343                                                 (intersection t1 t2-tail))))))
344                 ))
345         ))
346
347(define (difference t1 t2)
348  (cases cis t1
349         ((Nil) empty)
350         ((Single x1 t1-tail) 
351          (cases cis t2
352                 ((Nil)  t1)
353                 ((Single x2 t2-tail)
354                  (cond ((> x1 x2)  (cons-single x1 (difference t1-tail t2)))
355                        ((> x2 x1)  (difference t1 t2-tail))
356                        (else (difference t1-tail t2-tail))))
357                 ((Interv xmax2 xmin2 t2-tail)
358                  (cond ((> x1 xmax2) (cons-single x1 (difference t1-tail t2)))
359                        ((> xmin2 x1) (difference t1 t2-tail))
360                        (else (difference t1-tail t2-tail))))))
361         ((Interv xmax1 xmin1 t1-tail)
362          (cases cis t2
363                 ((Nil)  t1)
364                 ((Single x2 t2-tail)
365                  (cond ((> x2 xmax1)  (difference t1 t2-tail))
366                        ((> xmin1 x2)  (cons-interval xmax1 xmin1 (difference t1-tail t2)))
367                        ;; x2 <= xmax1 & xmin1 <= x2
368                        (else  (cons-interval xmax1 (+ 1 x2) (difference (cons-interval (- x2 1) xmin1 t1-tail) 
369                                                                         t2-tail)))))
370                 ((Interv xmax2 xmin2 t2-tail)
371                  (cond ((> xmin2 xmax1)  (difference t1 t2-tail))
372                        ((> xmin1 xmax2)  (cons-interval xmax1 xmin1 (difference t1-tail t2)))
373                        (else
374                         (cons-interval xmax1 (+ 1 xmax2)
375                                        (if (> xmin1 xmin2)
376                                            (difference t1-tail t2)
377                                            (difference (cons-interval (- xmin2 1) xmin1 t1-tail)
378                                                        (if (> xmax1 xmax2) t2-tail (interval xmax2 (+ 1 xmax1))))))))
379                  ))
380         ))
381  )
382
383
384(define (foreach f t)
385  (let outer ((t t))
386    (cases cis t
387           ((Nil)  (begin))
388           ((Single x t-tail)  (begin (f x) (outer t-tail)))
389           ((Interv xmax xmin t-tail) 
390            (begin
391              (let inner ((x xmax))
392                (begin (f x)
393                       (if (> x xmin) (inner (- x 1)))))
394              (outer t-tail)))
395           )))
396
397(define (fold-left f init t)
398  (cases cis t
399         ((Nil)  init)
400         ((Single x t-tail)
401          (fold-left f (f x init) t-tail))
402         ((Interv xmax xmin t-tail)
403          (fold-left f (fold-for-down (lambda (x res) (f x res)) xmax xmin init) t-tail))
404         ))
405
406(define (fold-right f init t)
407  (cases cis t
408         ((Nil)  init)
409         ((Single x t-tail)
410          (f x (fold-right f init t-tail)))
411         ((Interv xmax xmin t-tail)
412          (fold-for f xmin xmax (fold-right f init t-tail)))
413         ))
414
415(define (elements t) (fold-right cons '() t))
416
417#|
418 
419  (define (append t1 t2) ;; assumes (get-min t1) > (get-max t2)
420    (if (empty? t2) t1
421        (let recur ((t1 t1) (m (get-max t2)) (t2 t2))
422          (cases cis t1
423               ((Nil)   t2)
424               ((Single x t1)
425                (if (empty? t1)
426                    (if (= x (+ 1 m)) (cons-single x t2) (Single x t2))
427                    (Single x (recur t1 m t2))))
428               ((Interv xmax xmin t1)
429                (if (empty? t1)
430                    (if (= xmin (+ 1 m)) (cons-interval xmax xmin t2) (Interv xmax xmin t2))
431                    (Interv xmax xmin (recur t1 m t2))))
432               ))))
433|#
434)
Note: See TracBrowser for help on using the repository browser.