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 / vector.scm < prev    next >
Text File  |  2000-03-27  |  8KB  |  234 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: vector.scm,v 14.15 2000/03/27 19:56:07 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. 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.  
  22. ;;;; Operations on Vectors
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-primitives
  28.  vector? vector-length vector-ref vector-set!
  29.  list->vector vector subvector->list
  30.  subvector-move-right! subvector-move-left! subvector-fill!)
  31.  
  32. (define-integrable (guarantee-vector object procedure)
  33.   (if (not (vector? object))
  34.       (error:wrong-type-argument object "vector" procedure)))
  35.  
  36. (define-integrable (guarantee-subvector vector start end procedure)
  37.   (guarantee-vector vector procedure)
  38.   (if (not (index-fixnum? start))
  39.       (error:wrong-type-argument start "vector index" procedure))
  40.   (if (not (index-fixnum? end))
  41.       (error:wrong-type-argument end "vector index" procedure))
  42.   (if (not (fix:<= start end))
  43.       (error:bad-range-argument start procedure))
  44.   (if (not (fix:<= end (vector-length vector)))
  45.       (error:bad-range-argument end procedure)))
  46.  
  47. (define (make-vector size #!optional fill)
  48.   (if (not (index-fixnum? size))
  49.       (error:wrong-type-argument size "vector index" 'MAKE-VECTOR))
  50.   ((ucode-primitive vector-cons) size (if (default-object? fill) #f fill)))
  51.  
  52. (define (vector->list vector)
  53.   (guarantee-vector vector 'VECTOR->LIST)
  54.   (subvector->list vector 0 (vector-length vector)))
  55.  
  56. (define (vector-fill! vector value)
  57.   (guarantee-vector vector 'VECTOR-FILL!)
  58.   (subvector-fill! vector 0 (vector-length vector) value))
  59.  
  60. (define (subvector vector start end)
  61.   (guarantee-subvector vector start end 'SUBVECTOR)
  62.   (let ((result (make-vector (fix:- end start))))
  63.     (subvector-move-right! vector start end result 0)
  64.     result))
  65.  
  66. (define-integrable (vector-head vector end)
  67.   (subvector vector 0 end))
  68.  
  69. (define (vector-tail vector start)
  70.   (guarantee-vector vector 'VECTOR-TAIL)
  71.   (subvector vector start (vector-length vector)))
  72.  
  73. (define (vector-copy vector)
  74.   (guarantee-vector vector 'VECTOR-COPY)
  75.   (let ((length (vector-length vector)))
  76.     (let ((new-vector (make-vector length)))
  77.       (subvector-move-right! vector 0 length new-vector 0)
  78.       new-vector)))
  79.  
  80. (define (vector-append . vectors)
  81.   (let ((result
  82.      (make-vector
  83.       (let loop ((vectors vectors) (length 0))
  84.         (if (null? vectors)
  85.         length
  86.         (begin
  87.           (guarantee-vector (car vectors) 'VECTOR-APPEND)
  88.           (loop (cdr vectors)
  89.             (fix:+ (vector-length (car vectors)) length))))))))
  90.     (let loop ((vectors vectors) (index 0))
  91.       (if (null? vectors)
  92.       result
  93.       (let ((size (vector-length (car vectors))))
  94.         (subvector-move-right! (car vectors) 0 size result index)
  95.         (loop (cdr vectors) (fix:+ index size)))))))
  96.  
  97. (define (vector-grow vector length #!optional value)
  98.   (guarantee-vector vector 'VECTOR-GROW)
  99.   (if (not (index-fixnum? length))
  100.       (error:wrong-type-argument length "vector length" 'VECTOR-GROW))
  101.   (if (fix:< length (vector-length vector))
  102.       (error:bad-range-argument length 'VECTOR-GROW))
  103.   (let ((vector* (make-vector length (if (default-object? value) #f value))))
  104.     (subvector-move-right! vector 0 (vector-length vector) vector* 0)
  105.     vector*))
  106.  
  107. (define (make-initialized-vector length initialization)
  108.   ;; LENGTH is checked by MAKE-VECTOR
  109.   (let ((vector (make-vector length)))
  110.     (let loop ((index 0))
  111.       (if (fix:< index length)
  112.       (begin
  113.         (vector-set! vector index (initialization index))
  114.         (loop (fix:+ index 1)))))
  115.     vector))
  116.  
  117. (define (vector-map procedure vector)
  118.   (if (vector? procedure)
  119.       ;; KLUDGE: accept arguments in old order.
  120.       (vector-map vector procedure)
  121.       (begin
  122.     (guarantee-vector vector 'VECTOR-MAP)
  123.     (let ((length (vector-length vector)))
  124.       (if (fix:= 0 length)
  125.           vector
  126.           (let ((result (make-vector length)))
  127.         (let loop ((index 0))
  128.           (if (fix:< index length)
  129.               (begin
  130.             (vector-set! result
  131.                      index
  132.                      (procedure (vector-ref vector index)))
  133.             (loop (fix:+ index 1)))))
  134.         result))))))
  135.  
  136. (define (for-each-vector-element vector procedure)
  137.   (guarantee-vector vector 'FOR-EACH-VECTOR-ELEMENT)
  138.   (let ((length (vector-length vector)))
  139.     (let loop ((index 0))
  140.       (if (fix:< index length)
  141.       (begin
  142.         (procedure (vector-ref vector index))
  143.         (loop (fix:+ index 1)))))))
  144.  
  145. (define (subvector-find-next-element vector start end item)
  146.   (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT)
  147.   (let loop ((index start))
  148.     (and (fix:< index end)
  149.      (if (eqv? (vector-ref vector index) item)
  150.          index
  151.          (loop (fix:+ index 1))))))
  152.  
  153. (define (subvector-find-next-element-not vector start end item)
  154.   (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT-NOT)
  155.   (let loop ((index start))
  156.     (and (fix:< index end)
  157.      (if (eqv? (vector-ref vector index) item)
  158.          (loop (fix:+ index 1))
  159.          index))))
  160.  
  161. (define (subvector-find-previous-element vector start end item)
  162.   (guarantee-subvector vector start end 'SUBVECTOR-FIND-PREVIOUS-ELEMENT)
  163.   (let loop ((index (fix:- end 1)))
  164.     (and (fix:<= start index)
  165.      (if (eqv? (vector-ref vector index) item)
  166.          index
  167.          (loop (fix:- index 1))))))
  168.  
  169. (define (subvector-find-previous-element-not vector start end item)
  170.   (guarantee-subvector vector start end 'SUBVECTOR-FIND-PREVIOUS-ELEMENT-NOT)
  171.   (let loop ((index (fix:- end 1)))
  172.     (and (fix:<= start index)
  173.      (if (eqv? (vector-ref vector index) item)
  174.          (loop (fix:- index 1))
  175.          index))))
  176.  
  177. (define-integrable (vector-find-next-element vector item)
  178.   (guarantee-vector vector 'VECTOR-FIND-NEXT-ELEMENT)
  179.   (subvector-find-next-element vector 0 (vector-length vector) item))
  180.  
  181. (define-integrable (vector-find-previous-element vector item)
  182.   (guarantee-vector vector 'VECTOR-FIND-PREVIOUS-ELEMENT)
  183.   (subvector-find-previous-element vector 0 (vector-length vector) item))
  184.  
  185. (define (vector-binary-search vector key<? unwrap-key key)
  186.   (guarantee-vector vector 'VECTOR-BINARY-SEARCH)
  187.   (let loop ((start 0) (end (vector-length vector)))
  188.     (and (fix:< start end)
  189.      (let ((midpoint (fix:quotient (fix:+ start end) 2)))
  190.        (let ((item (vector-ref vector midpoint)))
  191.          (let ((key* (unwrap-key item)))
  192.            (cond ((key<? key key*) (loop start midpoint))
  193.              ((key<? key* key) (loop (fix:+ midpoint 1) end))
  194.              (else item))))))))
  195.  
  196. (let-syntax
  197.     ((iref
  198.       (macro (name index)
  199.     `(DEFINE-INTEGRABLE (,name VECTOR)
  200.        (GUARANTEE-VECTOR VECTOR 'SAFE-VECTOR-REF)
  201.        (VECTOR-REF VECTOR ,index)))))
  202.   (iref vector-first 0)
  203.   (iref vector-second 1)
  204.   (iref vector-third 2)
  205.   (iref vector-fourth 3)
  206.   (iref vector-fifth 4)
  207.   (iref vector-sixth 5)
  208.   (iref vector-seventh 6)
  209.   (iref vector-eighth 7))
  210.  
  211. (define (vector-move! v1 v2)
  212.   (guarantee-vector v1 'VECTOR-MOVE!)
  213.   (subvector-move-left! v1 0 (vector-length v1) v2 0))
  214.  
  215. (define (subvector-filled? vector start end element)
  216.   (guarantee-subvector vector start end 'SUBVECTOR-FILLED?)
  217.   (let loop ((index start))
  218.     (or (fix:= index end)
  219.     (and (eqv? (vector-ref vector index) element)
  220.          (loop (fix:+ index 1))))))
  221.  
  222. (define (vector-filled? vector element)
  223.   (guarantee-vector vector 'VECTOR-FILLED?)
  224.   (subvector-filled? vector 0 (vector-length vector) element))
  225.  
  226. (define (subvector-uniform? vector start end)
  227.   (guarantee-subvector vector start end 'SUBVECTOR-UNIFORM?)
  228.   (if (fix:< start end)
  229.       (subvector-filled? vector (fix:+ start 1) end (vector-ref vector start))
  230.       #t))
  231.  
  232. (define (vector-uniform? vector)
  233.   (guarantee-vector vector 'VECTOR-UNIFORM?)
  234.   (subvector-uniform? vector 0 (vector-length vector)))