Import Upstream version 3a1upstream/3a1

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" ---                    ;;