source: project/release/5/yasos/trunk/collections.scm @ 36586

Last change on this file since 36586 was 36586, checked in by iraikov, 3 months ago

yasos: added a subset of srfi-127 lseqs to collections module

File size: 18.1 KB
Line 
1
2(module yasos-collections
3
4 (collection? random-access? empty? size gen-keys gen-elts 
5              do-elts do-keys do-items 
6              map-elts map-keys map-items
7              for-each-key for-each-elt elt-ref elt-set! elt-take elt-drop
8              reduce reduce* reduce-items reduce-items* sort! sort
9              make-vector-generator list->generator vector->generator
10              string->generator hash-table->generator
11              g-map g-reduce g-find g-filter
12              generator->lseq lseq-first lseq-rest
13              )
14 
15 (import scheme (chicken base) (chicken format) srfi-69 
16         (except yasos object object-with-ancestors))
17
18 
19;; COLLECTION INTERFACE
20
21;; (collection? obj)  -- predicate
22;;
23;; (empty? collection)  -- I bet you can guess what these do as well...
24;; (size collection)
25;;
26;; (do-elts proc coll+) -- apply proc element-wise to collections
27;; (do-keys proc coll+) -- .. return value is unspecified
28;;
29;; (map-elts proc coll+) -- as with do-*, but returns collection
30;; (map-keys proc coll+) -- e.g. (map-keys + (list 1 2 3) (vector 1 2 3))
31;;                                      -> #( 2 4 6 )
32;;
33;; (for-each-key coll proc) -- for single collection (more efficient)
34;; (for-each-elt coll proc)
35;;
36;; (reduce proc seed coll+) -- e.g. (reduce + 0 (vector 1 2 3))
37;;
38;;==============================
39;; Collections must implement:
40;;  collection?
41;;  gen-elts
42;;  gen-keys
43;;  size
44;;  print
45;;
46;; Collections should implement {typically faster}:
47;;  for-each-key
48;;  for-each-elt
49;;
50;; Collections may optionally implement:
51;; 1) random access operations:
52;;
53;; elt-ref
54;; elt-set!
55;; elt-take
56;; elt-drop
57;;
58
59 
60 (define *eof-object* (read (open-input-string "")))
61 (define (eof-object) *eof-object*)
62
63 (define (list-any pred lis)
64   (and (not (null? lis))
65        (let lp ((head (car lis)) (tail (cdr lis)))
66          (if (null? tail)
67              (pred head)               ; Last PRED app is tail call.
68              (or (pred head) (lp (car tail) (cdr tail)))))))
69
70 (define (list-zip list1 . more-lists) (apply map list list1 more-lists))
71
72 (define (list-take lis k)
73  (let recur ((lis lis) (k k))
74    (if (eq? 0 k) '()
75        (cons (car lis)
76              (recur (cdr lis) (- k 1))))))
77
78 (define (list-drop lis k)
79   (let iter ((lis lis) (k k))
80    (if (eq? 0 k) lis (iter (cdr lis) (- k 1)))))
81 
82 
83 (define-operation (collection? obj)
84  ;; default
85   (cond
86    ((or (list? obj) (vector? obj) (string? obj) (hash-table? obj)) #t)
87    (else #f)
88    ))
89
90 
91 (define-operation (random-access? obj)
92  ;; default
93   (cond
94    ((or (list? obj) (vector? obj) (string? obj) (hash-table? obj)) #t)
95    (else #f)
96    ))
97
98 
99 (define (empty? collection) (zero? (size collection)))
100 
101 (define-operation (elt-ref <collection> i);; random access collection
102  ;; default behavior
103   (cond                    
104    ((vector? <collection>) (vector-ref <collection> i)) 
105    ((list?   <collection>) (list-ref  <collection> i))
106    ((string? <collection>) (string-ref  <collection> i))
107    ((hash-table? <collection>) (hash-table-ref <collection> i))
108    (else
109     (error "operation not supported: elt-ref"))
110    ))
111 
112 (define-operation (elt-set! <collection> i v);; random access collection
113  ;; default behavior
114   (cond                    
115    ((vector? <collection>) (vector-set! <collection> i v)) 
116    ((list?   <collection>) (list-set!  <collection> i v))
117    ((string? <collection>) (string-set!  <collection> i v))
118    ((hash-table? <collection>) (hash-table-set! <collection> i v))
119    (else
120     (error "operation not supported: elt-set!"))
121    ))
122
123 (define-operation (elt-take <collection> n);; random access collection
124  ;; default behavior
125   (cond                    
126    ((vector? <collection>) (subvector <collection> 0 n))
127    ((list?   <collection>) (list-take  <collection> n))
128    ((string? <collection>) (substring  <collection> 0 n))
129    ((hash-table? <collection>)
130     (let ((keys (hash-table-keys <collection>))
131           (result (make-hash-table)))
132       (for-each
133        (lambda (k) (hash-table-set! result k (hash-table-ref <collection> k)))
134        (list-take keys n))
135       result))
136    (else
137     (error "operation not supported: elt-take"))
138    ))
139
140
141 (define-operation (elt-drop <collection> n);; random access collection
142  ;; default behavior
143   (cond                    
144    ((vector? <collection>) (subvector <collection> n))
145    ((list?   <collection>) (list-drop  <collection> n))
146    ((string? <collection>) (substring  <collection> n))
147    ((hash-table? <collection>)
148     (let ((keys (hash-table-keys <collection>))
149           (result (make-hash-table)))
150       (for-each
151        (lambda (k) (hash-table-set! result k (hash-table-ref <collection> k)))
152        (list-drop keys n))
153       result))
154    (else
155     (error "operation not supported: elt-take"))
156    ))
157
158 (define-operation (gen-elts <collection>);; return SRFI-121 element generator
159  ;; default behavior
160   (cond                    
161    ((vector? <collection>) (vector->generator <collection>)) 
162    ((list?   <collection>) (list->generator   <collection>))
163    ((string? <collection>) (string->generator <collection>))
164    ((hash-table? <collection>) (hash-table->generator <collection>))
165    (else
166     (error "operation not supported: gen-elts "))
167    ))
168
169
170 (define-operation (gen-keys collection)
171   (cond
172    ((or (vector? collection) (list? collection) (string? collection))
173     (let ( (max+1 (size collection)) (index (make-parameter 0) ))
174       (lambda ()
175         (let ((i (index)))
176           (cond
177            ((< i max+1)
178             (index (add1 i))
179             i)
180            (else (eof-object))
181            ))
182         ))
183     )
184    ((hash-table? collection)
185     (list->generator (hash-table-keys collection)))
186    (else
187     (error "operation not handled: gen-keys " collection))
188    ))
189
190 (define (do-elts <proc> . <collections>)
191   (let ( (max+1 (size (car <collections>)))
192          (generators (map gen-elts <collections>))
193          )
194     (let loop ( (counter 0) )
195       (cond
196        ((< counter max+1)
197         (apply <proc> (map (lambda (g) (g)) generators))
198         (loop (add1 counter))
199         )
200        (else 'unspecific)  ; done
201        )  )
202     ) )
203
204 (define (do-keys <proc> . <collections>)
205   (let ( (max+1 (size (car <collections>)))
206          (generators (map gen-keys <collections>))
207          )
208     (let loop ( (counter 0) )
209       (cond
210        ((< counter max+1)
211         (apply <proc> (map (lambda (g) (g)) generators))
212         (loop (add1 counter))
213         )
214        (else 'unspecific)  ; done
215        )  )
216     ) )
217
218 (define (do-items <proc> . <collections>)
219   (let ( (max+1 (size (car <collections>)))
220          (elt-generators (map gen-elts <collections>))
221          (key-generators (map gen-keys <collections>)) )
222     (let loop ( (counter 0) )
223       (cond
224        ((< counter max+1)
225         (apply <proc> (list-zip (map (lambda (g) (g)) key-generators)
226                                 (map (lambda (g) (g)) elt-generators)))
227         (loop (add1 counter))
228         )
229        (else 'unspecific)  ; done
230        )  )
231     ) )
232
233 (define (map-elts <proc> . <collections>)
234   (let ( (max+1 (size (car <collections>)))
235          (generators (map gen-elts <collections>))
236          (vec (make-vector (size (car <collections>))))
237          )
238     (let loop ( (index 0) )
239       (cond
240        ((< index max+1)
241         (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
242         (loop (add1 index))
243         )
244        (else vec)  ; done
245        )  )
246     ) )
247
248 (define (map-keys <proc> . <collections>)
249   (let ( (max+1 (size (car <collections>)))
250          (generators (map gen-keys <collections>))
251          (vec (make-vector (size (car <collections>))))
252          )
253     (let loop ( (index 0) )
254       (cond
255        ((< index max+1)
256         (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
257         (loop (add1 index))
258         )
259        (else vec)  ; done
260        )  )
261     ) )
262
263 (define (map-items <proc> . <collections>)
264   (let ( (max+1 (size (car <collections>)))
265          (key-generators (map gen-keys <collections>))
266          (elt-generators (map gen-elts <collections>))
267          (vec (make-vector (size (car <collections>))))
268          )
269     (let loop ( (index 0) )
270       (cond
271        ((< index max+1)
272         (vector-set! vec index (apply <proc> (list-zip (map (lambda (g) (g)) key-generators)
273                                                        (map (lambda (g) (g)) elt-generators))))
274         (loop (add1 index))
275         )
276        (else vec)  ; done
277        )  )
278     ) )
279
280 (define-operation (for-each-key <proc> <collection>)
281  ;; default
282   (do-keys <proc> <collection>) ;; talk about lazy!
283   )
284
285 (define-operation (for-each-elt <proc> <collection>)
286   (do-elts <proc> <collection>)
287   )
288
289 (define (reduce <proc> <seed> . <collections>)
290   (let ( (max+1 (size (car <collections>)))
291          (elt-generators (map gen-elts <collections>))
292          (ax (make-parameter <seed>))
293          )
294     (let loop ( (count 0) )
295       (cond
296        ((< count max+1)
297         (ax (apply <proc> (append (map (lambda (g) (g)) elt-generators) (list (ax)))))
298         (loop (add1 count))
299         )
300        (else (ax))
301        ) )
302     )  )
303 
304
305 (define (reduce-items <proc> <seed> . <collections>)
306   (let ( (max+1 (size (car <collections>)))
307          (key-generators (map gen-keys <collections>))
308          (elt-generators (map gen-elts <collections>))
309          (ax (make-parameter <seed>))
310          )
311     (let loop ( (count 0) )
312       (cond
313        ((< count max+1)
314         (ax (apply <proc> (append (list-zip (map (lambda (g) (g)) key-generators)
315                                             (map (lambda (g) (g)) elt-generators))
316                                   (list (ax)))))
317         (loop (add1 count))
318         )
319        (else (ax))
320        ) )
321     )  )
322 
323;; reduce operation where the first element of the collection is the seed
324
325 (define (reduce* <proc> . <collections>)
326   (let* ( (max+1 (- (size (car <collections>)) 1))
327           (elt-generators (map gen-elts <collections>))
328           (ax (make-parameter (map (lambda (g) (g)) elt-generators)))
329           )
330     (let loop ( (count 0) )
331       (cond
332        ((< count max+1)
333         (let ((args (append (map (lambda (g) (g)) elt-generators) (ax))))
334           (ax (list (apply <proc> args))))
335         (loop (add1 count))
336         )
337        (else (car (ax)))
338        ) )
339     )  )
340
341 (define (reduce-items* <proc> . <collections>)
342   (let* ( (max+1 (- (size (car <collections>)) 1))
343           (key-generators (map gen-keys <collections>))
344           (elt-generators (map gen-elts <collections>))
345           (ax (make-parameter (list-zip (map (lambda (g) (g)) key-generators)
346                                         (map (lambda (g) (g)) elt-generators))))
347           )
348     (let loop ( (count 0) )
349       (cond
350        ((< count max+1)
351         (ax (list (apply <proc> (append (list-zip (map (lambda (g) (g)) key-generators)
352                                                   (map (lambda (g) (g)) elt-generators))
353                                         (ax)))))
354         (loop (add1 count))
355         )
356        (else (car (ax)))
357        ) )
358     )  )
359
360 
361;; generator for list elements
362 (define (list->generator <list>)
363   (let ((l (make-parameter <list>)))
364     (lambda ()
365       (if (null? (l))
366           (eof-object)
367           (let ( (elt (car (l))) )
368             (l (cdr (l)))
369             elt))
370       ))
371   )
372
373 (define (make-vector-generator <accessor>)
374   (lambda (vec)
375     (let ( (max+1 (size vec))
376            (index (make-parameter 0))
377            )
378       (lambda ()
379         (let ((i (index)))
380           (cond ((< i max+1)
381                  (index (add1 i))
382                  (<accessor> vec i)
383                  )
384                 (else (eof-object))
385                 ))
386         ))
387     ))
388
389 (define vector->generator (make-vector-generator vector-ref))
390
391 (define string->generator (make-vector-generator string-ref))
392
393 (define (hash-table->generator table)
394   (let ((keys (make-parameter (hash-table-keys table))))
395     (lambda () 
396       (cond ((null? keys) (eof-object))
397             (else (let ((res (hash-table-ref table (car (keys)))))
398                     (keys (cdr (keys)))
399                     res))
400             ))
401     ))
402
403
404;; nota bene:  list-set! is bogus for element 0
405
406 (define (list-set! <list> <index> <value>)
407
408   (define (set-loop last this idx)
409     (cond
410      ((zero? idx) 
411       (set-cdr! last (cons <value> (cdr this)))
412       <list>
413       )
414      (else (set-loop (cdr last) (cdr this) (sub1 idx)))
415      )  )
416
417  ;; main
418   (if (zero? <index>)
419       (cons <value> (cdr <list>)) ;; return value
420       (set-loop <list> (cdr <list>) (sub1 <index>)))
421   )
422
423 
424 ;;
425 ;; In-place quick sort from SRFI-32 reference implementation.
426 ;; Modified so that the comparison function uses element indices as
427 ;; well as element values:
428 ;;
429 ;; elt< :: i1 v1 i2 v2 -> boolean
430 ;;
431 ;; Copyright (c) 1998 by Olin Shivers. You may do as you please with
432 ;; this code, as long as you do not delete this notice or hold me
433 ;; responsible for any outcome related to its use.
434 ;;
435 
436 (define (sort! elt< v . rest)
437   (let-optionals rest ((start 0) (end (size v)))
438    (let recur ((l start) (r end))      ; Sort the range [l,r).
439      (if (< 1 (- r l))
440         
441          ;; Choose the median of V[l], V[r], and V[middle] for the pivot.
442          (let ((median
443                 (lambda (i1 i2 i3)
444                   (let ((v1 (elt-ref v i1))
445                         (v2 (elt-ref v i2))
446                         (v3 (elt-ref v i3)))
447                     (receive (ilittle little ibig big)
448                              (if (elt< i1 v1 i2 v2)
449                                  (values i1 v1 i2 v2)
450                                  (values i2 v2 i1 v1))
451                              (if (elt< ibig big i3 v3) 
452                                  (values ibig big)
453                                  (if (elt< ilittle little i3 v3) 
454                                      (values i3 v3) 
455                                      (values ilittle little))))))))
456           
457            (let-values (((ipivot pivot) (median l (quotient (+ l r) 2) (- r 1))))
458              (let loop ((i l) (j (- r 1)))
459                (let ((i (let scan ((i i)) (if (elt< i (elt-ref v i) ipivot pivot)
460                                               (scan (+ i 1))
461                                               i)))
462                      (j (let scan ((j j)) (if (elt< ipivot pivot j (elt-ref v j))
463                                               (scan (- j 1))
464                                               j))))
465                  (if (< i j)
466                      (let ((tmp (elt-ref v j)))               
467                        (elt-set! v j (elt-ref v i))    ; Swap V[I]
468                        (elt-set! v i tmp)              ;  and V[J].
469                        (loop (+ i 1) (- j 1)))
470                     
471                      (begin (recur l i) (recur (+ j 1) r)))))))
472          v)
473      ))
474   )
475
476 ;; Blit FROM[I,END) to TO[J,?].
477 
478 (define (vector-blit! from i end to j)
479    (assert (< i end))
480    (let recur ((i i) (j j))
481      (if (< i end)
482          (let ((vi (elt-ref from i)))
483            (vector-set! to j vi)
484            (recur (+ i 1) (+ j 1)))
485          ))
486      )
487
488 
489 ;; Given array A and indices p, q, r such that p < q < r,
490 ;; merge subarray A[p..q) and subarray A[q..r) into array B[n..]
491
492(define (vector-merge! elt< a p q r b n)
493    (assert (and (< p q) (< q r)))
494    (let recur ((i p) (j q) (k n))
495      (if (and (< i q) (< j r))
496          (let ((ai (elt-ref a i))
497                (aj (elt-ref a j)))
498            (if (elt< i ai j aj)
499                (begin
500                  (vector-set! b k ai)
501                  (recur (+ 1 i) j (+ 1 k)))
502                (begin
503                  (vector-set! b k aj)
504                  (recur i (+ 1 j) (+ 1 k)))
505                ))
506          (if (< i q)
507              (vector-blit! a i q b k)
508              (if (< j r)
509                  (vector-blit! a j r b k))))
510      )
511    b)
512
513 
514 ;; Collection merge sort
515 (define (sort elt< x)
516   (let* ((n (size x))
517          (a (make-vector n)))
518     (do-items (lambda (item) (vector-set! a (car item) (cadr item))) x)
519     (if (< n 2)
520         a
521         (let ((b (make-vector n)))
522           (let recur ((m 1))
523             (if (< m n)
524                 (let inner-recur ((p 0))
525                   (if (< p (- n m))
526                       (let ((q (+ p m))
527                             (r (min (+ p (* 2 m)) n)))
528                         (vector-merge! elt< a p q r b p)
529                         (vector-blit! b p r a p)
530                         (inner-recur (+ p (* 2 m)))
531                         )
532                       (recur (* m 2))))
533                 b))
534           ))
535     ))
536           
537
538  ;; Generator combinators
539  (define (g-map f . gs)
540    (lambda ()
541      (let ((vs (map (lambda (g) (g)) gs)))
542        (if (list-any eof-object? vs)
543            (eof-object)
544            (apply f vs))
545        ))
546    )
547
548
549  (define (g-reduce f seed . gs)
550    (define (inner-fold seed)
551      (let ((vs (map (lambda (g) (g)) gs)))
552        (if (list-any eof-object? vs)
553            seed
554            (inner-fold (apply f (append vs (list seed)))))))
555    (inner-fold seed))
556
557
558  (define (g-find pred g)
559    (let loop ((v (g)))
560      (if (or (pred v) (eof-object? v))
561          v
562          (loop (g)))
563      ))
564
565  (define (g-filter pred g)
566    (let loop ((v (g)) (res '()))
567      (cond ((eof-object? v) res)
568            ((pred v) (loop (g) (cons v res)))
569            (else (loop (g) res)))
570      ))
571
572;;;; SRFI 127 lazy sequences
573;;; Convert a generator (procedure with no arguments) to an lseq
574;;; This is the basic constructor for lseqs, since every proper list
575;;; is already an lseq and so list->lseq is not needed
576
577  (define (generator->lseq gen)
578    (let ((value (gen)))
579      ;; See what starts off the generator:
580      ;; if it's already exhausted, the lseq is empty,
581      ;; otherwise, return an improper list with one value and the generator
582      ;; in the tail, which is how we represent unrealized lseqs
583      (if (eof-object? value)
584          '()
585          (cons value gen))))
586
587
588  (define (lseq-first lseq) (car lseq))
589
590;;; Lseq-cdr expands the generator if it's there, or falls back to regular cdr
591  (define (lseq-rest lseq)
592    ;; We assume lseq is a pair, because it is an error if it isn't
593    ;; If it's a procedure, we assume it's a generator and invoke it
594    (if (procedure? (cdr lseq))
595        (let ((obj ((cdr lseq))))
596          (cond
597           ;; If the generator is exhausted, replace with () and return ()
598           ((eof-object? obj)
599            (set-cdr! lseq '())
600            '())
601           ;; Otherwise, make a new pair of the value and the generator
602           ;; and patch it in to the cdr
603           (else (let ((result (cons obj (cdr lseq))))
604                   (set-cdr! lseq result)
605                   result))))
606        ;; If there is no procedure, return the ordinary cdr
607        (cdr lseq)))
608
609 )
Note: See TracBrowser for help on using the repository browser.