Changeset 39597 in project


Ignore:
Timestamp:
02/15/21 12:17:31 (13 days ago)
Author:
juergen
Message:

pseudolists 3.0

Location:
release/5/pseudolists
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/5/pseudolists/tags/3.0/pseudolists.egg

    r38334 r39597  
    55 (test-dependencies simple-tests)
    66 (author "Juergen Lorenz")
    7  (version "2.0")
     7 (version "3.0")
    88 (components (extension pseudolists
    99                        (csc-options "-d0" "-O3"))))
  • release/5/pseudolists/tags/3.0/pseudolists.scm

    r38334 r39597  
    1 ; Author: Juergen Lorenz ; ju (at jugilo (dot) de
    2 ;
    3 ; Copyright (c) 2013-2020, Juergen Lorenz
     1; Copyright (c) 2013-2021 , Juergen Lorenz, ju (at) jugilo (dot) de
    42; All rights reserved.
    53;
     
    97;
    108; Redistributions of source code must retain the above copyright
    11 ; notice, this list of conditions and the following dispasser.
     9; notice, this list of conditions and the following disclaimer.
    1210;
    1311; Redistributions in binary form must reproduce the above copyright
    14 ; notice, this list of conditions and the following dispasser in the
     12; notice, this list of conditions and the following disclaimer in the
    1513; documentation and/or other materials provided with the distribution.
    16 ;
    1714; Neither the name of the author nor the names of its contributors may be
    1815; used to endorse or promote products derived from this software without
    1916; specific prior written permission.
    20 ;
     17;  
    2118; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
    2219; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
     
    3229
    3330
     31#|[
     32This module exports routines to handle pseudolists as a generalisation
     33of ordinary lists. They can be considered as parametrized (or
     34tagged) lists, where the parameter (or tag) is stored in the sentinel of a
     35dotted list. In such a naive approch, we are faced with two problems.
     36
     37First, since dotted lists differ from lists only insofor, as their
     38sentinels might be arbitrary atoms instead of the empty list. In other
     39words, a dotted list is either a pair or an atom. But since an atom is
     40simply not a pair, everything is a pseudolist, in particular, a list is
     41one. Hence, there is no meaningfull predicate for dotted lists.
     42
     43Second, there is an efficency problem: to get a handle to the sentinel,
     44we have to traverse the whole dotted list. This is not acceptable, if,
     45for example, the parameter is a type predicate to check the type of
     46items to be put into the dotted list. Ok, as in previous versions of
     47this module, we can put the sentinel into a parameter, but this alone
     48doesn't help much, if different parameters are used simultaneously.
     49
     50This module offers a simple solution to both problems: Make the dotted
     51list callable, in other words, put it into a closure and acces the items
     52as well as the sentinel -- and the length for that matter -- via calls
     53to that closure, e.g. (pls i), where i is an index.
     54
     55Note, that most procedures are implemented in a curried and uncurried
     56form, but only the latter is described in detail in the documentation.
     57The former can be used in map and friends.
     58
     59Note also, that the order or arguments of all procedures is consistent:
     60The pseudolist argument(s) are always last, other procedures first.
     61]|#
     62
    3463(module pseudolists (
    35   pl-sentinel pl-check-sentinel? pl-change-sentinel
    36   pl pl-maker pl-null? pl? pl-of?
    37   pl-iterate pl-length pl-head pl-tail
    38   pl-flatten pl-reverse
    39   pl-index pl-filter pl-map pl-for-each
    40   pl-memp pl-member pl-memq pl-memv
    41   pl-adjoin pl-remove-dups
    42   pl-at pl-drop pl-take pl-append
    43   pl-drop-while pl-take-while
    44   pl-fold-right pl-fold-left
    45   pl-fold-right0 pl-fold-left0
    46   pl-collect pseudolists
     64  pl-parameter
     65  pl-checker
     66  pl-checker?
     67  pl
     68  pl?
     69  pl-maker
     70  pl-at
     71  pl-set!
     72  pl-length
     73  pl-null?
     74  pl-head
     75  pl-tail
     76  pl-data
     77  pl-cons
     78  pl-car
     79  pl-cdr
     80  pl-of?
     81  pl-iterate
     82  pl-drop
     83  pl-drop-while
     84  pl-take
     85  pl-take-while
     86  pl-reverse
     87  pl-map
     88  pl-for-each
     89  pl-memp
     90  pl-memq
     91  pl-memv
     92  pl-member
     93  pl-index
     94  pl-filter
     95  pl-append
     96  pl-fold-right
     97  pl-fold-right0
     98  pl-fold-left
     99  pl-fold-left0
     100  pl-adjoin
     101  pl-remove-dups
     102  pl-flat?
     103  pl-flatten
     104  pl-collect
     105  pseudolists
    47106  )
    48107
    49108  (import scheme
    50           (only (chicken base) receive
     109          (only (chicken condition) condition-case)
     110          (only (chicken base) receive gensym parameterize
    51111                unless cut case-lambda assert print error make-parameter))
    52112
    53 (define pl-sentinel
     113#|[
     114(pl-parameter)
     115(pl-parameter new)
     116--- parameter ---
     117returns or resets the sentinel of a pseudolist, initially '()
     118]|#
     119(define pl-parameter
    54120  (make-parameter '()
    55121                  (lambda (x)
     
    58124                      x))))
    59125
    60 (define (pl . args)
    61   (let recur ((args args))
    62     (if (null? args)
    63       (pl-sentinel)
    64       (cons (car args) (recur (cdr args))))))
    65 
     126;(define pl-sentinel pl-parameter) ; deprecated
     127
     128#|[
     129(pl-checker ok? arg)
     130(pl-checker ok?)
     131--- procedure ---
     132type constructor: wrap the predicate ok? into a unary procedure,
     133which returns its argument unchanged, if only it passes the ok? test.
     134An uncurried version is given as well
     135]|#
     136(define pl-checker 'pl-checker)
     137
     138#|[
     139(pl-checker? xpr)
     140--- procedure ---
     141type predicate. Used to check if the tag can be used to check all items.
     142]|#
     143(define pl-checker? 'pl-checker?)
     144
     145(let ((in (gensym 'in)) (out (gensym 'out)))
     146  (set! pl-checker
     147    (case-lambda
     148      ((ok?)
     149       (lambda (arg)
     150         (pl-checker ok? arg)))
     151      ((ok? arg)
     152       (cond
     153         ((eq? arg in) out)
     154         ((ok? arg) arg)
     155         (else
     156           (error 'pl-checker
     157                  "argument not accepted by predicate"
     158                  ok?
     159                  arg))))))
     160  (set! pl-checker?
     161    (lambda (xpr)
     162      (and (procedure? xpr)
     163           (condition-case (eq? (xpr in) out)
     164             ((exn) #f)))))
     165  )
     166
     167#|[
     168(pl . args)
     169--- procedure ---
     170constructor: creates a pseudolist with sentinel tag from pl-parameter
     171and items from args, encapsulated into a closure, which, when called with an
     172index, returns the argument at that index, or, when called with -1,
     173returns the length of args.
     174]|#
     175(define pl 'pl)
     176
     177#|[
     178(pl? xpr)
     179--- procedure ---
     180type predicate
     181]|#
     182(define pl? 'pl?)
     183
     184(let ((in (gensym 'in)) (out (gensym 'out)))
     185
     186  (set! pl
     187    (lambda args
     188      (let ((tag (pl-parameter))
     189            (args args)
     190            (len (length args)))
     191        (let ((args
     192                (if (pl-checker? tag)
     193                  (map tag args)
     194                  args)))
     195          (case-lambda
     196            (() (values args tag))
     197            ((k)
     198             (cond
     199               ((and (symbol? k) (eq? k in)) out)
     200               ((= k -1) len)
     201               ((or (>= k len) (< k -1))
     202                (error 'pl "out of range" k))
     203               (else
     204                (list-ref args k))))
     205            ((k val)
     206             (if (or (< k 0) (>= k len))
     207               (error 'pl "out of range" k)
     208               (set! (list-ref args k)
     209                 (if (pl-checker? tag)
     210                   (tag val)
     211                   val))))
     212               )))))
     213
     214  (set! pl?
     215    (lambda (xpr)
     216      (and (procedure? xpr)
     217           (condition-case (eq? out (xpr in))
     218             ((exn) #f)))))
     219  )
     220#|[
     221(pl-maker len fill)
     222(pl-maker len)
     223--- procedure ---
     224creates a pseudolist of length len with sentinel (pl-parameter),
     225items fill or (pl-sentinel), if fill is not given
     226]|#
    66227(define (pl-maker len . args)
    67   (cond
    68     ((null? args)
    69      (pl-maker len (pl-sentinel)))
    70     ((null? (cdr args))
    71      (let ((fill (car args)))
    72          (if (zero? len)
    73            (pl-sentinel)
    74            (cons fill (pl-maker (- len 1) fill)))))
    75     (else (error 'pl-maker "too many arguments"))))
    76 
     228  (let ((parameter (pl-parameter)))
     229    (cond
     230      ((null? args)
     231       (pl-maker len parameter))
     232      ((null? (cdr args))
     233       (let ((fill (car args)))
     234         (apply pl
     235           (let recur ((i 0))
     236             (if (= i len)
     237               parameter
     238               (cons fill (recur (+ i 1))))))))
     239      (else (error 'pl-maker "too many arguments")))))
     240
     241#|[
     242(pl-at k pls)
     243(pl-at k)
     244--- procedure ---
     245returns the kth item of pls
     246]|#
     247(define (pl-at k . plss)
     248  (cond
     249    ((null? plss)
     250     (lambda (pls) (pls k)))
     251    ((null? (cdr plss))
     252     (let ((pls ((pl-checker pl?) (car plss))))
     253       (pls k)))
     254    (else 'pl-at "to many arguments")))
     255
     256#|[
     257(pl-set! k val pls)
     258--- procedure ---
     259sets the kth item of pls to val
     260]|#
     261(define (pl-set! k val pls)
     262  (((pl-checker pl?) pls) k val))
     263
     264#|[
     265(pl-length pls)
     266--- procedure ---
     267returns the length of the pseudolist pls
     268]|#
     269(define (pl-length pls)
     270  ((pl-checker pl? pls) -1))
     271
     272#|[
     273(pl-null? xpr)
     274--- procedure ---
     275checks, if no items are stored in the pseudolist xpr
     276]|#
    77277(define (pl-null? xpr)
    78   ;(equal? xpr (pl-sentinel)))
    79   (not (pair? xpr)))
    80 
    81 (define (pl? xpr) #t)
    82   ;(or (pl-null? xpr)
    83   ;    (pair? xpr)))
    84 
    85 (define (pl-check-sentinel? . pls)
    86   (cond
    87     ((null? pls)
    88      (lambda (pl) (pl-check-sentinel? pl)))
    89     ((null? (cdr pls))
    90      (equal? (pl-tail pl) (pl-sentinel)))
    91     (else (error 'pl-check-sentinel? "too many arguments"))))
     278  (and (pl? xpr)
     279       (zero? (pl-length xpr))))
     280
     281#|[
     282(pl-head pls)
     283--- procedure ---
     284returns the list part of the pseudolist pls
     285]|#
     286(define (pl-head pls)
     287  ((pl-checker pl? pls)))
     288  ;(let ((pls (pl-checker pl? pls)))
     289  ;  (let recur ((lst (pls)))
     290  ;    (if (null? lst)
     291  ;      '()
     292  ;      (cons (car lst)
     293  ;            (recur (cdr lst)))))))
     294
     295#|[
     296(pl-tail pls)
     297--- procedure ---
     298returns the sentinel of the pseudolist pls
     299]|#
     300(define (pl-tail pls)
     301  (receive (_ tail) ((pl-checker pl? pls)) tail))
     302
     303#|[
     304(pl-data pls)
     305--- procedure ---
     306returns the dotted list underlying the pseudolist pls
     307]|#
     308(define (pl-data pls)
     309  (receive (head tail) ((pl-checker pl? pls))
     310    (append head tail)))
     311
     312#|[
     313(pl-cons x pls)
     314(pl-cons x)
     315--- procedure ---
     316adds the item x to the front of the pseudolist pls
     317]|#
     318(define (pl-cons x . plss)
     319  (cond
     320    ((null? plss)
     321     (lambda (pls) (pl-cons x pls)))
     322    ((null? (cdr plss))
     323     (let ((pls (pl-checker pl? (car plss))))
     324       (let ((lst (pl-head pls)) (tag (pl-tail pls)))
     325         (parameterize ((pl-parameter tag))
     326           (apply pl
     327             (if (pl-checker? tag)
     328               (cons (tag x) lst)
     329               (cons x lst)))))))
     330    (else (error 'pl-cons "too many arguments"))))
     331
     332#|[
     333(pl-car pls)
     334--- procedure ---
     335returns the first item of the pseudolist pls
     336]|#
     337(define (pl-car pls)
     338  (pl-at 0 (pl-checker pl? pls)))
     339
     340#|[
     341(pl-cdr pls)
     342--- procedure ---
     343returns a new pseudolist removing the first item of pls
     344]|#
     345(define (pl-cdr pls)
     346  (pl-drop 1 (pl-checker pl? pls)))
    92347
    93348(define (my-conjoin . preds)
     
    100355        (else #f)))))
    101356
    102 (define (pl-of? . preds)
    103   (let ((ok? (apply my-conjoin preds)))
    104     (lambda (xpr)
    105       (if (pair? xpr)
    106         (and (ok? (car xpr))
    107              ((pl-of? ok?) (cdr xpr)))
    108         (pl-null? xpr)))))
    109 
    110 (define (pl-length pl)
    111   ;; sentinel doesn't count in length!
    112   (if (pl-null? pl)
    113     0
    114     (+ 1 (pl-length (cdr pl)))))
    115 
    116 (define (pl-head pl)
    117   (let recur ((pl pl))
    118     (if (pl-null? pl)
    119       '()
    120       (cons (car pl) (recur (cdr pl))))))
    121 
    122 (define (pl-tail pl)
    123   (let loop ((pl pl))
    124     (if (pl-null? pl)
    125       pl
    126       (loop (cdr pl)))))
    127 
     357#|[
     358(pl-of? tag . preds)
     359--- procedure ---
     360creates a unary predicate, which tests, if its argument is a
     361pseudolist with parameter tag, whose items pass all the predicates preds
     362]|#
     363(define (pl-of? tag . preds)
     364  (lambda (xpr)
     365    (and (pl? xpr)
     366         (equal? tag (pl-tail xpr))
     367         (if (null? preds)
     368           #t
     369           (let ((ok? (if (null? (cdr preds))
     370                        (car preds)
     371                        (apply my-conjoin preds)))
     372                 (lst (pl-head xpr)))
     373             (let loop ((lst lst))
     374               (cond
     375                 ((null? lst) #t)
     376                 ((ok? (car lst)) (loop (cdr lst)))
     377                 (else #f))))))))
     378
     379#|[
     380(pl-iterate fn times init)
     381(pl-iterate fn times)
     382--- procedure ---
     383creates a pseudolist with sentinel (pl-parameter) applying fn
     384to init recursively k times
     385]|#
    128386(define (pl-iterate fn times . inits)
    129387  (cond
     
    132390       (pl-iterate fn times init)))
    133391    ((null? (cdr inits))
    134      (let recur ((x (car inits)) (k 0))
    135        (if (= k times)
    136          (pl-sentinel)
    137          (cons x (recur (fn x) (+ k 1))))))
     392     (apply pl
     393       (let recur ((x (car inits)) (k 0))
     394         (if (= k times)
     395           '()
     396           (cons x (recur (fn x) (+ k 1)))))))
    138397    (else (error 'pl-iterate "too many arguments"))))
    139398
    140 (define (pl-change-sentinel new-sentinel . pls)
    141   (cond
    142     ((null? pls)
    143      (lambda (pl)
    144        (pl-change-sentinel new-sentinel pl)))
    145     ((null? (cdr pls))
    146      (let recur ((pl (car pls)))
    147        (if (pair? pl)
    148          (cons (car pl) (recur (cdr pl)))
    149          new-sentinel)))
    150     (else (error 'pl-change-sentinel "too many arguments"))))
    151 
    152 (define (pl-at n . pls)
    153   (cond
    154     ((null? pls)
    155      (lambda (pl)
    156        (pl-at n pl)))
    157     ((null? (cdr pls))
    158      (let ((pl (car pls)))
    159        (assert (< -1 n (pl-length pl)))
    160        (let loop ((k 0) (pl pl))
    161          (cond
    162            ((pl-null? pl) pl)
    163            ((= k n) (car pl))
    164            (else
    165              (loop (+ k 1) (cdr pl)))))))
    166     (else (error 'pl-at "too many arguments"))))
    167 
    168 (define (pl-drop n . pls)
    169   (cond
    170     ((null? pls)
    171      (lambda (pl)
    172        (pl-drop n pl)))
    173     ((null? (cdr pls))
    174      (let ((pl (car pls)))
    175        (assert (or (pl-null? pl) (< -1 n (pl-length pl))))
    176        (let loop ((n n) (pl pl))
    177          (cond
    178            ((pl-null? pl) pl)
    179            ((zero? n) pl)
    180            (else
    181              (loop (- n 1) (cdr pl)))))))
     399#|[
     400(pl-drop n pls)
     401(pl-drop n)
     402--- procedure ---
     403returns a new pseudolist removing the first n items of the pseudolist pls
     404]|#
     405(define (pl-drop n . plss)
     406  (cond
     407    ((null? plss)
     408     (lambda (pls)
     409       (pl-drop n pls)))
     410    ((null? (cdr plss))
     411     (let ((pls (pl-checker pl? (car plss))))
     412       (parameterize ((pl-parameter (pl-tail pls)))
     413         (apply pl
     414           (list-tail (pl-head pls)
     415                      (pl-checker (cut < -1 <> (pl-length pls)) n))))))
    182416    (else
    183417      (error 'pl-drop "too many arguments"))))
    184418
    185 (define (pl-drop-while ok? . pls)
    186   (cond
    187     ((null? pls)
    188      (lambda (pl)
    189        (pl-drop-while ok? pl)))
    190     ((null? (cdr pls))
    191      (let loop ((pl (car pls)))
    192        (if (pair? pl)
    193          (if (ok? (car pl))
    194            (loop (cdr pl))
    195            pl)
    196          pl)))
     419#|[
     420(pl-drop-while ok? pls)
     421(pl-drop-while ok?)
     422--- procedure ---
     423returns the tail of pls starting with the first item
     424that does not pass the ok? test
     425]|#
     426(define (pl-drop-while ok? . plss)
     427  (cond
     428    ((null? plss)
     429     (lambda (pls)
     430       (pl-drop-while ok? pls)))
     431    ((null? (cdr plss))
     432     (let ((pls (pl-checker pl? (car plss)))
     433           (ok? (pl-checker procedure? ok?)))
     434       (parameterize ((pl-parameter (pl-tail pls)))
     435         (apply pl
     436           (let loop ((lst (pl-head pls)))
     437             (if (null? lst)
     438               lst
     439               (if (ok? (car lst))
     440                 (loop (cdr lst))
     441                 lst)))))))
    197442    (else (error 'pl-drop-while "too many arguments"))))
    198443
    199 (define (pl-take n . pls)
    200   (cond
    201     ((null? pls)
    202      (lambda (pl)
    203        (pl-take n pl)))
    204     ((null? (cdr pls))
    205      (let ((pl (car pls)))
    206        (assert (or (pl-null? pl) (< -1 n (pl-length pl))))
    207        (let recur ((k 0) (pl pl))
    208          (cond
    209            ((pl-null? pl) pl)
    210            ((< k n)
    211             (cons (car pl) (recur (+ k 1) (cdr pl))))
    212            (else (recur (+ k 1) (cdr pl)))))))
     444#|[
     445(pl-take n pls)
     446(pl-take n)
     447--- procedure ---
     448returns a new pseudolist consisting of the first n items of
     449the pseudolist pls, keeping the sentinel
     450]|#
     451(define (pl-take n . plss)
     452  (cond
     453    ((null? plss)
     454     (lambda (pls)
     455       (pl-take n pls)))
     456    ((null? (cdr plss))
     457     (let* ((pls (pl-checker pl? (car plss)))
     458            (n (pl-checker (cut < -1 <> (pl-length pls)) n)))
     459       (parameterize ((pl-parameter (pl-tail pls)))
     460         (apply pl
     461           (let recur ((k 0) (lst (pl-head pls)))
     462             (cond
     463               ((null? lst) lst)
     464               ((< k n) (cons (car lst) (recur (+ k 1) (cdr lst))))
     465               (else (recur (+ k 1) (cdr lst)))))))))
    213466    (else (error 'pl-take "too many arguments"))))
    214467     
    215 (define (pl-take-while ok? . pls)
    216   (cond
    217     ((null? pls)
    218      (lambda (pl)
    219        (pl-take-while ok? pl)))
    220     ((null? (cdr pls))
    221      (let recur ((pl (car pls)))
    222        (if (pl-null? pl)
    223          pl
    224          (let ((first (car pl)) (rest (cdr pl)))
    225            (if (ok? first)
    226              (cons first (recur rest))
    227              (pl-tail rest))))))
     468#|[
     469(pl-take-while ok? pls)
     470(pl-take-while ok?)
     471--- procedure ---
     472returns the sublist of pls consisting of items
     473until the first item doesn't pass the ok? test.
     474]|#
     475(define (pl-take-while ok? . plss)
     476  (cond
     477    ((null? plss)
     478     (lambda (pls)
     479       (pl-take-while ok? pls)))
     480    ((null? (cdr plss))
     481     (let ((pls (pl-checker pl? (car plss)))
     482           (ok? (pl-checker procedure? ok?)))
     483       (parameterize ((pl-parameter (pl-tail pls)))
     484         (apply pl
     485           (let recur ((lst (pl-head pls)))
     486             (if (null? lst)
     487               lst
     488               (let ((first (car lst)) (rest (cdr lst)))
     489                 (if (ok? first)
     490                   (cons first (recur rest))
     491                   '()))))))))
    228492    (else (error 'pl-take-while "too many arguments"))))
    229493
    230 (define (pl-reverse pl)
    231   (let loop ((pl pl) (result (pl-tail pl)))
    232     (if (pl-null? pl)
    233       result
    234       (loop (cdr pl) (cons (car pl) result)))))
    235 
    236 (define (pl-map fn . pls)
    237   (cond
    238     ((null? pls)
    239      (lambda pls
    240        (apply pl-map fn pls)))
    241     ((null? (cdr pls))
    242      (let recur ((pl (car pls)))
    243        (if (pl-null? pl)
    244          pl
    245          (cons (fn (car pl)) (recur (cdr pl))))))
     494#|[
     495(pl-reverse pl)
     496--- procedure ---
     497reverses its pseudolist argument to a new pseudolist
     498with same sentinel
     499]|#
     500(define (pl-reverse pls)
     501  (let ((pls (pl-checker pl? pls)))
     502    (parameterize ((pl-parameter (pl-tail pls)))
     503      (apply pl (reverse (pl-head pls))))))
     504
     505;(define (all-equal? lst)
     506;  (if (null? lst)
     507;    #t
     508;    (null? (cdr (let loop ((lst lst) (result '()))
     509;                  (cond
     510;                    ((null? lst) result)
     511;                    ((member (car lst) result)
     512;                     (loop (cdr lst) result))
     513;                    (else (loop (cdr lst)
     514;                                (cons (car lst) result)))))))))
     515
     516(define (all cmp? lst)
     517  (if (null? lst)
     518    #t
     519    (let ((x (car lst)) (xs (cdr lst)))
     520      (let* ((gsym (gensym)) ; xs might be a list of #f
     521             (checker (lambda (arg)
     522                        (if (cmp? x arg) arg gsym))))
     523        (let loop ((xs xs))
     524          (cond
     525            ((null? xs) #t)
     526            ((cmp? (checker (car xs)) gsym) #f)
     527            (else (loop (cdr xs)))))))))
     528
     529
     530#|[
     531(pl-map fn . plss)
     532--- procedure ---
     533maps fn over the pseudolists plss as long as none of the items is
     534pl-null? and returns a new pseudolist if all sentinels are equal.
     535Note, that this is R7RS-, not R5RS-logic.
     536]|#
     537(define (pl-map fn . plss)
     538  (cond
     539    ((null? plss)
     540     (lambda plss
     541       (apply pl-map fn plss)))
     542    ((null? (cdr plss))
     543     (let ((pls (pl-checker pl? (car plss))))
     544       (parameterize ((pl-parameter (pl-tail pls)))
     545         (apply pl
     546           (let recur ((lst (pl-head pls)))
     547             (if (null? lst)
     548               lst
     549               (cons (fn (car lst))
     550                     (recur (cdr lst)))))))))
    246551    (else
    247       (let recur ((pls pls))
    248         (let ((ls (memq #t (map pl-null? pls))))
    249           (if ls
    250             (pl-tail (list-ref pls (- (length pls) (length ls))))
    251             (cons (apply fn (map car pls))
    252                   (recur (map cdr pls)))))))
    253         ;(if (memq #t (map pl-null? pls))
    254         ;  (pl-sentinel)
    255         ;  (cons (apply fn (map car pls))
    256         ;        (recur (map cdr pls))))))
     552      (let ((plss (map (pl-checker pl?) plss)))
     553        (let ((len (apply min (map pl-length plss)))
     554              (tags (map pl-tail plss)))
     555          (if (all equal? tags)
     556            (parameterize ((pl-parameter (car tags)))
     557              (apply pl
     558                (let recur ((i 0))
     559                  (if (= i len)
     560                    '()
     561                    (cons (apply fn (map (pl-at i) plss))
     562                          (recur (+ i 1)))))))
     563            (error 'pl-map "not all tags equal" tags)))))
    257564    ))
    258565
    259 (define (pl-for-each fn pl . pls)
    260   (if (null? pls)
    261     (let loop ((pl pl))
    262       (unless (pl-null? pl)
    263         (fn (car pl))
    264         (loop (cdr pl))))
    265     (let loop ((pls (cons pl pls)))
    266       (unless (memq #t (map pl-null? pls))
    267         (apply fn (map car pls))
    268         (loop (map cdr pls))))))
    269 
    270 (define (pl-memp ok? . pls)
    271   (cond
    272     ((null? pls)
    273      (lambda (pl)
    274        (pl-memp ok? pl)))
    275     ((null? (cdr pls))
    276      (let loop ((pl (car pls)))
     566#|[
     567(pl-for-each fn pls . plss)
     568--- procedure ---
     569applies fn over the pseudolists (cons pls plss)
     570stops if one of the items is pl-null?
     571Note, that this is R7RS-, not R5RS-logic
     572]|#
     573(define (pl-for-each fn pls . plss)
     574  (if (null? plss)
     575    (let* ((pls (pl-checker pl? pls))
     576           (len (pl-length pls)))
     577      (let loop ((i 0))
     578        (unless (= i len)
     579          (fn (pl-at i pls))
     580          (loop (+ i 1)))))
     581    (let* ((plss (map (pl-checker pl?) (cons pls plss)))
     582           (len (apply min (map pl-length plss))))
     583      (let ((tags (map pl-tail plss)))
     584        (if (all equal? tags)
     585          (let recur ((i 0) (plss plss))
     586            (unless (= i len)
     587              (cons (apply fn (map car plss))
     588                    (recur (+ i 1) (map cdr plss)))))
     589          (error 'pl-for-each "not all tags equal" tags))))
     590    ))
     591#|[
     592(pl-memp ok? pls)
     593(pl-memp ok?)
     594--- procedure ---
     595returns the subpseudolist starting at the first
     596item which passes the ok? test, keeping ps's sentinel.
     597Returns #f if no item passes the ok? test
     598]|#
     599(define (pl-memp ok? . plss)
     600  (cond
     601    ((null? plss)
     602     (lambda (pls)
     603       (pl-memp ok? pls)))
     604    ((null? (cdr plss))
     605     (let ((pls (pl-checker pl? (car plss))))
     606       (let loop ((lst (pl-head pls)))
     607         (cond
     608           ((null? lst) #f)
     609           ((ok? (car lst))
     610            (parameterize ((pl-parameter (pl-tail pls)))
     611              (apply pl lst)))
     612           (else (loop (cdr lst)))))))
     613    (else (error 'pl-memp "too many arguments"))))
     614
     615#|[
     616(pl-memq x pls)
     617(pl-memq x)
     618--- procedure ---
     619same as (pl-memp (cut eq? <> x) pls)
     620]|#
     621(define (pl-memq x . plss)
     622  (cond
     623    ((null? plss)
     624     (lambda (pls) (pl-memq x pls)))
     625    ((null? (cdr plss))
     626     (pl-memp (cut eq? <> x) (car plss)))
     627    (else (error 'pl-memq "too many arguments"))))
     628
     629#|[
     630(pl-memv x pls)
     631(pl-memv x)
     632--- procedure ---
     633same as (pl-memp (cut eqv? <> x) pls)
     634]|#
     635(define (pl-memv x . plss)
     636  (cond
     637    ((null? plss)
     638     (lambda (pls) (pl-memv x pls)))
     639    ((null? (cdr plss))
     640     (pl-memp (cut eqv? <> x) (car plss)))
     641    (else (error 'pl-memv "too many arguments"))))
     642
     643#|[
     644(pl-member x pls)
     645(pl-member x)
     646--- procedure ---
     647same as (pl-memp (cut equal? <> x) pls)
     648]|#
     649(define (pl-member x . plss)
     650  (cond
     651    ((null? plss)
     652     (lambda (pls) (pl-member x pls)))
     653    ((null? (cdr plss))
     654     (pl-memp (cut equal? <> x) (car plss)))
     655    (else (error 'pl-member "too many arguments"))))
     656
     657#|[
     658(pl-index ok? pls)
     659(pl-index ok?)
     660--- procedure ---
     661returns the index of the first item passing
     662the ok? test, -1 otherwise
     663]|#
     664(define (pl-index ok? . plss)
     665  (cond
     666    ((null? plss)
     667     (lambda (pls)
     668       (pl-index ok? pls)))
     669    ((null? (cdr plss))
     670     (let ((pls(pl-checker pl? (car plss))))
     671     (let loop ((k 0) (lst (pl-head pls)))
    277672       (cond
    278          ((pl-null? pl) #f)
    279          ((ok? (car pl)) pl)
    280          (else (loop (cdr pl))))))
    281     (else (error 'pl-memp "too many arguments"))))
    282 
    283 (define (pl-memq x . pls)
    284   (apply pl-memp (cut eq? <> x) pls))
    285 
    286 (define (pl-memv x . pls)
    287   (apply pl-memp (cut eqv? <> x) pls))
    288 
    289 (define (pl-member x . pls)
    290   (apply pl-memp (cut equal? <> x) pls))
    291 
    292 (define (pl-index ok? . pls)
    293   (cond
    294     ((null? pls)
    295      (lambda (pl)
    296        (pl-index ok? pl)))
    297     ((null? (cdr pls))
    298      (let loop ((k 0) (pl (car pls)))
    299        (cond
    300          ((pl-null? pl) -1)
    301          ((ok? (car pl)) k)
     673         ((null? lst) -1)
     674         ((ok? (car lst)) k)
    302675         (else
    303            (loop (+ k 1) (cdr pl))))))
     676           (loop (+ k 1) (cdr lst)))))))
    304677    (else (error 'pl-index "too many arguments"))))
    305678
    306 (define (pl-filter ok? . pls)
    307   (cond
    308     ((null? pls)
    309      (lambda (pl)
    310        (pl-filter ok? pl)))
    311     ((null? (cdr pls))
    312      (let recur ((pl (car pls)))
    313        (if (pl-null? pl)
    314          (values pl pl)
    315          (receive (yes no) (pl-filter ok? (cdr pl))
    316            (if (ok? (car pl))
    317              (values (cons (car pl) yes) no)
    318              (values yes (cons (car pl) no)))))))
     679#|[
     680(pl-filter ok? pls)
     681(pl-filter ok?)
     682--- procedure ---
     683filters a pseudolist by means of a predicate ok?
     684returning two new pseudolists, those of items of pls
     685passing the ok? test, and those that don't
     686]|#
     687(define (pl-filter ok? . plss)
     688  (cond
     689    ((null? plss)
     690     (lambda (pls)
     691       (pl-filter ok? pls)))
     692    ((null? (cdr plss))
     693     (let* ((pls (pl-checker pl? (car plss))))
     694       (receive (yes no)
     695         (let loop ((lst (pl-head pls)) (yes '()) (no '()))
     696           (if (null? lst)
     697             (values (reverse yes) (reverse no))
     698             (let ((val (car lst)))
     699               (if (ok? val)
     700                 (loop (cdr lst) (cons val yes) no)
     701                 (loop (cdr lst) yes (cons val no))))))
     702         (parameterize ((pl-parameter (pl-tail pls)))
     703           (values (apply pl yes) (apply pl no))))))
    319704    (else (error 'pl-filter "too many arguments"))))
    320705
    321 (define (pl-append pl . pls)
    322   (cond
    323     ((null? pls) pl)
    324     ((null? (cdr pls))
    325      (let recur ((pl pl))
    326        (if (pl-null? pl)
    327          (car pls)
    328          (cons (car pl) (recur (cdr pl))))))
    329     (else
    330       (pl-append pl (apply pl-append (car pls) (cdr pls))))
    331     ))
    332 
    333 (define (pl-fold-right op init . pls)
    334   (cond
    335     ((null? pls)
    336      (lambda (pl)
    337        (pl-fold-right op init pl)))
    338     ((null? (cdr pls))
    339      (let recur ((pl (car pls)))
    340        (if (pl-null? pl)
    341          init
    342          (op (car pl) (recur (cdr pl))))))
     706#|[
     707(pl-append pls . plss)
     708--- procedure ---
     709appends all argument pseudolist, provided their tags are
     710all equal
     711]|#
     712(define (pl-append pls . plss)
     713  (let ((plss (map (pl-checker pl?) (cons pls plss))))
     714    (let ((tails (map pl-tail plss))
     715          (heads (map pl-head plss)))
     716      (if (all equal? tails)
     717        (parameterize ((pl-parameter (car tails)))
     718          (apply pl (apply append heads)))
     719        (error 'pl-append "not all equal" tails)))))
     720
     721#|[
     722(pl-fold-right op init pls)
     723(pl-fold-right op init)
     724--- procedure ---
     725folds pls from the right with binary operation op
     726and starting value init
     727]|#
     728(define (pl-fold-right op init . plss)
     729  (cond
     730    ((null? plss)
     731     (lambda (pls)
     732       (pl-fold-right op init pls)))
     733    ((null? (cdr plss))
     734     (let ((pls (pl-checker pl? (car plss))))
     735       (let recur ((lst (pl-head pls)))
     736         (if (null? lst)
     737           init
     738           (op (car lst) (recur (cdr lst)))))))
    343739    (else (error 'pl-fold-right "too many arguments"))))
    344740
    345 (define (pl-fold-right0 op . pls)
    346   (cond
    347     ((null? pls)
    348      (lambda (pl)
    349        (pl-fold-right0 op pl)))
    350     ((null? (cdr pls))
    351      (let ((pl (car pls)))
    352        (if (pl-null? pl)
    353          (error 'pl-fold-right0 "pseudolist empty" pl)
    354          (apply pl-fold-right op (car pl) (cdr pl)))))
     741#|[
     742(pl-fold-right0 op pls)
     743(pl-fold-right0 op)
     744--- procedure ---
     745folds (pl-cdr pls) from the right with binary operation op
     746and starting value (pl-car pls)
     747]|#
     748(define (pl-fold-right0 op . plss)
     749  (cond
     750    ((null? plss)
     751     (lambda (pls)
     752       (pl-fold-right0 op pls)))
     753    ((null? (cdr plss))
     754     (let ((pls (pl-checker pl? (car plss))))
     755       (if (pl-null? pls)
     756         (error 'pl-fold-right0 "pseudolist empty" pls)
     757         (pl-fold-right op (pl-car pls) (pl-cdr pls)))))
    355758    (else (error 'pl-fold-right0 "too many arguments"))
    356759    ))
    357760
    358 (define (pl-fold-left op init . pls)
    359   (cond
    360     ((null? pls)
    361      (lambda (pl)
    362        (pl-fold-left op init pl)))
    363     ((null? (cdr pls))
    364      (let loop ((pl (car pls)) (result init))
    365        (if (pl-null? pl)
     761#|[
     762(pl-fold-left op init pls)
     763(pl-fold-left op init)
     764--- procedure ---
     765folds pls from the left with binary operation op
     766and starting value init
     767]|#
     768(define (pl-fold-left op init . plss)
     769  (cond
     770    ((null? plss)
     771     (lambda (pls)
     772       (pl-fold-left op init pls)))
     773    ((null? (cdr plss))
     774     (let ((pls (pl-checker pl? (car plss))))
     775     (let loop ((lst (pl-head pls)) (result init))
     776       (if (null? lst)
    366777         result
    367          (loop (cdr pl) (op result (car pl))))))
     778         (loop (cdr lst) (op result (car lst)))))))
    368779    (else (error 'pl-fold-left "too many arguments"))
    369780    ))
    370781
    371 (define (pl-fold-left0 op . pls)
    372   (cond
    373     ((null? pls)
    374      (lambda (pl)
    375        (pl-fold-left0 op pl)))
    376     ((null? (cdr pls))
    377      (let ((pl (car pls)))
    378        (if (pl-null? pl)
    379          (error 'pl-fold-left0 "pseudolist empty" pl)
    380          (apply pl-fold-left op (car pl) (cdr pl)))))
     782#|[
     783(pl-fold-left0 op pls)
     784(pl-fold-left0 op)
     785--- procedure ---
     786folds (pl-cdr pls) from the left with binary operation op
     787and starting value (pl-car pls)
     788]|#
     789(define (pl-fold-left0 op . plss)
     790  (cond
     791    ((null? plss)
     792     (lambda (pls)
     793       (pl-fold-left0 op pls)))
     794    ((null? (cdr plss))
     795     (let ((pls (pl-checker pl? (car plss))))
     796       (if (pl-null? pls)
     797         (error 'pl-fold-left0 "pseudolist empty" pls)
     798         (pl-fold-left op (pl-car pls) (pl-cdr pls)))))
    381799    (else (error 'pl-fold-left0 "too many arguments"))
    382800    ))
    383801
    384 (define (pl-adjoin obj . pls)
    385   (cond
    386     ((null? pls)
    387      (lambda (pl)
    388        (pl-adjoin obj pl)))
    389     ((null? (cdr pls))
    390      (let ((pl (car pls)))
    391        (if (pair? (pl-member obj pl))
    392          pl
    393          (cons obj pl))))
     802#|[
     803 (pl-adjoin obj pls)
     804 (pl-adjoin obj)
     805--- procedure ---
     806add obj to the front of pls only if it is not already a member of pls
     807]|#
     808(define (pl-adjoin obj . plss)
     809  (cond
     810    ((null? plss)
     811     (lambda (pls)
     812       (pl-adjoin obj pls)))
     813    ((null? (cdr plss))
     814     (let* ((pls (pl-checker pl? (car plss)))
     815            (lst (pl-head pls)))
     816       (parameterize ((pl-parameter (pl-tail pls)))
     817         (apply pl
     818           (if (member obj lst)
     819             lst
     820             (cons obj lst))))))
    394821    (else (error 'pl-adjoin "too many arguments"))
    395822    ))
    396823
    397 (define (pl-remove-dups pl)
    398   (let recur ((pl pl))
    399     (if (pl-null? pl)
    400       pl
    401       (pl-adjoin (car pl) (recur (cdr pl))))))
    402 
     824#|[
     825(pl-remove-dups pls)
     826--- procedure ---
     827removes the duplicates in the pseudolist pls
     828]|#
     829(define (pl-remove-dups pls)
     830  (let* ((pls (pl-checker pl? pls))
     831         (lst (pl-head pls))
     832         (adjoin (lambda (obj lst)
     833                   (if (member obj lst)
     834                     lst
     835                     (cons obj lst)))))
     836    (parameterize ((pl-parameter (pl-tail pls)))
     837      (apply pl
     838        (let recur ((lst lst))
     839          (if (null? lst)
     840            lst
     841            (adjoin (car lst) (recur (cdr lst)))))))))
     842
     843#|[
     844(pl-flat? xpr)
     845--- procedure ---
     846is xpr a flat pseudolist, i.e. not containing other pseudolists
     847]|#
     848(define (pl-flat? xpr)
     849  (and (pl? xpr)
     850       (not (pl-memp pl? xpr))))
     851
     852#|[
     853(pl-flatten pl-tree)
     854--- procedure ---
     855flattens the nested pseudolist pl-tree to a pseudolist,
     856i.e. splices the pseudolist items of pl-tree into pl-tree
     857provided all parameters are equal
     858]|#
    403859(define (pl-flatten pl-tree)
    404   ;(let recur ((tree pl-tree) (result (pl-sentinel)))
    405   (let recur ((tree (pl-head pl-tree)) (result (pl-tail pl-tree)))
    406     (if (pair? tree)
    407       (let ((head (car tree)) (tail (cdr tree)))
    408         (cond
    409           ((pair? head)
    410            (recur head (recur tail result)))
    411           (else
    412             (cons head (recur tail result)))))
    413       result)))
    414 
     860  (let ((pls (pl-map (lambda (x)
     861                       (cond
     862                         ((pl-flat? x) x)
     863                         ((pl? x) (pl-flatten x))
     864                         (else (pl x))))
     865                     pl-tree)))
     866    (apply pl-append (pl-head pls))))
     867           ; pl-append checks for equal tails
     868
     869#|[
     870(pl-collect item-xpr (var pls ok-xpr ...))
     871(pl-collect item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
     872--- macro ---
     873creates a new pseudolist by binding var to each element
     874of the pseudolist pls in sequence, and if it passes the checks,
     875ok-xpr ..., inserts the value of xpr into the resulting pseudolist.
     876The qualifieres, (var pls ok-xpr ...), are processed
     877sequentially from left to right, so that filters of a
     878qualifier have access to the variables of qualifiers
     879to its left.
     880]|#
    415881(define-syntax pl-collect
    416882  (syntax-rules ()
    417    ((_ item-xpr (var pl ok-xpr ...))
    418      (let recur ((seq pl))
    419        (if (pl-null? seq)
    420          seq
    421          (let ((var (car seq)))
    422            (if (and ok-xpr ...)
    423              (cons item-xpr (recur (cdr seq)))
    424              (recur (cdr seq)))))))
    425    ((_ item-xpr (var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...)
    426     (let recur ((seq pl))
    427       (if (pl-null? seq)
    428         seq
    429         (let ((var (car seq)))
    430           (if (and ok-xpr ...)
    431             (pl-append (pl-collect item-xpr (var1 pl1 ok-xpr1 ...) ...)
    432                        (recur (cdr seq)))
    433             (recur (cdr seq)))))))
     883   ((_ item-xpr (var pls ok-xpr ...))
     884    (apply pl
     885      (let recur ((seq (pl-head (pl-checker pl? pls))))
     886         (if (null? seq)
     887           seq
     888           (let ((var (car seq)))
     889             (if (and ok-xpr ...)
     890               (cons item-xpr (recur (cdr seq)))
     891               (recur (cdr seq))))))))
     892   ((_ item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
     893    (apply pl
     894      (let recur ((seq (pl-head (pl-checker pl? pls))))
     895        (if (null? seq)
     896          seq
     897          (let ((var (car seq)))
     898            (if (and ok-xpr ...)
     899              ;(append (pl-head (pl-collect item-xpr (var1 pls1 ok-xpr1
     900              ;                                            ...) ...)))
     901              (pl-head
     902                (pl-append (pl-collect item-xpr (var1 pls1 ok-xpr1 ...) ...)
     903                (apply pl (recur (cdr seq)))))
     904              (recur (cdr seq))))))))
    434905   ))
    435906
    436 
    437 ;;; (pseudolists sym ..)
    438 ;;; ----------------------------
    439 ;;; documentation procedure.
     907#|[
     908(pseudolists)
     909(pseudolists sym)
     910--- procedure ---
     911documentation procedure
     912]|#
    440913(define pseudolists
    441   (let ((alst '(
    442     (pseudolists
    443       procedure:
    444       (pseudolists)
    445       (pseudolists sym)
    446       "documentation procedure,"
    447       "the first call returns all exported symbols,"
    448       "the second documentation of symbol sym")
    449     (pl-sentinel
    450       parameter:
    451       (pl-sentinel)
    452       (pl-sentinel atom)
    453       "returns or sets the sentinel")
    454     (pl-check-sentinel?
    455       procedure?
    456       (pl-check-sentinel?)
    457       (pl-check-sentinel? pl)
    458       "checks if pl's sentinel is equal to (pl-sentinel)")
    459     (pl-change-sentinel
    460       procedure:
    461       (pl-change-sentinel new-sentinel)
    462       (pl-change-sentinel new-sentinel pl)
    463       "changes the sentinel of pl")
    464     (pl
    465       procedure:
    466       (pl . args)
    467       "creates a pseudolist from args with sentinel from pl-sentinel")
    468     (pl-maker
    469       procedure:
    470       (pl-maker len)
    471       (pl-maker len fill)
    472       "creates a pseudolist of length len and sentinel from pl-sentinel"
    473       "with items fill if given, (pl-sentinel) otherwise")
    474     (pl-null?
    475       procedure:
     914  (let (
     915    (alist '(
     916      (pl-parameter
     917        parameter:
     918        (pl-parameter)
     919        (pl-parameter new)
     920        "returns or resets the sentinel of a pseudolist, initially '()"
     921        )
     922      (pl-checker
     923        procedure:
     924        (pl-checker ok? arg)
     925        (pl-checker ok?)
     926        "type constructor: wrap the predicate ok? into a unary procedure,"
     927        "which returns its argument unchanged, if only it passes the ok? test."
     928        "An uncurried version is given as well"
     929        )
     930      (pl-checker?
     931        procedure:
     932        (pl-checker? xpr)
     933        "type predicate. Used to check if the tag can be used to check all items."
     934        )
     935      (pl
     936        procedure:
     937        (pl . args)
     938        "constructor: creates a pseudolist with sentinel tag from pl-parameter"
     939        "and items from args, encapsulated into a closure, which, when called with an"
     940        "index, returns the argument at that index, or, when called with -1,"
     941        "returns the length of args."
     942        )
     943      (pl?
     944        procedure:
     945        (pl? xpr)
     946        "type predicate"
     947        )
     948      (pl-maker
     949        procedure:
     950        (pl-maker len fill)
     951        (pl-maker len)
     952        "creates a pseudolist of length len with sentinel (pl-parameter),"
     953        "items fill or (pl-sentinel), if fill is not given"
     954        )
     955      (pl-at
     956        procedure:
     957        (pl-at k pls)
     958        (pl-at k)
     959        "returns the kth item of pls"
     960        )
     961      (pl-set!
     962        procedure:
     963        (pl-set! k val pls)
     964        "sets the kth item of pls to val"
     965        )
     966      (pl-length
     967        procedure:
     968        (pl-length pls)
     969        "returns the length of the pseudolist pls"
     970        )
     971      (pl-null?
     972        procedure:
    476973        (pl-null? xpr)
    477         "is xpr an atom equal to (pl-sentinel)")
    478     (pl?
    479       procedure:
    480       (pl? xpr)
    481       "is xpr a pseudolist, i.e either a pair or the atom (pl-sentinel)")
    482     (pl-of?
    483       procedure:
    484       (pl-of? . preds)
    485       "returns a unary predicate, which checks"
    486       "if its argument passes each predicate in preds")
    487     (pl-length
    488       procedure:
    489         (pl-length pl)
    490         "length of a pseudolist pl"
    491         "the sentinel doesn't count")
    492     (pl-head
    493       procedure:
    494         (pl-head pl)
    495         "returns the list of items with pl's sentinel stripped")
    496     (pl-tail
    497       procedure:
    498         (pl-tail pl)
    499         "returns the sentinel of the pseudolist")
    500     (pl-iterate
    501       procedure:
    502       (pl-iterate fn k)
    503       (pl-iterate fn k init)
    504       "creates a pseudolist with sentinel (pl-sentinel) applying fn to init"
    505       "recursively k times")
    506     (pl-at
    507       procedure:
    508         (pl-at k)
    509         (pl-at k pl)
    510         "returns the kth item of pl")
    511     (pl-drop
    512       procedure:
     974        "checks, if no items are stored in the pseudolist xpr"
     975        )
     976      (pl-head
     977        procedure:
     978        (pl-head pls)
     979        "returns the list part of the pseudolist pls"
     980        )
     981      (pl-tail
     982        procedure:
     983        (pl-tail pls)
     984        "returns the sentinel of the pseudolist pls"
     985        )
     986      (pl-data
     987        procedure:
     988        (pl-data pls)
     989        "returns the dotted list underlying the pseudolist pls"
     990        )
     991      (pl-cons
     992        procedure:
     993        (pl-cons x pls)
     994        (pl-cons x)
     995        "adds the item x to the front of the pseudolist pls"
     996        )
     997      (pl-car
     998        procedure:
     999        (pl-car pls)
     1000        "returns the first item of the pseudolist pls"
     1001        )
     1002      (pl-cdr
     1003        procedure:
     1004        (pl-cdr pls)
     1005        "returns a new pseudolist removing the first item of pls"
     1006        )
     1007      (pl-of?
     1008        procedure:
     1009        (pl-of? tag . preds)
     1010        "creates a unary predicate, which tests, if its argument is a"
     1011        "pseudolist with parameter tag, whose items pass all the predicates preds"
     1012        )
     1013      (pl-iterate
     1014        procedure:
     1015        (pl-iterate fn times init)
     1016        (pl-iterate fn times)
     1017        "creates a pseudolist with sentinel (pl-parameter) applying fn"
     1018        "to init recursively k times"
     1019        )
     1020      (pl-drop
     1021        procedure:
     1022        (pl-drop n pls)
    5131023        (pl-drop n)
    514         (pl-drop n pl)
    515         "returns the tail of pl removing the first n items")
    516     (pl-drop-while
    517       procedure:
     1024        "returns a new pseudolist removing the first n items of the pseudolist pls"
     1025        )
     1026      (pl-drop-while
     1027        procedure:
     1028        (pl-drop-while ok? pls)
    5181029        (pl-drop-while ok?)
    519         (pl-drop-while ok? pl)
    520         "returns the tail of pl starting with the first item"
    521         "that does not pass the ok? test")
    522     (pl-take
    523       procedure:
     1030        "returns the tail of pls starting with the first item"
     1031        "that does not pass the ok? test"
     1032        )
     1033      (pl-take
     1034        procedure:
     1035        (pl-take n pls)
    5241036        (pl-take n)
    525         (pl-take n pl)
    526         "returns the sublist of pl up to but excluding index n,"
    527         "where n is less than or equal to pl's pl-length."
    528         "The sentinel is unchanged")
    529     (pl-take-while
    530       procedure:
     1037        "returns a new pseudolist consisting of the first n items of"
     1038        "the pseudolist pls, keeping the sentinel"
     1039        )
     1040      (pl-take-while
     1041        procedure:
     1042        (pl-take-while ok? pls)
    5311043        (pl-take-while ok?)
    532         (pl-take-while ok? pl)
    533         "returns the sublist of pl consisting of items"
     1044        "returns the sublist of pls consisting of items"
    5341045        "until the first item doesn't pass the ok? test."
    535         "The sentinel remains unchanged")
    536     (pl-map
    537       procedure:
    538         (pl-map fn)
    539         (pl-map fn . pls)
    540         "maps fn over the pseudolists pls as long as none of the"
    541         "items is pl-null? and returns a new pseudolist with pl-sentinel."
    542         "The sentinel is that of the first pl-null item."
    543         "Note, that this is R7RS-, not R5RS-logic")
    544     (pl-for-each
    545       procedure:
    546         (pl-for-each fn pl . pls)
    547         "applies fn over the pseudolists (cons pl pls)"
     1046        )
     1047      (pl-reverse
     1048        procedure:
     1049        (pl-reverse pl)
     1050        "reverses its pseudolist argument to a new pseudolist"
     1051        "with same sentinel"
     1052        )
     1053      (pl-map
     1054        procedure:
     1055        (pl-map fn . plss)
     1056        "maps fn over the pseudolists plss as long as none of the items is"
     1057        "pl-null? and returns a new pseudolist if all sentinels are equal."
     1058        "Note, that this is R7RS-, not R5RS-logic."
     1059        )
     1060      (pl-for-each
     1061        procedure:
     1062        (pl-for-each fn pls . plss)
     1063        "applies fn over the pseudolists (cons pls plss)"
    5481064        "stops if one of the items is pl-null?"
    549         "Note, that this is R7RS-, not R5RS-logic")
    550     (pl-index
    551       procedure:
    552       (pl-index ok?)
    553       (pl-index ok? pl)
    554       "returns the index of the first item passing"
    555       "the ok? test, -1 otherwise")
    556     (pl-filter
    557       procedure:
     1065        "Note, that this is R7RS-, not R5RS-logic"
     1066        )
     1067      (pl-memp
     1068        procedure:
     1069        (pl-memp ok? pls)
     1070        (pl-memp ok?)
     1071        "returns the subpseudolist starting at the first"
     1072        "item which passes the ok? test, keeping ps's sentinel."
     1073        "Returns #f if no item passes the ok? test"
     1074        )
     1075      (pl-memq
     1076        procedure:
     1077        (pl-memq x pls)
     1078        (pl-memq x)
     1079        "same as (pl-memp (cut eq? <> x) pls)"
     1080        )
     1081      (pl-memv
     1082        procedure:
     1083        (pl-memv x pls)
     1084        (pl-memv x)
     1085        "same as (pl-memp (cut eqv? <> x) pls)"
     1086        )
     1087      (pl-member
     1088        procedure:
     1089        (pl-member x pls)
     1090        (pl-member x)
     1091        "same as (pl-memp (cut equal? <> x) pls)"
     1092        )
     1093      (pl-index
     1094        procedure:
     1095        (pl-index ok? pls)
     1096        (pl-index ok?)
     1097        "returns the index of the first item passing"
     1098        "the ok? test, -1 otherwise"
     1099        )
     1100      (pl-filter
     1101        procedure:
     1102        (pl-filter ok? pls)
    5581103        (pl-filter ok?)
    559         (pl-filter ok? pl)
    5601104        "filters a pseudolist by means of a predicate ok?"
    561         "Both values (passing or not passing ok?) keep pl's sentinel.")
    562     (pl-reverse
    563       procedure:
    564       (pl-reverse pl)
    565       "reverses its pseudolist argument to a new pseudolist"
    566       "with same sentinel")
    567     (pl-append
    568       procedure:
    569       (pl-append pl . pls)
    570       "appends all argument pseudolists to a pseudolist"
    571       "with sentinel of the last item")
    572     (pl-memp
    573       procedure:
    574       (pl-memp ok?)
    575       (pl-memp ok? pl)
    576       "returns the sublist starting at the first"
    577       "item which passes the ok? test, keeping ps's sentinel."
    578       "Returns #f if no item passes the ok? test")
    579     (pl-member
    580       procedure:
    581       (pl-member x)
    582       (pl-member x pl)
    583       "same as (pl-memp (cut equal? <> x) pl)")
    584     (pl-memq
    585       procedure:
    586       (pl-memq x)
    587       (pl-memq x pl)
    588       "same as (pl-memp (cut eq? <> x) pl)")
    589     (pl-memv
    590       procedure:
    591       (pl-memv x)
    592       (pl-memv x pl)
    593       "same as (pl-memp (cut eqv? <> x) pl)")
    594     (pl-fold-right
    595       procedure:
    596       (pl-fold-right op init)
    597       (pl-fold-right op init pl)
    598       "folds pl from the right with binary operation op"
    599       "and starting value init")
    600     (pl-fold-right0
    601       procedure:
    602       (pl-fold-right0 op)
    603       (pl-fold-right0 op pl)
    604       "folds (cdr pl) from the right with binary operation op"
    605       "and starting value (car pl)")
    606     (pl-fold-left
    607       procedure:
    608       (pl-fold-left op init)
    609       (pl-fold-left op init pl)
    610       "folds pl from the left with binary operation op"
    611       "and starting value init")
    612     (pl-fold-left0
    613       procedure:
    614       (pl-fold-left0 op)
    615       "folds (cdr pl) from the left with binary operation op"
    616       "and starting value (car pl)")
    617       (pl-fold-left0 op pl)
    618     (pl-adjoin
    619       procedure:
    620         (pl-adjoin obj)
    621         (pl-adjoin obj pl)
    622         "adds obj to a pseudolist provided, it isn't already there")
    623     (pl-remove-dups
    624       procedure:
    625         (pl-remove-dups lst)
    626         "removes duplicates of a pseudolist keeping the sentinel")
    627     (pl-flatten
    628       procedure:
     1105        "returning two new pseudolists, those of items of pls"
     1106        "passing the ok? test, and those that don't"
     1107        )
     1108      (pl-append
     1109        procedure:
     1110        (pl-append pls . plss)
     1111        "appends all argument pseudolist, provided their tags are"
     1112        "all equal"
     1113        )
     1114      (pl-fold-right
     1115        procedure:
     1116        (pl-fold-right op init pls)
     1117        (pl-fold-right op init)
     1118        "folds pls from the right with binary operation op"
     1119        "and starting value init"
     1120        )
     1121      (pl-fold-right0
     1122        procedure:
     1123        (pl-fold-right0 op pls)
     1124        (pl-fold-right0 op)
     1125        "folds (pl-cdr pls) from the right with binary operation op"
     1126        "and starting value (pl-car pls)"
     1127        )
     1128      (pl-fold-left
     1129        procedure:
     1130        (pl-fold-left op init pls)
     1131        (pl-fold-left op init)
     1132        "folds pls from the left with binary operation op"
     1133        "and starting value init"
     1134        )
     1135      (pl-fold-left0
     1136        procedure:
     1137        (pl-fold-left0 op pls)
     1138        (pl-fold-left0 op)
     1139        "folds (pl-cdr pls) from the left with binary operation op"
     1140        "and starting value (pl-car pls)"
     1141        )
     1142      (pl-adjoin
     1143        procedure:
     1144         (pl-adjoin obj pls)
     1145         (pl-adjoin obj)
     1146        "add obj to the front of pls only if it is not already a member of pls"
     1147        )
     1148      (pl-remove-dups
     1149        procedure:
     1150        (pl-remove-dups pls)
     1151        "removes the duplicates in the pseudolist pls"
     1152        )
     1153      (pl-flat?
     1154        procedure:
     1155        (pl-flat? xpr)
     1156        "is xpr a flat pseudolist, i.e. not containing other pseudolists"
     1157        )
     1158      (pl-flatten
     1159        procedure:
    6291160        (pl-flatten pl-tree)
    630         "flattens the nested pseudolist tree to a pseudolist"
    631         "with sentinel from the pseudolist of depth 0")
    632     (pl-collect
    633       macro:
    634       (pl-collect xpr (var pl ok-xpr ...) ....)
    635       "creates a new list by binding var to each element"
    636       "of the pseudolist pl in sequence, and if it passes the checks,"
    637       "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
    638       "The qualifieres, (var pl ok-xpr ...), are processed"
    639       "sequentially from left to right, so that filters of a"
    640       "qualifier have access to the variables of qualifiers"
    641       "to its left."
    642       "The leftmost pseudolist determines the result's sentinel")
    643     )))
    644     (case-lambda
    645       (()
    646        (map car alst))
    647       ((sym)
    648        (let ((lst (assq sym alst)))
    649          (if lst
    650            (for-each print (cdr lst))
    651            (error 'basic-macros
    652                   "not exported" sym)))))))
    653 ) ; module pseudolists
    654 
    655 ;(import pseudolists simple-tests)
    656 ;(pl-sentinel 0)
    657 ;(ppp (pl-maker 3 0)
    658 ;     (pl-memp odd? '(0 1 2 . 0))
    659 ;     (pl-memp odd? '(0 4 2 . 0))
    660 ;     (pl-memp odd? 0)
    661 ;     (pl-filter odd? '(0 1 2 3 4 . 0))
    662 ;     (pl-flatten '(0 (1 2 (3 4 . 0) . 0) . 0))
    663 ;     (pl-flatten '(0 (1 2 (3 4))))
    664 ;     )
     1161        "flattens the nested pseudolist pl-tree to a pseudolist,"
     1162        "i.e. splices the pseudolist items of pl-tree into pl-tree"
     1163        "provided all parameters are equal"
     1164        )
     1165      (pl-collect
     1166        macro:
     1167        (pl-collect item-xpr (var pls ok-xpr ...))
     1168        (pl-collect item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
     1169        "creates a new pseudolist by binding var to each element"
     1170        "of the pseudolist pls in sequence, and if it passes the checks,"
     1171        "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
     1172        "The qualifieres, (var pls ok-xpr ...), are processed"
     1173        "sequentially from left to right, so that filters of a"
     1174        "qualifier have access to the variables of qualifiers"
     1175        "to its left."
     1176        )
     1177      (pseudolists
     1178        procedure:
     1179        (pseudolists)
     1180        (pseudolists sym)
     1181        "with sym: documentation of exported symbol"
     1182        "without sym: list of exported symbols"
     1183        )
     1184        ))
     1185      )
     1186      (case-lambda
     1187        (() (map car alist))
     1188        ((sym)
     1189         (let ((pair (assq sym alist)))
     1190           (if pair
     1191             (for-each print (cdr pair))
     1192             (print "Choose one of " (map car alist))))))))
     1193)
  • release/5/pseudolists/tags/3.0/tests/run.scm

    r38334 r39597  
    1 
    2 (import scheme (chicken base) (chicken condition)
    3         pseudolists
    4         simple-tests)
    5 
    6 ;; set sentinel
    7 (pl-sentinel 0)
    8 
    9 (define-checks (basic? verbose?)
    10   (pl? "x") #t
    11   (pl? '(a b . c)) #t
    12   (pl-check-sentinel? '(a b . c)) #f
    13   (pl-null? 5) #t
    14   ((pl-of?) "x") #t
    15   ((pl-of? symbol?) '(a b . #f)) #t
    16 
    17   (pl 0 1 2) '(0 1 2 . 0)
    18   (pl) 0
    19 
    20   (pl-maker 3) '(0 0 0 . 0)
    21   (pl-iterate add1 5 0) '(0 1 2 3 4 . 0)
    22 
    23   (pl-tail '(1 2 3 4 . #f)) #f
    24   (pl-tail '(0 1 2 3 2 . 2)) 2
    25  
    26   (pl-length '(0 1 2 3 . 0)) 4
    27 
    28   (pl-head '(0 1 2 3 2 . 0)) '(0 1 2 3 2)
    29   (pl-head 0) '()
    30   (pl-head '(0 . 1)) '(0)
    31 
    32   (pl-at 1 '(0 1 2 3 . 4)) 1
    33   (pl-at 2 '(0 1 2 3 . #f)) 2
    34   (condition-case (pl-at 0 1)
    35     ((exn) #f)) #f
    36 
    37   (pl-index odd? '(0 1 2 . 0)) 1
    38   (pl-index odd? '(0 2 4 . 0)) -1
    39 
    40   (pl-memp odd? '(0 2 4 . 0)) #f
    41   (pl-memv 5 '(0 1 2 3 4 . 5)) #f
    42   (pl-member 3 '(0 1 2 3 4 . 5)) '(3 4 . 5)
     1(import pseudolists)
     2
     3(import simple-tests (chicken base) (chicken condition))
     4
     5'(basic?
     6   parameter
     7   (pl-parameter 0)
     8   pls
     9   (pl 0 1 2 3)
     10   mls
     11   (pl-maker 5)
     12   ils
     13   (pl-iterate add1 5 1))
     14
     15(define-tester
     16  (basic?
     17    parameter
     18    (pl-parameter 0)
     19    pls
     20    (pl 0 1 2 3)
     21    mls
     22    (pl-maker 5)
     23    ils
     24    (pl-iterate add1 5 1))
     25  (pl-parameter)
     26  0
     27  (pl-data pls)
     28  '(0 1 2 3 . 0)
     29  (pl-data mls)
     30  '(0 0 0 0 0 . 0)
     31  (pl-data ils)
     32  '(1 2 3 4 5 . 0)
     33  (pl? pls)
     34  #t
     35  (pl? mls)
     36  #t
     37  (pl? ils)
     38  #t
     39  (pl? '(0 1 2 3))
     40  #f
     41  ((pl-of? 0) pls)
     42  #t
     43  ((pl-of? '()) mls)
     44  #f
     45  (pl-car mls)
     46  0
     47  (pl-at 3 mls)
     48  0
     49  (pl-at 3 pls)
     50  3
     51  (pls 3)
     52  3
     53  (pl-head pls)
     54  '(0 1 2 3)
     55  (pls)
     56  '(0 1 2 3)
     57  (pl-tail pls)
     58  0
     59  (pl-data pls)
     60  '(0 1 2 3 . 0)
     61  (pl-data mls)
     62  '(0 0 0 0 0 . 0)
     63  (pl-tail mls)
     64  0
     65  (pl-data ils)
     66  '(1 2 3 4 5 . 0)
     67  (ils)
     68  '(1 2 3 4 5)
     69  (pl-tail ils)
     70  0
     71  (pl-head (pl-cons -1 pls))
     72  '(-1 0 1 2 3)
     73  (pl-head (pl-cdr pls))
     74  '(1 2 3)
     75  (pl-set! 0 1 mls)
     76  (void)
     77  (pl-at 0 mls)
     78  1
     79  (pl-set! 1 2 mls)
     80  (void)
     81  (pl-at 1 mls)
     82  2
     83  (mls 1)
     84  2
     85  (mls 2 3)
     86  (void)
     87  (mls 2)
     88  3
     89  (mls)
     90  '(1 2 3 0 0)
     91  (pl-head mls)
     92  '(1 2 3 0 0))
     93
     94(newline)
     95
     96'(checked? parameter (pl-parameter (pl-checker integer?)) pls (pl 0 1 2 3))
     97
     98(define-tester
     99  (checked? parameter (pl-parameter (pl-checker integer?)) pls (pl 0 1 2 3))
     100  (pl-tail pls)
     101  (pl-parameter)
     102  (pl-head pls)
     103  '(0 1 2 3)
     104  (condition-case (pl 0 1 #f 3) ((exn) #f))
     105  #f
     106  (condition-case (pl-set! 0 #f pls) ((exn) #f))
     107  #f
     108  (pl-set! 0 100 pls)
     109  (void)
     110  (pl-car pls)
     111  100
     112  (pls 0 10)
     113  (void)
     114  (pls 0)
     115  10)
     116
     117(newline)
     118
     119'(ops? parameter
     120       (pl-parameter 0)
     121       pls
     122       (pl 0 1 2 3)
     123       mls
     124       (pl-maker 5)
     125       ils
     126       (pl-iterate add1 5 1)
     127       ii
     128       (pl-iterate add1 5))
     129
     130(define-tester
     131  (ops? parameter
     132        (pl-parameter 0)
     133        pls
     134        (pl 0 1 2 3)
     135        mls
     136        (pl-maker 5)
     137        ils
     138        (pl-iterate add1 5 1)
     139        ii
     140        (pl-iterate add1 5))
     141  (pl-parameter)
     142  0
     143  (pl-data pls)
     144  '(0 1 2 3 . 0)
     145  (pl-data mls)
     146  '(0 0 0 0 0 . 0)
     147  (pl-data ils)
     148  '(1 2 3 4 5 . 0)
     149  (pl-data (ii 1))
     150  '(1 2 3 4 5 . 0)
     151  (pls)
     152  '(0 1 2 3)
     153  (pl? pls)
     154  #t
     155  ((pl-of? 1) pls)
     156  #f
     157  ((pl-of? 0) pls)
     158  #t
     159  ((pl-of? 0 integer?) pls)
     160  #t
     161  ((pl-of? 0 integer? positive?) pls)
     162  #f
     163  (pl? '(0 1 2 3 . 0))
     164  #f
     165  (pl-at 0 pls)
     166  0
     167  (pl-at 3 pls)
     168  3
     169  (pl-head (pl-map add1 pls))
     170  '(1 2 3 4)
     171  (pl-head (pl-map + pls pls))
     172  '(0 2 4 6)
     173  (pl-index negative? pls)
     174  -1
     175  (pl-index odd? pls)
     176  1
     177  (pl-head (pl-filter odd? pls))
     178  '(1 3)
     179  (receive (_ pl-no) (pl-filter odd? pls) (pl-head pl-no))
     180  '(0 2)
     181  (pl-head (pl-append pls ils))
     182  '(0 1 2 3 1 2 3 4 5)
     183  (pl-head (pl-append pls ils mls))
     184  '(0 1 2 3 1 2 3 4 5 0 0 0 0 0)
     185  (pl-set! 2 20 pls)
     186  (void)
     187  (pl-head pls)
     188  '(0 1 20 3)
     189  (pl-length pls)
     190  4
     191  (pl-tail pls)
     192  0
     193  (pl-at 2 pls)
     194  20
     195  (pl-head pls)
     196  '(0 1 20 3)
     197  (pl-head (pl-drop 3 pls))
     198  '(3)
     199  (pl-head (pl-drop-while zero? pls))
     200  '(1 20 3)
     201  (pl-head (pl-drop-while (cut <= <> 10) pls))
     202  '(20 3)
     203  (pl-head (pl-take 3 pls))
     204  '(0 1 20)
     205  (pl-head (pl-take-while (cut <= <> 10) pls))
     206  '(0 1)
     207  (pl-head (pl-reverse pls))
     208  '(3 20 1 0)
     209  (pl-head (pl-memp (lambda (x) (> x 10)) pls))
     210  '(20 3)
     211  (pl-head mls)
     212  '(0 0 0 0 0)
     213  ((pl-of? 0 zero?) mls)
     214  #t
     215  (pl-length mls)
     216  5
     217  (pl-set! 2 20 mls)
     218  (void)
     219  (pl-head mls)
     220  '(0 0 20 0 0)
     221  (pl-tail mls)
     222  0
     223  (pl? mls)
     224  #t
     225  (pl-head (pl-maker 5 1))
     226  '(1 1 1 1 1)
     227  (pl? ils)
     228  #t
     229  (pl-head ils)
     230  '(1 2 3 4 5)
     231  (pl-tail ils)
     232  0
     233  (pl-at 2 ils)
     234  3
     235  (pl? ii)
     236  #f
     237  (pl? (ii 1))
     238  #t
     239  (pl-length (ii 1))
     240  5
     241  (pl-at 3 (ii 1))
     242  4
     243  (pl-head (pl-map * (pl 0 1 2 3) (pl 10 20)))
     244  '(0 20)
     245  (condition-case
     246    (pl-map
     247      +
     248      (parameterize ((pl-parameter #f)) (pl 0 1 2 3))
     249      (parameterize ((pl-parameter #t)) (pl 0 1 2 3)))
     250    ((exn) #f))
     251  #f)
     252
     253(newline)
     254
     255'(new-ops? parameter (pl-parameter 0) pls (pl 0 1 2 3 4 5))
     256
     257(define-tester
     258  (new-ops? parameter (pl-parameter 0) pls (pl 0 1 2 3 4 5))
     259  (pl-data pls)
     260  '(0 1 2 3 4 5 . 0)
     261  (pl-fold-right + 0 pls)
     262  15
     263  (pl-fold-left + 0 pls)
     264  15
     265  (pl-fold-right0 + pls)
     266  15
     267  (pl-fold-left0 + pls)
     268  15
     269  (pl-head (pl-fold-right pl-cons (pl) pls))
     270  '(0 1 2 3 4 5)
     271  (pl-fold-right cons '() pls)
     272  '(0 1 2 3 4 5)
     273  (pl-head (pl-adjoin 3 pls))
     274  '(0 1 2 3 4 5)
     275  (pl-head (pl-adjoin #f pls))
     276  '(#f 0 1 2 3 4 5)
     277  (pl-head (pl-remove-dups pls))
     278  '(0 1 2 3 4 5)
     279  (pl-head (pl-remove-dups (pl 0 1 0 1 0 1)))
     280  '(0 1)
     281  (pl-flat? pls)
     282  #t
     283  (pl-flat? (pl 0 (pl 1 (pl 2))))
     284  #f
     285  (pl-head (pl-flatten (pl 1 2 3)))
     286  '(1 2 3)
     287  (pl-head (pl-flatten (pl 1 '(2 3))))
     288  '(1 (2 3))
     289  (pl-head (pl-flatten (pl 1 (pl 2 3))))
     290  '(1 2 3)
     291  (pl-head (pl-flatten (pl 1 (pl 2 3) (pl 4 5) 6)))
     292  '(1 2 3 4 5 6)
     293  (pl-head (pl-flatten (pl 1 (pl 2 (pl 3)))))
     294  '(1 2 3)
     295  (pl-head (pl-flatten (pl 1 (pl 2 (pl 3 (pl 4)) 5) 6)))
     296  '(1 2 3 4 5 6)
     297  (condition-case
     298    (pl-flatten (pl 1 (parameterize ((pl-parameter #f)) (pl 2 3))))
     299    ((exn) #f))
     300  #f)
     301
     302(newline)
     303
     304(define-tester
     305  (collect?)
     306  (pl-data (pl-collect (add1 x) (x (pl 0 1 2 3))))
     307  '(1 2 3 4 . 0)
     308  (pl-data (pl-collect (add1 x) (x (pl 0 1 2 3))))
     309  '(1 2 3 4 . 0)
     310  (pl-data (pl-collect x (x (pl 0 1 2 3 4 5) (odd? x))))
     311  '(1 3 5 . 0)
     312  (pl-data (pl-collect x (x (pl 0 1 2 3 4 5) (odd? x))))
     313  '(1 3 5 . 0)
     314  (pl-data (pl-collect (* 10 n) (n (pl 0 1 2 3 4 5) (positive? n) (even? n))))
     315  '(20 40 . 0)
     316  (pl-data (pl-collect (list c k) (c (pl 'A 'B 'C)) (k (pl 1 2 3 4))))
     317  '((A 1)
     318    (A 2)
     319    (A 3)
     320    (A 4)
     321    (B 1)
     322    (B 2)
     323    (B 3)
     324    (B 4)
     325    (C 1)
     326    (C 2)
     327    (C 3)
     328    (C 4)
     329    .
     330    0))
     331
     332(newline)
     333
     334(test-all PSEUDOLISTS
     335  basic?
     336  checked?
     337  ops?
     338  new-ops?
     339  collect?
    43340  )
    44 ;(basic?)
    45 
    46 (define-checks (higher? verbose?)
    47   (pl-drop 1 '(0 1 2 3 . 4)) '(1 2 3 . 4)
    48   (pl-drop 0 1) 1
    49   (pl-drop 2 '(0 1 2 3 . #f)) '(2 3 . #f)
    50   (pl-drop-while odd? '(1 3 2 4 . #f)) '(2 4 . #f)
    51   (pl-drop-while negative? '(1 3 2 4 . #f)) '(1 3 2 4 . #f)
    52  
    53   (pl-take 3 '(0 1 2 3 4 . #t)) '(0 1 2 . #t)
    54   (pl-take 2 '(0 1 2 3 . #f)) '(0 1 . #f)
    55   (pl-take-while odd? '(1 3 2 4 . #f)) '(1 3 . #f)
    56   (pl-take-while negative? '(1 3 2 4 . #f)) #f
    57   (pl-take-while even? '(0 1 2 3 . #f)) '(0 . #f)
    58 
    59   (pl-filter odd? 1) 1
    60   (pl-filter odd? '(0 1 2 3 4)) '(1 3)
    61   (pl-filter odd? '(0 1 2 3 . 4)) '(1 3 . 4)
    62   (pl-filter even? '(0 1 2 3 . 4)) '(0 2 . 4)
    63  
    64   (pl-map add1 '(0 1 2 3 . 4)) '(1 2 3 4 . 4)
    65   (pl-map add1 '(0 1 2 3)) '(1 2 3 4)
    66   (pl-map add1 #f) #f
    67   (pl-map + '(1 2 3 . 4) '(10 20 . 30))
    68     '(11 22 . 30)
    69   (pl-map + '(1 2 3 . 4) '(10 20 . 30) '(100 200 . 300))
    70     '(111 222 . 30)
    71 
    72   (pl-reverse '(0 1 2 3 . 4)) '(3 2 1 0 . 4)
    73   (pl-reverse '(0 1 2 3)) '(3 2 1 0)
    74 
    75   (pl-append '(0 1) #f) '(0 1 . #f)
    76   (pl-append '(0 1)) '(0 1)
    77   (pl-append '(0 1) '(2 3) #f) '(0 1 2 3 . #f)
    78   (pl-append '(0 1 . #f) '(2 3)) '(0 1 2 3)
    79   (pl-append '(0 1) '(2 3) '(4 5)) '(0 1 2 3 4 5)
    80   (pl-append '(0 1 . #f) '(2 3 . #t) '(4 5)) '(0 1 2 3 4 5)
    81   (pl-append '(0 1 . #t) '(2 3 . #t) '(4 5 . #t)) '(0 1 2 3 4 5 . #t)
    82   (pl-append '(0 1 . #t) '(2 3 . #t) '(4 5) #t) '(0 1 2 3 4 5 . #t)
    83 
    84   (pl-fold-right + 0 '(1 2 3 . #f)) 6
    85   (pl-fold-left + 0 '(1 2 3)) 6
    86 
    87   (pl-adjoin 2 '(0 1 2 3 . #f)) '(0 1 2 3 . #f)
    88   (pl-adjoin 4 '(0 1 2 3 #f . #t)) '(4 0 1 2 3 #f . #t)
    89   (pl-adjoin 1 '(0 1 2 3)) '(0 1 2 3)
    90   (pl-adjoin 1 #f) '(1 . #f)
    91 
    92   (pl-remove-dups '(0 1 2 3 2 . 2)) '(0 1 3 2 . 2)
    93   (pl-remove-dups '(0 1 2 3 2 2)) '(0 1 3 2)
    94   (pl-remove-dups '(0 1 2 1 3 2)) '(0 1 3 2)
    95 
    96   (pl-flatten '(1 (2 3) . #t)) '(1 2 3 . #t)
    97   (pl-flatten '(1 (2 (3 . #f) . #t) . #f)) '(1 2 3 . #f)
    98   (pl-flatten '(1 (2 (3 . #f) . #t))) '(1 2 3)
    99   (pl-flatten #f) #f
    100   )
    101 ;(higher?)
    102  
    103 (define-checks (collect? verbose?)
    104   (pl-collect (add1 x) (x '(0 1 2 3 . #f))) ; map
    105     '(1 2 3 4 . #f)
    106   (pl-collect (add1 x) (x '(0 1 2 3))) ; map
    107     '(1 2 3 4)
    108   (pl-collect x (x '(0 1 2 3 4 5 . #f) (odd? x))) ; filter
    109     '(1 3 5 . #f)
    110   (pl-collect x (x '(0 1 2 3 4 5) (odd? x))) ; filter
    111     '(1 3 5)
    112   (pl-collect (* 10 n) (n '(0 1 2 3 4 5) (positive? n) (even? n)))
    113     '(20 40)
    114   (pl-collect (list c k)
    115               (c '(A B C))
    116               (k '(1 2 3 4)))
    117     '((A 1) (A 2) (A 3) (A 4)
    118       (B 1) (B 2) (B 3) (B 4)
    119       (C 1) (C 2) (C 3) (C 4))
    120   (pl-collect (list c k)
    121               (c '(A B C . #t))
    122               (k '(1 2 3 4 . #f)))
    123     '((A 1) (A 2) (A 3) (A 4)
    124       (B 1) (B 2) (B 3) (B 4)
    125       (C 1) (C 2) (C 3) (C 4) . #t)
    126   )
    127 ;(collect?)
    128  
    129 (check-all PSEUDOLISTS
    130  (basic?)
    131  (higher?)
    132  (collect?)
    133  )
    134 
  • release/5/pseudolists/trunk/pseudolists.egg

    r38334 r39597  
    55 (test-dependencies simple-tests)
    66 (author "Juergen Lorenz")
    7  (version "2.0")
     7 (version "3.0")
    88 (components (extension pseudolists
    99                        (csc-options "-d0" "-O3"))))
  • release/5/pseudolists/trunk/pseudolists.scm

    r38334 r39597  
    1 ; Author: Juergen Lorenz ; ju (at jugilo (dot) de
    2 ;
    3 ; Copyright (c) 2013-2020, Juergen Lorenz
     1; Copyright (c) 2013-2021 , Juergen Lorenz, ju (at) jugilo (dot) de
    42; All rights reserved.
    53;
     
    97;
    108; Redistributions of source code must retain the above copyright
    11 ; notice, this list of conditions and the following dispasser.
     9; notice, this list of conditions and the following disclaimer.
    1210;
    1311; Redistributions in binary form must reproduce the above copyright
    14 ; notice, this list of conditions and the following dispasser in the
     12; notice, this list of conditions and the following disclaimer in the
    1513; documentation and/or other materials provided with the distribution.
    16 ;
    1714; Neither the name of the author nor the names of its contributors may be
    1815; used to endorse or promote products derived from this software without
    1916; specific prior written permission.
    20 ;
     17;  
    2118; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
    2219; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
     
    3229
    3330
     31#|[
     32This module exports routines to handle pseudolists as a generalisation
     33of ordinary lists. They can be considered as parametrized (or
     34tagged) lists, where the parameter (or tag) is stored in the sentinel of a
     35dotted list. In such a naive approch, we are faced with two problems.
     36
     37First, since dotted lists differ from lists only insofor, as their
     38sentinels might be arbitrary atoms instead of the empty list. In other
     39words, a dotted list is either a pair or an atom. But since an atom is
     40simply not a pair, everything is a pseudolist, in particular, a list is
     41one. Hence, there is no meaningfull predicate for dotted lists.
     42
     43Second, there is an efficency problem: to get a handle to the sentinel,
     44we have to traverse the whole dotted list. This is not acceptable, if,
     45for example, the parameter is a type predicate to check the type of
     46items to be put into the dotted list. Ok, as in previous versions of
     47this module, we can put the sentinel into a parameter, but this alone
     48doesn't help much, if different parameters are used simultaneously.
     49
     50This module offers a simple solution to both problems: Make the dotted
     51list callable, in other words, put it into a closure and acces the items
     52as well as the sentinel -- and the length for that matter -- via calls
     53to that closure, e.g. (pls i), where i is an index.
     54
     55Note, that most procedures are implemented in a curried and uncurried
     56form, but only the latter is described in detail in the documentation.
     57The former can be used in map and friends.
     58
     59Note also, that the order or arguments of all procedures is consistent:
     60The pseudolist argument(s) are always last, other procedures first.
     61]|#
     62
    3463(module pseudolists (
    35   pl-sentinel pl-check-sentinel? pl-change-sentinel
    36   pl pl-maker pl-null? pl? pl-of?
    37   pl-iterate pl-length pl-head pl-tail
    38   pl-flatten pl-reverse
    39   pl-index pl-filter pl-map pl-for-each
    40   pl-memp pl-member pl-memq pl-memv
    41   pl-adjoin pl-remove-dups
    42   pl-at pl-drop pl-take pl-append
    43   pl-drop-while pl-take-while
    44   pl-fold-right pl-fold-left
    45   pl-fold-right0 pl-fold-left0
    46   pl-collect pseudolists
     64  pl-parameter
     65  pl-checker
     66  pl-checker?
     67  pl
     68  pl?
     69  pl-maker
     70  pl-at
     71  pl-set!
     72  pl-length
     73  pl-null?
     74  pl-head
     75  pl-tail
     76  pl-data
     77  pl-cons
     78  pl-car
     79  pl-cdr
     80  pl-of?
     81  pl-iterate
     82  pl-drop
     83  pl-drop-while
     84  pl-take
     85  pl-take-while
     86  pl-reverse
     87  pl-map
     88  pl-for-each
     89  pl-memp
     90  pl-memq
     91  pl-memv
     92  pl-member
     93  pl-index
     94  pl-filter
     95  pl-append
     96  pl-fold-right
     97  pl-fold-right0
     98  pl-fold-left
     99  pl-fold-left0
     100  pl-adjoin
     101  pl-remove-dups
     102  pl-flat?
     103  pl-flatten
     104  pl-collect
     105  pseudolists
    47106  )
    48107
    49108  (import scheme
    50           (only (chicken base) receive
     109          (only (chicken condition) condition-case)
     110          (only (chicken base) receive gensym parameterize
    51111                unless cut case-lambda assert print error make-parameter))
    52112
    53 (define pl-sentinel
     113#|[
     114(pl-parameter)
     115(pl-parameter new)
     116--- parameter ---
     117returns or resets the sentinel of a pseudolist, initially '()
     118]|#
     119(define pl-parameter
    54120  (make-parameter '()
    55121                  (lambda (x)
     
    58124                      x))))
    59125
    60 (define (pl . args)
    61   (let recur ((args args))
    62     (if (null? args)
    63       (pl-sentinel)
    64       (cons (car args) (recur (cdr args))))))
    65 
     126;(define pl-sentinel pl-parameter) ; deprecated
     127
     128#|[
     129(pl-checker ok? arg)
     130(pl-checker ok?)
     131--- procedure ---
     132type constructor: wrap the predicate ok? into a unary procedure,
     133which returns its argument unchanged, if only it passes the ok? test.
     134An uncurried version is given as well
     135]|#
     136(define pl-checker 'pl-checker)
     137
     138#|[
     139(pl-checker? xpr)
     140--- procedure ---
     141type predicate. Used to check if the tag can be used to check all items.
     142]|#
     143(define pl-checker? 'pl-checker?)
     144
     145(let ((in (gensym 'in)) (out (gensym 'out)))
     146  (set! pl-checker
     147    (case-lambda
     148      ((ok?)
     149       (lambda (arg)
     150         (pl-checker ok? arg)))
     151      ((ok? arg)
     152       (cond
     153         ((eq? arg in) out)
     154         ((ok? arg) arg)
     155         (else
     156           (error 'pl-checker
     157                  "argument not accepted by predicate"
     158                  ok?
     159                  arg))))))
     160  (set! pl-checker?
     161    (lambda (xpr)
     162      (and (procedure? xpr)
     163           (condition-case (eq? (xpr in) out)
     164             ((exn) #f)))))
     165  )
     166
     167#|[
     168(pl . args)
     169--- procedure ---
     170constructor: creates a pseudolist with sentinel tag from pl-parameter
     171and items from args, encapsulated into a closure, which, when called with an
     172index, returns the argument at that index, or, when called with -1,
     173returns the length of args.
     174]|#
     175(define pl 'pl)
     176
     177#|[
     178(pl? xpr)
     179--- procedure ---
     180type predicate
     181]|#
     182(define pl? 'pl?)
     183
     184(let ((in (gensym 'in)) (out (gensym 'out)))
     185
     186  (set! pl
     187    (lambda args
     188      (let ((tag (pl-parameter))
     189            (args args)
     190            (len (length args)))
     191        (let ((args
     192                (if (pl-checker? tag)
     193                  (map tag args)
     194                  args)))
     195          (case-lambda
     196            (() (values args tag))
     197            ((k)
     198             (cond
     199               ((and (symbol? k) (eq? k in)) out)
     200               ((= k -1) len)
     201               ((or (>= k len) (< k -1))
     202                (error 'pl "out of range" k))
     203               (else
     204                (list-ref args k))))
     205            ((k val)
     206             (if (or (< k 0) (>= k len))
     207               (error 'pl "out of range" k)
     208               (set! (list-ref args k)
     209                 (if (pl-checker? tag)
     210                   (tag val)
     211                   val))))
     212               )))))
     213
     214  (set! pl?
     215    (lambda (xpr)
     216      (and (procedure? xpr)
     217           (condition-case (eq? out (xpr in))
     218             ((exn) #f)))))
     219  )
     220#|[
     221(pl-maker len fill)
     222(pl-maker len)
     223--- procedure ---
     224creates a pseudolist of length len with sentinel (pl-parameter),
     225items fill or (pl-sentinel), if fill is not given
     226]|#
    66227(define (pl-maker len . args)
    67   (cond
    68     ((null? args)
    69      (pl-maker len (pl-sentinel)))
    70     ((null? (cdr args))
    71      (let ((fill (car args)))
    72          (if (zero? len)
    73            (pl-sentinel)
    74            (cons fill (pl-maker (- len 1) fill)))))
    75     (else (error 'pl-maker "too many arguments"))))
    76 
     228  (let ((parameter (pl-parameter)))
     229    (cond
     230      ((null? args)
     231       (pl-maker len parameter))
     232      ((null? (cdr args))
     233       (let ((fill (car args)))
     234         (apply pl
     235           (let recur ((i 0))
     236             (if (= i len)
     237               parameter
     238               (cons fill (recur (+ i 1))))))))
     239      (else (error 'pl-maker "too many arguments")))))
     240
     241#|[
     242(pl-at k pls)
     243(pl-at k)
     244--- procedure ---
     245returns the kth item of pls
     246]|#
     247(define (pl-at k . plss)
     248  (cond
     249    ((null? plss)
     250     (lambda (pls) (pls k)))
     251    ((null? (cdr plss))
     252     (let ((pls ((pl-checker pl?) (car plss))))
     253       (pls k)))
     254    (else 'pl-at "to many arguments")))
     255
     256#|[
     257(pl-set! k val pls)
     258--- procedure ---
     259sets the kth item of pls to val
     260]|#
     261(define (pl-set! k val pls)
     262  (((pl-checker pl?) pls) k val))
     263
     264#|[
     265(pl-length pls)
     266--- procedure ---
     267returns the length of the pseudolist pls
     268]|#
     269(define (pl-length pls)
     270  ((pl-checker pl? pls) -1))
     271
     272#|[
     273(pl-null? xpr)
     274--- procedure ---
     275checks, if no items are stored in the pseudolist xpr
     276]|#
    77277(define (pl-null? xpr)
    78   ;(equal? xpr (pl-sentinel)))
    79   (not (pair? xpr)))
    80 
    81 (define (pl? xpr) #t)
    82   ;(or (pl-null? xpr)
    83   ;    (pair? xpr)))
    84 
    85 (define (pl-check-sentinel? . pls)
    86   (cond
    87     ((null? pls)
    88      (lambda (pl) (pl-check-sentinel? pl)))
    89     ((null? (cdr pls))
    90      (equal? (pl-tail pl) (pl-sentinel)))
    91     (else (error 'pl-check-sentinel? "too many arguments"))))
     278  (and (pl? xpr)
     279       (zero? (pl-length xpr))))
     280
     281#|[
     282(pl-head pls)
     283--- procedure ---
     284returns the list part of the pseudolist pls
     285]|#
     286(define (pl-head pls)
     287  ((pl-checker pl? pls)))
     288  ;(let ((pls (pl-checker pl? pls)))
     289  ;  (let recur ((lst (pls)))
     290  ;    (if (null? lst)
     291  ;      '()
     292  ;      (cons (car lst)
     293  ;            (recur (cdr lst)))))))
     294
     295#|[
     296(pl-tail pls)
     297--- procedure ---
     298returns the sentinel of the pseudolist pls
     299]|#
     300(define (pl-tail pls)
     301  (receive (_ tail) ((pl-checker pl? pls)) tail))
     302
     303#|[
     304(pl-data pls)
     305--- procedure ---
     306returns the dotted list underlying the pseudolist pls
     307]|#
     308(define (pl-data pls)
     309  (receive (head tail) ((pl-checker pl? pls))
     310    (append head tail)))
     311
     312#|[
     313(pl-cons x pls)
     314(pl-cons x)
     315--- procedure ---
     316adds the item x to the front of the pseudolist pls
     317]|#
     318(define (pl-cons x . plss)
     319  (cond
     320    ((null? plss)
     321     (lambda (pls) (pl-cons x pls)))
     322    ((null? (cdr plss))
     323     (let ((pls (pl-checker pl? (car plss))))
     324       (let ((lst (pl-head pls)) (tag (pl-tail pls)))
     325         (parameterize ((pl-parameter tag))
     326           (apply pl
     327             (if (pl-checker? tag)
     328               (cons (tag x) lst)
     329               (cons x lst)))))))
     330    (else (error 'pl-cons "too many arguments"))))
     331
     332#|[
     333(pl-car pls)
     334--- procedure ---
     335returns the first item of the pseudolist pls
     336]|#
     337(define (pl-car pls)
     338  (pl-at 0 (pl-checker pl? pls)))
     339
     340#|[
     341(pl-cdr pls)
     342--- procedure ---
     343returns a new pseudolist removing the first item of pls
     344]|#
     345(define (pl-cdr pls)
     346  (pl-drop 1 (pl-checker pl? pls)))
    92347
    93348(define (my-conjoin . preds)
     
    100355        (else #f)))))
    101356
    102 (define (pl-of? . preds)
    103   (let ((ok? (apply my-conjoin preds)))
    104     (lambda (xpr)
    105       (if (pair? xpr)
    106         (and (ok? (car xpr))
    107              ((pl-of? ok?) (cdr xpr)))
    108         (pl-null? xpr)))))
    109 
    110 (define (pl-length pl)
    111   ;; sentinel doesn't count in length!
    112   (if (pl-null? pl)
    113     0
    114     (+ 1 (pl-length (cdr pl)))))
    115 
    116 (define (pl-head pl)
    117   (let recur ((pl pl))
    118     (if (pl-null? pl)
    119       '()
    120       (cons (car pl) (recur (cdr pl))))))
    121 
    122 (define (pl-tail pl)
    123   (let loop ((pl pl))
    124     (if (pl-null? pl)
    125       pl
    126       (loop (cdr pl)))))
    127 
     357#|[
     358(pl-of? tag . preds)
     359--- procedure ---
     360creates a unary predicate, which tests, if its argument is a
     361pseudolist with parameter tag, whose items pass all the predicates preds
     362]|#
     363(define (pl-of? tag . preds)
     364  (lambda (xpr)
     365    (and (pl? xpr)
     366         (equal? tag (pl-tail xpr))
     367         (if (null? preds)
     368           #t
     369           (let ((ok? (if (null? (cdr preds))
     370                        (car preds)
     371                        (apply my-conjoin preds)))
     372                 (lst (pl-head xpr)))
     373             (let loop ((lst lst))
     374               (cond
     375                 ((null? lst) #t)
     376                 ((ok? (car lst)) (loop (cdr lst)))
     377                 (else #f))))))))
     378
     379#|[
     380(pl-iterate fn times init)
     381(pl-iterate fn times)
     382--- procedure ---
     383creates a pseudolist with sentinel (pl-parameter) applying fn
     384to init recursively k times
     385]|#
    128386(define (pl-iterate fn times . inits)
    129387  (cond
     
    132390       (pl-iterate fn times init)))
    133391    ((null? (cdr inits))
    134      (let recur ((x (car inits)) (k 0))
    135        (if (= k times)
    136          (pl-sentinel)
    137          (cons x (recur (fn x) (+ k 1))))))
     392     (apply pl
     393       (let recur ((x (car inits)) (k 0))
     394         (if (= k times)
     395           '()
     396           (cons x (recur (fn x) (+ k 1)))))))
    138397    (else (error 'pl-iterate "too many arguments"))))
    139398
    140 (define (pl-change-sentinel new-sentinel . pls)
    141   (cond
    142     ((null? pls)
    143      (lambda (pl)
    144        (pl-change-sentinel new-sentinel pl)))
    145     ((null? (cdr pls))
    146      (let recur ((pl (car pls)))
    147        (if (pair? pl)
    148          (cons (car pl) (recur (cdr pl)))
    149          new-sentinel)))
    150     (else (error 'pl-change-sentinel "too many arguments"))))
    151 
    152 (define (pl-at n . pls)
    153   (cond
    154     ((null? pls)
    155      (lambda (pl)
    156        (pl-at n pl)))
    157     ((null? (cdr pls))
    158      (let ((pl (car pls)))
    159        (assert (< -1 n (pl-length pl)))
    160        (let loop ((k 0) (pl pl))
    161          (cond
    162            ((pl-null? pl) pl)
    163            ((= k n) (car pl))
    164            (else
    165              (loop (+ k 1) (cdr pl)))))))
    166     (else (error 'pl-at "too many arguments"))))
    167 
    168 (define (pl-drop n . pls)
    169   (cond
    170     ((null? pls)
    171      (lambda (pl)
    172        (pl-drop n pl)))
    173     ((null? (cdr pls))
    174      (let ((pl (car pls)))
    175        (assert (or (pl-null? pl) (< -1 n (pl-length pl))))
    176        (let loop ((n n) (pl pl))
    177          (cond
    178            ((pl-null? pl) pl)
    179            ((zero? n) pl)
    180            (else
    181              (loop (- n 1) (cdr pl)))))))
     399#|[
     400(pl-drop n pls)
     401(pl-drop n)
     402--- procedure ---
     403returns a new pseudolist removing the first n items of the pseudolist pls
     404]|#
     405(define (pl-drop n . plss)
     406  (cond
     407    ((null? plss)
     408     (lambda (pls)
     409       (pl-drop n pls)))
     410    ((null? (cdr plss))
     411     (let ((pls (pl-checker pl? (car plss))))
     412       (parameterize ((pl-parameter (pl-tail pls)))
     413         (apply pl
     414           (list-tail (pl-head pls)
     415                      (pl-checker (cut < -1 <> (pl-length pls)) n))))))
    182416    (else
    183417      (error 'pl-drop "too many arguments"))))
    184418
    185 (define (pl-drop-while ok? . pls)
    186   (cond
    187     ((null? pls)
    188      (lambda (pl)
    189        (pl-drop-while ok? pl)))
    190     ((null? (cdr pls))
    191      (let loop ((pl (car pls)))
    192        (if (pair? pl)
    193          (if (ok? (car pl))
    194            (loop (cdr pl))
    195            pl)
    196          pl)))
     419#|[
     420(pl-drop-while ok? pls)
     421(pl-drop-while ok?)
     422--- procedure ---
     423returns the tail of pls starting with the first item
     424that does not pass the ok? test
     425]|#
     426(define (pl-drop-while ok? . plss)
     427  (cond
     428    ((null? plss)
     429     (lambda (pls)
     430       (pl-drop-while ok? pls)))
     431    ((null? (cdr plss))
     432     (let ((pls (pl-checker pl? (car plss)))
     433           (ok? (pl-checker procedure? ok?)))
     434       (parameterize ((pl-parameter (pl-tail pls)))
     435         (apply pl
     436           (let loop ((lst (pl-head pls)))
     437             (if (null? lst)
     438               lst
     439               (if (ok? (car lst))
     440                 (loop (cdr lst))
     441                 lst)))))))
    197442    (else (error 'pl-drop-while "too many arguments"))))
    198443
    199 (define (pl-take n . pls)
    200   (cond
    201     ((null? pls)
    202      (lambda (pl)
    203        (pl-take n pl)))
    204     ((null? (cdr pls))
    205      (let ((pl (car pls)))
    206        (assert (or (pl-null? pl) (< -1 n (pl-length pl))))
    207        (let recur ((k 0) (pl pl))
    208          (cond
    209            ((pl-null? pl) pl)
    210            ((< k n)
    211             (cons (car pl) (recur (+ k 1) (cdr pl))))
    212            (else (recur (+ k 1) (cdr pl)))))))
     444#|[
     445(pl-take n pls)
     446(pl-take n)
     447--- procedure ---
     448returns a new pseudolist consisting of the first n items of
     449the pseudolist pls, keeping the sentinel
     450]|#
     451(define (pl-take n . plss)
     452  (cond
     453    ((null? plss)
     454     (lambda (pls)
     455       (pl-take n pls)))
     456    ((null? (cdr plss))
     457     (let* ((pls (pl-checker pl? (car plss)))
     458            (n (pl-checker (cut < -1 <> (pl-length pls)) n)))
     459       (parameterize ((pl-parameter (pl-tail pls)))
     460         (apply pl
     461           (let recur ((k 0) (lst (pl-head pls)))
     462             (cond
     463               ((null? lst) lst)
     464               ((< k n) (cons (car lst) (recur (+ k 1) (cdr lst))))
     465               (else (recur (+ k 1) (cdr lst)))))))))
    213466    (else (error 'pl-take "too many arguments"))))
    214467     
    215 (define (pl-take-while ok? . pls)
    216   (cond
    217     ((null? pls)
    218      (lambda (pl)
    219        (pl-take-while ok? pl)))
    220     ((null? (cdr pls))
    221      (let recur ((pl (car pls)))
    222        (if (pl-null? pl)
    223          pl
    224          (let ((first (car pl)) (rest (cdr pl)))
    225            (if (ok? first)
    226              (cons first (recur rest))
    227              (pl-tail rest))))))
     468#|[
     469(pl-take-while ok? pls)
     470(pl-take-while ok?)
     471--- procedure ---
     472returns the sublist of pls consisting of items
     473until the first item doesn't pass the ok? test.
     474]|#
     475(define (pl-take-while ok? . plss)
     476  (cond
     477    ((null? plss)
     478     (lambda (pls)
     479       (pl-take-while ok? pls)))
     480    ((null? (cdr plss))
     481     (let ((pls (pl-checker pl? (car plss)))
     482           (ok? (pl-checker procedure? ok?)))
     483       (parameterize ((pl-parameter (pl-tail pls)))
     484         (apply pl
     485           (let recur ((lst (pl-head pls)))
     486             (if (null? lst)
     487               lst
     488               (let ((first (car lst)) (rest (cdr lst)))
     489                 (if (ok? first)
     490                   (cons first (recur rest))
     491                   '()))))))))
    228492    (else (error 'pl-take-while "too many arguments"))))
    229493
    230 (define (pl-reverse pl)
    231   (let loop ((pl pl) (result (pl-tail pl)))
    232     (if (pl-null? pl)
    233       result
    234       (loop (cdr pl) (cons (car pl) result)))))
    235 
    236 (define (pl-map fn . pls)
    237   (cond
    238     ((null? pls)
    239      (lambda pls
    240        (apply pl-map fn pls)))
    241     ((null? (cdr pls))
    242      (let recur ((pl (car pls)))
    243        (if (pl-null? pl)
    244          pl
    245          (cons (fn (car pl)) (recur (cdr pl))))))
     494#|[
     495(pl-reverse pl)
     496--- procedure ---
     497reverses its pseudolist argument to a new pseudolist
     498with same sentinel
     499]|#
     500(define (pl-reverse pls)
     501  (let ((pls (pl-checker pl? pls)))
     502    (parameterize ((pl-parameter (pl-tail pls)))
     503      (apply pl (reverse (pl-head pls))))))
     504
     505;(define (all-equal? lst)
     506;  (if (null? lst)
     507;    #t
     508;    (null? (cdr (let loop ((lst lst) (result '()))
     509;                  (cond
     510;                    ((null? lst) result)
     511;                    ((member (car lst) result)
     512;                     (loop (cdr lst) result))
     513;                    (else (loop (cdr lst)
     514;                                (cons (car lst) result)))))))))
     515
     516(define (all cmp? lst)
     517  (if (null? lst)
     518    #t
     519    (let ((x (car lst)) (xs (cdr lst)))
     520      (let* ((gsym (gensym)) ; xs might be a list of #f
     521             (checker (lambda (arg)
     522                        (if (cmp? x arg) arg gsym))))
     523        (let loop ((xs xs))
     524          (cond
     525            ((null? xs) #t)
     526            ((cmp? (checker (car xs)) gsym) #f)
     527            (else (loop (cdr xs)))))))))
     528
     529
     530#|[
     531(pl-map fn . plss)
     532--- procedure ---
     533maps fn over the pseudolists plss as long as none of the items is
     534pl-null? and returns a new pseudolist if all sentinels are equal.
     535Note, that this is R7RS-, not R5RS-logic.
     536]|#
     537(define (pl-map fn . plss)
     538  (cond
     539    ((null? plss)
     540     (lambda plss
     541       (apply pl-map fn plss)))
     542    ((null? (cdr plss))
     543     (let ((pls (pl-checker pl? (car plss))))
     544       (parameterize ((pl-parameter (pl-tail pls)))
     545         (apply pl
     546           (let recur ((lst (pl-head pls)))
     547             (if (null? lst)
     548               lst
     549               (cons (fn (car lst))
     550                     (recur (cdr lst)))))))))
    246551    (else
    247       (let recur ((pls pls))
    248         (let ((ls (memq #t (map pl-null? pls))))
    249           (if ls
    250             (pl-tail (list-ref pls (- (length pls) (length ls))))
    251             (cons (apply fn (map car pls))
    252                   (recur (map cdr pls)))))))
    253         ;(if (memq #t (map pl-null? pls))
    254         ;  (pl-sentinel)
    255         ;  (cons (apply fn (map car pls))
    256         ;        (recur (map cdr pls))))))
     552      (let ((plss (map (pl-checker pl?) plss)))
     553        (let ((len (apply min (map pl-length plss)))
     554              (tags (map pl-tail plss)))
     555          (if (all equal? tags)
     556            (parameterize ((pl-parameter (car tags)))
     557              (apply pl
     558                (let recur ((i 0))
     559                  (if (= i len)
     560                    '()
     561                    (cons (apply fn (map (pl-at i) plss))
     562                          (recur (+ i 1)))))))
     563            (error 'pl-map "not all tags equal" tags)))))
    257564    ))
    258565
    259 (define (pl-for-each fn pl . pls)
    260   (if (null? pls)
    261     (let loop ((pl pl))
    262       (unless (pl-null? pl)
    263         (fn (car pl))
    264         (loop (cdr pl))))
    265     (let loop ((pls (cons pl pls)))
    266       (unless (memq #t (map pl-null? pls))
    267         (apply fn (map car pls))
    268         (loop (map cdr pls))))))
    269 
    270 (define (pl-memp ok? . pls)
    271   (cond
    272     ((null? pls)
    273      (lambda (pl)
    274        (pl-memp ok? pl)))
    275     ((null? (cdr pls))
    276      (let loop ((pl (car pls)))
     566#|[
     567(pl-for-each fn pls . plss)
     568--- procedure ---
     569applies fn over the pseudolists (cons pls plss)
     570stops if one of the items is pl-null?
     571Note, that this is R7RS-, not R5RS-logic
     572]|#
     573(define (pl-for-each fn pls . plss)
     574  (if (null? plss)
     575    (let* ((pls (pl-checker pl? pls))
     576           (len (pl-length pls)))
     577      (let loop ((i 0))
     578        (unless (= i len)
     579          (fn (pl-at i pls))
     580          (loop (+ i 1)))))
     581    (let* ((plss (map (pl-checker pl?) (cons pls plss)))
     582           (len (apply min (map pl-length plss))))
     583      (let ((tags (map pl-tail plss)))
     584        (if (all equal? tags)
     585          (let recur ((i 0) (plss plss))
     586            (unless (= i len)
     587              (cons (apply fn (map car plss))
     588                    (recur (+ i 1) (map cdr plss)))))
     589          (error 'pl-for-each "not all tags equal" tags))))
     590    ))
     591#|[
     592(pl-memp ok? pls)
     593(pl-memp ok?)
     594--- procedure ---
     595returns the subpseudolist starting at the first
     596item which passes the ok? test, keeping ps's sentinel.
     597Returns #f if no item passes the ok? test
     598]|#
     599(define (pl-memp ok? . plss)
     600  (cond
     601    ((null? plss)
     602     (lambda (pls)
     603       (pl-memp ok? pls)))
     604    ((null? (cdr plss))
     605     (let ((pls (pl-checker pl? (car plss))))
     606       (let loop ((lst (pl-head pls)))
     607         (cond
     608           ((null? lst) #f)
     609           ((ok? (car lst))
     610            (parameterize ((pl-parameter (pl-tail pls)))
     611              (apply pl lst)))
     612           (else (loop (cdr lst)))))))
     613    (else (error 'pl-memp "too many arguments"))))
     614
     615#|[
     616(pl-memq x pls)
     617(pl-memq x)
     618--- procedure ---
     619same as (pl-memp (cut eq? <> x) pls)
     620]|#
     621(define (pl-memq x . plss)
     622  (cond
     623    ((null? plss)
     624     (lambda (pls) (pl-memq x pls)))
     625    ((null? (cdr plss))
     626     (pl-memp (cut eq? <> x) (car plss)))
     627    (else (error 'pl-memq "too many arguments"))))
     628
     629#|[
     630(pl-memv x pls)
     631(pl-memv x)
     632--- procedure ---
     633same as (pl-memp (cut eqv? <> x) pls)
     634]|#
     635(define (pl-memv x . plss)
     636  (cond
     637    ((null? plss)
     638     (lambda (pls) (pl-memv x pls)))
     639    ((null? (cdr plss))
     640     (pl-memp (cut eqv? <> x) (car plss)))
     641    (else (error 'pl-memv "too many arguments"))))
     642
     643#|[
     644(pl-member x pls)
     645(pl-member x)
     646--- procedure ---
     647same as (pl-memp (cut equal? <> x) pls)
     648]|#
     649(define (pl-member x . plss)
     650  (cond
     651    ((null? plss)
     652     (lambda (pls) (pl-member x pls)))
     653    ((null? (cdr plss))
     654     (pl-memp (cut equal? <> x) (car plss)))
     655    (else (error 'pl-member "too many arguments"))))
     656
     657#|[
     658(pl-index ok? pls)
     659(pl-index ok?)
     660--- procedure ---
     661returns the index of the first item passing
     662the ok? test, -1 otherwise
     663]|#
     664(define (pl-index ok? . plss)
     665  (cond
     666    ((null? plss)
     667     (lambda (pls)
     668       (pl-index ok? pls)))
     669    ((null? (cdr plss))
     670     (let ((pls(pl-checker pl? (car plss))))
     671     (let loop ((k 0) (lst (pl-head pls)))
    277672       (cond
    278          ((pl-null? pl) #f)
    279          ((ok? (car pl)) pl)
    280          (else (loop (cdr pl))))))
    281     (else (error 'pl-memp "too many arguments"))))
    282 
    283 (define (pl-memq x . pls)
    284   (apply pl-memp (cut eq? <> x) pls))
    285 
    286 (define (pl-memv x . pls)
    287   (apply pl-memp (cut eqv? <> x) pls))
    288 
    289 (define (pl-member x . pls)
    290   (apply pl-memp (cut equal? <> x) pls))
    291 
    292 (define (pl-index ok? . pls)
    293   (cond
    294     ((null? pls)
    295      (lambda (pl)
    296        (pl-index ok? pl)))
    297     ((null? (cdr pls))
    298      (let loop ((k 0) (pl (car pls)))
    299        (cond
    300          ((pl-null? pl) -1)
    301          ((ok? (car pl)) k)
     673         ((null? lst) -1)
     674         ((ok? (car lst)) k)
    302675         (else
    303            (loop (+ k 1) (cdr pl))))))
     676           (loop (+ k 1) (cdr lst)))))))
    304677    (else (error 'pl-index "too many arguments"))))
    305678
    306 (define (pl-filter ok? . pls)
    307   (cond
    308     ((null? pls)
    309      (lambda (pl)
    310        (pl-filter ok? pl)))
    311     ((null? (cdr pls))
    312      (let recur ((pl (car pls)))
    313        (if (pl-null? pl)
    314          (values pl pl)
    315          (receive (yes no) (pl-filter ok? (cdr pl))
    316            (if (ok? (car pl))
    317              (values (cons (car pl) yes) no)
    318              (values yes (cons (car pl) no)))))))
     679#|[
     680(pl-filter ok? pls)
     681(pl-filter ok?)
     682--- procedure ---
     683filters a pseudolist by means of a predicate ok?
     684returning two new pseudolists, those of items of pls
     685passing the ok? test, and those that don't
     686]|#
     687(define (pl-filter ok? . plss)
     688  (cond
     689    ((null? plss)
     690     (lambda (pls)
     691       (pl-filter ok? pls)))
     692    ((null? (cdr plss))
     693     (let* ((pls (pl-checker pl? (car plss))))
     694       (receive (yes no)
     695         (let loop ((lst (pl-head pls)) (yes '()) (no '()))
     696           (if (null? lst)
     697             (values (reverse yes) (reverse no))
     698             (let ((val (car lst)))
     699               (if (ok? val)
     700                 (loop (cdr lst) (cons val yes) no)
     701                 (loop (cdr lst) yes (cons val no))))))
     702         (parameterize ((pl-parameter (pl-tail pls)))
     703           (values (apply pl yes) (apply pl no))))))
    319704    (else (error 'pl-filter "too many arguments"))))
    320705
    321 (define (pl-append pl . pls)
    322   (cond
    323     ((null? pls) pl)
    324     ((null? (cdr pls))
    325      (let recur ((pl pl))
    326        (if (pl-null? pl)
    327          (car pls)
    328          (cons (car pl) (recur (cdr pl))))))
    329     (else
    330       (pl-append pl (apply pl-append (car pls) (cdr pls))))
    331     ))
    332 
    333 (define (pl-fold-right op init . pls)
    334   (cond
    335     ((null? pls)
    336      (lambda (pl)
    337        (pl-fold-right op init pl)))
    338     ((null? (cdr pls))
    339      (let recur ((pl (car pls)))
    340        (if (pl-null? pl)
    341          init
    342          (op (car pl) (recur (cdr pl))))))
     706#|[
     707(pl-append pls . plss)
     708--- procedure ---
     709appends all argument pseudolist, provided their tags are
     710all equal
     711]|#
     712(define (pl-append pls . plss)
     713  (let ((plss (map (pl-checker pl?) (cons pls plss))))
     714    (let ((tails (map pl-tail plss))
     715          (heads (map pl-head plss)))
     716      (if (all equal? tails)
     717        (parameterize ((pl-parameter (car tails)))
     718          (apply pl (apply append heads)))
     719        (error 'pl-append "not all equal" tails)))))
     720
     721#|[
     722(pl-fold-right op init pls)
     723(pl-fold-right op init)
     724--- procedure ---
     725folds pls from the right with binary operation op
     726and starting value init
     727]|#
     728(define (pl-fold-right op init . plss)
     729  (cond
     730    ((null? plss)
     731     (lambda (pls)
     732       (pl-fold-right op init pls)))
     733    ((null? (cdr plss))
     734     (let ((pls (pl-checker pl? (car plss))))
     735       (let recur ((lst (pl-head pls)))
     736         (if (null? lst)
     737           init
     738           (op (car lst) (recur (cdr lst)))))))
    343739    (else (error 'pl-fold-right "too many arguments"))))
    344740
    345 (define (pl-fold-right0 op . pls)
    346   (cond
    347     ((null? pls)
    348      (lambda (pl)
    349        (pl-fold-right0 op pl)))
    350     ((null? (cdr pls))
    351      (let ((pl (car pls)))
    352        (if (pl-null? pl)
    353          (error 'pl-fold-right0 "pseudolist empty" pl)
    354          (apply pl-fold-right op (car pl) (cdr pl)))))
     741#|[
     742(pl-fold-right0 op pls)
     743(pl-fold-right0 op)
     744--- procedure ---
     745folds (pl-cdr pls) from the right with binary operation op
     746and starting value (pl-car pls)
     747]|#
     748(define (pl-fold-right0 op . plss)
     749  (cond
     750    ((null? plss)
     751     (lambda (pls)
     752       (pl-fold-right0 op pls)))
     753    ((null? (cdr plss))
     754     (let ((pls (pl-checker pl? (car plss))))
     755       (if (pl-null? pls)
     756         (error 'pl-fold-right0 "pseudolist empty" pls)
     757         (pl-fold-right op (pl-car pls) (pl-cdr pls)))))
    355758    (else (error 'pl-fold-right0 "too many arguments"))
    356759    ))
    357760
    358 (define (pl-fold-left op init . pls)
    359   (cond
    360     ((null? pls)
    361      (lambda (pl)
    362        (pl-fold-left op init pl)))
    363     ((null? (cdr pls))
    364      (let loop ((pl (car pls)) (result init))
    365        (if (pl-null? pl)
     761#|[
     762(pl-fold-left op init pls)
     763(pl-fold-left op init)
     764--- procedure ---
     765folds pls from the left with binary operation op
     766and starting value init
     767]|#
     768(define (pl-fold-left op init . plss)
     769  (cond
     770    ((null? plss)
     771     (lambda (pls)
     772       (pl-fold-left op init pls)))
     773    ((null? (cdr plss))
     774     (let ((pls (pl-checker pl? (car plss))))
     775     (let loop ((lst (pl-head pls)) (result init))
     776       (if (null? lst)
    366777         result
    367          (loop (cdr pl) (op result (car pl))))))
     778         (loop (cdr lst) (op result (car lst)))))))
    368779    (else (error 'pl-fold-left "too many arguments"))
    369780    ))
    370781
    371 (define (pl-fold-left0 op . pls)
    372   (cond
    373     ((null? pls)
    374      (lambda (pl)
    375        (pl-fold-left0 op pl)))
    376     ((null? (cdr pls))
    377      (let ((pl (car pls)))
    378        (if (pl-null? pl)
    379          (error 'pl-fold-left0 "pseudolist empty" pl)
    380          (apply pl-fold-left op (car pl) (cdr pl)))))
     782#|[
     783(pl-fold-left0 op pls)
     784(pl-fold-left0 op)
     785--- procedure ---
     786folds (pl-cdr pls) from the left with binary operation op
     787and starting value (pl-car pls)
     788]|#
     789(define (pl-fold-left0 op . plss)
     790  (cond
     791    ((null? plss)
     792     (lambda (pls)
     793       (pl-fold-left0 op pls)))
     794    ((null? (cdr plss))
     795     (let ((pls (pl-checker pl? (car plss))))
     796       (if (pl-null? pls)
     797         (error 'pl-fold-left0 "pseudolist empty" pls)
     798         (pl-fold-left op (pl-car pls) (pl-cdr pls)))))
    381799    (else (error 'pl-fold-left0 "too many arguments"))
    382800    ))
    383801
    384 (define (pl-adjoin obj . pls)
    385   (cond
    386     ((null? pls)
    387      (lambda (pl)
    388        (pl-adjoin obj pl)))
    389     ((null? (cdr pls))
    390      (let ((pl (car pls)))
    391        (if (pair? (pl-member obj pl))
    392          pl
    393          (cons obj pl))))
     802#|[
     803 (pl-adjoin obj pls)
     804 (pl-adjoin obj)
     805--- procedure ---
     806add obj to the front of pls only if it is not already a member of pls
     807]|#
     808(define (pl-adjoin obj . plss)
     809  (cond
     810    ((null? plss)
     811     (lambda (pls)
     812       (pl-adjoin obj pls)))
     813    ((null? (cdr plss))
     814     (let* ((pls (pl-checker pl? (car plss)))
     815            (lst (pl-head pls)))
     816       (parameterize ((pl-parameter (pl-tail pls)))
     817         (apply pl
     818           (if (member obj lst)
     819             lst
     820             (cons obj lst))))))
    394821    (else (error 'pl-adjoin "too many arguments"))
    395822    ))
    396823
    397 (define (pl-remove-dups pl)
    398   (let recur ((pl pl))
    399     (if (pl-null? pl)
    400       pl
    401       (pl-adjoin (car pl) (recur (cdr pl))))))
    402 
     824#|[
     825(pl-remove-dups pls)
     826--- procedure ---
     827removes the duplicates in the pseudolist pls
     828]|#
     829(define (pl-remove-dups pls)
     830  (let* ((pls (pl-checker pl? pls))
     831         (lst (pl-head pls))
     832         (adjoin (lambda (obj lst)
     833                   (if (member obj lst)
     834                     lst
     835                     (cons obj lst)))))
     836    (parameterize ((pl-parameter (pl-tail pls)))
     837      (apply pl
     838        (let recur ((lst lst))
     839          (if (null? lst)
     840            lst
     841            (adjoin (car lst) (recur (cdr lst)))))))))
     842
     843#|[
     844(pl-flat? xpr)
     845--- procedure ---
     846is xpr a flat pseudolist, i.e. not containing other pseudolists
     847]|#
     848(define (pl-flat? xpr)
     849  (and (pl? xpr)
     850       (not (pl-memp pl? xpr))))
     851
     852#|[
     853(pl-flatten pl-tree)
     854--- procedure ---
     855flattens the nested pseudolist pl-tree to a pseudolist,
     856i.e. splices the pseudolist items of pl-tree into pl-tree
     857provided all parameters are equal
     858]|#
    403859(define (pl-flatten pl-tree)
    404   ;(let recur ((tree pl-tree) (result (pl-sentinel)))
    405   (let recur ((tree (pl-head pl-tree)) (result (pl-tail pl-tree)))
    406     (if (pair? tree)
    407       (let ((head (car tree)) (tail (cdr tree)))
    408         (cond
    409           ((pair? head)
    410            (recur head (recur tail result)))
    411           (else
    412             (cons head (recur tail result)))))
    413       result)))
    414 
     860  (let ((pls (pl-map (lambda (x)
     861                       (cond
     862                         ((pl-flat? x) x)
     863                         ((pl? x) (pl-flatten x))
     864                         (else (pl x))))
     865                     pl-tree)))
     866    (apply pl-append (pl-head pls))))
     867           ; pl-append checks for equal tails
     868
     869#|[
     870(pl-collect item-xpr (var pls ok-xpr ...))
     871(pl-collect item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
     872--- macro ---
     873creates a new pseudolist by binding var to each element
     874of the pseudolist pls in sequence, and if it passes the checks,
     875ok-xpr ..., inserts the value of xpr into the resulting pseudolist.
     876The qualifieres, (var pls ok-xpr ...), are processed
     877sequentially from left to right, so that filters of a
     878qualifier have access to the variables of qualifiers
     879to its left.
     880]|#
    415881(define-syntax pl-collect
    416882  (syntax-rules ()
    417    ((_ item-xpr (var pl ok-xpr ...))
    418      (let recur ((seq pl))
    419        (if (pl-null? seq)
    420          seq
    421          (let ((var (car seq)))
    422            (if (and ok-xpr ...)
    423              (cons item-xpr (recur (cdr seq)))
    424              (recur (cdr seq)))))))
    425    ((_ item-xpr (var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...)
    426     (let recur ((seq pl))
    427       (if (pl-null? seq)
    428         seq
    429         (let ((var (car seq)))
    430           (if (and ok-xpr ...)
    431             (pl-append (pl-collect item-xpr (var1 pl1 ok-xpr1 ...) ...)
    432                        (recur (cdr seq)))
    433             (recur (cdr seq)))))))
     883   ((_ item-xpr (var pls ok-xpr ...))
     884    (apply pl
     885      (let recur ((seq (pl-head (pl-checker pl? pls))))
     886         (if (null? seq)
     887           seq
     888           (let ((var (car seq)))
     889             (if (and ok-xpr ...)
     890               (cons item-xpr (recur (cdr seq)))
     891               (recur (cdr seq))))))))
     892   ((_ item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
     893    (apply pl
     894      (let recur ((seq (pl-head (pl-checker pl? pls))))
     895        (if (null? seq)
     896          seq
     897          (let ((var (car seq)))
     898            (if (and ok-xpr ...)
     899              ;(append (pl-head (pl-collect item-xpr (var1 pls1 ok-xpr1
     900              ;                                            ...) ...)))
     901              (pl-head
     902                (pl-append (pl-collect item-xpr (var1 pls1 ok-xpr1 ...) ...)
     903                (apply pl (recur (cdr seq)))))
     904              (recur (cdr seq))))))))
    434905   ))
    435906
    436 
    437 ;;; (pseudolists sym ..)
    438 ;;; ----------------------------
    439 ;;; documentation procedure.
     907#|[
     908(pseudolists)
     909(pseudolists sym)
     910--- procedure ---
     911documentation procedure
     912]|#
    440913(define pseudolists
    441   (let ((alst '(
    442     (pseudolists
    443       procedure:
    444       (pseudolists)
    445       (pseudolists sym)
    446       "documentation procedure,"
    447       "the first call returns all exported symbols,"
    448       "the second documentation of symbol sym")
    449     (pl-sentinel
    450       parameter:
    451       (pl-sentinel)
    452       (pl-sentinel atom)
    453       "returns or sets the sentinel")
    454     (pl-check-sentinel?
    455       procedure?
    456       (pl-check-sentinel?)
    457       (pl-check-sentinel? pl)
    458       "checks if pl's sentinel is equal to (pl-sentinel)")
    459     (pl-change-sentinel
    460       procedure:
    461       (pl-change-sentinel new-sentinel)
    462       (pl-change-sentinel new-sentinel pl)
    463       "changes the sentinel of pl")
    464     (pl
    465       procedure:
    466       (pl . args)
    467       "creates a pseudolist from args with sentinel from pl-sentinel")
    468     (pl-maker
    469       procedure:
    470       (pl-maker len)
    471       (pl-maker len fill)
    472       "creates a pseudolist of length len and sentinel from pl-sentinel"
    473       "with items fill if given, (pl-sentinel) otherwise")
    474     (pl-null?
    475       procedure:
     914  (let (
     915    (alist '(
     916      (pl-parameter
     917        parameter:
     918        (pl-parameter)
     919        (pl-parameter new)
     920        "returns or resets the sentinel of a pseudolist, initially '()"
     921        )
     922      (pl-checker
     923        procedure:
     924        (pl-checker ok? arg)
     925        (pl-checker ok?)
     926        "type constructor: wrap the predicate ok? into a unary procedure,"
     927        "which returns its argument unchanged, if only it passes the ok? test."
     928        "An uncurried version is given as well"
     929        )
     930      (pl-checker?
     931        procedure:
     932        (pl-checker? xpr)
     933        "type predicate. Used to check if the tag can be used to check all items."
     934        )
     935      (pl
     936        procedure:
     937        (pl . args)
     938        "constructor: creates a pseudolist with sentinel tag from pl-parameter"
     939        "and items from args, encapsulated into a closure, which, when called with an"
     940        "index, returns the argument at that index, or, when called with -1,"
     941        "returns the length of args."
     942        )
     943      (pl?
     944        procedure:
     945        (pl? xpr)
     946        "type predicate"
     947        )
     948      (pl-maker
     949        procedure:
     950        (pl-maker len fill)
     951        (pl-maker len)
     952        "creates a pseudolist of length len with sentinel (pl-parameter),"
     953        "items fill or (pl-sentinel), if fill is not given"
     954        )
     955      (pl-at
     956        procedure:
     957        (pl-at k pls)
     958        (pl-at k)
     959        "returns the kth item of pls"
     960        )
     961      (pl-set!
     962        procedure:
     963        (pl-set! k val pls)
     964        "sets the kth item of pls to val"
     965        )
     966      (pl-length
     967        procedure:
     968        (pl-length pls)
     969        "returns the length of the pseudolist pls"
     970        )
     971      (pl-null?
     972        procedure:
    476973        (pl-null? xpr)
    477         "is xpr an atom equal to (pl-sentinel)")
    478     (pl?
    479       procedure:
    480       (pl? xpr)
    481       "is xpr a pseudolist, i.e either a pair or the atom (pl-sentinel)")
    482     (pl-of?
    483       procedure:
    484       (pl-of? . preds)
    485       "returns a unary predicate, which checks"
    486       "if its argument passes each predicate in preds")
    487     (pl-length
    488       procedure:
    489         (pl-length pl)
    490         "length of a pseudolist pl"
    491         "the sentinel doesn't count")
    492     (pl-head
    493       procedure:
    494         (pl-head pl)
    495         "returns the list of items with pl's sentinel stripped")
    496     (pl-tail
    497       procedure:
    498         (pl-tail pl)
    499         "returns the sentinel of the pseudolist")
    500     (pl-iterate
    501       procedure:
    502       (pl-iterate fn k)
    503       (pl-iterate fn k init)
    504       "creates a pseudolist with sentinel (pl-sentinel) applying fn to init"
    505       "recursively k times")
    506     (pl-at
    507       procedure:
    508         (pl-at k)
    509         (pl-at k pl)
    510         "returns the kth item of pl")
    511     (pl-drop
    512       procedure:
     974        "checks, if no items are stored in the pseudolist xpr"
     975        )
     976      (pl-head
     977        procedure:
     978        (pl-head pls)
     979        "returns the list part of the pseudolist pls"
     980        )
     981      (pl-tail
     982        procedure:
     983        (pl-tail pls)
     984        "returns the sentinel of the pseudolist pls"
     985        )
     986      (pl-data
     987        procedure:
     988        (pl-data pls)
     989        "returns the dotted list underlying the pseudolist pls"
     990        )
     991      (pl-cons
     992        procedure:
     993        (pl-cons x pls)
     994        (pl-cons x)
     995        "adds the item x to the front of the pseudolist pls"
     996        )
     997      (pl-car
     998        procedure:
     999        (pl-car pls)
     1000        "returns the first item of the pseudolist pls"
     1001        )
     1002      (pl-cdr
     1003        procedure:
     1004        (pl-cdr pls)
     1005        "returns a new pseudolist removing the first item of pls"
     1006        )
     1007      (pl-of?
     1008        procedure:
     1009        (pl-of? tag . preds)
     1010        "creates a unary predicate, which tests, if its argument is a"
     1011        "pseudolist with parameter tag, whose items pass all the predicates preds"
     1012        )
     1013      (pl-iterate
     1014        procedure:
     1015        (pl-iterate fn times init)
     1016        (pl-iterate fn times)
     1017        "creates a pseudolist with sentinel (pl-parameter) applying fn"
     1018        "to init recursively k times"
     1019        )
     1020      (pl-drop
     1021        procedure:
     1022        (pl-drop n pls)
    5131023        (pl-drop n)
    514         (pl-drop n pl)
    515         "returns the tail of pl removing the first n items")
    516     (pl-drop-while
    517       procedure:
     1024        "returns a new pseudolist removing the first n items of the pseudolist pls"
     1025        )
     1026      (pl-drop-while
     1027        procedure:
     1028        (pl-drop-while ok? pls)
    5181029        (pl-drop-while ok?)
    519         (pl-drop-while ok? pl)
    520         "returns the tail of pl starting with the first item"
    521         "that does not pass the ok? test")
    522     (pl-take
    523       procedure:
     1030        "returns the tail of pls starting with the first item"
     1031        "that does not pass the ok? test"
     1032        )
     1033      (pl-take
     1034        procedure:
     1035        (pl-take n pls)
    5241036        (pl-take n)
    525         (pl-take n pl)
    526         "returns the sublist of pl up to but excluding index n,"
    527         "where n is less than or equal to pl's pl-length."
    528         "The sentinel is unchanged")
    529     (pl-take-while
    530       procedure:
     1037        "returns a new pseudolist consisting of the first n items of"
     1038        "the pseudolist pls, keeping the sentinel"
     1039        )
     1040      (pl-take-while
     1041        procedure:
     1042        (pl-take-while ok? pls)
    5311043        (pl-take-while ok?)
    532         (pl-take-while ok? pl)
    533         "returns the sublist of pl consisting of items"
     1044        "returns the sublist of pls consisting of items"
    5341045        "until the first item doesn't pass the ok? test."
    535         "The sentinel remains unchanged")
    536     (pl-map
    537       procedure:
    538         (pl-map fn)
    539         (pl-map fn . pls)
    540         "maps fn over the pseudolists pls as long as none of the"
    541         "items is pl-null? and returns a new pseudolist with pl-sentinel."
    542         "The sentinel is that of the first pl-null item."
    543         "Note, that this is R7RS-, not R5RS-logic")
    544     (pl-for-each
    545       procedure:
    546         (pl-for-each fn pl . pls)
    547         "applies fn over the pseudolists (cons pl pls)"
     1046        )
     1047      (pl-reverse
     1048        procedure:
     1049        (pl-reverse pl)
     1050        "reverses its pseudolist argument to a new pseudolist"
     1051        "with same sentinel"
     1052        )
     1053      (pl-map
     1054        procedure:
     1055        (pl-map fn . plss)
     1056        "maps fn over the pseudolists plss as long as none of the items is"
     1057        "pl-null? and returns a new pseudolist if all sentinels are equal."
     1058        "Note, that this is R7RS-, not R5RS-logic."
     1059        )
     1060      (pl-for-each
     1061        procedure:
     1062        (pl-for-each fn pls . plss)
     1063        "applies fn over the pseudolists (cons pls plss)"
    5481064        "stops if one of the items is pl-null?"
    549         "Note, that this is R7RS-, not R5RS-logic")
    550     (pl-index
    551       procedure:
    552       (pl-index ok?)
    553       (pl-index ok? pl)
    554       "returns the index of the first item passing"
    555       "the ok? test, -1 otherwise")
    556     (pl-filter
    557       procedure:
     1065        "Note, that this is R7RS-, not R5RS-logic"
     1066        )
     1067      (pl-memp
     1068        procedure:
     1069        (pl-memp ok? pls)
     1070        (pl-memp ok?)
     1071        "returns the subpseudolist starting at the first"
     1072        "item which passes the ok? test, keeping ps's sentinel."
     1073        "Returns #f if no item passes the ok? test"
     1074        )
     1075      (pl-memq
     1076        procedure:
     1077        (pl-memq x pls)
     1078        (pl-memq x)
     1079        "same as (pl-memp (cut eq? <> x) pls)"
     1080        )
     1081      (pl-memv
     1082        procedure:
     1083        (pl-memv x pls)
     1084        (pl-memv x)
     1085        "same as (pl-memp (cut eqv? <> x) pls)"
     1086        )
     1087      (pl-member
     1088        procedure:
     1089        (pl-member x pls)
     1090        (pl-member x)
     1091        "same as (pl-memp (cut equal? <> x) pls)"
     1092        )
     1093      (pl-index
     1094        procedure:
     1095        (pl-index ok? pls)
     1096        (pl-index ok?)
     1097        "returns the index of the first item passing"
     1098        "the ok? test, -1 otherwise"
     1099        )
     1100      (pl-filter
     1101        procedure:
     1102        (pl-filter ok? pls)
    5581103        (pl-filter ok?)
    559         (pl-filter ok? pl)
    5601104        "filters a pseudolist by means of a predicate ok?"
    561         "Both values (passing or not passing ok?) keep pl's sentinel.")
    562     (pl-reverse
    563       procedure:
    564       (pl-reverse pl)
    565       "reverses its pseudolist argument to a new pseudolist"
    566       "with same sentinel")
    567     (pl-append
    568       procedure:
    569       (pl-append pl . pls)
    570       "appends all argument pseudolists to a pseudolist"
    571       "with sentinel of the last item")
    572     (pl-memp
    573       procedure:
    574       (pl-memp ok?)
    575       (pl-memp ok? pl)
    576       "returns the sublist starting at the first"
    577       "item which passes the ok? test, keeping ps's sentinel."
    578       "Returns #f if no item passes the ok? test")
    579     (pl-member
    580       procedure:
    581       (pl-member x)
    582       (pl-member x pl)
    583       "same as (pl-memp (cut equal? <> x) pl)")
    584     (pl-memq
    585       procedure:
    586       (pl-memq x)
    587       (pl-memq x pl)
    588       "same as (pl-memp (cut eq? <> x) pl)")
    589     (pl-memv
    590       procedure:
    591       (pl-memv x)
    592       (pl-memv x pl)
    593       "same as (pl-memp (cut eqv? <> x) pl)")
    594     (pl-fold-right
    595       procedure:
    596       (pl-fold-right op init)
    597       (pl-fold-right op init pl)
    598       "folds pl from the right with binary operation op"
    599       "and starting value init")
    600     (pl-fold-right0
    601       procedure:
    602       (pl-fold-right0 op)
    603       (pl-fold-right0 op pl)
    604       "folds (cdr pl) from the right with binary operation op"
    605       "and starting value (car pl)")
    606     (pl-fold-left
    607       procedure:
    608       (pl-fold-left op init)
    609       (pl-fold-left op init pl)
    610       "folds pl from the left with binary operation op"
    611       "and starting value init")
    612     (pl-fold-left0
    613       procedure:
    614       (pl-fold-left0 op)
    615       "folds (cdr pl) from the left with binary operation op"
    616       "and starting value (car pl)")
    617       (pl-fold-left0 op pl)
    618     (pl-adjoin
    619       procedure:
    620         (pl-adjoin obj)
    621         (pl-adjoin obj pl)
    622         "adds obj to a pseudolist provided, it isn't already there")
    623     (pl-remove-dups
    624       procedure:
    625         (pl-remove-dups lst)
    626         "removes duplicates of a pseudolist keeping the sentinel")
    627     (pl-flatten
    628       procedure:
     1105        "returning two new pseudolists, those of items of pls"
     1106        "passing the ok? test, and those that don't"
     1107        )
     1108      (pl-append
     1109        procedure:
     1110        (pl-append pls . plss)
     1111        "appends all argument pseudolist, provided their tags are"
     1112        "all equal"
     1113        )
     1114      (pl-fold-right
     1115        procedure:
     1116        (pl-fold-right op init pls)
     1117        (pl-fold-right op init)
     1118        "folds pls from the right with binary operation op"
     1119        "and starting value init"
     1120        )
     1121      (pl-fold-right0
     1122        procedure:
     1123        (pl-fold-right0 op pls)
     1124        (pl-fold-right0 op)
     1125        "folds (pl-cdr pls) from the right with binary operation op"
     1126        "and starting value (pl-car pls)"
     1127        )
     1128      (pl-fold-left
     1129        procedure:
     1130        (pl-fold-left op init pls)
     1131        (pl-fold-left op init)
     1132        "folds pls from the left with binary operation op"
     1133        "and starting value init"
     1134        )
     1135      (pl-fold-left0
     1136        procedure:
     1137        (pl-fold-left0 op pls)
     1138        (pl-fold-left0 op)
     1139        "folds (pl-cdr pls) from the left with binary operation op"
     1140        "and starting value (pl-car pls)"
     1141        )
     1142      (pl-adjoin
     1143        procedure:
     1144         (pl-adjoin obj pls)
     1145         (pl-adjoin obj)
     1146        "add obj to the front of pls only if it is not already a member of pls"
     1147        )
     1148      (pl-remove-dups
     1149        procedure:
     1150        (pl-remove-dups pls)
     1151        "removes the duplicates in the pseudolist pls"
     1152        )
     1153      (pl-flat?
     1154        procedure:
     1155        (pl-flat? xpr)
     1156        "is xpr a flat pseudolist, i.e. not containing other pseudolists"
     1157        )
     1158      (pl-flatten
     1159        procedure:
    6291160        (pl-flatten pl-tree)
    630         "flattens the nested pseudolist tree to a pseudolist"
    631         "with sentinel from the pseudolist of depth 0")
    632     (pl-collect
    633       macro:
    634       (pl-collect xpr (var pl ok-xpr ...) ....)
    635       "creates a new list by binding var to each element"
    636       "of the pseudolist pl in sequence, and if it passes the checks,"
    637       "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
    638       "The qualifieres, (var pl ok-xpr ...), are processed"
    639       "sequentially from left to right, so that filters of a"
    640       "qualifier have access to the variables of qualifiers"
    641       "to its left."
    642       "The leftmost pseudolist determines the result's sentinel")
    643     )))
    644     (case-lambda
    645       (()
    646        (map car alst))
    647       ((sym)
    648        (let ((lst (assq sym alst)))
    649          (if lst
    650            (for-each print (cdr lst))
    651            (error 'basic-macros
    652                   "not exported" sym)))))))
    653 ) ; module pseudolists
    654 
    655 ;(import pseudolists simple-tests)
    656 ;(pl-sentinel 0)
    657 ;(ppp (pl-maker 3 0)
    658 ;     (pl-memp odd? '(0 1 2 . 0))
    659 ;     (pl-memp odd? '(0 4 2 . 0))
    660 ;     (pl-memp odd? 0)
    661 ;     (pl-filter odd? '(0 1 2 3 4 . 0))
    662 ;     (pl-flatten '(0 (1 2 (3 4 . 0) . 0) . 0))
    663 ;     (pl-flatten '(0 (1 2 (3 4))))
    664 ;     )
     1161        "flattens the nested pseudolist pl-tree to a pseudolist,"
     1162        "i.e. splices the pseudolist items of pl-tree into pl-tree"
     1163        "provided all parameters are equal"
     1164        )
     1165      (pl-collect
     1166        macro:
     1167        (pl-collect item-xpr (var pls ok-xpr ...))
     1168        (pl-collect item-xpr (var pls ok-xpr ...) (var1 pls1 ok-xpr1 ...) ...)
     1169        "creates a new pseudolist by binding var to each element"
     1170        "of the pseudolist pls in sequence, and if it passes the checks,"
     1171        "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
     1172        "The qualifieres, (var pls ok-xpr ...), are processed"
     1173        "sequentially from left to right, so that filters of a"
     1174        "qualifier have access to the variables of qualifiers"
     1175        "to its left."
     1176        )
     1177      (pseudolists
     1178        procedure:
     1179        (pseudolists)
     1180        (pseudolists sym)
     1181        "with sym: documentation of exported symbol"
     1182        "without sym: list of exported symbols"
     1183        )
     1184        ))
     1185      )
     1186      (case-lambda
     1187        (() (map car alist))
     1188        ((sym)
     1189         (let ((pair (assq sym alist)))
     1190           (if pair
     1191             (for-each print (cdr pair))
     1192             (print "Choose one of " (map car alist))))))))
     1193)
  • release/5/pseudolists/trunk/tests/run.scm

    r38334 r39597  
    1 
    2 (import scheme (chicken base) (chicken condition)
    3         pseudolists
    4         simple-tests)
    5 
    6 ;; set sentinel
    7 (pl-sentinel 0)
    8 
    9 (define-checks (basic? verbose?)
    10   (pl? "x") #t
    11   (pl? '(a b . c)) #t
    12   (pl-check-sentinel? '(a b . c)) #f
    13   (pl-null? 5) #t
    14   ((pl-of?) "x") #t
    15   ((pl-of? symbol?) '(a b . #f)) #t
    16 
    17   (pl 0 1 2) '(0 1 2 . 0)
    18   (pl) 0
    19 
    20   (pl-maker 3) '(0 0 0 . 0)
    21   (pl-iterate add1 5 0) '(0 1 2 3 4 . 0)
    22 
    23   (pl-tail '(1 2 3 4 . #f)) #f
    24   (pl-tail '(0 1 2 3 2 . 2)) 2
    25  
    26   (pl-length '(0 1 2 3 . 0)) 4
    27 
    28   (pl-head '(0 1 2 3 2 . 0)) '(0 1 2 3 2)
    29   (pl-head 0) '()
    30   (pl-head '(0 . 1)) '(0)
    31 
    32   (pl-at 1 '(0 1 2 3 . 4)) 1
    33   (pl-at 2 '(0 1 2 3 . #f)) 2
    34   (condition-case (pl-at 0 1)
    35     ((exn) #f)) #f
    36 
    37   (pl-index odd? '(0 1 2 . 0)) 1
    38   (pl-index odd? '(0 2 4 . 0)) -1
    39 
    40   (pl-memp odd? '(0 2 4 . 0)) #f
    41   (pl-memv 5 '(0 1 2 3 4 . 5)) #f
    42   (pl-member 3 '(0 1 2 3 4 . 5)) '(3 4 . 5)
     1(import pseudolists)
     2
     3(import simple-tests (chicken base) (chicken condition))
     4
     5'(basic?
     6   parameter
     7   (pl-parameter 0)
     8   pls
     9   (pl 0 1 2 3)
     10   mls
     11   (pl-maker 5)
     12   ils
     13   (pl-iterate add1 5 1))
     14
     15(define-tester
     16  (basic?
     17    parameter
     18    (pl-parameter 0)
     19    pls
     20    (pl 0 1 2 3)
     21    mls
     22    (pl-maker 5)
     23    ils
     24    (pl-iterate add1 5 1))
     25  (pl-parameter)
     26  0
     27  (pl-data pls)
     28  '(0 1 2 3 . 0)
     29  (pl-data mls)
     30  '(0 0 0 0 0 . 0)
     31  (pl-data ils)
     32  '(1 2 3 4 5 . 0)
     33  (pl? pls)
     34  #t
     35  (pl? mls)
     36  #t
     37  (pl? ils)
     38  #t
     39  (pl? '(0 1 2 3))
     40  #f
     41  ((pl-of? 0) pls)
     42  #t
     43  ((pl-of? '()) mls)
     44  #f
     45  (pl-car mls)
     46  0
     47  (pl-at 3 mls)
     48  0
     49  (pl-at 3 pls)
     50  3
     51  (pls 3)
     52  3
     53  (pl-head pls)
     54  '(0 1 2 3)
     55  (pls)
     56  '(0 1 2 3)
     57  (pl-tail pls)
     58  0
     59  (pl-data pls)
     60  '(0 1 2 3 . 0)
     61  (pl-data mls)
     62  '(0 0 0 0 0 . 0)
     63  (pl-tail mls)
     64  0
     65  (pl-data ils)
     66  '(1 2 3 4 5 . 0)
     67  (ils)
     68  '(1 2 3 4 5)
     69  (pl-tail ils)
     70  0
     71  (pl-head (pl-cons -1 pls))
     72  '(-1 0 1 2 3)
     73  (pl-head (pl-cdr pls))
     74  '(1 2 3)
     75  (pl-set! 0 1 mls)
     76  (void)
     77  (pl-at 0 mls)
     78  1
     79  (pl-set! 1 2 mls)
     80  (void)
     81  (pl-at 1 mls)
     82  2
     83  (mls 1)
     84  2
     85  (mls 2 3)
     86  (void)
     87  (mls 2)
     88  3
     89  (mls)
     90  '(1 2 3 0 0)
     91  (pl-head mls)
     92  '(1 2 3 0 0))
     93
     94(newline)
     95
     96'(checked? parameter (pl-parameter (pl-checker integer?)) pls (pl 0 1 2 3))
     97
     98(define-tester
     99  (checked? parameter (pl-parameter (pl-checker integer?)) pls (pl 0 1 2 3))
     100  (pl-tail pls)
     101  (pl-parameter)
     102  (pl-head pls)
     103  '(0 1 2 3)
     104  (condition-case (pl 0 1 #f 3) ((exn) #f))
     105  #f
     106  (condition-case (pl-set! 0 #f pls) ((exn) #f))
     107  #f
     108  (pl-set! 0 100 pls)
     109  (void)
     110  (pl-car pls)
     111  100
     112  (pls 0 10)
     113  (void)
     114  (pls 0)
     115  10)
     116
     117(newline)
     118
     119'(ops? parameter
     120       (pl-parameter 0)
     121       pls
     122       (pl 0 1 2 3)
     123       mls
     124       (pl-maker 5)
     125       ils
     126       (pl-iterate add1 5 1)
     127       ii
     128       (pl-iterate add1 5))
     129
     130(define-tester
     131  (ops? parameter
     132        (pl-parameter 0)
     133        pls
     134        (pl 0 1 2 3)
     135        mls
     136        (pl-maker 5)
     137        ils
     138        (pl-iterate add1 5 1)
     139        ii
     140        (pl-iterate add1 5))
     141  (pl-parameter)
     142  0
     143  (pl-data pls)
     144  '(0 1 2 3 . 0)
     145  (pl-data mls)
     146  '(0 0 0 0 0 . 0)
     147  (pl-data ils)
     148  '(1 2 3 4 5 . 0)
     149  (pl-data (ii 1))
     150  '(1 2 3 4 5 . 0)
     151  (pls)
     152  '(0 1 2 3)
     153  (pl? pls)
     154  #t
     155  ((pl-of? 1) pls)
     156  #f
     157  ((pl-of? 0) pls)
     158  #t
     159  ((pl-of? 0 integer?) pls)
     160  #t
     161  ((pl-of? 0 integer? positive?) pls)
     162  #f
     163  (pl? '(0 1 2 3 . 0))
     164  #f
     165  (pl-at 0 pls)
     166  0
     167  (pl-at 3 pls)
     168  3
     169  (pl-head (pl-map add1 pls))
     170  '(1 2 3 4)
     171  (pl-head (pl-map + pls pls))
     172  '(0 2 4 6)
     173  (pl-index negative? pls)
     174  -1
     175  (pl-index odd? pls)
     176  1
     177  (pl-head (pl-filter odd? pls))
     178  '(1 3)
     179  (receive (_ pl-no) (pl-filter odd? pls) (pl-head pl-no))
     180  '(0 2)
     181  (pl-head (pl-append pls ils))
     182  '(0 1 2 3 1 2 3 4 5)
     183  (pl-head (pl-append pls ils mls))
     184  '(0 1 2 3 1 2 3 4 5 0 0 0 0 0)
     185  (pl-set! 2 20 pls)
     186  (void)
     187  (pl-head pls)
     188  '(0 1 20 3)
     189  (pl-length pls)
     190  4
     191  (pl-tail pls)
     192  0
     193  (pl-at 2 pls)
     194  20
     195  (pl-head pls)
     196  '(0 1 20 3)
     197  (pl-head (pl-drop 3 pls))
     198  '(3)
     199  (pl-head (pl-drop-while zero? pls))
     200  '(1 20 3)
     201  (pl-head (pl-drop-while (cut <= <> 10) pls))
     202  '(20 3)
     203  (pl-head (pl-take 3 pls))
     204  '(0 1 20)
     205  (pl-head (pl-take-while (cut <= <> 10) pls))
     206  '(0 1)
     207  (pl-head (pl-reverse pls))
     208  '(3 20 1 0)
     209  (pl-head (pl-memp (lambda (x) (> x 10)) pls))
     210  '(20 3)
     211  (pl-head mls)
     212  '(0 0 0 0 0)
     213  ((pl-of? 0 zero?) mls)
     214  #t
     215  (pl-length mls)
     216  5
     217  (pl-set! 2 20 mls)
     218  (void)
     219  (pl-head mls)
     220  '(0 0 20 0 0)
     221  (pl-tail mls)
     222  0
     223  (pl? mls)
     224  #t
     225  (pl-head (pl-maker 5 1))
     226  '(1 1 1 1 1)
     227  (pl? ils)
     228  #t
     229  (pl-head ils)
     230  '(1 2 3 4 5)
     231  (pl-tail ils)
     232  0
     233  (pl-at 2 ils)
     234  3
     235  (pl? ii)
     236  #f
     237  (pl? (ii 1))
     238  #t
     239  (pl-length (ii 1))
     240  5
     241  (pl-at 3 (ii 1))
     242  4
     243  (pl-head (pl-map * (pl 0 1 2 3) (pl 10 20)))
     244  '(0 20)
     245  (condition-case
     246    (pl-map
     247      +
     248      (parameterize ((pl-parameter #f)) (pl 0 1 2 3))
     249      (parameterize ((pl-parameter #t)) (pl 0 1 2 3)))
     250    ((exn) #f))
     251  #f)
     252
     253(newline)
     254
     255'(new-ops? parameter (pl-parameter 0) pls (pl 0 1 2 3 4 5))
     256
     257(define-tester
     258  (new-ops? parameter (pl-parameter 0) pls (pl 0 1 2 3 4 5))
     259  (pl-data pls)
     260  '(0 1 2 3 4 5 . 0)
     261  (pl-fold-right + 0 pls)
     262  15
     263  (pl-fold-left + 0 pls)
     264  15
     265  (pl-fold-right0 + pls)
     266  15
     267  (pl-fold-left0 + pls)
     268  15
     269  (pl-head (pl-fold-right pl-cons (pl) pls))
     270  '(0 1 2 3 4 5)
     271  (pl-fold-right cons '() pls)
     272  '(0 1 2 3 4 5)
     273  (pl-head (pl-adjoin 3 pls))
     274  '(0 1 2 3 4 5)
     275  (pl-head (pl-adjoin #f pls))
     276  '(#f 0 1 2 3 4 5)
     277  (pl-head (pl-remove-dups pls))
     278  '(0 1 2 3 4 5)
     279  (pl-head (pl-remove-dups (pl 0 1 0 1 0 1)))
     280  '(0 1)
     281  (pl-flat? pls)
     282  #t
     283  (pl-flat? (pl 0 (pl 1 (pl 2))))
     284  #f
     285  (pl-head (pl-flatten (pl 1 2 3)))
     286  '(1 2 3)
     287  (pl-head (pl-flatten (pl 1 '(2 3))))
     288  '(1 (2 3))
     289  (pl-head (pl-flatten (pl 1 (pl 2 3))))
     290  '(1 2 3)
     291  (pl-head (pl-flatten (pl 1 (pl 2 3) (pl 4 5) 6)))
     292  '(1 2 3 4 5 6)
     293  (pl-head (pl-flatten (pl 1 (pl 2 (pl 3)))))
     294  '(1 2 3)
     295  (pl-head (pl-flatten (pl 1 (pl 2 (pl 3 (pl 4)) 5) 6)))
     296  '(1 2 3 4 5 6)
     297  (condition-case
     298    (pl-flatten (pl 1 (parameterize ((pl-parameter #f)) (pl 2 3))))
     299    ((exn) #f))
     300  #f)
     301
     302(newline)
     303
     304(define-tester
     305  (collect?)
     306  (pl-data (pl-collect (add1 x) (x (pl 0 1 2 3))))
     307  '(1 2 3 4 . 0)
     308  (pl-data (pl-collect (add1 x) (x (pl 0 1 2 3))))
     309  '(1 2 3 4 . 0)
     310  (pl-data (pl-collect x (x (pl 0 1 2 3 4 5) (odd? x))))
     311  '(1 3 5 . 0)
     312  (pl-data (pl-collect x (x (pl 0 1 2 3 4 5) (odd? x))))
     313  '(1 3 5 . 0)
     314  (pl-data (pl-collect (* 10 n) (n (pl 0 1 2 3 4 5) (positive? n) (even? n))))
     315  '(20 40 . 0)
     316  (pl-data (pl-collect (list c k) (c (pl 'A 'B 'C)) (k (pl 1 2 3 4))))
     317  '((A 1)
     318    (A 2)
     319    (A 3)
     320    (A 4)
     321    (B 1)
     322    (B 2)
     323    (B 3)
     324    (B 4)
     325    (C 1)
     326    (C 2)
     327    (C 3)
     328    (C 4)
     329    .
     330    0))
     331
     332(newline)
     333
     334(test-all PSEUDOLISTS
     335  basic?
     336  checked?
     337  ops?
     338  new-ops?
     339  collect?
    43340  )
    44 ;(basic?)
    45 
    46 (define-checks (higher? verbose?)
    47   (pl-drop 1 '(0 1 2 3 . 4)) '(1 2 3 . 4)
    48   (pl-drop 0 1) 1
    49   (pl-drop 2 '(0 1 2 3 . #f)) '(2 3 . #f)
    50   (pl-drop-while odd? '(1 3 2 4 . #f)) '(2 4 . #f)
    51   (pl-drop-while negative? '(1 3 2 4 . #f)) '(1 3 2 4 . #f)
    52  
    53   (pl-take 3 '(0 1 2 3 4 . #t)) '(0 1 2 . #t)
    54   (pl-take 2 '(0 1 2 3 . #f)) '(0 1 . #f)
    55   (pl-take-while odd? '(1 3 2 4 . #f)) '(1 3 . #f)
    56   (pl-take-while negative? '(1 3 2 4 . #f)) #f
    57   (pl-take-while even? '(0 1 2 3 . #f)) '(0 . #f)
    58 
    59   (pl-filter odd? 1) 1
    60   (pl-filter odd? '(0 1 2 3 4)) '(1 3)
    61   (pl-filter odd? '(0 1 2 3 . 4)) '(1 3 . 4)
    62   (pl-filter even? '(0 1 2 3 . 4)) '(0 2 . 4)
    63  
    64   (pl-map add1 '(0 1 2 3 . 4)) '(1 2 3 4 . 4)
    65   (pl-map add1 '(0 1 2 3)) '(1 2 3 4)
    66   (pl-map add1 #f) #f
    67   (pl-map + '(1 2 3 . 4) '(10 20 . 30))
    68     '(11 22 . 30)
    69   (pl-map + '(1 2 3 . 4) '(10 20 . 30) '(100 200 . 300))
    70     '(111 222 . 30)
    71 
    72   (pl-reverse '(0 1 2 3 . 4)) '(3 2 1 0 . 4)
    73   (pl-reverse '(0 1 2 3)) '(3 2 1 0)
    74 
    75   (pl-append '(0 1) #f) '(0 1 . #f)
    76   (pl-append '(0 1)) '(0 1)
    77   (pl-append '(0 1) '(2 3) #f) '(0 1 2 3 . #f)
    78   (pl-append '(0 1 . #f) '(2 3)) '(0 1 2 3)
    79   (pl-append '(0 1) '(2 3) '(4 5)) '(0 1 2 3 4 5)
    80   (pl-append '(0 1 . #f) '(2 3 . #t) '(4 5)) '(0 1 2 3 4 5)
    81   (pl-append '(0 1 . #t) '(2 3 . #t) '(4 5 . #t)) '(0 1 2 3 4 5 . #t)
    82   (pl-append '(0 1 . #t) '(2 3 . #t) '(4 5) #t) '(0 1 2 3 4 5 . #t)
    83 
    84   (pl-fold-right + 0 '(1 2 3 . #f)) 6
    85   (pl-fold-left + 0 '(1 2 3)) 6
    86 
    87   (pl-adjoin 2 '(0 1 2 3 . #f)) '(0 1 2 3 . #f)
    88   (pl-adjoin 4 '(0 1 2 3 #f . #t)) '(4 0 1 2 3 #f . #t)
    89   (pl-adjoin 1 '(0 1 2 3)) '(0 1 2 3)
    90   (pl-adjoin 1 #f) '(1 . #f)
    91 
    92   (pl-remove-dups '(0 1 2 3 2 . 2)) '(0 1 3 2 . 2)
    93   (pl-remove-dups '(0 1 2 3 2 2)) '(0 1 3 2)
    94   (pl-remove-dups '(0 1 2 1 3 2)) '(0 1 3 2)
    95 
    96   (pl-flatten '(1 (2 3) . #t)) '(1 2 3 . #t)
    97   (pl-flatten '(1 (2 (3 . #f) . #t) . #f)) '(1 2 3 . #f)
    98   (pl-flatten '(1 (2 (3 . #f) . #t))) '(1 2 3)
    99   (pl-flatten #f) #f
    100   )
    101 ;(higher?)
    102  
    103 (define-checks (collect? verbose?)
    104   (pl-collect (add1 x) (x '(0 1 2 3 . #f))) ; map
    105     '(1 2 3 4 . #f)
    106   (pl-collect (add1 x) (x '(0 1 2 3))) ; map
    107     '(1 2 3 4)
    108   (pl-collect x (x '(0 1 2 3 4 5 . #f) (odd? x))) ; filter
    109     '(1 3 5 . #f)
    110   (pl-collect x (x '(0 1 2 3 4 5) (odd? x))) ; filter
    111     '(1 3 5)
    112   (pl-collect (* 10 n) (n '(0 1 2 3 4 5) (positive? n) (even? n)))
    113     '(20 40)
    114   (pl-collect (list c k)
    115               (c '(A B C))
    116               (k '(1 2 3 4)))
    117     '((A 1) (A 2) (A 3) (A 4)
    118       (B 1) (B 2) (B 3) (B 4)
    119       (C 1) (C 2) (C 3) (C 4))
    120   (pl-collect (list c k)
    121               (c '(A B C . #t))
    122               (k '(1 2 3 4 . #f)))
    123     '((A 1) (A 2) (A 3) (A 4)
    124       (B 1) (B 2) (B 3) (B 4)
    125       (C 1) (C 2) (C 3) (C 4) . #t)
    126   )
    127 ;(collect?)
    128  
    129 (check-all PSEUDOLISTS
    130  (basic?)
    131  (higher?)
    132  (collect?)
    133  )
    134 
Note: See TracChangeset for help on using the changeset viewer.