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

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

C5 port of cis

File size: 11.7 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) (cons-interval xmin xmax 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                          (else  (cons-interval xmax1 (+ 1 x2) (difference (cons-interval (- x2 1) xmin1 t1-tail) 
368                                                                             t2-tail)))))
369                   ((Interv xmax2 xmin2 t2-tail)
370                    (cond ((> xmin2 xmax1)  (difference t1 t2-tail))
371                          ((> xmin1 xmax2)  (cons-interval xmax1 xmin1 (difference t1-tail t2)))
372                          (else
373                           (cons-interval xmax1 (+ 1 xmax2)
374                                          (if (>= xmin1 xmin2)
375                                              (difference t1-tail t2)
376                                              (difference (cons-interval (- xmin2 1) xmin1 t1-tail)
377                                                          t2-tail))))))
378                   ))
379           ))
380 
381 
382 
383(define (foreach f t)
384  (let outer ((t t))
385    (cases cis t
386           ((Nil)  (begin))
387           ((Single x t-tail)  (begin (f x) (outer t-tail)))
388           ((Interv xmax xmin t-tail) 
389            (begin
390              (let inner ((x xmax))
391                (begin (f x)
392                       (if (> x xmin) (inner (- x 1)))))
393              (outer t-tail)))
394           )))
395
396(define (fold-left f init t)
397  (cases cis t
398         ((Nil)  init)
399         ((Single x t-tail)
400          (fold-left f (f x init) t-tail))
401         ((Interv xmax xmin t-tail)
402          (fold-left f (fold-for-down (lambda (x res) (f x res)) xmax xmin init) t-tail))
403         ))
404
405(define (fold-right f init t)
406  (cases cis t
407         ((Nil)  init)
408         ((Single x t-tail)
409          (f x (fold-right f init t-tail)))
410         ((Interv xmax xmin t-tail)
411          (fold-for f xmin xmax (fold-right f init t-tail)))
412         ))
413
414(define (elements t) (fold-right cons '() t))
415
416#|
417 
418  (define (append t1 t2) ;; assumes (get-min t1) > (get-max t2)
419    (if (empty? t2) t1
420        (let recur ((t1 t1) (m (get-max t2)) (t2 t2))
421          (cases cis t1
422               ((Nil)   t2)
423               ((Single x t1)
424                (if (empty? t1)
425                    (if (= x (+ 1 m)) (cons-single x t2) (Single x t2))
426                    (Single x (recur t1 m t2))))
427               ((Interv xmax xmin t1)
428                (if (empty? t1)
429                    (if (= xmin (+ 1 m)) (cons-interval xmax xmin t2) (Interv xmax xmin t2))
430                    (Interv xmax xmin (recur t1 m t2))))
431               ))))
432|#
433)
Note: See TracBrowser for help on using the repository browser.