From 8466d8cfa486fb30d1755c4261b781135083787b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:29 -0800 Subject: Import Upstream version 3a1 --- collectx.scm | 247 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 247 insertions(+) create mode 100644 collectx.scm (limited to 'collectx.scm') 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 (!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) + (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) + (set! !1 + (apply !1 + !1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 count!3))) + (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" --- ;; -- cgit v1.2.3