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

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

typed-lists version 1.2 added list-cons-sorted

File size: 24.3 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(functor (typed-lists (M (type? equ?)))
39  ;;functor exports
40  (typed-lists typed-list? typed-list untyped-list->typed-list typed-list->untyped-list
41   list-apply list-null list-null? list-cons list-first list-rest list-reverse
42   list-length list-item list-map list-for-each list-append list-mappend
43   list-from-upto list-split-at list-split-with list-equal? list-member
44   list-memp list-remp list-remove list-remove-dups list-assp list-assoc
45   list-filter list-fold-left list-fold-right list-merge list-sort
46   list-sorted? list-cons-sorted
47   list-drop list-drop-while list-take list-take-while list-repeat list-iterate
48   list-iterate-while list-iterate-until list-zip list-interpose list-every?
49   list-some list-not-every? list-not-any? list-in? list-bind
50   ;sets
51   sets set? set typed-list->set set->typed-list 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
56(import scheme
57        (only chicken error define-record-printer
58              unless receive case-lambda)
59        (only data-structures list-of? o compose)
60        (only extras sprintf)
61        datatype
62        M)
63
64(import-for-syntax (only chicken receive print))
65
66(define-datatype typed-list typed-list?
67  (list-null)
68  (list-cons
69    (first type?)
70    (rest typed-list?)))
71
72(define-record-printer (typed-list tlst out)
73  (let ((str (sprintf "~s" (typed-list->untyped-list tlst))))
74    (string-set! str (- (string-length str) 1) #\])
75    (string-set! str 0 #\[)
76    (display str out)))
77
78;(define-reader-ctor 'typed typed-list)
79
80(define (list-null? xpr)
81  (and (typed-list? xpr)
82       (cases typed-list xpr
83         (list-null () #t)
84         (list-cons (first rest) #f))))
85
86(define (list-first lst)
87  (cases typed-list lst
88    (list-null () (error 'list-first "list empty" lst))
89    (list-cons (first rest) first)))
90
91(define (list-rest lst)
92  (cases typed-list lst
93    (list-null () (error 'list-rest "list empty" lst))
94    (list-cons (first rest) rest)))
95
96(define-syntax list-bind
97  (ir-macro-transformer
98    (lambda (form inject compare?)
99      (let ((pat (cadr form))
100            (tlst (caddr form))
101            (xpr (caddr form))
102            (xprs (cdddr form)))
103        (let ((tlst tlst))
104                    ;; not available at compile time
105                    ;(if (typed-list? tlst)
106                    ;  tlst
107                    ;  (error 'list-bind
108                    ;         "not a typed list"
109                    ;         tlst))))
110          (if (list? pat)
111            `(if (= ,(length pat) (list-length ,tlst))
112               (list-apply (lambda ,pat ,xpr ,@xprs) ,tlst)
113               (error 'list-bind "match error" ',pat ,tlst))
114            ;; pseudolist: separate list part
115            (receive (head tail)
116              (let loop ((pat pat) (lst '()))
117                (if (pair? pat)
118                  (loop (cdr pat) (cons (car pat) lst))
119                  (values (reverse lst) pat)))
120              `(if (<= ,(length head) (list-length ,tlst))
121                 (receive (hd tl) (list-split-at ,(length head) ,tlst)
122                   (let ((,tail tl))
123                     (list-apply (lambda ,head ,xpr ,@xprs) hd)))
124                 (error 'list-bind "match error" ',pat ,tlst)))))))))
125
126(define (list-reverse . lsts)
127  (cond
128    ((null? lsts)
129     (list-null))
130    ((null? (cdr lsts))
131     (let loop ((ls (car lsts)) (result (list-null)))
132       (cases typed-list ls
133         (list-null () result)
134         (list-cons (first rest)
135                    (loop rest (list-cons first result))))))
136    (else
137      (let loop (
138        (lsts lsts)
139        (results ;(make-list (length lsts) (list-null)))
140                 (let recur ((n (length lsts))
141                             (result '()))
142                   (if (zero? n)
143                     result
144                     (recur (- n 1) (cons (list-null) result)))))
145        )
146        (cond
147          (((list-of? list-null?) lsts)
148           (apply values results))
149          (((list-of? (o not list-null?)) lsts)
150           (loop (map list-rest lsts)
151                 (map (lambda (l ll) (list-cons l ll))
152                      (map list-first lsts)
153                      results)))
154          (else (error 'list-reverse "lists not of equal length")))))))
155
156(define (typed-list . args)
157  (let loop ((args args) (result (list-null)))
158    (if (null? args)
159      (list-reverse result)
160      (loop (cdr args) (list-cons (car args) result)))))
161
162(define (list-repeat n x)
163  (let loop ((k 0) (result (list-null)))
164    (if (= k n)
165      result
166      (loop (+ k 1) (list-cons x result)))))
167
168(define (list-iterate n fn x)
169  (let loop ((k 0) (val x) (result (list-null)))
170    (if (= k n)
171      (list-reverse result)
172      (loop (+ k 1) (fn val) (list-cons val result)))))
173
174(define (list-iterate-while ok? fn x)
175  (let loop ((val x) (result (list-null)))
176    (if (ok? val)
177      (loop (fn val) (list-cons val result))
178      (list-reverse result))))
179
180(define (list-iterate-until ok? fn x)
181  (let loop ((val x) (result (list-null)))
182    (if (ok? val)
183      (list-reverse result)
184      (loop (fn val) (list-cons val result)))))
185
186(define (typed-list->untyped-list lst)
187  (let loop ((ls lst) (result '()))
188    (cases typed-list ls
189      (list-null () (reverse result))
190      (list-cons (first rest)
191       (loop rest (cons first result))))))
192
193(define (list-apply fn . args)
194  (let ((len (length args)))
195    (apply fn
196      (let loop ((k 0) (result '()))
197        (cond
198          ((= k len) (reverse result))
199          ((= k (- len 1))
200           (let ((tail (list-ref args k)))
201             (if (typed-list? tail)
202               (loop (+ k 1)
203                     (append
204                       (reverse
205                         (typed-list->untyped-list tail))
206                       result))
207               (error 'list-apply
208                      (string-append
209                        "not a "
210                        (symbol->string
211                          'tlist))
212                      tail))))
213          (else
214            (let ((item (list-ref args k)))
215              (if (type? item)
216                (loop (+ k 1)
217                      (cons item result))
218                (error 'list-apply
219                       "wrong list-ype"
220                       `(,type? ,item))))))))))
221
222(define (untyped-list->typed-list lst)
223  (apply typed-list lst))
224
225(define (list-length lst)
226  (let loop ((ls lst) (k 0))
227    (cases typed-list ls
228      (list-null () k)
229      (list-cons (first rest)
230        (loop rest (+ k 1))))))
231
232(define (list-item k lst)
233  (let loop ((ls lst) (n 0))
234    (cases typed-list ls
235      (list-null () (error 'list-item "range error"))
236      (list-cons (first rest)
237        (if (= n k)
238          first
239          (loop rest (+ n 1)))))))
240
241(define (list-from-upto from upto lst)
242  (let loop ((ls lst) (k 0) (result (list-null)))
243    (cases typed-list ls
244      (list-null () (list-reverse result))
245      (list-cons (first rest)
246        (cond
247          ((= k upto)
248           (list-reverse result))
249          ((< k from)
250           (loop rest (+ k 1) result))
251          (else
252            (loop rest (+ k 1) (list-cons first result))))))))
253
254(define (list-split-at k lst)
255  (let loop ((ls lst) (n 0) (head (list-null)))
256    (cases typed-list ls
257      (list-null () (values (list-reverse head) ls))
258      (list-cons (first rest)
259        (if (= n k)
260         (values (list-reverse head) ls)
261         (loop rest (+ n 1) (list-cons first head)))))))
262
263(define (list-split-with ok? lst)
264  (let loop ((ls lst) (head (list-null)))
265    (cases typed-list ls
266      (list-null () (values (list-reverse head) ls))
267      (list-cons (first rest)
268        (if (ok? first)
269          (values (list-reverse head) ls)
270          (loop rest (list-cons first head)))))))
271
272(define (list-take k lst)
273  (call-with-values
274    (lambda () (list-split-at k lst))
275    (lambda (head tail) head)))
276
277(define (list-take-while ok? lst)
278  (call-with-values
279    (lambda () (list-split-with (o not ok?) lst))
280    (lambda (head tail) head)))
281
282(define (list-drop k lst)
283  (call-with-values
284    (lambda () (list-split-at k lst))
285    (lambda (head tail) tail)))
286
287(define (list-drop-while ok? lst)
288  (call-with-values
289    (lambda () (list-split-with (o not ok?) lst))
290    (lambda (head tail) tail)))
291
292(define (list-append . lsts)
293  (cond
294    ((null? lsts)
295     (list-null))
296    ((null? (cdr lsts))
297     (car lsts))
298    ((null? (cddr lsts))
299     (let loop ((ls0 (list-reverse (car lsts)))
300                (result (cadr lsts)))
301       (cases typed-list ls0
302         (list-null () result)
303         (list-cons (first rest)
304                 (loop rest (list-cons first result))))))
305    (else
306      (list-append (car lsts)
307                (apply list-append (cdr lsts))))))
308
309(define (list-mappend fn . lsts)
310  (apply list-append
311         (apply map fn
312                (map typed-list->untyped-list lsts))))
313
314(define (list-map fn . lsts)
315  (if (null? lsts)
316    (list-null)
317    (let loop ((lsts lsts) (result (list-null)))
318      (if (memq #t (map list-null? lsts))
319        (list-reverse result)
320        (loop (map list-rest lsts)
321              (list-cons (apply fn (map list-first lsts))
322                      result))))))
323
324(define (list-for-each fn . lsts)
325  (unless (null? lsts)
326    (do ((lsts lsts (map list-rest lsts)))
327      ((memq #t (map list-null? lsts)))
328      (apply fn (map list-first lsts)))))
329
330(define (list-filter ok? lst)
331  (let loop ((ls lst) (yes (list-null)) (no (list-null)))
332    (cases typed-list ls
333      (list-null ()
334        (values (list-reverse yes) (list-reverse no)))
335      (list-cons (first rest)
336         (if (ok? first)
337           (loop rest (list-cons first yes) no)
338           (loop rest yes (list-cons first no)))))))
339
340(define (list-equal? lst0 lst1)
341  (let loop ((ls0 lst0) (ls1 lst1))
342    (cond
343      ((list-null? ls0)
344       (list-null? ls1))
345      ((list-null? ls1)
346       (list-null? ls0))
347      (else
348        (and (equ? (list-first ls0)
349                    (list-first ls1))
350             (loop (list-rest ls0)
351                   (list-rest ls1)))))))
352
353(define (list-memp ok? lst)
354  (let loop ((ls lst))
355    (cases typed-list ls
356      (list-null () #f)
357      (list-cons (first rest)
358         (if (ok? first)
359           ls
360           (loop rest))))))
361
362(define (list-member item lst)
363  (list-memp (lambda (x) (equ? x item)) lst))
364
365(define (list-remp ok? lst)
366  (call-with-values (lambda () (list-filter ok? lst))
367                    (lambda (a b) b)))
368
369(define (list-remove item lst)
370  (list-remp (lambda (x) (equ? item x)) lst))
371
372(define (list-adjoin item lst)
373  (if (list-member item lst)
374    lst
375    (list-cons item lst)))
376
377(define (list-remove-dups lst)
378  (let loop ((ls lst) (result (list-null)))
379    (cases typed-list ls
380      (list-null () result)
381      (list-cons (first rest)
382              (loop rest (list-adjoin first result))))))
383
384(define (list-assp ok? lst)
385  (let loop ((ls lst))
386    (cases typed-list ls
387      (list-null () #f)
388      (list-cons (first rest)
389        (if (ok? (car first))
390          first
391          (loop rest))))))
392
393(define (list-assoc item lst)
394  (list-assp (lambda (x) (equ? item x)) lst))
395
396(define (list-fold-left op base . lsts)
397  (cond
398    ((null? lsts) base)
399    ((null? (cdr lsts))
400     (let loop ((lst (car lsts)) (result base))
401       (if (list-null? lst)
402         result
403         (loop (list-rest lst)
404               (op result (list-first lst))))))
405    (else
406      (let loop ((lsts lsts) (result base))
407        (cond
408          (((list-of? list-null?) lsts)
409           result)
410          (((list-of? (o not list-null?)) lsts)
411           (loop (map list-rest lsts)
412                 (apply op result (map list-first lsts))))
413          (else
414            (error 'list-fold-left "lists not of equal length")))))))
415
416(define (list-fold-right op base . lsts)
417  (cond
418    ((null? lsts) base)
419    ((null? (cdr lsts))
420     (let loop ((lst (list-reverse (car lsts)))
421                (result base))
422       (if (list-null? lst)
423         result
424         (loop (list-rest lst)
425               (op (list-first lst) result)))))
426    (else
427      (let loop (
428        ;; checking for equal length is done by list-reverse
429        (lsts (call-with-values
430                (lambda () (apply list-reverse lsts))
431                list))
432        (result base)
433        )
434        (if ((list-of? list-null?) lsts)
435          result
436          (loop (map list-rest lsts)
437                (apply op
438                       (append (map list-first lsts)
439                               (list result)))))))))
440
441(define (list-merge <? lst0 lst1)
442  ;; without sorted checks, not tail recursive
443  ;(let loop ((ls0 lst0) (ls1 lst1))
444  ;  (cond
445  ;    ((list-null? ls0) ls1)
446  ;    ((list-null? ls1) ls0)
447  ;    ((<? (list-first ls0) (list-first ls1))
448  ;     (list-cons (list-first ls0)
449  ;             (loop (list-rest ls0) ls1)))
450  ;    (else
451  ;     (list-cons (list-first ls1)
452  ;             (loop ls0 (list-rest ls1)))))))
453  ;; tail recursive, with sorted checks
454  (let loop ((ls0 lst0) (ls1 lst1) (result (list-null)))
455    (cond
456      ((and (list-null? ls0) (list-null? ls1))
457       (list-reverse result))
458      ((list-null? ls0)
459       (if (or (list-null? (list-rest ls1))
460               (<? (list-first ls1) (list-first (list-rest ls1))))
461         (loop ls0 (list-rest ls1) (list-cons (list-first ls1) result))
462         (error 'list-merge "not sorted" lst1)))
463      ((list-null? ls1)
464       (if (or (list-null? (list-rest ls0))
465               (<? (list-first ls0) (list-first (list-rest ls0))))
466         (loop (list-rest ls0) ls1 (list-cons (list-first ls0) result))
467         (error 'list-merge "not sorted" lst1)))
468      ((not (or (list-null? (list-rest ls0))
469                (<? (list-first ls0) (list-first (list-rest ls0)))))
470       (error 'list-merge "not sorted" lst0))
471      ((not (or (list-null? (list-rest ls1))
472                (<? (list-first ls1) (list-first (list-rest ls1)))))
473       (error 'list-merge "not sorted" lst1))
474      (else
475        (if (<? (list-first ls0) (list-first ls1))
476          (loop (list-rest ls0) ls1 (list-cons (list-first ls0) result))
477          (loop ls0 (list-rest ls1) (list-cons (list-first ls1) result))))
478      )))
479
480(define (list-sort <? lst)
481  (let loop ((ls lst))
482    (let ((len (list-length ls)))
483      (if (< len 2)
484        ls
485        (receive (head tail)
486          (list-split-at (quotient len 2) ls)
487          (list-merge <?
488                   (loop head)
489                   (loop tail)))))))
490
491(define (list-sorted? <? lst)
492  (let loop ((ls lst))
493    (cases typed-list ls
494      (list-null () #t)
495      (list-cons (first rest)
496        (cond
497          ((list-null? rest) #t)
498          ((<? first (list-first rest))
499           (loop rest))
500          (else #f))))))
501
502(define (list-cons-sorted <? item lst)
503  (if (list-sorted? <? lst)
504    (let loop ((lst lst))
505      (cases typed-list lst
506        (list-null () (list-cons item (list-null)))
507        (list-cons (first rest)
508          (if (<? item first)
509            (list-apply typed-list item first rest)
510            (list-cons first (loop rest))))))
511    (error 'list-cons-sorted "argument list not sorted" lst)))
512
513(define (list-zip lst0 lst1)
514  (cond
515    ((list-null? lst0)
516     lst1)
517    (else
518      (list-cons (list-first lst0)
519              (list-zip lst1 (list-rest lst0))))))
520
521(define (list-interpose sep lst)
522  (list-rest
523    (let loop ((ls lst) (result (list-null)))
524      (cases typed-list ls
525        (list-null () (list-reverse result))
526        (list-cons (first rest)
527          (loop rest
528                (list-cons first (list-cons sep result))))))))
529                ;(list-apply typed-list first sep result)))))))
530
531(define (list-every? ok? lst)
532  (not (list-memp (o not ok?) lst)))
533
534(define (list-not-every? ok? lst)
535  (if (list-memp (o not ok?) lst) #t #f))
536
537(define (list-not-any? ok? lst)
538  (if (list-memp ok? lst)
539    #f
540    #t))
541
542(define (list-some ok? lst)
543  (let loop ((ls lst))
544    (cases typed-list ls
545      (list-null () #f)
546      (list-cons (first rest)
547         (if (ok? first)
548           first
549           (loop rest))))))
550
551(define (list-in? tlst1 tlst2)
552  (cases typed-list tlst1
553    (list-null () #t)
554    (list-cons (first rest)
555      (let ((start (list-member first tlst2)))
556        (if start
557          (let loop ((ls0 tlst1) (ls1 start))
558            (cond
559              ((and (list-null? ls0) (list-null? ls1)) #t)
560              ((list-null? ls0) #t)
561              ((list-null? ls1) #f)
562              ((equ? (list-first ls0) (list-first ls1))
563               (loop (list-rest ls0) (list-rest ls1)))
564              (else #f)))
565          #f)))))
566
567;;; documentation
568(define typed-lists
569  (let (
570    (signatures '(
571      (typed-list? xpr)
572      (typed-list . args)
573      (untyped-list->typed-list tlst)
574      (list-null)
575      (list-cons item tlst)
576      (list-repeat n x)
577      (list-iterate n fn x)
578      (list-iterate-while ok? fn x)
579      (list-iterate-until ok? fn x)
580
581      (typed-list->untyped-list tlst)
582      (list-apply fn . args)
583      (list-null? xpr)
584      (list-first tlst)
585      (list-rest tlst)
586      (list-reverse . tlsts)
587      (list-length tlst)
588      (list-from-upto from upto tlst) ; sublist
589      (list-item k tlst) ; ref
590      (list-split-at k tlst)
591      (list-split-with ok? tlst)
592      (list-drop k tlst)
593      (list-drop-while ok? tlst)
594      (list-take k tlst)
595      (list-take-while ok? tlst)
596      (list-append . tlsts)
597      (list-map fn . tlsts)
598      (list-mappend fn . tlsts)
599      (list-for-each fn . tlsts)
600      (list-filter ok? tlst)
601      (list-adjoin item tlst)
602      (list-equal? tlst0 tlst1)
603      (list-memp ok? tlst)
604      (list-member item tlst)
605      (list-remp ok? tlst)
606      (list-remove item tlst)
607      (list-remove-dups tlst)
608      (list-assp ok? tlst)
609      (list-assoc item tlst)
610      (list-fold-left op base . tlsts)
611      (list-fold-right op base . tlsts)
612      (list-merge <? tlst0 tlst1)
613      (list-sort <? tlst)
614      (list-sorted? <? tlst)
615      (list-cons-sorted <? item tlst)
616      (list-zip tlst0 tlst1)
617      (list-interpose sep tlst)
618      (list-every? ok? tlst)
619      (list-some ok? tlst)
620      (list-not-every? ok? tlst)
621      (list-not-any? ok? tlst)
622      (list-in? tlst0 tlst1)
623      (list-bind (x ... . xs) tlst xpr . xprs)
624      ))
625    )
626    (case-lambda
627      (() (map car signatures))
628      ((sym) (assq sym signatures)))))
629
630;;; sets as typed-lists
631
632(define-datatype set set?
633  (typed-list->set (ls typed-list?)))
634
635(define (set-add item st)
636  (typed-list->set
637    (cases set st
638      (typed-list->set (ls)
639         (list-cons item ls)))))
640 
641(define (set-remove item st)
642  (typed-list->set
643    (cases set st
644      (typed-list->set (ls)
645        (cases typed-list ls
646          (list-null ()
647            (list-null))
648          (list-cons (first rest)
649            (if (equ? item first)
650              (list-remove item rest)
651              (list-cons first
652                         (list-remove item rest)))))))))
653     
654(define (set->typed-list st)
655  (cases set st
656    (typed-list->set (st) st)))
657
658(define-record-printer (set st out)
659  (let ((str (sprintf "~s"
660               (typed-list->untyped-list
661                 (cases set st
662                   (typed-list->set (ls)
663                     (list-remove-dups ls)))))))
664    (string-set! str 0 #\{)
665    (string-set! str (- (string-length str) 1) #\})
666    (display str out)))
667
668(define (set . args)
669  (typed-list->set (apply typed-list args)))
670
671(define (set-cardinality st)
672  (cases set st
673    (typed-list->set (ls)
674       (list-length (list-remove-dups ls)))))
675
676(define (set-in? item st)
677  (cases set st
678    (typed-list->set (ls)
679      (if (list-member item ls) #t #f))))
680
681(define (set<= set0 set1)
682  (cases set set0
683    (typed-list->set (ls0)
684      (list-every?
685        (lambda (item)
686          (list-member
687            item
688            (cases set set1
689              (typed-list->set (ls1)
690                          ls1))))
691        ls0))))
692
693(define (set>= set0 set1) (set<= set1 set0))
694
695(define (set= set0 set1)
696  (and (set<= set0 set1)
697       (set<= set1 set0)))
698
699;; list-filter not used, to avoid unnessecary reversing
700(define (set-filter ok? st)
701  (cases set st
702    (typed-list->set (ls)
703      (let loop ((ls ls) (yes (list-null)) (no (list-null)))
704        (cases typed-list ls
705          (list-null ()
706            (values (typed-list->set yes) (typed-list->set no)))
707          (list-cons (first rest)
708            (if (ok? first)
709              (loop rest (list-cons first yes) no)
710              (loop rest yes (list-cons first no)))))))))
711
712(define (set-null? xpr)
713  (and (set? xpr)
714       (cases set xpr
715         (typed-list->set (ls) (list-null? ls)))))
716
717(define (set-difference set0 set1)
718  (let loop ((ls1 (set->typed-list  set1))
719             (ls0 (set->typed-list set0)))
720    (cases typed-list ls1
721      (list-null () (typed-list->set ls0))
722      (list-cons (first rest)
723        (loop rest (list-remove first ls0))))))
724
725;; list-append not used, list-o avoid unnessecary reversing
726(define (set-union . sts)
727  (cond
728    ((null? sts) (typed-list->set (list-null)))
729    ((null? (cdr sts)) (car sts))
730    ((null? (cddr sts))
731     (cases set (car sts)
732       (typed-list->set (ls)
733         (let loop ((ls ls) (result (cadr sts)))
734           (cases typed-list ls
735             (list-null () result)
736             (list-cons (first rest)
737               (loop rest
738                     (set-add first result))))))))
739    (else
740      (set-union (car sts)
741                   (apply set-union (cdr sts))))))
742
743(define (set-intersection . sts)
744    (cond
745      ((null? sts)
746       (typed-list->set (list-null)))
747      ((null? (cdr sts))
748       (car sts))
749      ((null? (cddr sts))
750       (let ((set1 (cadr sts)))
751         (cases set (car sts)
752           (typed-list->set (ls)
753             (let loop ((ls ls)
754                        (result (list-null)))
755               (cases typed-list ls
756                 (list-null () (typed-list->set result))
757                 (list-cons (first rest)
758                   (if (set-in? first set1)
759                     (loop rest
760                           (list-cons first result))
761                     (loop rest result)))))))))
762      (else
763        (set-intersection (car sts)
764                            (apply set-intersection (cdr sts))))))
765
766;; documentation procedure
767(define sets
768  (let (
769    (signatures '(
770      (set? xpr)
771      (set . args)
772      (typed-list->set lst)
773      (set->typed-list st)
774      (set-in? item st)
775      (set<= set0 set1)
776      (set= set0 set1)
777      (set>= set0 set1)
778      (set-filter ok? st)
779      (set-null? xpr)
780      (set-add item st)
781      (set-remove item st)
782      (set-cardinality st)
783      (set-difference set0 set1)
784      (set-union . sts)
785      (set-intersection . sts)
786      ))
787    )
788    (case-lambda
789      (() (map car signatures))
790      ((sym) (assq sym signatures)))))
791
792) ; functor typed-lists
793
794;(use simple-tests)
795;(import datatype typed-lists)
796;;; argument module
797;(module nums (type? equ?)
798;  (import scheme)
799;  (define type? number?)
800;  (define equ? =))
801;;; apply functor
802;(module lists = (typed-lists nums))
803;
804;(import lists)
805;
806;(use bindings)
807;(seq-length-ref-tail! typed-list?
808;                      list-length
809;                      (lambda (seq it) (list-item it seq))
810;                      (lambda (seq it) (list-drop it seq)))
811;(xpr:val (typed-list? (bind (a b . c) (typed-list 1 2 3 4) c)))
Note: See TracBrowser for help on using the repository browser.