source: project/dyn-vector/tags/1.8a/dyn-vector.scm @ 7359

Last change on this file since 7359 was 4870, checked in by Ivan Raikov, 13 years ago

License upgrade to GPL v3.

File size: 5.6 KB
Line 
1;;
2;;
3;; Dynamic (dense) vectors.
4;;
5;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and 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 3 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, 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;; A full copy of the GPL license can be found at
18;; <http://www.gnu.org/licenses/>.
19;;
20
21(require-extension srfi-1)
22(require-extension vector-lib)
23
24(define-extension dyn-vector)
25
26(declare (export dynvector?             
27                 dynvector-tabulate
28                 list->dynvector
29                 make-dynvector
30                 dynvector-clear!
31                 dynvector-length
32                 dynvector-ref
33                 dynvector-set!
34                 dynvector-expand!
35                 dynvector-for-each
36                 dynvector-map
37                 dynvector-copy
38                 dynvector-fold
39                 dynvector-fold-right
40                 dynvector-index
41                 dynvector-any
42                 dynvector-every
43                 dynvector->list))
44                 
45
46(define-record dvbase vect dflt cnt)
47
48(define-record-printer (dvbase x out)
49  (fprintf out "#(dynvector")
50  (for-each (lambda (x) (fprintf out " ~A" x)) (dynvector->list x))
51  (fprintf out ")"))
52
53
54(define dynvector? dvbase?)
55
56
57(define (dynvector-tabulate n f . rest) 
58  (let-optionals  rest ((dflt #f))
59   (let* ((vect (vector-unfold f n))
60          (dflt (if dflt dflt (vector-ref vect 0))))
61     (make-dvbase vect dflt n))))
62
63(define (list->dynvector l . rest)
64  (let-optionals  rest ((dflt #f))
65   (let* ((vect (list->vector l))
66          (dflt (if dflt dflt (vector-ref vect 0))))
67     (make-dvbase vect dflt (vector-length vect)))))
68 
69(define (make-dynvector n dflt)
70  (make-dvbase (make-vector n dflt) dflt 0))
71
72(define (dynvector-clear! dv n) 
73    (dvbase-vect-set! dv (make-vector n (dvbase-dflt dv)))
74    (dvbase-cnt-set! dv n))
75
76(define (dynvector-length dv)
77  (dvbase-cnt dv))
78
79(define (dynvector-ref dv i)
80  (define (handle-ref thunk dflt)
81    (condition-case (thunk)
82                    [(exn bounds)  dflt]))
83 
84  (let ((vect (dvbase-vect dv)))
85    (handle-ref (lambda () (vector-ref vect i)) (dvbase-dflt dv))))
86
87(define (dynvector-set! dv i e)
88  (define (handle-update thunk extend)
89    (condition-case (thunk)
90                    [(exn bounds)  (extend)]))
91 
92  (let ((vect (dvbase-vect dv))
93        (n    (dvbase-cnt dv)))
94    (handle-update
95     (lambda () (begin
96                  (vector-set! vect i e)
97                  (dvbase-cnt-set! dv (max n (fx+ 1 i)))))
98     (lambda () (let* ((n1    (max (fx* 2 n) (fx+ 1 i) 16))
99                       (vect1 (if (fx= 0 (vector-length vect))
100                                  (make-vector n1 (dvbase-dflt dv))
101                                  (vector-copy vect 0 n1 (dvbase-dflt dv)))))
102                  (vector-set! vect1 i e)
103                  (dvbase-vect-set! dv vect1)
104                  (dvbase-cnt-set! dv (fx+ 1 i)))))))
105
106
107(define (dynvector-expand! dv n)
108  (dynvector-set! dv (- n 1) (dvbase-dflt dv)))
109
110(define (dynvector-for-each f dv . rest)
111  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
112    (let-values (((vect n)  (unzip2 vect+n)))
113        (let ((min-n  (apply min n)))
114          (apply vector-for-each 
115                 (cons (lambda (i v . rest) (apply f (cons i rest)))
116                       (cons (make-vector min-n #f) vect)))))))
117
118(define (dynvector-map f dv . rest)
119  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
120    (let-values (((vect n)  (unzip2 vect+n)))
121        (let ((min-n  (apply min n)))
122          (let ((vect1 (apply vector-map 
123                              (cons (lambda (i v . rest) (apply f (cons i rest)))
124                                    (cons (make-vector min-n #f) vect)))))
125            (make-dvbase vect1 (vector-ref vect1 0) min-n))))))
126
127(define (dynvector-copy dv)
128  (let ((vect (dvbase-vect dv))
129        (dflt (dvbase-dflt dv))
130        (n    (dvbase-cnt dv)))
131  (make-dvbase (vector-copy vect) dflt n)))
132
133
134(define (dynvector-fold f init dv . rest)
135  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
136    (let-values (((vect n)  (unzip2 vect+n)))
137        (let ((min-n  (apply min n)))
138          (apply vector-fold 
139                 (cons (lambda (i state v . rest) (apply f (cons i (cons state rest))))
140                       (cons init (cons (make-vector min-n #f) vect))))))))
141
142
143(define (dynvector-fold-right f init dv . rest)
144  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
145    (let-values (((vect n)  (unzip2 vect+n)))
146        (let ((min-n  (apply min n)))
147          (apply vector-fold-right 
148                 (cons (lambda (i state v . rest) (apply f (cons i (cons state rest))))
149                       (cons init (cons (make-vector min-n #f) vect))))))))
150
151(define (dynvector-index pred? dv . rest)
152  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
153    (let-values (((vect n)  (unzip2 vect+n)))
154        (let ((min-n  (apply min n)))
155          (apply vector-index 
156                 (cons (lambda (v . rest) (apply pred? rest))
157                       (cons (make-vector min-n #f) vect)))))))
158
159(define (dynvector-any pred? dv . rest)
160  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
161    (let-values (((vect n)  (unzip2 vect+n)))
162        (let ((min-n  (apply min n)))
163          (apply vector-any 
164                 (cons (lambda (v . rest) (apply pred? rest))
165                       (cons (make-vector min-n #f) vect)))))))
166
167(define (dynvector-every pred? dv . rest)
168  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
169    (let-values (((vect n)  (unzip2 vect+n)))
170        (let ((min-n  (apply min n)))
171          (apply vector-every 
172                 (cons (lambda (v . rest) (apply pred? rest))
173                       (cons (make-vector min-n #f) vect)))))))
174
175(define (dynvector->list dv)
176  (let ((n     (dvbase-cnt dv))
177        (vect  (dvbase-vect dv)))
178    (vector->list vect 0 n)))
179
180
Note: See TracBrowser for help on using the repository browser.