Changeset 27348 in project
- Timestamp:
- 09/01/12 07:08:13 (9 years ago)
- Location:
- release/4/kd-tree/trunk
- Files:
-
- 2 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 ;; 2 24 3 25 (module kd-tree … … 497 519 498 520 499 ;; near Neighbors treep 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. 500 522 501 523 (define=> (make-kd-tree-near-neighbors <Point>) 502 524 (define (tree-empty? t) (cases kd-tree t (KdLeaf (ii pp vv axis) (cis:empty? ii)) (else #f))) 503 525 (letrec ((near-neighbors 504 (lambda (t radius probe fdist )526 (lambda (t radius probe fdist filter-fn) 505 527 (cases kd-tree t 506 528 (KdLeaf (ii pp vv axis) 507 529 (let ((r2 (* radius radius))) 508 (filter (lambda (p) (<= (fdist probe p) r2)) pp)))530 (filter-fn probe pp r2))) 509 531 510 532 (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)))) 513 534 514 535 (if (and (tree-empty? l) … … 522 543 (if (<= x-probe xp) 523 544 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)))) 525 546 (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) 527 548 nearest)) 528 549 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)))) 530 551 (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) 532 553 nearest))) 533 554 )))) 534 555 )) 535 556 )) 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 )) 540 568 )) 541 542 569 543 570 … … 545 572 (define (tree-empty? t) (cases kd-tree t (KdLeaf (ii pp vv axis) (cis:empty? ii)) (else #f))) 546 573 (letrec ((near-neighbors 547 (lambda (t radius probe fdist )574 (lambda (t radius probe fdist filter-fn) 548 575 (cases kd-tree t 549 576 550 577 (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))) 559 580 560 581 (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)))) 566 583 567 584 (if (and (tree-empty? l) … … 575 592 (if (<= x-probe xp) 576 593 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)))) 578 595 (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) 580 597 nearest)) 581 598 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)))) 583 600 (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) 585 602 nearest))) 586 603 )) … … 588 605 )) 589 606 )) 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 )) 594 630 )) 595 631 -
release/4/kd-tree/trunk/kd-tree.setup
r27344 r27348 16 16 17 17 ;; Assoc list with properties for your extension: 18 '((version 3.3)18 '((version 4.0) 19 19 ))
Note: See TracChangeset
for help on using the changeset viewer.