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 | |
---|