From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 28 May 2018 02:47:13 +0000 (-0700)
Subject: Implement vector-any and vector-every.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~7
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=be8576406e36917e376c82ec98b0668293f683bd;p=mit-scheme.git

Implement vector-any and vector-every.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index cc1678e36..348588841 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -851,12 +851,14 @@ USA.
 	  subvector-uniform?
 	  vector
 	  vector->list
+	  vector-any
 	  vector-append
 	  vector-binary-search
 	  vector-builder
 	  vector-copy
 	  vector-copy!
 	  vector-eighth
+	  vector-every
 	  vector-fifth
 	  vector-fill!
 	  vector-filled?
diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm
index 15c6bdd85..90d50df63 100644
--- a/src/runtime/vector.scm
+++ b/src/runtime/vector.scm
@@ -200,6 +200,52 @@ USA.
 (define (for-each-vector-element vector procedure)
   (vector-for-each procedure vector))
 
+(define (vector-any procedure vector . vectors)
+  (let ((n (vector-length vector)))
+    (if (pair? vectors)
+	(let ((n
+	       (fold-left (lambda (n v)
+			    (fix:min (vector-length v) n))
+			  n
+			  vectors)))
+	  (let loop ((i 0))
+	    (if (fix:< i n)
+		(or (apply procedure
+			   (vector-ref vector i)
+			   (map (lambda (vector*)
+				  (vector-ref vector* i))
+				vectors))
+		    (loop (fix:+ i 1)))
+		#f)))
+	(let loop ((i 0))
+	  (if (fix:< i n)
+	      (or (procedure (vector-ref vector i))
+		  (loop (fix:+ i 1)))
+	      #f)))))
+
+(define (vector-every procedure vector . vectors)
+  (let ((n (vector-length vector)))
+    (if (pair? vectors)
+	(let ((n
+	       (fold-left (lambda (n v)
+			    (fix:min (vector-length v) n))
+			  n
+			  vectors)))
+	  (let loop ((i 0))
+	    (if (fix:< i n)
+		(and (apply procedure
+			    (vector-ref vector i)
+			    (map (lambda (vector*)
+				   (vector-ref vector* i))
+				 vectors))
+		     (loop (fix:+ i 1)))
+		#t)))
+	(let loop ((i 0))
+	  (if (fix:< i n)
+	      (and (procedure (vector-ref vector i))
+		   (loop (fix:+ i 1)))
+	      #t)))))
+
 (define (subvector-find-next-element vector start end item)
   (guarantee-subvector vector start end 'subvector-find-next-element)
   (let loop ((index start))