source: project/release/5/pseudolists/trunk/pseudolists.scm @ 37451

Last change on this file since 37451 was 37451, checked in by juergen, 20 months ago

pseudolists 1.0 initial import

File size: 15.2 KB
Line 
1; Author: Juergen Lorenz ; ju (at jugilo (dot) de
2;
3; Copyright (c) 2013-2019, Juergen Lorenz
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions are
8; met:
9;
10; Redistributions of source code must retain the above copyright
11; notice, this list of conditions and the following dispasser.
12;
13; Redistributions in binary form must reproduce the above copyright
14; notice, this list of conditions and the following dispasser in the
15; documentation and/or other materials provided with the distribution.
16;
17; Neither the name of the author nor the names of its contributors may be
18; used to endorse or promote products derived from this software without
19; specific prior written permission.
20;
21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
22; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
23; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
24; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33
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 pl-memp pl-member
39   pl-memq pl-memv pl-adjoin pl-remove-dups
40   pl-at pl-drop pl-take pl-append
41   pl-drop-while pl-take-while
42   pl-fold-right pl-fold-left
43   pl-fold-right0 pl-fold-left0
44   pl-for pseudolists
45   )
46
47  (import scheme
48          (only (chicken base) cut case-lambda assert print error))
49
50(define (pl-maker sentinel . args)
51  (let loop ((args args))
52    (if (null? args)
53      sentinel
54      (cons (car args) (loop (cdr args))))))
55
56(define (pl-iterate sentinel times fn . inits)
57  (cond
58    ((null? inits)
59     (lambda (x)
60       (pl-iterate sentinel times fn x)))
61    ((null? (cdr inits))
62     (let recur ((x (car inits)) (k 0))
63       (if (= k times)
64         sentinel
65         (cons x (recur (fn x) (+ k 1))))))
66    (else 'pl-iterate "too many arguments")))
67
68(define (pl? xpr)
69  #t)
70
71(define (my-conjoin . preds)
72  (let recur ((preds preds))
73    (lambda (xpr)
74      (cond
75        ((null? preds) #t)
76        (((car preds) xpr)
77         ((recur (cdr preds)) xpr))
78        (else #f)))))
79
80(define (pl-of? . preds)
81  (let ((ok? (apply my-conjoin preds)))
82    (lambda (xpr)
83      (if (pair? xpr)
84        (and (ok? (car xpr))
85             ((pl-of? ok?) (cdr xpr)))
86        (ok? xpr)))))
87
88(define (pl-null? xpr)
89  (not (pair? xpr)))
90
91(define (pl-length pl)
92  ;; sentinel doesn't count in length!
93  (if (pl-null? pl)
94    0
95    (+ 1 (pl-length (cdr pl)))))
96
97(define (pl-sentinel pl)
98  (if (pl-null? pl)
99    pl
100    (let ((rest (cdr pl)))
101      (if (pl-null? rest)
102        rest
103        (pl-sentinel rest)))))
104
105(define (pl-head pl)
106  (let ((len (pl-length pl)))
107    (let recur ((k 0) (pl pl))
108      (cond
109        ((pl-null? pl) '())
110        ((< k len)
111         (cons (car pl) (recur (+ k 1) (cdr pl))))
112        (else (recur (+ k 1) (cdr pl)))))))
113
114(define (pl-at n . pls)
115  (cond
116    ((null? pls)
117     (lambda (pl)
118       (pl-at n pl)))
119    ((null? (cdr pls))
120     (let ((pl (car pls)))
121       (assert (< -1 n (pl-length pl))) 
122       (let loop ((k 0) (pl pl))
123         (cond
124           ((pl-null? pl) pl)
125           ((= k n) (car pl))
126           (else
127             (loop (+ k 1) (cdr pl)))))))
128    (else (error 'pl-at "too many arguments"))))
129
130(define (pl-drop n . pls)
131  (cond
132    ((null? pls)
133     (lambda (pl)
134       (pl-drop n pl)))
135    ((null? (cdr pls))
136     (let ((pl (car pls)))
137       (assert (or (pl-null? pl) (< -1 n (pl-length pl)))) 
138       (let loop ((n n) (pl pl))
139         (cond
140           ((pl-null? pl) pl)
141           ((zero? n) pl)
142           (else
143             (loop (- n 1) (cdr pl)))))))
144    (else (error 'pl-drop "too many arguments"))
145    ))
146
147(define (pl-drop-while ok? . pls)
148  (cond
149    ((null? pls)
150     (lambda (pl)
151       (pl-drop-while ok? pl)))
152    ((null? (cdr pls))
153       (let loop ((pl (car pls)))
154         (if (pl-null? pl)
155           pl
156           (let ((first (car pl)) (rest (cdr pl)))
157             (if (ok? first)
158               (loop rest)
159               pl)))))
160    (else (error 'pl-drop-while "too many arguments"))
161    ))
162
163(define (pl-take n . pls)
164  (cond
165    ((null? pls)
166     (lambda (pl)
167       (pl-take n pl)))
168    ((null? (cdr pls))
169     (let ((pl (car pls)))
170       (assert (or (pl-null? pl) (< -1 n (pl-length pl)))) 
171       (let recur ((k 0) (pl pl))
172         (cond
173           ((pl-null? pl) pl)
174           ((< k n)
175            (cons (car pl) (recur (+ k 1) (cdr pl))))
176           (else (recur (+ k 1) (cdr pl)))))))
177    (else (error 'pl-take "too many arguments"))))
178     
179(define (pl-take-while ok? . pls)
180  (cond
181    ((null? pls)
182     (lambda (pl)
183       (pl-take-while ok? pl)))
184    ((null? (cdr pls))
185     (let recur ((pl (car pls)))
186       (if (pl-null? pl)
187         pl
188         (let ((first (car pl)) (rest (cdr pl)))
189           (if (ok? first)
190             (cons first (recur rest))
191             (recur rest))))))
192    (else (error 'pl-take-while "too many arguments"))))
193     
194(define (pl-reverse pl)
195  (let loop ((pl pl) (result (pl-sentinel pl)))
196    (if (pl-null? pl)
197      result
198      (loop (cdr pl) (cons (car pl) result)))))
199
200(define (pl-map fn . pls)
201  (cond
202    ((null? pls)
203     (lambda (pl)
204       (pl-map fn pl)))
205    ((null? (cdr pls))
206     (let recur ((pl (car pls)))
207       (if (pl-null? pl)
208         pl
209         (cons (fn (car pl)) (recur (cdr pl))))))
210    (else (error 'pl-map "too many arguments"))))
211
212(define (pl-memp ok? . pls)
213  (cond
214    ((null? pls)
215     (lambda (pl)
216       (pl-memp ok? pl)))
217    ((null? (cdr pls))
218     (let recur ((pl (car pls)))
219       (if (pl-null? pl)
220         pl
221         (let ((first (car pl)) (rest (cdr pl)))
222           (if (ok? first)
223             (cons first rest)
224             (recur rest))))))
225    (else (error 'pl-memp "too many arguments"))))
226
227(define (pl-memq x . pls)
228  (apply pl-memp (cut eq? <> x) pls))
229
230(define (pl-memv x . pls)
231  (apply pl-memp (cut eqv? <> x) pls))
232
233(define (pl-member x . pls)
234  (apply pl-memp (cut equal? <> x) pls))
235
236(define (pl-index ok? . pls)
237  (cond
238    ((null? pls)
239     (lambda (pl)
240       (pl-index ok? pl)))
241    ((null? (cdr pls))
242     (let loop ((k 0) (pl (car pls)))
243       (cond
244         ((pl-null? pl) -1)
245         ((ok? (car pl)) k)
246         (else
247           (loop (+ k 1) (cdr pl))))))
248    (else
249      (error 'pl-index "too many arguments"))))
250
251(define (pl-filter ok? . pls)
252  (cond
253    ((null? pls)
254     (lambda (pl)
255       (pl-filter ok? pl)))
256    ((null? (cdr pls))
257     (let recur ((pl (car pls)))
258       (if (pl-null? pl)
259         pl
260         (let ((first (car pl)) (rest (cdr pl)))
261           (if (ok? first)
262             (cons first (recur rest))
263             (recur rest))))))
264    (else
265      (error 'pl-filter "too many arguments"))))
266
267(define (pl-append pl . pls)
268  (cond
269    ((null? pls) pl)
270    ((null? (cdr pls))
271     (let recur ((pl pl))
272       (if (pl-null? pl)
273         (car pls)
274         (cons (car pl) (recur (cdr pl))))))
275    (else
276      (pl-append pl (apply pl-append (car pls) (cdr pls))))))
277
278
279(define (pl-fold-right op init . pls)
280  (cond
281    ((null? pls)
282     (lambda (pl)
283       (pl-fold-right op init pl)))
284    ((null? (cdr pls))
285     (let recur ((pl (car pls)))
286       (if (pl-null? pl)
287         init
288         (op (car pl) (recur (cdr pl))))))
289    (else (error 'pl-fold-right "too many arguments"))))
290
291(define (pl-fold-right0 op . pls)
292  (cond
293    ((null? pls)
294     (lambda (pl)
295       (pl-fold-right0 op pl)))
296    ((null? (cdr pls))
297     (let ((pl (car pls)))
298       (if (pl-null? pl)
299         (error 'pl-fold-right0 "pseudolist empty" pl)
300         (apply pl-fold-right op (car pl) (cdr pl)))))
301    ))
302
303(define (pl-fold-left op init . pls)
304  (cond
305    ((null? pls)
306     (lambda (pl)
307       (pl-fold-left op init pl)))
308    ((null? (cdr pls))
309     (let loop ((pl (car pls)) (result init))
310       (if (pl-null? pl)
311         result
312         (loop (cdr pl) (op result (car pl))))))
313    (else (error 'pl-fold-left "too many arguments"))))
314
315(define (pl-fold-left0 op . pls)
316  (cond
317    ((null? pls)
318     (lambda (pl)
319       (pl-fold-left0 op pl)))
320    ((null? (cdr pls))
321     (let ((pl (car pls)))
322       (if (pl-null? pl)
323         (error 'pl-fold-left0 "pseudolist empty" pl)
324         (apply pl-fold-left op (car pl) (cdr pl)))))
325    ))
326
327(define (pl-adjoin obj . pls)
328  (cond
329    ((null? pls)
330     (lambda (pl)
331       (pl-adjoin obj pl)))
332    ((null? (cdr pls))
333     (let ((pl (car pls)))
334       (if (pair? (pl-member obj pl))
335         pl
336         (cons obj pl))))
337    (else (error 'pl-adjoin "too many arguments"))))
338
339(define (pl-remove-dups pl)
340  (let recur ((pl pl))
341    (if (pl-null? pl)
342      pl
343      (pl-adjoin (car pl) (recur (cdr pl))))))
344
345(define (pl-flatten tree)
346  ; imported flatten doesn't work with pl-makers
347  (let recur ((tree tree) (result '()))
348    (cond
349      ((pair? tree)
350       (recur (car tree) (recur (cdr tree) result)))
351      ((null? tree) result)
352      (else
353        (cons tree result)))))
354
355;;; (pl-for ((var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...) item-xpr)
356;;; ------------------------------------------------------------------
357(define-syntax pl-for
358  (syntax-rules ()
359   ((_ ((var pl ok-xpr ...)) item-xpr)
360     (let recur ((seq pl))
361       (if (pl-null? seq)
362         seq
363         (let ((var (car seq)))
364           (if (and ok-xpr ...)
365             (cons item-xpr (recur (cdr seq)))
366             (recur (cdr seq)))))))
367    ((_ ((var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...) item-xpr)
368     (let recur ((seq pl))
369       (if (pl-null? seq)
370         seq
371         (let ((var (car seq)))
372           (if (and ok-xpr ...)
373             (pl-append (pl-for ((var1 pl1 ok-xpr1 ...) ...) item-xpr)
374                        (recur (cdr seq)))
375             (recur (cdr seq)))))))
376    ))
377
378;;; (pseudolists sym ..)
379;;; ----------------------------
380;;; documentation procedure.
381(define pseudolists
382  (let ((alst '(
383    (pseudolists
384      procedure:
385      (pseudolists)
386      (pseudolists sym)
387      "documentation procedure,"
388      "the first call returns all exported symbols,"
389      "the second documentation of symbol sym")
390    (pl-maker
391      procedure:
392        (pl-maker sentinel . args)
393        "creates a new pseudolist from args"
394        "and sentinel")
395    (pl?
396      procedure:
397        (pl? xpr)
398        "is xpr a pl?"
399        "i.e. not a list?")
400    (pl-of?
401      procedure:
402      (pl-of? . preds)
403      "returns a unary predicate, which checks"
404      "if its argument passes each predicate in preds")
405    (pl-null?
406      procedure:
407        (pl-null? xpr)
408        "is xpr pl-null?, i.e. not a pair")
409    (pl-iterate
410      procedure:
411      (pl-iterate sentinel k fn)
412      (pl-iterate sentinel k fn init)
413      "creates a pseudolist with sentinel applying fn to int"
414      "recursively k times")
415    (pl-length
416      procedure:
417        (pl-length pl)
418        "length of a pseudolist pl"
419        "the sentinel doesn't count")
420    (pl-sentinel
421      procedure:
422        (pl-sentinel pl)
423        "returns the sentinel of pl")
424    (pl-head
425      procedure:
426        (pl-head pl)
427        "returns the list of items with pl's sentinel stripped")
428    (pl-at
429      procedure:
430        (pl-at k)
431        (pl-at k pl)
432        "returns the kth item of pl")
433    (pl-drop
434      procedure:
435        (pl-drop pl)
436        (pl-drop n pl)
437        "returns the tail of pl removing all head items"
438        "that pass the ok? test")
439    (pl-drop-while
440      procedure:
441        (pl-drop-while pl)
442        (pl-drop-while n pl)
443        "returns the tail of pl starting with the first item"
444        "that does not pass the ok? test")
445    (pl-take
446      procedure:
447        (pl-take n pl)
448        (pl-take pl)
449        "returns the head of pl up to but excluding index n,"
450        "where n is less than or equal to pl's pl-length")
451    (pl-take-while
452      procedure:
453        (pl-take-while pl)
454        (pl-take-while ok? pl)
455        "returns the head of pl consisting of items"
456        "which pass the ok? test")
457    (pl-map
458      procedure:
459        (pl-map fn pl)
460        "maps fn over the pseudolist pl")
461    (pl-index
462      procedure:
463      (pl-index ok?)
464      (pl-index ok? pl)
465      "returns the index of the first item passing"
466      "the ok? test, -1 otherwise")
467    (pl-filter
468      procedure:
469        (pl-filter ok?)
470        (pl-filter ok? pl)
471        "filters a pseudolist by means of a predicate ok?")
472    (pl-reverse
473      procedure:
474      (pl-reverse pl)
475      "reverses its pseudolist argument")
476    (pl-append
477      procedure:
478      (pl-append pl . pls)
479      "appends all argument pseudolists")
480    (pl-memp
481      procedure:
482      (pl-memp ok? pl)
483      "returns the sub-pseudolist starting at the first"
484      "item which passes the ok? test")
485    (pl-member
486      procedure:
487      (pl-member x pl)
488      "same as (pl-memp (cut equal? <> x) pl)")
489    (pl-memq
490      procedure:
491      (pl-memq x pl)
492      "same as (pl-memp (cut eq? <> x) pl)")
493    (pl-memv
494      procedure:
495      (pl-memv x pl)
496      "same as (pl-memp (cut eqv? <> x) pl)")
497    (pl-fold-right
498      procedure:
499      (pl-fold-right op init)
500      (pl-fold-right op init pl)
501      "folds pl from the right with binary operation op"
502      "and starting value init")
503    (pl-fold-right0
504      procedure:
505      (pl-fold-right0 op)
506      (pl-fold-right0 op pl)
507      "folds (cdr pl) from the right with binary operation op"
508      "and starting value (car pl)")
509    (pl-fold-left
510      procedure:
511      (pl-fold-left op init)
512      (pl-fold-left op init pl)
513      "folds pl from the left with binary operation op"
514      "and starting value init")
515    (pl-fold-left0
516      procedure:
517      (pl-fold-left0 op)
518      "folds (cdr pl) from the left with binary operation op"
519      "and starting value (car pl)")
520      (pl-fold-left0 op pl)
521    (pl-adjoin
522      procedure:
523        (pl-adjoin obj)
524        (pl-adjoin obj pl)
525        "adds obj to a pseudolist, provided, it isn't already there")
526    (pl-remove-dups
527      procedure:
528        (pl-remove-dups lst)
529        "removes duplicates of a pseudolist")
530    (pl-flatten
531      procedure:
532        (pl-flatten tree)
533        "flattens the nested pseudolist tree to a proper list")
534    (pl-for
535      macro:
536      (pl-for ((var pl ok-xpr ...) (var1 pl1 ok-xpr1 ...) ...) xpr)
537      "creates a new pseudolist by binding var to each element"
538      "of the pseudolist pl in sequence, and if it passes the checks,"
539      "ok-xpr ..., inserts the value of xpr into the resulting pseudolist."
540      "The qualifieres, (var pl ok-xpr ...), are processed"
541      "sequentially from left to right, so that filters of a"
542      "qualifier have access to the variables of qualifiers"
543      "to its left.")
544    )))
545    (case-lambda
546      (()
547       (map car alst))
548      ((sym)
549       (let ((lst (assq sym alst)))
550         (if lst
551           (for-each print (cdr lst))
552           (error 'basic-macros
553                  "not exported" sym)))))))
554) ; module pseudolists
555
556;(import pseudolists simple-tests)
557
Note: See TracBrowser for help on using the repository browser.