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

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

list-bind corrected, list-in? added, record-printer changed

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