Changeset 25912 in project


Ignore:
Timestamp:
02/15/12 08:00:43 (8 years ago)
Author:
Ivan Raikov
Message:

spatial-trees: bug fixes and testsuite for kd-tree

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  
    2525  (import scheme chicken data-structures)
    2626 
    27   (require-library srfi-1)
     27  (require-library srfi-1 extras)
    2828  (require-extension typeclass datatype)
    2929
    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))
    3132
    3233
     
    4647
    4748    )
     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          )))
    4859
    4960  (define (sum lst) (fold + 0. lst))
     
    5364            (lambda (a b)
    5465              (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)))))
    5667
    5768           (compare-distance
     
    7586    )
    7687
     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             ))
    7794
    7895  (define Point-point3d
     
    99116                            (sort points (lambda (a b) (< (coord axis a) (coord axis b)))))
    100117                           (median-index
    101                             (quotient (length sorted-points) 2)))
    102                      
     118                            (quotient (- (length sorted-points) 1) 2)))
     119
    103120                      (KdNode (list->kd-tree/depth (take sorted-points median-index) (+ 1 depth))
    104121                              (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))
    106123                              axis)
    107124                      ))
     
    116133    (letrec ((find-nearest
    117134              (lambda (t1 t2 p probe xp x-probe)
     135
    118136                (let* ((candidates1
    119137                        (let ((best1 (nearest-neighbor t1 probe)))
    120138                          (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
    123144                       (candidates2
    124145                        (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))
    126148                            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))))
    128151                  )))
     152
    129153             
    130154             (nearest-neighbor
     
    137161                                        (let ((x-probe (coord axis probe))
    138162                                              (xp (coord axis p)))
     163
    139164                                          (if (<= x-probe xp)
    140165                                              (find-nearest l r p probe xp x-probe)
     
    234259             (KdNode (l p r axis)
    235260                     (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)))))
    238265             )))
    239266 
Note: See TracChangeset for help on using the changeset viewer.