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

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

yasos: additional operations on collections

File size: 16.3 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* 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          (key-generators (map gen-keys <collections>))
295          (elt-generators (map gen-elts <collections>))
296          (ax (make-parameter <seed>))
297          )
298     (let loop ( (count 0) )
299       (cond
300        ((< count max+1)
301         (ax (apply <proc> (ax) (list-zip (map (lambda (g) (g)) key-generators)
302                                          (map (lambda (g) (g)) elt-generators))))
303         (loop (add1 count))
304         )
305        (else (ax))
306        ) )
307     )  )
308 
309;; reduce operation where the first element of the collection is the seed
310
311 (define (reduce* <proc> . <collections>)
312   (let* ( (max+1 (size (car <collections>)))
313           (key-generators (map gen-keys <collections>))
314           (elt-generators (map gen-elts <collections>))
315           (ax (make-parameter (list-zip (map (lambda (g) (g)) key-generators)
316                                         (map (lambda (g) (g)) elt-generators))))
317           )
318     (let loop ( (count 0) )
319       (cond
320        ((< count max+1)
321         (ax (apply <proc> (ax) (list-zip (map (lambda (g) (g)) key-generators)
322                                          (map (lambda (g) (g)) elt-generators))))
323         (loop (add1 count))
324         )
325        (else (ax))
326        ) )
327     )  )
328
329;; pred true for every elt?
330 (define (every-elt? <pred?> . <collections>)
331   (let ( (max+1 (size (car <collections>)))
332          (generators (map gen-elts <collections>))
333          )
334     (let loop ( (count 0) )
335       (cond
336        ((< count max+1)
337         (if (apply <pred?> (map (lambda (g) (g)) generators))
338             (loop (add1 count))
339             #f)
340         )
341        (else #t)
342        ) )
343     )  )
344
345;; pred true for any elt?
346 (define (any-elt? <pred?> . <collections>)
347   (let ( (max+1 (size (car <collections>)))
348          (generators (map gen-elts <collections>))
349          )
350     (let loop ( (count 0) )
351       (cond
352        ((< count max+1)
353         (if (apply <pred?> (map (lambda (g) (g)) generators))
354             #t
355             (loop (add1 count))
356             ))
357        (else #f)
358        ) )
359     )  )
360
361
362
363
364;; generator for list elements
365 (define (list-gen-elts <list>)
366   (let ((l (make-parameter <list>)))
367     (lambda ()
368       (if (null? (l))
369           (error "no more list elements in generator")
370           (let ( (elt (car (l))) )
371             (l (cdr (l)))
372             elt))
373       ))
374   )
375
376 (define (make-vec-gen-elts <accessor>)
377   (lambda (vec)
378     (let ( (max+1 (size vec))
379            (index (make-parameter 0))
380            )
381       (lambda ()
382         (let ((i (index)))
383           (cond ((< i max+1)
384                  (index (add1 i))
385                  (<accessor> vec i)
386                  )
387                 (else #f)
388                 ))
389         ))
390     ))
391
392 (define vector-gen-elts (make-vec-gen-elts vector-ref))
393
394 (define string-gen-elts (make-vec-gen-elts string-ref))
395
396 (define (hash-table-gen-elts table)
397   (let ((keys (make-parameter (hash-table-keys table))))
398     (lambda () 
399       (cond ((null? keys) #f)
400             (else (let ((res (hash-table-ref table (car (keys)))))
401                     (keys (cdr (keys)))
402                     res))
403             ))
404     ))
405
406 
407 (define (zip-elts <collection> . <rest>)
408   (let* (
409          (<collections> (cons <collection> <rest>))
410          (max+1 (- (size (car <collections>)) 1))
411          (generators (map gen-elts <collections>))
412          (result (make-vector (+ 1 max+1)))
413          )
414     (let loop ( (count 0) )
415       (cond
416        ((< count max+1)
417         (vector-set! result count (map (lambda (g) (g)) generators))
418         (loop (add1 count))
419         )
420        (else result)
421        ))
422     ))
423
424
425
426;; nota bene:  list-set! is bogus for element 0
427
428 (define (list-set! <list> <index> <value>)
429
430   (define (set-loop last this idx)
431     (cond
432      ((zero? idx) 
433       (set-cdr! last (cons <value> (cdr this)))
434       <list>
435       )
436      (else (set-loop (cdr last) (cdr this) (sub1 idx)))
437      )  )
438
439  ;; main
440   (if (zero? <index>)
441       (cons <value> (cdr <list>)) ;; return value
442       (set-loop <list> (cdr <list>) (sub1 <index>)))
443   )
444
445 
446 ;;
447 ;; In-place quick sort from SRFI-32 reference implementation.
448 ;; Modified so that the comparison function uses element indices as
449 ;; well as element values:
450 ;;
451 ;; elt< :: i1 v1 i2 v2 -> boolean
452 ;;
453 ;; Copyright (c) 1998 by Olin Shivers. You may do as you please with
454 ;; this code, as long as you do not delete this notice or hold me
455 ;; responsible for any outcome related to its use.
456 ;;
457 
458 (define (sort! elt< v . rest)
459   (let-optionals rest ((start 0) (end (size v)))
460    (let recur ((l start) (r end))      ; Sort the range [l,r).
461      (if (< 1 (- r l))
462         
463          ;; Choose the median of V[l], V[r], and V[middle] for the pivot.
464          (let ((median
465                 (lambda (i1 i2 i3)
466                   (let ((v1 (elt-ref v i1))
467                         (v2 (elt-ref v i2))
468                         (v3 (elt-ref v i3)))
469                     (receive (ilittle little ibig big)
470                              (if (elt< i1 v1 i2 v2)
471                                  (values i1 v1 i2 v2)
472                                  (values i2 v2 i1 v1))
473                              (if (elt< ibig big i3 v3) 
474                                  (values ibig big)
475                                  (if (elt< ilittle little i3 v3) 
476                                      (values i3 v3) 
477                                      (values ilittle little))))))))
478           
479            (let-values (((ipivot pivot) (median l (quotient (+ l r) 2) (- r 1))))
480              (let loop ((i l) (j (- r 1)))
481                (let ((i (let scan ((i i)) (if (elt< i (elt-ref v i) ipivot pivot)
482                                               (scan (+ i 1))
483                                               i)))
484                      (j (let scan ((j j)) (if (elt< ipivot pivot j (elt-ref v j))
485                                               (scan (- j 1))
486                                               j))))
487                  (if (< i j)
488                      (let ((tmp (elt-ref v j)))               
489                        (elt-set! v j (elt-ref v i))    ; Swap V[I]
490                        (elt-set! v i tmp)              ;  and V[J].
491                        (loop (+ i 1) (- j 1)))
492                     
493                      (begin (recur l i) (recur (+ j 1) r)))))))
494          v)
495      ))
496   )
497
498 ;; Blit FROM[I,END) to TO[J,?].
499 
500 (define (vector-blit! from i end to j)
501    (assert (< i end))
502    (let recur ((i i) (j j))
503      (if (< i end)
504          (let ((vi (elt-ref from i)))
505            (vector-set! to j vi)
506            (recur (+ i 1) (+ j 1)))
507          ))
508      )
509
510 
511 ;; Given array A and indices p, q, r such that p < q < r,
512 ;; merge subarray A[p..q) and subarray A[q..r) into array B[n..]
513
514(define (vector-merge! elt< a p q r b n)
515    (assert (and (< p q) (< q r)))
516    (let recur ((i p) (j q) (k n))
517      (if (and (< i q) (< j r))
518          (let ((ai (elt-ref a i))
519                (aj (elt-ref a j)))
520            (if (elt< i ai j aj)
521                (begin
522                  (vector-set! b k ai)
523                  (recur (+ 1 i) j (+ 1 k)))
524                (begin
525                  (vector-set! b k aj)
526                  (recur i (+ 1 j) (+ 1 k)))
527                ))
528          (if (< i q)
529              (vector-blit! a i q b k)
530              (if (< j r)
531                  (vector-blit! a j r b k))))
532      )
533    b)
534
535 
536 ;; Collection merge sort
537 (define (sort elt< x)
538   (let* ((n (size x))
539          (a (make-vector n))
540          (b (make-vector n)))
541     (do-items (lambda (item) (vector-set! a (car item) (cadr item))) x)
542      (let recur ((m 1))
543        (if (< m n)
544            (let inner-recur ((p 0))
545              (if (< p (- n m))
546                  (let ((q (+ p m))
547                        (r (min (+ p (* 2 m)) n)))
548                    (vector-merge! elt< a p q r b p)
549                    (vector-blit! b p r a p)
550                    (inner-recur (+ p (* 2 m)))
551                    )
552                  (recur (* m 2))))
553            b))
554      ))
555           
556
557
558 )
Note: See TracBrowser for help on using the repository browser.