104 lines
4.2 KiB
Scheme
104 lines
4.2 KiB
Scheme
;;;
|
|
;;; <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))))))))))
|