source: project/release/5/dyn-vector/trunk/dyn-vector.scm @ 35708

Last change on this file since 35708 was 35708, checked in by iraikov, 4 months ago

dyn-vector: fixed tabulate export

File size: 5.7 KB
Line 
1;;
2;;
3;; Dynamic (dense) vectors.
4;;
5;; Copyright 2007-2018 Ivan Raikov.
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  dynvector
27  list->dynvector
28  make-dynvector
29  dynvector-clear!
30  dynvector-length
31  dynvector-ref
32  dynvector-set!
33  dynvector-expand!
34  dynvector-for-each
35  dynvector-map
36  dynvector-copy
37  dynvector-fold
38  dynvector-fold-right
39  dynvector-index
40  dynvector-any
41  dynvector-every
42  dynvector->list)
43                 
44                   
45 (import scheme (chicken base) (chicken condition) (chicken format) (chicken fixnum)
46         srfi-1 vector-lib)
47
48 
49(define-record dvbase vect dflt cnt)
50
51(define-record-printer (dvbase x out)
52  (fprintf out "#(dynvector")
53  (for-each (lambda (x) (fprintf out " ~A" x)) (dynvector->list x))
54  (fprintf out ")"))
55
56
57(define dynvector? dvbase?)
58
59
60(define (dynvector-tabulate n f . rest) 
61  (let-optionals  rest ((dflt #f))
62   (let* ((vect (vector-unfold f n))
63          (dflt (if dflt dflt (vector-ref vect 0))))
64     (make-dvbase vect dflt n))))
65
66
67(define (list->dynvector l . rest)
68  (let-optionals  rest ((dflt #f))
69   (let* ((vect (list->vector l))
70          (dflt (if dflt dflt #f)))
71     (make-dvbase vect dflt (vector-length vect)))))
72 
73
74(define (dynvector . lst)
75  (list->dynvector lst))
76 
77(define (make-dynvector n dflt)
78  (if (> n 0)
79      (make-dvbase (make-vector n dflt) dflt 0)
80      (list->dynvector '() dflt)))
81
82(define (dynvector-clear! dv n) 
83    (dvbase-vect-set! dv (make-vector n (dvbase-dflt dv)))
84    (dvbase-cnt-set! dv n))
85
86(define (dynvector-length dv)
87  (dvbase-cnt dv))
88
89(define (dynvector-ref dv i)
90  (define (handle-ref thunk dflt)
91    (condition-case (thunk)
92                    [(exn bounds)  dflt]))
93 
94  (let ((vect (dvbase-vect dv)))
95    (handle-ref (lambda () (vector-ref vect i)) (dvbase-dflt dv))))
96
97(define (dynvector-set! dv i e)
98  (define (handle-update thunk extend)
99    (condition-case (thunk)
100                    [(exn bounds)  (extend)]))
101 
102  (let ((vect (dvbase-vect dv))
103        (n    (dvbase-cnt dv)))
104    (handle-update
105     (lambda () (begin
106                  (vector-set! vect i e)
107                  (dvbase-cnt-set! dv (max n (fx+ 1 i)))))
108     (lambda () (let* ((n1    (max (fx* 2 n) (fx+ 1 i) 16))
109                       (vect1 (if (fx= 0 (vector-length vect))
110                                  (make-vector n1 (dvbase-dflt dv))
111                                  (vector-copy vect 0 n1 (dvbase-dflt dv)))))
112                  (vector-set! vect1 i e)
113                  (dvbase-vect-set! dv vect1)
114                  (dvbase-cnt-set! dv (fx+ 1 i)))))))
115
116
117(define (dynvector-expand! dv n)
118  (dynvector-set! dv (- n 1) (dvbase-dflt dv)))
119
120(define (dynvector-for-each 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          (apply vector-for-each 
125                 (cons (lambda (i v . rest) (apply f (cons i rest)))
126                       (cons (make-vector min-n #f) vect)))))))
127
128(define (dynvector-map f dv . rest)
129  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
130    (let-values (((vect n)  (unzip2 vect+n)))
131        (let ((min-n  (apply min n)))
132          (let ((vect1 (apply vector-map 
133                              (cons (lambda (i v . rest) (apply f (cons i rest)))
134                                    (cons (make-vector min-n #f) vect)))))
135            (make-dvbase vect1 (vector-ref vect1 0) min-n))))))
136
137(define (dynvector-copy dv)
138  (let ((vect (dvbase-vect dv))
139        (dflt (dvbase-dflt dv))
140        (n    (dvbase-cnt dv)))
141  (make-dvbase (vector-copy vect) dflt n)))
142
143
144(define (dynvector-fold f init dv . rest)
145  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
146    (let-values (((vect n)  (unzip2 vect+n)))
147        (let ((min-n  (apply min n)))
148          (apply vector-fold 
149                 (cons (lambda (i state v . rest) (apply f (cons i (cons state rest))))
150                       (cons init (cons (make-vector min-n #f) vect))))))))
151
152
153(define (dynvector-fold-right f init 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-fold-right 
158                 (cons (lambda (i state v . rest) (apply f (cons i (cons state rest))))
159                       (cons init (cons (make-vector min-n #f) vect))))))))
160
161(define (dynvector-index 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-index 
166                 (cons (lambda (v . rest) (apply pred? rest))
167                       (cons (make-vector min-n #f) vect)))))))
168
169(define (dynvector-any 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-any 
174                 (cons (lambda (v . rest) (apply pred? rest))
175                       (cons (make-vector min-n #f) vect)))))))
176
177(define (dynvector-every pred? dv . rest)
178  (let ((vect+n (map (lambda (dv) (list (dvbase-vect dv) (dvbase-cnt dv))) (cons dv rest))))
179    (let-values (((vect n)  (unzip2 vect+n)))
180        (let ((min-n  (apply min n)))
181          (apply vector-every 
182                 (cons (lambda (v . rest) (apply pred? rest))
183                       (cons (make-vector min-n #f) vect)))))))
184
185(define (dynvector->list dv)
186  (let ((n     (dvbase-cnt dv))
187        (vect  (dvbase-vect dv)))
188    (if (> n 0)
189        (vector->list vect 0 n)
190        '())))
191
192
193)
Note: See TracBrowser for help on using the repository browser.