source: project/release/4/spatial-trees/tags/2.3/axial-vectors.scm @ 26910

Last change on this file since 26910 was 26910, checked in by Ivan Raikov, 9 years ago

spatial-trees release 2.3

File size: 2.6 KB
Line 
1(use srfi-4)   
2(define (axial-vectors-ref axv i) 
3  (map (lambda (x) (f64vector-ref x i)) axv))
4
5
6(define (axial-vectors-set! axv i vs) 
7  (for-each (lambda (x v) (f64vector-set! x i v)) axv vs))
8
9
10(define (axial-vectors-slice axv m n) 
11  (map (lambda (x) (f64vector-slice x m n)) axv))
12
13
14(define (axial-vectors-length axv) 
15  (car (map f64vector-length axv)))
16 
17
18(define (axial-vectors-swap axv i j)
19  (let ((t (axial-vectors-ref axv i)))
20    (axial-vectors-set! axv i (axial-vectors-ref axv j))
21    (axial-vectors-set! axv j t)))
22
23
24(define (axial-vectors-quick-sort! v elt< . rest)
25
26   (let-optionals rest ((start 0) (end (axial-vectors-length v)))
27
28    (let recur ((l start) (r end))      ; Sort the range [l,r).
29      (if (fx< 1 (fx- r l))
30         
31          ;; Choose the median of V[l], V[r], and V[middle] for the pivot.
32          (let ((median
33                 (lambda (i1 i2 i3)
34                   (let ((v1 (axial-vectors-ref v i1))
35                         (v2 (axial-vectors-ref v i2))
36                         (v3 (axial-vectors-ref v i3)))
37                     (receive (ilittle little ibig big)
38                              (if (elt< v1 v2) (values i1 v1 i2 v2) (values i2 v2 i1 v1))
39                              (if (elt< big v3) 
40                                  (values ibig big)
41                                  (if (elt< little v3) 
42                                      (values i3 v3) 
43                                      (values ilittle little))))))))
44           
45            (let-values (((ipivot pivot) (median l (quotient (fx+ l r) 2) (fx- r 1))))
46              (let loop ((i l) (j (fx- r 1)))
47                (let ((i (let scan ((i i)) (if (elt< (axial-vectors-ref v i) pivot)
48                                               (scan (fx+ i 1))
49                                               i)))
50                      (j (let scan ((j j)) (if (elt< pivot (axial-vectors-ref v j))
51                                               (scan (fx- j 1))
52                                               j))))
53                  (if (fx< i j)
54                      (let ((tmp (axial-vectors-ref v j)))             
55                        (axial-vectors-set! v j (axial-vectors-ref v i))        ; Swap V[I]
56                        (axial-vectors-set! v i tmp)            ;  and V[J].
57                        (loop (fx+ i 1) (fx- j 1)))
58                     
59                      (begin (recur l i) (recur (fx+ j 1) r)))))))
60          v))
61    ))
62
63#|
64(define v (list
65           (f64vector -0.222040417143891 -0.130686806836244 -1.1393810545548 -1.00134012588717 0.0924614903801722 0.42675256780991 0.551266501042691 0.625060401322083 0.883934414691624 1.21222958296103)
66           (f64vector -2.17154877253389 -0.834435142767373 0.225814871833791 0.437485236568444 1.21484732174379 -1.68427156225624 -0.0535433787075397 0.969658849385054 0.414706397978174 0.279138871747951)
67           (f64vector 0.520316303519054 0.0769195867181162 0.354078180046104 0.843539318556113 -1.03408418836396 -0.611541686998526 0.18774392065007 0.418251640058755 1.86917059941044 0.0956638351872146)))
68
69
70
71(print "v = ") (pp  v)
72
73(axial-vectors-quick-sort! v (lambda (x y) (< (list-ref x 1) (list-ref y 1))) 5 9)
74
75(print "sorted v = ") (pp v)
76|#
Note: See TracBrowser for help on using the repository browser.