From 5947007621d0045617addfc61f7444edc47dfb16 Mon Sep 17 00:00:00 2001 From: Chongkai Zhu Date: Mon, 9 Apr 2007 04:56:48 +0000 Subject: [PATCH] update svn: r5897 --- collects/srfi/43/constructors.ss | 215 -------- collects/srfi/43/conversion.ss | 98 ---- collects/srfi/43/iteration.ss | 278 ---------- collects/srfi/43/mutators.ss | 159 ------ collects/srfi/43/predicates.ss | 103 ---- collects/srfi/43/searching.ss | 298 ----------- collects/srfi/43/util.ss | 163 ------ collects/srfi/43/vector-lib.ss | 883 +++++++++++++++++++++++++++++-- collects/srfi/63/63.ss | 424 ++++++--------- 9 files changed, 991 insertions(+), 1630 deletions(-) delete mode 100644 collects/srfi/43/constructors.ss delete mode 100644 collects/srfi/43/conversion.ss delete mode 100644 collects/srfi/43/iteration.ss delete mode 100644 collects/srfi/43/mutators.ss delete mode 100644 collects/srfi/43/predicates.ss delete mode 100644 collects/srfi/43/searching.ss delete mode 100644 collects/srfi/43/util.ss diff --git a/collects/srfi/43/constructors.ss b/collects/srfi/43/constructors.ss deleted file mode 100644 index 53c5c6a58a..0000000000 --- a/collects/srfi/43/constructors.ss +++ /dev/null @@ -1,215 +0,0 @@ -;;; -;;; ---- Vector constructors -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005-2006 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - - -(module constructors mzscheme - - (require (lib "receive.ss" "srfi" "8") - "util.ss" - (lib "etc.ss" "mzlib")) - - (provide vector-unfold - vector-unfold-right - vector-copy - vector-reverse-copy - vector-append - vector-concatenate) - - ;;; (VECTOR-UNFOLD ...) -> vector - ;;; (F ...) -> [elt seed' ...] - ;;; The fundamental vector constructor. Creates a vector whose - ;;; length is LENGTH and iterates across each index K between 0 and - ;;; LENGTH, applying F at each iteration to the current index and the - ;;; current seeds to receive N+1 values: first, the element to put in - ;;; the Kth slot and then N new seeds for the next iteration. - (define vector-unfold - (letrec ((tabulate! ; Special zero-seed case. - (lambda (f vec i len) - (cond ((< i len) - (vector-set! vec i (f i)) - (tabulate! f vec (add1 i) len))))) - (unfold1! ; Fast path for one seed. - (lambda (f vec i len seed) - (if (< i len) - (receive (elt new-seed) - (f i seed) - (vector-set! vec i elt) - (unfold1! f vec (add1 i) len new-seed))))) - (unfold2+! ; Slower variant for N seeds. - (lambda (f vec i len seeds) - (if (< i len) - (receive (elt . new-seeds) - (apply f i seeds) - (vector-set! vec i elt) - (unfold2+! f vec (add1 i) len new-seeds)))))) - (lambda (f len . initial-seeds) - (unless (procedure? f) - (apply raise-type-error - 'vector-unfold "procedure" 0 - f len initial-seeds)) - (unless (nonneg-int? len) - (apply raise-type-error - 'vector-unfold "non-negative exact integer" 1 - f len initial-seeds)) - (let ((vec (make-vector len))) - (cond ((null? initial-seeds) - (tabulate! f vec 0 len)) - ((null? (cdr initial-seeds)) - (unfold1! f vec 0 len (car initial-seeds))) - (else - (unfold2+! f vec 0 len initial-seeds))) - vec)))) - - ;;; (VECTOR-UNFOLD-RIGHT ...) -> vector - ;;; (F ...) -> [seed' ...] - ;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 - ;;; (still exclusive with LENGTH and inclusive with 0), not 0 to - ;;; LENGTH as with VECTOR-UNFOLD. - (define vector-unfold-right - (letrec ((tabulate! - (lambda (f vec i) - (cond ((>= i 0) - (vector-set! vec i (f i)) - (tabulate! f vec (sub1 i)))))) - (unfold2+! - (lambda (f vec i seeds) - (if (>= i 0) - (receive (elt . new-seeds) - (apply f i seeds) - (vector-set! vec i elt) - (unfold2+! f vec (sub1 i) new-seeds)))))) - (lambda (f len . initial-seeds) - (unless (procedure? f) - (apply raise-type-error - 'vector-unfold-right "procedure" 0 - f len initial-seeds)) - (unless (nonneg-int? len) - (apply raise-type-error - 'vector-unfold-right "non-negative exact integer" 1 - f len initial-seeds)) - (let ((vec (make-vector len)) - (i (sub1 len))) - (cond ((null? initial-seeds) - (tabulate! f vec i)) - ((null? (cdr initial-seeds)) - (unfold1! f vec i (car initial-seeds))) - (else - (unfold2+! f vec i initial-seeds))) - vec)))) - - ;;; (VECTOR-COPY [ ]) -> vector - ;;; Create a newly allocated vector containing the elements from the - ;;; range [START,END) in VECTOR. START defaults to 0; END defaults - ;;; to the length of VECTOR. END may be greater than the length of - ;;; VECTOR, in which case the vector is enlarged; if FILL is passed, - ;;; the new locations from which there is no respective element in - ;;; VECTOR are filled with FILL. - (define (vector-copy vec . arg) - (unless (vector? vec) - (raise-type-error 'vector-copy "vector" vec)) - (apply - (opt-lambda ((start 0) (end (vector-length vec)) (fill 0)) - (check-index vec start 'vector-copy) - (unless (nonneg-int? end) - (raise-type-error 'vector-copy "non-negative exact integer" end)) - (unless (<= start end) - (raise - (make-exn:fail:contract - (format "~a: indices (~a, ~a) out of range for vector: ~a" - 'vector-copy start end vec) - (current-continuation-marks)))) - (let ((new-vector - (make-vector (- end start) fill))) - (%vector-copy! new-vector 0 - vec start - (min end (vector-length vec))) - new-vector)) - arg)) - - ;;; (VECTOR-REVERSE-COPY [ ]) -> vector - ;;; Create a newly allocated vector whose elements are the reversed - ;;; sequence of elements between START and END in VECTOR. START's - ;;; default is 0; END's default is the length of VECTOR. - (define (vector-reverse-copy vec . arg) - (unless (vector? vec) - (raise-type-error 'vector-reverse-copy "vector" vec)) - (let-values (((start end) - (check-indices vec arg 'vector-reverse-copy))) - (let ((new (make-vector (- end start)))) - (%vector-reverse-copy! new 0 vec start end) - new))) - - ;;; (VECTOR-APPEND ...) -> vector - ;;; Append VECTOR ... into a newly allocated vector and return that - ;;; new vector. - (define (vector-append . vectors) - (check-list-of-vecs vectors 'vector-append) - (vector-concatenate:aux vectors)) - - ;;; (VECTOR-CONCATENATE ) -> vector - ;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to - ;;; (apply vector-append VECTOR-LIST) - ;;; Actually, they're both implemented in terms of an internal routine. - (define (vector-concatenate vector-list) - (unless (and (list? vector-list) - (andmap vector? vector-list)) - (raise-type-error 'vector-concatenate "list of vectors" vector-list)) - (vector-concatenate:aux vector-list)) - - ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE - (define vector-concatenate:aux - (letrec ((compute-length - (lambda (vectors len) - (if (null? vectors) - len - (let ((vec (car vectors))) - (compute-length (cdr vectors) - (+ (vector-length vec) len)))))) - (concatenate! - (lambda (vectors target to) - (if (null? vectors) - target - (let* ((vec1 (car vectors)) - (len (vector-length vec1))) - (%vector-copy! target to vec1 0 len) - (concatenate! (cdr vectors) target - (+ to len))))))) - (lambda (vectors) - (let ((new-vector - (make-vector (compute-length vectors 0)))) - (concatenate! vectors new-vector 0) - new-vector))))) diff --git a/collects/srfi/43/conversion.ss b/collects/srfi/43/conversion.ss deleted file mode 100644 index cf756e08bc..0000000000 --- a/collects/srfi/43/conversion.ss +++ /dev/null @@ -1,98 +0,0 @@ -;;; -;;; ---- Vector conversion -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005-2006 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module conversion mzscheme - - (require "util.ss") - - (provide (rename my-vector->list vector->list) - reverse-vector->list - reverse-list->vector) - - ;;; (VECTOR->LIST [ ]) -> list - ;;; [R5RS+] Produce a list containing the elements in the locations - ;;; between START, whose default is 0, and END, whose default is the - ;;; length of VECTOR, from VECTOR. - (define (my-vector->list vec . maybe-start+end) - (unless (vector? vec) - (apply raise-type-error - 'vector->list "vector" 0 - vec maybe-start+end)) - (if (null? maybe-start+end) - (vector->list vec) ;+++ - (let-values (((start end) - (check-indices vec maybe-start+end 'vector->list))) - ;(unfold (lambda (i) ; No SRFI 1. - ; (< i start)) - ; (lambda (i) (vector-ref vec i)) - ; (lambda (i) (sub1 i)) - ; (sub1 end)) - (do ((i (sub1 end) (sub1 i)) - (result '() (cons (vector-ref vec i) result))) - ((< i start) result))))) - - ;;; (REVERSE-VECTOR->LIST [ ]) -> list - ;;; Produce a list containing the elements in the locations between - ;;; START, whose default is 0, and END, whose default is the length - ;;; of VECTOR, from VECTOR, in reverse order. - (define (reverse-vector->list vec . maybe-start+end) - (unless (vector? vec) - (apply raise-type-error - 'reverse-vector->list "vector" 0 - vec maybe-start+end)) - (let-values (((start end) - (check-indices vec maybe-start+end 'reverse-vector->list))) - ;(unfold (lambda (i) (= i end)) ; No SRFI 1. - ; (lambda (i) (vector-ref vec i)) - ; (lambda (i) (add1 i)) - ; start) - (do ((i start (add1 i)) - (result '() (cons (vector-ref vec i) result))) - ((= i end) result)))) - - ;;; (REVERSE-LIST->VECTOR -> vector - ;;; Produce a vector containing the elements in LIST in reverse order. - (define (reverse-list->vector lst) - (unless (list? lst) - (raise-type-error 'reverse-list->vector "proper list" lst)) - (let* ((len (length lst)) - (vec (make-vector len))) - (unfold1! (lambda (index l) (values (car l) (cdr l))) - vec - (sub1 len) - lst) - vec))) diff --git a/collects/srfi/43/iteration.ss b/collects/srfi/43/iteration.ss deleted file mode 100644 index fc854b8f95..0000000000 --- a/collects/srfi/43/iteration.ss +++ /dev/null @@ -1,278 +0,0 @@ -;;; -;;; ---- Vector iteration -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005-2006 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module iteration mzscheme - - (require "util.ss") - - (provide vector-fold - vector-fold-right - vector-map - vector-map! - vector-for-each - vector-count) - - ;;; (VECTOR-FOLD ...) -> knil - ;;; (KONS ...) -> knil' ; N vectors -> N+1 args - ;;; The fundamental vector iterator. KONS is iterated over each - ;;; index in all of the vectors in parallel, stopping at the end of - ;;; the shortest; KONS is applied to an argument list of (list I - ;;; STATE (vector-ref VEC I) ...), where STATE is the current state - ;;; value -- the state value begins with KNIL and becomes whatever - ;;; KONS returned at the respective iteration --, and I is the - ;;; current index in the iteration. The iteration is strictly left- - ;;; to-right. - ;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) - ;;; <=> - ;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) - (define (vector-fold kons knil vec . vectors) - (unless (procedure? kons) - (apply raise-type-error - 'vector-fold "procedure" 0 - kons knil vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-fold "vector" 2 - kons knil vec vectors)) - (if (null? vectors) - (%vector-fold1 kons knil (vector-length vec) vec) - (begin (check-list-of-vecs vectors 'vector-fold 3 - (list* kons knil vec vectors)) - (%vector-fold2+ kons knil - (%smallest-length vectors - (vector-length vec)) - (cons vec vectors))))) - - (define %vector-fold1 - (letrec ((loop (lambda (kons knil len vec i) - (if (= i len) - knil - (loop kons - (kons i knil (vector-ref vec i)) - len vec (add1 i)))))) - (lambda (kons knil len vec) - (loop kons knil len vec 0)))) - (define %vector-fold2+ - (letrec ((loop (lambda (kons knil len vectors i) - (if (= i len) - knil - (loop kons - (apply kons i knil - (vectors-ref vectors i)) - len vectors (add1 i)))))) - (lambda (kons knil len vectors) - (loop kons knil len vectors 0)))) - - ;;; (VECTOR-COUNT ...) - ;;; -> exact, nonnegative integer - ;;; (PREDICATE? ...) ; N vectors -> N+1 args - ;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., - ;;; and a count is tallied of the number of elements for which a - ;;; true value is produced by PREDICATE?. This count is returned. - (define (vector-count pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-count "procedure" 0 - pred? vec vectors)) - (if (null? vectors) - (%vector-fold1 (lambda (index count elt) - (if (pred? index elt) - (add1 count) - count)) - 0 - (vector-length vec) - vec) - (begin (check-list-of-vecs vectors 'vector-count 2 - (list* pred? vec vectors)) - (%vector-fold2+ (lambda (index count . elts) - (if (apply pred? index elts) - (add1 count) - count)) - 0 - (%smallest-length vectors - (vector-length vec)) - (cons vec vectors))))) - - ;;; (VECTOR-FOLD-RIGHT ...) -> knil - ;;; (KONS ...) -> knil' ; N vectors => N+1 args - ;;; The fundamental vector recursor. Iterates in parallel across - ;;; VECTOR ... right to left, applying KONS to the elements and the - ;;; current state value; the state value becomes what KONS returns - ;;; at each next iteration. KNIL is the initial state value. - ;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) - ;;; <=> - ;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1) - ;;; - ;;; Not implemented in terms of a more primitive operations that might - ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very - ;;; useful elsewhere. - (define vector-fold-right - (letrec ((loop1 (lambda (kons knil vec i) - (if (zero? i) - knil - (let ((j (sub1 i))) - (loop1 kons - (kons j knil (vector-ref vec j)) - vec - j))))) - (loop2+ (lambda (kons knil vectors i) - (if (zero? i) - knil - (let ((j (sub1 i))) - (loop2+ kons - (apply kons j knil - (vectors-ref vectors j)) - vectors - j)))))) - (lambda (kons knil vec . vectors) - (unless (procedure? kons) - (apply raise-type-error - 'vector-fold-right "procedure" 0 - kons knil vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-fold-right "vector" 2 - kons knil vec vectors)) - (if (null? vectors) - (loop1 kons knil vec (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-fold-right 3 - (list* kons knil vec vectors)) - (loop2+ kons knil (cons vec vectors) - (%smallest-length vectors - (vector-length vec)))))))) - - ;;; (VECTOR-MAP ...) -> vector - ;;; (F ...) -> value ; N vectors -> N args - ;;; Constructs a new vector of the shortest length of the vector - ;;; arguments. Each element at index I of the new vector is mapped - ;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The - ;;; dynamic order of application of F is unspecified. - (define (vector-map f vec . vectors) - (unless (procedure? f) - (apply raise-type-error - 'vector-map "procedure" 0 - f vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-map "vector" 1 - f vec vectors)) - (if (null? vectors) - (let ((len (vector-length vec))) - (%vector-map1! f (make-vector len) vec len)) - (begin (check-list-of-vecs vectors 'vector-map 2 - (list* f vec vectors)) - (let ((len (%smallest-length vectors - (vector-length vec)))) - (%vector-map2+! f (make-vector len) - (cons vec vectors) len))))) - - ;;; (%VECTOR-MAP1! ) - ;;; (F ) -> elt' - (define (%vector-map1! f target vec i) - (if (zero? i) - target - (let ((j (sub1 i))) - (vector-set! target j - (f j (vector-ref vec j))) - (%vector-map1! f target vec j)))) - (define (%vector-map2+! f target vectors i) - (if (zero? i) - target - (let ((j (sub1 i))) - (vector-set! target j - (apply f j (vectors-ref vectors j))) - (%vector-map2+! f target vectors j)))) - - ;;; (VECTOR-MAP! ...) -> vector - ;;; (F ...) -> element' ; N vectors -> N args - ;;; Similar to VECTOR-MAP, but rather than mapping the new elements - ;;; into a new vector, the new mapped elements are destructively - ;;; inserted into the first vector. Again, the dynamic order of - ;;; application of F is unspecified, so it is dangerous for F to - ;;; manipulate the first VECTOR. - (define (vector-map! f vec . vectors) - (unless (procedure? f) - (apply raise-type-error - 'vector-map! "procedure" 0 - f vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-map! "vector" 1 - f vec vectors)) - (if (null? vectors) - (%vector-map1! f vec vec (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-map! 2 - (list* f vec vectors)) - (%vector-map2+! f vec (cons vec vectors) - (%smallest-length vectors - (vector-length vec)))))) - - ;;; (VECTOR-FOR-EACH ...) -> void - ;;; (F ...) ; N vectors -> N args - ;;; Simple vector iterator: applies F to each index in the range [0, - ;;; LENGTH), where LENGTH is the length of the smallest vector - ;;; argument passed, and the respective element at that index. In - ;;; contrast with VECTOR-MAP, F is reliably applied to each - ;;; subsequent elements, starting at index 0 from left to right, in - ;;; the vectors. - (define vector-for-each - (letrec ((for-each1 - (lambda (f vec i len) - (when (< i len) - (f i (vector-ref vec i)) - (for-each1 f vec (add1 i) len)))) - (for-each2+ - (lambda (f vecs i len) - (when (< i len) - (apply f i (vectors-ref vecs i)) - (for-each2+ f vecs (add1 i) len))))) - (lambda (f vec . vectors) - (unless (procedure? f) - (apply raise-type-error - 'vector-for-each "procedure" 0 - f vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-for-each "vector" 1 - f vec vectors)) - (if (null? vectors) - (for-each1 f vec 0 (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-for-each 2 - (list* f vec vectors)) - (for-each2+ f (cons vec vectors) 0 - (%smallest-length vectors - (vector-length vec))))))))) diff --git a/collects/srfi/43/mutators.ss b/collects/srfi/43/mutators.ss deleted file mode 100644 index 2dcc88df03..0000000000 --- a/collects/srfi/43/mutators.ss +++ /dev/null @@ -1,159 +0,0 @@ -;;; -;;; ---- Vector mutators -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005-2006 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module mutators mzscheme - - (require "util.ss") - - (provide vector-swap! - (rename my-vector-fill! vector-fill!) - vector-reverse! - vector-copy! - vector-reverse-copy!) - - ;;; (VECTOR-SWAP! ) -> void - ;;; Swap the values in the locations at INDEX1 and INDEX2. - (define (vector-swap! vec i j) - (unless (vector? vec) - (raise-type-error 'vector-swap! "vector" 0 - vec i j)) - (check-index vec i 'vector-swap!) - (check-index vec j 'vector-swap!) - (%vector-swap! vec i j)) - - (define (%vector-swap! vec i j) - (let ((x (vector-ref vec i))) - (vector-set! vec i (vector-ref vec j)) - (vector-set! vec j x))) - - ;;; (VECTOR-FILL! [ ]) -> - ;;; [R5RS+] Fill the locations in VECTOR between START, whose default - ;;; is 0, and END, whose default is the length of VECTOR, with VALUE. - ;;; - ;;; This one can probably be made really fast natively. - (define (my-vector-fill! vec value . maybe-start+end) - (cond ((null? maybe-start+end) - (vector-fill! vec value)) ;+++ - ((not (vector? vec)) - (apply raise-type-error - 'vector-fill! "vector" 0 - vec value maybe-start+end)) - (else - (let-values (((start end) - (check-indices vec maybe-start+end 'vector-fill!))) - (do ((i start (add1 i))) - ((= i end)) - (vector-set! vec i value)) - vec)))) - - (define %vector-reverse! - (letrec ((loop (lambda (vec i j) - (when (< i j) - (%vector-swap! vec i j) - (loop vec (add1 i) (sub1 j)))))) - (lambda (vec start end) - (loop vec start (sub1 end))))) - - ;;; (VECTOR-REVERSE! [ ]) -> void - ;;; Destructively reverse the contents of the sequence of locations - ;;; in VECTOR between START, whose default is 0, and END, whose - ;;; default is the length of VECTOR. - (define (vector-reverse! vec . maybe-start+end) - (unless (vector? vec) - (apply raise-type-error - 'vector-reverse! "vector" 0 - vec maybe-start+end)) - (let-values (((start end) - (check-indices vec maybe-start+end 'vector-reverse!))) - (%vector-reverse! vec start end))) - - ;;; (VECTOR-COPY! [ ]) - ;;; -> unspecified - ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to - ;;; to TARGET, starting at TSTART in TARGET. - (define (vector-copy! target tstart source . maybe-sstart+send) - (unless (vector? target) - (apply raise-type-error - 'vector-copy! "vector" 0 - target tstart source maybe-sstart+send)) - (check-index target tstart 'vector-copy!) - (unless (vector? source) - (apply raise-type-error - 'vector-copy! "vector" 2 - target tstart source maybe-sstart+send)) - (let-values (((sstart send) - (check-indices source maybe-sstart+send 'vector-copy!))) - (if (< (- (vector-length target) tstart) - (- send sstart)) - (error 'vector-copy! - "target vector not long enough to copy")) - (%vector-copy! target tstart source sstart send))) - - ;;; (VECTOR-REVERSE-COPY! [ ]) - (define (vector-reverse-copy! target tstart source . maybe-sstart+send) - (unless (vector? target) - (apply raise-type-error - 'vector-reverse-copy! "vector" 0 - target tstart source maybe-sstart+send)) - (check-index target tstart 'vector-reverse-copy!) - (unless (vector? source) - (apply raise-type-error - 'vector-reverse-copy! "vector" 2 - target tstart source maybe-sstart+send)) - (let-values (((sstart send) - (check-indices source maybe-sstart+send 'vector-reverse-copy!))) - (cond ((< (- (vector-length target) tstart) - (- send sstart)) - (error 'vector-reverse-copy! - "target vector not long enough to copy")) - ((and (eq? target source) - (= sstart tstart)) - (%vector-reverse! target tstart send)) - ((and (eq? target source) - (or (between? sstart tstart send) - (between? tstart sstart - (+ tstart (- send sstart))))) - ;an error in the reference implement here - (error 'vector-reverse-copy! - "Vector range for self-copying overlaps")) - (else - (%vector-reverse-copy! target tstart - source sstart send))))) - - (define (between? x y z) - (and (< x y) - (<= y z)))) diff --git a/collects/srfi/43/predicates.ss b/collects/srfi/43/predicates.ss deleted file mode 100644 index 60325196da..0000000000 --- a/collects/srfi/43/predicates.ss +++ /dev/null @@ -1,103 +0,0 @@ -;;; -;;; ---- Vector predicates -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005-2006 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module predicates mzscheme - - (require "util.ss") - - (provide vector-empty? - vector=) - - ;;; (VECTOR-EMPTY? ) -> boolean - ;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length - ;;; is 0, and #F if not. - (define (vector-empty? vec) - (unless (vector? vec) - (raise-type-error 'vector-empty? "vector" vec)) - (zero? (vector-length vec))) - - ;;; (VECTOR= ...) -> boolean - ;;; (ELT=? ) -> boolean - ;;; Determine vector equality generalized across element comparators. - ;;; Vectors A and B are equal iff their lengths are the same and for - ;;; each respective elements E_a and E_b (element=? E_a E_b) returns - ;;; a true value. ELT=? is always applied to two arguments. Element - ;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b) - ;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a - ;;; true value. This may be exploited to avoid multiple unnecessary - ;;; element comparisons. (This implementation does, but does not deal - ;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary - ;;; comparisons, but I believe this optimization is probably fairly - ;;; insignificant.) - ;;; - ;;; If the number of vector arguments is zero or one, then #T is - ;;; automatically returned. If there are N vector arguments, - ;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are - ;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N - ;;; are compared. The precise order in which ELT=? is applied is not - ;;; specified. - (define (vector= elt=? . vectors) - (unless (procedure-arity-includes? elt=? 2) - (apply raise-type-error - 'vector= "procedure of arity 2" 0 - elt=? vectors)) - (cond ((null? vectors) - #t) - ((null? (cdr vectors)) - (unless (vector? (car vectors)) - (apply raise-type-error - 'vector= "vector" 1 - elt=? vectors)) - #t) - (else - (check-list-of-vecs vectors 'vector= - 1 (cons elt=? vectors)) - (let loop ((vecs vectors)) - (let ((vec1 (car vecs)) - (vec2+ (cdr vecs))) - (or (null? vec2+) - (and (binary-vector= elt=? vec1 (car vec2+)) - (loop vec2+)))))))) - (define (binary-vector= elt=? vector-a vector-b) - (or (eq? vector-a vector-b) ;+++ - (let ((length-a (vector-length vector-a))) - (and (= length-a (vector-length vector-b)) - (let loop ((i 0)) - (or (= i length-a) - (and (elt=? (vector-ref vector-a i) - (vector-ref vector-b i)) - (loop (add1 i)))))))))) diff --git a/collects/srfi/43/searching.ss b/collects/srfi/43/searching.ss deleted file mode 100644 index a48a51b8c9..0000000000 --- a/collects/srfi/43/searching.ss +++ /dev/null @@ -1,298 +0,0 @@ -;;; -;;; ---- Vector searching -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005-2006 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module searching mzscheme - - (require "util.ss") - - (provide vector-index - vector-index-right - vector-skip - vector-skip-right - vector-binary-search - vector-any - vector-every) - - ;; All the functions (except vector-binary-search) here can be - ;; abstracted, but for performance I didn't do so. - - ;;; (VECTOR-INDEX ...) - ;;; -> exact, nonnegative integer or #F - ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args - ;;; Search left-to-right across VECTOR ... in parallel, returning the - ;;; index of the first set of values VALUE ... such that (PREDICATE? - ;;; VALUE ...) returns a true value; if no such set of elements is - ;;; reached, return #F. - (define vector-index - (letrec ((loop1 (lambda (pred? vec len i) - (cond ((= i len) #f) - ((pred? (vector-ref vec i)) i) - (else (loop1 pred? vec len (add1 i)))))) - (loop2+ (lambda (pred? vectors len i) - (cond ((= i len) #f) - ((apply pred? (vectors-ref vectors i)) i) - (else (loop2+ pred? vectors len (add1 i))))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-index "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-index "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec (vector-length vec) 0) - (begin (check-list-of-vecs vectors 'vector-index 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - (%smallest-length vectors - (vector-length vec)) - 0)))))) - - ;;; (VECTOR-SKIP ...) - ;;; -> exact, nonnegative integer or #F - ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args - ;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) - ;;; VECTOR ...) - ;;; Like VECTOR-INDEX, but find the index of the first set of values - ;;; that do _not_ satisfy PREDICATE?. - (define vector-skip - (letrec ((loop1 (lambda (pred? vec len i) - (cond ((= i len) #f) - ((pred? (vector-ref vec i)) - (loop1 pred? vec len (add1 i))) - (else i)))) - (loop2+ (lambda (pred? vectors len i) - (cond ((= i len) #f) - ((apply pred? (vectors-ref vectors i)) - (loop2+ pred? vectors len (add1 i))) - (else i))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-skip "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-skip "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec (vector-length vec) 0) - (begin (check-list-of-vecs vectors 'vector-skip 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - (%smallest-length vectors - (vector-length vec)) - 0)))))) - - ;;; (VECTOR-INDEX-RIGHT ...) - ;;; -> exact, nonnegative integer or #F - ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args - ;;; Right-to-left variant of VECTOR-INDEX. - (define vector-index-right - (letrec ((loop1 (lambda (pred? vec i) - (if (zero? i) - #f - (let ((i (sub1 i))) - (if (pred? (vector-ref vec i)) - i - (loop1 pred? vec i)))))) - (loop2+ (lambda (pred? vectors i) - (if (zero? i) - #f - (let ((i (sub1 i))) - (if (apply pred? (vectors-ref vectors i)) - i - (loop2+ pred? vectors i))))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-index-right "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-index-right "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-index-right 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - (%smallest-length vectors - (vector-length vec)))))))) - - ;;; (VECTOR-SKIP-RIGHT ...) - ;;; -> exact, nonnegative integer or #F - ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args - ;;; Right-to-left variant of VECTOR-SKIP. - (define vector-skip-right - (letrec ((loop1 (lambda (pred? vec i) - (if (zero? i) - #f - (let ((i (sub1 i))) - (if (pred? (vector-ref vec i)) - (loop1 pred? vec i) - i))))) - (loop2+ (lambda (pred? vectors i) - (if (zero? i) - #f - (let ((i (sub1 i))) - (if (apply pred? (vectors-ref vectors i)) - (loop2+ pred? vectors i) - i)))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-skip-right "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-skip-right "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-skip-right 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - (%smallest-length vectors - (vector-length vec)))))))) - - ;;; (VECTOR-BINARY-SEARCH ) - ;;; -> exact, nonnegative integer or #F - ;;; (CMP ) -> integer - ;;; positive -> VALUE1 > VALUE2 - ;;; zero -> VALUE1 = VALUE2 - ;;; negative -> VALUE1 < VALUE2 - ;;; Perform a binary search through VECTOR for VALUE, comparing each - ;;; element to VALUE with CMP. - (define (vector-binary-search vec value cmp) - (unless (vector? vec) - (raise-type-error 'vector-binary-search "vector" 0 - vec value cmp)) - (unless (procedure-arity-includes? cmp 2) - (raise-type-error 'vector-binary-search "procedure of arity 2" 2 - vec value cmp)) - (let loop ((start 0) - (end (vector-length vec)) - (j -1)) - (let ((i (quotient (+ start end) 2))) - (if (= i j) - #f - (let ((comparison (cmp (vector-ref vec i) value))) - (unless (integer? comparison) - (raise-type-error 'vector-binary-search - "procedure that returns an integer" - 2 - vec value cmp)) - (cond ((zero? comparison) i) - ((positive? comparison) (loop start i i)) - (else (loop i end i)))))))) - - ;;; (VECTOR-ANY ...) -> value - ;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? - ;;; should ever return a true value, immediately stop and return that - ;;; value; otherwise, when the shortest vector runs out, return #F. - ;;; The iteration and order of application of PRED? across elements - ;;; is of the vectors is strictly left-to-right. - (define vector-any - (letrec ((loop1 (lambda (pred? vec i len) - (and (not (= i len)) - (or (pred? (vector-ref vec i)) - (loop1 pred? vec (add1 i) len))))) - (loop2+ (lambda (pred? vectors i len) - (and (not (= i len)) - (or (apply pred? (vectors-ref vectors i)) - (loop2+ pred? vectors (add1 i) len)))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-any "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-any "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec 0 (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-any 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - 0 (%smallest-length vectors - (vector-length vec)))))))) - - ;;; (VECTOR-EVERY ...) -> value - ;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? - ;;; should ever return #F, immediately stop and return #F; otherwise, - ;;; if PRED? should return a true value for each element, stopping at - ;;; the end of the shortest vector, return the last value that PRED? - ;;; returned. In the case that there is an empty vector, return #T. - ;;; The iteration and order of application of PRED? across elements - ;;; is of the vectors is strictly left-to-right. - (define vector-every - (letrec ((loop1 (lambda (pred? vec i len) - (or (> i len) - (if (= i len) - (pred? (vector-ref vec i)) - (and (pred? (vector-ref vec i)) - (loop1 pred? vec (add1 i) len)))))) - (loop2+ (lambda (pred? vectors i len) - (or (> i len) - (if (= i len) - (apply pred? (vectors-ref vectors i)) - (and (apply pred? (vectors-ref vectors i)) - (loop2+ pred? vectors (add1 i) len))))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-every "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-every "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec 0 (sub1 (vector-length vec))) - (begin (check-list-of-vecs vectors 'vector-every 2 - (list* pred? vec vectors)) - (loop2+ pred? - (cons vec vectors) - 0 - (sub1 - (%smallest-length vectors - (vector-length vec)))))))))) - diff --git a/collects/srfi/43/util.ss b/collects/srfi/43/util.ss deleted file mode 100644 index b9000af8ab..0000000000 --- a/collects/srfi/43/util.ss +++ /dev/null @@ -1,163 +0,0 @@ -;;; -;;; ---- Utility functions -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005-2006 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module util mzscheme - - (require (lib "etc.ss" "mzlib") - (lib "receive.ss" "srfi" "8")) - - (provide (all-defined)) - - ;;; (CHECK-INDEX ) -> - ;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an - ;;; error stating that it is not and that this happened in a call to - ;;; CALLEE. (Note that this does NOT check that VECTOR is indeed a - ;;; vector.) - (define (check-index vec index callee) - (unless (nonneg-int? index) - (raise-type-error callee "non-negative exact integer" index)) - (unless (and (<= 0 index) - (< index (vector-length vec))) - (raise - (make-exn:fail:contract - (format "~a: index ~a out of range for vector: ~a" - callee index vec) - (current-continuation-marks))))) - - (define (check-indices vec maybe-start+end callee) - (if (null? maybe-start+end) - (values 0 (vector-length vec)) - (let ((start (car maybe-start+end))) - (unless (nonneg-int? start) - (raise-type-error callee "non-negative exact integer" start)) - (unless (<= 0 start (vector-length vec)) - (raise - (make-exn:fail:contract - (format "~a: index ~a out of range for vector: ~a" - callee start vec) - (current-continuation-marks)))) - (if (null? (cdr maybe-start+end)) - (values start (vector-length vec)) - (let ((end (cadr maybe-start+end))) - (unless (nonneg-int? end) - (raise-type-error callee "non-negative exact integer" end)) - (unless (<= start end (vector-length vec)) - (raise - (make-exn:fail:contract - (format "~a: indices (~a, ~a) out of range for vector: ~a" - callee start end vec)))) - (values start end)))))) - - (define (nonneg-int? x) - (and (integer? x) - (exact? x) - (not (negative? x)))) - - ;;; (%VECTOR-COPY! ) - ;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET, - ;;; starting at TSTART in TARGET. - (define %vector-copy! - (letrec ((loop/l->r (lambda (target source send i j) - (cond ((< i send) - (vector-set! target j - (vector-ref source i)) - (loop/l->r target source send - (add1 i) (add1 j)))))) - (loop/r->l (lambda (target source sstart i j) - (cond ((>= i sstart) - (vector-set! target j - (vector-ref source i)) - (loop/r->l target source sstart - (sub1 i) (sub1 j))))))) - (lambda (target tstart source sstart send) - (if (> sstart tstart) ; Make sure we don't copy over - ; ourselves. - (loop/l->r target source send sstart tstart) - (loop/r->l target source sstart (sub1 send) - (+ -1 tstart send (- sstart))))))) - - ;;; (%VECTOR-REVERSE-COPY! ) - ;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the - ;;; reverse order. - (define %vector-reverse-copy! - (letrec ((loop (lambda (target source sstart i j) - (cond ((>= i sstart) - (vector-set! target j (vector-ref source i)) - (loop target source sstart - (sub1 i) - (add1 j))))))) - (lambda (target tstart source sstart send) - (loop target source sstart - (sub1 send) - tstart)))) - - ;; type-check : check whether list-of-vecs is list of VECTORs - (define check-list-of-vecs - (opt-lambda (list-of-vecs caller (n 0) (all-args list-of-vecs)) - (let loop ((l list-of-vecs) - (i 0)) - (unless (null? l) - (if (vector? (car l)) - (loop (cdr l) (add1 i)) - (apply raise-type-error - caller "vector" - (+ n i) - all-args)))))) - - ;;; (%SMALLEST-LENGTH ) - ;;; -> exact, nonnegative integer - ;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is - ;;; the length that is returned if VECTOR-LIST is empty. Common use - ;;; of this is in n-ary vector routines: - ;;; (define (f vec . vectors) - (define (%smallest-length vector-list length) - (if (null? vector-list) - length - (%smallest-length (cdr vector-list) - (min length - (vector-length (car vector-list)))))) - - (define (vectors-ref vectors i) - (map (lambda (v) (vector-ref v i)) vectors)) - - ;;; from vector-unfold-right - (define (unfold1! f vec i seed) - (if (>= i 0) - (receive (elt new-seed) - (f i seed) - (vector-set! vec i elt) - (unfold1! f vec (sub1 i) new-seed))))) diff --git a/collects/srfi/43/vector-lib.ss b/collects/srfi/43/vector-lib.ss index a6802384b6..a63a3ba17e 100644 --- a/collects/srfi/43/vector-lib.ss +++ b/collects/srfi/43/vector-lib.ss @@ -1,43 +1,846 @@ -;;; -;;; ---- Utility functions -;;; Time-stamp: <05/03/07 18:21:41 Zhu Chongkai> -;;; -;;; Copyright (C) 2005-2006 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; +;;; Copyright (C) 2005-2007 by Chongkai Zhu. (module vector-lib mzscheme + + (require (lib "receive.ss" "srfi" "8") + (lib "etc.ss" "mzlib") + (lib "contract.ss")) + + (define (nonneg-int? x) + (and (integer? x) + (exact? x) + (not (negative? x)))) + + (define mutable-vector/c + (and/c vector? (not/c immutable?))) + + (define (vec-start-end-contract vector?) + (case-> + (-> vector? any) + (->r ((vec vector?) + (start (and/c nonneg-int? + (<=/c (vector-length vec))))) + any) + (->pp ((vec vector?) + (start nonneg-int?) + (end nonneg-int?)) + (<= start end (vector-length vec)) + any))) + + ;;; (%SMALLEST-LENGTH ) + ;;; -> exact, nonnegative integer + ;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is + ;;; the length that is returned if VECTOR-LIST is empty. Common use + ;;; of this is in n-ary vector routines: + ;;; (define (f vec . vectors) + (define (%smallest-length vector-list length) + (if (null? vector-list) + length + (%smallest-length (cdr vector-list) + (min length + (vector-length (car vector-list)))))) + + (define (vectors-ref vectors i) + (map (lambda (v) (vector-ref v i)) vectors)) + + ;;; from vector-unfold-right + (define (unfold1! f vec i seed) + (if (>= i 0) + (receive (elt new-seed) + (f i seed) + (vector-set! vec i elt) + (unfold1! f vec (sub1 i) new-seed)))) - (require "constructors.ss" - "predicates.ss" - "iteration.ss" - "searching.ss" - (all-except "mutators.ss" vector-fill!) - (rename "mutators.ss" s:vector-fill! vector-fill!) - (all-except "conversion.ss" vector->list) - (rename "conversion.ss" s:vector->list vector->list)) - - (provide - (all-from "constructors.ss") - (all-from "predicates.ss") - (all-from "iteration.ss") - (all-from "searching.ss") - (all-from "mutators.ss") - (all-from "conversion.ss"))) + (define unfold-contract + (->r ((f (lambda (f) + (and (procedure? f) + (procedure-arity-includes? f (add1 (length seeds)))))) + (len nonneg-int?)) + seeds list? + any)) + + (define copy-contract + (case-> + (-> vector? any) + (->r ((vec vector?) + (start (and/c nonneg-int? + (<=/c (vector-length vec))))) + any) + (->r ((vec vector?) + (start (and/c nonneg-int? + (<=/c (vector-length vec)))) + (end (and/c nonneg-int? + (>=/c start)))) + any) + (->r ((vec vector?) + (start (and/c nonneg-int? + (<=/c (vector-length vec)))) + (end (and/c nonneg-int? + (>=/c start))) + (fill any/c)) + any))) + + (provide/contract (vector-unfold unfold-contract) + (vector-unfold-right unfold-contract) + (vector-copy copy-contract) + (vector-reverse-copy (vec-start-end-contract vector?)) + (vector-append (->* () (listof vector?) any)) + (vector-concatenate (-> (listof vector?) any))) + + ;;; (VECTOR-UNFOLD ...) -> vector + ;;; (F ...) -> [elt seed' ...] + ;;; The fundamental vector constructor. Creates a vector whose + ;;; length is LENGTH and iterates across each index K between 0 and + ;;; LENGTH, applying F at each iteration to the current index and the + ;;; current seeds to receive N+1 values: first, the element to put in + ;;; the Kth slot and then N new seeds for the next iteration. + (define vector-unfold + (letrec ((tabulate! ; Special zero-seed case. + (lambda (f vec i len) + (cond ((< i len) + (vector-set! vec i (f i)) + (tabulate! f vec (add1 i) len))))) + (unfold1! ; Fast path for one seed. + (lambda (f vec i len seed) + (if (< i len) + (receive (elt new-seed) + (f i seed) + (vector-set! vec i elt) + (unfold1! f vec (add1 i) len new-seed))))) + (unfold2+! ; Slower variant for N seeds. + (lambda (f vec i len seeds) + (if (< i len) + (receive (elt . new-seeds) + (apply f i seeds) + (vector-set! vec i elt) + (unfold2+! f vec (add1 i) len new-seeds)))))) + (lambda (f len . initial-seeds) + (let ((vec (make-vector len))) + (cond ((null? initial-seeds) + (tabulate! f vec 0 len)) + ((null? (cdr initial-seeds)) + (unfold1! f vec 0 len (car initial-seeds))) + (else + (unfold2+! f vec 0 len initial-seeds))) + vec)))) + + ;;; (VECTOR-UNFOLD-RIGHT ...) -> vector + ;;; (F ...) -> [seed' ...] + ;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 + ;;; (still exclusive with LENGTH and inclusive with 0), not 0 to + ;;; LENGTH as with VECTOR-UNFOLD. + (define vector-unfold-right + (letrec ((tabulate! + (lambda (f vec i) + (cond ((>= i 0) + (vector-set! vec i (f i)) + (tabulate! f vec (sub1 i)))))) + (unfold2+! + (lambda (f vec i seeds) + (if (>= i 0) + (receive (elt . new-seeds) + (apply f i seeds) + (vector-set! vec i elt) + (unfold2+! f vec (sub1 i) new-seeds)))))) + (lambda (f len . initial-seeds) + (let ((vec (make-vector len)) + (i (sub1 len))) + (cond ((null? initial-seeds) + (tabulate! f vec i)) + ((null? (cdr initial-seeds)) + (unfold1! f vec i (car initial-seeds))) + (else + (unfold2+! f vec i initial-seeds))) + vec)))) + + ;;; (VECTOR-COPY [ ]) -> vector + ;;; Create a newly allocated vector containing the elements from the + ;;; range [START,END) in VECTOR. START defaults to 0; END defaults + ;;; to the length of VECTOR. END may be greater than the length of + ;;; VECTOR, in which case the vector is enlarged; if FILL is passed, + ;;; the new locations from which there is no respective element in + ;;; VECTOR are filled with FILL. + (define vector-copy + (opt-lambda (vec (start 0) (end (vector-length vec)) (fill 0)) + (let ((new-vector + (make-vector (- end start) fill))) + (vector-copy! new-vector 0 + vec start + (min end (vector-length vec))) + new-vector))) + + ;;; (VECTOR-REVERSE-COPY [ ]) -> vector + ;;; Create a newly allocated vector whose elements are the reversed + ;;; sequence of elements between START and END in VECTOR. START's + ;;; default is 0; END's default is the length of VECTOR. + (define vector-reverse-copy + (opt-lambda (vec (start 0) (end (vector-length vec))) + (let ((new (make-vector (- end start)))) + (vector-reverse-copy! new 0 vec start end) + new))) + + ;;; (VECTOR-APPEND ...) -> vector + ;;; Append VECTOR ... into a newly allocated vector and return that + ;;; new vector. + (define (vector-append . vectors) + (vector-concatenate vectors)) + + ;;; (VECTOR-CONCATENATE ) -> vector + ;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to + ;;; (apply vector-append VECTOR-LIST) + ;;; Actually, they're both implemented in terms of an internal routine. + (define vector-concatenate + (letrec ((compute-length + (lambda (vectors len) + (if (null? vectors) + len + (let ((vec (car vectors))) + (compute-length (cdr vectors) + (+ (vector-length vec) len)))))) + (concatenate! + (lambda (vectors target to) + (if (null? vectors) + target + (let* ((vec1 (car vectors)) + (len (vector-length vec1))) + (vector-copy! target to vec1 0 len) + (concatenate! (cdr vectors) target + (+ to len))))))) + (lambda (vectors) + (let ((new-vector + (make-vector (compute-length vectors 0)))) + (concatenate! vectors new-vector 0) + new-vector)))) + + (provide/contract (vector-empty? + (-> vector? any)) + (vector= + (->* ((-> any/c any/c any)) + (listof vector?) + any))) + + ;;; (VECTOR-EMPTY? ) -> boolean + ;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length + ;;; is 0, and #F if not. + (define (vector-empty? vec) + (zero? (vector-length vec))) + + ;;; (VECTOR= ...) -> boolean + ;;; (ELT=? ) -> boolean + ;;; Determine vector equality generalized across element comparators. + ;;; Vectors A and B are equal iff their lengths are the same and for + ;;; each respective elements E_a and E_b (element=? E_a E_b) returns + ;;; a true value. ELT=? is always applied to two arguments. Element + ;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b) + ;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a + ;;; true value. This may be exploited to avoid multiple unnecessary + ;;; element comparisons. (This implementation does, but does not deal + ;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary + ;;; comparisons, but I believe this optimization is probably fairly + ;;; insignificant.) + ;;; + ;;; If the number of vector arguments is zero or one, then #T is + ;;; automatically returned. If there are N vector arguments, + ;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are + ;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N + ;;; are compared. The precise order in which ELT=? is applied is not + ;;; specified. + (define (vector= elt=? . vectors) + (or (null? vectors) + (null? (cdr vectors)) + (let loop ((vecs vectors)) + (let ((vec1 (car vecs)) + (vec2+ (cdr vecs))) + (or (null? vec2+) + (and (binary-vector= elt=? vec1 (car vec2+)) + (loop vec2+))))))) + (define (binary-vector= elt=? vector-a vector-b) + (or (eq? vector-a vector-b) ;+++ + (let ((length-a (vector-length vector-a))) + (and (= length-a (vector-length vector-b)) + (let loop ((i 0)) + (or (= i length-a) + (and (elt=? (vector-ref vector-a i) + (vector-ref vector-b i)) + (loop (add1 i))))))))) + + (define fold-contract + (->r ((kons (lambda (f) + (and (procedure? f) + (procedure-arity-includes? f (+ 3 (length vec)))))) + (knil any/c) + (vec1 vector?)) + vec (listof vector?) + any)) + + (define (map-contract m) + (->r ((f (lambda (f) + (and (procedure? f) + (procedure-arity-includes? f (+ 2 (length vec)))))) + (vec1 m)) + vec (listof vector?) + any)) + + (provide/contract (vector-fold fold-contract) + (vector-fold-right fold-contract) + (vector-map (map-contract vector?)) + (vector-map! (map-contract mutable-vector/c)) + (vector-for-each (map-contract vector?)) + (vector-count (map-contract vector?))) + + ;;; (VECTOR-FOLD ...) -> knil + ;;; (KONS ...) -> knil' ; N vectors -> N+1 args + ;;; The fundamental vector iterator. KONS is iterated over each + ;;; index in all of the vectors in parallel, stopping at the end of + ;;; the shortest; KONS is applied to an argument list of (list I + ;;; STATE (vector-ref VEC I) ...), where STATE is the current state + ;;; value -- the state value begins with KNIL and becomes whatever + ;;; KONS returned at the respective iteration --, and I is the + ;;; current index in the iteration. The iteration is strictly left- + ;;; to-right. + ;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) + ;;; <=> + ;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) + (define (vector-fold kons knil vec . vectors) + (if (null? vectors) + (%vector-fold1 kons knil (vector-length vec) vec) + (%vector-fold2+ kons knil + (%smallest-length vectors + (vector-length vec)) + (cons vec vectors)))) + + (define %vector-fold1 + (letrec ((loop (lambda (kons knil len vec i) + (if (= i len) + knil + (loop kons + (kons i knil (vector-ref vec i)) + len vec (add1 i)))))) + (lambda (kons knil len vec) + (loop kons knil len vec 0)))) + (define %vector-fold2+ + (letrec ((loop (lambda (kons knil len vectors i) + (if (= i len) + knil + (loop kons + (apply kons i knil + (vectors-ref vectors i)) + len vectors (add1 i)))))) + (lambda (kons knil len vectors) + (loop kons knil len vectors 0)))) + + ;;; (VECTOR-COUNT ...) + ;;; -> exact, nonnegative integer + ;;; (PREDICATE? ...) ; N vectors -> N+1 args + ;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., + ;;; and a count is tallied of the number of elements for which a + ;;; true value is produced by PREDICATE?. This count is returned. + (define (vector-count pred? vec . vectors) + (if (null? vectors) + (%vector-fold1 (lambda (index count elt) + (if (pred? index elt) + (add1 count) + count)) + 0 + (vector-length vec) + vec) + (%vector-fold2+ (lambda (index count . elts) + (if (apply pred? index elts) + (add1 count) + count)) + 0 + (%smallest-length vectors + (vector-length vec)) + (cons vec vectors)))) + + ;;; (VECTOR-FOLD-RIGHT ...) -> knil + ;;; (KONS ...) -> knil' ; N vectors => N+1 args + ;;; The fundamental vector recursor. Iterates in parallel across + ;;; VECTOR ... right to left, applying KONS to the elements and the + ;;; current state value; the state value becomes what KONS returns + ;;; at each next iteration. KNIL is the initial state value. + ;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) + ;;; <=> + ;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1) + ;;; + ;;; Not implemented in terms of a more primitive operations that might + ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very + ;;; useful elsewhere. + (define vector-fold-right + (letrec ((loop1 (lambda (kons knil vec i) + (if (zero? i) + knil + (let ((j (sub1 i))) + (loop1 kons + (kons j knil (vector-ref vec j)) + vec + j))))) + (loop2+ (lambda (kons knil vectors i) + (if (zero? i) + knil + (let ((j (sub1 i))) + (loop2+ kons + (apply kons j knil + (vectors-ref vectors j)) + vectors + j)))))) + (lambda (kons knil vec . vectors) + (if (null? vectors) + (loop1 kons knil vec (vector-length vec)) + (loop2+ kons knil (cons vec vectors) + (%smallest-length vectors + (vector-length vec))))))) + + ;;; (VECTOR-MAP ...) -> vector + ;;; (F ...) -> value ; N vectors -> N args + ;;; Constructs a new vector of the shortest length of the vector + ;;; arguments. Each element at index I of the new vector is mapped + ;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The + ;;; dynamic order of application of F is unspecified. + (define (vector-map f vec . vectors) + (if (null? vectors) + (let ((len (vector-length vec))) + (%vector-map1! f (make-vector len) vec len)) + (let ((len (%smallest-length vectors + (vector-length vec)))) + (%vector-map2+! f (make-vector len) + (cons vec vectors) len)))) + + ;;; (%VECTOR-MAP1! ) + ;;; (F ) -> elt' + (define (%vector-map1! f target vec i) + (if (zero? i) + target + (let ((j (sub1 i))) + (vector-set! target j + (f j (vector-ref vec j))) + (%vector-map1! f target vec j)))) + (define (%vector-map2+! f target vectors i) + (if (zero? i) + target + (let ((j (sub1 i))) + (vector-set! target j + (apply f j (vectors-ref vectors j))) + (%vector-map2+! f target vectors j)))) + + ;;; (VECTOR-MAP! ...) -> vector + ;;; (F ...) -> element' ; N vectors -> N args + ;;; Similar to VECTOR-MAP, but rather than mapping the new elements + ;;; into a new vector, the new mapped elements are destructively + ;;; inserted into the first vector. Again, the dynamic order of + ;;; application of F is unspecified, so it is dangerous for F to + ;;; manipulate the first VECTOR. + (define (vector-map! f vec . vectors) + (if (null? vectors) + (%vector-map1! f vec vec (vector-length vec)) + (%vector-map2+! f vec (cons vec vectors) + (%smallest-length vectors + (vector-length vec))))) + + ;;; (VECTOR-FOR-EACH ...) -> void + ;;; (F ...) ; N vectors -> N args + ;;; Simple vector iterator: applies F to each index in the range [0, + ;;; LENGTH), where LENGTH is the length of the smallest vector + ;;; argument passed, and the respective element at that index. In + ;;; contrast with VECTOR-MAP, F is reliably applied to each + ;;; subsequent elements, starting at index 0 from left to right, in + ;;; the vectors. + (define vector-for-each + (letrec ((for-each1 + (lambda (f vec i len) + (when (< i len) + (f i (vector-ref vec i)) + (for-each1 f vec (add1 i) len)))) + (for-each2+ + (lambda (f vecs i len) + (when (< i len) + (apply f i (vectors-ref vecs i)) + (for-each2+ f vecs (add1 i) len))))) + (lambda (f vec . vectors) + (if (null? vectors) + (for-each1 f vec 0 (vector-length vec)) + (for-each2+ f (cons vec vectors) 0 + (%smallest-length vectors + (vector-length vec))))))) + + (define index-contract + (->r ((f (lambda (f) + (and (procedure? f) + (procedure-arity-includes? f (add1 (length vec)))))) + (vec1 vector?)) + vec (listof vector?) + any)) + + (provide/contract (vector-index index-contract) + (vector-index-right index-contract) + (vector-skip index-contract) + (vector-skip-right index-contract) + (vector-binary-search + (-> vector? any/c + (-> any/c any/c real?) + any)) + (vector-any index-contract) + (vector-every index-contract)) + + ;; All the functions (except vector-binary-search) here can be + ;; abstracted, but for performance I didn't do so. + + ;;; (VECTOR-INDEX ...) + ;;; -> exact, nonnegative integer or #F + ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args + ;;; Search left-to-right across VECTOR ... in parallel, returning the + ;;; index of the first set of values VALUE ... such that (PREDICATE? + ;;; VALUE ...) returns a true value; if no such set of elements is + ;;; reached, return #F. + (define vector-index + (letrec ((loop1 (lambda (pred? vec len i) + (cond ((= i len) #f) + ((pred? (vector-ref vec i)) i) + (else (loop1 pred? vec len (add1 i)))))) + (loop2+ (lambda (pred? vectors len i) + (cond ((= i len) #f) + ((apply pred? (vectors-ref vectors i)) i) + (else (loop2+ pred? vectors len (add1 i))))))) + (lambda (pred? vec . vectors) + (if (null? vectors) + (loop1 pred? vec (vector-length vec) 0) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec)) + 0))))) + + ;;; (VECTOR-SKIP ...) + ;;; -> exact, nonnegative integer or #F + ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args + ;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) + ;;; VECTOR ...) + ;;; Like VECTOR-INDEX, but find the index of the first set of values + ;;; that do _not_ satisfy PREDICATE?. + (define vector-skip + (letrec ((loop1 (lambda (pred? vec len i) + (cond ((= i len) #f) + ((pred? (vector-ref vec i)) + (loop1 pred? vec len (add1 i))) + (else i)))) + (loop2+ (lambda (pred? vectors len i) + (cond ((= i len) #f) + ((apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors len (add1 i))) + (else i))))) + (lambda (pred? vec . vectors) + (if (null? vectors) + (loop1 pred? vec (vector-length vec) 0) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec)) + 0))))) + + ;;; (VECTOR-INDEX-RIGHT ...) + ;;; -> exact, nonnegative integer or #F + ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args + ;;; Right-to-left variant of VECTOR-INDEX. + (define vector-index-right + (letrec ((loop1 (lambda (pred? vec i) + (if (zero? i) + #f + (let ((i (sub1 i))) + (if (pred? (vector-ref vec i)) + i + (loop1 pred? vec i)))))) + (loop2+ (lambda (pred? vectors i) + (if (zero? i) + #f + (let ((i (sub1 i))) + (if (apply pred? (vectors-ref vectors i)) + i + (loop2+ pred? vectors i))))))) + (lambda (pred? vec . vectors) + (if (null? vectors) + (loop1 pred? vec (vector-length vec)) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec))))))) + + ;;; (VECTOR-SKIP-RIGHT ...) + ;;; -> exact, nonnegative integer or #F + ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args + ;;; Right-to-left variant of VECTOR-SKIP. + (define vector-skip-right + (letrec ((loop1 (lambda (pred? vec i) + (if (zero? i) + #f + (let ((i (sub1 i))) + (if (pred? (vector-ref vec i)) + (loop1 pred? vec i) + i))))) + (loop2+ (lambda (pred? vectors i) + (if (zero? i) + #f + (let ((i (sub1 i))) + (if (apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors i) + i)))))) + (lambda (pred? vec . vectors) + (if (null? vectors) + (loop1 pred? vec (vector-length vec)) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec))))))) + + ;;; (VECTOR-BINARY-SEARCH ) + ;;; -> exact, nonnegative integer or #F + ;;; (CMP ) -> integer + ;;; positive -> VALUE1 > VALUE2 + ;;; zero -> VALUE1 = VALUE2 + ;;; negative -> VALUE1 < VALUE2 + ;;; Perform a binary search through VECTOR for VALUE, comparing each + ;;; element to VALUE with CMP. + (define (vector-binary-search vec value cmp) + (let loop ((start 0) + (end (vector-length vec)) + (j -1)) + (let ((i (quotient (+ start end) 2))) + (if (= i j) + #f + (let ((comparison (cmp (vector-ref vec i) value))) + (cond ((zero? comparison) i) + ((positive? comparison) (loop start i i)) + (else (loop i end i)))))))) + + ;;; (VECTOR-ANY ...) -> value + ;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? + ;;; should ever return a true value, immediately stop and return that + ;;; value; otherwise, when the shortest vector runs out, return #F. + ;;; The iteration and order of application of PRED? across elements + ;;; is of the vectors is strictly left-to-right. + (define vector-any + (letrec ((loop1 (lambda (pred? vec i len) + (and (not (= i len)) + (or (pred? (vector-ref vec i)) + (loop1 pred? vec (add1 i) len))))) + (loop2+ (lambda (pred? vectors i len) + (and (not (= i len)) + (or (apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors (add1 i) len)))))) + (lambda (pred? vec . vectors) + (if (null? vectors) + (loop1 pred? vec 0 (vector-length vec)) + (loop2+ pred? (cons vec vectors) + 0 (%smallest-length vectors + (vector-length vec))))))) + + ;;; (VECTOR-EVERY ...) -> value + ;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? + ;;; should ever return #F, immediately stop and return #F; otherwise, + ;;; if PRED? should return a true value for each element, stopping at + ;;; the end of the shortest vector, return the last value that PRED? + ;;; returned. In the case that there is an empty vector, return #T. + ;;; The iteration and order of application of PRED? across elements + ;;; is of the vectors is strictly left-to-right. + (define vector-every + (letrec ((loop1 (lambda (pred? vec i len) + (or (> i len) + (if (= i len) + (pred? (vector-ref vec i)) + (and (pred? (vector-ref vec i)) + (loop1 pred? vec (add1 i) len)))))) + (loop2+ (lambda (pred? vectors i len) + (or (> i len) + (if (= i len) + (apply pred? (vectors-ref vectors i)) + (and (apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors (add1 i) len))))))) + (lambda (pred? vec . vectors) + (if (null? vectors) + (loop1 pred? vec 0 (sub1 (vector-length vec))) + (loop2+ pred? + (cons vec vectors) + 0 + (sub1 + (%smallest-length vectors + (vector-length vec)))))))) + + (define copy!-contract + (case-> + (->r ((target mutable-vector/c) + (tstart (and/c nonneg-int? + (<=/c (- (vector-length target) + (vector-length source))))) + (source vector?)) + any) + (->r ((target mutable-vector/c) + (tstart (and/c nonneg-int? + (<=/c (- (vector-length target) + (- (vector-length source) + sstart))))) + (source vector?) + (sstart (and/c nonneg-int? + (<=/c (vector-length source))))) + any) + (->pp ((target mutable-vector/c) + (tstart (and/c nonneg-int? + (<=/c (- (vector-length target) + (- send sstart))))) + (source vector?) + (sstart nonneg-int?) + (send nonneg-int?)) + (<= sstart send (vector-length source)) + any))) + + (provide/contract (vector-swap! + (->r ((vec mutable-vector/c) + (i (and/c nonneg-int? + ( + (-> vector? any/c any) + (->r ((vec vector?) + (fill any/c) + (start (and/c nonneg-int? + (<=/c (vector-length vec))))) + any) + (->pp ((vec vector?) + (fill any/c) + (start nonneg-int?) + (end nonneg-int?)) + (<= start end (vector-length vec)) + any))) + (vector-reverse! (vec-start-end-contract mutable-vector/c)) + (vector-copy! copy!-contract) + (vector-reverse-copy! copy!-contract)) + + ;;; (VECTOR-SWAP! ) -> void + ;;; Swap the values in the locations at INDEX1 and INDEX2. + (define (vector-swap! vec i j) + (let ((x (vector-ref vec i))) + (vector-set! vec i (vector-ref vec j)) + (vector-set! vec j x))) + + ;;; (VECTOR-FILL! [ ]) -> + ;;; [R5RS+] Fill the locations in VECTOR between START, whose default + ;;; is 0, and END, whose default is the length of VECTOR, with VALUE. + ;;; + ;;; This one can probably be made really fast natively. + (define my-vector-fill! + (case-lambda + ((vec value) + (vector-fill! vec value)) + ((vec value start) + (my-vector-fill! vec value start (vector-length vec))) + ((vec value start end) + (do ((i start (add1 i))) + ((= i end)) + (vector-set! vec i value)) + vec))) + + ;;; (VECTOR-REVERSE! [ ]) -> void + ;;; Destructively reverse the contents of the sequence of locations + ;;; in VECTOR between START, whose default is 0, and END, whose + ;;; default is the length of VECTOR. + (define vector-reverse! + (letrec ((loop (lambda (vec i j) + (when (< i j) + (vector-swap! vec i j) + (loop vec (add1 i) (sub1 j)))))) + (opt-lambda (vec (start 0) (end (vector-length vec))) + (loop vec start (sub1 end))))) + + ;;; (VECTOR-COPY! [ ]) + ;;; -> unspecified + ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to + ;;; to TARGET, starting at TSTART in TARGET. + (define vector-copy! + (letrec ((loop/l->r (lambda (target source send i j) + (cond ((< i send) + (vector-set! target j + (vector-ref source i)) + (loop/l->r target source send + (add1 i) (add1 j)))))) + (loop/r->l (lambda (target source sstart i j) + (cond ((>= i sstart) + (vector-set! target j + (vector-ref source i)) + (loop/r->l target source sstart + (sub1 i) (sub1 j))))))) + (opt-lambda (target tstart source (sstart 0) (send (vector-length source))) + (if (> sstart tstart) ; Make sure we don't copy over + ; ourselves. + (loop/l->r target source send sstart tstart) + (loop/r->l target source sstart (sub1 send) + (+ -1 tstart send (- sstart))))))) + + ;;; (VECTOR-REVERSE-COPY! [ ]) + (define vector-reverse-copy! + (letrec ((loop (lambda (target source sstart i j) + (cond ((>= i sstart) + (vector-set! target j (vector-ref source i)) + (loop target source sstart + (sub1 i) + (add1 j))))))) + (opt-lambda (target tstart source (sstart 0) (send (vector-length source))) + (cond ((and (eq? target source) + (= sstart tstart)) + (vector-reverse! target tstart send)) + ((and (eq? target source) + (or (between? sstart tstart send) + (between? tstart sstart + (+ tstart (- send sstart))))) + ;an error in the reference implement here + (error 'vector-reverse-copy! + "Vector range for self-copying overlaps")) + (else + (loop target source sstart + (sub1 send) + tstart)))))) + + (define (between? x y z) + (and (< x y) + (<= y z))) + + (provide/contract (rename my-vector->list s:vector->list + (vec-start-end-contract vector?)) + (reverse-vector->list vec-start-end-contract) + (reverse-list->vector (-> list? any))) + + ;;; (VECTOR->LIST [ ]) -> list + ;;; [R5RS+] Produce a list containing the elements in the locations + ;;; between START, whose default is 0, and END, whose default is the + ;;; length of VECTOR, from VECTOR. + (define my-vector->list + (opt-lambda (vec (start 0) (end (vector-length vec))) + ;(unfold (lambda (i) ; No SRFI 1. + ; (< i start)) + ; (lambda (i) (vector-ref vec i)) + ; (lambda (i) (sub1 i)) + ; (sub1 end)) + (do ((i (sub1 end) (sub1 i)) + (result '() (cons (vector-ref vec i) result))) + ((< i start) result)))) + + ;;; (REVERSE-VECTOR->LIST [ ]) -> list + ;;; Produce a list containing the elements in the locations between + ;;; START, whose default is 0, and END, whose default is the length + ;;; of VECTOR, from VECTOR, in reverse order. + (define reverse-vector->list + (opt-lambda (vec (start 0) (end (vector-length vec))) + ;(unfold (lambda (i) (= i end)) ; No SRFI 1. + ; (lambda (i) (vector-ref vec i)) + ; (lambda (i) (add1 i)) + ; start) + (do ((i start (add1 i)) + (result '() (cons (vector-ref vec i) result))) + ((= i end) result)))) + + ;;; (REVERSE-LIST->VECTOR -> vector + ;;; Produce a vector containing the elements in LIST in reverse order. + (define (reverse-list->vector lst) + (let* ((len (length lst)) + (vec (make-vector len))) + (unfold1! (lambda (index l) (values (car l) (cdr l))) + vec + (sub1 len) + lst) + vec))) \ No newline at end of file diff --git a/collects/srfi/63/63.ss b/collects/srfi/63/63.ss index 7da2b5bc19..29a16b1635 100644 --- a/collects/srfi/63/63.ss +++ b/collects/srfi/63/63.ss @@ -1,7 +1,7 @@ ;; Implementation of SRFI 63 "Homogeneous and Heterogeneous Arrays" for PLT ;; Scheme. -;; Copyright (C) 2006 David Van Horn +;; Copyright (C) 2007 Chongkai Zhu ;; Released under the same terms as the SRFI reference implementation. @@ -9,201 +9,118 @@ ;; Copyright (C) 2001, 2003, 2005, 2006 Aubrey Jaffer (module |63| mzscheme - (require (lib "4.ss" "srfi") - (lib "9.ss" "srfi") - (lib "16.ss" "srfi") - (lib "contract.ss")) - (define-syntax enumerate - (syntax-rules () - ((enumerate name (const val) ...) - (define-syntax name - (syntax-rules (const ...) - ((name const) val) ...))))) + (require (lib "contract.ss")) - (enumerate a: - (vector 0) - (floc128b 1) (floc64b 2) (floc32b 3) (floc16b 4) - (flor128b 5) (flor64b 6) (flor32b 7) (flor16b 8) - (floq128d 9) (floq64d 10) (floq32d 11) - (fixz64b 12) (fixz32b 13) (fixz16b 14) (fixz8b 15) - (fixn64b 16) (fixn32b 17) (fixn16b 18) (fixn8b 19) - (bool 20) - (string 21)) - - ;; This implementation uses SRFI-4 vectors as the store for - ;; several of the homogeneous array types, but several types - ;; are implemented using plain vectors. To improve the - ;; implementation, simply update the appropriate entry in - ;; this table. - (define implementation-list - (let ((ls list-immutable)) - (ls (ls (a: vector) make-vector vector-ref vector-set!) - (ls (a: floc128b) make-vector vector-ref vector-set!) - (ls (a: floc64b) make-f64vector f64vector-ref f64vector-set!) - (ls (a: floc32b) make-f32vector f32vector-ref f32vector-set!) - (ls (a: floc16b) make-vector vector-ref vector-set!) - (ls (a: flor128b) make-vector vector-ref vector-set!) - (ls (a: flor64b) make-vector vector-ref vector-set!) - (ls (a: flor32b) make-vector vector-ref vector-set!) - (ls (a: flor16b) make-vector vector-ref vector-set!) - (ls (a: floq128d) make-vector vector-ref vector-set!) - (ls (a: floq64d) make-vector vector-ref vector-set!) - (ls (a: floq32d) make-vector vector-ref vector-set!) - (ls (a: fixz64b) make-s64vector s64vector-ref s64vector-set!) - (ls (a: fixz32b) make-s32vector s32vector-ref s32vector-set!) - (ls (a: fixz16b) make-s16vector s16vector-ref s16vector-set!) - (ls (a: fixz8b) make-s8vector s8vector-ref s8vector-set!) - (ls (a: fixn64b) make-u64vector u64vector-ref u64vector-set!) - (ls (a: fixn32b) make-u32vector u32vector-ref u32vector-set!) - (ls (a: fixn16b) make-u16vector u16vector-ref u16vector-set!) - (ls (a: fixn8b) make-u8vector u8vector-ref u8vector-set!) - (ls (a: bool) make-vector vector-ref vector-set!) - (ls (a: string) make-string string-ref string-set!)))) + (define-struct array:rtd + (dimensions + scales ;list of dimension scales + offset ;exact integer + store ;data + ) + #f) - ;; PLTisms: list-immutable, vector-immutable, sub1, add1, - ;; arithmetic-shift, contracts. - - (define-record-type :strict-array - (make-strict-array dimensions scales offset store store-type) - strict-array? - (dimensions strict-array-dimensions) - (scales strict-array-scales) - (offset strict-array-offset) - (store strict-array-store) - (store-type strict-array-store-type)) - - (define (array-dimensions array) + (define (array:dimensions array) (cond ((vector? array) (list (vector-length array))) ((string? array) (list (string-length array))) - (else (strict-array-dimensions array)))) + ((bytes? array) (list (bytes-length array))) + (else (array:rtd-dimensions array)))) - (define (array-scales array) - (cond ((string? array) '(1)) - ((vector? array) '(1)) - (else (strict-array-scales array)))) + (define (array:scales obj) + (if (or (string? obj) + (bytes? obj) + (vector? obj)) + '(1) + (array:rtd-scales obj))) - (define (array-store array) - (cond ((string? array) array) - ((vector? array) array) - (else (strict-array-store array)))) - - (define store-makers - (apply vector-immutable - (map (lambda (item) (list-ref item 1)) implementation-list))) + (define (array:store obj) + (if (or (string? obj) + (bytes? obj) + (vector? obj)) + obj + (array:rtd-store obj))) - (define store-reffers - (apply vector-immutable - (map (lambda (item) (list-ref item 2)) implementation-list))) - - (define store-setters - (apply vector-immutable - (map (lambda (item) (list-ref item 3)) implementation-list))) - - (define (array-store-type array) - (cond ((string? array) (a: string)) - ((vector? array) (a: vector)) - (else (strict-array-store-type array)))) - - (define (array-store-ref array) - (vector-ref store-reffers (array-store-type array))) - - (define (array-store-set array) - (vector-ref store-setters (array-store-type array))) - - (define (array-store-maker array-type) - (vector-ref store-makers array-type)) - - (define (array-offset array) - (cond ((string? array) 0) - ((vector? array) 0) - (else (strict-array-offset array)))) + (define (array:offset obj) + (if (or (string? obj) + (bytes? obj) + (vector? obj)) + 0 + (array:rtd-offset obj))) (define (array? obj) (or (string? obj) + (bytes? obj) (vector? obj) - (strict-array? obj))) + (array:rtd? obj))) - (define (s:equal? obj1 obj2) - (or (equal? obj1 obj2) - (and (array? obj1) (array? obj2) - (equal? (array-dimensions obj1) - (array-dimensions obj2)) - (s:equal? (array->vector obj1) (array->vector obj2))))) - - (define (array-rank x) - (if (array? x) - (length (array-dimensions x)) - 0)) + (define (array-rank obj) + (if (array? obj) (length (array:dimensions obj)) 0)) + + (define array-dimensions array:dimensions) (define (make-array prototype . dimensions) - (let ((prot (array-store prototype)) - (pdims (array-dimensions prototype)) - (onedim? (eqv? 1 (length dimensions))) - (tcnt (apply * dimensions))) - (let ((initializer - (if (zero? (apply * pdims)) '() - (list ;; a list with single element at origin - (apply array-ref prototype - (map (lambda (x) 0) pdims)))))) - - (cond ((and onedim? (string? prot)) - (apply make-string (car dimensions) initializer)) - ((and onedim? (vector? prot)) - (apply make-vector (car dimensions) initializer)) - (else - (let* ((store-type (array-store-type prototype)) - (store (apply (array-store-maker store-type) - tcnt initializer))) - (let loop ((dims (reverse dimensions)) (scales '(1))) - (if (null? dims) - (make-strict-array dimensions (cdr scales) 0 - store - store-type) - (loop (cdr dims) - (cons (* (car dims) (car scales)) scales)))))))))) + (define tcnt (apply * dimensions)) + (let ((store + (cond ((string? prototype) + (case (string-length prototype) + ((0) (make-string tcnt)) + (else (make-string tcnt + (string-ref prototype 0))))) + ((bytes? prototype) + (case (bytes-length prototype) + ((0) (make-bytes tcnt)) + (else (make-bytes tcnt + (bytes-ref prototype 0))))) + (else + (let ((pdims (array:dimensions prototype))) + (case (apply * pdims) + ((0) (make-vector tcnt)) + (else (make-vector tcnt + (apply array-ref prototype + (map (lambda (x) 0) pdims)))))))))) + (define (loop dims scales) + (if (null? dims) + (make-array:rtd dimensions (cdr scales) 0 store) + (loop (cdr dims) (cons (* (car dims) (car scales)) scales)))) + (loop (reverse dimensions) '(1)))) (define (make-shared-array array mapper . dimensions) - (define odl (array-scales array)) + (define odl (array:scales array)) (define rank (length dimensions)) (define shape (map (lambda (dim) (if (list? dim) dim (list 0 (sub1 dim)))) dimensions)) - (do ((idx (sub1 rank) (sub1 idx)) - (uvt (if (zero? rank) - '() - (append (cdr (vector->list (make-vector rank 0))) '(1))) + (uvt (append (cdr (vector->list (make-vector rank 0))) '(1)) (append (cdr uvt) '(0))) (uvts '() (cons uvt uvts))) ((negative? idx) (let ((ker0 (apply + (map * odl (apply mapper uvt))))) - (make-strict-array - (map (lambda (dim) (add1 (- (cadr dim) (car dim)))) shape) - (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0)) - uvts) - (apply + - (array-offset array) - (map * odl (apply mapper (map car shape)))) - (array-store array) - (array-store-type array)))))) + (make-array:rtd + (map (lambda (dim) (add1 (- (cadr dim) (car dim)))) shape) + (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0)) + uvts) + (apply + + (array:offset array) + (map * odl (apply mapper (map car shape)))) + (array:store array)))))) (define (list->array rank proto lst) (define dimensions (do ((shp '() (cons (length row) shp)) (row lst (car lst)) (rnk (sub1 rank) (sub1 rnk))) - ((negative? rnk) (reverse shp)))) + ((negative? rnk) (reverse shp)))) (let ((nra (apply make-array proto dimensions))) (define (l2ra dims idxs row) (cond ((null? dims) (apply array-set! nra row (reverse idxs))) - (;; ERROR CHECKING (should be a contract) - (if (not (eqv? (car dims) (length row))) - (error "non-rectangular array" dims dimensions)) - + ((unless (eqv? (car dims) (length row)) + (error 'list->array + "non-rectangular array ~a ~a" + dims dimensions)) (do ((idx 0 (add1 idx)) (row row (cdr row))) - ((>= idx (car dims))) + ((>= idx (car dims))) (l2ra (cdr dims) (cons idx idxs) (car row)))))) (l2ra dimensions '() lst) nra)) @@ -214,19 +131,22 @@ (apply array-ref ra (reverse idxs)) (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst)) (idx (sub1 (car dims)) (sub1 idx))) - ((negative? idx) lst)))) + ((negative? idx) lst)))) (ra2l (array-dimensions ra) '())) (define (vector->array vect prototype . dimensions) - (let ((vdx (vector-length vect)) - (ra (apply make-array prototype dimensions))) + (define vdx (vector-length vect)) + (unless (eqv? vdx (apply * dimensions)) + (error 'vector->array + "~a not equal to ~a" vdx (cons '* dimensions))) + (let ((ra (apply make-array prototype dimensions))) (define (v2ra dims idxs) (cond ((null? dims) (set! vdx (sub1 vdx)) (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) (else (do ((idx (sub1 (car dims)) (sub1 idx))) - ((negative? idx) vect) + ((negative? idx) vect) (v2ra (cdr dims) (cons idx idxs)))))) (v2ra dimensions '()) ra)) @@ -239,95 +159,60 @@ (if (null? dims) (let ((val (apply array-ref ra (reverse idxs)))) (set! vdx (sub1 vdx)) - (vector-set! vect vdx val)) + (vector-set! vect vdx val) + vect) (do ((idx (sub1 (car dims)) (sub1 idx))) - ((negative? idx) vect) + ((negative? idx) vect) (ra2v (cdr dims) (cons idx idxs))))) - (ra2v dims '()) - vect)) + (ra2v dims '()))) - (define (array-in-bounds? array . indices) - (do ((bnds (array-dimensions array) (cdr bnds)) + (define (array:in-bounds? array indices) + (do ((bnds (array:dimensions array) (cdr bnds)) (idxs indices (cdr idxs))) ((or (null? bnds) - (null? idxs) - (not (integer? (car idxs))) - (not (< -1 (car idxs) (car bnds)))) + (null? idxs) + (not (integer? (car idxs))) + (not (< -1 (car idxs) (car bnds)))) (and (null? bnds) (null? idxs))))) - (define (array-ref array . indices) - ((array-store-ref array) - (array-store array) - (apply + (array-offset array) (map * (array-scales array) indices)))) + (define (array-in-bounds? array . indices) + (array:in-bounds? array indices)) - (define (array-set! array obj . indices) - ((array-store-set array) - (array-store array) - (apply + (array-offset array) (map * (array-scales array) indices)) + (define (array-ref array . indices) + (define store (array:store array)) + (or (array:in-bounds? array indices) + (error 'array-ref "bad-indices ~a" indices)) + ((cond ((string? store) + string-ref) + ((bytes? store) + bytes-ref) + (else + vector-ref)) + store (apply + (array:offset array) (map * (array:scales array) indices)))) + + (define (array-set! array obj . indices) + (define store (array:store array)) + (or (array:in-bounds? array indices) + (error 'array-set! "bad-indices ~a" indices)) + ((cond ((string? store) + string-set!) + ((bytes? store) + bytes-set!) + (else + vector-set!)) + store (apply + (array:offset array) (map * (array:scales array) indices)) obj)) - (define (tag-maker array-type) - (case-lambda - (() (make-strict-array - '(0) '(1) 0 - ((array-store-maker array-type) 0) - array-type)) - - ((x) (make-strict-array - '(1) '(1) 0 - ((array-store-maker array-type) 1 x) - array-type)))) + (define A: vector) - (define a:floc128b (tag-maker (a: floc128b))) - (define a:floc64b (tag-maker (a: floc64b))) - (define a:floc32b (tag-maker (a: floc32b))) - (define a:floc16b (tag-maker (a: floc16b))) - - (define a:flor128b (tag-maker (a: flor128b))) - (define a:flor64b (tag-maker (a: flor64b))) - (define a:flor32b (tag-maker (a: flor32b))) - (define a:flor16b (tag-maker (a: flor16b))) - - (define a:floq128d (tag-maker (a: floq128d))) - (define a:floq64d (tag-maker (a: floq64d))) - (define a:floq32d (tag-maker (a: floq32d))) - - (define a:fixz64b (tag-maker (a: fixz64b))) - (define a:fixz16b (tag-maker (a: fixz16b))) - (define a:fixz32b (tag-maker (a: fixz32b))) - (define a:fixz8b (tag-maker (a: fixz8b))) - - (define a:fixn64b (tag-maker (a: fixn64b))) - (define a:fixn32b (tag-maker (a: fixn32b))) - (define a:fixn16b (tag-maker (a: fixn16b))) - (define a:fixn8b (tag-maker (a: fixn8b))) - - (define a:bool (tag-maker (a: bool))) - - - ;; -- - ;; Contracts for module |63|. - - ;; Returns a contract for a binary flonum complex prototype function - ;; given the number of bits (NOT USED). (define (make-floc/c _) (case-> (-> array?) (-> (and/c inexact? complex?) array?))) - ;; Returns a contract for a binary flonum real prototype function - ;; given the number of bits (NOT USED). (define (make-flor/c _) (case-> (-> array?) (-> (and/c inexact? real?) array?))) - ;; Returns a contract for a decimal flonum rational prototype function - ;; given the number of bits (NOT USED). - (define (make-floq/c _) - (case-> (-> array?) - (-> (and/c exact? rational?) array?))) - - ;; Returns a contract for a binary fixnum prototype function given - ;; the number of bits and whether the elements are signed. (define (make-fix/c n signed?) (case-> (-> array?) @@ -338,35 +223,28 @@ (integer-in 0 (sub1 (arithmetic-shift 1 n))))) array?))) - (provide/contract - + (array? (-> any/c boolean?)) - (s:equal? (-> any/c any/c boolean?)) (array-rank (-> any/c natural-number/c)) (array-dimensions (-> array? (listof natural-number/c))) (make-array - (->r ((proto array?)) dimensions (listof natural-number/c) - (lambda (result) - (let ((rank (length dimensions))) - (cond ((and (string? proto) (= 1 rank)) - (string? result)) - ((and (vector? proto) (= 1 rank)) - (vector? result)) - (else - (equal? (array-store-type proto) - (array-store-type result)))))))) + (->r ((proto array?)) dimensions (listof natural-number/c) array?)) (make-shared-array (->r ((array array?) - (mapper (->* () (listof natural-number/c) - ((listof natural-number/c))))) + (mapper procedure?)) indices (listof natural-number/c) array?)) (list->array - (->r ((rank natural-number/c) (proto array?) (list list?)) array?)) + (->r ((rank natural-number/c) + (proto array?) + (list (if (zero? rank) + any/c + list?))) + array?)) (array->list (->r ((array array?)) @@ -376,7 +254,7 @@ (array->vector (->r ((array array?)) vector?)) - + (array-in-bounds? (->r ((array array?)) indices (listof any/c) boolean?)) @@ -396,35 +274,29 @@ any)) ;; Binary flonum complex - (a:floc128b (make-floc/c 128)) - (a:floc64b (make-floc/c 64)) - (a:floc32b (make-floc/c 32)) - (a:floc16b (make-floc/c 16)) - - ;; Binary flonum real - (a:flor128b (make-flor/c 128)) - (a:flor64b (make-flor/c 64)) - (a:flor32b (make-flor/c 32)) - (a:flor16b (make-flor/c 16)) + (rename A: A:floC128b (make-floc/c 128)) + (rename A: A:floC64b (make-floc/c 64)) + (rename A: A:floC32b (make-floc/c 32)) + (rename A: A:floC16b (make-floc/c 16)) + + ;; Binary flonum real + (rename A: A:floR128b (make-flor/c 128)) + (rename A: A:floR64b (make-flor/c 64)) + (rename A: A:floR32b (make-flor/c 32)) + (rename A: A:floR16b (make-flor/c 16)) - ;; Decimal flonum rational - (a:floq128d (make-floq/c 128)) - (a:floq64d (make-floq/c 64)) - (a:floq32d (make-floq/c 32)) - ;; Binary fixnum - (a:fixz64b (make-fix/c 64 #t)) - (a:fixz32b (make-fix/c 32 #t)) - (a:fixz16b (make-fix/c 16 #t)) - (a:fixz8b (make-fix/c 8 #t)) - (a:fixn64b (make-fix/c 64 #f)) - (a:fixn32b (make-fix/c 32 #f)) - (a:fixn16b (make-fix/c 16 #f)) - (a:fixn8b (make-fix/c 8 #f)) + (rename A: A:fixZ64b (make-fix/c 64 #t)) + (rename A: A:fixZ32b (make-fix/c 32 #t)) + (rename A: A:fixZ16b (make-fix/c 16 #t)) + (rename A: A:fixZ8b (make-fix/c 8 #t)) + (rename A: A:fixN64b (make-fix/c 64 #f)) + (rename A: A:fixN32b (make-fix/c 32 #f)) + (rename A: A:fixN16b (make-fix/c 16 #f)) + (rename A: A:fixN8b (make-fix/c 8 #f)) ;; Boolean - (a:bool + (rename A: A:bool (case-> (-> array?) (-> boolean? array?)))) - - ) ; end of module |63| + ) \ No newline at end of file