source: project/release/4/basic-sequences/trunk/basic-sequences.scm @ 35852

Last change on this file since 35852 was 35852, checked in by juergen, 2 years ago

basic-sequences 2.2 fixed a bugfix

File size: 16.2 KB
Line 
1; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
2;
3; Copyright (c) 2016-2018, 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(require-library simple-exceptions)
34
35(module basic-sequences
36  (seq-db seq-null? seq? seq-of seq-ref seq-tail seq-maker seq-exception
37   seq-car seq-cdr seq-random-access? basic-sequences
38   thunk thunk? tagged-vector-of
39   tagged-vector tagged-vector? tagged-vector-ref tagged-vector-tail
40   cons* list-of pseudo-list-of vector-of symbol-dispatcher)
41  (import scheme
42          (only chicken case-lambda receive condition-case define-inline
43                define-values gensym string->keyword assert fixnum?
44                fx+ fx- fx= fx> fx< fx>= error subvector print keyword?)
45          (only data-structures chop conjoin disjoin list-of?)
46          (only simple-exceptions raise make-exception))
47
48;;; exceptions
49;;; ----------
50(define seq-exception
51  (make-exception "sequence exception" 'sequence))
52
53;;; helpers
54;;; -------
55(define-inline (1+ n) (fx+ n 1))
56(define-inline (1- n) (fx- n 1))
57(define-inline (0= n) (fx= n 0))
58(define-inline (0<= n) (fx>= n 0))
59
60
61(define-syntax thunk
62  (syntax-rules ()
63    ((_ xpr . xprs)
64     (lambda () xpr . xprs))))
65
66(define (thunk? xpr)
67  (let ((type (gensym 'thunk)))
68    (and (procedure? xpr)
69         (if (eq? (condition-case (xpr)
70                    ((exn arity) type))
71                  type)
72           #f #t))))
73
74(define-values (tagged-vector tagged-vector?)
75  (let ((type (gensym 'tagged-vector)))
76    (values
77      (lambda (kw . args)
78        (let ((result (make-vector (1+ (length args)))))
79          (vector-set! result 0 (thunk (values kw type)))
80                       ;0
81                       ;(lambda ()
82                       ;  (values kw type)))
83          (do ((args args (cdr args))
84               (k 1 (1+ k)))
85            ((null? args) result)
86            (vector-set! result k (car args)))))
87      (lambda (xpr)
88        (and (vector? xpr)
89             (fx>= (vector-length xpr) 1)
90             (let ((top (vector-ref xpr 0)))
91               (if (thunk? top)
92                 (condition-case
93                   (receive (key sym) (top)
94                     (and (keyword? key)
95                          (symbol? sym)
96                          (eq? sym type)))
97                   ((exn) #f))
98                 #f)))))))
99
100(define (tagged-vector-ref tv k)
101  (if (0= k)
102    ((vector-ref tv k))
103    (vector-ref tv k)))
104
105(define (tagged-vector-tail tv k)
106  (cond
107    ((fx= k (vector-length tv))
108     (vector (thunk
109               (raise
110                 (seq-exception 'tagged-vector-tail
111                                "can't access null tagged vector")))))
112    ((0= k) tv)
113    (else
114      (let* ((tail (subvector tv k))
115             (len (vector-length tail))
116             (result (make-vector (1+ len))))
117        (vector-set! result 0 (vector-ref tv 0))
118        (do ((i 0 (1+ i)))
119          ((fx= i len) result)
120          (vector-set! result (1+ i) (vector-ref tail i)))))))
121
122;;; (seq-ref seq k)
123;;; ---------------
124;;; access to a sequence item
125;;; the second returned value is needed in seq-null?
126(define (seq-ref seq k)
127  (assert (0<= k) 'seq-ref)
128  (values
129    (cond
130      ((list? seq)
131       (condition-case (list-ref seq k)
132         ((exn)
133          (raise (seq-exception 'seq-ref
134                                "out of range" seq k)))))
135      ((pair? seq)
136       (condition-case
137         (let loop ((pl seq) (n k))
138           (if (pair? pl)
139             (if (0= n)
140               (car pl)
141               (loop (cdr pl) (1- n)))
142             (raise (seq-exception 'seq-ref
143                                   "out of range" seq k))))))
144      ((tagged-vector? seq)
145       (condition-case (tagged-vector-ref seq k)
146         ((exn)
147          (raise (seq-exception 'seq-ref "out of range" seq k)))))
148      ((vector? seq)
149       (condition-case (vector-ref seq k)
150         ((exn)
151          (raise (seq-exception 'seq-ref
152                                "out of range" seq k)))))
153      ((string? seq)
154       (condition-case (string-ref seq k)
155         ((exn)
156          (raise (seq-exception 'seq-ref "out of range" seq k)))))
157      (else
158        (let loop ((db (seq-db)))
159          (cond
160            ((null? db)
161             (raise (seq-exception 'seq-ref
162                                   "no handler defined"
163                                   seq)))
164            (((caar db) seq)
165             ((vector-ref (cdar db) 0) seq k))
166            (else (loop (cdr db)))))))
167    #f))
168
169;;; (seq-tail seq k)
170;;; ----------------
171;;; access to the tail of a sequence
172(define (seq-tail seq k)
173  (assert (0<= k) 'seq-tail)
174  (cond
175    ((list? seq)
176     (condition-case (list-tail seq k)
177       ((exn) (raise (seq-exception 'seq-tail
178                                           "out of range" seq k)))))
179    ((pair? seq)
180     (condition-case
181       (let loop ((pl seq) (n k))
182         (if (pair? pl)
183           (if (0= n)
184             pl
185             (loop (cdr pl) (1- n)))
186           (if (fx> n 0)
187             (raise (seq-exception 'seq-tail
188                                   "out-of-range" seq k))
189             pl)))))
190    ((tagged-vector? seq)
191     (condition-case (tagged-vector-tail seq k)
192       ((exn)
193        (raise (seq-exception 'seq-tail
194                              "out of range" seq k)))))
195    ((vector? seq)
196     (condition-case (subvector seq k)
197       ((exn)
198        (raise (seq-exception 'seq-tail
199                              "out of range" seq k)))))
200    ((string? seq)
201     (condition-case (substring seq k)
202       ((exn)
203        (raise (seq-exception 'seq-tail
204                              "out of range" seq k)))))
205    (else
206      (let loop ((db (seq-db)))
207        (cond
208          ((null? db)
209           seq)
210          (((caar db) seq)
211           ((vector-ref (cdar db) 1) seq k))
212          (else (loop (cdr db))))))))
213
214(define (seq-maker seq)
215  (cond
216    ((list? seq) list)
217    ((pair? seq) cons*)
218    ((tagged-vector? seq) tagged-vector)
219    ((vector? seq) vector)
220    ((string? seq) string)
221    (else
222      (let loop ((db (seq-db)))
223        (cond
224          ((null? db)
225           (raise (seq-exception 'seq-maker
226                                 "no handler defined"
227                                 seq)))
228          (((caar db) seq)
229           (vector-ref (cdar db) 2))
230          (else (loop (cdr db))))))))
231
232(define (seq-random-access? seq)
233  (cond
234    ((list? seq) #f)
235    ((pair? seq) #f)
236    ((tagged-vector? seq) #t)
237    ((vector? seq) #t)
238    ((string? seq) #t)
239    (else
240      (let loop ((db (seq-db)))
241        (cond
242          ((null? db)
243           (raise (seq-exception 'seq-maker
244                                 "no handler defined"
245                                 seq)))
246          (((caar db) seq)
247           (vector-ref (cdar db) 3))
248          (else (loop (cdr db))))))))
249
250;;; (seq-null? seq)
251;;; ---------------
252;;; tests for emptiness of a sequence
253(define (seq-null? seq)
254  (receive (result out-of-bounds?)
255    (condition-case (seq-ref seq 0)
256      ((exn sequence) (values #t #t)))
257    (if out-of-bounds? #t #f)))
258
259;;; (seq-car seq)
260;;; -------------
261;;; returns the first item of a sequence
262(define (seq-car seq)
263  (seq-ref seq 0))
264
265;;; (seq-cdr seq)
266;;; -------------
267;;; returns the first tail of a sequence
268(define (seq-cdr seq)
269  (seq-tail seq 1))
270
271;;; (seq-db type? ref: ref tail: tail maker: maker ra?: random-access?)
272;;; ------------------------------------------------------------------
273;;; adds a new sequence type to the database
274;;; (seq-db)
275;;; --------
276;;; shows the sequence database
277(define seq-db
278  (let ((db '()))
279    (case-lambda
280      (() db)
281      ((type? . keyword-args)
282       (let* ((args (chop keyword-args 2))
283              (vec (make-vector (length args))))
284         ;; populate vec and add to db
285         (do ((args args (cdr args)))
286           ((null? args)
287            (set! db
288                  (cons (cons type? vec) db)))
289             (case (caar args)
290               ((#:ref)
291                (vector-set! vec
292                             0
293                             (lambda (seq k)
294                               (condition-case
295                                 ((cadar args) seq k)
296                                 ((exn)
297                                  (raise (seq-exception 'seq-ref
298                                                        "out of range"
299                                                        seq k)))))))
300               ((#:tail)
301                (vector-set! vec
302                             1
303                             (lambda (seq k)
304                               (condition-case
305                                 ((cadar args) seq k)
306                                 ((exn)
307                                  (raise (seq-exception 'seq-tail
308                                                        "out of range"
309                                                        seq k)))))))
310               ((#:maker)
311                (vector-set! vec 2 (cadar args)))
312               ((#:ra?)
313                (vector-set! vec 3 (cadar args)))
314               (else
315                 (raise (seq-exception 'seq-db
316                                       "not a keyword"
317                                       (caar args))))
318               )))))))
319
320;;; (seq? xpr)
321;;; ----------
322;;; sequence predicate
323(define (seq? xpr)
324  (or (list? xpr)
325      (pair? xpr)
326      (tagged-vector? xpr)
327      (vector? xpr)
328      (string? xpr)
329      ((apply disjoin (map car (seq-db))) xpr)))
330
331;;; (seq-of ok? ....)
332;;; --------------------
333;;; returns a sequence predicate which checks all ok? arguments
334(define (seq-of . oks?)
335  (let (
336    (seq-of?
337      (lambda (ok?)
338        (lambda (xpr)
339          (and (seq? xpr)
340               (let loop ((n 0))
341                 (cond
342                   ((seq-null? (seq-tail xpr n))
343                    #t)
344                   ((ok? (seq-ref xpr n))
345                    (loop (1+ n)))
346                   (else #f)))))))
347    )
348    (seq-of? (apply conjoin oks?))))
349
350;;; (cons* arg . args)
351;;; ------------------
352;;; sequential version of cons
353(define (cons* arg . args)
354  (let ((revs (reverse (cons arg args))))
355    (let loop ((args (reverse (cdr revs))))
356      (if (null? args)
357        (car revs)
358        (cons (car args) (loop (cdr args)))))))
359
360;;; (list-of ok? ....)
361;;; ------------------
362;;; returns a list predicate which checks all ok? arguments
363(define (list-of . oks?) (list-of? (apply conjoin oks?)))
364
365;;; (pseudo-list-of ok? ....)
366;;; ------------------
367;;; returns a pseudo-list predicate which checks all ok? arguments
368(define (pseudo-list-of . oks?)
369  (letrec
370    ((pseudo-list-of?
371       (lambda (ok?)
372         (lambda (xpr)
373           (or (ok? xpr)
374               (and (pair? xpr)
375                    (ok? (car xpr))
376                    ((pseudo-list-of? ok?) (cdr xpr))))))))
377    (pseudo-list-of? (apply conjoin oks?))))
378
379;;; (vector-of ok? ....)
380;;; --------------------
381;;; returns a vector predicate which checks all ok? arguments
382(define (vector-of . oks?)
383  (let (
384    (vector-of?
385      (lambda (ok?)
386        (lambda (vec)
387          (and (vector? vec)
388               (let loop ((n 0))
389                 (cond
390                   ((fx= n (vector-length vec))
391                    #t)
392                   ((ok? (vector-ref vec n))
393                    (loop (1+ n)))
394                   (else #f)))))))
395    )
396    (vector-of? (apply conjoin oks?))))
397
398;;; (tagged-vector-of ok? ...)
399;;; --------------------------
400;;; returns a vector predicate which checks all ok? arguments
401(define (tagged-vector-of . oks?)
402  (lambda (xpr)
403    (and (tagged-vector? xpr)
404         ((apply vector-of oks?)
405          (subvector xpr 1)))))
406
407;;; (symbol-dispatcher alist)
408;;; -------------------------
409;;; returns a procedure of zero or one argument, which shows all cars
410;;; or the cdr of the alist item with car symbol
411(define (symbol-dispatcher alist)
412  (case-lambda
413    (()
414     (map car alist))
415    ((sym)
416     (let ((pair (assq sym alist)))
417       (if pair
418         (for-each print (cdr pair))
419         (error "Not in list"
420                sym
421                (map car alist)))))))
422
423
424;;; (basic-sequences sym ..)
425;;; ----------------------
426;;; documentation procedure
427(define basic-sequences
428  (symbol-dispatcher '(
429    (seq-ref
430      procedure:
431      (seq-ref seq k)
432      "sequence version of list-ref")
433    (seq-tail
434      procedure:
435      (seq-tail seq k)
436      "sequence version of list-tail")
437    (seq-car
438      procedure:
439      (seq-car seq)
440      "sequence version of cdr")
441    (seq-cdr
442      procedure:
443      (seq-cdr seq)
444      "sequence version of cdr")
445    (seq-null?
446      procedure:
447      (seq-null? seq)
448      "sequence version of null?")
449    (seq?
450      procedure:
451      (seq? xpr)
452      "checks if xpr is a sequence")
453    (seq-of
454      procedure:
455      (seq-of ok? ...)
456      "returns a sequence predicate which checks sequence items")
457    (seq-maker
458      procedure:
459      (seq-maker seq)
460      "returns a constructor for seq's type")
461    (seq-random-access?
462      procedure:
463      (seq-random-access? seq)
464      "checks, if seq is a random access sequence")
465    (seq-db
466      procedure:
467      (seq-db)
468      "shows the sequence database"
469      (seq-db type ref: ref tail: tail maker: maker ra?: random-access?)
470      "adds a new sequence type to the database where the keywords"
471      "name arguments being accessed as seq-ref and seq-tail seq-maker"
472      "and seq-random-access? respectively")
473    (seq-exception
474      procedure:
475      (seq-exception loc msg arg ...)
476      "generates a composite condition with location symbol, string message"
477      "and possible additional arguments arg ...")
478    (cons*
479      procedure:
480      (cons* arg ....)
481      "iterative version of cons")
482    (list-of
483      procedure:
484      (list-of ok? ...)
485      "generates a list predicate which checks all of its arguments")
486    (pseudo-list-of
487      procedure:
488      (pseudo-list-of ok? ...)
489      "generates a pseudo-list predicate which checks all of its arguments")
490    (vector-of
491      procedure:
492      (vector-of ok? ...)
493      "generates a vector predicate which checks all of its arguments")
494    (tagged-vector
495      procedure:
496      (tagged-vector kw arg ...)
497      "generates a tagged vector with keyword kw and args arg ...")
498    (tagged-vector?
499      procedure:
500      (tagged-vector? xpr)
501      "type predicate")
502    (tagged-vector-of
503      procedure:
504      (tagged-vector-of ok? ...)
505      "generates a tagged vector predicate which checks all of its arguments")
506    (tagged-vector-ref
507      procedure:
508      (tagged-vector-ref tv k)
509      "access to kth item of tagged vector tv")
510    (tagged-vector-tail
511      procedure:
512      (tagged-vector-tail tv k)
513      "returns a tagged subvector of tv starting at k")
514    (thunk
515      macro:
516      (thunk xpr ....)
517      "generates a thunk with body xpr ....")
518    (thunk?
519      procedure:
520      (thunk? xpr)
521      "checks if xpr is a thunk, i.e. a nullary procedure")
522    (symbol-dispatcher
523      procedure:
524      (symbol-dispatcher alist)
525      "generates a procedure of zero or one argument showing all"
526      "cars or the cdr or the alist item with symbol as car")
527    )))
528  ) ; basic-sequences
529
Note: See TracBrowser for help on using the repository browser.