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

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

yasos collections: include the actual lazy implementation of lseq-filter

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