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

Last change on this file since 38029 was 38029, checked in by Ivan Raikov, 9 months ago

added elt-slice to yasos collections

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