source: project/release/4/typed-lists/trunk/typed-lists.scm @ 32976

Last change on this file since 32976 was 32976, checked in by juergen, 5 years ago

typed-lists 2.3 sets renamed list-sets

File size: 25.6 KB
Line 
1#|[
2Author: Juergen Lorenz
3ju (at) jugilo (dot) de
4
5Copyright (c) 2014, Juergen Lorenz
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions are
10met:
11
12Redistributions of source code must retain the above copyright
13notice, this list of conditions and the following disclaimer.
14
15Redistributions in binary form must reproduce the above copyright
16notice, this list of conditions and the following disclaimer in the
17documentation and/or other materials provided with the distribution.
18
19Neither the name of the author nor the names of its contributors may be
20used to endorse or promote products derived from this software without
21specific prior written permission.
22
23THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
26PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
27HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
29TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34]|#
35
36(require-library datatype)
37
38(define-interface LISTS
39  (ilists ilist? ilist list->ilist ilist->list
40   ilist-apply ilist-null ilist-null? ilist-cons ilist-first ilist-rest ilist-reverse
41   ilist-length ilist-item ilist-map ilist-for-each ilist-append ilist-mappend
42   ilist-from-upto ilist-split-at ilist-split-with ilist-equal? ilist-member
43   ilist-memp ilist-remp ilist-remove ilist-remove-dups ilist-assp ilist-assoc
44   ilist-filter ilist-fold-left ilist-fold-right ilist-merge ilist-merge-sort
45   ilist-insertion-sort ilist-sorted? ilist-insert-sorted ilist-drop
46   ilist-drop-while ilist-take ilist-take-while ilist-repeat ilist-iterate
47   ilist-iterate-while ilist-iterate-until ilist-zip ilist-unzip ilist-interpose
48   ilist-every? ilist-some ilist-not-every? ilist-not-any? ilist-in? ilist-bind))
49
50(define-interface SETS
51   (list-sets set? set ilist->set set->ilist set-in?  set-cardinality
52    set-filter set-null? set-difference set-add set-remove
53    set= set>= set<= set-union set-intersection))
54
55(functor (list-functor (M (item? equ?))) LISTS
56
57(import scheme
58        (only chicken error define-record-printer
59              unless receive case-lambda)
60        (only data-structures list-of? o)
61        (only extras sprintf)
62        datatype
63        M)
64
65(import-for-syntax (only chicken receive))
66
67(define-datatype ilist ilist?
68  (ilist-null)
69  (ilist-cons
70    (first item?)
71    (rest ilist?)))
72
73(define-record-printer (ilist ilst out)
74  (let ((str (sprintf "~s" (ilist->list ilst))))
75    (string-set! str (- (string-length str) 1) #\])
76    (string-set! str 0 #\[)
77    (display str out)))
78
79;(define-reader-ctor 'typed ilist)
80
81(define (ilist-null? xpr)
82  (and (ilist? xpr)
83       (cases ilist xpr
84         (ilist-null () #t)
85         (ilist-cons (first rest) #f))))
86
87(define (ilist-first lst)
88  (cases ilist lst
89    (ilist-null () (error 'ilist-first "list empty" lst))
90    (ilist-cons (first rest) first)))
91
92(define (ilist-rest lst)
93  (cases ilist lst
94    (ilist-null () (error 'ilist-rest "list empty" lst))
95    (ilist-cons (first rest) rest)))
96
97(define-syntax ilist-bind
98  (ir-macro-transformer
99    (lambda (form inject compare?)
100      (let ((pat (cadr form))
101            (ilst (caddr form))
102            (xpr (caddr form))
103            (xprs (cdddr form)))
104        (let ((ilst ilst))
105                    ;; not available at compile time
106                    ;(if (ilist? ilst)
107                    ;  ilst
108                    ;  (error 'ilist-bind
109                    ;         "not a typed list"
110                    ;         ilst))))
111          (if (list? pat)
112            `(if (= ,(length pat) (ilist-length ,ilst))
113               (ilist-apply (lambda ,pat ,xpr ,@xprs) ,ilst)
114               (error 'ilist-bind "match error" ',pat ,ilst))
115            ;; pseudolist: separate list part
116            (receive (head tail)
117              (let loop ((pat pat) (lst '()))
118                (if (pair? pat)
119                  (loop (cdr pat) (cons (car pat) lst))
120                  (values (reverse lst) pat)))
121              `(if (<= ,(length head) (ilist-length ,ilst))
122                 (receive (hd tl) (ilist-split-at ,(length head) ,ilst)
123                   (let ((,tail tl))
124                     (ilist-apply (lambda ,head ,xpr ,@xprs) hd)))
125                 (error 'ilist-bind "match error" ',pat ,ilst)))))))))
126
127(define (ilist-reverse . lsts)
128  (cond
129    ((null? lsts)
130     (ilist-null))
131    ((null? (cdr lsts))
132     (let loop ((ls (car lsts)) (result (ilist-null)))
133       (cases ilist ls
134         (ilist-null () result)
135         (ilist-cons (first rest)
136                    (loop rest (ilist-cons first result))))))
137    (else
138      (let loop (
139        (lsts lsts)
140        (results ;(make-list (length lsts) (ilist-null)))
141                 (let recur ((n (length lsts))
142                             (result '()))
143                   (if (zero? n)
144                     result
145                     (recur (- n 1) (cons (ilist-null) result)))))
146        )
147        (cond
148          (((list-of? ilist-null?) lsts)
149           (apply values results))
150          (((list-of? (o not ilist-null?)) lsts)
151           (loop (map ilist-rest lsts)
152                 (map (lambda (l ll) (ilist-cons l ll))
153                      (map ilist-first lsts)
154                      results)))
155          (else (error 'ilist-reverse "lists not of equal length")))))))
156
157(define (ilist . args)
158  (let loop ((args args) (result (ilist-null)))
159    (if (null? args)
160      (ilist-reverse result)
161      (loop (cdr args) (ilist-cons (car args) result)))))
162
163(define (ilist-repeat n x)
164  (let loop ((k 0) (result (ilist-null)))
165    (if (= k n)
166      result
167      (loop (+ k 1) (ilist-cons x result)))))
168
169(define (ilist-iterate n fn x)
170  (let loop ((k 0) (val x) (result (ilist-null)))
171    (if (= k n)
172      (ilist-reverse result)
173      (loop (+ k 1) (fn val) (ilist-cons val result)))))
174
175(define (ilist-iterate-while ok? fn x)
176  (let loop ((val x) (result (ilist-null)))
177    (if (ok? val)
178      (loop (fn val) (ilist-cons val result))
179      (ilist-reverse result))))
180
181(define (ilist-iterate-until ok? fn x)
182  (let loop ((val x) (result (ilist-null)))
183    (if (ok? val)
184      (ilist-reverse result)
185      (loop (fn val) (ilist-cons val result)))))
186
187(define (ilist->list lst)
188  (let loop ((ls lst) (result '()))
189    (cases ilist ls
190      (ilist-null () (reverse result))
191      (ilist-cons (first rest)
192       (loop rest (cons first result))))))
193
194;(define (ilist-apply fn . args)
195;  (let ((len (length args)))
196;    (apply fn
197;      (let loop ((k 0) (result '()))
198;        (cond
199;          ((= k len) (reverse result))
200;          ((= k (- len 1))
201;           (let ((tail (list-ref args k)))
202;             (if (ilist? tail)
203;               (loop (+ k 1)
204;                     (append
205;                       (reverse
206;                         (ilist->list tail))
207;                       result))
208;               (error 'ilist-apply
209;                      (string-append
210;                        "not an "
211;                        (symbol->string
212;                          'ilist))
213;                      tail))))
214;          (else
215;            (let ((item (list-ref args k)))
216;              (if (item? item)
217;                (loop (+ k 1)
218;                      (cons item result))
219;                (error 'ilist-apply
220;                       "wrong item-type"
221;                       `(,item? ,item))))))))))
222(define (ilist-apply fn . args)
223  (let ((args (reverse args)))
224    (cond
225      ((null? args)
226       (error 'ilist-apply "no argument supplied"))
227      ((ilist? (car args))
228       (let ((head (reverse (ilist->list (car args))))
229             (tail (cdr args)))
230         (apply fn (reverse (append head tail)))))
231      (else
232        (error 'ilist-apply "not an ilist" (car args))))))
233
234
235(define (list->ilist lst)
236  (apply ilist lst))
237
238(define (ilist-length lst)
239  (let loop ((ls lst) (k 0))
240    (cases ilist ls
241      (ilist-null () k)
242      (ilist-cons (first rest)
243        (loop rest (+ k 1))))))
244
245(define (ilist-item k lst)
246  (let loop ((ls lst) (n 0))
247    (cases ilist ls
248      (ilist-null () (error 'ilist-item "range error"))
249      (ilist-cons (first rest)
250        (if (= n k)
251          first
252          (loop rest (+ n 1)))))))
253
254(define (ilist-from-upto from upto lst)
255  (let loop ((ls lst) (k 0) (result (ilist-null)))
256    (cases ilist ls
257      (ilist-null () (ilist-reverse result))
258      (ilist-cons (first rest)
259        (cond
260          ((= k upto)
261           (ilist-reverse result))
262          ((< k from)
263           (loop rest (+ k 1) result))
264          (else
265            (loop rest (+ k 1) (ilist-cons first result))))))))
266
267(define (ilist-split-at k lst)
268  (let loop ((ls lst) (n 0) (head (ilist-null)))
269    (cases ilist ls
270      (ilist-null () (values (ilist-reverse head) ls))
271      (ilist-cons (first rest)
272        (if (= n k)
273         (values (ilist-reverse head) ls)
274         (loop rest (+ n 1) (ilist-cons first head)))))))
275
276(define (ilist-split-with ok? lst)
277  (let loop ((ls lst) (head (ilist-null)))
278    (cases ilist ls
279      (ilist-null () (values (ilist-reverse head) ls))
280      (ilist-cons (first rest)
281        (if (ok? first)
282          (values (ilist-reverse head) ls)
283          (loop rest (ilist-cons first head)))))))
284
285(define (ilist-take k lst)
286  (call-with-values
287    (lambda () (ilist-split-at k lst))
288    (lambda (head tail) head)))
289
290(define (ilist-take-while ok? lst)
291  (call-with-values
292    (lambda () (ilist-split-with (o not ok?) lst))
293    (lambda (head tail) head)))
294
295(define (ilist-drop k lst)
296  (call-with-values
297    (lambda () (ilist-split-at k lst))
298    (lambda (head tail) tail)))
299
300(define (ilist-drop-while ok? lst)
301  (call-with-values
302    (lambda () (ilist-split-with (o not ok?) lst))
303    (lambda (head tail) tail)))
304
305(define (ilist-append . lsts)
306  (cond
307    ((null? lsts)
308     (ilist-null))
309    ((null? (cdr lsts))
310     (car lsts))
311    ((null? (cddr lsts))
312     (let loop ((ls0 (ilist-reverse (car lsts)))
313                (result (cadr lsts)))
314       (cases ilist ls0
315         (ilist-null () result)
316         (ilist-cons (first rest)
317                 (loop rest (ilist-cons first result))))))
318    (else
319      (ilist-append (car lsts)
320                (apply ilist-append (cdr lsts))))))
321
322;(define (ilist-mappend fn . lsts)
323;  (apply ilist-append
324;         (apply map fn
325;                (map ilist->list lsts))))
326
327(define (ilist-mappend fn . lsts)
328  (ilist-apply ilist-append
329               (apply ilist-map fn lsts)))
330
331(define (ilist-map fn . lsts)
332  (if (null? lsts)
333    (ilist-null)
334    (let loop ((lsts lsts) (result (ilist-null)))
335      (if (memq #t (map ilist-null? lsts))
336        (ilist-reverse result)
337        (loop (map ilist-rest lsts)
338              (ilist-cons (apply fn (map ilist-first lsts))
339                      result))))))
340
341(define (ilist-for-each fn . lsts)
342  (unless (null? lsts)
343    (do ((lsts lsts (map ilist-rest lsts)))
344      ((memq #t (map ilist-null? lsts)))
345      (apply fn (map ilist-first lsts)))))
346
347(define (ilist-filter ok? lst)
348  (let loop ((ls lst) (yes (ilist-null)) (no (ilist-null)))
349    (cases ilist ls
350      (ilist-null ()
351        (values (ilist-reverse yes) (ilist-reverse no)))
352      (ilist-cons (first rest)
353         (if (ok? first)
354           (loop rest (ilist-cons first yes) no)
355           (loop rest yes (ilist-cons first no)))))))
356
357(define (ilist-equal? lst0 lst1)
358  (let loop ((ls0 lst0) (ls1 lst1))
359    (cond
360      ((ilist-null? ls0)
361       (ilist-null? ls1))
362      ((ilist-null? ls1)
363       (ilist-null? ls0))
364      (else
365        (and (equ? (ilist-first ls0)
366                    (ilist-first ls1))
367             (loop (ilist-rest ls0)
368                   (ilist-rest ls1)))))))
369
370(define (ilist-memp ok? lst)
371  (let loop ((ls lst))
372    (cases ilist ls
373      (ilist-null () #f)
374      (ilist-cons (first rest)
375         (if (ok? first)
376           ls
377           (loop rest))))))
378
379(define (ilist-member item lst)
380  (ilist-memp (lambda (x) (equ? x item)) lst))
381
382(define (ilist-remp ok? lst)
383  (call-with-values (lambda () (ilist-filter ok? lst))
384                    (lambda (a b) b)))
385
386(define (ilist-remove item lst)
387  (ilist-remp (lambda (x) (equ? item x)) lst))
388
389(define (ilist-adjoin item lst)
390  (if (ilist-member item lst)
391    lst
392    (ilist-cons item lst)))
393
394(define (ilist-remove-dups lst)
395  (let loop ((ls lst) (result (ilist-null)))
396    (cases ilist ls
397      (ilist-null () result)
398      (ilist-cons (first rest)
399              (loop rest (ilist-adjoin first result))))))
400
401(define (ilist-assp ok? lst)
402  (let loop ((ls lst))
403    (cases ilist ls
404      (ilist-null () #f)
405      (ilist-cons (first rest)
406        (if (ok? (car first))
407          first
408          (loop rest))))))
409
410(define (ilist-assoc item lst)
411  (ilist-assp (lambda (x) (equ? item x)) lst))
412
413(define (ilist-fold-left op base . lsts)
414  (cond
415    ((null? lsts) base)
416    ((null? (cdr lsts))
417     (let loop ((lst (car lsts)) (result base))
418       (if (ilist-null? lst)
419         result
420         (loop (ilist-rest lst)
421               (op result (ilist-first lst))))))
422    (else
423      (let loop ((lsts lsts) (result base))
424        (cond
425          (((list-of? ilist-null?) lsts)
426           result)
427          (((list-of? (o not ilist-null?)) lsts)
428           (loop (map ilist-rest lsts)
429                 (apply op result (map ilist-first lsts))))
430          (else
431            (error 'ilist-fold-left "lists not of equal length")))))))
432
433(define (ilist-fold-right op base . lsts)
434  (cond
435    ((null? lsts) base)
436    ((null? (cdr lsts))
437     (let loop ((lst (ilist-reverse (car lsts)))
438                (result base))
439       (if (ilist-null? lst)
440         result
441         (loop (ilist-rest lst)
442               (op (ilist-first lst) result)))))
443    (else
444      (let loop (
445        ;; checking for equal length is done by ilist-reverse
446        (lsts (call-with-values
447                (lambda () (apply ilist-reverse lsts))
448                list))
449        (result base)
450        )
451        (if ((list-of? ilist-null?) lsts)
452          result
453          (loop (map ilist-rest lsts)
454                (apply op
455                       (append (map ilist-first lsts)
456                               (list result)))))))))
457
458(define (ilist-merge <? lst0 lst1)
459  ;; without sorted checks, not tail recursive
460  ;(let loop ((ls0 lst0) (ls1 lst1))
461  ;  (cond
462  ;    ((ilist-null? ls0) ls1)
463  ;    ((ilist-null? ls1) ls0)
464  ;    ((<? (ilist-first ls0) (ilist-first ls1))
465  ;     (ilist-cons (ilist-first ls0)
466  ;             (loop (ilist-rest ls0) ls1)))
467  ;    (else
468  ;     (ilist-cons (ilist-first ls1)
469  ;             (loop ls0 (ilist-rest ls1)))))))
470  ;; tail recursive, with sorted checks
471  (let loop ((ls0 lst0) (ls1 lst1) (result (ilist-null)))
472    (cond
473      ((and (ilist-null? ls0) (ilist-null? ls1))
474       (ilist-reverse result))
475      ((ilist-null? ls0)
476       (if (or (ilist-null? (ilist-rest ls1))
477               (<? (ilist-first ls1) (ilist-first (ilist-rest ls1))))
478         (loop ls0 (ilist-rest ls1) (ilist-cons (ilist-first ls1) result))
479         (error 'ilist-merge "not sorted" lst1)))
480      ((ilist-null? ls1)
481       (if (or (ilist-null? (ilist-rest ls0))
482               (<? (ilist-first ls0) (ilist-first (ilist-rest ls0))))
483         (loop (ilist-rest ls0) ls1 (ilist-cons (ilist-first ls0) result))
484         (error 'ilist-merge "not sorted" lst1)))
485      ((not (or (ilist-null? (ilist-rest ls0))
486                (<? (ilist-first ls0) (ilist-first (ilist-rest ls0)))))
487       (error 'ilist-merge "not sorted" lst0))
488      ((not (or (ilist-null? (ilist-rest ls1))
489                (<? (ilist-first ls1) (ilist-first (ilist-rest ls1)))))
490       (error 'ilist-merge "not sorted" lst1))
491      (else
492        (if (<? (ilist-first ls0) (ilist-first ls1))
493          (loop (ilist-rest ls0) ls1 (ilist-cons (ilist-first ls0) result))
494          (loop ls0 (ilist-rest ls1) (ilist-cons (ilist-first ls1) result))))
495      )))
496
497(define (ilist-merge-sort <? lst)
498  (let loop ((ls lst))
499    (let ((len (ilist-length ls)))
500      (if (< len 2)
501        ls
502        (receive (head tail)
503          (ilist-split-at (quotient len 2) ls)
504          (ilist-merge <?
505                   (loop head)
506                   (loop tail)))))))
507
508(define (ilist-insertion-sort <? lst)
509  (cases ilist lst
510    (ilist-null () lst)
511    (ilist-cons (first rest)
512      (ilist-insert-sorted <?
513                           first
514                           (ilist-insertion-sort <? rest)))))
515
516(define (ilist-sorted? <? lst)
517  (let loop ((ls lst))
518    (cases ilist ls
519      (ilist-null () #t)
520      (ilist-cons (first rest)
521        (cond
522          ((ilist-null? rest) #t)
523          ((<? first (ilist-first rest))
524           (loop rest))
525          (else #f))))))
526
527(define (ilist-insert-sorted <? item lst)
528  (if (ilist-sorted? <? lst)
529    (let loop ((lst lst))
530      (cases ilist lst
531        (ilist-null () (ilist-cons item (ilist-null)))
532        (ilist-cons (first rest)
533          (if (<? item first)
534            (ilist-apply ilist item first rest)
535            (ilist-cons first (loop rest))))))
536    (error 'ilist-insert-sorted "argument list not sorted" lst)))
537
538(define (ilist-zip lst0 lst1)
539  (cond
540    ((ilist-null? lst0)
541     lst1)
542    (else
543      (ilist-cons (ilist-first lst0)
544              (ilist-zip lst1 (ilist-rest lst0))))))
545
546(define (ilist-unzip lst)
547  (let loop ((lst lst)
548             (k 0)
549             (lst0 (ilist-null))
550             (lst1 (ilist-null)))
551    (cases ilist lst
552      (ilist-null ()
553        (values (ilist-reverse lst0)
554                (ilist-reverse lst1)))
555      (ilist-cons (first rest)
556        (if (even? k)
557          (loop rest
558                (+ k 1)
559                (ilist-cons first lst0)
560                lst1)
561          (loop rest
562                (+ k 1)
563                lst0
564                (ilist-cons first lst1)))))))
565
566(define (ilist-interpose sep lst)
567  (ilist-rest
568    (let loop ((ls lst) (result (ilist-null)))
569      (cases ilist ls
570        (ilist-null () (ilist-reverse result))
571        (ilist-cons (first rest)
572          (loop rest
573                (ilist-cons first (ilist-cons sep result))))))))
574                ;(ilist-apply ilist first sep result)))))))
575
576(define (ilist-every? ok? lst)
577  (not (ilist-memp (o not ok?) lst)))
578
579(define (ilist-not-every? ok? lst)
580  (if (ilist-memp (o not ok?) lst) #t #f))
581
582(define (ilist-not-any? ok? lst)
583  (if (ilist-memp ok? lst)
584    #f
585    #t))
586
587(define (ilist-some ok? lst)
588  (let loop ((ls lst))
589    (cases ilist ls
590      (ilist-null () #f)
591      (ilist-cons (first rest)
592         (if (ok? first)
593           first
594           (loop rest))))))
595
596(define (ilist-in? ilst1 ilst2)
597  (cases ilist ilst1
598    (ilist-null () #t)
599    (ilist-cons (first rest)
600      (let ((start (ilist-member first ilst2)))
601        (if start
602          (let loop ((ls0 ilst1) (ls1 start))
603            (cond
604              ((and (ilist-null? ls0) (ilist-null? ls1)) #t)
605              ((ilist-null? ls0) #t)
606              ((ilist-null? ls1) #f)
607              ((equ? (ilist-first ls0) (ilist-first ls1))
608               (loop (ilist-rest ls0) (ilist-rest ls1)))
609              (else #f)))
610          #f)))))
611
612;;; documentation
613(define ilists
614  (let (
615    (signatures '(
616      (ilist? xpr)
617      (ilist . args)
618      (list->ilist lst)
619      (ilist-null)
620      (ilist-cons item ilst)
621      (ilist-repeat n x)
622      (ilist-iterate n fn x)
623      (ilist-iterate-while ok? fn x)
624      (ilist-iterate-until ok? fn x)
625
626      (ilist->list ilst)
627      (ilist-apply fn . args)
628      (ilist-null? xpr)
629      (ilist-first ilst)
630      (ilist-rest ilst)
631      (ilist-reverse . ilsts)
632      (ilist-length ilst)
633      (ilist-from-upto from upto ilst) ; sublist
634      (ilist-item k ilst) ; ref
635      (ilist-split-at k ilst)
636      (ilist-split-with ok? ilst)
637      (ilist-drop k ilst)
638      (ilist-drop-while ok? ilst)
639      (ilist-take k ilst)
640      (ilist-take-while ok? ilst)
641      (ilist-append . ilsts)
642      (ilist-map fn . ilsts)
643      (ilist-mappend fn . ilsts)
644      (ilist-for-each fn . ilsts)
645      (ilist-filter ok? ilst)
646      (ilist-adjoin item ilst)
647      (ilist-equal? ilst0 ilst1)
648      (ilist-memp ok? ilst)
649      (ilist-member item ilst)
650      (ilist-remp ok? ilst)
651      (ilist-remove item ilst)
652      (ilist-remove-dups ilst)
653      (ilist-assp ok? ilst)
654      (ilist-assoc item ilst)
655      (ilist-fold-left op base . ilsts)
656      (ilist-fold-right op base . ilsts)
657      (ilist-merge <? ilst0 ilst1)
658      (ilist-merge-sort <? ilst)
659      (ilist-insertion-sort <? ilst)
660      (ilist-sorted? <? ilst)
661      (ilist-insert-sorted <? item ilst)
662      (ilist-zip ilst0 ilst1)
663      (ilist-unzip ilst)
664      (ilist-interpose sep ilst)
665      (ilist-every? ok? ilst)
666      (ilist-some ok? ilst)
667      (ilist-not-every? ok? ilst)
668      (ilist-not-any? ok? ilst)
669      (ilist-in? ilst0 ilst1)
670      (ilist-bind (x ... . xs) ilst xpr . xprs)
671      ))
672    )
673    (case-lambda
674      (() (map car signatures))
675      ((sym) (assq sym signatures)))))
676
677) ; functor list-functor
678
679(functor (set-functor (M (item? equ?)) (N LISTS)) SETS
680
681(import scheme
682        (only chicken error define-record-printer case-lambda)
683        (only extras sprintf)
684        datatype
685        M N)
686
687;;; sets as ilists
688
689(define-datatype set set?
690  (ilist->set (ls ilist?)))
691
692(define (set-add item st)
693  (ilist->set
694    (cases set st
695      (ilist->set (ls)
696         (ilist-cons item ls)))))
697 
698(define (set-remove item st)
699  (ilist->set
700    (cases set st
701      (ilist->set (ls)
702        (cases ilist ls
703          (ilist-null ()
704            (ilist-null))
705          (ilist-cons (first rest)
706            (if (equ? item first)
707              (ilist-remove item rest)
708              (ilist-cons first
709                         (ilist-remove item rest)))))))))
710     
711(define (set->ilist st)
712  (cases set st
713    (ilist->set (st) st)))
714
715(define-record-printer (set st out)
716  (let ((str (sprintf "~s"
717               (ilist->list
718                 (cases set st
719                   (ilist->set (ls)
720                     (ilist-remove-dups ls)))))))
721    (string-set! str 0 #\{)
722    (string-set! str (- (string-length str) 1) #\})
723    (display str out)))
724
725(define (set . args)
726  (ilist->set (apply ilist args)))
727
728(define (set-cardinality st)
729  (cases set st
730    (ilist->set (ls)
731       (ilist-length (ilist-remove-dups ls)))))
732
733(define (set-in? item st)
734  (cases set st
735    (ilist->set (ls)
736      (if (ilist-member item ls) #t #f))))
737
738(define (set<= set0 set1)
739  (cases set set0
740    (ilist->set (ls0)
741      (ilist-every?
742        (lambda (item)
743          (ilist-member
744            item
745            (cases set set1
746              (ilist->set (ls1)
747                          ls1))))
748        ls0))))
749
750(define (set>= set0 set1) (set<= set1 set0))
751
752(define (set= set0 set1)
753  (and (set<= set0 set1)
754       (set<= set1 set0)))
755
756;; ilist-filter not used, to avoid unnessecary reversing
757(define (set-filter ok? st)
758  (cases set st
759    (ilist->set (ls)
760      (let loop ((ls ls) (yes (ilist-null)) (no (ilist-null)))
761        (cases ilist ls
762          (ilist-null ()
763            (values (ilist->set yes) (ilist->set no)))
764          (ilist-cons (first rest)
765            (if (ok? first)
766              (loop rest (ilist-cons first yes) no)
767              (loop rest yes (ilist-cons first no)))))))))
768
769(define (set-null? xpr)
770  (and (set? xpr)
771       (cases set xpr
772         (ilist->set (ls) (ilist-null? ls)))))
773
774(define (set-difference set0 set1)
775  (let loop ((ls1 (set->ilist  set1))
776             (ls0 (set->ilist set0)))
777    (cases ilist ls1
778      (ilist-null () (ilist->set ls0))
779      (ilist-cons (first rest)
780        (loop rest (ilist-remove first ls0))))))
781
782;; ilist-append not used, ilist-o avoid unnessecary reversing
783(define (set-union . sts)
784  (cond
785    ((null? sts) (ilist->set (ilist-null)))
786    ((null? (cdr sts)) (car sts))
787    ((null? (cddr sts))
788     (cases set (car sts)
789       (ilist->set (ls)
790         (let loop ((ls ls) (result (cadr sts)))
791           (cases ilist ls
792             (ilist-null () result)
793             (ilist-cons (first rest)
794               (loop rest
795                     (set-add first result))))))))
796    (else
797      (set-union (car sts)
798                   (apply set-union (cdr sts))))))
799
800(define (set-intersection . sts)
801    (cond
802      ((null? sts)
803       (ilist->set (ilist-null)))
804      ((null? (cdr sts))
805       (car sts))
806      ((null? (cddr sts))
807       (let ((set1 (cadr sts)))
808         (cases set (car sts)
809           (ilist->set (ls)
810             (let loop ((ls ls)
811                        (result (ilist-null)))
812               (cases ilist ls
813                 (ilist-null () (ilist->set result))
814                 (ilist-cons (first rest)
815                   (if (set-in? first set1)
816                     (loop rest
817                           (ilist-cons first result))
818                     (loop rest result)))))))))
819      (else
820        (set-intersection (car sts)
821                            (apply set-intersection (cdr sts))))))
822
823;; documentation procedure
824(define list-sets
825  (let (
826    (signatures '(
827      (set? xpr)
828      (set . args)
829      (ilist->set lst)
830      (set->ilist st)
831      (set-in? item st)
832      (set<= set0 set1)
833      (set= set0 set1)
834      (set>= set0 set1)
835      (set-filter ok? st)
836      (set-null? xpr)
837      (set-add item st)
838      (set-remove item st)
839      (set-cardinality st)
840      (set-difference set0 set1)
841      (set-union . sts)
842      (set-intersection . sts)
843      ))
844    )
845    (case-lambda
846      (() (map car signatures))
847      ((sym) (assq sym signatures)))))
848
849) ; functor set-functor
850
851;;; implicit functor argument _immutable-lists
852(module immutable-lists = list-functor
853  (import scheme
854          (only chicken case-lambda))
855
856  (define item? (lambda (x) #t))
857  (define equ? equal?)
858  ) ; immutable-lists
859
860
861
862;;; explicit functor arguments
863(module list-sets = (set-functor _immutable-lists immutable-lists))
864
Note: See TracBrowser for help on using the repository browser.