Changeset 27348 in project for release/4/kd-tree/trunk/kd-tree.scm


Ignore:
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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/kd-tree/trunk/kd-tree.scm

    r27343 r27348  
    1 ;; http://en.wikipedia.org/wiki/K-d_tree
     1;;
     2;; An implementation of the K-D tree spatial indexing data structures.
     3;;  http://en.wikipedia.org/wiki/K-d_tree
     4;;
     5;; This code is based on the Haskell kd-tree library implementation of
     6;; K-D trees.
     7;;
     8;; Copyright 2012 Ivan Raikov and the Okinawa Institute of
     9;; Science and Technology.
     10;;
     11;; This program is free software: you can redistribute it and/or
     12;; modify it under the terms of the GNU General Public License as
     13;; published by the Free Software Foundation, either version 3 of the
     14;; License, or (at your option) any later version.
     15;;
     16;; This program is distributed in the hope that it will be useful, but
     17;; WITHOUT ANY WARRANTY; without even the implied warranty of
     18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
     19;; General Public License for more details.
     20;;
     21;; A full copy of the GPL license can be found at
     22;; <http://www.gnu.org/licenses/>.
     23;;
    224
    325(module kd-tree
     
    497519 
    498520   
    499   ;; nearNeighbors tree p returns all neighbors within distance r from p in tree t.
     521  ;; near-neighbors t r p returns all neighbors within distance r from p in tree t.
    500522
    501523  (define=> (make-kd-tree-near-neighbors <Point>)
    502524    (define (tree-empty? t) (cases kd-tree t (KdLeaf (ii pp vv axis) (cis:empty? ii)) (else #f)))
    503525    (letrec ((near-neighbors
    504               (lambda (t radius probe fdist)
     526              (lambda (t radius probe fdist filter-fn)
    505527                (cases kd-tree t
    506528                       (KdLeaf (ii pp vv axis) 
    507529                               (let ((r2 (* radius radius)))
    508                                  (filter (lambda (p) (<= (fdist probe p) r2)) pp)))
     530                                 (filter-fn probe pp r2)))
    509531
    510532                       (KdNode (l p i v r axis ci)
    511                                (let ((maybe-pivot
    512                                       (if (<= (fdist probe p) (* radius radius)) (list p) '())))
     533                               (let ((maybe-pivot (filter-fn probe (list p) (* radius radius))))
    513534                                 
    514535                                 (if (and (tree-empty? l)
     
    522543                                       (if (<= x-probe xp)
    523544
    524                                            (let ((nearest (append maybe-pivot (near-neighbors l radius probe fdist))))
     545                                           (let ((nearest (append maybe-pivot (near-neighbors l radius probe fdist filter-fn))))
    525546                                             (if (> (+ x-probe (abs radius)) xp)
    526                                                  (append (near-neighbors r radius probe fdist) nearest)
     547                                                 (append (near-neighbors r radius probe fdist filter-fn) nearest)
    527548                                                 nearest))
    528549
    529                                            (let ((nearest (append maybe-pivot (near-neighbors r radius probe fdist))))
     550                                           (let ((nearest (append maybe-pivot (near-neighbors r radius probe fdist filter-fn))))
    530551                                             (if (< (- x-probe (abs radius)) xp)
    531                                                  (append (near-neighbors l radius probe fdist) nearest)
     552                                                 (append (near-neighbors l radius probe fdist filter-fn) nearest)
    532553                                                 nearest)))
    533554                                       ))))
    534555                       ))
    535556              ))
    536       (lambda (t radius probe #!key (factors #f))
    537         (if (not factors)
    538             (near-neighbors t radius probe dist2)
    539             (near-neighbors t radius probe (sdist2 factors))))
     557      (lambda (t radius probe #!key (factors #f) (with-distance? #f))
     558        (let* ((dist-fn (if factors (sdist2 factors) dist2))
     559               (filter-fn (if with-distance?
     560                              (lambda (probe pp d2) (filter-map (lambda (p) (let ((pd (dist-fn probe p)))
     561                                                                              (and (<= pd d2) (list p (sqrt pd) )))) pp))
     562                              (lambda (probe pp d2) (filter (lambda (p) (<= (dist-fn probe p) d2)) pp))
     563                              ))
     564               )
     565
     566          (near-neighbors t radius probe dist-fn filter-fn)
     567          ))
    540568      ))
    541  
    542569
    543570
     
    545572    (define (tree-empty? t) (cases kd-tree t (KdLeaf (ii pp vv axis) (cis:empty? ii)) (else #f)))
    546573    (letrec ((near-neighbors
    547               (lambda (t radius probe fdist)
     574              (lambda (t radius probe fdist filter-fn)
    548575                (cases kd-tree t
    549576
    550577                       (KdLeaf (ii pp vv axis) 
    551                                (let ((rr (* radius radius)))
    552                                  (if vv
    553                                      (filter-map (lambda (i v p) (and (<= (fdist probe p) rr) (list (list i v) p)))
    554                                                  (reverse (cis:elements ii)) vv pp)
    555                                      (filter-map (lambda (i p) (and (<= (fdist probe p) rr) (list i p)))
    556                                                  (reverse (cis:elements ii)) pp)
    557                                      )))
    558                                              
     578                               (let ((r2 (* radius radius)))
     579                                 (filter-fn probe pp ii vv r2)))
    559580
    560581                       (KdNode (l p i v r axis ci)
    561                                (let ((maybe-pivot
    562                                       (if (<= (fdist probe p) (* radius radius))
    563                                           (if v (list (list (list i v) p))
    564                                               (list (list i p)) )
    565                                           '())))
     582                               (let ((maybe-pivot (filter-fn probe (list p) (list i) (list v) (* radius radius))))
    566583
    567584                                 (if (and (tree-empty? l)
     
    575592                                       (if (<= x-probe xp)
    576593
    577                                            (let ((nearest (append maybe-pivot (near-neighbors l radius probe fdist))))
     594                                           (let ((nearest (append maybe-pivot (near-neighbors l radius probe fdist filter-fn))))
    578595                                             (if (> (+ x-probe (abs radius)) xp)
    579                                                  (append (near-neighbors r radius probe fdist) nearest)
     596                                                 (append (near-neighbors r radius probe fdist filter-fn) nearest)
    580597                                                 nearest))
    581598
    582                                            (let ((nearest (append maybe-pivot (near-neighbors r radius probe fdist))))
     599                                           (let ((nearest (append maybe-pivot (near-neighbors r radius probe fdist filter-fn))))
    583600                                             (if (< (- x-probe (abs radius)) xp)
    584                                                  (append (near-neighbors l radius probe fdist) nearest)
     601                                                 (append (near-neighbors l radius probe fdist filter-fn) nearest)
    585602                                                 nearest)))
    586603                                       ))
     
    588605                       ))
    589606              ))
    590       (lambda (t radius probe #!key (factors #f))
    591         (if (not factors)
    592             (near-neighbors t radius probe dist2)
    593             (near-neighbors t radius probe (sdist2 factors))))
     607      (lambda (t radius probe #!key (factors #f) (with-distance? #f))
     608        (let* ((dist-fn (if factors (sdist2 factors) dist2))
     609               (filter-fn (if with-distance?
     610                              (lambda (probe pp ii vv r2)
     611                                 (if vv
     612                                     (filter-map (lambda (i v p) (let ((pd (dist-fn probe p))) (and (<= pd r2) (list (list i v) p (sqrt pd)))))
     613                                                 (reverse (cis:elements ii)) vv pp)
     614                                     (filter-map (lambda (i p) (let ((pd (dist-fn probe p))) (and (<= pd r2) (list i p (sqrt pd)))))
     615                                                 (reverse (cis:elements ii)) pp)
     616                                     ))
     617                              (lambda (probe pp ii vv r2)
     618                                 (if vv
     619                                     (filter-map (lambda (i v p) (and (<= (dist-fn probe p) r2) (list (list i v) p)))
     620                                                 (reverse (cis:elements ii)) vv pp)
     621                                     (filter-map (lambda (i p) (and (<= (dist-fn probe p) r2) (list i p)))
     622                                                 (reverse (cis:elements ii)) pp)
     623                                     ))
     624                              ))
     625               )
     626
     627          (near-neighbors t radius probe dist-fn filter-fn)
     628
     629          ))
    594630      ))
    595631 
Note: See TracChangeset for help on using the changeset viewer.