279 lines
12 KiB
Scheme
279 lines
12 KiB
Scheme
;;;
|
|
;;; <iteration.ss> ---- Vector iteration
|
|
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
|
|
;;;
|
|
;;; Copyright (C) 2005 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)))))))))
|