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

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

basic-sequences bug in tagged-vector? fixed

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