diff options
Diffstat (limited to 'collectx.scm')
| -rw-r--r-- | collectx.scm | 247 |
1 files changed, 247 insertions, 0 deletions
diff --git a/collectx.scm b/collectx.scm new file mode 100644 index 0000000..7ba46b9 --- /dev/null +++ b/collectx.scm @@ -0,0 +1,247 @@ +;"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 (<collection>!2) + (cond ((vector? <collection>!2) + (collect:vector-gen-elts <collection>!2)) + ((list? <collection>!2) + (collect:list-gen-elts <collection>!2)) + ((string? <collection>!2) + (collect:string-gen-elts <collection>!2)) + (else + (slib:error + 'gen-elts + 'operation-not-supported + (collect:print <collection>!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 (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((counter!3 0)) + (cond ((< counter!3 max+1!2) + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2)) + (loop!4 (collect:add1 counter!3))) + (else 'unspecific)))))) +;@ +(define do-keys + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-keys <collections>!1))) + (let loop!4 ((counter!3 0)) + (cond ((< counter!3 max+1!2) + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2)) + (loop!4 (collect:add1 counter!3))) + (else 'unspecific)))))) +;@ +(define map-elts + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1)) + (vec!2 (make-vector + (collect:size (car <collections>!1))))) + (let loop!4 ((index!3 0)) + (cond ((< index!3 max+1!2) + (vector-set! + vec!2 + index!3 + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 index!3))) + (else vec!2)))))) +;@ +(define map-keys + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-keys <collections>!1)) + (vec!2 (make-vector + (collect:size (car <collections>!1))))) + (let loop!4 ((index!3 0)) + (cond ((< index!3 max+1!2) + (vector-set! + vec!2 + index!3 + (apply <proc>!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 (<collection>!2 <proc>!2) + (collect:do-keys <proc>!2 <collection>!2)))) +;@ +(define for-each-elt + (make-generic-method + (lambda (<collection>!2 <proc>!2) + (collect:do-elts <proc>!2 <collection>!2)))) +;@ +(define reduce + (lambda (<proc>!1 <seed>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (set! <seed>!1 + (apply <proc>!1 + <seed>!1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 count!3))) + (else <seed>!1)))))) + + + +;;@ pred true for every elt? +(define every? + (lambda (<pred?>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (if (apply <pred?>!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 (<pred?>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (if (apply <pred?>!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 (<list>!1 <index>!1 <value>!1) + (letrec ((set-loop!3 + (lambda (last!4 this!4 idx!4) + (cond ((zero? idx!4) + (set-cdr! last!4 (cons <value>!1 (cdr this!4))) + <list>!1) + (else + (set-loop!3 + (cdr last!4) + (cdr this!4) + (collect:sub1 idx!4))))))) + (if (zero? <index>!1) + (cons <value>!1 (cdr <list>!1)) + (set-loop!3 + <list>!1 + (cdr <list>!1) + (collect:sub1 <index>!1)))))) + +(add-setter list-ref collect:list-set!) + ; for (setter list-ref) + + +;; generator for list elements +(define collect:list-gen-elts + (lambda (<list>!1) + (lambda () + (if (null? <list>!1) + (slib:error + 'no-more + 'list-elements + 'in + 'generator) + (let ((elt!3 (car <list>!1))) + (begin (set! <list>!1 (cdr <list>!1)) elt!3)))))) + +;; generator for vector elements +(define collect:make-vec-gen-elts + (lambda (<accessor>!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)) + (<accessor>!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" --- ;; |