;"collect.scm" Sample collection operations ; COPYRIGHT (c) Kenneth Dickey 1992 ; ; This software may be used for any purpose whatever ; without warrantee of any kind. ; AUTHOR Ken Dickey ; DATE 1992 September 1 ; LAST UPDATED 1992 September 2 ; NOTES Expository (optimizations & checks elided). ; Requires YASOS (Yet Another Scheme Object System). (require 'yasos) (define-operation (collect:collection? obj) ;; default (cond ((or (list? obj) (vector? obj) (string? obj)) #t) (else #f) ) ) (define (collect:empty? collection) (zero? (yasos:size collection))) (define-operation (collect:gen-elts ) ;; return element generator ;; default behavior (cond ;; see utilities, below, for generators ((vector? ) (collect:vector-gen-elts )) ((list? ) (collect:list-gen-elts )) ((string? ) (collect:string-gen-elts )) (else (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f))) ) ) (define-operation (collect:gen-keys collection) (if (or (vector? collection) (list? collection) (string? collection)) (let ( (max+1 (yasos:size collection)) (index 0) ) (lambda () (cond ((< index max+1) (set! index (collect:add1 index)) (collect:sub1 index)) (else (slib:error "no more keys in generator")) ) ) ) (slib:error "Operation not handled: GEN-KEYS " collection) ) ) (define (collect:do-elts . ) (let ( (max+1 (yasos:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (counter 0) ) (cond ((< counter max+1) (apply (map (lambda (g) (g)) generators)) (loop (collect:add1 counter)) ) (else 'unspecific) ; done ) ) ) ) (define (collect:do-keys . ) (let ( (max+1 (yasos:size (car ))) (generators (map collect:gen-keys )) ) (let loop ( (counter 0) ) (cond ((< counter max+1) (apply (map (lambda (g) (g)) generators)) (loop (collect:add1 counter)) ) (else 'unspecific) ; done ) ) ) ) (define (collect:map-elts . ) (let ( (max+1 (yasos:size (car ))) (generators (map collect:gen-elts )) (vec (make-vector (yasos:size (car )))) ) (let loop ( (index 0) ) (cond ((< index max+1) (vector-set! vec index (apply (map (lambda (g) (g)) generators))) (loop (collect:add1 index)) ) (else vec) ; done ) ) ) ) (define (collect:map-keys . ) (let ( (max+1 (yasos:size (car ))) (generators (map collect:gen-keys )) (vec (make-vector (yasos:size (car )))) ) (let loop ( (index 0) ) (cond ((< index max+1) (vector-set! vec index (apply (map (lambda (g) (g)) generators))) (loop (collect:add1 index)) ) (else vec) ; done ) ) ) ) (define-operation (collect:for-each-key ) ;; default (collect:do-keys ) ;; talk about lazy! ) (define-operation (collect:for-each-elt ) (collect:do-elts ) ) (define (collect:reduce . ) (let ( (max+1 (yasos:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (count 0) ) (cond ((< count max+1) (set! (apply (map (lambda (g) (g)) generators))) (loop (collect:add1 count)) ) (else ) ) ) ) ) ;; pred true for every elt? (define (collect:every? . ) (let ( (max+1 (yasos:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (count 0) ) (cond ((< count max+1) (if (apply (map (lambda (g) (g)) generators)) (loop (collect:add1 count)) #f) ) (else #t) ) ) ) ) ;; pred true for any elt? (define (collect:any? . ) (let ( (max+1 (yasos:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (count 0) ) (cond ((< count max+1) (if (apply (map (lambda (g) (g)) generators)) #t (loop (collect:add1 count)) )) (else #f) ) ) ) ) ;; MISC UTILITIES (define (collect:add1 obj) (+ obj 1)) (define (collect:sub1 obj) (- obj 1)) ;; Nota Bene: list-set! is bogus for element 0 (define (collect:list-set! ) (define (set-loop last this idx) (cond ((zero? idx) (set-cdr! last (cons (cdr this))) ) (else (set-loop (cdr last) (cdr this) (collect:sub1 idx))) ) ) ;; main (if (zero? ) (cons (cdr )) ;; return value (set-loop (cdr ) (collect:sub1 ))) ) (add-setter list-ref collect:list-set!) ; for (setter list-ref) ;; generator for list elements (define (collect:list-gen-elts ) (lambda () (if (null? ) (slib:error "No more list elements in generator") (let ( (elt (car )) ) (set! (cdr )) elt)) ) ) ;; generator for vector elements (define (collect:make-vec-gen-elts ) (lambda (vec) (let ( (max+1 (yasos:size vec)) (index 0) ) (lambda () (cond ((< index max+1) (set! index (collect:add1 index)) ( vec (collect:sub1 index)) ) (else #f) ) ) ) ) ) (define collect:vector-gen-elts (collect:make-vec-gen-elts vector-ref)) (define collect:string-gen-elts (collect:make-vec-gen-elts string-ref)) ;;; exports: (define collection? collect:collection?) (define empty? collect:empty?) (define gen-keys collect:gen-keys) (define gen-elts collect:gen-elts) (define do-elts collect:do-elts) (define do-keys collect:do-keys) (define map-elts collect:map-elts) (define map-keys collect:map-keys) (define for-each-key collect:for-each-key) (define for-each-elt collect:for-each-elt) (define reduce collect:reduce) ; reduce is also in comlist.scm (define every? collect:every?) (define any? collect:any?) ;; --- E O F "collect.oo" --- ;;