Changeset 31337 in project


Ignore:
Timestamp:
09/06/14 15:59:19 (5 years ago)
Author:
juergen
Message:

typed-lists 2.0 with additional modules and changed symbol names

Location:
release/4/typed-lists
Files:
4 added
3 edited
5 copied

Legend:

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

    r31264 r31337  
    1 (require-library cells simple-tests datatype)
    2 (import typed-lists typed-sets simple-tests datatype)
    3 
    4 (define-test (number-lists?)
    5   (check
    6     ;; argument module
    7     (module numbers (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 numbers))
    23    
    24     ;; import
    25     (import lists cells)
    26 
    27     (define nil (list-null))
    28     (typed-list? nil)
    29     (list-null? nil)
     1(require-library cells simple-tests datatype typed-lists)
     2(import list-functor set-functor simple-tests datatype)
     3
     4;;;;;; test untyped modules
     5
     6(define-test (immutable-lists?)
     7  (check
     8    (import cells
     9            immutable-lists)
     10    (define nil (ilist-null))
     11    (ilist? nil)
     12    (ilist-null? nil)
    3013    (not (null? nil))
    31     (define nls (list-cons 1 nil))
    32     (typed-list? nls)
     14    (define nls (ilist-cons 1 nil))
     15    (ilist? nls)
    3316    nls
    34     (define nlst (typed-list 0 1 (cell 2) 3 4))
    35     (typed-list? nlst)
     17    (define nlst (ilist 0 1 (cell 2) 3 4))
     18    (ilist? nlst)
    3619    (not (list? nlst))
    3720    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))
     21    (= (ilist-apply + 1 2 (ilist 3 4 5)) 15)
     22    (ilist-equal? (ilist-repeat 5 0) (ilist 0 0 0 0 0))
     23    (ilist-equal? (ilist-iterate 5 add1 0) (ilist 0 1 2 3 4))
     24    (ilist-equal? (ilist-iterate-while (lambda (x) (< x 5)) add1 0)
     25                  (ilist 0 1 2 3 4))
     26    (ilist-equal? (ilist-iterate-until (lambda (x) (= x 5)) add1 0)
     27                  (ilist 0 1 2 3 4))
     28    (ilist-equal? (ilist-zip (ilist 1 2 3 4 5) (ilist 10 20 30))
     29                  (ilist 1 10 2 20 3 30 4 5))
     30    (ilist-equal? (ilist-interpose 10 (ilist 1 2 3 4 5))
     31                  (ilist 1 10 2 10 3 10 4 10 5))
     32    (ilist-equal? (ilist-drop 3 nlst) (ilist 3 4))
     33    (ilist-equal? (ilist-drop-while odd? (ilist 1 3 2 4 5))
     34             (ilist 2 4 5))
     35    (ilist-equal? (ilist-take-while odd? (ilist 1 3 2 4 5))
     36                  (ilist 1 3))
     37    (receive (head tail) (ilist-split-with even? (ilist 1 3 2 4 5))
     38      (and (ilist-equal? head (ilist 1 3))
     39           (ilist-equal? tail (ilist 2 4 5))))
     40    (ilist-equal? (ilist-take 2 nlst) (ilist 0 1))
     41    (define nrest (ilist-rest nlst))
    5942    nrest
    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)
     43    (ilist? (ilist-null))
     44    (ilist-null? (ilist-null))
     45    (not (ilist-null? nls))
     46    (not (ilist? '(1 2)))
     47    (ilist-null? (ilist-rest nls))
     48    (= (ilist-first nlst) 0)
     49    (ilist? (ilist-reverse nlst))
     50    (ilist-reverse nlst)
     51    (equal? (ilist->list nlst)
    6952            (list 0 1 (cell 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))
     53    (equal? (ilist-item 2 nlst) (cell 2))
     54    (cell-set! (ilist-item 2 nlst) 20)
     55    (equal? (ilist-item 2 nlst) (cell 20))
     56    (= (cell-ref (ilist-item 2 nlst)) 20)
     57    (= (ilist-length nlst) 5)
     58    (ilist-equal? (ilist-from-upto 2 4 nlst)
     59                  (ilist (cell 20) 3))
     60    (ilist-equal?  (ilist-append (ilist 0 1 2 3)
     61                                 (ilist 4 5 6))
     62                   (ilist 0 1 2 3 4 5 6))
     63    (ilist-equal? (ilist-append
     64                    (ilist 0)
     65                    (ilist 1)
     66                    (ilist 2)
     67                    (ilist 3 4)
     68                    (ilist 5 6 7)
     69                    (ilist 8))
     70                  (ilist 0 1 2 3 4 5 6 7 8))
     71    (ilist-equal? (ilist-map add1
     72                             (ilist 0 1 2 3))
     73                  (ilist 1 2 3 4))
     74    (ilist-equal? (ilist-map +
     75                             (ilist 1 2 3)
     76                             (ilist 10 20 30 40))
     77                  (ilist 11 22 33))
     78    (ilist-equal?
     79      (ilist-mappend ilist (ilist 10 20 30) (ilist 1 2 3 4 5))
     80      (ilist 10 1 20 2 30 3))
     81    (ilist-equal?
     82      (ilist-fold-right ilist-cons (ilist-null) (ilist 0 1 2 3 4))
     83      (ilist 0 1 2 3 4))
     84    (ilist-equal?
     85      (ilist-fold-right ilist-cons (ilist 0 1 2) (ilist 3 4))
     86      (ilist 3 4 0 1 2))
     87    (= (ilist-fold-right * 1 (ilist 1 2 3 4 5)) 120)
     88    (= (ilist-fold-left * 1 (ilist 1 2 3 4 5)) 120)
     89    (= (ilist-fold-left + 0 (ilist 1 2 3) (ilist 10 20 30)) 66)
     90    (equal? (ilist-fold-left cons '(100) (ilist 1 2 3 4))
    10891            '(((((100) . 1) . 2) . 3) . 4))
    10992    (equal?
    11093      (call-with-values
    111         (lambda () (list-reverse (typed-list 1 2 3) (typed-list 10 20 30)))
     94        (lambda () (ilist-reverse (ilist 1 2 3) (ilist 10 20 30)))
    11295        list)
    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))
     96      (list (ilist 3 2 1) (ilist 30 20 10)))
     97    (ilist-equal? (ilist-remove 0 (ilist 1 0 2 0 3 0 4))
     98                  (ilist 1 2 3 4))
     99    (ilist-equal? (ilist-merge < (ilist 2 4 5 7 8) (ilist 1 3 6 9 10))
     100                  (ilist 1 2 3 4 5 6 7 8 9 10))
     101    (not (condition-case (ilist-merge < (ilist-null) (ilist 1 3 2))
    119102           ((exn) #f)))
    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-equal?
    125       (list-cons-sorted <= 2 (typed-list 0 1 2 3 4))
    126       (typed-list 0 1 2 2 3 4))
    127     (list-equal?
    128       (list-cons-sorted <= 5 (typed-list 0 1 2 3 4))
    129       (typed-list 0 1 2 3 4 5))
    130     (list-every? odd? (typed-list 1 3 5))
    131     (list-every? odd? (typed-list))
    132     (= (list-some odd? (typed-list 2 3 5)) 3)
    133     (not (list-some odd? (typed-list 2 4 6)))
    134     (list-not-every? odd? (typed-list 1 2 3))
    135     (list-not-any? odd? (typed-list 2 4 6))
    136     (list-in? (typed-list 2 3) (typed-list 1 2 3))
    137     (not (list-in? (typed-list 1 2 3) (typed-list 2 3)))
    138     (not (list-in? (typed-list 1 2 3) (typed-list 2 1 3)))
    139     (list-in? (typed-list) (typed-list 2 3))
    140     ))
     103    (ilist-equal? (ilist-merge-sort <= (ilist 2 0 1 4 3))
     104                  (ilist 0 1 2 3 4))
     105    (ilist-equal? (ilist-insertion-sort < (ilist 2 0 1 4 3))
     106                  (ilist 0 1 2 3 4))
     107    (not (ilist-sorted? <= (ilist 2 0 1 4 3)))
     108    (ilist-sorted? <= (ilist 0 1 2 3 4))
     109    (ilist-equal?
     110      (ilist-insert-sorted <= 2 (ilist 0 1 2 3 4))
     111      (ilist 0 1 2 2 3 4))
     112    (ilist-equal?
     113      (ilist-insert-sorted <= 5 (ilist 0 1 2 3 4))
     114      (ilist 0 1 2 3 4 5))
     115    (ilist-every? odd? (ilist 1 3 5))
     116    (ilist-every? odd? (ilist))
     117    (= (ilist-some odd? (ilist 2 3 5)) 3)
     118    (not (ilist-some odd? (ilist 2 4 6)))
     119    (ilist-not-every? odd? (ilist 1 2 3))
     120    (ilist-not-any? odd? (ilist 2 4 6))
     121    (ilist-in? (ilist 2 3) (ilist 1 2 3))
     122    (not (ilist-in? (ilist 1 2 3) (ilist 2 3)))
     123    (not (ilist-in? (ilist 1 2 3) (ilist 2 1 3)))
     124    (ilist-in? (ilist) (ilist 2 3))
     125    ))
     126
     127(define-test (sets?)
     128  (check
     129    (import sets immutable-lists)
     130    (set=
     131      (ilist->set (ilist 1 2 1 3 2 3))
     132      (set 3 2 1))
     133    (set? (set 1 2 3))
     134    (set? (set 1 2 2 3))
     135    (set= (set 2 1 3) (set 1 2 2 3))
     136    (set-in? 2 (set 1 1 2 3))
     137    (set<= (set 2 1 2) (set 4 1 2 3 4))
     138    (set=
     139      (set-add 0 (set 1 2 3))
     140      (set 0 1 2 3))
     141    (set=
     142      (set-add 2 (set 1 2 3))
     143      (set 1 2 3))
     144    (= (set-cardinality (set 2 1 2 3 2)) 3)
     145    (set=
     146      (set-remove 2 (set 2 1 2 3 2))
     147      (set 1 3))
     148    (set=
     149      (set 0 1 1 0 2 3 2)
     150      (set 2 3 0 1))
     151    (set=
     152      (set-difference (set 0 2 1 3) (set 1 1))
     153      (set 0 2 3))
     154    (set=
     155      (set-union (set 1 2) (set 2 3) (set 3 4))
     156      (set 1 2 3 4))
     157    (set=
     158      (set-intersection (set 1 2 3 4) (set 2 3 5) (set 3 4))
     159      (set 3))
     160    (set= (set-filter odd? (set 2 1 3 3 1 1)) (set 3 1))
     161    ))
     162
     163;;;;;; test functors
    141164
    142165(define-test (any-lists?)
    143166  (check
    144167    ;; argument module
    145     (module any (type? equ?)
    146       (import scheme)
    147       (define (type? x) #t)
     168    (module any (item? equ?)
     169      (import scheme)
     170      (define (item? x) #t)
    148171      (define (equ? x y) (equal? x y))
    149172      )
    150173    ;; apply functor
    151     (module any-lists = (typed-lists any))
     174    (module any-lists = (list-functor any))
    152175    ;; import
    153     (import (prefix any-lists a) cells)
    154     (define als (alist-repeat 3 (cell #f)))
    155     (atyped-list? als)
     176    (import (prefix any-lists any-) cells)
     177    (define als (any-ilist-repeat 3 (cell #f)))
     178    (any-ilist? als)
    156179    (not (list? als))
    157     (= (alist-length als) 3)
    158     (equal? (atyped-list->untyped-list (alist-map cell-ref als))
     180    (= (any-ilist-length als) 3)
     181    (equal? (any-ilist->list (any-ilist-map cell-ref als))
    159182            (make-list 3))
    160     (define alst (atyped-list (lambda (x) #f) 'a "x" (cell 3) #\z))
    161     (procedure? (alist-first alst))
    162     (alist-equal? (alist-memp cell? alst)
    163                   (atyped-list (cell 3) #\z))
    164     (alist-equal? (alist-member #\z alst)
    165              (alist-cons #\z (alist-null)))
     183    (define alst (any-ilist (lambda (x) #f) 'a "x" (cell 3) #\z))
     184    (procedure? (any-ilist-first alst))
     185    (any-ilist-equal? (any-ilist-memp cell? alst)
     186                  (any-ilist (cell 3) #\z))
     187    (any-ilist-equal? (any-ilist-member #\z alst)
     188             (any-ilist-cons #\z (any-ilist-null)))
    166189    ))
    167190
     
    169192(define-test (string-lists?)
    170193  (check
    171     (module strings (equ? type?)
     194    (module strings (equ? item?)
    172195      (import scheme)
    173196      (define equ? string=?)
    174       (define type? string?))
    175     (module string-lists = (typed-lists strings))
     197      (define item? string?))
     198    (module string-lists = (list-functor strings))
    176199    (import (prefix string-lists str-))
    177     (str-list-equal?
    178       (str-list-append (str-typed-list "a" "b")
    179                    (str-typed-list "c"))
    180       (str-typed-list "a" "b" "c"))
     200    (str-ilist-equal?
     201      (str-ilist-append (str-ilist "a" "b")
     202                   (str-ilist "c"))
     203      (str-ilist "a" "b" "c"))
    181204    ))
    182205
    183206(define-test (symbol-lists?)
    184207  (check
    185     (module symbols (equ? type?)
     208    (module symbols (equ? item?)
    186209      (import scheme)
    187210      (define equ? eq?)
    188       (define type? symbol?))
    189     (module symbol-lists = (typed-lists symbols))
     211      (define item? symbol?))
     212    (module symbol-lists = (list-functor symbols))
    190213    (import (prefix symbol-lists sym-))
    191     (sym-list-equal?
    192       (sym-list-append (sym-typed-list 'a 'b)
    193                    (sym-typed-list 'c))
    194       (sym-typed-list 'a 'b 'c))
     214    (sym-ilist-equal?
     215      (sym-ilist-append (sym-ilist 'a 'b)
     216                   (sym-ilist 'c))
     217      (sym-ilist 'a 'b 'c))
    195218    (equal?
    196       (sym-list-bind (x y z) (sym-typed-list 'a 'b 'c) (list x y z))
     219      (sym-ilist-bind (x y z) (sym-ilist 'a 'b 'c) (list x y z))
    197220      '(a b c))
    198     (sym-list-equal?
    199         (sym-list-bind (x . y) (sym-typed-list 'a 'b 'c) y)
    200       (sym-typed-list 'b 'c))
     221    (sym-ilist-equal?
     222        (sym-ilist-bind (x . y) (sym-ilist 'a 'b 'c) y)
     223      (sym-ilist 'b 'c))
    201224    (xpr:val
    202       (sym-list-bind (x . y) (sym-typed-list 'a 'b) (list x y)))
    203     (sym-list-null? (sym-list-bind x (sym-list-null) x))
    204     (sym-list-bind () (sym-list-null) #t)
     225      (sym-ilist-bind (x . y) (sym-ilist 'a 'b) (list x y)))
     226    (sym-ilist-null? (sym-ilist-bind x (sym-ilist-null) x))
     227    (sym-ilist-bind () (sym-ilist-null) #t)
    205228    ))
    206229
    207230(define-test (list-lists?)
    208231  (check
    209     (module lists (equ? type?)
     232    (module lists (equ? item?)
    210233      (import scheme
    211234              (only data-structures list-of?)
    212235              (only chicken condition-case))
    213236      (define equ? equal?)
    214       (define type? (list-of? symbol?)));list?))
    215     (module list-lists = (typed-lists lists))
    216     (import (prefix list-lists l))
    217     (not (condition-case (llist-cons '(1) (llist-null))
     237      (define item? (list-of? symbol?)))
     238    (module list-lists = (list-functor lists))
     239    (import (prefix list-lists lst-))
     240    (not (condition-case (lst-ilist-cons '(1) (lst-ilist-null))
    218241           ((exn) #f)))
    219     (llist-equal?
    220       (llist-append
    221         (ltyped-list '(a) '(b))
    222         (ltyped-list '(c)))
    223       (ltyped-list '(a) '(b) '(c)))
     242    (lst-ilist-equal?
     243      (lst-ilist-append
     244        (lst-ilist '(a) '(b))
     245        (lst-ilist '(c)))
     246      (lst-ilist '(a) '(b) '(c)))
    224247    ))
    225248
    226249(define-test (pair-lists?)
    227250  (check
    228     (module pairs (type? equ?)
    229       (import scheme)
    230       (define (type? x)
     251    (module pairs (item? equ?)
     252      (import scheme)
     253      (define (item? x)
    231254        (and (pair? x) (number? (car x)) (string? (cdr x))))
    232255      (define equ? equal?))
    233     (module pair-lists = (typed-lists pairs))
     256    (module pair-lists = (list-functor pairs))
    234257    (import (prefix pair-lists nsp-))
    235     (define nspl (nsp-typed-list (cons 1 "one") (cons 2 "two") (cons 3 "three")))
    236     (equal? (nsp-list-assoc 2 nspl) '(2 . "two"))
    237     (not (nsp-list-assp zero? nspl))
    238     ))
    239 
    240 (define-test (sets?)
     258    (define nspl (nsp-ilist (cons 1 "one") (cons 2 "two") (cons 3 "three")))
     259    (equal? (nsp-ilist-assoc 2 nspl) '(2 . "two"))
     260    (not (nsp-ilist-assp zero? nspl))
     261    ))
     262
     263(define-test (num-sets?)
    241264  (check
    242265    ;; argument module
    243     (module nums (type? equ?)
    244       (import scheme)
    245       (define type? number?)
     266    (module nums (item? equ?)
     267      (import scheme)
     268      (define item? number?)
    246269      (define equ? =)
    247270      )
    248271    ;; apply functors
    249     (module num-lists = (typed-lists nums))
    250     (module num-sets = (typed-sets nums num-lists))
     272    (module num-lists = (list-functor nums))
     273    (module num-sets = (set-functor nums num-lists))
    251274    ;; import
    252275    (import (prefix num-lists num-)
    253276            (prefix num-sets num-))
    254277    (num-set=
    255       (num-typed-list->set (num-typed-list 1 2 1 3 2 3))
     278      (num-ilist->set (num-ilist 1 2 1 3 2 3))
    256279      (num-set 3 2 1))
    257280    (num-set? (num-set 1 2 3))
     
    287310
    288311(compound-test (TYPED-LISTS-AND-SETS)
    289   (number-lists?)
     312  (immutable-lists?)
     313  (sets?)
    290314  (any-lists?)
    291315  (string-lists?)
     
    293317  (list-lists?)
    294318  (pair-lists?)
    295   (sets?)
     319  (num-sets?)
    296320  )
  • release/4/typed-lists/tags/2.0/typed-lists.scm

    r31264 r31337  
    3737
    3838(define-interface LISTS
    39   (typed-lists typed-list? typed-list untyped-list->typed-list typed-list->untyped-list
    40    list-apply list-null list-null? list-cons list-first list-rest list-reverse
    41    list-length list-item list-map list-for-each list-append list-mappend
    42    list-from-upto list-split-at list-split-with list-equal? list-member
    43    list-memp list-remp list-remove list-remove-dups list-assp list-assoc
    44    list-filter list-fold-left list-fold-right list-merge list-sort
    45    list-sorted? list-cons-sorted
    46    list-drop list-drop-while list-take list-take-while list-repeat list-iterate
    47    list-iterate-while list-iterate-until list-zip list-interpose list-every?
    48    list-some list-not-every? list-not-any? list-in? list-bind))
     39  (ilists ilist? ilist list->ilist ilist->list
     40   ilist-apply ilist-null ilist-null? ilist-cons ilist-first ilist-rest ilist-reverse
     41   ilist-length ilist-item ilist-map ilist-for-each ilist-append ilist-mappend
     42   ilist-from-upto ilist-split-at ilist-split-with ilist-equal? ilist-member
     43   ilist-memp ilist-remp ilist-remove ilist-remove-dups ilist-assp ilist-assoc
     44   ilist-filter ilist-fold-left ilist-fold-right ilist-merge ilist-merge-sort
     45   ilist-insertion-sort ilist-sorted? ilist-insert-sorted
     46   ilist-drop ilist-drop-while ilist-take ilist-take-while ilist-repeat ilist-iterate
     47   ilist-iterate-while ilist-iterate-until ilist-zip ilist-interpose ilist-every?
     48   ilist-some ilist-not-every? ilist-not-any? ilist-in? ilist-bind))
    4949
    5050(define-interface SETS
    51    (sets set? set typed-list->set set->typed-list set-in?  set-cardinality
     51   (sets set? set ilist->set set->ilist set-in?  set-cardinality
    5252    set-filter set-null? set-difference set-add set-remove
    5353    set= set>= set<= set-union set-intersection))
    5454
    55 (functor (typed-lists (M (type? equ?))) LISTS
    56 
     55(functor (list-functor (M (item? equ?))) LISTS
    5756
    5857(import scheme
    5958        (only chicken error define-record-printer
    6059              unless receive case-lambda)
    61         (only data-structures list-of? o compose)
     60        (only data-structures list-of? o)
    6261        (only extras sprintf)
    6362        datatype
    6463        M)
    6564
    66 (import-for-syntax (only chicken receive print))
    67 
    68 (define-datatype typed-list typed-list?
    69   (list-null)
    70   (list-cons
    71     (first type?)
    72     (rest typed-list?)))
    73 
    74 (define-record-printer (typed-list tlst out)
    75   (let ((str (sprintf "~s" (typed-list->untyped-list tlst))))
     65(import-for-syntax (only chicken receive))
     66
     67(define-datatype ilist ilist?
     68  (ilist-null)
     69  (ilist-cons
     70    (first item?)
     71    (rest ilist?)))
     72
     73(define-record-printer (ilist ilst out)
     74  (let ((str (sprintf "~s" (ilist->list ilst))))
    7675    (string-set! str (- (string-length str) 1) #\])
    7776    (string-set! str 0 #\[)
    7877    (display str out)))
    7978
    80 ;(define-reader-ctor 'typed typed-list)
    81 
    82 (define (list-null? xpr)
    83   (and (typed-list? xpr)
    84        (cases typed-list xpr
    85          (list-null () #t)
    86          (list-cons (first rest) #f))))
    87 
    88 (define (list-first lst)
    89   (cases typed-list lst
    90     (list-null () (error 'list-first "list empty" lst))
    91     (list-cons (first rest) first)))
    92 
    93 (define (list-rest lst)
    94   (cases typed-list lst
    95     (list-null () (error 'list-rest "list empty" lst))
    96     (list-cons (first rest) rest)))
    97 
    98 (define-syntax list-bind
     79;(define-reader-ctor 'typed ilist)
     80
     81(define (ilist-null? xpr)
     82  (and (ilist? xpr)
     83       (cases ilist xpr
     84         (ilist-null () #t)
     85         (ilist-cons (first rest) #f))))
     86
     87(define (ilist-first lst)
     88  (cases ilist lst
     89    (ilist-null () (error 'ilist-first "list empty" lst))
     90    (ilist-cons (first rest) first)))
     91
     92(define (ilist-rest lst)
     93  (cases ilist lst
     94    (ilist-null () (error 'ilist-rest "list empty" lst))
     95    (ilist-cons (first rest) rest)))
     96
     97(define-syntax ilist-bind
    9998  (ir-macro-transformer
    10099    (lambda (form inject compare?)
    101100      (let ((pat (cadr form))
    102             (tlst (caddr form))
     101            (ilst (caddr form))
    103102            (xpr (caddr form))
    104103            (xprs (cdddr form)))
    105         (let ((tlst tlst))
     104        (let ((ilst ilst))
    106105                    ;; not available at compile time
    107                     ;(if (typed-list? tlst)
    108                     ;  tlst
    109                     ;  (error 'list-bind
     106                    ;(if (ilist? ilst)
     107                    ;  ilst
     108                    ;  (error 'ilist-bind
    110109                    ;         "not a typed list"
    111                     ;         tlst))))
     110                    ;         ilst))))
    112111          (if (list? pat)
    113             `(if (= ,(length pat) (list-length ,tlst))
    114                (list-apply (lambda ,pat ,xpr ,@xprs) ,tlst)
    115                (error 'list-bind "match error" ',pat ,tlst))
     112            `(if (= ,(length pat) (ilist-length ,ilst))
     113               (ilist-apply (lambda ,pat ,xpr ,@xprs) ,ilst)
     114               (error 'ilist-bind "match error" ',pat ,ilst))
    116115            ;; pseudolist: separate list part
    117116            (receive (head tail)
     
    120119                  (loop (cdr pat) (cons (car pat) lst))
    121120                  (values (reverse lst) pat)))
    122               `(if (<= ,(length head) (list-length ,tlst))
    123                  (receive (hd tl) (list-split-at ,(length head) ,tlst)
     121              `(if (<= ,(length head) (ilist-length ,ilst))
     122                 (receive (hd tl) (ilist-split-at ,(length head) ,ilst)
    124123                   (let ((,tail tl))
    125                      (list-apply (lambda ,head ,xpr ,@xprs) hd)))
    126                  (error 'list-bind "match error" ',pat ,tlst)))))))))
    127 
    128 (define (list-reverse . lsts)
     124                     (ilist-apply (lambda ,head ,xpr ,@xprs) hd)))
     125                 (error 'ilist-bind "match error" ',pat ,ilst)))))))))
     126
     127(define (ilist-reverse . lsts)
    129128  (cond
    130129    ((null? lsts)
    131      (list-null))
     130     (ilist-null))
    132131    ((null? (cdr lsts))
    133      (let loop ((ls (car lsts)) (result (list-null)))
    134        (cases typed-list ls
    135          (list-null () result)
    136          (list-cons (first rest)
    137                     (loop rest (list-cons first result))))))
     132     (let loop ((ls (car lsts)) (result (ilist-null)))
     133       (cases ilist ls
     134         (ilist-null () result)
     135         (ilist-cons (first rest)
     136                    (loop rest (ilist-cons first result))))))
    138137    (else
    139138      (let loop (
    140139        (lsts lsts)
    141         (results ;(make-list (length lsts) (list-null)))
     140        (results ;(make-list (length lsts) (ilist-null)))
    142141                 (let recur ((n (length lsts))
    143142                             (result '()))
    144143                   (if (zero? n)
    145144                     result
    146                      (recur (- n 1) (cons (list-null) result)))))
     145                     (recur (- n 1) (cons (ilist-null) result)))))
    147146        )
    148147        (cond
    149           (((list-of? list-null?) lsts)
     148          (((list-of? ilist-null?) lsts)
    150149           (apply values results))
    151           (((list-of? (o not list-null?)) lsts)
    152            (loop (map list-rest lsts)
    153                  (map (lambda (l ll) (list-cons l ll))
    154                       (map list-first lsts)
     150          (((list-of? (o not ilist-null?)) lsts)
     151           (loop (map ilist-rest lsts)
     152                 (map (lambda (l ll) (ilist-cons l ll))
     153                      (map ilist-first lsts)
    155154                      results)))
    156           (else (error 'list-reverse "lists not of equal length")))))))
    157 
    158 (define (typed-list . args)
    159   (let loop ((args args) (result (list-null)))
     155          (else (error 'ilist-reverse "lists not of equal length")))))))
     156
     157(define (ilist . args)
     158  (let loop ((args args) (result (ilist-null)))
    160159    (if (null? args)
    161       (list-reverse result)
    162       (loop (cdr args) (list-cons (car args) result)))))
    163 
    164 (define (list-repeat n x)
    165   (let loop ((k 0) (result (list-null)))
     160      (ilist-reverse result)
     161      (loop (cdr args) (ilist-cons (car args) result)))))
     162
     163(define (ilist-repeat n x)
     164  (let loop ((k 0) (result (ilist-null)))
    166165    (if (= k n)
    167166      result
    168       (loop (+ k 1) (list-cons x result)))))
    169 
    170 (define (list-iterate n fn x)
    171   (let loop ((k 0) (val x) (result (list-null)))
     167      (loop (+ k 1) (ilist-cons x result)))))
     168
     169(define (ilist-iterate n fn x)
     170  (let loop ((k 0) (val x) (result (ilist-null)))
    172171    (if (= k n)
    173       (list-reverse result)
    174       (loop (+ k 1) (fn val) (list-cons val result)))))
    175 
    176 (define (list-iterate-while ok? fn x)
    177   (let loop ((val x) (result (list-null)))
     172      (ilist-reverse result)
     173      (loop (+ k 1) (fn val) (ilist-cons val result)))))
     174
     175(define (ilist-iterate-while ok? fn x)
     176  (let loop ((val x) (result (ilist-null)))
    178177    (if (ok? val)
    179       (loop (fn val) (list-cons val result))
    180       (list-reverse result))))
    181 
    182 (define (list-iterate-until ok? fn x)
    183   (let loop ((val x) (result (list-null)))
     178      (loop (fn val) (ilist-cons val result))
     179      (ilist-reverse result))))
     180
     181(define (ilist-iterate-until ok? fn x)
     182  (let loop ((val x) (result (ilist-null)))
    184183    (if (ok? val)
    185       (list-reverse result)
    186       (loop (fn val) (list-cons val result)))))
    187 
    188 (define (typed-list->untyped-list lst)
     184      (ilist-reverse result)
     185      (loop (fn val) (ilist-cons val result)))))
     186
     187(define (ilist->list lst)
    189188  (let loop ((ls lst) (result '()))
    190     (cases typed-list ls
    191       (list-null () (reverse result))
    192       (list-cons (first rest)
     189    (cases ilist ls
     190      (ilist-null () (reverse result))
     191      (ilist-cons (first rest)
    193192       (loop rest (cons first result))))))
    194193
    195 (define (list-apply fn . args)
     194(define (ilist-apply fn . args)
    196195  (let ((len (length args)))
    197196    (apply fn
     
    201200          ((= k (- len 1))
    202201           (let ((tail (list-ref args k)))
    203              (if (typed-list? tail)
     202             (if (ilist? tail)
    204203               (loop (+ k 1)
    205204                     (append
    206205                       (reverse
    207                          (typed-list->untyped-list tail))
     206                         (ilist->list tail))
    208207                       result))
    209                (error 'list-apply
     208               (error 'ilist-apply
    210209                      (string-append
    211210                        "not a "
     
    215214          (else
    216215            (let ((item (list-ref args k)))
    217               (if (type? item)
     216              (if (item? item)
    218217                (loop (+ k 1)
    219218                      (cons item result))
    220                 (error 'list-apply
    221                        "wrong list-ype"
    222                        `(,type? ,item))))))))))
    223 
    224 (define (untyped-list->typed-list lst)
    225   (apply typed-list lst))
    226 
    227 (define (list-length lst)
     219                (error 'ilist-apply
     220                       "wrong ilist-ype"
     221                       `(,item? ,item))))))))))
     222
     223(define (list->ilist lst)
     224  (apply ilist lst))
     225
     226(define (ilist-length lst)
    228227  (let loop ((ls lst) (k 0))
    229     (cases typed-list ls
    230       (list-null () k)
    231       (list-cons (first rest)
     228    (cases ilist ls
     229      (ilist-null () k)
     230      (ilist-cons (first rest)
    232231        (loop rest (+ k 1))))))
    233232
    234 (define (list-item k lst)
     233(define (ilist-item k lst)
    235234  (let loop ((ls lst) (n 0))
    236     (cases typed-list ls
    237       (list-null () (error 'list-item "range error"))
    238       (list-cons (first rest)
     235    (cases ilist ls
     236      (ilist-null () (error 'ilist-item "range error"))
     237      (ilist-cons (first rest)
    239238        (if (= n k)
    240239          first
    241240          (loop rest (+ n 1)))))))
    242241
    243 (define (list-from-upto from upto lst)
    244   (let loop ((ls lst) (k 0) (result (list-null)))
    245     (cases typed-list ls
    246       (list-null () (list-reverse result))
    247       (list-cons (first rest)
     242(define (ilist-from-upto from upto lst)
     243  (let loop ((ls lst) (k 0) (result (ilist-null)))
     244    (cases ilist ls
     245      (ilist-null () (ilist-reverse result))
     246      (ilist-cons (first rest)
    248247        (cond
    249248          ((= k upto)
    250            (list-reverse result))
     249           (ilist-reverse result))
    251250          ((< k from)
    252251           (loop rest (+ k 1) result))
    253252          (else
    254             (loop rest (+ k 1) (list-cons first result))))))))
    255 
    256 (define (list-split-at k lst)
    257   (let loop ((ls lst) (n 0) (head (list-null)))
    258     (cases typed-list ls
    259       (list-null () (values (list-reverse head) ls))
    260       (list-cons (first rest)
     253            (loop rest (+ k 1) (ilist-cons first result))))))))
     254
     255(define (ilist-split-at k lst)
     256  (let loop ((ls lst) (n 0) (head (ilist-null)))
     257    (cases ilist ls
     258      (ilist-null () (values (ilist-reverse head) ls))
     259      (ilist-cons (first rest)
    261260        (if (= n k)
    262          (values (list-reverse head) ls)
    263          (loop rest (+ n 1) (list-cons first head)))))))
    264 
    265 (define (list-split-with ok? lst)
    266   (let loop ((ls lst) (head (list-null)))
    267     (cases typed-list ls
    268       (list-null () (values (list-reverse head) ls))
    269       (list-cons (first rest)
     261         (values (ilist-reverse head) ls)
     262         (loop rest (+ n 1) (ilist-cons first head)))))))
     263
     264(define (ilist-split-with ok? lst)
     265  (let loop ((ls lst) (head (ilist-null)))
     266    (cases ilist ls
     267      (ilist-null () (values (ilist-reverse head) ls))
     268      (ilist-cons (first rest)
    270269        (if (ok? first)
    271           (values (list-reverse head) ls)
    272           (loop rest (list-cons first head)))))))
    273 
    274 (define (list-take k lst)
     270          (values (ilist-reverse head) ls)
     271          (loop rest (ilist-cons first head)))))))
     272
     273(define (ilist-take k lst)
    275274  (call-with-values
    276     (lambda () (list-split-at k lst))
     275    (lambda () (ilist-split-at k lst))
    277276    (lambda (head tail) head)))
    278277
    279 (define (list-take-while ok? lst)
     278(define (ilist-take-while ok? lst)
    280279  (call-with-values
    281     (lambda () (list-split-with (o not ok?) lst))
     280    (lambda () (ilist-split-with (o not ok?) lst))
    282281    (lambda (head tail) head)))
    283282
    284 (define (list-drop k lst)
     283(define (ilist-drop k lst)
    285284  (call-with-values
    286     (lambda () (list-split-at k lst))
     285    (lambda () (ilist-split-at k lst))
    287286    (lambda (head tail) tail)))
    288287
    289 (define (list-drop-while ok? lst)
     288(define (ilist-drop-while ok? lst)
    290289  (call-with-values
    291     (lambda () (list-split-with (o not ok?) lst))
     290    (lambda () (ilist-split-with (o not ok?) lst))
    292291    (lambda (head tail) tail)))
    293292
    294 (define (list-append . lsts)
     293(define (ilist-append . lsts)
    295294  (cond
    296295    ((null? lsts)
    297      (list-null))
     296     (ilist-null))
    298297    ((null? (cdr lsts))
    299298     (car lsts))
    300299    ((null? (cddr lsts))
    301      (let loop ((ls0 (list-reverse (car lsts)))
     300     (let loop ((ls0 (ilist-reverse (car lsts)))
    302301                (result (cadr lsts)))
    303        (cases typed-list ls0
    304          (list-null () result)
    305          (list-cons (first rest)
    306                  (loop rest (list-cons first result))))))
     302       (cases ilist ls0
     303         (ilist-null () result)
     304         (ilist-cons (first rest)
     305                 (loop rest (ilist-cons first result))))))
    307306    (else
    308       (list-append (car lsts)
    309                 (apply list-append (cdr lsts))))))
    310 
    311 (define (list-mappend fn . lsts)
    312   (apply list-append
     307      (ilist-append (car lsts)
     308                (apply ilist-append (cdr lsts))))))
     309
     310(define (ilist-mappend fn . lsts)
     311  (apply ilist-append
    313312         (apply map fn
    314                 (map typed-list->untyped-list lsts))))
    315 
    316 (define (list-map fn . lsts)
     313                (map ilist->list lsts))))
     314
     315(define (ilist-map fn . lsts)
    317316  (if (null? lsts)
    318     (list-null)
    319     (let loop ((lsts lsts) (result (list-null)))
    320       (if (memq #t (map list-null? lsts))
    321         (list-reverse result)
    322         (loop (map list-rest lsts)
    323               (list-cons (apply fn (map list-first lsts))
     317    (ilist-null)
     318    (let loop ((lsts lsts) (result (ilist-null)))
     319      (if (memq #t (map ilist-null? lsts))
     320        (ilist-reverse result)
     321        (loop (map ilist-rest lsts)
     322              (ilist-cons (apply fn (map ilist-first lsts))
    324323                      result))))))
    325324
    326 (define (list-for-each fn . lsts)
     325(define (ilist-for-each fn . lsts)
    327326  (unless (null? lsts)
    328     (do ((lsts lsts (map list-rest lsts)))
    329       ((memq #t (map list-null? lsts)))
    330       (apply fn (map list-first lsts)))))
    331 
    332 (define (list-filter ok? lst)
    333   (let loop ((ls lst) (yes (list-null)) (no (list-null)))
    334     (cases typed-list ls
    335       (list-null ()
    336         (values (list-reverse yes) (list-reverse no)))
    337       (list-cons (first rest)
     327    (do ((lsts lsts (map ilist-rest lsts)))
     328      ((memq #t (map ilist-null? lsts)))
     329      (apply fn (map ilist-first lsts)))))
     330
     331(define (ilist-filter ok? lst)
     332  (let loop ((ls lst) (yes (ilist-null)) (no (ilist-null)))
     333    (cases ilist ls
     334      (ilist-null ()
     335        (values (ilist-reverse yes) (ilist-reverse no)))
     336      (ilist-cons (first rest)
    338337         (if (ok? first)
    339            (loop rest (list-cons first yes) no)
    340            (loop rest yes (list-cons first no)))))))
    341 
    342 (define (list-equal? lst0 lst1)
     338           (loop rest (ilist-cons first yes) no)
     339           (loop rest yes (ilist-cons first no)))))))
     340
     341(define (ilist-equal? lst0 lst1)
    343342  (let loop ((ls0 lst0) (ls1 lst1))
    344343    (cond
    345       ((list-null? ls0)
    346        (list-null? ls1))
    347       ((list-null? ls1)
    348        (list-null? ls0))
     344      ((ilist-null? ls0)
     345       (ilist-null? ls1))
     346      ((ilist-null? ls1)
     347       (ilist-null? ls0))
    349348      (else
    350         (and (equ? (list-first ls0)
    351                     (list-first ls1))
    352              (loop (list-rest ls0)
    353                    (list-rest ls1)))))))
    354 
    355 (define (list-memp ok? lst)
     349        (and (equ? (ilist-first ls0)
     350                    (ilist-first ls1))
     351             (loop (ilist-rest ls0)
     352                   (ilist-rest ls1)))))))
     353
     354(define (ilist-memp ok? lst)
    356355  (let loop ((ls lst))
    357     (cases typed-list ls
    358       (list-null () #f)
    359       (list-cons (first rest)
     356    (cases ilist ls
     357      (ilist-null () #f)
     358      (ilist-cons (first rest)
    360359         (if (ok? first)
    361360           ls
    362361           (loop rest))))))
    363362
    364 (define (list-member item lst)
    365   (list-memp (lambda (x) (equ? x item)) lst))
    366 
    367 (define (list-remp ok? lst)
    368   (call-with-values (lambda () (list-filter ok? lst))
     363(define (ilist-member item lst)
     364  (ilist-memp (lambda (x) (equ? x item)) lst))
     365
     366(define (ilist-remp ok? lst)
     367  (call-with-values (lambda () (ilist-filter ok? lst))
    369368                    (lambda (a b) b)))
    370369
    371 (define (list-remove item lst)
    372   (list-remp (lambda (x) (equ? item x)) lst))
    373 
    374 (define (list-adjoin item lst)
    375   (if (list-member item lst)
     370(define (ilist-remove item lst)
     371  (ilist-remp (lambda (x) (equ? item x)) lst))
     372
     373(define (ilist-adjoin item lst)
     374  (if (ilist-member item lst)
    376375    lst
    377     (list-cons item lst)))
    378 
    379 (define (list-remove-dups lst)
    380   (let loop ((ls lst) (result (list-null)))
    381     (cases typed-list ls
    382       (list-null () result)
    383       (list-cons (first rest)
    384               (loop rest (list-adjoin first result))))))
    385 
    386 (define (list-assp ok? lst)
     376    (ilist-cons item lst)))
     377
     378(define (ilist-remove-dups lst)
     379  (let loop ((ls lst) (result (ilist-null)))
     380    (cases ilist ls
     381      (ilist-null () result)
     382      (ilist-cons (first rest)
     383              (loop rest (ilist-adjoin first result))))))
     384
     385(define (ilist-assp ok? lst)
    387386  (let loop ((ls lst))
    388     (cases typed-list ls
    389       (list-null () #f)
    390       (list-cons (first rest)
     387    (cases ilist ls
     388      (ilist-null () #f)
     389      (ilist-cons (first rest)
    391390        (if (ok? (car first))
    392391          first
    393392          (loop rest))))))
    394393
    395 (define (list-assoc item lst)
    396   (list-assp (lambda (x) (equ? item x)) lst))
    397 
    398 (define (list-fold-left op base . lsts)
     394(define (ilist-assoc item lst)
     395  (ilist-assp (lambda (x) (equ? item x)) lst))
     396
     397(define (ilist-fold-left op base . lsts)
    399398  (cond
    400399    ((null? lsts) base)
    401400    ((null? (cdr lsts))
    402401     (let loop ((lst (car lsts)) (result base))
    403        (if (list-null? lst)
     402       (if (ilist-null? lst)
    404403         result
    405          (loop (list-rest lst)
    406                (op result (list-first lst))))))
     404         (loop (ilist-rest lst)
     405               (op result (ilist-first lst))))))
    407406    (else
    408407      (let loop ((lsts lsts) (result base))
    409408        (cond
    410           (((list-of? list-null?) lsts)
     409          (((list-of? ilist-null?) lsts)
    411410           result)
    412           (((list-of? (o not list-null?)) lsts)
    413            (loop (map list-rest lsts)
    414                  (apply op result (map list-first lsts))))
     411          (((list-of? (o not ilist-null?)) lsts)
     412           (loop (map ilist-rest lsts)
     413                 (apply op result (map ilist-first lsts))))
    415414          (else
    416             (error 'list-fold-left "lists not of equal length")))))))
    417 
    418 (define (list-fold-right op base . lsts)
     415            (error 'ilist-fold-left "lists not of equal length")))))))
     416
     417(define (ilist-fold-right op base . lsts)
    419418  (cond
    420419    ((null? lsts) base)
    421420    ((null? (cdr lsts))
    422      (let loop ((lst (list-reverse (car lsts)))
     421     (let loop ((lst (ilist-reverse (car lsts)))
    423422                (result base))
    424        (if (list-null? lst)
     423       (if (ilist-null? lst)
    425424         result
    426          (loop (list-rest lst)
    427                (op (list-first lst) result)))))
     425         (loop (ilist-rest lst)
     426               (op (ilist-first lst) result)))))
    428427    (else
    429428      (let loop (
    430         ;; checking for equal length is done by list-reverse
     429        ;; checking for equal length is done by ilist-reverse
    431430        (lsts (call-with-values
    432                 (lambda () (apply list-reverse lsts))
     431                (lambda () (apply ilist-reverse lsts))
    433432                list))
    434433        (result base)
    435434        )
    436         (if ((list-of? list-null?) lsts)
     435        (if ((list-of? ilist-null?) lsts)
    437436          result
    438           (loop (map list-rest lsts)
     437          (loop (map ilist-rest lsts)
    439438                (apply op
    440                        (append (map list-first lsts)
     439                       (append (map ilist-first lsts)
    441440                               (list result)))))))))
    442441
    443 (define (list-merge <? lst0 lst1)
     442(define (ilist-merge <? lst0 lst1)
    444443  ;; without sorted checks, not tail recursive
    445444  ;(let loop ((ls0 lst0) (ls1 lst1))
    446445  ;  (cond
    447   ;    ((list-null? ls0) ls1)
    448   ;    ((list-null? ls1) ls0)
    449   ;    ((<? (list-first ls0) (list-first ls1))
    450   ;     (list-cons (list-first ls0)
    451   ;             (loop (list-rest ls0) ls1)))
     446  ;    ((ilist-null? ls0) ls1)
     447  ;    ((ilist-null? ls1) ls0)
     448  ;    ((<? (ilist-first ls0) (ilist-first ls1))
     449  ;     (ilist-cons (ilist-first ls0)
     450  ;             (loop (ilist-rest ls0) ls1)))
    452451  ;    (else
    453   ;     (list-cons (list-first ls1)
    454   ;             (loop ls0 (list-rest ls1)))))))
     452  ;     (ilist-cons (ilist-first ls1)
     453  ;             (loop ls0 (ilist-rest ls1)))))))
    455454  ;; tail recursive, with sorted checks
    456   (let loop ((ls0 lst0) (ls1 lst1) (result (list-null)))
     455  (let loop ((ls0 lst0) (ls1 lst1) (result (ilist-null)))
    457456    (cond
    458       ((and (list-null? ls0) (list-null? ls1))
    459        (list-reverse result))
    460       ((list-null? ls0)
    461        (if (or (list-null? (list-rest ls1))
    462                (<? (list-first ls1) (list-first (list-rest ls1))))
    463          (loop ls0 (list-rest ls1) (list-cons (list-first ls1) result))
    464          (error 'list-merge "not sorted" lst1)))
    465       ((list-null? ls1)
    466        (if (or (list-null? (list-rest ls0))
    467                (<? (list-first ls0) (list-first (list-rest ls0))))
    468          (loop (list-rest ls0) ls1 (list-cons (list-first ls0) result))
    469          (error 'list-merge "not sorted" lst1)))
    470       ((not (or (list-null? (list-rest ls0))
    471                 (<? (list-first ls0) (list-first (list-rest ls0)))))
    472        (error 'list-merge "not sorted" lst0))
    473       ((not (or (list-null? (list-rest ls1))
    474                 (<? (list-first ls1) (list-first (list-rest ls1)))))
    475        (error 'list-merge "not sorted" lst1))
     457      ((and (ilist-null? ls0) (ilist-null? ls1))
     458       (ilist-reverse result))
     459      ((ilist-null? ls0)
     460       (if (or (ilist-null? (ilist-rest ls1))
     461               (<? (ilist-first ls1) (ilist-first (ilist-rest ls1))))
     462         (loop ls0 (ilist-rest ls1) (ilist-cons (ilist-first ls1) result))
     463         (error 'ilist-merge "not sorted" lst1)))
     464      ((ilist-null? ls1)
     465       (if (or (ilist-null? (ilist-rest ls0))
     466               (<? (ilist-first ls0) (ilist-first (ilist-rest ls0))))
     467         (loop (ilist-rest ls0) ls1 (ilist-cons (ilist-first ls0) result))
     468         (error 'ilist-merge "not sorted" lst1)))
     469      ((not (or (ilist-null? (ilist-rest ls0))
     470                (<? (ilist-first ls0) (ilist-first (ilist-rest ls0)))))
     471       (error 'ilist-merge "not sorted" lst0))
     472      ((not (or (ilist-null? (ilist-rest ls1))
     473                (<? (ilist-first ls1) (ilist-first (ilist-rest ls1)))))
     474       (error 'ilist-merge "not sorted" lst1))
    476475      (else
    477         (if (<? (list-first ls0) (list-first ls1))
    478           (loop (list-rest ls0) ls1 (list-cons (list-first ls0) result))
    479           (loop ls0 (list-rest ls1) (list-cons (list-first ls1) result))))
     476        (if (<? (ilist-first ls0) (ilist-first ls1))
     477          (loop (ilist-rest ls0) ls1 (ilist-cons (ilist-first ls0) result))
     478          (loop ls0 (ilist-rest ls1) (ilist-cons (ilist-first ls1) result))))
    480479      )))
    481480
    482 (define (list-sort <? lst)
     481(define (ilist-merge-sort <? lst)
    483482  (let loop ((ls lst))
    484     (let ((len (list-length ls)))
     483    (let ((len (ilist-length ls)))
    485484      (if (< len 2)
    486485        ls
    487486        (receive (head tail)
    488           (list-split-at (quotient len 2) ls)
    489           (list-merge <?
     487          (ilist-split-at (quotient len 2) ls)
     488          (ilist-merge <?
    490489                   (loop head)
    491490                   (loop tail)))))))
    492491
    493 (define (list-sorted? <? lst)
     492(define (ilist-insertion-sort <? lst)
     493  (cases ilist lst
     494    (ilist-null () lst)
     495    (ilist-cons (first rest)
     496      (ilist-insert-sorted <?
     497                           first
     498                           (ilist-insertion-sort <? rest)))))
     499
     500(define (ilist-sorted? <? lst)
    494501  (let loop ((ls lst))
    495     (cases typed-list ls
    496       (list-null () #t)
    497       (list-cons (first rest)
     502    (cases ilist ls
     503      (ilist-null () #t)
     504      (ilist-cons (first rest)
    498505        (cond
    499           ((list-null? rest) #t)
    500           ((<? first (list-first rest))
     506          ((ilist-null? rest) #t)
     507          ((<? first (ilist-first rest))
    501508           (loop rest))
    502509          (else #f))))))
    503510
    504 (define (list-cons-sorted <? item lst)
    505   (if (list-sorted? <? lst)
     511(define (ilist-insert-sorted <? item lst)
     512  (if (ilist-sorted? <? lst)
    506513    (let loop ((lst lst))
    507       (cases typed-list lst
    508         (list-null () (list-cons item (list-null)))
    509         (list-cons (first rest)
     514      (cases ilist lst
     515        (ilist-null () (ilist-cons item (ilist-null)))
     516        (ilist-cons (first rest)
    510517          (if (<? item first)
    511             (list-apply typed-list item first rest)
    512             (list-cons first (loop rest))))))
    513     (error 'list-cons-sorted "argument list not sorted" lst)))
    514 
    515 (define (list-zip lst0 lst1)
     518            (ilist-apply ilist item first rest)
     519            (ilist-cons first (loop rest))))))
     520    (error 'ilist-insert-sorted "argument list not sorted" lst)))
     521
     522(define (ilist-zip lst0 lst1)
    516523  (cond
    517     ((list-null? lst0)
     524    ((ilist-null? lst0)
    518525     lst1)
    519526    (else
    520       (list-cons (list-first lst0)
    521               (list-zip lst1 (list-rest lst0))))))
    522 
    523 (define (list-interpose sep lst)
    524   (list-rest
    525     (let loop ((ls lst) (result (list-null)))
    526       (cases typed-list ls
    527         (list-null () (list-reverse result))
    528         (list-cons (first rest)
     527      (ilist-cons (ilist-first lst0)
     528              (ilist-zip lst1 (ilist-rest lst0))))))
     529
     530(define (ilist-interpose sep lst)
     531  (ilist-rest
     532    (let loop ((ls lst) (result (ilist-null)))
     533      (cases ilist ls
     534        (ilist-null () (ilist-reverse result))
     535        (ilist-cons (first rest)
    529536          (loop rest
    530                 (list-cons first (list-cons sep result))))))))
    531                 ;(list-apply typed-list first sep result)))))))
    532 
    533 (define (list-every? ok? lst)
    534   (not (list-memp (o not ok?) lst)))
    535 
    536 (define (list-not-every? ok? lst)
    537   (if (list-memp (o not ok?) lst) #t #f))
    538 
    539 (define (list-not-any? ok? lst)
    540   (if (list-memp ok? lst)
     537                (ilist-cons first (ilist-cons sep result))))))))
     538                ;(ilist-apply ilist first sep result)))))))
     539
     540(define (ilist-every? ok? lst)
     541  (not (ilist-memp (o not ok?) lst)))
     542
     543(define (ilist-not-every? ok? lst)
     544  (if (ilist-memp (o not ok?) lst) #t #f))
     545
     546(define (ilist-not-any? ok? lst)
     547  (if (ilist-memp ok? lst)
    541548    #f
    542549    #t))
    543550
    544 (define (list-some ok? lst)
     551(define (ilist-some ok? lst)
    545552  (let loop ((ls lst))
    546     (cases typed-list ls
    547       (list-null () #f)
    548       (list-cons (first rest)
     553    (cases ilist ls
     554      (ilist-null () #f)
     555      (ilist-cons (first rest)
    549556         (if (ok? first)
    550557           first
    551558           (loop rest))))))
    552559
    553 (define (list-in? tlst1 tlst2)
    554   (cases typed-list tlst1
    555     (list-null () #t)
    556     (list-cons (first rest)
    557       (let ((start (list-member first tlst2)))
     560(define (ilist-in? ilst1 ilst2)
     561  (cases ilist ilst1
     562    (ilist-null () #t)
     563    (ilist-cons (first rest)
     564      (let ((start (ilist-member first ilst2)))
    558565        (if start
    559           (let loop ((ls0 tlst1) (ls1 start))
     566          (let loop ((ls0 ilst1) (ls1 start))
    560567            (cond
    561               ((and (list-null? ls0) (list-null? ls1)) #t)
    562               ((list-null? ls0) #t)
    563               ((list-null? ls1) #f)
    564               ((equ? (list-first ls0) (list-first ls1))
    565                (loop (list-rest ls0) (list-rest ls1)))
     568              ((and (ilist-null? ls0) (ilist-null? ls1)) #t)
     569              ((ilist-null? ls0) #t)
     570              ((ilist-null? ls1) #f)
     571              ((equ? (ilist-first ls0) (ilist-first ls1))
     572               (loop (ilist-rest ls0) (ilist-rest ls1)))
    566573              (else #f)))
    567574          #f)))))
    568575
    569576;;; documentation
    570 (define typed-lists
     577(define ilists
    571578  (let (
    572579    (signatures '(
    573       (typed-list? xpr)
    574       (typed-list . args)
    575       (untyped-list->typed-list tlst)
    576       (list-null)
    577       (list-cons item tlst)
    578       (list-repeat n x)
    579       (list-iterate n fn x)
    580       (list-iterate-while ok? fn x)
    581       (list-iterate-until ok? fn x)
    582 
    583       (typed-list->untyped-list tlst)
    584       (list-apply fn . args)
    585       (list-null? xpr)
    586       (list-first tlst)
    587       (list-rest tlst)
    588       (list-reverse . tlsts)
    589       (list-length tlst)
    590       (list-from-upto from upto tlst) ; sublist
    591       (list-item k tlst) ; ref
    592       (list-split-at k tlst)
    593       (list-split-with ok? tlst)
    594       (list-drop k tlst)
    595       (list-drop-while ok? tlst)
    596       (list-take k tlst)
    597       (list-take-while ok? tlst)
    598       (list-append . tlsts)
    599       (list-map fn . tlsts)
    600       (list-mappend fn . tlsts)
    601       (list-for-each fn . tlsts)
    602       (list-filter ok? tlst)
    603       (list-adjoin item tlst)
    604       (list-equal? tlst0 tlst1)
    605       (list-memp ok? tlst)
    606       (list-member item tlst)
    607       (list-remp ok? tlst)
    608       (list-remove item tlst)
    609       (list-remove-dups tlst)
    610       (list-assp ok? tlst)
    611       (list-assoc item tlst)
    612       (list-fold-left op base . tlsts)
    613       (list-fold-right op base . tlsts)
    614       (list-merge <? tlst0 tlst1)
    615       (list-sort <? tlst)
    616       (list-sorted? <? tlst)
    617       (list-cons-sorted <? item tlst)
    618       (list-zip tlst0 tlst1)
    619       (list-interpose sep tlst)
    620       (list-every? ok? tlst)
    621       (list-some ok? tlst)
    622       (list-not-every? ok? tlst)
    623       (list-not-any? ok? tlst)
    624       (list-in? tlst0 tlst1)
    625       (list-bind (x ... . xs) tlst xpr . xprs)
     580      (ilist? xpr)
     581      (ilist . args)
     582      (list->ilist lst)
     583      (ilist-null)
     584      (ilist-cons item ilst)
     585      (ilist-repeat n x)
     586      (ilist-iterate n fn x)
     587      (ilist-iterate-while ok? fn x)
     588      (ilist-iterate-until ok? fn x)
     589
     590      (ilist->list ilst)
     591      (ilist-apply fn . args)
     592      (ilist-null? xpr)
     593      (ilist-first ilst)
     594      (ilist-rest ilst)
     595      (ilist-reverse . ilsts)
     596      (ilist-length ilst)
     597      (ilist-from-upto from upto ilst) ; sublist
     598      (ilist-item k ilst) ; ref
     599      (ilist-split-at k ilst)
     600      (ilist-split-with ok? ilst)
     601      (ilist-drop k ilst)
     602      (ilist-drop-while ok? ilst)
     603      (ilist-take k ilst)
     604      (ilist-take-while ok? ilst)
     605      (ilist-append . ilsts)
     606      (ilist-map fn . ilsts)
     607      (ilist-mappend fn . ilsts)
     608      (ilist-for-each fn . ilsts)
     609      (ilist-filter ok? ilst)
     610      (ilist-adjoin item ilst)
     611      (ilist-equal? ilst0 ilst1)
     612      (ilist-memp ok? ilst)
     613      (ilist-member item ilst)
     614      (ilist-remp ok? ilst)
     615      (ilist-remove item ilst)
     616      (ilist-remove-dups ilst)
     617      (ilist-assp ok? ilst)
     618      (ilist-assoc item ilst)
     619      (ilist-fold-left op base . ilsts)
     620      (ilist-fold-right op base . ilsts)
     621      (ilist-merge <? ilst0 ilst1)
     622      (ilist-merge-sort <? ilst)
     623      (ilist-insertion-sort <? ilst)
     624      (ilist-sorted? <? ilst)
     625      (ilist-insert-sorted <? item ilst)
     626      (ilist-zip ilst0 ilst1)
     627      (ilist-interpose sep ilst)
     628      (ilist-every? ok? ilst)
     629      (ilist-some ok? ilst)
     630      (ilist-not-every? ok? ilst)
     631      (ilist-not-any? ok? ilst)
     632      (ilist-in? ilst0 ilst1)
     633      (ilist-bind (x ... . xs) ilst xpr . xprs)
    626634      ))
    627635    )
     
    630638      ((sym) (assq sym signatures)))))
    631639
    632 ) ; functor typed-lists
    633 
    634 (functor (typed-sets (M (type? equ?)) (N LISTS)) SETS
     640) ; functor list-functor
     641
     642(functor (set-functor (M (item? equ?)) (N LISTS)) SETS
    635643
    636644(import scheme
    637         (only chicken error define-record-printer
    638               unless receive case-lambda)
    639         (only data-structures list-of? o compose)
     645        (only chicken error define-record-printer case-lambda)
    640646        (only extras sprintf)
    641647        datatype
    642648        M N)
    643649
    644 ;;; sets as typed-lists
     650;;; sets as ilists
    645651
    646652(define-datatype set set?
    647   (typed-list->set (ls typed-list?)))
     653  (ilist->set (ls ilist?)))
    648654
    649655(define (set-add item st)
    650   (typed-list->set
     656  (ilist->set
    651657    (cases set st
    652       (typed-list->set (ls)
    653          (list-cons item ls)))))
     658      (ilist->set (ls)
     659         (ilist-cons item ls)))))
    654660 
    655661(define (set-remove item st)
    656   (typed-list->set
     662  (ilist->set
    657663    (cases set st
    658       (typed-list->set (ls)
    659         (cases typed-list ls
    660           (list-null ()
    661             (list-null))
    662           (list-cons (first rest)
     664      (ilist->set (ls)
     665        (cases ilist ls
     666          (ilist-null ()
     667            (ilist-null))
     668          (ilist-cons (first rest)
    663669            (if (equ? item first)
    664               (list-remove item rest)
    665               (list-cons first
    666                          (list-remove item rest)))))))))
     670              (ilist-remove item rest)
     671              (ilist-cons first
     672                         (ilist-remove item rest)))))))))
    667673     
    668 (define (set->typed-list st)
     674(define (set->ilist st)
    669675  (cases set st
    670     (typed-list->set (st) st)))
     676    (ilist->set (st) st)))
    671677
    672678(define-record-printer (set st out)
    673679  (let ((str (sprintf "~s"
    674                (typed-list->untyped-list
     680               (ilist->list
    675681                 (cases set st
    676                    (typed-list->set (ls)
    677                      (list-remove-dups ls)))))))
     682                   (ilist->set (ls)
     683                     (ilist-remove-dups ls)))))))
    678684    (string-set! str 0 #\{)
    679685    (string-set! str (- (string-length str) 1) #\})
     
    681687
    682688(define (set . args)
    683   (typed-list->set (apply typed-list args)))
     689  (ilist->set (apply ilist args)))
    684690
    685691(define (set-cardinality st)
    686692  (cases set st
    687     (typed-list->set (ls)
    688        (list-length (list-remove-dups ls)))))
     693    (ilist->set (ls)
     694       (ilist-length (ilist-remove-dups ls)))))
    689695
    690696(define (set-in? item st)
    691697  (cases set st
    692     (typed-list->set (ls)
    693       (if (list-member item ls) #t #f))))
     698    (ilist->set (ls)
     699      (if (ilist-member item ls) #t #f))))
    694700
    695701(define (set<= set0 set1)
    696702  (cases set set0
    697     (typed-list->set (ls0)
    698       (list-every?
     703    (ilist->set (ls0)
     704      (ilist-every?
    699705        (lambda (item)
    700           (list-member
     706          (ilist-member
    701707            item
    702708            (cases set set1
    703               (typed-list->set (ls1)
     709              (ilist->set (ls1)
    704710                          ls1))))
    705711        ls0))))
     
    711717       (set<= set1 set0)))
    712718
    713 ;; list-filter not used, to avoid unnessecary reversing
     719;; ilist-filter not used, to avoid unnessecary reversing
    714720(define (set-filter ok? st)
    715721  (cases set st
    716     (typed-list->set (ls)
    717       (let loop ((ls ls) (yes (list-null)) (no (list-null)))
    718         (cases typed-list ls
    719           (list-null ()
    720             (values (typed-list->set yes) (typed-list->set no)))
    721           (list-cons (first rest)
     722    (ilist->set (ls)
     723      (let loop ((ls ls) (yes (ilist-null)) (no (ilist-null)))
     724        (cases ilist ls
     725          (ilist-null ()
     726            (values (ilist->set yes) (ilist->set no)))
     727          (ilist-cons (first rest)
    722728            (if (ok? first)
    723               (loop rest (list-cons first yes) no)
    724               (loop rest yes (list-cons first no)))))))))
     729              (loop rest (ilist-cons first yes) no)
     730              (loop rest yes (ilist-cons first no)))))))))
    725731
    726732(define (set-null? xpr)
    727733  (and (set? xpr)
    728734       (cases set xpr
    729          (typed-list->set (ls) (list-null? ls)))))
     735         (ilist->set (ls) (ilist-null? ls)))))
    730736
    731737(define (set-difference set0 set1)
    732   (let loop ((ls1 (set->typed-list  set1))
    733              (ls0 (set->typed-list set0)))
    734     (cases typed-list ls1
    735       (list-null () (typed-list->set ls0))
    736       (list-cons (first rest)
    737         (loop rest (list-remove first ls0))))))
    738 
    739 ;; list-append not used, list-o avoid unnessecary reversing
     738  (let loop ((ls1 (set->ilist  set1))
     739             (ls0 (set->ilist set0)))
     740    (cases ilist ls1
     741      (ilist-null () (ilist->set ls0))
     742      (ilist-cons (first rest)
     743        (loop rest (ilist-remove first ls0))))))
     744
     745;; ilist-append not used, ilist-o avoid unnessecary reversing
    740746(define (set-union . sts)
    741747  (cond
    742     ((null? sts) (typed-list->set (list-null)))
     748    ((null? sts) (ilist->set (ilist-null)))
    743749    ((null? (cdr sts)) (car sts))
    744750    ((null? (cddr sts))
    745751     (cases set (car sts)
    746        (typed-list->set (ls)
     752       (ilist->set (ls)
    747753         (let loop ((ls ls) (result (cadr sts)))
    748            (cases typed-list ls
    749              (list-null () result)
    750              (list-cons (first rest)
     754           (cases ilist ls
     755             (ilist-null () result)
     756             (ilist-cons (first rest)
    751757               (loop rest
    752758                     (set-add first result))))))))
     
    758764    (cond
    759765      ((null? sts)
    760        (typed-list->set (list-null)))
     766       (ilist->set (ilist-null)))
    761767      ((null? (cdr sts))
    762768       (car sts))
     
    764770       (let ((set1 (cadr sts)))
    765771         (cases set (car sts)
    766            (typed-list->set (ls)
     772           (ilist->set (ls)
    767773             (let loop ((ls ls)
    768                         (result (list-null)))
    769                (cases typed-list ls
    770                  (list-null () (typed-list->set result))
    771                  (list-cons (first rest)
     774                        (result (ilist-null)))
     775               (cases ilist ls
     776                 (ilist-null () (ilist->set result))
     777                 (ilist-cons (first rest)
    772778                   (if (set-in? first set1)
    773779                     (loop rest
    774                            (list-cons first result))
     780                           (ilist-cons first result))
    775781                     (loop rest result)))))))))
    776782      (else
     
    784790      (set? xpr)
    785791      (set . args)
    786       (typed-list->set lst)
    787       (set->typed-list st)
     792      (ilist->set lst)
     793      (set->ilist st)
    788794      (set-in? item st)
    789795      (set<= set0 set1)
     
    804810      ((sym) (assq sym signatures)))))
    805811
    806 ) ; functor typed-sets
    807 
    808 ;(use simple-tests)
    809 ;(import datatype typed-lists)
    810 ;;; argument module
    811 ;(module nums (type? equ?)
    812 ;  (import scheme)
    813 ;  (define type? number?)
    814 ;  (define equ? =))
    815 ;;; apply functor
    816 ;(module num-lists = (typed-lists nums))
    817 ;(module num-sets = (typed-sets nums num-lists))
    818 ;(import num-lists num-sets)
    819 ;
    820 ;(use bindings)
    821 ;(seq-length-ref-tail! typed-list?
    822 ;                      list-length
    823 ;                      (lambda (seq it) (list-item it seq))
    824 ;                      (lambda (seq it) (list-drop it seq)))
    825 ;(xpr:val
    826 ;  (typed-list? (bind (a b . c) (typed-list 1 2 3 4) c))
    827 ;  (set 1 2 1 4 2 4 3 5)
    828 ;  )
     812) ; functor set-functor
     813
     814;;; implicit functor argument _immutable-lists
     815(module immutable-lists = list-functor
     816  (import scheme
     817          (only chicken case-lambda))
     818
     819  (define item? (lambda (x) #t))
     820  (define equ? equal?)
     821  ) ; immutable-lists
     822
     823
     824
     825;;; explicit functor arguments
     826(module sets = (set-functor _immutable-lists immutable-lists))
     827
  • release/4/typed-lists/tags/2.0/typed-lists.setup

    r31264 r31337  
    22
    33(compile -O3 -s -d1 typed-lists.scm -J)
    4 (compile -O3 -d0 -s typed-lists.import.scm)
    5 (compile -O3 -d0 -s typed-sets.import.scm)
     4(compile -O3 -d0 -s list-functor.import.scm)
     5(compile -O3 -d0 -s set-functor.import.scm)
     6(compile -O3 -d0 -s _immutable-lists.import.scm)
     7(process-run "patch immutable-lists.import.scm immutable-lists.patch")
     8(compile -O3 -d0 -s immutable-lists.import.scm)
     9(process-run "patch sets.import.scm sets.patch")
     10(compile -O3 -d0 -s sets.import.scm)
    611
    712(install-extension
    813 'typed-lists
    9  '("typed-lists.so" "typed-lists.import.so" "typed-sets.import.so")
    10  '((version "1.3")))
     14 '("typed-lists.so" "list-functor.import.so" "set-functor.import.so"
     15"_immutable-lists.import.so" "immutable-lists.import.so" "sets.import.so")
     16 '((version "2.0")))
    1117
  • release/4/typed-lists/trunk/tests/run.scm

    r31264 r31337  
    1 (require-library cells simple-tests datatype)
    2 (import typed-lists typed-sets simple-tests datatype)
    3 
    4 (define-test (number-lists?)
    5   (check
    6     ;; argument module
    7     (module numbers (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 numbers))
    23    
    24     ;; import
    25     (import lists cells)
    26 
    27     (define nil (list-null))
    28     (typed-list? nil)
    29     (list-null? nil)
     1(require-library cells simple-tests datatype typed-lists)
     2(import list-functor set-functor simple-tests datatype)
     3
     4;;;;;; test untyped modules
     5
     6(define-test (immutable-lists?)
     7  (check
     8    (import cells
     9            immutable-lists)
     10    (define nil (ilist-null))
     11    (ilist? nil)
     12    (ilist-null? nil)
    3013    (not (null? nil))
    31     (define nls (list-cons 1 nil))
    32     (typed-list? nls)
     14    (define nls (ilist-cons 1 nil))
     15    (ilist? nls)
    3316    nls
    34     (define nlst (typed-list 0 1 (cell 2) 3 4))
    35     (typed-list? nlst)
     17    (define nlst (ilist 0 1 (cell 2) 3 4))
     18    (ilist? nlst)
    3619    (not (list? nlst))
    3720    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))
     21    (= (ilist-apply + 1 2 (ilist 3 4 5)) 15)
     22    (ilist-equal? (ilist-repeat 5 0) (ilist 0 0 0 0 0))
     23    (ilist-equal? (ilist-iterate 5 add1 0) (ilist 0 1 2 3 4))
     24    (ilist-equal? (ilist-iterate-while (lambda (x) (< x 5)) add1 0)
     25                  (ilist 0 1 2 3 4))
     26    (ilist-equal? (ilist-iterate-until (lambda (x) (= x 5)) add1 0)
     27                  (ilist 0 1 2 3 4))
     28    (ilist-equal? (ilist-zip (ilist 1 2 3 4 5) (ilist 10 20 30))
     29                  (ilist 1 10 2 20 3 30 4 5))
     30    (ilist-equal? (ilist-interpose 10 (ilist 1 2 3 4 5))
     31                  (ilist 1 10 2 10 3 10 4 10 5))
     32    (ilist-equal? (ilist-drop 3 nlst) (ilist 3 4))
     33    (ilist-equal? (ilist-drop-while odd? (ilist 1 3 2 4 5))
     34             (ilist 2 4 5))
     35    (ilist-equal? (ilist-take-while odd? (ilist 1 3 2 4 5))
     36                  (ilist 1 3))
     37    (receive (head tail) (ilist-split-with even? (ilist 1 3 2 4 5))
     38      (and (ilist-equal? head (ilist 1 3))
     39           (ilist-equal? tail (ilist 2 4 5))))
     40    (ilist-equal? (ilist-take 2 nlst) (ilist 0 1))
     41    (define nrest (ilist-rest nlst))
    5942    nrest
    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)
     43    (ilist? (ilist-null))
     44    (ilist-null? (ilist-null))
     45    (not (ilist-null? nls))
     46    (not (ilist? '(1 2)))
     47    (ilist-null? (ilist-rest nls))
     48    (= (ilist-first nlst) 0)
     49    (ilist? (ilist-reverse nlst))
     50    (ilist-reverse nlst)
     51    (equal? (ilist->list nlst)
    6952            (list 0 1 (cell 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))
     53    (equal? (ilist-item 2 nlst) (cell 2))
     54    (cell-set! (ilist-item 2 nlst) 20)
     55    (equal? (ilist-item 2 nlst) (cell 20))
     56    (= (cell-ref (ilist-item 2 nlst)) 20)
     57    (= (ilist-length nlst) 5)
     58    (ilist-equal? (ilist-from-upto 2 4 nlst)
     59                  (ilist (cell 20) 3))
     60    (ilist-equal?  (ilist-append (ilist 0 1 2 3)
     61                                 (ilist 4 5 6))
     62                   (ilist 0 1 2 3 4 5 6))
     63    (ilist-equal? (ilist-append
     64                    (ilist 0)
     65                    (ilist 1)
     66                    (ilist 2)
     67                    (ilist 3 4)
     68                    (ilist 5 6 7)
     69                    (ilist 8))
     70                  (ilist 0 1 2 3 4 5 6 7 8))
     71    (ilist-equal? (ilist-map add1
     72                             (ilist 0 1 2 3))
     73                  (ilist 1 2 3 4))
     74    (ilist-equal? (ilist-map +
     75                             (ilist 1 2 3)
     76                             (ilist 10 20 30 40))
     77                  (ilist 11 22 33))
     78    (ilist-equal?
     79      (ilist-mappend ilist (ilist 10 20 30) (ilist 1 2 3 4 5))
     80      (ilist 10 1 20 2 30 3))
     81    (ilist-equal?
     82      (ilist-fold-right ilist-cons (ilist-null) (ilist 0 1 2 3 4))
     83      (ilist 0 1 2 3 4))
     84    (ilist-equal?
     85      (ilist-fold-right ilist-cons (ilist 0 1 2) (ilist 3 4))
     86      (ilist 3 4 0 1 2))
     87    (= (ilist-fold-right * 1 (ilist 1 2 3 4 5)) 120)
     88    (= (ilist-fold-left * 1 (ilist 1 2 3 4 5)) 120)
     89    (= (ilist-fold-left + 0 (ilist 1 2 3) (ilist 10 20 30)) 66)
     90    (equal? (ilist-fold-left cons '(100) (ilist 1 2 3 4))
    10891            '(((((100) . 1) . 2) . 3) . 4))
    10992    (equal?
    11093      (call-with-values
    111         (lambda () (list-reverse (typed-list 1 2 3) (typed-list 10 20 30)))
     94        (lambda () (ilist-reverse (ilist 1 2 3) (ilist 10 20 30)))
    11295        list)
    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))
     96      (list (ilist 3 2 1) (ilist 30 20 10)))
     97    (ilist-equal? (ilist-remove 0 (ilist 1 0 2 0 3 0 4))
     98                  (ilist 1 2 3 4))
     99    (ilist-equal? (ilist-merge < (ilist 2 4 5 7 8) (ilist 1 3 6 9 10))
     100                  (ilist 1 2 3 4 5 6 7 8 9 10))
     101    (not (condition-case (ilist-merge < (ilist-null) (ilist 1 3 2))
    119102           ((exn) #f)))
    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-equal?
    125       (list-cons-sorted <= 2 (typed-list 0 1 2 3 4))
    126       (typed-list 0 1 2 2 3 4))
    127     (list-equal?
    128       (list-cons-sorted <= 5 (typed-list 0 1 2 3 4))
    129       (typed-list 0 1 2 3 4 5))
    130     (list-every? odd? (typed-list 1 3 5))
    131     (list-every? odd? (typed-list))
    132     (= (list-some odd? (typed-list 2 3 5)) 3)
    133     (not (list-some odd? (typed-list 2 4 6)))
    134     (list-not-every? odd? (typed-list 1 2 3))
    135     (list-not-any? odd? (typed-list 2 4 6))
    136     (list-in? (typed-list 2 3) (typed-list 1 2 3))
    137     (not (list-in? (typed-list 1 2 3) (typed-list 2 3)))
    138     (not (list-in? (typed-list 1 2 3) (typed-list 2 1 3)))
    139     (list-in? (typed-list) (typed-list 2 3))
    140     ))
     103    (ilist-equal? (ilist-merge-sort <= (ilist 2 0 1 4 3))
     104                  (ilist 0 1 2 3 4))
     105    (ilist-equal? (ilist-insertion-sort < (ilist 2 0 1 4 3))
     106                  (ilist 0 1 2 3 4))
     107    (not (ilist-sorted? <= (ilist 2 0 1 4 3)))
     108    (ilist-sorted? <= (ilist 0 1 2 3 4))
     109    (ilist-equal?
     110      (ilist-insert-sorted <= 2 (ilist 0 1 2 3 4))
     111      (ilist 0 1 2 2 3 4))
     112    (ilist-equal?
     113      (ilist-insert-sorted <= 5 (ilist 0 1 2 3 4))
     114      (ilist 0 1 2 3 4 5))
     115    (ilist-every? odd? (ilist 1 3 5))
     116    (ilist-every? odd? (ilist))
     117    (= (ilist-some odd? (ilist 2 3 5)) 3)
     118    (not (ilist-some odd? (ilist 2 4 6)))
     119    (ilist-not-every? odd? (ilist 1 2 3))
     120    (ilist-not-any? odd? (ilist 2 4 6))
     121    (ilist-in? (ilist 2 3) (ilist 1 2 3))
     122    (not (ilist-in? (ilist 1 2 3) (ilist 2 3)))
     123    (not (ilist-in? (ilist 1 2 3) (ilist 2 1 3)))
     124    (ilist-in? (ilist) (ilist 2 3))
     125    ))
     126
     127(define-test (sets?)
     128  (check
     129    (import sets immutable-lists)
     130    (set=
     131      (ilist->set (ilist 1 2 1 3 2 3))
     132      (set 3 2 1))
     133    (set? (set 1 2 3))
     134    (set? (set 1 2 2 3))
     135    (set= (set 2 1 3) (set 1 2 2 3))
     136    (set-in? 2 (set 1 1 2 3))
     137    (set<= (set 2 1 2) (set 4 1 2 3 4))
     138    (set=
     139      (set-add 0 (set 1 2 3))
     140      (set 0 1 2 3))
     141    (set=
     142      (set-add 2 (set 1 2 3))
     143      (set 1 2 3))
     144    (= (set-cardinality (set 2 1 2 3 2)) 3)
     145    (set=
     146      (set-remove 2 (set 2 1 2 3 2))
     147      (set 1 3))
     148    (set=
     149      (set 0 1 1 0 2 3 2)
     150      (set 2 3 0 1))
     151    (set=
     152      (set-difference (set 0 2 1 3) (set 1 1))
     153      (set 0 2 3))
     154    (set=
     155      (set-union (set 1 2) (set 2 3) (set 3 4))
     156      (set 1 2 3 4))
     157    (set=
     158      (set-intersection (set 1 2 3 4) (set 2 3 5) (set 3 4))
     159      (set 3))
     160    (set= (set-filter odd? (set 2 1 3 3 1 1)) (set 3 1))
     161    ))
     162
     163;;;;;; test functors
    141164
    142165(define-test (any-lists?)
    143166  (check
    144167    ;; argument module
    145     (module any (type? equ?)
    146       (import scheme)
    147       (define (type? x) #t)
     168    (module any (item? equ?)
     169      (import scheme)
     170      (define (item? x) #t)
    148171      (define (equ? x y) (equal? x y))
    149172      )
    150173    ;; apply functor
    151     (module any-lists = (typed-lists any))
     174    (module any-lists = (list-functor any))
    152175    ;; import
    153     (import (prefix any-lists a) cells)
    154     (define als (alist-repeat 3 (cell #f)))
    155     (atyped-list? als)
     176    (import (prefix any-lists any-) cells)
     177    (define als (any-ilist-repeat 3 (cell #f)))
     178    (any-ilist? als)
    156179    (not (list? als))
    157     (= (alist-length als) 3)
    158     (equal? (atyped-list->untyped-list (alist-map cell-ref als))
     180    (= (any-ilist-length als) 3)
     181    (equal? (any-ilist->list (any-ilist-map cell-ref als))
    159182            (make-list 3))
    160     (define alst (atyped-list (lambda (x) #f) 'a "x" (cell 3) #\z))
    161     (procedure? (alist-first alst))
    162     (alist-equal? (alist-memp cell? alst)
    163                   (atyped-list (cell 3) #\z))
    164     (alist-equal? (alist-member #\z alst)
    165              (alist-cons #\z (alist-null)))
     183    (define alst (any-ilist (lambda (x) #f) 'a "x" (cell 3) #\z))
     184    (procedure? (any-ilist-first alst))
     185    (any-ilist-equal? (any-ilist-memp cell? alst)
     186                  (any-ilist (cell 3) #\z))
     187    (any-ilist-equal? (any-ilist-member #\z alst)
     188             (any-ilist-cons #\z (any-ilist-null)))
    166189    ))
    167190
     
    169192(define-test (string-lists?)
    170193  (check
    171     (module strings (equ? type?)
     194    (module strings (equ? item?)
    172195      (import scheme)
    173196      (define equ? string=?)
    174       (define type? string?))
    175     (module string-lists = (typed-lists strings))
     197      (define item? string?))
     198    (module string-lists = (list-functor strings))
    176199    (import (prefix string-lists str-))
    177     (str-list-equal?
    178       (str-list-append (str-typed-list "a" "b")
    179                    (str-typed-list "c"))
    180       (str-typed-list "a" "b" "c"))
     200    (str-ilist-equal?
     201      (str-ilist-append (str-ilist "a" "b")
     202                   (str-ilist "c"))
     203      (str-ilist "a" "b" "c"))
    181204    ))
    182205
    183206(define-test (symbol-lists?)
    184207  (check
    185     (module symbols (equ? type?)
     208    (module symbols (equ? item?)
    186209      (import scheme)
    187210      (define equ? eq?)
    188       (define type? symbol?))
    189     (module symbol-lists = (typed-lists symbols))
     211      (define item? symbol?))
     212    (module symbol-lists = (list-functor symbols))
    190213    (import (prefix symbol-lists sym-))
    191     (sym-list-equal?
    192       (sym-list-append (sym-typed-list 'a 'b)
    193                    (sym-typed-list 'c))
    194       (sym-typed-list 'a 'b 'c))
     214    (sym-ilist-equal?
     215      (sym-ilist-append (sym-ilist 'a 'b)
     216                   (sym-ilist 'c))
     217      (sym-ilist 'a 'b 'c))
    195218    (equal?
    196       (sym-list-bind (x y z) (sym-typed-list 'a 'b 'c) (list x y z))
     219      (sym-ilist-bind (x y z) (sym-ilist 'a 'b 'c) (list x y z))
    197220      '(a b c))
    198     (sym-list-equal?
    199         (sym-list-bind (x . y) (sym-typed-list 'a 'b 'c) y)
    200       (sym-typed-list 'b 'c))
     221    (sym-ilist-equal?
     222        (sym-ilist-bind (x . y) (sym-ilist 'a 'b 'c) y)
     223      (sym-ilist 'b 'c))
    201224    (xpr:val
    202       (sym-list-bind (x . y) (sym-typed-list 'a 'b) (list x y)))
    203     (sym-list-null? (sym-list-bind x (sym-list-null) x))
    204     (sym-list-bind () (sym-list-null) #t)
     225      (sym-ilist-bind (x . y) (sym-ilist 'a 'b) (list x y)))
     226    (sym-ilist-null? (sym-ilist-bind x (sym-ilist-null) x))
     227    (sym-ilist-bind () (sym-ilist-null) #t)
    205228    ))
    206229
    207230(define-test (list-lists?)
    208231  (check
    209     (module lists (equ? type?)
     232    (module lists (equ? item?)
    210233      (import scheme
    211234              (only data-structures list-of?)
    212235              (only chicken condition-case))
    213236      (define equ? equal?)
    214       (define type? (list-of? symbol?)));list?))
    215     (module list-lists = (typed-lists lists))
    216     (import (prefix list-lists l))
    217     (not (condition-case (llist-cons '(1) (llist-null))
     237      (define item? (list-of? symbol?)))
     238    (module list-lists = (list-functor lists))
     239    (import (prefix list-lists lst-))
     240    (not (condition-case (lst-ilist-cons '(1) (lst-ilist-null))
    218241           ((exn) #f)))
    219     (llist-equal?
    220       (llist-append
    221         (ltyped-list '(a) '(b))
    222         (ltyped-list '(c)))
    223       (ltyped-list '(a) '(b) '(c)))
     242    (lst-ilist-equal?
     243      (lst-ilist-append
     244        (lst-ilist '(a) '(b))
     245        (lst-ilist '(c)))
     246      (lst-ilist '(a) '(b) '(c)))
    224247    ))
    225248
    226249(define-test (pair-lists?)
    227250  (check
    228     (module pairs (type? equ?)
    229       (import scheme)
    230       (define (type? x)
     251    (module pairs (item? equ?)
     252      (import scheme)
     253      (define (item? x)
    231254        (and (pair? x) (number? (car x)) (string? (cdr x))))
    232255      (define equ? equal?))
    233     (module pair-lists = (typed-lists pairs))
     256    (module pair-lists = (list-functor pairs))
    234257    (import (prefix pair-lists nsp-))
    235     (define nspl (nsp-typed-list (cons 1 "one") (cons 2 "two") (cons 3 "three")))
    236     (equal? (nsp-list-assoc 2 nspl) '(2 . "two"))
    237     (not (nsp-list-assp zero? nspl))
    238     ))
    239 
    240 (define-test (sets?)
     258    (define nspl (nsp-ilist (cons 1 "one") (cons 2 "two") (cons 3 "three")))
     259    (equal? (nsp-ilist-assoc 2 nspl) '(2 . "two"))
     260    (not (nsp-ilist-assp zero? nspl))
     261    ))
     262
     263(define-test (num-sets?)
    241264  (check
    242265    ;; argument module
    243     (module nums (type? equ?)
    244       (import scheme)
    245       (define type? number?)
     266    (module nums (item? equ?)
     267      (import scheme)
     268      (define item? number?)
    246269      (define equ? =)
    247270      )
    248271    ;; apply functors
    249     (module num-lists = (typed-lists nums))
    250     (module num-sets = (typed-sets nums num-lists))
     272    (module num-lists = (list-functor nums))
     273    (module num-sets = (set-functor nums num-lists))
    251274    ;; import
    252275    (import (prefix num-lists num-)
    253276            (prefix num-sets num-))
    254277    (num-set=
    255       (num-typed-list->set (num-typed-list 1 2 1 3 2 3))
     278      (num-ilist->set (num-ilist 1 2 1 3 2 3))
    256279      (num-set 3 2 1))
    257280    (num-set? (num-set 1 2 3))
     
    287310
    288311(compound-test (TYPED-LISTS-AND-SETS)
    289   (number-lists?)
     312  (immutable-lists?)
     313  (sets?)
    290314  (any-lists?)
    291315  (string-lists?)
     
    293317  (list-lists?)
    294318  (pair-lists?)
    295   (sets?)
     319  (num-sets?)
    296320  )
  • release/4/typed-lists/trunk/typed-lists.scm

    r31264 r31337  
    3737
    3838(define-interface LISTS
    39   (typed-lists typed-list? typed-list untyped-list->typed-list typed-list->untyped-list
    40    list-apply list-null list-null? list-cons list-first list-rest list-reverse
    41    list-length list-item list-map list-for-each list-append list-mappend
    42    list-from-upto list-split-at list-split-with list-equal? list-member
    43    list-memp list-remp list-remove list-remove-dups list-assp list-assoc
    44    list-filter list-fold-left list-fold-right list-merge list-sort
    45    list-sorted? list-cons-sorted
    46    list-drop list-drop-while list-take list-take-while list-repeat list-iterate
    47    list-iterate-while list-iterate-until list-zip list-interpose list-every?
    48    list-some list-not-every? list-not-any? list-in? list-bind))
     39  (ilists ilist? ilist list->ilist ilist->list
     40   ilist-apply ilist-null ilist-null? ilist-cons ilist-first ilist-rest ilist-reverse
     41   ilist-length ilist-item ilist-map ilist-for-each ilist-append ilist-mappend
     42   ilist-from-upto ilist-split-at ilist-split-with ilist-equal? ilist-member
     43   ilist-memp ilist-remp ilist-remove ilist-remove-dups ilist-assp ilist-assoc
     44   ilist-filter ilist-fold-left ilist-fold-right ilist-merge ilist-merge-sort
     45   ilist-insertion-sort ilist-sorted? ilist-insert-sorted
     46   ilist-drop ilist-drop-while ilist-take ilist-take-while ilist-repeat ilist-iterate
     47   ilist-iterate-while ilist-iterate-until ilist-zip ilist-interpose ilist-every?
     48   ilist-some ilist-not-every? ilist-not-any? ilist-in? ilist-bind))
    4949
    5050(define-interface SETS
    51    (sets set? set typed-list->set set->typed-list set-in?  set-cardinality
     51   (sets set? set ilist->set set->ilist set-in?  set-cardinality
    5252    set-filter set-null? set-difference set-add set-remove
    5353    set= set>= set<= set-union set-intersection))
    5454
    55 (functor (typed-lists (M (type? equ?))) LISTS
    56 
     55(functor (list-functor (M (item? equ?))) LISTS
    5756
    5857(import scheme
    5958        (only chicken error define-record-printer
    6059              unless receive case-lambda)
    61         (only data-structures list-of? o compose)
     60        (only data-structures list-of? o)
    6261        (only extras sprintf)
    6362        datatype
    6463        M)
    6564
    66 (import-for-syntax (only chicken receive print))
    67 
    68 (define-datatype typed-list typed-list?
    69   (list-null)
    70   (list-cons
    71     (first type?)
    72     (rest typed-list?)))
    73 
    74 (define-record-printer (typed-list tlst out)
    75   (let ((str (sprintf "~s" (typed-list->untyped-list tlst))))
     65(import-for-syntax (only chicken receive))
     66
     67(define-datatype ilist ilist?
     68  (ilist-null)
     69  (ilist-cons
     70    (first item?)
     71    (rest ilist?)))
     72
     73(define-record-printer (ilist ilst out)
     74  (let ((str (sprintf "~s" (ilist->list ilst))))
    7675    (string-set! str (- (string-length str) 1) #\])
    7776    (string-set! str 0 #\[)
    7877    (display str out)))
    7978
    80 ;(define-reader-ctor 'typed typed-list)
    81 
    82 (define (list-null? xpr)
    83   (and (typed-list? xpr)
    84        (cases typed-list xpr
    85          (list-null () #t)
    86          (list-cons (first rest) #f))))
    87 
    88 (define (list-first lst)
    89   (cases typed-list lst
    90     (list-null () (error 'list-first "list empty" lst))
    91     (list-cons (first rest) first)))
    92 
    93 (define (list-rest lst)
    94   (cases typed-list lst
    95     (list-null () (error 'list-rest "list empty" lst))
    96     (list-cons (first rest) rest)))
    97 
    98 (define-syntax list-bind
     79;(define-reader-ctor 'typed ilist)
     80
     81(define (ilist-null? xpr)
     82  (and (ilist? xpr)
     83       (cases ilist xpr
     84         (ilist-null () #t)
     85         (ilist-cons (first rest) #f))))
     86
     87(define (ilist-first lst)
     88  (cases ilist lst
     89    (ilist-null () (error 'ilist-first "list empty" lst))
     90    (ilist-cons (first rest) first)))
     91
     92(define (ilist-rest lst)
     93  (cases ilist lst
     94    (ilist-null () (error 'ilist-rest "list empty" lst))
     95    (ilist-cons (first rest) rest)))
     96
     97(define-syntax ilist-bind
    9998  (ir-macro-transformer
    10099    (lambda (form inject compare?)
    101100      (let ((pat (cadr form))
    102             (tlst (caddr form))
     101            (ilst (caddr form))
    103102            (xpr (caddr form))
    104103            (xprs (cdddr form)))
    105         (let ((tlst tlst))
     104        (let ((ilst ilst))
    106105                    ;; not available at compile time
    107                     ;(if (typed-list? tlst)
    108                     ;  tlst
    109                     ;  (error 'list-bind
     106                    ;(if (ilist? ilst)
     107                    ;  ilst
     108                    ;  (error 'ilist-bind
    110109                    ;         "not a typed list"
    111                     ;         tlst))))
     110                    ;         ilst))))
    112111          (if (list? pat)
    113             `(if (= ,(length pat) (list-length ,tlst))
    114                (list-apply (lambda ,pat ,xpr ,@xprs) ,tlst)
    115                (error 'list-bind "match error" ',pat ,tlst))
     112            `(if (= ,(length pat) (ilist-length ,ilst))
     113               (ilist-apply (lambda ,pat ,xpr ,@xprs) ,ilst)
     114               (error 'ilist-bind "match error" ',pat ,ilst))
    116115            ;; pseudolist: separate list part
    117116            (receive (head tail)
     
    120119                  (loop (cdr pat) (cons (car pat) lst))
    121120                  (values (reverse lst) pat)))
    122               `(if (<= ,(length head) (list-length ,tlst))
    123                  (receive (hd tl) (list-split-at ,(length head) ,tlst)
     121              `(if (<= ,(length head) (ilist-length ,ilst))
     122                 (receive (hd tl) (ilist-split-at ,(length head) ,ilst)
    124123                   (let ((,tail tl))
    125                      (list-apply (lambda ,head ,xpr ,@xprs) hd)))
    126                  (error 'list-bind "match error" ',pat ,tlst)))))))))
    127 
    128 (define (list-reverse . lsts)
     124                     (ilist-apply (lambda ,head ,xpr ,@xprs) hd)))
     125                 (error 'ilist-bind "match error" ',pat ,ilst)))))))))
     126
     127(define (ilist-reverse . lsts)
    129128  (cond
    130129    ((null? lsts)
    131      (list-null))
     130     (ilist-null))
    132131    ((null? (cdr lsts))
    133      (let loop ((ls (car lsts)) (result (list-null)))
    134        (cases typed-list ls
    135          (list-null () result)
    136          (list-cons (first rest)
    137                     (loop rest (list-cons first result))))))
     132     (let loop ((ls (car lsts)) (result (ilist-null)))
     133       (cases ilist ls
     134         (ilist-null () result)
     135         (ilist-cons (first rest)
     136                    (loop rest (ilist-cons first result))))))
    138137    (else
    139138      (let loop (
    140139        (lsts lsts)
    141         (results ;(make-list (length lsts) (list-null)))
     140        (results ;(make-list (length lsts) (ilist-null)))
    142141                 (let recur ((n (length lsts))
    143142                             (result '()))
    144143                   (if (zero? n)
    145144                     result
    146                      (recur (- n 1) (cons (list-null) result)))))
     145                     (recur (- n 1) (cons (ilist-null) result)))))
    147146        )
    148147        (cond
    149           (((list-of? list-null?) lsts)
     148          (((list-of? ilist-null?) lsts)
    150149           (apply values results))
    151           (((list-of? (o not list-null?)) lsts)
    152            (loop (map list-rest lsts)
    153                  (map (lambda (l ll) (list-cons l ll))
    154                       (map list-first lsts)
     150          (((list-of? (o not ilist-null?)) lsts)
     151           (loop (map ilist-rest lsts)
     152                 (map (lambda (l ll) (ilist-cons l ll))
     153                      (map ilist-first lsts)
    155154                      results)))
    156           (else (error 'list-reverse "lists not of equal length")))))))
    157 
    158 (define (typed-list . args)
    159   (let loop ((args args) (result (list-null)))
     155          (else (error 'ilist-reverse "lists not of equal length")))))))
     156
     157(define (ilist . args)
     158  (let loop ((args args) (result (ilist-null)))
    160159    (if (null? args)
    161       (list-reverse result)
    162       (loop (cdr args) (list-cons (car args) result)))))
    163 
    164 (define (list-repeat n x)
    165   (let loop ((k 0) (result (list-null)))
     160      (ilist-reverse result)
     161      (loop (cdr args) (ilist-cons (car args) result)))))
     162
     163(define (ilist-repeat n x)
     164  (let loop ((k 0) (result (ilist-null)))
    166165    (if (= k n)
    167166      result
    168       (loop (+ k 1) (list-cons x result)))))
    169 
    170 (define (list-iterate n fn x)
    171   (let loop ((k 0) (val x) (result (list-null)))
     167      (loop (+ k 1) (ilist-cons x result)))))
     168
     169(define (ilist-iterate n fn x)
     170  (let loop ((k 0) (val x) (result (ilist-null)))
    172171    (if (= k n)
    173       (list-reverse result)
    174       (loop (+ k 1) (fn val) (list-cons val result)))))
    175 
    176 (define (list-iterate-while ok? fn x)
    177   (let loop ((val x) (result (list-null)))
     172      (ilist-reverse result)
     173      (loop (+ k 1) (fn val) (ilist-cons val result)))))
     174
     175(define (ilist-iterate-while ok? fn x)
     176  (let loop ((val x) (result (ilist-null)))
    178177    (if (ok? val)
    179       (loop (fn val) (list-cons val result))
    180       (list-reverse result))))
    181 
    182 (define (list-iterate-until ok? fn x)
    183   (let loop ((val x) (result (list-null)))
     178      (loop (fn val) (ilist-cons val result))
     179      (ilist-reverse result))))
     180
     181(define (ilist-iterate-until ok? fn x)
     182  (let loop ((val x) (result (ilist-null)))
    184183    (if (ok? val)
    185       (list-reverse result)
    186       (loop (fn val) (list-cons val result)))))
    187 
    188 (define (typed-list->untyped-list lst)
     184      (ilist-reverse result)
     185      (loop (fn val) (ilist-cons val result)))))
     186
     187(define (ilist->list lst)
    189188  (let loop ((ls lst) (result '()))
    190     (cases typed-list ls
    191       (list-null () (reverse result))
    192       (list-cons (first rest)
     189    (cases ilist ls
     190      (ilist-null () (reverse result))
     191      (ilist-cons (first rest)
    193192       (loop rest (cons first result))))))
    194193
    195 (define (list-apply fn . args)
     194(define (ilist-apply fn . args)
    196195  (let ((len (length args)))
    197196    (apply fn
     
    201200          ((= k (- len 1))
    202201           (let ((tail (list-ref args k)))
    203              (if (typed-list? tail)
     202             (if (ilist? tail)
    204203               (loop (+ k 1)
    205204                     (append
    206205                       (reverse
    207                          (typed-list->untyped-list tail))
     206                         (ilist->list tail))
    208207                       result))
    209                (error 'list-apply
     208               (error 'ilist-apply
    210209                      (string-append
    211210                        "not a "
     
    215214          (else
    216215            (let ((item (list-ref args k)))
    217               (if (type? item)
     216              (if (item? item)
    218217                (loop (+ k 1)
    219218                      (cons item result))
    220                 (error 'list-apply
    221                        "wrong list-ype"
    222                        `(,type? ,item))))))))))
    223 
    224 (define (untyped-list->typed-list lst)
    225   (apply typed-list lst))
    226 
    227 (define (list-length lst)
     219                (error 'ilist-apply
     220                       "wrong ilist-ype"
     221                       `(,item? ,item))))))))))
     222
     223(define (list->ilist lst)
     224  (apply ilist lst))
     225
     226(define (ilist-length lst)
    228227  (let loop ((ls lst) (k 0))
    229     (cases typed-list ls
    230       (list-null () k)
    231       (list-cons (first rest)
     228    (cases ilist ls
     229      (ilist-null () k)
     230      (ilist-cons (first rest)
    232231        (loop rest (+ k 1))))))
    233232
    234 (define (list-item k lst)
     233(define (ilist-item k lst)
    235234  (let loop ((ls lst) (n 0))
    236     (cases typed-list ls
    237       (list-null () (error 'list-item "range error"))
    238       (list-cons (first rest)
     235    (cases ilist ls
     236      (ilist-null () (error 'ilist-item "range error"))
     237      (ilist-cons (first rest)
    239238        (if (= n k)
    240239          first
    241240          (loop rest (+ n 1)))))))
    242241
    243 (define (list-from-upto from upto lst)
    244   (let loop ((ls lst) (k 0) (result (list-null)))
    245     (cases typed-list ls
    246       (list-null () (list-reverse result))
    247       (list-cons (first rest)
     242(define (ilist-from-upto from upto lst)
     243  (let loop ((ls lst) (k 0) (result (ilist-null)))
     244    (cases ilist ls
     245      (ilist-null () (ilist-reverse result))
     246      (ilist-cons (first rest)
    248247        (cond
    249248          ((= k upto)
    250            (list-reverse result))
     249           (ilist-reverse result))
    251250          ((< k from)
    252251           (loop rest (+ k 1) result))
    253252          (else
    254             (loop rest (+ k 1) (list-cons first result))))))))
    255 
    256 (define (list-split-at k lst)
    257   (let loop ((ls lst) (n 0) (head (list-null)))
    258     (cases typed-list ls
    259       (list-null () (values (list-reverse head) ls))
    260       (list-cons (first rest)
     253            (loop rest (+ k 1) (ilist-cons first result))))))))
     254
     255(define (ilist-split-at k lst)
     256  (let loop ((ls lst) (n 0) (head (ilist-null)))
     257    (cases ilist ls
     258      (ilist-null () (values (ilist-reverse head) ls))
     259      (ilist-cons (first rest)
    261260        (if (= n k)
    262          (values (list-reverse head) ls)
    263          (loop rest (+ n 1) (list-cons first head)))))))
    264 
    265 (define (list-split-with ok? lst)
    266   (let loop ((ls lst) (head (list-null)))
    267     (cases typed-list ls
    268       (list-null () (values (list-reverse head) ls))
    269       (list-cons (first rest)
     261         (values (ilist-reverse head) ls)
     262         (loop rest (+ n 1) (ilist-cons first head)))))))
     263
     264(define (ilist-split-with ok? lst)
     265  (let loop ((ls lst) (head (ilist-null)))
     266    (cases ilist ls
     267      (ilist-null () (values (ilist-reverse head) ls))
     268      (ilist-cons (first rest)
    270269        (if (ok? first)
    271           (values (list-reverse head) ls)
    272           (loop rest (list-cons first head)))))))
    273 
    274 (define (list-take k lst)
     270          (values (ilist-reverse head) ls)
     271          (loop rest (ilist-cons first head)))))))
     272
     273(define (ilist-take k lst)
    275274  (call-with-values
    276     (lambda () (list-split-at k lst))
     275    (lambda () (ilist-split-at k lst))
    277276    (lambda (head tail) head)))
    278277
    279 (define (list-take-while ok? lst)
     278(define (ilist-take-while ok? lst)
    280279  (call-with-values
    281     (lambda () (list-split-with (o not ok?) lst))
     280    (lambda () (ilist-split-with (o not ok?) lst))
    282281    (lambda (head tail) head)))
    283282
    284 (define (list-drop k lst)
     283(define (ilist-drop k lst)
    285284  (call-with-values
    286     (lambda () (list-split-at k lst))
     285    (lambda () (ilist-split-at k lst))
    287286    (lambda (head tail) tail)))
    288287
    289 (define (list-drop-while ok? lst)
     288(define (ilist-drop-while ok? lst)
    290289  (call-with-values
    291     (lambda () (list-split-with (o not ok?) lst))
     290    (lambda () (ilist-split-with (o not ok?) lst))
    292291    (lambda (head tail) tail)))
    293292
    294 (define (list-append . lsts)
     293(define (ilist-append . lsts)
    295294  (cond
    296295    ((null? lsts)
    297      (list-null))
     296     (ilist-null))
    298297    ((null? (cdr lsts))
    299298     (car lsts))
    300299    ((null? (cddr lsts))
    301      (let loop ((ls0 (list-reverse (car lsts)))
     300     (let loop ((ls0 (ilist-reverse (car lsts)))
    302301                (result (cadr lsts)))
    303        (cases typed-list ls0
    304          (list-null () result)
    305          (list-cons (first rest)
    306                  (loop rest (list-cons first result))))))
     302       (cases ilist ls0
     303         (ilist-null () result)
     304         (ilist-cons (first rest)
     305                 (loop rest (ilist-cons first result))))))
    307306    (else
    308       (list-append (car lsts)
    309                 (apply list-append (cdr lsts))))))
    310 
    311 (define (list-mappend fn . lsts)
    312   (apply list-append
     307      (ilist-append (car lsts)
     308                (apply ilist-append (cdr lsts))))))
     309
     310(define (ilist-mappend fn . lsts)
     311  (apply ilist-append
    313312         (apply map fn
    314                 (map typed-list->untyped-list lsts))))
    315 
    316 (define (list-map fn . lsts)
     313                (map ilist->list lsts))))
     314
     315(define (ilist-map fn . lsts)
    317316  (if (null? lsts)
    318     (list-null)
    319     (let loop ((lsts lsts) (result (list-null)))
    320       (if (memq #t (map list-null? lsts))
    321         (list-reverse result)
    322         (loop (map list-rest lsts)
    323               (list-cons (apply fn (map list-first lsts))
     317    (ilist-null)
     318    (let loop ((lsts lsts) (result (ilist-null)))
     319      (if (memq #t (map ilist-null? lsts))
     320        (ilist-reverse result)
     321        (loop (map ilist-rest lsts)
     322              (ilist-cons (apply fn (map ilist-first lsts))
    324323                      result))))))
    325324
    326 (define (list-for-each fn . lsts)
     325(define (ilist-for-each fn . lsts)
    327326  (unless (null? lsts)
    328     (do ((lsts lsts (map list-rest lsts)))
    329       ((memq #t (map list-null? lsts)))
    330       (apply fn (map list-first lsts)))))
    331 
    332 (define (list-filter ok? lst)
    333   (let loop ((ls lst) (yes (list-null)) (no (list-null)))
    334     (cases typed-list ls
    335       (list-null ()
    336         (values (list-reverse yes) (list-reverse no)))
    337       (list-cons (first rest)
     327    (do ((lsts lsts (map ilist-rest lsts)))
     328      ((memq #t (map ilist-null? lsts)))
     329      (apply fn (map ilist-first lsts)))))
     330
     331(define (ilist-filter ok? lst)
     332  (let loop ((ls lst) (yes (ilist-null)) (no (ilist-null)))
     333    (cases ilist ls
     334      (ilist-null ()
     335        (values (ilist-reverse yes) (ilist-reverse no)))
     336      (ilist-cons (first rest)
    338337         (if (ok? first)
    339            (loop rest (list-cons first yes) no)
    340            (loop rest yes (list-cons first no)))))))
    341 
    342 (define (list-equal? lst0 lst1)
     338           (loop rest (ilist-cons first yes) no)
     339           (loop rest yes (ilist-cons first no)))))))
     340
     341(define (ilist-equal? lst0 lst1)
    343342  (let loop ((ls0 lst0) (ls1 lst1))
    344343    (cond
    345       ((list-null? ls0)
    346        (list-null? ls1))
    347       ((list-null? ls1)
    348        (list-null? ls0))
     344      ((ilist-null? ls0)
     345       (ilist-null? ls1))
     346      ((ilist-null? ls1)
     347       (ilist-null? ls0))
    349348      (else
    350         (and (equ? (list-first ls0)
    351                     (list-first ls1))
    352              (loop (list-rest ls0)
    353                    (list-rest ls1)))))))
    354 
    355 (define (list-memp ok? lst)
     349        (and (equ? (ilist-first ls0)
     350                    (ilist-first ls1))
     351             (loop (ilist-rest ls0)
     352                   (ilist-rest ls1)))))))
     353
     354(define (ilist-memp ok? lst)
    356355  (let loop ((ls lst))
    357     (cases typed-list ls
    358       (list-null () #f)
    359       (list-cons (first rest)
     356    (cases ilist ls
     357      (ilist-null () #f)
     358      (ilist-cons (first rest)
    360359         (if (ok? first)
    361360           ls
    362361           (loop rest))))))
    363362
    364 (define (list-member item lst)
    365   (list-memp (lambda (x) (equ? x item)) lst))
    366 
    367 (define (list-remp ok? lst)
    368   (call-with-values (lambda () (list-filter ok? lst))
     363(define (ilist-member item lst)
     364  (ilist-memp (lambda (x) (equ? x item)) lst))
     365
     366(define (ilist-remp ok? lst)
     367  (call-with-values (lambda () (ilist-filter ok? lst))
    369368                    (lambda (a b) b)))
    370369
    371 (define (list-remove item lst)
    372   (list-remp (lambda (x) (equ? item x)) lst))
    373 
    374 (define (list-adjoin item lst)
    375   (if (list-member item lst)
     370(define (ilist-remove item lst)
     371  (ilist-remp (lambda (x) (equ? item x)) lst))
     372
     373(define (ilist-adjoin item lst)
     374  (if (ilist-member item lst)
    376375    lst
    377     (list-cons item lst)))
    378 
    379 (define (list-remove-dups lst)
    380   (let loop ((ls lst) (result (list-null)))
    381     (cases typed-list ls
    382       (list-null () result)
    383       (list-cons (first rest)
    384               (loop rest (list-adjoin first result))))))
    385 
    386 (define (list-assp ok? lst)
     376    (ilist-cons item lst)))
     377
     378(define (ilist-remove-dups lst)
     379  (let loop ((ls lst) (result (ilist-null)))
     380    (cases ilist ls
     381      (ilist-null () result)
     382      (ilist-cons (first rest)
     383              (loop rest (ilist-adjoin first result))))))
     384
     385(define (ilist-assp ok? lst)
    387386  (let loop ((ls lst))
    388     (cases typed-list ls
    389       (list-null () #f)
    390       (list-cons (first rest)
     387    (cases ilist ls
     388      (ilist-null () #f)
     389      (ilist-cons (first rest)
    391390        (if (ok? (car first))
    392391          first
    393392          (loop rest))))))
    394393
    395 (define (list-assoc item lst)
    396   (list-assp (lambda (x) (equ? item x)) lst))
    397 
    398 (define (list-fold-left op base . lsts)
     394(define (ilist-assoc item lst)
     395  (ilist-assp (lambda (x) (equ? item x)) lst))
     396
     397(define (ilist-fold-left op base . lsts)
    399398  (cond
    400399    ((null? lsts) base)
    401400    ((null? (cdr lsts))
    402401     (let loop ((lst (car lsts)) (result base))
    403        (if (list-null? lst)
     402       (if (ilist-null? lst)
    404403         result
    405          (loop (list-rest lst)
    406                (op result (list-first lst))))))
     404         (loop (ilist-rest lst)
     405               (op result (ilist-first lst))))))
    407406    (else
    408407      (let loop ((lsts lsts) (result base))
    409408        (cond
    410           (((list-of? list-null?) lsts)
     409          (((list-of? ilist-null?) lsts)
    411410           result)
    412           (((list-of? (o not list-null?)) lsts)
    413            (loop (map list-rest lsts)
    414                  (apply op result (map list-first lsts))))
     411          (((list-of? (o not ilist-null?)) lsts)
     412           (loop (map ilist-rest lsts)
     413                 (apply op result (map ilist-first lsts))))
    415414          (else
    416             (error 'list-fold-left "lists not of equal length")))))))
    417 
    418 (define (list-fold-right op base . lsts)
     415            (error 'ilist-fold-left "lists not of equal length")))))))
     416
     417(define (ilist-fold-right op base . lsts)
    419418  (cond
    420419    ((null? lsts) base)
    421420    ((null? (cdr lsts))
    422      (let loop ((lst (list-reverse (car lsts)))
     421     (let loop ((lst (ilist-reverse (car lsts)))
    423422                (result base))
    424        (if (list-null? lst)
     423       (if (ilist-null? lst)
    425424         result
    426          (loop (list-rest lst)
    427                (op (list-first lst) result)))))
     425         (loop (ilist-rest lst)
     426               (op (ilist-first lst) result)))))
    428427    (else
    429428      (let loop (
    430         ;; checking for equal length is done by list-reverse
     429        ;; checking for equal length is done by ilist-reverse
    431430        (lsts (call-with-values
    432                 (lambda () (apply list-reverse lsts))
     431                (lambda () (apply ilist-reverse lsts))
    433432                list))
    434433        (result base)
    435434        )
    436         (if ((list-of? list-null?) lsts)
     435        (if ((list-of? ilist-null?) lsts)
    437436          result
    438           (loop (map list-rest lsts)
     437          (loop (map ilist-rest lsts)
    439438                (apply op
    440                        (append (map list-first lsts)
     439                       (append (map ilist-first lsts)
    441440                               (list result)))))))))
    442441
    443 (define (list-merge <? lst0 lst1)
     442(define (ilist-merge <? lst0 lst1)
    444443  ;; without sorted checks, not tail recursive
    445444  ;(let loop ((ls0 lst0) (ls1 lst1))
    446445  ;  (cond
    447   ;    ((list-null? ls0) ls1)
    448   ;    ((list-null? ls1) ls0)
    449   ;    ((<? (list-first ls0) (list-first ls1))
    450   ;     (list-cons (list-first ls0)
    451   ;             (loop (list-rest ls0) ls1)))
     446  ;    ((ilist-null? ls0) ls1)
     447  ;    ((ilist-null? ls1) ls0)
     448  ;    ((<? (ilist-first ls0) (ilist-first ls1))
     449  ;     (ilist-cons (ilist-first ls0)
     450  ;             (loop (ilist-rest ls0) ls1)))
    452451  ;    (else
    453   ;     (list-cons (list-first ls1)
    454   ;             (loop ls0 (list-rest ls1)))))))
     452  ;     (ilist-cons (ilist-first ls1)
     453  ;             (loop ls0 (ilist-rest ls1)))))))
    455454  ;; tail recursive, with sorted checks
    456   (let loop ((ls0 lst0) (ls1 lst1) (result (list-null)))
     455  (let loop ((ls0 lst0) (ls1 lst1) (result (ilist-null)))
    457456    (cond
    458       ((and (list-null? ls0) (list-null? ls1))
    459        (list-reverse result))
    460       ((list-null? ls0)
    461        (if (or (list-null? (list-rest ls1))
    462                (<? (list-first ls1) (list-first (list-rest ls1))))
    463          (loop ls0 (list-rest ls1) (list-cons (list-first ls1) result))
    464          (error 'list-merge "not sorted" lst1)))
    465       ((list-null? ls1)
    466        (if (or (list-null? (list-rest ls0))
    467                (<? (list-first ls0) (list-first (list-rest ls0))))
    468          (loop (list-rest ls0) ls1 (list-cons (list-first ls0) result))
    469          (error 'list-merge "not sorted" lst1)))
    470       ((not (or (list-null? (list-rest ls0))
    471                 (<? (list-first ls0) (list-first (list-rest ls0)))))
    472        (error 'list-merge "not sorted" lst0))
    473       ((not (or (list-null? (list-rest ls1))
    474                 (<? (list-first ls1) (list-first (list-rest ls1)))))
    475        (error 'list-merge "not sorted" lst1))
     457      ((and (ilist-null? ls0) (ilist-null? ls1))
     458       (ilist-reverse result))
     459      ((ilist-null? ls0)
     460       (if (or (ilist-null? (ilist-rest ls1))
     461               (<? (ilist-first ls1) (ilist-first (ilist-rest ls1))))
     462         (loop ls0 (ilist-rest ls1) (ilist-cons (ilist-first ls1) result))
     463         (error 'ilist-merge "not sorted" lst1)))
     464      ((ilist-null? ls1)
     465       (if (or (ilist-null? (ilist-rest ls0))
     466               (<? (ilist-first ls0) (ilist-first (ilist-rest ls0))))
     467         (loop (ilist-rest ls0) ls1 (ilist-cons (ilist-first ls0) result))
     468         (error 'ilist-merge "not sorted" lst1)))
     469      ((not (or (ilist-null? (ilist-rest ls0))
     470                (<? (ilist-first ls0) (ilist-first (ilist-rest ls0)))))
     471       (error 'ilist-merge "not sorted" lst0))
     472      ((not (or (ilist-null? (ilist-rest ls1))
     473                (<? (ilist-first ls1) (ilist-first (ilist-rest ls1)))))
     474       (error 'ilist-merge "not sorted" lst1))
    476475      (else
    477         (if (<? (list-first ls0) (list-first ls1))
    478           (loop (list-rest ls0) ls1 (list-cons (list-first ls0) result))
    479           (loop ls0 (list-rest ls1) (list-cons (list-first ls1) result))))
     476        (if (<? (ilist-first ls0) (ilist-first ls1))
     477          (loop (ilist-rest ls0) ls1 (ilist-cons (ilist-first ls0) result))
     478          (loop ls0 (ilist-rest ls1) (ilist-cons (ilist-first ls1) result))))
    480479      )))
    481480
    482 (define (list-sort <? lst)
     481(define (ilist-merge-sort <? lst)
    483482  (let loop ((ls lst))
    484     (let ((len (list-length ls)))
     483    (let ((len (ilist-length ls)))
    485484      (if (< len 2)
    486485        ls
    487486        (receive (head tail)
    488           (list-split-at (quotient len 2) ls)
    489           (list-merge <?
     487          (ilist-split-at (quotient len 2) ls)
     488          (ilist-merge <?
    490489                   (loop head)
    491490                   (loop tail)))))))
    492491
    493 (define (list-sorted? <? lst)
     492(define (ilist-insertion-sort <? lst)
     493  (cases ilist lst
     494    (ilist-null () lst)
     495    (ilist-cons (first rest)
     496      (ilist-insert-sorted <?
     497                           first
     498                           (ilist-insertion-sort <? rest)))))
     499
     500(define (ilist-sorted? <? lst)
    494501  (let loop ((ls lst))
    495     (cases typed-list ls
    496       (list-null () #t)
    497       (list-cons (first rest)
     502    (cases ilist ls
     503      (ilist-null () #t)
     504      (ilist-cons (first rest)
    498505        (cond
    499           ((list-null? rest) #t)
    500           ((<? first (list-first rest))
     506          ((ilist-null? rest) #t)
     507          ((<? first (ilist-first rest))
    501508           (loop rest))
    502509          (else #f))))))
    503510
    504 (define (list-cons-sorted <? item lst)
    505   (if (list-sorted? <? lst)
     511(define (ilist-insert-sorted <? item lst)
     512  (if (ilist-sorted? <? lst)
    506513    (let loop ((lst lst))
    507       (cases typed-list lst
    508         (list-null () (list-cons item (list-null)))
    509         (list-cons (first rest)
     514      (cases ilist lst
     515        (ilist-null () (ilist-cons item (ilist-null)))
     516        (ilist-cons (first rest)
    510517          (if (<? item first)
    511             (list-apply typed-list item first rest)
    512             (list-cons first (loop rest))))))
    513     (error 'list-cons-sorted "argument list not sorted" lst)))
    514 
    515 (define (list-zip lst0 lst1)
     518            (ilist-apply ilist item first rest)
     519            (ilist-cons first (loop rest))))))
     520    (error 'ilist-insert-sorted "argument list not sorted" lst)))
     521
     522(define (ilist-zip lst0 lst1)
    516523  (cond
    517     ((list-null? lst0)
     524    ((ilist-null? lst0)
    518525     lst1)
    519526    (else
    520       (list-cons (list-first lst0)
    521               (list-zip lst1 (list-rest lst0))))))
    522 
    523 (define (list-interpose sep lst)
    524   (list-rest
    525     (let loop ((ls lst) (result (list-null)))
    526       (cases typed-list ls
    527         (list-null () (list-reverse result))
    528         (list-cons (first rest)
     527      (ilist-cons (ilist-first lst0)
     528              (ilist-zip lst1 (ilist-rest lst0))))))
     529
     530(define (ilist-interpose sep lst)
     531  (ilist-rest
     532    (let loop ((ls lst) (result (ilist-null)))
     533      (cases ilist ls
     534        (ilist-null () (ilist-reverse result))
     535        (ilist-cons (first rest)
    529536          (loop rest
    530                 (list-cons first (list-cons sep result))))))))
    531                 ;(list-apply typed-list first sep result)))))))
    532 
    533 (define (list-every? ok? lst)
    534   (not (list-memp (o not ok?) lst)))
    535 
    536 (define (list-not-every? ok? lst)
    537   (if (list-memp (o not ok?) lst) #t #f))
    538 
    539 (define (list-not-any? ok? lst)
    540   (if (list-memp ok? lst)
     537                (ilist-cons first (ilist-cons sep result))))))))
     538                ;(ilist-apply ilist first sep result)))))))
     539
     540(define (ilist-every? ok? lst)
     541  (not (ilist-memp (o not ok?) lst)))
     542
     543(define (ilist-not-every? ok? lst)
     544  (if (ilist-memp (o not ok?) lst) #t #f))
     545
     546(define (ilist-not-any? ok? lst)
     547  (if (ilist-memp ok? lst)
    541548    #f
    542549    #t))
    543550
    544 (define (list-some ok? lst)
     551(define (ilist-some ok? lst)
    545552  (let loop ((ls lst))
    546     (cases typed-list ls
    547       (list-null () #f)
    548       (list-cons (first rest)
     553    (cases ilist ls
     554      (ilist-null () #f)
     555      (ilist-cons (first rest)
    549556         (if (ok? first)
    550557           first
    551558           (loop rest))))))
    552559
    553 (define (list-in? tlst1 tlst2)
    554   (cases typed-list tlst1
    555     (list-null () #t)
    556     (list-cons (first rest)
    557       (let ((start (list-member first tlst2)))
     560(define (ilist-in? ilst1 ilst2)
     561  (cases ilist ilst1
     562    (ilist-null () #t)
     563    (ilist-cons (first rest)
     564      (let ((start (ilist-member first ilst2)))
    558565        (if start
    559           (let loop ((ls0 tlst1) (ls1 start))
     566          (let loop ((ls0 ilst1) (ls1 start))
    560567            (cond
    561               ((and (list-null? ls0) (list-null? ls1)) #t)
    562               ((list-null? ls0) #t)
    563               ((list-null? ls1) #f)
    564               ((equ? (list-first ls0) (list-first ls1))
    565                (loop (list-rest ls0) (list-rest ls1)))
     568              ((and (ilist-null? ls0) (ilist-null? ls1)) #t)
     569              ((ilist-null? ls0) #t)
     570              ((ilist-null? ls1) #f)
     571              ((equ? (ilist-first ls0) (ilist-first ls1))
     572               (loop (ilist-rest ls0) (ilist-rest ls1)))
    566573              (else #f)))
    567574          #f)))))
    568575
    569576;;; documentation
    570 (define typed-lists
     577(define ilists
    571578  (let (
    572579    (signatures '(
    573       (typed-list? xpr)
    574       (typed-list . args)
    575       (untyped-list->typed-list tlst)
    576       (list-null)
    577       (list-cons item tlst)
    578       (list-repeat n x)
    579       (list-iterate n fn x)
    580       (list-iterate-while ok? fn x)
    581       (list-iterate-until ok? fn x)
    582 
    583       (typed-list->untyped-list tlst)
    584       (list-apply fn . args)
    585       (list-null? xpr)
    586       (list-first tlst)
    587       (list-rest tlst)
    588       (list-reverse . tlsts)
    589       (list-length tlst)
    590       (list-from-upto from upto tlst) ; sublist
    591       (list-item k tlst) ; ref
    592       (list-split-at k tlst)
    593       (list-split-with ok? tlst)
    594       (list-drop k tlst)
    595       (list-drop-while ok? tlst)
    596       (list-take k tlst)
    597       (list-take-while ok? tlst)
    598       (list-append . tlsts)
    599       (list-map fn . tlsts)
    600       (list-mappend fn . tlsts)
    601       (list-for-each fn . tlsts)
    602       (list-filter ok? tlst)
    603       (list-adjoin item tlst)
    604       (list-equal? tlst0 tlst1)
    605       (list-memp ok? tlst)
    606       (list-member item tlst)
    607       (list-remp ok? tlst)
    608       (list-remove item tlst)
    609       (list-remove-dups tlst)
    610       (list-assp ok? tlst)
    611       (list-assoc item tlst)
    612       (list-fold-left op base . tlsts)
    613       (list-fold-right op base . tlsts)
    614       (list-merge <? tlst0 tlst1)
    615       (list-sort <? tlst)
    616       (list-sorted? <? tlst)
    617       (list-cons-sorted <? item tlst)
    618       (list-zip tlst0 tlst1)
    619       (list-interpose sep tlst)
    620       (list-every? ok? tlst)
    621       (list-some ok? tlst)
    622       (list-not-every? ok? tlst)
    623       (list-not-any? ok? tlst)
    624       (list-in? tlst0 tlst1)
    625       (list-bind (x ... . xs) tlst xpr . xprs)
     580      (ilist? xpr)
     581      (ilist . args)
     582      (list->ilist lst)
     583      (ilist-null)
     584      (ilist-cons item ilst)
     585      (ilist-repeat n x)
     586      (ilist-iterate n fn x)
     587      (ilist-iterate-while ok? fn x)
     588      (ilist-iterate-until ok? fn x)
     589
     590      (ilist->list ilst)
     591      (ilist-apply fn . args)
     592      (ilist-null? xpr)
     593      (ilist-first ilst)
     594      (ilist-rest ilst)
     595      (ilist-reverse . ilsts)
     596      (ilist-length ilst)
     597      (ilist-from-upto from upto ilst) ; sublist
     598      (ilist-item k ilst) ; ref
     599      (ilist-split-at k ilst)
     600      (ilist-split-with ok? ilst)
     601      (ilist-drop k ilst)
     602      (ilist-drop-while ok? ilst)
     603      (ilist-take k ilst)
     604      (ilist-take-while ok? ilst)
     605      (ilist-append . ilsts)
     606      (ilist-map fn . ilsts)
     607      (ilist-mappend fn . ilsts)
     608      (ilist-for-each fn . ilsts)
     609      (ilist-filter ok? ilst)
     610      (ilist-adjoin item ilst)
     611      (ilist-equal? ilst0 ilst1)
     612      (ilist-memp ok? ilst)
     613      (ilist-member item ilst)
     614      (ilist-remp ok? ilst)
     615      (ilist-remove item ilst)
     616      (ilist-remove-dups ilst)
     617      (ilist-assp ok? ilst)
     618      (ilist-assoc item ilst)
     619      (ilist-fold-left op base . ilsts)
     620      (ilist-fold-right op base . ilsts)
     621      (ilist-merge <? ilst0 ilst1)
     622      (ilist-merge-sort <? ilst)
     623      (ilist-insertion-sort <? ilst)
     624      (ilist-sorted? <? ilst)
     625      (ilist-insert-sorted <? item ilst)
     626      (ilist-zip ilst0 ilst1)
     627      (ilist-interpose sep ilst)
     628      (ilist-every? ok? ilst)
     629      (ilist-some ok? ilst)
     630      (ilist-not-every? ok? ilst)
     631      (ilist-not-any? ok? ilst)
     632      (ilist-in? ilst0 ilst1)
     633      (ilist-bind (x ... . xs) ilst xpr . xprs)
    626634      ))
    627635    )
     
    630638      ((sym) (assq sym signatures)))))
    631639
    632 ) ; functor typed-lists
    633 
    634 (functor (typed-sets (M (type? equ?)) (N LISTS)) SETS
     640) ; functor list-functor
     641
     642(functor (set-functor (M (item? equ?)) (N LISTS)) SETS
    635643
    636644(import scheme
    637         (only chicken error define-record-printer
    638               unless receive case-lambda)
    639         (only data-structures list-of? o compose)
     645        (only chicken error define-record-printer case-lambda)
    640646        (only extras sprintf)
    641647        datatype
    642648        M N)
    643649
    644 ;;; sets as typed-lists
     650;;; sets as ilists
    645651
    646652(define-datatype set set?
    647   (typed-list->set (ls typed-list?)))
     653  (ilist->set (ls ilist?)))
    648654
    649655(define (set-add item st)
    650   (typed-list->set
     656  (ilist->set
    651657    (cases set st
    652       (typed-list->set (ls)
    653          (list-cons item ls)))))
     658      (ilist->set (ls)
     659         (ilist-cons item ls)))))
    654660 
    655661(define (set-remove item st)
    656   (typed-list->set
     662  (ilist->set
    657663    (cases set st
    658       (typed-list->set (ls)
    659         (cases typed-list ls
    660           (list-null ()
    661             (list-null))
    662           (list-cons (first rest)
     664      (ilist->set (ls)
     665        (cases ilist ls
     666          (ilist-null ()
     667            (ilist-null))
     668          (ilist-cons (first rest)
    663669            (if (equ? item first)
    664               (list-remove item rest)
    665               (list-cons first
    666                          (list-remove item rest)))))))))
     670              (ilist-remove item rest)
     671              (ilist-cons first
     672                         (ilist-remove item rest)))))))))
    667673     
    668 (define (set->typed-list st)
     674(define (set->ilist st)
    669675  (cases set st
    670     (typed-list->set (st) st)))
     676    (ilist->set (st) st)))
    671677
    672678(define-record-printer (set st out)
    673679  (let ((str (sprintf "~s"
    674                (typed-list->untyped-list
     680               (ilist->list
    675681                 (cases set st
    676                    (typed-list->set (ls)
    677                      (list-remove-dups ls)))))))
     682                   (ilist->set (ls)
     683                     (ilist-remove-dups ls)))))))
    678684    (string-set! str 0 #\{)
    679685    (string-set! str (- (string-length str) 1) #\})
     
    681687
    682688(define (set . args)
    683   (typed-list->set (apply typed-list args)))
     689  (ilist->set (apply ilist args)))
    684690
    685691(define (set-cardinality st)
    686692  (cases set st
    687     (typed-list->set (ls)
    688        (list-length (list-remove-dups ls)))))
     693    (ilist->set (ls)
     694       (ilist-length (ilist-remove-dups ls)))))
    689695
    690696(define (set-in? item st)
    691697  (cases set st
    692     (typed-list->set (ls)
    693       (if (list-member item ls) #t #f))))
     698    (ilist->set (ls)
     699      (if (ilist-member item ls) #t #f))))
    694700
    695701(define (set<= set0 set1)
    696702  (cases set set0
    697     (typed-list->set (ls0)
    698       (list-every?
     703    (ilist->set (ls0)
     704      (ilist-every?
    699705        (lambda (item)
    700           (list-member
     706          (ilist-member
    701707            item
    702708            (cases set set1
    703               (typed-list->set (ls1)
     709              (ilist->set (ls1)
    704710                          ls1))))
    705711        ls0))))
     
    711717       (set<= set1 set0)))
    712718
    713 ;; list-filter not used, to avoid unnessecary reversing
     719;; ilist-filter not used, to avoid unnessecary reversing
    714720(define (set-filter ok? st)
    715721  (cases set st
    716     (typed-list->set (ls)
    717       (let loop ((ls ls) (yes (list-null)) (no (list-null)))
    718         (cases typed-list ls
    719           (list-null ()
    720             (values (typed-list->set yes) (typed-list->set no)))
    721           (list-cons (first rest)
     722    (ilist->set (ls)
     723      (let loop ((ls ls) (yes (ilist-null)) (no (ilist-null)))
     724        (cases ilist ls
     725          (ilist-null ()
     726            (values (ilist->set yes) (ilist->set no)))
     727          (ilist-cons (first rest)
    722728            (if (ok? first)
    723               (loop rest (list-cons first yes) no)
    724               (loop rest yes (list-cons first no)))))))))
     729              (loop rest (ilist-cons first yes) no)
     730              (loop rest yes (ilist-cons first no)))))))))
    725731
    726732(define (set-null? xpr)
    727733  (and (set? xpr)
    728734       (cases set xpr
    729          (typed-list->set (ls) (list-null? ls)))))
     735         (ilist->set (ls) (ilist-null? ls)))))
    730736
    731737(define (set-difference set0 set1)
    732   (let loop ((ls1 (set->typed-list  set1))
    733              (ls0 (set->typed-list set0)))
    734     (cases typed-list ls1
    735       (list-null () (typed-list->set ls0))
    736       (list-cons (first rest)
    737         (loop rest (list-remove first ls0))))))
    738 
    739 ;; list-append not used, list-o avoid unnessecary reversing
     738  (let loop ((ls1 (set->ilist  set1))
     739             (ls0 (set->ilist set0)))
     740    (cases ilist ls1
     741      (ilist-null () (ilist->set ls0))
     742      (ilist-cons (first rest)
     743        (loop rest (ilist-remove first ls0))))))
     744
     745;; ilist-append not used, ilist-o avoid unnessecary reversing
    740746(define (set-union . sts)
    741747  (cond
    742     ((null? sts) (typed-list->set (list-null)))
     748    ((null? sts) (ilist->set (ilist-null)))
    743749    ((null? (cdr sts)) (car sts))
    744750    ((null? (cddr sts))
    745751     (cases set (car sts)
    746        (typed-list->set (ls)
     752       (ilist->set (ls)
    747753         (let loop ((ls ls) (result (cadr sts)))
    748            (cases typed-list ls
    749              (list-null () result)
    750              (list-cons (first rest)
     754           (cases ilist ls
     755             (ilist-null () result)
     756             (ilist-cons (first rest)
    751757               (loop rest
    752758                     (set-add first result))))))))
     
    758764    (cond
    759765      ((null? sts)
    760        (typed-list->set (list-null)))
     766       (ilist->set (ilist-null)))
    761767      ((null? (cdr sts))
    762768       (car sts))
     
    764770       (let ((set1 (cadr sts)))
    765771         (cases set (car sts)
    766            (typed-list->set (ls)
     772           (ilist->set (ls)
    767773             (let loop ((ls ls)
    768                         (result (list-null)))
    769                (cases typed-list ls
    770                  (list-null () (typed-list->set result))
    771                  (list-cons (first rest)
     774                        (result (ilist-null)))
     775               (cases ilist ls
     776                 (ilist-null () (ilist->set result))
     777                 (ilist-cons (first rest)
    772778                   (if (set-in? first set1)
    773779                     (loop rest
    774                            (list-cons first result))
     780                           (ilist-cons first result))
    775781                     (loop rest result)))))))))
    776782      (else
     
    784790      (set? xpr)
    785791      (set . args)
    786       (typed-list->set lst)
    787       (set->typed-list st)
     792      (ilist->set lst)
     793      (set->ilist st)
    788794      (set-in? item st)
    789795      (set<= set0 set1)
     
    804810      ((sym) (assq sym signatures)))))
    805811
    806 ) ; functor typed-sets
    807 
    808 ;(use simple-tests)
    809 ;(import datatype typed-lists)
    810 ;;; argument module
    811 ;(module nums (type? equ?)
    812 ;  (import scheme)
    813 ;  (define type? number?)
    814 ;  (define equ? =))
    815 ;;; apply functor
    816 ;(module num-lists = (typed-lists nums))
    817 ;(module num-sets = (typed-sets nums num-lists))
    818 ;(import num-lists num-sets)
    819 ;
    820 ;(use bindings)
    821 ;(seq-length-ref-tail! typed-list?
    822 ;                      list-length
    823 ;                      (lambda (seq it) (list-item it seq))
    824 ;                      (lambda (seq it) (list-drop it seq)))
    825 ;(xpr:val
    826 ;  (typed-list? (bind (a b . c) (typed-list 1 2 3 4) c))
    827 ;  (set 1 2 1 4 2 4 3 5)
    828 ;  )
     812) ; functor set-functor
     813
     814;;; implicit functor argument _immutable-lists
     815(module immutable-lists = list-functor
     816  (import scheme
     817          (only chicken case-lambda))
     818
     819  (define item? (lambda (x) #t))
     820  (define equ? equal?)
     821  ) ; immutable-lists
     822
     823
     824
     825;;; explicit functor arguments
     826(module sets = (set-functor _immutable-lists immutable-lists))
     827
  • release/4/typed-lists/trunk/typed-lists.setup

    r31264 r31337  
    22
    33(compile -O3 -s -d1 typed-lists.scm -J)
    4 (compile -O3 -d0 -s typed-lists.import.scm)
    5 (compile -O3 -d0 -s typed-sets.import.scm)
     4(compile -O3 -d0 -s list-functor.import.scm)
     5(compile -O3 -d0 -s set-functor.import.scm)
     6(compile -O3 -d0 -s _immutable-lists.import.scm)
     7(process-run "patch immutable-lists.import.scm immutable-lists.patch")
     8(compile -O3 -d0 -s immutable-lists.import.scm)
     9(process-run "patch sets.import.scm sets.patch")
     10(compile -O3 -d0 -s sets.import.scm)
    611
    712(install-extension
    813 'typed-lists
    9  '("typed-lists.so" "typed-lists.import.so" "typed-sets.import.so")
    10  '((version "1.3")))
     14 '("typed-lists.so" "list-functor.import.so" "set-functor.import.so"
     15"_immutable-lists.import.so" "immutable-lists.import.so" "sets.import.so")
     16 '((version "2.0")))
    1117
Note: See TracChangeset for help on using the changeset viewer.