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

Last change on this file since 36391 was 36391, checked in by iraikov, 7 weeks ago

yasos: simplified collections operations and added several basic combinators for generator functions
statistics: completed conversion to yasos-collections interface

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