Changeset 25912 in project
- Timestamp:
- 02/15/12 08:00:43 (9 years ago)
- Location:
- release/4/spatial-trees/trunk
- Files:
-
- 2 added
- 2 deleted
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/spatial-trees/trunk/kd-tree.scm
r25904 r25912 25 25 (import scheme chicken data-structures) 26 26 27 (require-library srfi-1 )27 (require-library srfi-1 extras) 28 28 (require-extension typeclass datatype) 29 29 30 (import (only srfi-1 fold list-tabulate drop take every)) 30 (import (only srfi-1 xcons fold list-tabulate drop take every) 31 (only extras fprintf)) 31 32 32 33 … … 46 47 47 48 ) 49 50 (define (minimum-by lst less?) 51 (if (null? lst) #f 52 (let recur ((lst (cdr lst)) (m (car lst))) 53 (if (null? lst) m 54 (if (less? (car lst) m) 55 (recur (cdr lst) (car lst)) 56 (recur (cdr lst) m) 57 )) 58 ))) 48 59 49 60 (define (sum lst) (fold + 0. lst)) … … 53 64 (lambda (a b) 54 65 (let ((diff2 (lambda (i) (let ((v (- (coord i a) (coord i b)))) (* v v))))) 55 (sum (list-tabulate ( - (dimension a) 1) diff2)))))66 (sum (list-tabulate (dimension a) diff2))))) 56 67 57 68 (compare-distance … … 75 86 ) 76 87 88 (define-record-printer (point3d p out) 89 (fprintf out "#<~a,~a,~a>" 90 (point3d-x p) 91 (point3d-y p) 92 (point3d-z p) 93 )) 77 94 78 95 (define Point-point3d … … 99 116 (sort points (lambda (a b) (< (coord axis a) (coord axis b))))) 100 117 (median-index 101 (quotient ( length sorted-points) 2)))102 118 (quotient (- (length sorted-points) 1) 2))) 119 103 120 (KdNode (list->kd-tree/depth (take sorted-points median-index) (+ 1 depth)) 104 121 (list-ref sorted-points median-index) 105 (list->kd-tree/depth (drop sorted-points (+ 1 median-index)) (+ 1 depth))122 (list->kd-tree/depth (drop sorted-points (+ median-index 1)) (+ 1 depth)) 106 123 axis) 107 124 )) … … 116 133 (letrec ((find-nearest 117 134 (lambda (t1 t2 p probe xp x-probe) 135 118 136 (let* ((candidates1 119 137 (let ((best1 (nearest-neighbor t1 probe))) 120 138 (or (and best1 (list best1 p)) (list p)))) 121 (sphere-intersects-plane? 122 (<= (expt (- x-probe xp) 2.) (dist2 probe p))) 139 140 (sphere-intersects-plane? 141 (let ((v (- x-probe xp))) 142 (< (* v v) (dist2 probe (car candidates1))))) 143 123 144 (candidates2 124 145 (if sphere-intersects-plane? 125 (append candidates1 (or (nearest-neighbor t2 probe) '())) 146 (let ((nn (nearest-neighbor t2 probe))) 147 (if nn (append candidates1 (list nn)) candidates1)) 126 148 candidates1))) 127 (car (sort candidates2 (lambda (a b) (positive? (compare-distance probe a b))))) 149 150 (minimum-by candidates2 (lambda (a b) (negative? (compare-distance probe a b)))) 128 151 ))) 152 129 153 130 154 (nearest-neighbor … … 137 161 (let ((x-probe (coord axis probe)) 138 162 (xp (coord axis p))) 163 139 164 (if (<= x-probe xp) 140 165 (find-nearest l r p probe xp x-probe) … … 234 259 (KdNode (l p r axis) 235 260 (let ((x (coord axis p))) 236 (and (every (lambda (y) (<= x (coord axis y))) (kd-tree->list l)) 237 (every (lambda (y) (<= x (coord axis y))) (kd-tree->list r))))) 261 (and (every (lambda (y) (<= (coord axis y) x )) 262 (kd-tree->list l)) 263 (every (lambda (y) (>= (coord axis y) x)) 264 (kd-tree->list r))))) 238 265 ))) 239 266
Note: See TracChangeset
for help on using the changeset viewer.