From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 2a6 --- collect.scm | 236 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 236 insertions(+) create mode 100644 collect.scm (limited to 'collect.scm') diff --git a/collect.scm b/collect.scm new file mode 100644 index 0000000..abdf209 --- /dev/null +++ b/collect.scm @@ -0,0 +1,236 @@ +;"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" --- ;; -- cgit v1.2.3