Changeset 38334 in project


Ignore:
Timestamp:
03/24/20 15:56:27 (2 weeks ago)
Author:
juergen
Message:

pseudolists 2.0 with sentinels kept

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

Legend:

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

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

    r38203 r38334  
    11; Author: Juergen Lorenz ; ju (at jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2019, Juergen Lorenz
     3; Copyright (c) 2013-2020, Juergen Lorenz
    44; All rights reserved.
    55;
     
    3232
    3333
    34 (module pseudolists
    35   (pl-maker pl-iterate pl? pl-of?
    36    pl-null? pl-length pl-head pl-sentinel
    37    pl-flatten pl-reverse
    38    pl-index pl-filter pl-map
    39    pl-memp pl-member pl-memq pl-memv
    40    pl-adjoin pl-remove-dups
    41    pl-at pl-drop pl-take pl-append
    42    pl-drop-while pl-take-while
    43    pl-fold-right pl-fold-left
    44    pl-fold-right0 pl-fold-left0
    45    pl-collect
    46   pseudolists
    47    )
     34(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
     47  )
    4848
    4949  (import scheme
    50           (only (chicken base) cut case-lambda assert print error))
    51 
    52 
    53 (define (pl-maker sentinel . args)
     50          (only (chicken base) receive
     51                unless cut case-lambda assert print error make-parameter))
     52
     53(define pl-sentinel
     54  (make-parameter '()
     55                  (lambda (x)
     56                    (if (pair? x)
     57                      '()
     58                      x))))
     59
     60(define (pl . args)
    5461  (let recur ((args args))
    5562    (if (null? args)
    56       sentinel
     63      (pl-sentinel)
    5764      (cons (car args) (recur (cdr args))))))
    5865
    59 (define pl-iterate
    60   (case-lambda
    61     ((fn times)
    62      (lambda (init)
    63        (pl-iterate fn times init)))
    64     ((fn times init)
    65      (let recur ((x init) (k 0))
    66        (if (= k times)
    67          '()
    68          (cons x (recur (fn x) (+ k 1))))))
    69     ))
    70 
    71 (define (pl? xpr)
    72   #t)
     66(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
     77(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"))))
    7392
    7493(define (my-conjoin . preds)
     
    87106        (and (ok? (car xpr))
    88107             ((pl-of? ok?) (cdr xpr)))
    89         (ok? xpr)))))
    90 
    91 (define (pl-null? xpr)
    92   (not (pair? xpr)))
     108        (pl-null? xpr)))))
    93109
    94110(define (pl-length pl)
     
    98114    (+ 1 (pl-length (cdr pl)))))
    99115
    100 (define (pl-sentinel pl)
    101   (let loop ((pl pl))
    102     (if (pl-null? pl)
    103       pl
    104       (loop (cdr pl)))))
    105 
    106116(define (pl-head pl)
    107117  (let recur ((pl pl))
     
    110120      (cons (car pl) (recur (cdr pl))))))
    111121
    112 (define pl-at
    113   (case-lambda
    114     ((n)
     122(define (pl-tail pl)
     123  (let loop ((pl pl))
     124    (if (pl-null? pl)
     125      pl
     126      (loop (cdr pl)))))
     127
     128(define (pl-iterate fn times . inits)
     129  (cond
     130    ((null? inits)
     131     (lambda (init)
     132       (pl-iterate fn times init)))
     133    ((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))))))
     138    (else (error 'pl-iterate "too many arguments"))))
     139
     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)
    115155     (lambda (pl)
    116156       (pl-at n pl)))
    117     ((n pl)
    118      (let ((pl pl))
     157    ((null? (cdr pls))
     158     (let ((pl (car pls)))
    119159       (assert (< -1 n (pl-length pl)))
    120160       (let loop ((k 0) (pl pl))
     
    124164           (else
    125165             (loop (+ k 1) (cdr pl)))))))
    126     ))
    127 
    128 (define pl-drop
    129   (case-lambda
    130     ((n)
     166    (else (error 'pl-at "too many arguments"))))
     167
     168(define (pl-drop n . pls)
     169  (cond
     170    ((null? pls)
    131171     (lambda (pl)
    132172       (pl-drop n pl)))
    133     ((n pl)
    134      (let ((pl pl))
     173    ((null? (cdr pls))
     174     (let ((pl (car pls)))
    135175       (assert (or (pl-null? pl) (< -1 n (pl-length pl))))
    136176       (let loop ((n n) (pl pl))
    137          (print "PPP " pl)
    138177         (cond
    139            ((pl-null? pl) (pl-head pl))
    140            ((zero? n) (pl-head pl))
     178           ((pl-null? pl) pl)
     179           ((zero? n) pl)
    141180           (else
    142181             (loop (- n 1) (cdr pl)))))))
    143     ))
    144 
    145 (define pl-drop-while
    146   (case-lambda
    147     ((ok?)
     182    (else
     183      (error 'pl-drop "too many arguments"))))
     184
     185(define (pl-drop-while ok? . pls)
     186  (cond
     187    ((null? pls)
    148188     (lambda (pl)
    149189       (pl-drop-while ok? pl)))
    150     ((ok? pl)
    151      (let loop ((pl pl))
    152        (if (pl-null? pl)
    153          '()
    154          (let ((first (car pl)) (rest (cdr pl)))
    155            (if (ok? first)
    156              (loop rest)
    157              (pl-head pl))))))
    158     ))
    159 
    160 (define pl-take
    161   (case-lambda
    162     ((n)
     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)))
     197    (else (error 'pl-drop-while "too many arguments"))))
     198
     199(define (pl-take n . pls)
     200  (cond
     201    ((null? pls)
    163202     (lambda (pl)
    164203       (pl-take n pl)))
    165     ((n pl)
    166      (assert (or (pl-null? pl) (< -1 n (pl-length pl))))
    167      (let recur ((k 0) (pl pl))
    168        (cond
    169          ((pl-null? pl)
    170           '())
    171          ((< k n)
    172           (cons (car pl) (recur (+ k 1) (cdr pl))))
    173          (else (recur (+ k 1) (cdr pl))))))
    174     ))
     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)))))))
     213    (else (error 'pl-take "too many arguments"))))
    175214     
    176 (define pl-take-while
    177   (case-lambda
    178     ((ok?)
     215(define (pl-take-while ok? . pls)
     216  (cond
     217    ((null? pls)
    179218     (lambda (pl)
    180219       (pl-take-while ok? pl)))
    181     ((ok? pl)
    182      (let recur ((pl pl))
    183        (if (pl-null? pl)
    184          '()
     220    ((null? (cdr pls))
     221     (let recur ((pl (car pls)))
     222       (if (pl-null? pl)
     223         pl
    185224         (let ((first (car pl)) (rest (cdr pl)))
    186225           (if (ok? first)
    187226             (cons first (recur rest))
    188              (recur rest))))))
    189     ))
     227             (pl-tail rest))))))
     228    (else (error 'pl-take-while "too many arguments"))))
    190229
    191230(define (pl-reverse pl)
    192   (let loop ((pl pl) (result '()))
     231  (let loop ((pl pl) (result (pl-tail pl)))
    193232    (if (pl-null? pl)
    194233      result
    195234      (loop (cdr pl) (cons (car pl) result)))))
    196235
    197 (define pl-map
    198   (case-lambda
    199     ((fn)
    200      (lambda (pl)
    201        (pl-map fn pl)))
    202     ((fn pl)
    203      (let recur ((pl pl))
    204        (if (pl-null? pl)
    205          '()
     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
    206245         (cons (fn (car pl)) (recur (cdr pl))))))
     246    (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))))))
    207257    ))
    208258
    209 (define pl-memp
    210   (case-lambda
    211     ((ok?)
     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)
    212273     (lambda (pl)
    213274       (pl-memp ok? pl)))
    214     ((ok? pl)
    215      (let ((result
    216              (let recur ((pl pl))
    217                (if (pl-null? pl)
    218                  '()
    219                  (let ((first (car pl))
    220                        (rest (cdr pl)))
    221                    (if (ok? first)
    222                      (cons first rest)
    223                      (recur rest)))))))
    224        (if (null? result) #f (pl-head result))))
    225     ))
     275    ((null? (cdr pls))
     276     (let loop ((pl (car pls)))
     277       (cond
     278         ((pl-null? pl) #f)
     279         ((ok? (car pl)) pl)
     280         (else (loop (cdr pl))))))
     281    (else (error 'pl-memp "too many arguments"))))
    226282
    227283(define (pl-memq x . pls)
     
    234290  (apply pl-memp (cut equal? <> x) pls))
    235291
    236 (define pl-index
    237   (case-lambda
    238     ((ok?)
     292(define (pl-index ok? . pls)
     293  (cond
     294    ((null? pls)
    239295     (lambda (pl)
    240296       (pl-index ok? pl)))
    241     ((ok? pl)
    242      (let loop ((k 0) (pl pl))
     297    ((null? (cdr pls))
     298     (let loop ((k 0) (pl (car pls)))
    243299       (cond
    244300         ((pl-null? pl) -1)
     
    246302         (else
    247303           (loop (+ k 1) (cdr pl))))))
     304    (else (error 'pl-index "too many arguments"))))
     305
     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)))))))
     319    (else (error 'pl-filter "too many arguments"))))
     320
     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))))
    248331    ))
    249332
    250 (define pl-filter
    251   (case-lambda
    252     ((ok?)
    253      (lambda (pl)
    254        (pl-filter ok? pl)))
    255     ((ok? pl)
    256      (let recur ((pl pl))
    257        (if (pl-null? pl)
    258          '()
    259          (let ((first (car pl)) (rest (cdr pl)))
    260            (if (ok? first)
    261              (cons first (recur rest))
    262              (recur rest))))))
    263     ))
    264 
    265 (define pl-append
    266   (case-lambda
    267     ((pl) pl)
    268     ((pl0 pl1)
    269      (let recur ((pl pl0))
    270        (if (pl-null? pl)
    271          (pl-head pl1)
    272          (cons (car pl) (recur (cdr pl))))))
    273     ((pl0 pl1 . pls)
    274      (pl-append pl0 (apply pl-append pl1 pls)))
    275     ))
    276 
    277 (define pl-fold-right
    278   (case-lambda
    279     ((op init)
     333(define (pl-fold-right op init . pls)
     334  (cond
     335    ((null? pls)
    280336     (lambda (pl)
    281337       (pl-fold-right op init pl)))
    282     ((op init pl)
    283      (let recur ((pl pl))
     338    ((null? (cdr pls))
     339     (let recur ((pl (car pls)))
    284340       (if (pl-null? pl)
    285341         init
    286342         (op (car pl) (recur (cdr pl))))))
    287     ))
    288 
    289 (define pl-fold-right0
    290   (case-lambda
    291     ((op)
     343    (else (error 'pl-fold-right "too many arguments"))))
     344
     345(define (pl-fold-right0 op . pls)
     346  (cond
     347    ((null? pls)
    292348     (lambda (pl)
    293349       (pl-fold-right0 op pl)))
    294     ((op pl)
    295      (let ((pl pl))
     350    ((null? (cdr pls))
     351     (let ((pl (car pls)))
    296352       (if (pl-null? pl)
    297353         (error 'pl-fold-right0 "pseudolist empty" pl)
    298354         (apply pl-fold-right op (car pl) (cdr pl)))))
     355    (else (error 'pl-fold-right0 "too many arguments"))
    299356    ))
    300357
    301 (define pl-fold-left
    302   (case-lambda
    303     ((op init)
     358(define (pl-fold-left op init . pls)
     359  (cond
     360    ((null? pls)
    304361     (lambda (pl)
    305362       (pl-fold-left op init pl)))
    306     ((op init pl)
    307      (let loop ((pl pl) (result init))
     363    ((null? (cdr pls))
     364     (let loop ((pl (car pls)) (result init))
    308365       (if (pl-null? pl)
    309366         result
    310367         (loop (cdr pl) (op result (car pl))))))
     368    (else (error 'pl-fold-left "too many arguments"))
    311369    ))
    312370
    313 (define pl-fold-left0
    314   (case-lambda
    315     ((op)
     371(define (pl-fold-left0 op . pls)
     372  (cond
     373    ((null? pls)
    316374     (lambda (pl)
    317375       (pl-fold-left0 op pl)))
    318     ((op pl)
    319      (let ((pl pl))
     376    ((null? (cdr pls))
     377     (let ((pl (car pls)))
    320378       (if (pl-null? pl)
    321379         (error 'pl-fold-left0 "pseudolist empty" pl)
    322380         (apply pl-fold-left op (car pl) (cdr pl)))))
     381    (else (error 'pl-fold-left0 "too many arguments"))
    323382    ))
    324383
    325 (define pl-adjoin
    326   (case-lambda
    327     ((obj)
     384(define (pl-adjoin obj . pls)
     385  (cond
     386    ((null? pls)
    328387     (lambda (pl)
    329388       (pl-adjoin obj pl)))
    330     ((obj pl)
    331      (let ((pl pl))
     389    ((null? (cdr pls))
     390     (let ((pl (car pls)))
    332391       (if (pair? (pl-member obj pl))
    333          (pl-head pl)
    334          (pl-head (cons obj pl)))))
     392         pl
     393         (cons obj pl))))
     394    (else (error 'pl-adjoin "too many arguments"))
    335395    ))
    336396
     
    338398  (let recur ((pl pl))
    339399    (if (pl-null? pl)
    340       '()
     400      pl
    341401      (pl-adjoin (car pl) (recur (cdr pl))))))
    342402
    343403(define (pl-flatten pl-tree)
    344   (let recur ((tree pl-tree) (result '()))
     404  ;(let recur ((tree pl-tree) (result (pl-sentinel)))
     405  (let recur ((tree (pl-head pl-tree)) (result (pl-tail pl-tree)))
    345406    (if (pair? tree)
    346407      (let ((head (car tree)) (tail (cdr tree)))
     
    357418     (let recur ((seq pl))
    358419       (if (pl-null? seq)
    359          '()
     420         seq
    360421         (let ((var (car seq)))
    361422           (if (and ok-xpr ...)
     
    365426    (let recur ((seq pl))
    366427      (if (pl-null? seq)
    367         '()
     428        seq
    368429        (let ((var (car seq)))
    369430          (if (and ok-xpr ...)
     
    386447      "the first call returns all exported symbols,"
    387448      "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")
    388468    (pl-maker
    389469      procedure:
    390       (pl-maker sentinel . args)
    391       "creates a pseudolist with sentinel from args")
     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:
     476        (pl-null? xpr)
     477        "is xpr an atom equal to (pl-sentinel)")
    392478    (pl?
    393479      procedure:
    394480      (pl? xpr)
    395       "is xpr a pl?"
    396       "i.e. not a list?")
     481      "is xpr a pseudolist, i.e either a pair or the atom (pl-sentinel)")
    397482    (pl-of?
    398483      procedure:
     
    400485      "returns a unary predicate, which checks"
    401486      "if its argument passes each predicate in preds")
    402     (pl-null?
    403       procedure:
    404         (pl-null? xpr)
    405         "is xpr an atom, i.e. not a pair?")
    406     (pl-iterate
    407       procedure:
    408       (pl-iterate fn k)
    409       (pl-iterate fn k init)
    410       "creates a list  applying fn to init"
    411       "recursively k times")
    412487    (pl-length
    413488      procedure:
     
    415490        "length of a pseudolist pl"
    416491        "the sentinel doesn't count")
    417     (pl-sentinel
    418       procedure:
    419         (pl-sentinel pl)
    420         "returns the sentinel of pl")
    421492    (pl-head
    422493      procedure:
    423494        (pl-head pl)
    424495        "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")
    425506    (pl-at
    426507      procedure:
     
    430511    (pl-drop
    431512      procedure:
    432         (pl-drop pl)
     513        (pl-drop n)
    433514        (pl-drop n pl)
    434         "returns the tail of pl removing all head items"
    435         "that pass the ok? test")
     515        "returns the tail of pl removing the first n items")
    436516    (pl-drop-while
    437517      procedure:
    438         (pl-drop-while pl)
    439         (pl-drop-while n pl)
     518        (pl-drop-while ok?)
     519        (pl-drop-while ok? pl)
    440520        "returns the tail of pl starting with the first item"
    441521        "that does not pass the ok? test")
    442522    (pl-take
    443523      procedure:
     524        (pl-take n)
    444525        (pl-take n pl)
    445         (pl-take pl)
    446526        "returns the sublist of pl up to but excluding index n,"
    447         "where n is less than or equal to pl's pl-length")
     527        "where n is less than or equal to pl's pl-length."
     528        "The sentinel is unchanged")
    448529    (pl-take-while
    449530      procedure:
    450         (pl-take-while pl)
     531        (pl-take-while ok?)
    451532        (pl-take-while ok? pl)
    452533        "returns the sublist of pl consisting of items"
    453         "which pass the ok? test")
     534        "until the first item doesn't pass the ok? test."
     535        "The sentinel remains unchanged")
    454536    (pl-map
    455537      procedure:
    456538        (pl-map fn)
    457         (pl-map fn pl)
    458         "maps fn over the pseudolist pl and returns a new list")
     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)"
     548        "stops if one of the items is pl-null?"
     549        "Note, that this is R7RS-, not R5RS-logic")
    459550    (pl-index
    460551      procedure:
     
    467558        (pl-filter ok?)
    468559        (pl-filter ok? pl)
    469         "filters a pseudolist by means of a predicate ok?")
     560        "filters a pseudolist by means of a predicate ok?"
     561        "Both values (passing or not passing ok?) keep pl's sentinel.")
    470562    (pl-reverse
    471563      procedure:
    472564      (pl-reverse pl)
    473       "reverses its pseudolist argument to a new list")
     565      "reverses its pseudolist argument to a new pseudolist"
     566      "with same sentinel")
    474567    (pl-append
    475568      procedure:
    476569      (pl-append pl . pls)
    477       "appends all argument pseudolists to a list")
     570      "appends all argument pseudolists to a pseudolist"
     571      "with sentinel of the last item")
    478572    (pl-memp
    479573      procedure:
     
    481575      (pl-memp ok? pl)
    482576      "returns the sublist starting at the first"
    483       "item which passes the ok? test,"
    484       "returns #f if now item passes the ok? test")
     577      "item which passes the ok? test, keeping ps's sentinel."
     578      "Returns #f if no item passes the ok? test")
    485579    (pl-member
    486580      procedure:
     
    526620        (pl-adjoin obj)
    527621        (pl-adjoin obj pl)
    528         "adds obj to a pseudolist stripping the sentinel,"
    529         "provided, it isn't already there")
     622        "adds obj to a pseudolist provided, it isn't already there")
    530623    (pl-remove-dups
    531624      procedure:
    532625        (pl-remove-dups lst)
    533         "removes duplicates of a pseudolist stripping the sentinel")
     626        "removes duplicates of a pseudolist keeping the sentinel")
    534627    (pl-flatten
    535628      procedure:
    536629        (pl-flatten pl-tree)
    537         "flattens the nested pseudolist tree to a list")
     630        "flattens the nested pseudolist tree to a pseudolist"
     631        "with sentinel from the pseudolist of depth 0")
    538632    (pl-collect
    539633      macro:
     
    541635      "creates a new list by binding var to each element"
    542636      "of the pseudolist pl in sequence, and if it passes the checks,"
    543       "ok-xpr ..., inserts the value of xpr into the resulting list."
     637      "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
    544638      "The qualifieres, (var pl ok-xpr ...), are processed"
    545639      "sequentially from left to right, so that filters of a"
    546640      "qualifier have access to the variables of qualifiers"
    547       "to its left.")
     641      "to its left."
     642      "The leftmost pseudolist determines the result's sentinel")
    548643    )))
    549644    (case-lambda
     
    559654
    560655;(import pseudolists simple-tests)
    561  
     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;     )
  • release/5/pseudolists/tags/2.0/tests/run.scm

    r38201 r38334  
    44        simple-tests)
    55
    6 ;(define pl (pl-maker #f 0 1 2))
     6;; set sentinel
     7(pl-sentinel 0)
    78
    8 (define-test (pseudolists?)
    9   (pl? "x")
    10   (pl? '(a b . c))
    11   (pl-null? 5)
    12   ((pl-of?) "x")
    13   ((pl-of? symbol?) '(a b . c))
     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
    1416
    15   (equal? (pl-maker #f 0 1 2) '(0 1 2 . #f))
    16   (not (pl-maker #f))
     17  (pl 0 1 2) '(0 1 2 . 0)
     18  (pl) 0
    1719
    18   (equal? (pl-iterate add1 5 0) '(0 1 2 3 4))
     20  (pl-maker 3) '(0 0 0 . 0)
     21  (pl-iterate add1 5 0) '(0 1 2 3 4 . 0)
    1922
    20   (not (pl-sentinel '(1 2 3 4 . #f)))
    21   (= (pl-sentinel '(0 1 2 3 2 . 2)) 2)
     23  (pl-tail '(1 2 3 4 . #f)) #f
     24  (pl-tail '(0 1 2 3 2 . 2)) 2
    2225 
    23   (= (pl-length '(0 1 2 3 . 4)) 4)
     26  (pl-length '(0 1 2 3 . 0)) 4
    2427
    25   (equal? (pl-head '(0 1 2 3 2 . 2)) '(0 1 2 3 2))
    26   (equal? (pl-head 0) '())
    27   (equal? (pl-head '(0 . 1)) '(0))
     28  (pl-head '(0 1 2 3 2 . 0)) '(0 1 2 3 2)
     29  (pl-head 0) '()
     30  (pl-head '(0 . 1)) '(0)
    2831
    29   (= (pl-at 1 '(0 1 2 3 . 4)) 1)
    30   (= (pl-at 2 '(0 1 2 3 . #f)) 2)
    31   (not (condition-case (pl-at 0 1)
    32          ((exn) #f)))
     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
    3336
    34   (= (pl-index odd? '(0 1 2 . 3)) 1)
    35   (= (pl-index odd? '(0 2 4 . 1)) -1)
     37  (pl-index odd? '(0 1 2 . 0)) 1
     38  (pl-index odd? '(0 2 4 . 0)) -1
    3639
    37   (equal? (pl-drop 1 '(0 1 2 3 . 4))
    38           '(1 2 3))
    39   (null? (pl-drop 0 1))
    40   (equal? (pl-drop 2 '(0 1 2 3 . #f)) '(2 3))
    41   (equal? (pl-drop-while odd? '(1 3 2 4 . #f)) '(2 4))
    42   (equal? (pl-drop-while negative? '(1 3 2 4 . #f)) '(1 3 2 4))
     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)
     43  )
     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)
    4352 
    44   (equal? (pl-take 3 '(0 1 2 3 4 . #t)) '(0 1 2))
    45   (equal? (pl-take 2 '(0 1 2 3 . #f)) '(0 1))
    46   (equal? (pl-take-while odd? '(1 3 2 4 . #f)) '(1 3))
    47   (null? (pl-take-while negative? '(1 3 2 4)))
     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)
    4858
    49   (null? (pl-filter odd? 1))
    50   (equal? (pl-filter odd? '(0 1 2 3 4)) '(1 3))
    51   (equal? (pl-filter odd? '(0 1 2 3 . 4)) '(1 3))
    52   (equal? (pl-filter even? '(0 1 2 3 . 4)) '(0 2))
     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)
    5363 
    54   (equal? (pl-map add1 '(0 1 2 3 . 4)) '(1 2 3 4))
    55   (equal? (pl-map add1 '(0 1 2 3 . 4)) '(1 2 3 4))
    56   (equal? (pl-map add1 '(0 1 2 3)) '(1 2 3 4))
    57   (null? (pl-map add1 #f))
     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)
    5871
    59   (not (pl-memp odd? '(0 2 4 . #t)))
    60   (not (pl-memv 5 '(0 1 2 3 4 . 5)))
    61   (equal? (pl-member 3 '(0 1 2 3 4 . 5)) '(3 4))
     72  (pl-reverse '(0 1 2 3 . 4)) '(3 2 1 0 . 4)
     73  (pl-reverse '(0 1 2 3)) '(3 2 1 0)
    6274
    63   (equal? (pl-reverse '(0 1 2 3 . 4)) '(3 2 1 0))
    64   (equal? (pl-reverse '(0 1 2 3 . 4)) '(3 2 1 0))
    65   (equal? (pl-reverse '(0 1 2 3)) '(3 2 1 0))
     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)
    6683
    67   (equal? (pl-append '(0 1) #f) '(0 1))
    68   (equal? (pl-append '(0 1)) '(0 1))
    69   (equal? (pl-append '(0 1) '(2 3) #f) '(0 1 2 3))
    70   (equal? (pl-append '(0 1 . #f) '(2 3)) '(0 1 2 3))
    71   (equal? (pl-append '(0 1) '(2 3) '(4 5)) '(0 1 2 3 4 5))
    72   (equal? (pl-append '(0 1 . #f) '(2 3 . #t) '(4 5)) '(0 1 2 3 4 5))
    73   (equal? (pl-append '(0 1 . #t) '(2 3 . #t) '(4 5 . #t)) '(0 1 2 3 4 5))
    74   (equal? (pl-append '(0 1 . #t) '(2 3 . #t) '(4 5) #t)
    75           '(0 1 2 3 4 5))
     84  (pl-fold-right + 0 '(1 2 3 . #f)) 6
     85  (pl-fold-left + 0 '(1 2 3)) 6
    7686
    77   (= (pl-fold-right + 0 '(1 2 3 . #f)) 6)
    78   (= (pl-fold-left + 0 '(1 2 3)) 6)
     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)
    7991
    80   (equal? (pl-adjoin 2 '(0 1 2 3 . #f)) '(0 1 2 3))
    81   (equal? (pl-adjoin 4 '(0 1 2 3 #f . #t)) '(4 0 1 2 3 #f))
    82   (equal? (pl-adjoin 1 '(0 1 2 3)) '(0 1 2 3))
    83   (equal? (pl-adjoin 1 #f) '(1))
     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)
    8495
    85   (equal? (pl-remove-dups '(0 1 2 3 2 . 2)) '(0 1 3 2))
    86   (equal? (pl-remove-dups '(0 1 2 3 2 2)) '(0 1 3 2))
    87   (equal? (pl-remove-dups '(0 1 2 1 3 2)) '(0 1 3 2))
    88 
    89   (equal? (pl-flatten '(1 (2 3) . #t)) '(1 2 3))
    90   (equal? (pl-flatten '(1 (2 (3 . #f) . #t) . #f)) '(1 2 3))
    91   (null? (pl-flatten #f))
     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?)
    92102 
    93   (equal? (pl-collect (add1 x) (x '(0 1 2 3 . #f))) ; map
    94     '(1 2 3 4))
    95   (equal? (pl-collect (add1 x) (x '(0 1 2 3))) ; map
    96     '(1 2 3 4))
    97   (equal? (pl-collect x (x '(0 1 2 3 4 5 . #f) (odd? x))) ; filter
    98     '(1 3 5))
    99   (equal? (pl-collect x (x '(0 1 2 3 4 5) (odd? x))) ; filter
    100     '(1 3 5))
    101   (equal? (pl-collect (* 10 n) (n '(0 1 2 3 4 5) (positive? n) (even? n)))
    102     '(20 40))
    103   (equal? (pl-collect (list c k)
    104                       (c '(A B C))
    105                       (k '(1 2 3 4)))
     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)))
    106117    '((A 1) (A 2) (A 3) (A 4)
    107118      (B 1) (B 2) (B 3) (B 4)
    108       (C 1) (C 2) (C 3) (C 4)))
    109   (equal? (pl-collect (list c k)
    110                       (c '(A B C . #f))
    111                       (k '(1 2 3 4 . #f)))
     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)))
    112123    '((A 1) (A 2) (A 3) (A 4)
    113124      (B 1) (B 2) (B 3) (B 4)
    114       (C 1) (C 2) (C 3) (C 4)))
     125      (C 1) (C 2) (C 3) (C 4) . #t)
    115126  )
     127;(collect?)
    116128 
    117 (compound-test (PSEUDOLISTS)
    118   (pseudolists?)
    119   )
     129(check-all PSEUDOLISTS
     130 (basic?)
     131 (higher?)
     132 (collect?)
     133 )
     134
  • release/5/pseudolists/trunk/pseudolists.egg

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

    r38203 r38334  
    11; Author: Juergen Lorenz ; ju (at jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2019, Juergen Lorenz
     3; Copyright (c) 2013-2020, Juergen Lorenz
    44; All rights reserved.
    55;
     
    3232
    3333
    34 (module pseudolists
    35   (pl-maker pl-iterate pl? pl-of?
    36    pl-null? pl-length pl-head pl-sentinel
    37    pl-flatten pl-reverse
    38    pl-index pl-filter pl-map
    39    pl-memp pl-member pl-memq pl-memv
    40    pl-adjoin pl-remove-dups
    41    pl-at pl-drop pl-take pl-append
    42    pl-drop-while pl-take-while
    43    pl-fold-right pl-fold-left
    44    pl-fold-right0 pl-fold-left0
    45    pl-collect
    46   pseudolists
    47    )
     34(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
     47  )
    4848
    4949  (import scheme
    50           (only (chicken base) cut case-lambda assert print error))
    51 
    52 
    53 (define (pl-maker sentinel . args)
     50          (only (chicken base) receive
     51                unless cut case-lambda assert print error make-parameter))
     52
     53(define pl-sentinel
     54  (make-parameter '()
     55                  (lambda (x)
     56                    (if (pair? x)
     57                      '()
     58                      x))))
     59
     60(define (pl . args)
    5461  (let recur ((args args))
    5562    (if (null? args)
    56       sentinel
     63      (pl-sentinel)
    5764      (cons (car args) (recur (cdr args))))))
    5865
    59 (define pl-iterate
    60   (case-lambda
    61     ((fn times)
    62      (lambda (init)
    63        (pl-iterate fn times init)))
    64     ((fn times init)
    65      (let recur ((x init) (k 0))
    66        (if (= k times)
    67          '()
    68          (cons x (recur (fn x) (+ k 1))))))
    69     ))
    70 
    71 (define (pl? xpr)
    72   #t)
     66(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
     77(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"))))
    7392
    7493(define (my-conjoin . preds)
     
    87106        (and (ok? (car xpr))
    88107             ((pl-of? ok?) (cdr xpr)))
    89         (ok? xpr)))))
    90 
    91 (define (pl-null? xpr)
    92   (not (pair? xpr)))
     108        (pl-null? xpr)))))
    93109
    94110(define (pl-length pl)
     
    98114    (+ 1 (pl-length (cdr pl)))))
    99115
    100 (define (pl-sentinel pl)
    101   (let loop ((pl pl))
    102     (if (pl-null? pl)
    103       pl
    104       (loop (cdr pl)))))
    105 
    106116(define (pl-head pl)
    107117  (let recur ((pl pl))
     
    110120      (cons (car pl) (recur (cdr pl))))))
    111121
    112 (define pl-at
    113   (case-lambda
    114     ((n)
     122(define (pl-tail pl)
     123  (let loop ((pl pl))
     124    (if (pl-null? pl)
     125      pl
     126      (loop (cdr pl)))))
     127
     128(define (pl-iterate fn times . inits)
     129  (cond
     130    ((null? inits)
     131     (lambda (init)
     132       (pl-iterate fn times init)))
     133    ((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))))))
     138    (else (error 'pl-iterate "too many arguments"))))
     139
     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)
    115155     (lambda (pl)
    116156       (pl-at n pl)))
    117     ((n pl)
    118      (let ((pl pl))
     157    ((null? (cdr pls))
     158     (let ((pl (car pls)))
    119159       (assert (< -1 n (pl-length pl)))
    120160       (let loop ((k 0) (pl pl))
     
    124164           (else
    125165             (loop (+ k 1) (cdr pl)))))))
    126     ))
    127 
    128 (define pl-drop
    129   (case-lambda
    130     ((n)
     166    (else (error 'pl-at "too many arguments"))))
     167
     168(define (pl-drop n . pls)
     169  (cond
     170    ((null? pls)
    131171     (lambda (pl)
    132172       (pl-drop n pl)))
    133     ((n pl)
    134      (let ((pl pl))
     173    ((null? (cdr pls))
     174     (let ((pl (car pls)))
    135175       (assert (or (pl-null? pl) (< -1 n (pl-length pl))))
    136176       (let loop ((n n) (pl pl))
    137          (print "PPP " pl)
    138177         (cond
    139            ((pl-null? pl) (pl-head pl))
    140            ((zero? n) (pl-head pl))
     178           ((pl-null? pl) pl)
     179           ((zero? n) pl)
    141180           (else
    142181             (loop (- n 1) (cdr pl)))))))
    143     ))
    144 
    145 (define pl-drop-while
    146   (case-lambda
    147     ((ok?)
     182    (else
     183      (error 'pl-drop "too many arguments"))))
     184
     185(define (pl-drop-while ok? . pls)
     186  (cond
     187    ((null? pls)
    148188     (lambda (pl)
    149189       (pl-drop-while ok? pl)))
    150     ((ok? pl)
    151      (let loop ((pl pl))
    152        (if (pl-null? pl)
    153          '()
    154          (let ((first (car pl)) (rest (cdr pl)))
    155            (if (ok? first)
    156              (loop rest)
    157              (pl-head pl))))))
    158     ))
    159 
    160 (define pl-take
    161   (case-lambda
    162     ((n)
     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)))
     197    (else (error 'pl-drop-while "too many arguments"))))
     198
     199(define (pl-take n . pls)
     200  (cond
     201    ((null? pls)
    163202     (lambda (pl)
    164203       (pl-take n pl)))
    165     ((n pl)
    166      (assert (or (pl-null? pl) (< -1 n (pl-length pl))))
    167      (let recur ((k 0) (pl pl))
    168        (cond
    169          ((pl-null? pl)
    170           '())
    171          ((< k n)
    172           (cons (car pl) (recur (+ k 1) (cdr pl))))
    173          (else (recur (+ k 1) (cdr pl))))))
    174     ))
     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)))))))
     213    (else (error 'pl-take "too many arguments"))))
    175214     
    176 (define pl-take-while
    177   (case-lambda
    178     ((ok?)
     215(define (pl-take-while ok? . pls)
     216  (cond
     217    ((null? pls)
    179218     (lambda (pl)
    180219       (pl-take-while ok? pl)))
    181     ((ok? pl)
    182      (let recur ((pl pl))
    183        (if (pl-null? pl)
    184          '()
     220    ((null? (cdr pls))
     221     (let recur ((pl (car pls)))
     222       (if (pl-null? pl)
     223         pl
    185224         (let ((first (car pl)) (rest (cdr pl)))
    186225           (if (ok? first)
    187226             (cons first (recur rest))
    188              (recur rest))))))
    189     ))
     227             (pl-tail rest))))))
     228    (else (error 'pl-take-while "too many arguments"))))
    190229
    191230(define (pl-reverse pl)
    192   (let loop ((pl pl) (result '()))
     231  (let loop ((pl pl) (result (pl-tail pl)))
    193232    (if (pl-null? pl)
    194233      result
    195234      (loop (cdr pl) (cons (car pl) result)))))
    196235
    197 (define pl-map
    198   (case-lambda
    199     ((fn)
    200      (lambda (pl)
    201        (pl-map fn pl)))
    202     ((fn pl)
    203      (let recur ((pl pl))
    204        (if (pl-null? pl)
    205          '()
     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
    206245         (cons (fn (car pl)) (recur (cdr pl))))))
     246    (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))))))
    207257    ))
    208258
    209 (define pl-memp
    210   (case-lambda
    211     ((ok?)
     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)
    212273     (lambda (pl)
    213274       (pl-memp ok? pl)))
    214     ((ok? pl)
    215      (let ((result
    216              (let recur ((pl pl))
    217                (if (pl-null? pl)
    218                  '()
    219                  (let ((first (car pl))
    220                        (rest (cdr pl)))
    221                    (if (ok? first)
    222                      (cons first rest)
    223                      (recur rest)))))))
    224        (if (null? result) #f (pl-head result))))
    225     ))
     275    ((null? (cdr pls))
     276     (let loop ((pl (car pls)))
     277       (cond
     278         ((pl-null? pl) #f)
     279         ((ok? (car pl)) pl)
     280         (else (loop (cdr pl))))))
     281    (else (error 'pl-memp "too many arguments"))))
    226282
    227283(define (pl-memq x . pls)
     
    234290  (apply pl-memp (cut equal? <> x) pls))
    235291
    236 (define pl-index
    237   (case-lambda
    238     ((ok?)
     292(define (pl-index ok? . pls)
     293  (cond
     294    ((null? pls)
    239295     (lambda (pl)
    240296       (pl-index ok? pl)))
    241     ((ok? pl)
    242      (let loop ((k 0) (pl pl))
     297    ((null? (cdr pls))
     298     (let loop ((k 0) (pl (car pls)))
    243299       (cond
    244300         ((pl-null? pl) -1)
     
    246302         (else
    247303           (loop (+ k 1) (cdr pl))))))
     304    (else (error 'pl-index "too many arguments"))))
     305
     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)))))))
     319    (else (error 'pl-filter "too many arguments"))))
     320
     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))))
    248331    ))
    249332
    250 (define pl-filter
    251   (case-lambda
    252     ((ok?)
    253      (lambda (pl)
    254        (pl-filter ok? pl)))
    255     ((ok? pl)
    256      (let recur ((pl pl))
    257        (if (pl-null? pl)
    258          '()
    259          (let ((first (car pl)) (rest (cdr pl)))
    260            (if (ok? first)
    261              (cons first (recur rest))
    262              (recur rest))))))
    263     ))
    264 
    265 (define pl-append
    266   (case-lambda
    267     ((pl) pl)
    268     ((pl0 pl1)
    269      (let recur ((pl pl0))
    270        (if (pl-null? pl)
    271          (pl-head pl1)
    272          (cons (car pl) (recur (cdr pl))))))
    273     ((pl0 pl1 . pls)
    274      (pl-append pl0 (apply pl-append pl1 pls)))
    275     ))
    276 
    277 (define pl-fold-right
    278   (case-lambda
    279     ((op init)
     333(define (pl-fold-right op init . pls)
     334  (cond
     335    ((null? pls)
    280336     (lambda (pl)
    281337       (pl-fold-right op init pl)))
    282     ((op init pl)
    283      (let recur ((pl pl))
     338    ((null? (cdr pls))
     339     (let recur ((pl (car pls)))
    284340       (if (pl-null? pl)
    285341         init
    286342         (op (car pl) (recur (cdr pl))))))
    287     ))
    288 
    289 (define pl-fold-right0
    290   (case-lambda
    291     ((op)
     343    (else (error 'pl-fold-right "too many arguments"))))
     344
     345(define (pl-fold-right0 op . pls)
     346  (cond
     347    ((null? pls)
    292348     (lambda (pl)
    293349       (pl-fold-right0 op pl)))
    294     ((op pl)
    295      (let ((pl pl))
     350    ((null? (cdr pls))
     351     (let ((pl (car pls)))
    296352       (if (pl-null? pl)
    297353         (error 'pl-fold-right0 "pseudolist empty" pl)
    298354         (apply pl-fold-right op (car pl) (cdr pl)))))
     355    (else (error 'pl-fold-right0 "too many arguments"))
    299356    ))
    300357
    301 (define pl-fold-left
    302   (case-lambda
    303     ((op init)
     358(define (pl-fold-left op init . pls)
     359  (cond
     360    ((null? pls)
    304361     (lambda (pl)
    305362       (pl-fold-left op init pl)))
    306     ((op init pl)
    307      (let loop ((pl pl) (result init))
     363    ((null? (cdr pls))
     364     (let loop ((pl (car pls)) (result init))
    308365       (if (pl-null? pl)
    309366         result
    310367         (loop (cdr pl) (op result (car pl))))))
     368    (else (error 'pl-fold-left "too many arguments"))
    311369    ))
    312370
    313 (define pl-fold-left0
    314   (case-lambda
    315     ((op)
     371(define (pl-fold-left0 op . pls)
     372  (cond
     373    ((null? pls)
    316374     (lambda (pl)
    317375       (pl-fold-left0 op pl)))
    318     ((op pl)
    319      (let ((pl pl))
     376    ((null? (cdr pls))
     377     (let ((pl (car pls)))
    320378       (if (pl-null? pl)
    321379         (error 'pl-fold-left0 "pseudolist empty" pl)
    322380         (apply pl-fold-left op (car pl) (cdr pl)))))
     381    (else (error 'pl-fold-left0 "too many arguments"))
    323382    ))
    324383
    325 (define pl-adjoin
    326   (case-lambda
    327     ((obj)
     384(define (pl-adjoin obj . pls)
     385  (cond
     386    ((null? pls)
    328387     (lambda (pl)
    329388       (pl-adjoin obj pl)))
    330     ((obj pl)
    331      (let ((pl pl))
     389    ((null? (cdr pls))
     390     (let ((pl (car pls)))
    332391       (if (pair? (pl-member obj pl))
    333          (pl-head pl)
    334          (pl-head (cons obj pl)))))
     392         pl
     393         (cons obj pl))))
     394    (else (error 'pl-adjoin "too many arguments"))
    335395    ))
    336396
     
    338398  (let recur ((pl pl))
    339399    (if (pl-null? pl)
    340       '()
     400      pl
    341401      (pl-adjoin (car pl) (recur (cdr pl))))))
    342402
    343403(define (pl-flatten pl-tree)
    344   (let recur ((tree pl-tree) (result '()))
     404  ;(let recur ((tree pl-tree) (result (pl-sentinel)))
     405  (let recur ((tree (pl-head pl-tree)) (result (pl-tail pl-tree)))
    345406    (if (pair? tree)
    346407      (let ((head (car tree)) (tail (cdr tree)))
     
    357418     (let recur ((seq pl))
    358419       (if (pl-null? seq)
    359          '()
     420         seq
    360421         (let ((var (car seq)))
    361422           (if (and ok-xpr ...)
     
    365426    (let recur ((seq pl))
    366427      (if (pl-null? seq)
    367         '()
     428        seq
    368429        (let ((var (car seq)))
    369430          (if (and ok-xpr ...)
     
    386447      "the first call returns all exported symbols,"
    387448      "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")
    388468    (pl-maker
    389469      procedure:
    390       (pl-maker sentinel . args)
    391       "creates a pseudolist with sentinel from args")
     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:
     476        (pl-null? xpr)
     477        "is xpr an atom equal to (pl-sentinel)")
    392478    (pl?
    393479      procedure:
    394480      (pl? xpr)
    395       "is xpr a pl?"
    396       "i.e. not a list?")
     481      "is xpr a pseudolist, i.e either a pair or the atom (pl-sentinel)")
    397482    (pl-of?
    398483      procedure:
     
    400485      "returns a unary predicate, which checks"
    401486      "if its argument passes each predicate in preds")
    402     (pl-null?
    403       procedure:
    404         (pl-null? xpr)
    405         "is xpr an atom, i.e. not a pair?")
    406     (pl-iterate
    407       procedure:
    408       (pl-iterate fn k)
    409       (pl-iterate fn k init)
    410       "creates a list  applying fn to init"
    411       "recursively k times")
    412487    (pl-length
    413488      procedure:
     
    415490        "length of a pseudolist pl"
    416491        "the sentinel doesn't count")
    417     (pl-sentinel
    418       procedure:
    419         (pl-sentinel pl)
    420         "returns the sentinel of pl")
    421492    (pl-head
    422493      procedure:
    423494        (pl-head pl)
    424495        "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")
    425506    (pl-at
    426507      procedure:
     
    430511    (pl-drop
    431512      procedure:
    432         (pl-drop pl)
     513        (pl-drop n)
    433514        (pl-drop n pl)
    434         "returns the tail of pl removing all head items"
    435         "that pass the ok? test")
     515        "returns the tail of pl removing the first n items")
    436516    (pl-drop-while
    437517      procedure:
    438         (pl-drop-while pl)
    439         (pl-drop-while n pl)
     518        (pl-drop-while ok?)
     519        (pl-drop-while ok? pl)
    440520        "returns the tail of pl starting with the first item"
    441521        "that does not pass the ok? test")
    442522    (pl-take
    443523      procedure:
     524        (pl-take n)
    444525        (pl-take n pl)
    445         (pl-take pl)
    446526        "returns the sublist of pl up to but excluding index n,"
    447         "where n is less than or equal to pl's pl-length")
     527        "where n is less than or equal to pl's pl-length."
     528        "The sentinel is unchanged")
    448529    (pl-take-while
    449530      procedure:
    450         (pl-take-while pl)
     531        (pl-take-while ok?)
    451532        (pl-take-while ok? pl)
    452533        "returns the sublist of pl consisting of items"
    453         "which pass the ok? test")
     534        "until the first item doesn't pass the ok? test."
     535        "The sentinel remains unchanged")
    454536    (pl-map
    455537      procedure:
    456538        (pl-map fn)
    457         (pl-map fn pl)
    458         "maps fn over the pseudolist pl and returns a new list")
     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)"
     548        "stops if one of the items is pl-null?"
     549        "Note, that this is R7RS-, not R5RS-logic")
    459550    (pl-index
    460551      procedure:
     
    467558        (pl-filter ok?)
    468559        (pl-filter ok? pl)
    469         "filters a pseudolist by means of a predicate ok?")
     560        "filters a pseudolist by means of a predicate ok?"
     561        "Both values (passing or not passing ok?) keep pl's sentinel.")
    470562    (pl-reverse
    471563      procedure:
    472564      (pl-reverse pl)
    473       "reverses its pseudolist argument to a new list")
     565      "reverses its pseudolist argument to a new pseudolist"
     566      "with same sentinel")
    474567    (pl-append
    475568      procedure:
    476569      (pl-append pl . pls)
    477       "appends all argument pseudolists to a list")
     570      "appends all argument pseudolists to a pseudolist"
     571      "with sentinel of the last item")
    478572    (pl-memp
    479573      procedure:
     
    481575      (pl-memp ok? pl)
    482576      "returns the sublist starting at the first"
    483       "item which passes the ok? test,"
    484       "returns #f if now item passes the ok? test")
     577      "item which passes the ok? test, keeping ps's sentinel."
     578      "Returns #f if no item passes the ok? test")
    485579    (pl-member
    486580      procedure:
     
    526620        (pl-adjoin obj)
    527621        (pl-adjoin obj pl)
    528         "adds obj to a pseudolist stripping the sentinel,"
    529         "provided, it isn't already there")
     622        "adds obj to a pseudolist provided, it isn't already there")
    530623    (pl-remove-dups
    531624      procedure:
    532625        (pl-remove-dups lst)
    533         "removes duplicates of a pseudolist stripping the sentinel")
     626        "removes duplicates of a pseudolist keeping the sentinel")
    534627    (pl-flatten
    535628      procedure:
    536629        (pl-flatten pl-tree)
    537         "flattens the nested pseudolist tree to a list")
     630        "flattens the nested pseudolist tree to a pseudolist"
     631        "with sentinel from the pseudolist of depth 0")
    538632    (pl-collect
    539633      macro:
     
    541635      "creates a new list by binding var to each element"
    542636      "of the pseudolist pl in sequence, and if it passes the checks,"
    543       "ok-xpr ..., inserts the value of xpr into the resulting list."
     637      "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
    544638      "The qualifieres, (var pl ok-xpr ...), are processed"
    545639      "sequentially from left to right, so that filters of a"
    546640      "qualifier have access to the variables of qualifiers"
    547       "to its left.")
     641      "to its left."
     642      "The leftmost pseudolist determines the result's sentinel")
    548643    )))
    549644    (case-lambda
     
    559654
    560655;(import pseudolists simple-tests)
    561  
     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;     )
  • release/5/pseudolists/trunk/tests/run.scm

    r38201 r38334  
    44        simple-tests)
    55
    6 ;(define pl (pl-maker #f 0 1 2))
     6;; set sentinel
     7(pl-sentinel 0)
    78
    8 (define-test (pseudolists?)
    9   (pl? "x")
    10   (pl? '(a b . c))
    11   (pl-null? 5)
    12   ((pl-of?) "x")
    13   ((pl-of? symbol?) '(a b . c))
     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
    1416
    15   (equal? (pl-maker #f 0 1 2) '(0 1 2 . #f))
    16   (not (pl-maker #f))
     17  (pl 0 1 2) '(0 1 2 . 0)
     18  (pl) 0
    1719
    18   (equal? (pl-iterate add1 5 0) '(0 1 2 3 4))
     20  (pl-maker 3) '(0 0 0 . 0)
     21  (pl-iterate add1 5 0) '(0 1 2 3 4 . 0)
    1922
    20   (not (pl-sentinel '(1 2 3 4 . #f)))
    21   (= (pl-sentinel '(0 1 2 3 2 . 2)) 2)
     23  (pl-tail '(1 2 3 4 . #f)) #f
     24  (pl-tail '(0 1 2 3 2 . 2)) 2
    2225 
    23   (= (pl-length '(0 1 2 3 . 4)) 4)
     26  (pl-length '(0 1 2 3 . 0)) 4
    2427
    25   (equal? (pl-head '(0 1 2 3 2 . 2)) '(0 1 2 3 2))
    26   (equal? (pl-head 0) '())
    27   (equal? (pl-head '(0 . 1)) '(0))
     28  (pl-head '(0 1 2 3 2 . 0)) '(0 1 2 3 2)
     29  (pl-head 0) '()
     30  (pl-head '(0 . 1)) '(0)
    2831
    29   (= (pl-at 1 '(0 1 2 3 . 4)) 1)
    30   (= (pl-at 2 '(0 1 2 3 . #f)) 2)
    31   (not (condition-case (pl-at 0 1)
    32          ((exn) #f)))
     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
    3336
    34   (= (pl-index odd? '(0 1 2 . 3)) 1)
    35   (= (pl-index odd? '(0 2 4 . 1)) -1)
     37  (pl-index odd? '(0 1 2 . 0)) 1
     38  (pl-index odd? '(0 2 4 . 0)) -1
    3639
    37   (equal? (pl-drop 1 '(0 1 2 3 . 4))
    38           '(1 2 3))
    39   (null? (pl-drop 0 1))
    40   (equal? (pl-drop 2 '(0 1 2 3 . #f)) '(2 3))
    41   (equal? (pl-drop-while odd? '(1 3 2 4 . #f)) '(2 4))
    42   (equal? (pl-drop-while negative? '(1 3 2 4 . #f)) '(1 3 2 4))
     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)
     43  )
     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)
    4352 
    44   (equal? (pl-take 3 '(0 1 2 3 4 . #t)) '(0 1 2))
    45   (equal? (pl-take 2 '(0 1 2 3 . #f)) '(0 1))
    46   (equal? (pl-take-while odd? '(1 3 2 4 . #f)) '(1 3))
    47   (null? (pl-take-while negative? '(1 3 2 4)))
     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)
    4858
    49   (null? (pl-filter odd? 1))
    50   (equal? (pl-filter odd? '(0 1 2 3 4)) '(1 3))
    51   (equal? (pl-filter odd? '(0 1 2 3 . 4)) '(1 3))
    52   (equal? (pl-filter even? '(0 1 2 3 . 4)) '(0 2))
     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)
    5363 
    54   (equal? (pl-map add1 '(0 1 2 3 . 4)) '(1 2 3 4))
    55   (equal? (pl-map add1 '(0 1 2 3 . 4)) '(1 2 3 4))
    56   (equal? (pl-map add1 '(0 1 2 3)) '(1 2 3 4))
    57   (null? (pl-map add1 #f))
     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)
    5871
    59   (not (pl-memp odd? '(0 2 4 . #t)))
    60   (not (pl-memv 5 '(0 1 2 3 4 . 5)))
    61   (equal? (pl-member 3 '(0 1 2 3 4 . 5)) '(3 4))
     72  (pl-reverse '(0 1 2 3 . 4)) '(3 2 1 0 . 4)
     73  (pl-reverse '(0 1 2 3)) '(3 2 1 0)
    6274
    63   (equal? (pl-reverse '(0 1 2 3 . 4)) '(3 2 1 0))
    64   (equal? (pl-reverse '(0 1 2 3 . 4)) '(3 2 1 0))
    65   (equal? (pl-reverse '(0 1 2 3)) '(3 2 1 0))
     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)
    6683
    67   (equal? (pl-append '(0 1) #f) '(0 1))
    68   (equal? (pl-append '(0 1)) '(0 1))
    69   (equal? (pl-append '(0 1) '(2 3) #f) '(0 1 2 3))
    70   (equal? (pl-append '(0 1 . #f) '(2 3)) '(0 1 2 3))
    71   (equal? (pl-append '(0 1) '(2 3) '(4 5)) '(0 1 2 3 4 5))
    72   (equal? (pl-append '(0 1 . #f) '(2 3 . #t) '(4 5)) '(0 1 2 3 4 5))
    73   (equal? (pl-append '(0 1 . #t) '(2 3 . #t) '(4 5 . #t)) '(0 1 2 3 4 5))
    74   (equal? (pl-append '(0 1 . #t) '(2 3 . #t) '(4 5) #t)
    75           '(0 1 2 3 4 5))
     84  (pl-fold-right + 0 '(1 2 3 . #f)) 6
     85  (pl-fold-left + 0 '(1 2 3)) 6
    7686
    77   (= (pl-fold-right + 0 '(1 2 3 . #f)) 6)
    78   (= (pl-fold-left + 0 '(1 2 3)) 6)
     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)
    7991
    80   (equal? (pl-adjoin 2 '(0 1 2 3 . #f)) '(0 1 2 3))
    81   (equal? (pl-adjoin 4 '(0 1 2 3 #f . #t)) '(4 0 1 2 3 #f))
    82   (equal? (pl-adjoin 1 '(0 1 2 3)) '(0 1 2 3))
    83   (equal? (pl-adjoin 1 #f) '(1))
     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)
    8495
    85   (equal? (pl-remove-dups '(0 1 2 3 2 . 2)) '(0 1 3 2))
    86   (equal? (pl-remove-dups '(0 1 2 3 2 2)) '(0 1 3 2))
    87   (equal? (pl-remove-dups '(0 1 2 1 3 2)) '(0 1 3 2))
    88 
    89   (equal? (pl-flatten '(1 (2 3) . #t)) '(1 2 3))
    90   (equal? (pl-flatten '(1 (2 (3 . #f) . #t) . #f)) '(1 2 3))
    91   (null? (pl-flatten #f))
     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?)
    92102 
    93   (equal? (pl-collect (add1 x) (x '(0 1 2 3 . #f))) ; map
    94     '(1 2 3 4))
    95   (equal? (pl-collect (add1 x) (x '(0 1 2 3))) ; map
    96     '(1 2 3 4))
    97   (equal? (pl-collect x (x '(0 1 2 3 4 5 . #f) (odd? x))) ; filter
    98     '(1 3 5))
    99   (equal? (pl-collect x (x '(0 1 2 3 4 5) (odd? x))) ; filter
    100     '(1 3 5))
    101   (equal? (pl-collect (* 10 n) (n '(0 1 2 3 4 5) (positive? n) (even? n)))
    102     '(20 40))
    103   (equal? (pl-collect (list c k)
    104                       (c '(A B C))
    105                       (k '(1 2 3 4)))
     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)))
    106117    '((A 1) (A 2) (A 3) (A 4)
    107118      (B 1) (B 2) (B 3) (B 4)
    108       (C 1) (C 2) (C 3) (C 4)))
    109   (equal? (pl-collect (list c k)
    110                       (c '(A B C . #f))
    111                       (k '(1 2 3 4 . #f)))
     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)))
    112123    '((A 1) (A 2) (A 3) (A 4)
    113124      (B 1) (B 2) (B 3) (B 4)
    114       (C 1) (C 2) (C 3) (C 4)))
     125      (C 1) (C 2) (C 3) (C 4) . #t)
    115126  )
     127;(collect?)
    116128 
    117 (compound-test (PSEUDOLISTS)
    118   (pseudolists?)
    119   )
     129(check-all PSEUDOLISTS
     130 (basic?)
     131 (higher?)
     132 (collect?)
     133 )
     134
Note: See TracChangeset for help on using the changeset viewer.