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

Last change on this file since 36387 was 36387, checked in by iraikov, 9 months ago

yasos: a separate reduce-items operation in collections

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