source: project/release/4/dyn-vector/trunk/dyn-vector.scm @ 28801

Last change on this file since 28801 was 28801, checked in by Ivan Raikov, 8 years ago

dyn-vector: license change to LGPL-3

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