Changeset 31219 in project


Ignore:
Timestamp:
08/17/14 18:21:19 (5 years ago)
Author:
juergen
Message:

functor-implementation of typed-lists, version 1.0

Location:
release/4/typed-lists
Files:
8 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/typed-lists/tags/1.0/tests/run.scm

    r31192 r31219  
    1 (require-library typed-lists cells simple-tests)
    2 (import typed-lists simple-tests cells)
     1(require-library cells simple-tests datatype)
     2(import typed-lists simple-tests datatype)
    33
    44(define-test (number-lists?)
    55  (check
    6     (define-list-type nlist
    7                       documentation: nlists
    8                       item-predicate: (lambda (x)
    9                                         (or (number? x)
    10                                             ((cell-of? number?) x)))
    11                       item-equality: (lambda (x y)
    12                                        (or (and (number? x)
    13                                                 (number? y)
    14                                                 (= x y))
    15                                            (and (cell? x)
    16                                                 (cell? y)
    17                                                 (= (cell-ref x)
    18                                                    (cell-ref y))))))
    19 
    20     (define nnil (nnull))
    21     (nlist? nnil)
    22     (nnull? nnil)
    23     (not (null? nnil))
    24     (define nls (ncons 1 nnil))
    25     (nlist? nls)
     6    ;; argument module
     7    (module nums (type? equ?)
     8      (import scheme cells)
     9      (define (type? x)
     10        (or (number? x) ((cell-of? number?) x)))
     11      (define (equ? x y)
     12        (or (and (number? x)
     13                 (number? y)
     14                 (= x y))
     15            (and (cell? x)
     16                 (cell? y)
     17                 (= (cell-ref x)
     18                    (cell-ref y)))))
     19      )
     20
     21    ;; apply functor
     22    (module lists = (typed-lists nums))
     23   
     24    ;; import
     25    (import lists cells)
     26
     27    (define nil (list-null))
     28    (typed-list? nil)
     29    (list-null? nil)
     30    (not (null? nil))
     31    (define nls (list-cons 1 nil))
     32    (typed-list? nls)
    2633    nls
    27     (define nlst (nlist 0 1 (cell 2) 3 4))
    28     (nlist? nlst)
     34    (define nlst (typed-list 0 1 (cell 2) 3 4))
     35    (typed-list? nlst)
    2936    (not (list? nlst))
    3037    nlst
    31     (= (napply + 1 2 (nlist 3 4 5)) 15)
    32     (nequal? (nrepeat 5 0) (nlist 0 0 0 0 0))
    33     (nequal? (niterate-times 5 add1 0) (nlist 0 1 2 3 4))
    34     (nequal? (niterate-while (lambda (x) (< x 5)) add1 0)
    35              (nlist 0 1 2 3 4))
    36     (nequal? (niterate-until (lambda (x) (= x 5)) add1 0)
    37              (nlist 0 1 2 3 4))
    38     (nequal? (nzip (nlist 1 2 3 4 5) (nlist 10 20 30))
    39              (nlist 1 10 2 20 3 30 4 5))
    40     (nequal? (ninterpose 10 (nlist 1 2 3 4 5))
    41              (nlist 1 10 2 10 3 10 4 10 5))
    42     (nequal? (ncdddr nlst) (nlist 3 4))
    43     (= (ncadddr nlst) 3)
    44     (nequal? (ndrop 3 nlst) (nlist 3 4))
    45     (nequal? (ndrop-while odd? (nlist 1 3 2 4 5))
    46              (nlist 2 4 5))
    47     (nequal? (ntake-while odd? (nlist 1 3 2 4 5))
    48              (nlist 1 3))
    49     (receive (head tail) (nsplit-with even? (nlist 1 3 2 4 5))
    50       (and (nequal? head (nlist 1 3))
    51            (nequal? tail (nlist 2 4 5))))
    52     (nequal? (ntake 2 nlst) (nlist 0 1))
    53     (define nrest (ncdr nlst))
     38    (= (list-apply + 1 2 (typed-list 3 4 5)) 15)
     39    (list-equal? (list-repeat 5 0) (typed-list 0 0 0 0 0))
     40    (list-equal? (list-iterate 5 add1 0) (typed-list 0 1 2 3 4))
     41    (list-equal? (list-iterate-while (lambda (x) (< x 5)) add1 0)
     42             (typed-list 0 1 2 3 4))
     43    (list-equal? (list-iterate-until (lambda (x) (= x 5)) add1 0)
     44             (typed-list 0 1 2 3 4))
     45    (list-equal? (list-zip (typed-list 1 2 3 4 5) (typed-list 10 20 30))
     46             (typed-list 1 10 2 20 3 30 4 5))
     47    (list-equal? (list-interpose 10 (typed-list 1 2 3 4 5))
     48             (typed-list 1 10 2 10 3 10 4 10 5))
     49    (list-equal? (list-drop 3 nlst) (typed-list 3 4))
     50    (list-equal? (list-drop-while odd? (typed-list 1 3 2 4 5))
     51             (typed-list 2 4 5))
     52    (list-equal? (list-take-while odd? (typed-list 1 3 2 4 5))
     53             (typed-list 1 3))
     54    (receive (head tail) (list-split-with even? (typed-list 1 3 2 4 5))
     55      (and (list-equal? head (typed-list 1 3))
     56           (list-equal? tail (typed-list 2 4 5))))
     57    (list-equal? (list-take 2 nlst) (typed-list 0 1))
     58    (define nrest (list-rest nlst))
    5459    nrest
    55     (nlist? (nnull))
    56     (nnull? (nnull))
    57     (not (nnull? nls))
    58     (not (nlist? '(1 2)))
    59     (nnull? (ncdr nls))
    60     (= (ncar nlst) 0)
    61     (nlist? (nreverse nlst))
    62     (nreverse nlst)
    63     (equal? (nlist->list nlst)
     60    (typed-list? (list-null))
     61    (list-null? (list-null))
     62    (not (list-null? nls))
     63    (not (typed-list? '(1 2)))
     64    (list-null? (list-rest nls))
     65    (= (list-first nlst) 0)
     66    (typed-list? (list-reverse nlst))
     67    (list-reverse nlst)
     68    (equal? (typed-list->untyped-list nlst)
    6469            (list 0 1 (cell 2) 3 4))
    65     (equal? (nref 2 nlst) (cell 2))
    66     (cell-set! (nref 2 nlst) 20)
    67     (equal? (nref 2 nlst) (cell 20))
    68     (= (cell-ref (nref 2 nlst)) 20)
    69     (= (nlength nlst) 5)
    70     (nequal? (nsublist 2 4 nlst)
    71              (nlist (cell 20) 3))
    72     (nequal?  (nappend (nlist 0 1 2 3)
    73                        (nlist 4 5 6))
    74               (nlist 0 1 2 3 4 5 6))
    75     (nequal? (nappend (nlist 0)
    76                       (nlist 1)
    77                       (nlist 2)
    78                       (nlist 3 4)
    79                       (nlist 5 6 7)
    80                       (nlist 8))
    81              (nlist 0 1 2 3 4 5 6 7 8))
    82     (nequal? (nmap add1
    83                    (nlist 0 1 2 3))
    84              (nlist 1 2 3 4))
    85     (nequal? (nmap +
    86                    (nlist 1 2 3)
    87                    (nlist 10 20 30 40))
    88              (nlist 11 22 33))
    89     (nequal?
    90       (nmappend nlist (nlist 10 20 30) (nlist 1 2 3 4 5))
    91       (nlist 10 1 20 2 30 3))
    92     (nequal?
    93       (nfold-right ncons (nnull) (nlist 0 1 2 3 4))
    94       (nlist 0 1 2 3 4))
    95     (nequal? (nfold-right ncons (nnull) (nlist 0 1 2 3 4))
    96              (nlist 0 1 2 3 4))
    97     (= (nfold-left + 0 (nlist 1 2 3) (nlist 10 20 30)) 66)
    98     (equal? (nfold-left cons '(100) (nlist 1 2 3 4))
     70    (equal? (list-item 2 nlst) (cell 2))
     71    (cell-set! (list-item 2 nlst) 20)
     72    (equal? (list-item 2 nlst) (cell 20))
     73    (= (cell-ref (list-item 2 nlst)) 20)
     74    (= (list-length nlst) 5)
     75    (list-equal? (list-from-upto 2 4 nlst)
     76             (typed-list (cell 20) 3))
     77    (list-equal?  (list-append (typed-list 0 1 2 3)
     78                       (typed-list 4 5 6))
     79              (typed-list 0 1 2 3 4 5 6))
     80    (list-equal? (list-append
     81                   (typed-list 0)
     82                   (typed-list 1)
     83                   (typed-list 2)
     84                   (typed-list 3 4)
     85                   (typed-list 5 6 7)
     86                   (typed-list 8))
     87             (typed-list 0 1 2 3 4 5 6 7 8))
     88    (list-equal? (list-map add1
     89                   (typed-list 0 1 2 3))
     90             (typed-list 1 2 3 4))
     91    (list-equal? (list-map +
     92                   (typed-list 1 2 3)
     93                   (typed-list 10 20 30 40))
     94             (typed-list 11 22 33))
     95    (list-equal?
     96      (list-mappend typed-list (typed-list 10 20 30) (typed-list 1 2 3 4 5))
     97      (typed-list 10 1 20 2 30 3))
     98    (list-equal?
     99      (list-fold-right list-cons (list-null) (typed-list 0 1 2 3 4))
     100      (typed-list 0 1 2 3 4))
     101    (list-equal?
     102      (list-fold-right list-cons (typed-list 0 1 2) (typed-list 3 4))
     103      (typed-list 3 4 0 1 2))
     104    (= (list-fold-right * 1 (typed-list 1 2 3 4 5)) 120)
     105    (= (list-fold-left * 1 (typed-list 1 2 3 4 5)) 120)
     106    (= (list-fold-left + 0 (typed-list 1 2 3) (typed-list 10 20 30)) 66)
     107    (equal? (list-fold-left cons '(100) (typed-list 1 2 3 4))
    99108            '(((((100) . 1) . 2) . 3) . 4))
    100109    (equal?
    101110      (call-with-values
    102         (lambda () (nreverse* (nlist 1 2 3) (nlist 10 20 30)))
     111        (lambda () (list-reverse (typed-list 1 2 3) (typed-list 10 20 30)))
    103112        list)
    104       (list (nlist 3 2 1) (nlist 30 20 10)))
    105     (nequal? (nremove 0 (nlist 1 0 2 0 3 0 4))
    106              (nlist 1 2 3 4))
    107     (nequal? (nmerge < (nlist 2 4 5 7 8) (nlist 1 3 6 9 10))
    108              (nlist 1 2 3 4 5 6 7 8 9 10))
    109     (not (condition-case (nmerge < (nnull) (nlist 1 3 2))
     113      (list (typed-list 3 2 1) (typed-list 30 20 10)))
     114    (list-equal? (list-remove 0 (typed-list 1 0 2 0 3 0 4))
     115             (typed-list 1 2 3 4))
     116    (list-equal? (list-merge < (typed-list 2 4 5 7 8) (typed-list 1 3 6 9 10))
     117             (typed-list 1 2 3 4 5 6 7 8 9 10))
     118    (not (condition-case (list-merge < (list-null) (typed-list 1 3 2))
    110119           ((exn) #f)))
    111     (nequal? (nsort <= (nlist 2 0 1 4 3))
    112              (nlist 0 1 2 3 4))
    113     (not (nsorted? <= (nlist 2 0 1 4 3)))
    114     (nsorted? <= (nlist 0 1 2 3 4))
    115     (nevery? odd? (nlist 1 3 5))
    116     (nevery? odd? (nlist))
    117     (= (nsome odd? (nlist 2 3 5)) 3)
    118     (not (nsome odd? (nlist 2 4 6)))
    119     (nnot-every? odd? (nlist 1 2 3))
    120     (nnot-any? odd? (nlist 2 4 6))
    121     ;;; sets
    122     (nset-equal?
    123       (nlist->set (nlist 1 2 1 3 2 3))
    124       (nset 3 2 1))
    125     (nset? (nset 1 2 3))
    126     (nset? (nset 1 2 2 3))
    127     (nset-equal? (nset 2 1 3) (nset 1 2 2 3))
    128     (nset-in? 2 (nset 1 1 2 3))
    129     (nsubset? (nset 2 1 2) (nset 4 1 2 3 4))
    130     (nset-equal?
    131       (nset-add 0 (nset 1 2 3))
    132       (nset 0 1 2 3))
    133     (nset-equal?
    134       (nset-add 2 (nset 1 2 3))
    135       (nset 1 2 3))
    136     (nset-equal?
    137       (nset 0 1 1 0 2 3 2)
    138       (nset 2 3 0 1))
    139     (nset-equal?
    140       (nset-difference (nset 0 2 1 3) (nset 1 1))
    141       (nset 0 2 3))
    142     (nset-equal?
    143       (nset-union (nset 1 2) (nset 2 3) (nset 3 4))
    144       (nset 1 2 3 4))
    145     (nset-equal?
    146       (nset-intersection (nset 1 2 3 4) (nset 2 3 5) (nset 3 4))
    147       (nset 3))
    148     (nset-equal? (nsubset odd? (nset 2 1 3 3 1 1)) (nset 3 1))
    149     ))
    150 
    151 (define-test (strlists?)
    152   (check
    153     (define-list-type strlist
    154                       documentation: strlists
    155                       item-predicate: string?
    156                       item-equality: string=?)
    157     (strequal?
    158       (strappend (strlist "a" "b")
    159                  (strlist "c"))
    160       (strlist "a" "b" "c"))
    161     ))
    162 
    163 (define-test (symlists?)
    164   (check
    165     (define-list-type symlist
    166                       documentation: symlists
    167                       item-predicate: symbol?
    168                       item-equality: eq?)
    169     (symequal?
    170       (symappend (symlist 'a 'b)
    171                  (symlist 'c))
    172       (symlist 'a 'b 'c))
    173     ))
    174 
    175 (define-test (llists?)
    176   (check
    177     (define-list-type llist
    178                       documentation: llists
    179                       item-predicate: list?
    180                       item-equality: equal?)
    181     (lequal?
    182       (lappend (llist '(a) '(b))
    183                (llist '(c)))
    184       (llist '(a) '(b) '(c)))
    185     ))
    186 
    187 (define-test (alists?)
    188   (check
    189     (define-list-type alist
    190                       documentation: alists
    191                       item-predicate: (lambda (x) #t)
    192                       item-equality: equal?)
    193     (define als (make-alist 3 (cell #f)))
    194     (alist? als)
     120    (list-equal? (list-sort <= (typed-list 2 0 1 4 3))
     121             (typed-list 0 1 2 3 4))
     122    (not (list-sorted? <= (typed-list 2 0 1 4 3)))
     123    (list-sorted? <= (typed-list 0 1 2 3 4))
     124    (list-every? odd? (typed-list 1 3 5))
     125    (list-every? odd? (typed-list))
     126    (= (list-some odd? (typed-list 2 3 5)) 3)
     127    (not (list-some odd? (typed-list 2 4 6)))
     128    (list-not-every? odd? (typed-list 1 2 3))
     129    (list-not-any? odd? (typed-list 2 4 6))
     130    ))
     131
     132(define-test (any-lists?)
     133  (check
     134    ;; argument module
     135    (module any (type? equ?)
     136      (import scheme)
     137      (define (type? x) #t)
     138      (define (equ? x y) (equal? x y))
     139      )
     140    ;; apply functor
     141    (module any-lists = (typed-lists any))
     142    ;; import
     143    (import (prefix any-lists a) cells)
     144    (define als (alist-repeat 3 (cell #f)))
     145    (atyped-list? als)
    195146    (not (list? als))
    196     (= (alength als) 3)
    197     (equal? (alist->list (amap cell-ref als)) (make-list 3))
    198     (define alst (alist (lambda (x) #f) 'a "x" (cell 3) #\z))
    199     (procedure? (acar alst))
    200     (aequal? (amemp cell? alst)
    201                   (alist (cell 3) #\z))
    202     (aequal? (amember #\z alst)
    203              (acons #\z (anull)))
    204     ))
    205 
    206 (define-test (plists?)
    207   (check
    208     (define-list-type nsplist
    209                       documentation: plists
    210                       item-predicate: (lambda (pair)
    211                                         (and (pair? pair)
    212                                              (number? (car pair))
    213                                              (string? (cdr pair))))
    214                       item-equality: equal?
    215                       procedure-prefix: nsp)
    216     (define nspl (nsplist (cons 1 "one") (cons 2 "two") (cons 3 "three")))
    217     (equal? (nspassoc 2 nspl) '(2 . "two"))
    218     (not (nspassp zero? nspl))
     147    (= (alist-length als) 3)
     148    (equal? (atyped-list->untyped-list (alist-map cell-ref als))
     149            (make-list 3))
     150    (define alst (atyped-list (lambda (x) #f) 'a "x" (cell 3) #\z))
     151    (procedure? (alist-first alst))
     152    (alist-equal? (alist-memp cell? alst)
     153                  (atyped-list (cell 3) #\z))
     154    (alist-equal? (alist-member #\z alst)
     155             (alist-cons #\z (alist-null)))
     156    ))
     157
     158(define-test (sets?)
     159  (check
     160;    ;; argument module
     161;    (module any (type? equ?)
     162;      (import scheme)
     163;      (define (type? x) #t)
     164;      (define (equ? x y) (equal? x y))
     165;      )
     166;    ;; apply functor
     167;    (module any-lists = (typed-lists any))
     168;    ;; import
     169;    (import any-lists)
     170    (aset=
     171      (atyped-list->set (atyped-list 1 2 1 3 2 3))
     172      (aset 3 2 1))
     173    (aset? (aset 1 2 3))
     174    (aset? (aset 1 2 2 3))
     175    (aset= (aset 2 1 3) (aset 1 2 2 3))
     176    (aset-in? 2 (aset 1 1 2 3))
     177    (aset<= (aset 2 1 2) (aset 4 1 2 3 4))
     178    (aset=
     179      (aset-add 0 (aset 1 2 3))
     180      (aset 0 1 2 3))
     181    (aset=
     182      (aset-add 2 (aset 1 2 3))
     183      (aset 1 2 3))
     184    (= (aset-cardinality (aset 2 1 2 3 2)) 3)
     185    (aset=
     186      (aset-remove 2 (aset 2 1 2 3 2))
     187      (aset 1 3))
     188    (aset=
     189      (aset 0 1 1 0 2 3 2)
     190      (aset 2 3 0 1))
     191    (aset=
     192      (aset-difference (aset 0 2 1 3) (aset 1 1))
     193      (aset 0 2 3))
     194    (aset=
     195      (aset-union (aset 1 2) (aset 2 3) (aset 3 4))
     196      (aset 1 2 3 4))
     197    (aset=
     198      (aset-intersection (aset 1 2 3 4) (aset 2 3 5) (aset 3 4))
     199      (aset 3))
     200    (aset= (aset-filter odd? (aset 2 1 3 3 1 1)) (aset 3 1))
     201    ))
     202
     203
     204(define-test (string-lists?)
     205  (check
     206    (module strings (equ? type?)
     207      (import scheme)
     208      (define equ? string=?)
     209      (define type? string?))
     210    (module string-lists = (typed-lists strings))
     211    (import (prefix string-lists str-))
     212    (str-list-equal?
     213      (str-list-append (str-typed-list "a" "b")
     214                   (str-typed-list "c"))
     215      (str-typed-list "a" "b" "c"))
     216    ))
     217
     218(define-test (symbol-lists?)
     219  (check
     220    (module symbols (equ? type?)
     221      (import scheme)
     222      (define equ? eq?)
     223      (define type? symbol?))
     224    (module symbol-lists = (typed-lists symbols))
     225    (import (prefix symbol-lists sym-))
     226    (sym-list-equal?
     227      (sym-list-append (sym-typed-list 'a 'b)
     228                   (sym-typed-list 'c))
     229      (sym-typed-list 'a 'b 'c))
     230    (equal?
     231      (sym-list-bind (x y z) (sym-typed-list 'a 'b 'c) (list x y z))
     232      '(a b c))
     233    (sym-list-equal?
     234        (sym-list-bind (x . y) (sym-typed-list 'a 'b 'c) y)
     235      (sym-typed-list 'b 'c))
     236    (sym-list-null? (sym-list-bind x (sym-list-null) x))
     237    (sym-list-bind () (sym-list-null) #t)
     238    ))
     239
     240(define-test (list-lists?)
     241  (check
     242    (module lists (equ? type?)
     243      (import scheme
     244              (only data-structures list-of?)
     245              (only chicken condition-case))
     246      (define equ? equal?)
     247      (define type? (list-of? symbol?)));list?))
     248    (module list-lists = (typed-lists lists))
     249    (import (prefix list-lists l))
     250    (not (condition-case (llist-cons '(1) (llist-null))
     251           ((exn) #f)))
     252    (llist-equal?
     253      (llist-append
     254        (ltyped-list '(a) '(b))
     255        (ltyped-list '(c)))
     256      (ltyped-list '(a) '(b) '(c)))
     257    ))
     258
     259(define-test (pair-lists?)
     260  (check
     261    (module pairs (type? equ?)
     262      (import scheme)
     263      (define (type? x)
     264        (and (pair? x) (number? (car x)) (string? (cdr x))))
     265      (define equ? equal?))
     266    (module pair-lists = (typed-lists pairs))
     267    (import (prefix pair-lists nsp-))
     268    (define nspl (nsp-typed-list (cons 1 "one") (cons 2 "two") (cons 3 "three")))
     269    (equal? (nsp-list-assoc 2 nspl) '(2 . "two"))
     270    (not (nsp-list-assp zero? nspl))
    219271    ))
    220272
     
    222274(compound-test (TYPED-LISTS)
    223275  (number-lists?)
    224   (strlists?)
    225   (symlists?)
    226   (llists?)
    227   (alists?)
    228   (plists?)
     276  (any-lists?)
     277  (sets?)
     278  (string-lists?)
     279  (symbol-lists?)
     280  (list-lists?)
     281  (pair-lists?)
    229282  )
  • release/4/typed-lists/tags/1.0/typed-lists.meta

    r31192 r31219  
    55 (license "BSD")
    66 (depends datatype)
    7  (test-depends simple-tests cells)
     7 (test-depends simple-tests cells datatype)
    88 (author "Juergen Lorenz")
    99 (files "typed-lists.setup" "typed-lists.release-info" "typed-lists.meta" "typed-lists.scm" "tests/run.scm"))
  • release/4/typed-lists/tags/1.0/typed-lists.scm

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

    r31192 r31219  
    77 'typed-lists
    88 '("typed-lists.so" "typed-lists.import.so")
    9  '((version "0.1")))
     9 '((version "1.0")))
    1010
  • release/4/typed-lists/trunk/tests/run.scm

    r31192 r31219  
    1 (require-library typed-lists cells simple-tests)
    2 (import typed-lists simple-tests cells)
     1(require-library cells simple-tests datatype)
     2(import typed-lists simple-tests datatype)
    33
    44(define-test (number-lists?)
    55  (check
    6     (define-list-type nlist
    7                       documentation: nlists
    8                       item-predicate: (lambda (x)
    9                                         (or (number? x)
    10                                             ((cell-of? number?) x)))
    11                       item-equality: (lambda (x y)
    12                                        (or (and (number? x)
    13                                                 (number? y)
    14                                                 (= x y))
    15                                            (and (cell? x)
    16                                                 (cell? y)
    17                                                 (= (cell-ref x)
    18                                                    (cell-ref y))))))
    19 
    20     (define nnil (nnull))
    21     (nlist? nnil)
    22     (nnull? nnil)
    23     (not (null? nnil))
    24     (define nls (ncons 1 nnil))
    25     (nlist? nls)
     6    ;; argument module
     7    (module nums (type? equ?)
     8      (import scheme cells)
     9      (define (type? x)
     10        (or (number? x) ((cell-of? number?) x)))
     11      (define (equ? x y)
     12        (or (and (number? x)
     13                 (number? y)
     14                 (= x y))
     15            (and (cell? x)
     16                 (cell? y)
     17                 (= (cell-ref x)
     18                    (cell-ref y)))))
     19      )
     20
     21    ;; apply functor
     22    (module lists = (typed-lists nums))
     23   
     24    ;; import
     25    (import lists cells)
     26
     27    (define nil (list-null))
     28    (typed-list? nil)
     29    (list-null? nil)
     30    (not (null? nil))
     31    (define nls (list-cons 1 nil))
     32    (typed-list? nls)
    2633    nls
    27     (define nlst (nlist 0 1 (cell 2) 3 4))
    28     (nlist? nlst)
     34    (define nlst (typed-list 0 1 (cell 2) 3 4))
     35    (typed-list? nlst)
    2936    (not (list? nlst))
    3037    nlst
    31     (= (napply + 1 2 (nlist 3 4 5)) 15)
    32     (nequal? (nrepeat 5 0) (nlist 0 0 0 0 0))
    33     (nequal? (niterate-times 5 add1 0) (nlist 0 1 2 3 4))
    34     (nequal? (niterate-while (lambda (x) (< x 5)) add1 0)
    35              (nlist 0 1 2 3 4))
    36     (nequal? (niterate-until (lambda (x) (= x 5)) add1 0)
    37              (nlist 0 1 2 3 4))
    38     (nequal? (nzip (nlist 1 2 3 4 5) (nlist 10 20 30))
    39              (nlist 1 10 2 20 3 30 4 5))
    40     (nequal? (ninterpose 10 (nlist 1 2 3 4 5))
    41              (nlist 1 10 2 10 3 10 4 10 5))
    42     (nequal? (ncdddr nlst) (nlist 3 4))
    43     (= (ncadddr nlst) 3)
    44     (nequal? (ndrop 3 nlst) (nlist 3 4))
    45     (nequal? (ndrop-while odd? (nlist 1 3 2 4 5))
    46              (nlist 2 4 5))
    47     (nequal? (ntake-while odd? (nlist 1 3 2 4 5))
    48              (nlist 1 3))
    49     (receive (head tail) (nsplit-with even? (nlist 1 3 2 4 5))
    50       (and (nequal? head (nlist 1 3))
    51            (nequal? tail (nlist 2 4 5))))
    52     (nequal? (ntake 2 nlst) (nlist 0 1))
    53     (define nrest (ncdr nlst))
     38    (= (list-apply + 1 2 (typed-list 3 4 5)) 15)
     39    (list-equal? (list-repeat 5 0) (typed-list 0 0 0 0 0))
     40    (list-equal? (list-iterate 5 add1 0) (typed-list 0 1 2 3 4))
     41    (list-equal? (list-iterate-while (lambda (x) (< x 5)) add1 0)
     42             (typed-list 0 1 2 3 4))
     43    (list-equal? (list-iterate-until (lambda (x) (= x 5)) add1 0)
     44             (typed-list 0 1 2 3 4))
     45    (list-equal? (list-zip (typed-list 1 2 3 4 5) (typed-list 10 20 30))
     46             (typed-list 1 10 2 20 3 30 4 5))
     47    (list-equal? (list-interpose 10 (typed-list 1 2 3 4 5))
     48             (typed-list 1 10 2 10 3 10 4 10 5))
     49    (list-equal? (list-drop 3 nlst) (typed-list 3 4))
     50    (list-equal? (list-drop-while odd? (typed-list 1 3 2 4 5))
     51             (typed-list 2 4 5))
     52    (list-equal? (list-take-while odd? (typed-list 1 3 2 4 5))
     53             (typed-list 1 3))
     54    (receive (head tail) (list-split-with even? (typed-list 1 3 2 4 5))
     55      (and (list-equal? head (typed-list 1 3))
     56           (list-equal? tail (typed-list 2 4 5))))
     57    (list-equal? (list-take 2 nlst) (typed-list 0 1))
     58    (define nrest (list-rest nlst))
    5459    nrest
    55     (nlist? (nnull))
    56     (nnull? (nnull))
    57     (not (nnull? nls))
    58     (not (nlist? '(1 2)))
    59     (nnull? (ncdr nls))
    60     (= (ncar nlst) 0)
    61     (nlist? (nreverse nlst))
    62     (nreverse nlst)
    63     (equal? (nlist->list nlst)
     60    (typed-list? (list-null))
     61    (list-null? (list-null))
     62    (not (list-null? nls))
     63    (not (typed-list? '(1 2)))
     64    (list-null? (list-rest nls))
     65    (= (list-first nlst) 0)
     66    (typed-list? (list-reverse nlst))
     67    (list-reverse nlst)
     68    (equal? (typed-list->untyped-list nlst)
    6469            (list 0 1 (cell 2) 3 4))
    65     (equal? (nref 2 nlst) (cell 2))
    66     (cell-set! (nref 2 nlst) 20)
    67     (equal? (nref 2 nlst) (cell 20))
    68     (= (cell-ref (nref 2 nlst)) 20)
    69     (= (nlength nlst) 5)
    70     (nequal? (nsublist 2 4 nlst)
    71              (nlist (cell 20) 3))
    72     (nequal?  (nappend (nlist 0 1 2 3)
    73                        (nlist 4 5 6))
    74               (nlist 0 1 2 3 4 5 6))
    75     (nequal? (nappend (nlist 0)
    76                       (nlist 1)
    77                       (nlist 2)
    78                       (nlist 3 4)
    79                       (nlist 5 6 7)
    80                       (nlist 8))
    81              (nlist 0 1 2 3 4 5 6 7 8))
    82     (nequal? (nmap add1
    83                    (nlist 0 1 2 3))
    84              (nlist 1 2 3 4))
    85     (nequal? (nmap +
    86                    (nlist 1 2 3)
    87                    (nlist 10 20 30 40))
    88              (nlist 11 22 33))
    89     (nequal?
    90       (nmappend nlist (nlist 10 20 30) (nlist 1 2 3 4 5))
    91       (nlist 10 1 20 2 30 3))
    92     (nequal?
    93       (nfold-right ncons (nnull) (nlist 0 1 2 3 4))
    94       (nlist 0 1 2 3 4))
    95     (nequal? (nfold-right ncons (nnull) (nlist 0 1 2 3 4))
    96              (nlist 0 1 2 3 4))
    97     (= (nfold-left + 0 (nlist 1 2 3) (nlist 10 20 30)) 66)
    98     (equal? (nfold-left cons '(100) (nlist 1 2 3 4))
     70    (equal? (list-item 2 nlst) (cell 2))
     71    (cell-set! (list-item 2 nlst) 20)
     72    (equal? (list-item 2 nlst) (cell 20))
     73    (= (cell-ref (list-item 2 nlst)) 20)
     74    (= (list-length nlst) 5)
     75    (list-equal? (list-from-upto 2 4 nlst)
     76             (typed-list (cell 20) 3))
     77    (list-equal?  (list-append (typed-list 0 1 2 3)
     78                       (typed-list 4 5 6))
     79              (typed-list 0 1 2 3 4 5 6))
     80    (list-equal? (list-append
     81                   (typed-list 0)
     82                   (typed-list 1)
     83                   (typed-list 2)
     84                   (typed-list 3 4)
     85                   (typed-list 5 6 7)
     86                   (typed-list 8))
     87             (typed-list 0 1 2 3 4 5 6 7 8))
     88    (list-equal? (list-map add1
     89                   (typed-list 0 1 2 3))
     90             (typed-list 1 2 3 4))
     91    (list-equal? (list-map +
     92                   (typed-list 1 2 3)
     93                   (typed-list 10 20 30 40))
     94             (typed-list 11 22 33))
     95    (list-equal?
     96      (list-mappend typed-list (typed-list 10 20 30) (typed-list 1 2 3 4 5))
     97      (typed-list 10 1 20 2 30 3))
     98    (list-equal?
     99      (list-fold-right list-cons (list-null) (typed-list 0 1 2 3 4))
     100      (typed-list 0 1 2 3 4))
     101    (list-equal?
     102      (list-fold-right list-cons (typed-list 0 1 2) (typed-list 3 4))
     103      (typed-list 3 4 0 1 2))
     104    (= (list-fold-right * 1 (typed-list 1 2 3 4 5)) 120)
     105    (= (list-fold-left * 1 (typed-list 1 2 3 4 5)) 120)
     106    (= (list-fold-left + 0 (typed-list 1 2 3) (typed-list 10 20 30)) 66)
     107    (equal? (list-fold-left cons '(100) (typed-list 1 2 3 4))
    99108            '(((((100) . 1) . 2) . 3) . 4))
    100109    (equal?
    101110      (call-with-values
    102         (lambda () (nreverse* (nlist 1 2 3) (nlist 10 20 30)))
     111        (lambda () (list-reverse (typed-list 1 2 3) (typed-list 10 20 30)))
    103112        list)
    104       (list (nlist 3 2 1) (nlist 30 20 10)))
    105     (nequal? (nremove 0 (nlist 1 0 2 0 3 0 4))
    106              (nlist 1 2 3 4))
    107     (nequal? (nmerge < (nlist 2 4 5 7 8) (nlist 1 3 6 9 10))
    108              (nlist 1 2 3 4 5 6 7 8 9 10))
    109     (not (condition-case (nmerge < (nnull) (nlist 1 3 2))
     113      (list (typed-list 3 2 1) (typed-list 30 20 10)))
     114    (list-equal? (list-remove 0 (typed-list 1 0 2 0 3 0 4))
     115             (typed-list 1 2 3 4))
     116    (list-equal? (list-merge < (typed-list 2 4 5 7 8) (typed-list 1 3 6 9 10))
     117             (typed-list 1 2 3 4 5 6 7 8 9 10))
     118    (not (condition-case (list-merge < (list-null) (typed-list 1 3 2))
    110119           ((exn) #f)))
    111     (nequal? (nsort <= (nlist 2 0 1 4 3))
    112              (nlist 0 1 2 3 4))
    113     (not (nsorted? <= (nlist 2 0 1 4 3)))
    114     (nsorted? <= (nlist 0 1 2 3 4))
    115     (nevery? odd? (nlist 1 3 5))
    116     (nevery? odd? (nlist))
    117     (= (nsome odd? (nlist 2 3 5)) 3)
    118     (not (nsome odd? (nlist 2 4 6)))
    119     (nnot-every? odd? (nlist 1 2 3))
    120     (nnot-any? odd? (nlist 2 4 6))
    121     ;;; sets
    122     (nset-equal?
    123       (nlist->set (nlist 1 2 1 3 2 3))
    124       (nset 3 2 1))
    125     (nset? (nset 1 2 3))
    126     (nset? (nset 1 2 2 3))
    127     (nset-equal? (nset 2 1 3) (nset 1 2 2 3))
    128     (nset-in? 2 (nset 1 1 2 3))
    129     (nsubset? (nset 2 1 2) (nset 4 1 2 3 4))
    130     (nset-equal?
    131       (nset-add 0 (nset 1 2 3))
    132       (nset 0 1 2 3))
    133     (nset-equal?
    134       (nset-add 2 (nset 1 2 3))
    135       (nset 1 2 3))
    136     (nset-equal?
    137       (nset 0 1 1 0 2 3 2)
    138       (nset 2 3 0 1))
    139     (nset-equal?
    140       (nset-difference (nset 0 2 1 3) (nset 1 1))
    141       (nset 0 2 3))
    142     (nset-equal?
    143       (nset-union (nset 1 2) (nset 2 3) (nset 3 4))
    144       (nset 1 2 3 4))
    145     (nset-equal?
    146       (nset-intersection (nset 1 2 3 4) (nset 2 3 5) (nset 3 4))
    147       (nset 3))
    148     (nset-equal? (nsubset odd? (nset 2 1 3 3 1 1)) (nset 3 1))
    149     ))
    150 
    151 (define-test (strlists?)
    152   (check
    153     (define-list-type strlist
    154                       documentation: strlists
    155                       item-predicate: string?
    156                       item-equality: string=?)
    157     (strequal?
    158       (strappend (strlist "a" "b")
    159                  (strlist "c"))
    160       (strlist "a" "b" "c"))
    161     ))
    162 
    163 (define-test (symlists?)
    164   (check
    165     (define-list-type symlist
    166                       documentation: symlists
    167                       item-predicate: symbol?
    168                       item-equality: eq?)
    169     (symequal?
    170       (symappend (symlist 'a 'b)
    171                  (symlist 'c))
    172       (symlist 'a 'b 'c))
    173     ))
    174 
    175 (define-test (llists?)
    176   (check
    177     (define-list-type llist
    178                       documentation: llists
    179                       item-predicate: list?
    180                       item-equality: equal?)
    181     (lequal?
    182       (lappend (llist '(a) '(b))
    183                (llist '(c)))
    184       (llist '(a) '(b) '(c)))
    185     ))
    186 
    187 (define-test (alists?)
    188   (check
    189     (define-list-type alist
    190                       documentation: alists
    191                       item-predicate: (lambda (x) #t)
    192                       item-equality: equal?)
    193     (define als (make-alist 3 (cell #f)))
    194     (alist? als)
     120    (list-equal? (list-sort <= (typed-list 2 0 1 4 3))
     121             (typed-list 0 1 2 3 4))
     122    (not (list-sorted? <= (typed-list 2 0 1 4 3)))
     123    (list-sorted? <= (typed-list 0 1 2 3 4))
     124    (list-every? odd? (typed-list 1 3 5))
     125    (list-every? odd? (typed-list))
     126    (= (list-some odd? (typed-list 2 3 5)) 3)
     127    (not (list-some odd? (typed-list 2 4 6)))
     128    (list-not-every? odd? (typed-list 1 2 3))
     129    (list-not-any? odd? (typed-list 2 4 6))
     130    ))
     131
     132(define-test (any-lists?)
     133  (check
     134    ;; argument module
     135    (module any (type? equ?)
     136      (import scheme)
     137      (define (type? x) #t)
     138      (define (equ? x y) (equal? x y))
     139      )
     140    ;; apply functor
     141    (module any-lists = (typed-lists any))
     142    ;; import
     143    (import (prefix any-lists a) cells)
     144    (define als (alist-repeat 3 (cell #f)))
     145    (atyped-list? als)
    195146    (not (list? als))
    196     (= (alength als) 3)
    197     (equal? (alist->list (amap cell-ref als)) (make-list 3))
    198     (define alst (alist (lambda (x) #f) 'a "x" (cell 3) #\z))
    199     (procedure? (acar alst))
    200     (aequal? (amemp cell? alst)
    201                   (alist (cell 3) #\z))
    202     (aequal? (amember #\z alst)
    203              (acons #\z (anull)))
    204     ))
    205 
    206 (define-test (plists?)
    207   (check
    208     (define-list-type nsplist
    209                       documentation: plists
    210                       item-predicate: (lambda (pair)
    211                                         (and (pair? pair)
    212                                              (number? (car pair))
    213                                              (string? (cdr pair))))
    214                       item-equality: equal?
    215                       procedure-prefix: nsp)
    216     (define nspl (nsplist (cons 1 "one") (cons 2 "two") (cons 3 "three")))
    217     (equal? (nspassoc 2 nspl) '(2 . "two"))
    218     (not (nspassp zero? nspl))
     147    (= (alist-length als) 3)
     148    (equal? (atyped-list->untyped-list (alist-map cell-ref als))
     149            (make-list 3))
     150    (define alst (atyped-list (lambda (x) #f) 'a "x" (cell 3) #\z))
     151    (procedure? (alist-first alst))
     152    (alist-equal? (alist-memp cell? alst)
     153                  (atyped-list (cell 3) #\z))
     154    (alist-equal? (alist-member #\z alst)
     155             (alist-cons #\z (alist-null)))
     156    ))
     157
     158(define-test (sets?)
     159  (check
     160;    ;; argument module
     161;    (module any (type? equ?)
     162;      (import scheme)
     163;      (define (type? x) #t)
     164;      (define (equ? x y) (equal? x y))
     165;      )
     166;    ;; apply functor
     167;    (module any-lists = (typed-lists any))
     168;    ;; import
     169;    (import any-lists)
     170    (aset=
     171      (atyped-list->set (atyped-list 1 2 1 3 2 3))
     172      (aset 3 2 1))
     173    (aset? (aset 1 2 3))
     174    (aset? (aset 1 2 2 3))
     175    (aset= (aset 2 1 3) (aset 1 2 2 3))
     176    (aset-in? 2 (aset 1 1 2 3))
     177    (aset<= (aset 2 1 2) (aset 4 1 2 3 4))
     178    (aset=
     179      (aset-add 0 (aset 1 2 3))
     180      (aset 0 1 2 3))
     181    (aset=
     182      (aset-add 2 (aset 1 2 3))
     183      (aset 1 2 3))
     184    (= (aset-cardinality (aset 2 1 2 3 2)) 3)
     185    (aset=
     186      (aset-remove 2 (aset 2 1 2 3 2))
     187      (aset 1 3))
     188    (aset=
     189      (aset 0 1 1 0 2 3 2)
     190      (aset 2 3 0 1))
     191    (aset=
     192      (aset-difference (aset 0 2 1 3) (aset 1 1))
     193      (aset 0 2 3))
     194    (aset=
     195      (aset-union (aset 1 2) (aset 2 3) (aset 3 4))
     196      (aset 1 2 3 4))
     197    (aset=
     198      (aset-intersection (aset 1 2 3 4) (aset 2 3 5) (aset 3 4))
     199      (aset 3))
     200    (aset= (aset-filter odd? (aset 2 1 3 3 1 1)) (aset 3 1))
     201    ))
     202
     203
     204(define-test (string-lists?)
     205  (check
     206    (module strings (equ? type?)
     207      (import scheme)
     208      (define equ? string=?)
     209      (define type? string?))
     210    (module string-lists = (typed-lists strings))
     211    (import (prefix string-lists str-))
     212    (str-list-equal?
     213      (str-list-append (str-typed-list "a" "b")
     214                   (str-typed-list "c"))
     215      (str-typed-list "a" "b" "c"))
     216    ))
     217
     218(define-test (symbol-lists?)
     219  (check
     220    (module symbols (equ? type?)
     221      (import scheme)
     222      (define equ? eq?)
     223      (define type? symbol?))
     224    (module symbol-lists = (typed-lists symbols))
     225    (import (prefix symbol-lists sym-))
     226    (sym-list-equal?
     227      (sym-list-append (sym-typed-list 'a 'b)
     228                   (sym-typed-list 'c))
     229      (sym-typed-list 'a 'b 'c))
     230    (equal?
     231      (sym-list-bind (x y z) (sym-typed-list 'a 'b 'c) (list x y z))
     232      '(a b c))
     233    (sym-list-equal?
     234        (sym-list-bind (x . y) (sym-typed-list 'a 'b 'c) y)
     235      (sym-typed-list 'b 'c))
     236    (sym-list-null? (sym-list-bind x (sym-list-null) x))
     237    (sym-list-bind () (sym-list-null) #t)
     238    ))
     239
     240(define-test (list-lists?)
     241  (check
     242    (module lists (equ? type?)
     243      (import scheme
     244              (only data-structures list-of?)
     245              (only chicken condition-case))
     246      (define equ? equal?)
     247      (define type? (list-of? symbol?)));list?))
     248    (module list-lists = (typed-lists lists))
     249    (import (prefix list-lists l))
     250    (not (condition-case (llist-cons '(1) (llist-null))
     251           ((exn) #f)))
     252    (llist-equal?
     253      (llist-append
     254        (ltyped-list '(a) '(b))
     255        (ltyped-list '(c)))
     256      (ltyped-list '(a) '(b) '(c)))
     257    ))
     258
     259(define-test (pair-lists?)
     260  (check
     261    (module pairs (type? equ?)
     262      (import scheme)
     263      (define (type? x)
     264        (and (pair? x) (number? (car x)) (string? (cdr x))))
     265      (define equ? equal?))
     266    (module pair-lists = (typed-lists pairs))
     267    (import (prefix pair-lists nsp-))
     268    (define nspl (nsp-typed-list (cons 1 "one") (cons 2 "two") (cons 3 "three")))
     269    (equal? (nsp-list-assoc 2 nspl) '(2 . "two"))
     270    (not (nsp-list-assp zero? nspl))
    219271    ))
    220272
     
    222274(compound-test (TYPED-LISTS)
    223275  (number-lists?)
    224   (strlists?)
    225   (symlists?)
    226   (llists?)
    227   (alists?)
    228   (plists?)
     276  (any-lists?)
     277  (sets?)
     278  (string-lists?)
     279  (symbol-lists?)
     280  (list-lists?)
     281  (pair-lists?)
    229282  )
  • release/4/typed-lists/trunk/typed-lists.meta

    r31192 r31219  
    55 (license "BSD")
    66 (depends datatype)
    7  (test-depends simple-tests cells)
     7 (test-depends simple-tests cells datatype)
    88 (author "Juergen Lorenz")
    99 (files "typed-lists.setup" "typed-lists.release-info" "typed-lists.meta" "typed-lists.scm" "tests/run.scm"))
  • release/4/typed-lists/trunk/typed-lists.scm

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

    r31192 r31219  
    77 'typed-lists
    88 '("typed-lists.so" "typed-lists.import.so")
    9  '((version "0.1")))
     9 '((version "1.0")))
    1010
Note: See TracChangeset for help on using the changeset viewer.