home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / ordvec.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  126 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: ordvec.scm,v 1.2 1999/01/02 06:11:34 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1995, 1999 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; Ordered Vectors
  22.  
  23. (declare (usual-integrations))
  24.  
  25. ;;; ORDER implements a total order.  It accepts two keys, returning
  26. ;;; one of LESS, GREATER, or EQUAL to indicate the relative position
  27. ;;; of the keys in the order.  It's assumed that the vector does not
  28. ;;; contain two distinct keys that ORDER finds EQUAL.
  29.  
  30. ;;; MATCH accepts two keys, returning either #F or a real number.  The
  31. ;;; returned value indicates how well the keys match, with #F meaning
  32. ;;; "no match", and larger numbers indicating better matches.  It is
  33. ;;; assumed that MATCH is true for an open set around each argument,
  34. ;;; within the order implemented by ORDER, and false everywhere
  35. ;;; outside that set.
  36.  
  37. (define (ordered-vector-minimum-match vector key item-key order match
  38.                       if-unique if-not-unique if-not-found)
  39.   (ordered-subvector-minimum-match vector 0 (vector-length vector) key item-key
  40.                    order match
  41.                    if-unique if-not-unique if-not-found))
  42.  
  43. (define (ordered-subvector-minimum-match vector start end key item-key
  44.                      order match
  45.                      if-unique if-not-unique if-not-found)
  46.   (call-with-values
  47.       (lambda ()
  48.     (match-ordered-subvector vector start end key item-key order match))
  49.     (lambda (lower upper gcm closest)
  50.       (cond ((not gcm)
  51.          (if-not-found))
  52.         ((fix:= lower (fix:- upper 1))
  53.          (if-unique (vector-ref vector closest)))
  54.         (else
  55.          (if-not-unique (vector-ref vector closest)
  56.                 gcm
  57.                 (lambda () (subvector vector lower upper))))))))
  58.  
  59. (define (ordered-vector-matches vector key item-key order match)
  60.   (ordered-subvector-matches vector 0 (vector-length vector) key item-key
  61.                  order match))
  62.  
  63. (define (ordered-subvector-matches vector start end key item-key order match)
  64.   (call-with-values
  65.       (lambda ()
  66.     (match-ordered-subvector vector start end key item-key order match))
  67.     (lambda (lower upper gcm closest)
  68.       gcm closest
  69.       (subvector vector lower upper))))
  70.  
  71. (define (match-ordered-vector vector key item-key order match)
  72.   (match-ordered-subvector vector 0 (vector-length vector) key item-key
  73.                order match))
  74.  
  75. (define (match-ordered-subvector vector start end key item-key order match)
  76.   (let ((perform-search
  77.      (lambda (index)
  78.        (letrec
  79.            ((scan-up
  80.          (lambda (upper gcm)
  81.            (if (fix:= upper end)
  82.                (values upper gcm)
  83.                (let ((m (mc upper)))
  84.              (if m
  85.                  (scan-up (fix:+ upper 1) (min gcm m))
  86.                  (values upper gcm))))))
  87.         (scan-down
  88.          (lambda (lower gcm)
  89.            (if (fix:= lower start)
  90.                (values lower gcm)
  91.                (let* ((index (fix:- lower 1))
  92.                   (m (mc index)))
  93.              (if m
  94.                  (scan-down index (min gcm m))
  95.                  (values lower gcm))))))
  96.         (mc
  97.          (let ((close (item-key (vector-ref vector index))))
  98.            (lambda (index)
  99.              (match close (item-key (vector-ref vector index)))))))
  100.          (call-with-values (lambda () (scan-up (fix:+ index 1) (mc index)))
  101.            (lambda (upper gcm)
  102.          (call-with-values (lambda () (scan-down index gcm))
  103.            (lambda (lower gcm)
  104.              (values lower upper gcm index)))))))))
  105.     (search-ordered-subvector vector start end key item-key order
  106.       perform-search
  107.       (lambda (index)
  108.     (if (and (fix:< index end)
  109.          (match key (item-key (vector-ref vector index))))
  110.         (perform-search index)
  111.         (values index index #f index))))))
  112.  
  113. (define (search-ordered-vector vector key item-key order if-found if-not-found)
  114.   (search-ordered-subvector vector 0 (vector-length vector) key item-key order
  115.                 if-found if-not-found))
  116.  
  117. (define (search-ordered-subvector vector start end key item-key order
  118.                   if-found if-not-found)
  119.   (let loop ((low start) (high end))
  120.     (if (fix:< low high)
  121.     (let ((index (fix:quotient (fix:+ low high) 2)))
  122.       (case (order key (item-key (vector-ref vector index)))
  123.         ((LESS) (loop low index))
  124.         ((GREATER) (loop (fix:+ index 1) high))
  125.         (else (if-found index))))
  126.     (if-not-found low))))