source: project/release/4/srfi-4-utils/trunk/srfi-4-utils.scm @ 28968

Last change on this file since 28968 was 28968, checked in by Ivan Raikov, 7 years ago

srfi-4-utils: removed redundant merge sort routine

File size: 14.5 KB
Line 
1
2;;
3;;
4;; A collection of utility functions for manipulating SRFI-4 vectors.
5;;
6;;
7;; Copyright 2007-2013 Ivan Raikov and the Okinawa Institute of Science and Technology.
8;;
9;;
10;; This program is free software: you can redistribute it and/or
11;; modify it under the terms of the GNU General Public License as
12;; published by the Free Software Foundation, either version 3 of the
13;; License, or (at your option) any later version.
14;;
15;; This program is distributed in the hope that it will be useful, but
16;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18;; General Public License for more details.
19;;
20;; A full copy of the GPL license can be found at
21;; <http://www.gnu.org/licenses/>.
22;;
23;;
24
25(module srfi-4-utils
26
27 (f64vector-fold f32vector-fold s32vector-fold u32vector-fold
28                 s16vector-fold u16vector-fold s8vector-fold u8vector-fold
29                 f64vector-map f32vector-map s32vector-map u32vector-map
30                 s16vector-map u16vector-map s8vector-map u8vector-map
31                 f64vector-foldi f32vector-foldi s32vector-foldi u32vector-foldi
32                 s16vector-foldi u16vector-foldi s8vector-foldi u8vector-foldi
33                 f64vector-mapi f32vector-mapi s32vector-mapi u32vector-mapi
34                 s16vector-mapi u16vector-mapi s8vector-mapi u8vector-mapi
35                 f64vector-take f32vector-take s32vector-take u32vector-take
36                 s16vector-take u16vector-take s8vector-take u8vector-take
37
38                 f64vector-blit! f32vector-blit! s32vector-blit! u32vector-blit!
39                 s16vector-blit! u16vector-blit! s8vector-blit! u8vector-blit!
40
41                 f64vector-quick-sort! f32vector-quick-sort! s32vector-quick-sort! u32vector-quick-sort!
42                 s16vector-quick-sort! u16vector-quick-sort! s8vector-quick-sort! u8vector-quick-sort!
43
44                 f64vector-merge! f32vector-merge! s32vector-merge! u32vector-merge!
45                 s16vector-merge! u16vector-merge! s8vector-merge! u8vector-merge!
46
47                 f64vector-merge-sort! f32vector-merge-sort! s32vector-merge-sort! u32vector-merge-sort!
48                 s16vector-merge-sort! u16vector-merge-sort! s8vector-merge-sort! u8vector-merge-sort!
49
50                 )
51
52 (import scheme chicken)
53 (require-library srfi-1 extras)
54 (import (only srfi-1 fold every)
55         (only extras printf))
56 (require-extension srfi-4 srfi-42 srfi-4-comprehensions)
57
58(define (make-vector-fold vector-length vector-ref)
59  (lambda (f x0 v . rest)
60    (let ((n   (vector-length v))
61          (vs  (cons v rest)))
62      (fold-ec x0 (:range i 0 n) 
63               (map (lambda (v) (vector-ref v i)) vs)
64               (lambda (x ax) (apply f (append x (list ax))))))))
65
66(define f64vector-fold (make-vector-fold f64vector-length f64vector-ref))
67(define f32vector-fold (make-vector-fold f32vector-length f32vector-ref))
68(define s32vector-fold (make-vector-fold s32vector-length s32vector-ref))
69(define u32vector-fold (make-vector-fold u32vector-length u32vector-ref))
70(define s16vector-fold (make-vector-fold s16vector-length s16vector-ref))
71(define u16vector-fold (make-vector-fold u16vector-length u16vector-ref))
72(define s8vector-fold  (make-vector-fold s8vector-length s8vector-ref))
73(define u8vector-fold  (make-vector-fold u8vector-length u8vector-ref))
74
75
76(define (make-vector-foldi vector-length vector-ref)
77  (lambda (f x0 v . rest)
78    (let ((n   (vector-length v))
79          (vs  (cons v rest)))
80      (fold-ec x0 (:range i 0 n) 
81               (cons i (map (lambda (v) (vector-ref v i)) vs))
82               (lambda (x ax) (apply f (append x (list ax))))))))
83
84
85(define f64vector-foldi (make-vector-foldi f64vector-length f64vector-ref))
86(define f32vector-foldi (make-vector-foldi f32vector-length f32vector-ref))
87(define s32vector-foldi (make-vector-foldi s32vector-length s32vector-ref))
88(define u32vector-foldi (make-vector-foldi u32vector-length u32vector-ref))
89(define s16vector-foldi (make-vector-foldi s16vector-length s16vector-ref))
90(define u16vector-foldi (make-vector-foldi u16vector-length u16vector-ref))
91(define s8vector-foldi  (make-vector-foldi s8vector-length s8vector-ref))
92(define u8vector-foldi  (make-vector-foldi u8vector-length u8vector-ref))
93
94
95(define (f64vector-map f v . rest) 
96  (let ((n (f64vector-length v)))
97    (f64vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (f64vector-ref v i)) (cons v rest))))))
98(define (f32vector-map f v . rest) 
99  (let ((n (f32vector-length v)))
100    (f32vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (f32vector-ref v i)) (cons v rest))))))
101(define (s32vector-map f v . rest) 
102  (let ((n (s32vector-length v)))
103    (s32vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (s32vector-ref v i)) (cons v rest))))))
104(define (u32vector-map f v . rest) 
105  (let ((n (u32vector-length v)))
106    (u32vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (u32vector-ref v i)) (cons v rest))))))
107(define (s16vector-map f v . rest) 
108  (let ((n (s16vector-length v)))
109    (s16vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (s16vector-ref v i)) (cons v rest))))))
110(define (u16vector-map f v . rest) 
111  (let ((n (u16vector-length v)))
112    (u16vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (u16vector-ref v i)) (cons v rest))))))
113(define (s8vector-map f v . rest) 
114  (let ((n (s8vector-length v)))
115    (s8vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (s8vector-ref v i)) (cons v rest))))))
116(define (u8vector-map f v . rest) 
117  (let ((n (u8vector-length v)))
118    (u8vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (u8vector-ref v i)) (cons v rest))))))
119
120
121(define (f64vector-mapi f v . rest) 
122  (let ((n (f64vector-length v)))
123    (f64vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (f64vector-ref v i)) (cons v rest)))))))
124(define (f32vector-mapi f v . rest) 
125  (let ((n (f32vector-length v)))
126    (f32vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (f32vector-ref v i)) (cons v rest)))))))
127(define (s32vector-mapi f v . rest) 
128  (let ((n (s32vector-length v)))
129    (s32vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (s32vector-ref v i)) (cons v rest)))))))
130(define (u32vector-mapi f v . rest) 
131  (let ((n (u32vector-length v)))
132    (u32vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (u32vector-ref v i)) (cons v rest)))))))
133(define (s16vector-mapi f v . rest) 
134  (let ((n (s16vector-length v)))
135    (s16vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (s16vector-ref v i)) (cons v rest)))))))
136(define (u16vector-mapi f v . rest) 
137  (let ((n (u16vector-length v)))
138    (u16vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (u16vector-ref v i)) (cons v rest)))))))
139(define (s8vector-mapi f v . rest) 
140  (let ((n (s8vector-length v)))
141    (s8vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (s8vector-ref v i)) (cons v rest)))))))
142(define (u8vector-mapi f v . rest) 
143  (let ((n (u8vector-length v)))
144    (u8vector-of-length-ec n (:range i 0 n) (apply f (cons i (map (lambda (v) (u8vector-ref v i)) (cons v rest)))))))
145
146
147(define (f64vector-take v n) 
148  (f64vector-of-length-ec n (:range i 0 n) (f64vector-ref v i)))
149(define (f32vector-take v n) 
150  (f32vector-of-length-ec n (:range i 0 n) (f32vector-ref v i)))
151(define (s32vector-take v n) 
152  (s32vector-of-length-ec n (:range i 0 n) (s32vector-ref v i)))
153(define (u32vector-take v n) 
154  (u32vector-of-length-ec n (:range i 0 n) (u32vector-ref v i)))
155(define (s16vector-take v n) 
156  (s16vector-of-length-ec n (:range i 0 n) (s16vector-ref v i)))
157(define (u16vector-take v n) 
158  (u16vector-of-length-ec n (:range i 0 n) (u16vector-ref v i)))
159(define (s8vector-take v n) 
160  (s8vector-of-length-ec n (:range i 0 n) (s8vector-ref v i)))
161(define (u8vector-take v n) 
162  (u8vector-of-length-ec n (:range i 0 n) (u8vector-ref v i)))
163
164
165
166;;
167;; In-place quick sort from SRFI-32 reference implementation.
168;; Modified so that the comparison function uses element indices as
169;; well as element values:
170;;
171;; elt< :: i1 v1 i2 v2 -> boolean
172;;
173;; Copyright (c) 1998 by Olin Shivers. You may do as you please with
174;; this code, as long as you do not delete this notice or hold me
175;; responsible for any outcome related to its use.
176;;
177
178(define (srfi-4-vector-quick-sort! vector-ref vector-set! vector-length)
179  (lambda (elt< v . rest)
180   (let-optionals rest ((start 0) (end (vector-length v)))
181    (let recur ((l start) (r end))      ; Sort the range [l,r).
182      (if (fx< 1 (fx- r l))
183         
184          ;; Choose the median of V[l], V[r], and V[middle] for the pivot.
185          (let ((median
186                 (lambda (i1 i2 i3)
187                   (let ((v1 (vector-ref v i1))
188                         (v2 (vector-ref v i2))
189                         (v3 (vector-ref v i3)))
190                     (receive (ilittle little ibig big)
191                              (if (elt< i1 v1 i2 v2) (values i1 v1 i2 v2) (values i2 v2 i1 v1))
192                              (if (elt< ibig big i3 v3) 
193                                  (values ibig big)
194                                  (if (elt< ilittle little i3 v3) 
195                                      (values i3 v3) 
196                                      (values ilittle little))))))))
197           
198            (let-values (((ipivot pivot) (median l (quotient (fx+ l r) 2) (fx- r 1))))
199              (let loop ((i l) (j (fx- r 1)))
200                (let ((i (let scan ((i i)) (if (elt< i (vector-ref v i) ipivot pivot)
201                                               (scan (fx+ i 1))
202                                               i)))
203                      (j (let scan ((j j)) (if (elt< ipivot pivot j (vector-ref v j))
204                                               (scan (fx- j 1))
205                                               j))))
206                  (if (fx< i j)
207                      (let ((tmp (vector-ref v j)))             
208                        (vector-set! v j (vector-ref v i))      ; Swap V[I]
209                        (vector-set! v i tmp)           ;  and V[J].
210                        (loop (fx+ i 1) (fx- j 1)))
211                     
212                      (begin (recur l i) (recur (fx+ j 1) r)))))))
213          v)))))
214
215
216(define f64vector-quick-sort!
217  (srfi-4-vector-quick-sort! f64vector-ref f64vector-set! f64vector-length))
218(define f32vector-quick-sort!
219  (srfi-4-vector-quick-sort! f32vector-ref f32vector-set! f32vector-length))
220(define s32vector-quick-sort!
221  (srfi-4-vector-quick-sort! s32vector-ref s32vector-set! s32vector-length))
222(define u32vector-quick-sort!
223  (srfi-4-vector-quick-sort! u32vector-ref u32vector-set! u32vector-length))
224(define s16vector-quick-sort!
225  (srfi-4-vector-quick-sort! s16vector-ref s16vector-set! s16vector-length))
226(define u16vector-quick-sort!
227  (srfi-4-vector-quick-sort! u16vector-ref u16vector-set! u16vector-length))
228(define s8vector-quick-sort!
229  (srfi-4-vector-quick-sort! s8vector-ref s8vector-set! s8vector-length))
230(define u8vector-quick-sort!
231  (srfi-4-vector-quick-sort! u8vector-ref u8vector-set! u8vector-length))
232
233
234; Blit FROM[I,END) to TO[J,?].
235
236(define (srfi-4-vector-blit! vector-ref vector-set! )
237  (lambda (from i end to j)     
238    (assert (< i end))
239    (let recur ((i i) (j j))
240      (if (< i end)
241          (let ((vi (vector-ref from i)))
242            (vector-set! to j vi)
243            (recur (+ i 1) (+ j 1)))
244          ))
245      ))
246
247
248(define f64vector-blit!
249  (srfi-4-vector-blit! f64vector-ref f64vector-set!))
250(define f32vector-blit!
251  (srfi-4-vector-blit! f32vector-ref f32vector-set!))
252(define s32vector-blit!
253  (srfi-4-vector-blit! s32vector-ref s32vector-set!))
254(define u32vector-blit!
255  (srfi-4-vector-blit! u32vector-ref u32vector-set!))
256(define s16vector-blit!
257  (srfi-4-vector-blit! s16vector-ref s16vector-set!))
258(define u16vector-blit!
259  (srfi-4-vector-blit! u16vector-ref u16vector-set!))
260(define s8vector-blit!
261  (srfi-4-vector-blit! s8vector-ref s8vector-set!))
262(define u8vector-blit!
263  (srfi-4-vector-blit! u8vector-ref u8vector-set!))
264
265
266;; Given array A and indices p, q, r such that p < q < r,
267;; merge subarray A[p..q) and subarray A[q..r) into array B[n..]
268
269(define (srfi-4-vector-merge! vector-ref vector-set! vblit! vector-length)
270  (lambda (elt< a p q r b n)
271    (assert (and (< p q) (< q r)))
272    (let recur ((i p) (j q) (k n))
273      (if (and (< i q) (< j r))
274          (let ((ai (vector-ref a i))
275                (bj (vector-ref a j)))
276            (if (elt< i ai j bj)
277                (begin
278                  (vector-set! b k ai)
279                  (recur (+ 1 i) j (+ 1 k)))
280                (begin
281                  (vector-set! b k bj)
282                  (recur i (+ 1 j) (+ 1 k)))
283                ))
284          (if (< i q)
285              (vblit! a i q b k)
286              (if (< j r)
287                  (vblit! a j r b k))))
288      )
289    b)
290  )
291
292
293
294(define f64vector-merge!
295  (srfi-4-vector-merge! f64vector-ref f64vector-set! f64vector-blit! f64vector-length ))
296(define f32vector-merge!
297  (srfi-4-vector-merge! f32vector-ref f32vector-set! f32vector-blit! f32vector-length ))
298(define s32vector-merge!
299  (srfi-4-vector-merge! s32vector-ref s32vector-set! s32vector-blit! s32vector-length ))
300(define u32vector-merge!
301  (srfi-4-vector-merge! u32vector-ref u32vector-set! u32vector-blit! u32vector-length ))
302(define s16vector-merge!
303  (srfi-4-vector-merge! s16vector-ref s16vector-set! s16vector-blit! s16vector-length ))
304(define u16vector-merge!
305  (srfi-4-vector-merge! u16vector-ref u16vector-set! u16vector-blit! u16vector-length ))
306(define s8vector-merge!
307  (srfi-4-vector-merge! s8vector-ref s8vector-set! s8vector-blit! s8vector-length ))
308(define u8vector-merge!
309  (srfi-4-vector-merge! u8vector-ref u8vector-set! u8vector-blit! u8vector-length ))
310
311
312
313;; Vector merge sort
314(define (srfi-4-vector-merge-sort! vector-length vector-ref vector-set! vector-merge! vblit!)
315  (lambda (elt< a )
316    (let* ((n (vector-length a)) 
317           (b (make-f64vector n 0.)))
318      (let recur ((m 1))
319        (if (< m n)
320            (let inner-recur ((p 0))
321              (if (< p (- n m))
322                  (let ((q (+ p m))
323                        (r (min (+ p (* 2 m)) n)))
324                    (vector-merge! elt< a p q r b p)
325                    (vblit! b p r a p)
326                    (inner-recur (+ p (* 2 m)))
327                    )
328                  (recur (* m 2))))
329            a)))
330    ))
331           
332
333                   
334
335(define f64vector-merge-sort!
336  (srfi-4-vector-merge-sort! f64vector-length f64vector-ref f64vector-set! f64vector-merge! f64vector-blit!))
337
338(define f32vector-merge-sort!
339  (srfi-4-vector-merge-sort! f32vector-length f32vector-ref f32vector-set! f32vector-merge! f32vector-blit!))
340
341(define s32vector-merge-sort!
342  (srfi-4-vector-merge-sort! s32vector-length s32vector-ref s32vector-set! s32vector-merge! s32vector-blit!))
343
344(define u32vector-merge-sort!
345  (srfi-4-vector-merge-sort! u32vector-length u32vector-ref u32vector-set! u32vector-merge! u32vector-blit!))
346
347(define s16vector-merge-sort!
348  (srfi-4-vector-merge-sort! s16vector-length s16vector-ref s16vector-set! s16vector-merge! s16vector-blit!))
349
350(define u16vector-merge-sort!
351  (srfi-4-vector-merge-sort! u16vector-length u16vector-ref u16vector-set! u16vector-merge! u16vector-blit!))
352
353(define s8vector-merge-sort!
354  (srfi-4-vector-merge-sort! s8vector-length s8vector-ref s8vector-set! s8vector-merge! s8vector-blit!))
355
356(define u8vector-merge-sort!
357  (srfi-4-vector-merge-sort! u8vector-length u8vector-ref u8vector-set! u8vector-merge! u8vector-blit!))
358
359)
Note: See TracBrowser for help on using the repository browser.