Ticket #975: srfi-4-utils-test.scm

File srfi-4-utils-test.scm, 1.7 KB (added by Ivan Raikov, 9 years ago)
Line 
1
2
3(import scheme chicken)
4(require-library srfi-1 extras)
5(import (only srfi-1 fold every)
6        (only extras printf))
7(require-extension srfi-4)
8
9; Blit FROM[I,END) to TO[J,?].
10
11(define (srfi-4-vector-blit! vector-ref vector-set! )
12  (lambda (from i end to j)     
13    (assert (< i end))
14    (let recur ((i i) (j j))
15      (if (< i end)
16          (let ((vi (vector-ref from i)))
17            (vector-set! to j vi)
18            (recur (+ i 1) (+ j 1)))
19          ))
20      ))
21
22
23(define f64vector-blit!
24  (srfi-4-vector-blit! f64vector-ref f64vector-set!))
25
26
27;; Given array A and indices p, q, r such that p < q < r,
28;; merge subarray A[p..q) and subarray A[q..r) into array B[n..]
29
30(define (srfi-4-vector-merge! vector-ref vector-set! vblit! vector-length)
31  (lambda (elt< a p q r b n)
32    (assert (and (< p q) (< q r) (<= (vector-length a) r)))
33    (let recur ((i p) (j q) (k n))
34      (if (and (< i q) (< j r))
35          (let ((ai (vector-ref a i))
36                (bj (vector-ref a j)))
37            (if (elt< i ai j bj)
38                (begin
39                  (vector-set! b k ai)
40                  (recur (+ 1 i) j (+ 1 k)))
41                (begin
42                  (vector-set! b k bj)
43                  (recur i (+ 1 j) (+ 1 k)))
44                ))
45          (if (< i q)
46              (vblit! a i q b k)
47              (if (< j r)
48                  (vblit! a j r b k))))
49      b
50      ))
51  )
52
53
54
55(define f64vector-merge!
56  (srfi-4-vector-merge! f64vector-ref f64vector-set! f64vector-blit! f64vector-length ))
57
58(define (elt< i vi j vj) (< vi vj))
59
60(define a (make-f64vector (inexact->exact 1e6) 1.))
61(define b (make-f64vector (inexact->exact 1e6) .))
62
63(time (f64vector-merge! elt< a 0 (inexact->exact 5e5) (inexact->exact 1e6) b 0))