;"collect.scm" Sample collection operations ; COPYRIGHT (c) Kenneth Dickey 1992 ; ; This software may be used for any purpose whatever ; without warranty 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 'object) (require 'yasos) (define collect:size size) (define collect:print print) ;@ (define collection? (make-generic-method (lambda (obj!2) (cond ((or (list? obj!2) (vector? obj!2) (string? obj!2)) #t) (else #f))))) ;@ (define empty? (lambda (collection!1) (zero? (collect:size collection!1)))) ;@ (define gen-elts (make-generic-method (lambda (!2) (cond ((vector? !2) (collect:vector-gen-elts !2)) ((list? !2) (collect:list-gen-elts !2)) ((string? !2) (collect:string-gen-elts !2)) (else (slib:error 'gen-elts 'operation-not-supported (collect:print !2 #f))))))) ;@ (define gen-keys (make-generic-method (lambda (collection!2) (if (or (vector? collection!2) (list? collection!2) (string? collection!2)) (let ((max+1!3 (collect:size collection!2)) (index!3 0)) (lambda () (cond ((< index!3 max+1!3) (set! index!3 (collect:add1 index!3)) (collect:sub1 index!3)) (else (slib:error 'no-more 'keys 'in 'generator))))) (slib:error 'gen-keys 'operation-not-handled collection!2))))) ;@ (define do-elts (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-elts !1))) (let loop!4 ((counter!3 0)) (cond ((< counter!3 max+1!2) (apply !1 (map (lambda (g!5) (g!5)) generators!2)) (loop!4 (collect:add1 counter!3))) (else 'unspecific)))))) ;@ (define do-keys (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-keys !1))) (let loop!4 ((counter!3 0)) (cond ((< counter!3 max+1!2) (apply !1 (map (lambda (g!5) (g!5)) generators!2)) (loop!4 (collect:add1 counter!3))) (else 'unspecific)))))) ;@ (define map-elts (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-elts !1)) (vec!2 (make-vector (collect:size (car !1))))) (let loop!4 ((index!3 0)) (cond ((< index!3 max+1!2) (vector-set! vec!2 index!3 (apply !1 (map (lambda (g!5) (g!5)) generators!2))) (loop!4 (collect:add1 index!3))) (else vec!2)))))) ;@ (define map-keys (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-keys !1)) (vec!2 (make-vector (collect:size (car !1))))) (let loop!4 ((index!3 0)) (cond ((< index!3 max+1!2) (vector-set! vec!2 index!3 (apply !1 (map (lambda (g!5) (g!5)) generators!2))) (loop!4 (collect:add1 index!3))) (else vec!2)))))) ;@ (define for-each-key (make-generic-method (lambda (!2 !2) (collect:do-keys !2 !2)))) ;@ (define for-each-elt (make-generic-method (lambda (!2 !2) (collect:do-elts !2 !2)))) ;@ (define reduce (lambda (!1 !1 . !1) (letrec ((reduce-init!3 (lambda (pred?!8 init!8 lst!8) (if (null? lst!8) init!8 (reduce-init!3 pred?!8 (pred?!8 init!8 (car lst!8)) (cdr lst!8)))))) (if (null? !1) (cond ((null? !1) !1) ((null? (cdr !1)) (car !1)) (else (reduce-init!3 !1 (car !1) (cdr !1)))) (let ((max+1!4 (collect:size (car !1))) (generators!4 (map collect:gen-elts !1))) (let loop!6 ((count!5 0)) (cond ((< count!5 max+1!4) (set! !1 (apply !1 !1 (map (lambda (g!7) (g!7)) generators!4))) (loop!6 (collect:add1 count!5))) (else !1)))))))) ;;@ pred true for every elt? (define every? (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-elts !1))) (let loop!4 ((count!3 0)) (cond ((< count!3 max+1!2) (if (apply !1 (map (lambda (g!5) (g!5)) generators!2)) (loop!4 (collect:add1 count!3)) #f)) (else #t)))))) ;;@ pred true for any elt? (define any? (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-elts !1))) (let loop!4 ((count!3 0)) (cond ((< count!3 max+1!2) (if (apply !1 (map (lambda (g!5) (g!5)) generators!2)) #t (loop!4 (collect:add1 count!3)))) (else #f)))))) ;; MISC UTILITIES (define collect:add1 (lambda (obj!1) (+ obj!1 1))) (define collect:sub1 (lambda (obj!1) (- obj!1 1))) ;; Nota Bene: list-set! is bogus for element 0 (define collect:list-set! (lambda (!1 !1 !1) (letrec ((set-loop!3 (lambda (last!4 this!4 idx!4) (cond ((zero? idx!4) (set-cdr! last!4 (cons !1 (cdr this!4))) !1) (else (set-loop!3 (cdr last!4) (cdr this!4) (collect:sub1 idx!4))))))) (if (zero? !1) (cons !1 (cdr !1)) (set-loop!3 !1 (cdr !1) (collect:sub1 !1)))))) (add-setter list-ref collect:list-set!) ; for (setter list-ref) ;; generator for list elements (define collect:list-gen-elts (lambda (!1) (lambda () (if (null? !1) (slib:error 'no-more 'list-elements 'in 'generator) (let ((elt!3 (car !1))) (begin (set! !1 (cdr !1)) elt!3)))))) ;; generator for vector elements (define collect:make-vec-gen-elts (lambda (!1) (lambda (vec!2) (let ((max+1!3 (collect:size vec!2)) (index!3 0)) (lambda () (cond ((< index!3 max+1!3) (set! index!3 (collect:add1 index!3)) (!1 vec!2 (collect:sub1 index!3))) (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 collect:gen-keys gen-keys) (define collect:gen-elts gen-elts) (define collect:do-elts do-elts) (define collect:do-keys do-keys) ;; --- E O F "collect.oo" --- ;;