Changeset 27348 in project

Timestamp:

09/01/12 07:08:13 (9 years ago)

Author:

Ivan Raikov

Message:

kd-tree: extended kd-tree-near-neighbors with with-distance? flag and version set to 4.0

Location:

release/4/kd-tree/trunk

Files:

• kd-tree.scm (modified) (6 diffs)
• kd-tree.setup (modified) (1 diff)

release/4/kd-tree/trunk/kd-tree.scm

@@ -1 @@
-;; http://en.wikipedia.org/wiki/K-d_tree
+;;
+;; An implementation of the K-D tree spatial indexing data structures.
+;;  http://en.wikipedia.org/wiki/K-d_tree
+;;
+;; This code is based on the Haskell kd-tree library implementation of
+;; K-D trees.
+;;
+;; Copyright 2012 Ivan Raikov and the Okinawa Institute of
+;; Science and Technology.
+;;
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; A full copy of the GPL license can be found at
+;; <http://www.gnu.org/licenses/>.
+;;
 
 (module kd-tree
@@ -497 +519 @@
   
     
-  ;; nearNeighbors tree p returns all neighbors within distance r from p in tree t.
+  ;; near-neighbors t r p returns all neighbors within distance r from p in tree t.
 
   (define=> (make-kd-tree-near-neighbors <Point>)
     (define (tree-empty? t) (cases kd-tree t (KdLeaf (ii pp vv axis) (cis:empty? ii)) (else #f)))
     (letrec ((near-neighbors
-              (lambda (t radius probe fdist)
+              (lambda (t radius probe fdist filter-fn)
                 (cases kd-tree t
                        (KdLeaf (ii pp vv axis)  
                                (let ((r2 (* radius radius)))
-                                 (filter (lambda (p) (<= (fdist probe p) r2)) pp)))
+                                 (filter-fn probe pp r2)))
 
                        (KdNode (l p i v r axis ci)
-                               (let ((maybe-pivot
-                                      (if (<= (fdist probe p) (* radius radius)) (list p) '())))
+                               (let ((maybe-pivot (filter-fn probe (list p) (* radius radius))))
                                  
                                  (if (and (tree-empty? l)
@@ -522 +543 @@
                                        (if (<= x-probe xp)
 
-                                           (let ((nearest (append maybe-pivot (near-neighbors l radius probe fdist))))
+                                           (let ((nearest (append maybe-pivot (near-neighbors l radius probe fdist filter-fn))))
                                              (if (> (+ x-probe (abs radius)) xp)
-                                                 (append (near-neighbors r radius probe fdist) nearest)
+                                                 (append (near-neighbors r radius probe fdist filter-fn) nearest)
                                                  nearest))
 
-                                           (let ((nearest (append maybe-pivot (near-neighbors r radius probe fdist))))
+                                           (let ((nearest (append maybe-pivot (near-neighbors r radius probe fdist filter-fn))))
                                              (if (< (- x-probe (abs radius)) xp)
-                                                 (append (near-neighbors l radius probe fdist) nearest)
+                                                 (append (near-neighbors l radius probe fdist filter-fn) nearest)
                                                  nearest)))
                                        ))))
                        ))
               ))
-      (lambda (t radius probe #!key (factors #f))
-        (if (not factors)
-            (near-neighbors t radius probe dist2)
-            (near-neighbors t radius probe (sdist2 factors))))
+      (lambda (t radius probe #!key (factors #f) (with-distance? #f))
+        (let* ((dist-fn (if factors (sdist2 factors) dist2))
+               (filter-fn (if with-distance? 
+                              (lambda (probe pp d2) (filter-map (lambda (p) (let ((pd (dist-fn probe p)))
+                                                                              (and (<= pd d2) (list p (sqrt pd) )))) pp))
+                              (lambda (probe pp d2) (filter (lambda (p) (<= (dist-fn probe p) d2)) pp))
+                              ))
+               )
+
+          (near-neighbors t radius probe dist-fn filter-fn)
+          ))
       ))
-  
 
 
@@ -545 +572 @@
     (define (tree-empty? t) (cases kd-tree t (KdLeaf (ii pp vv axis) (cis:empty? ii)) (else #f)))
     (letrec ((near-neighbors
-              (lambda (t radius probe fdist)
+              (lambda (t radius probe fdist filter-fn)
                 (cases kd-tree t
 
                        (KdLeaf (ii pp vv axis)  
-                               (let ((rr (* radius radius)))
-                                 (if vv 
-                                     (filter-map (lambda (i v p) (and (<= (fdist probe p) rr) (list (list i v) p)))
-                                                 (reverse (cis:elements ii)) vv pp)
-                                     (filter-map (lambda (i p) (and (<= (fdist probe p) rr) (list i p)))
-                                                 (reverse (cis:elements ii)) pp)
-                                     )))
-                                             
+                               (let ((r2 (* radius radius)))
+                                 (filter-fn probe pp ii vv r2)))
 
                        (KdNode (l p i v r axis ci)
-                               (let ((maybe-pivot
-                                      (if (<= (fdist probe p) (* radius radius))
-                                          (if v (list (list (list i v) p))
-                                              (list (list i p)) )
-                                          '())))
+                               (let ((maybe-pivot (filter-fn probe (list p) (list i) (list v) (* radius radius))))
 
                                  (if (and (tree-empty? l)
@@ -575 +592 @@
                                        (if (<= x-probe xp)
 
-                                           (let ((nearest (append maybe-pivot (near-neighbors l radius probe fdist))))
+                                           (let ((nearest (append maybe-pivot (near-neighbors l radius probe fdist filter-fn))))
                                              (if (> (+ x-probe (abs radius)) xp)
-                                                 (append (near-neighbors r radius probe fdist) nearest)
+                                                 (append (near-neighbors r radius probe fdist filter-fn) nearest)
                                                  nearest))
 
-                                           (let ((nearest (append maybe-pivot (near-neighbors r radius probe fdist))))
+                                           (let ((nearest (append maybe-pivot (near-neighbors r radius probe fdist filter-fn))))
                                              (if (< (- x-probe (abs radius)) xp)
-                                                 (append (near-neighbors l radius probe fdist) nearest)
+                                                 (append (near-neighbors l radius probe fdist filter-fn) nearest)
                                                  nearest)))
                                        ))
@@ -588 +605 @@
                        ))
               ))
-      (lambda (t radius probe #!key (factors #f))
-        (if (not factors)
-            (near-neighbors t radius probe dist2)
-            (near-neighbors t radius probe (sdist2 factors))))
+      (lambda (t radius probe #!key (factors #f) (with-distance? #f))
+        (let* ((dist-fn (if factors (sdist2 factors) dist2))
+               (filter-fn (if with-distance? 
+                              (lambda (probe pp ii vv r2)
+                                 (if vv 
+                                     (filter-map (lambda (i v p) (let ((pd (dist-fn probe p))) (and (<= pd r2) (list (list i v) p (sqrt pd)))))
+                                                 (reverse (cis:elements ii)) vv pp)
+                                     (filter-map (lambda (i p) (let ((pd (dist-fn probe p))) (and (<= pd r2) (list i p (sqrt pd)))))
+                                                 (reverse (cis:elements ii)) pp)
+                                     ))
+                              (lambda (probe pp ii vv r2)
+                                 (if vv 
+                                     (filter-map (lambda (i v p) (and (<= (dist-fn probe p) r2) (list (list i v) p)))
+                                                 (reverse (cis:elements ii)) vv pp)
+                                     (filter-map (lambda (i p) (and (<= (dist-fn probe p) r2) (list i p)))
+                                                 (reverse (cis:elements ii)) pp)
+                                     ))
+                              ))
+               )
+
+          (near-neighbors t radius probe dist-fn filter-fn)
+
+          ))
       ))
   

release/4/kd-tree/trunk/kd-tree.setup

@@ -16 +16 @@
   
   ;; Assoc list with properties for your extension:
-  '((version 3.3)
+  '((version 4.0)
     ))