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)) |
---|