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

Last change on this file since 33787 was 33787, checked in by juergen, 4 years ago

basic-sequences 2.0 with tagged-vectors

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