299 lines
13 KiB
Scheme
299 lines
13 KiB
Scheme
;;;
|
|
;;; <searching.ss> ---- Vector searching
|
|
;;; 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 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))))))))))
|
|
|