update
svn: r5897
This commit is contained in:
parent
61785f1fc8
commit
5947007621
|
@ -1,215 +0,0 @@
|
|||
;;;
|
||||
;;; <constructors.ss> ---- 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 <mrmathematica@yahoo.com>
|
||||
;;
|
||||
;;
|
||||
;; 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 <f> <length> <initial-seed> ...) -> vector
|
||||
;;; (F <index> <seed> ...) -> [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 <f> <length> <initial-seed> ...) -> vector
|
||||
;;; (F <seed> ...) -> [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> [<start> <end> <fill>]) -> 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> [<start> <end>]) -> 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> ...) -> 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-list>) -> 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)))))
|
|
@ -1,98 +0,0 @@
|
|||
;;;
|
||||
;;; <conversion.ss> ---- 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 <mrmathematica@yahoo.com>
|
||||
;;
|
||||
;;
|
||||
;; 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 <vector> [<start> <end>]) -> 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 <vector> [<start> <end>]) -> 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 <list> -> 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)))
|
|
@ -1,278 +0,0 @@
|
|||
;;;
|
||||
;;; <iteration.ss> ---- 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 <mrmathematica@yahoo.com>
|
||||
;;
|
||||
;;
|
||||
;; 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 <kons> <initial-knil> <vector> ...) -> knil
|
||||
;;; (KONS <knil> <elt> ...) -> 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer
|
||||
;;; (PREDICATE? <index> <value> ...) ; 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 <kons> <initial-knil> <vector> ...) -> knil
|
||||
;;; (KONS <knil> <elt> ...) -> 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 <f> <vector> ...) -> vector
|
||||
;;; (F <elt> ...) -> 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> <target> <length> <vector>)
|
||||
;;; (F <index> <elt>) -> 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! <f> <vector> ...) -> vector
|
||||
;;; (F <elt> ...) -> 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 <f> <vector> ...) -> void
|
||||
;;; (F <elt> ...) ; 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)))))))))
|
|
@ -1,159 +0,0 @@
|
|||
;;;
|
||||
;;; <mutators.ss> ---- 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 <mrmathematica@yahoo.com>
|
||||
;;
|
||||
;;
|
||||
;; 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! <vector> <index1> <index2>) -> 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! <vector> <value> [<start> <end>]) -> <vector>
|
||||
;;; [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! <vector> [<start> <end>]) -> 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! <target> <tstart> <source> [<sstart> <send>])
|
||||
;;; -> 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! <target> <tstart> <source> [<sstart> <send>])
|
||||
(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))))
|
|
@ -1,103 +0,0 @@
|
|||
;;;
|
||||
;;; <predicates.ss> ---- 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 <mrmathematica@yahoo.com>
|
||||
;;
|
||||
;;
|
||||
;; 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? <vector>) -> 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= <elt=?> <vector> ...) -> boolean
|
||||
;;; (ELT=? <value> <value>) -> 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))))))))))
|
|
@ -1,298 +0,0 @@
|
|||
;;;
|
||||
;;; <searching.ss> ---- 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 <mrmathematica@yahoo.com>
|
||||
;;
|
||||
;;
|
||||
;; 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (PREDICATE? <elt> ...) -> 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (PREDICATE? <elt> ...) -> 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (PREDICATE? <elt> ...) -> 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (PREDICATE? <elt> ...) -> 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 <vector> <value> <cmp>)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (CMP <value1> <value2>) -> 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 <pred?> <vector> ...) -> 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 <pred?> <vector> ...) -> 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))))))))))
|
||||
|
|
@ -1,163 +0,0 @@
|
|||
;;;
|
||||
;;; <util.ss> ---- 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 <mrmathematica@yahoo.com>
|
||||
;;
|
||||
;;
|
||||
;; 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 <vector> <index> <callee>) ->
|
||||
;;; 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! <target> <tstart> <source> <sstart> <send>)
|
||||
;;; 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! <target> <tstart> <source> <sstart> <send>)
|
||||
;;; 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 <vector-list> <default-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)))))
|
|
@ -1,43 +1,846 @@
|
|||
;;;
|
||||
;;; <util.ss> ---- 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 <mrmathematica@yahoo.com>
|
||||
;;
|
||||
;;; 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 <vector-list> <default-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 <f> <length> <initial-seed> ...) -> vector
|
||||
;;; (F <index> <seed> ...) -> [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 <f> <length> <initial-seed> ...) -> vector
|
||||
;;; (F <seed> ...) -> [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> [<start> <end> <fill>]) -> 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> [<start> <end>]) -> 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> ...) -> vector
|
||||
;;; Append VECTOR ... into a newly allocated vector and return that
|
||||
;;; new vector.
|
||||
(define (vector-append . vectors)
|
||||
(vector-concatenate vectors))
|
||||
|
||||
;;; (VECTOR-CONCATENATE <vector-list>) -> 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? <vector>) -> 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= <elt=?> <vector> ...) -> boolean
|
||||
;;; (ELT=? <value> <value>) -> 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 <kons> <initial-knil> <vector> ...) -> knil
|
||||
;;; (KONS <knil> <elt> ...) -> 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer
|
||||
;;; (PREDICATE? <index> <value> ...) ; 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 <kons> <initial-knil> <vector> ...) -> knil
|
||||
;;; (KONS <knil> <elt> ...) -> 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 <f> <vector> ...) -> vector
|
||||
;;; (F <elt> ...) -> 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> <target> <length> <vector>)
|
||||
;;; (F <index> <elt>) -> 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! <f> <vector> ...) -> vector
|
||||
;;; (F <elt> ...) -> 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 <f> <vector> ...) -> void
|
||||
;;; (F <elt> ...) ; 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (PREDICATE? <elt> ...) -> 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (PREDICATE? <elt> ...) -> 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (PREDICATE? <elt> ...) -> 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 <predicate?> <vector> ...)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (PREDICATE? <elt> ...) -> 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 <vector> <value> <cmp>)
|
||||
;;; -> exact, nonnegative integer or #F
|
||||
;;; (CMP <value1> <value2>) -> 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 <pred?> <vector> ...) -> 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 <pred?> <vector> ...) -> 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?
|
||||
(</c (vector-length vec))))
|
||||
(j (and/c nonneg-int?
|
||||
(</c (vector-length vec)))))
|
||||
any))
|
||||
(rename my-vector-fill! s:vector-fill!
|
||||
(case->
|
||||
(-> 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! <vector> <index1> <index2>) -> 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! <vector> <value> [<start> <end>]) -> <vector>
|
||||
;;; [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! <vector> [<start> <end>]) -> 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! <target> <tstart> <source> [<sstart> <send>])
|
||||
;;; -> 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! <target> <tstart> <source> [<sstart> <send>])
|
||||
(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 <vector> [<start> <end>]) -> 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 <vector> [<start> <end>]) -> 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 <list> -> 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)))
|
|
@ -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|
|
||||
)
|
Loading…
Reference in New Issue
Block a user