Changeset 3216

Show
Ignore:
Timestamp:
05/30/08 13:32:21 (7 months ago)
Author:
ksprotte
Message:

branches/bos-trunk-sat: map-nodes takes an additional keyword arg ORDER,

that allows to specify :depth-first or :breadth-first traversal.

Functions like FIND-NODE-IF that build upon MAP-NODES also allow for
specifying the order.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • branches/bos-trunk-sat/projects/bos/web/quad-tree.lisp

    r3199 r3216  
    179179(defmethod print-object ((node node-extension) stream) 
    180180  (print-unreadable-object (node stream :type t :identity t) 
    181     (format stream "name: ~s" (name node)))) 
     181    (format stream "name: ~s path: ~s" (name node) (node-path node)))) 
    182182 
    183183(defun equal-extension-type (a b) 
    …… 
    278278      (ensure-intersecting-children (ensure-child node index) geo-box function leaf-test)))) 
    279279 
    280 (defun map-nodes (function node &key (prune-test (constantly nil))) 
    281   (funcall function node) 
    282   (dotimes (i 4) 
    283     (let ((child (child node i))) 
    284       (when (and child (not (funcall prune-test child))) 
    285         (map-nodes function child :prune-test prune-test))))) 
    286  
    287 (defun find-node-if (test node &key (prune-test (constantly nil))) 
     280(defun map-nodes-internal (nodes function prune-test remove-node add-node) 
     281  "Used by MAP-NODES for depth-first and breadth-first 
     282traversal. 
     283 
     284NODES is an opaque collection, that is accessed via the given 
     285functions REMOVE-NODE and ADD-NODE. 
     286 
     287REMOVE-NODE will be called with NODES and has to return two 
     288values: The removed node and the updated NODES. 
     289 
     290ADD-NODE will be called with a node to be added and NODES. It has 
     291to return the updated NODES. 
     292 
     293FUNCTION will be called on each visited node. 
     294 
     295If PRUNE-TEST returns true, the given node will not be visited." 
     296  (labels ((pop* () 
     297             (multiple-value-bind (node new-nodes) 
     298                 (funcall remove-node nodes) 
     299               (setq nodes new-nodes) 
     300               node)) 
     301           (push* (node) 
     302             (setq nodes (funcall add-node node nodes)))) 
     303    (let ((node (pop*))) 
     304      (when node 
     305        (funcall function node) 
     306        (dotimes (i 4) 
     307          (let ((child (child node i))) 
     308            (when (and child (not (funcall prune-test child))) 
     309              (push* child)))) 
     310        (map-nodes-internal nodes function prune-test remove-node add-node))))) 
     311 
     312(defun map-nodes-depth-first (function node prune-test) 
     313  ;; nodes is here a stack 
     314  (map-nodes-internal (list node) function prune-test 
     315                      (lambda (nodes) 
     316                        (values (car nodes) (cdr nodes))) 
     317                      (lambda (node nodes) 
     318                        (cons node nodes)))) 
     319 
     320(defun map-nodes-breadth-first (function node prune-test) 
     321  ;; nodes is here a queue 
     322  (let ((nodes (make-queue))) 
     323    (enqueue node nodes) 
     324    (map-nodes-internal nodes function prune-test 
     325                        (lambda (nodes) 
     326                          (values (dequeue nodes) nodes)) 
     327                        (lambda (node nodes) 
     328                          (enqueue node nodes) 
     329                          nodes)))) 
     330 
     331(defun map-nodes (function node &key (prune-test (constantly nil)) (order :depth-first))   
     332  (check-type order (member :depth-first :breadth-first)) 
     333  (let ((mapper (case order 
     334                  (:depth-first #'map-nodes-depth-first) 
     335                  (:breadth-first #'map-nodes-breadth-first)))) 
     336    (funcall mapper function node prune-test))) 
     337 
     338(defun find-node-if (test node &key (prune-test (constantly nil)) (order :depth-first)) 
    288339  (block nil 
    289340    (map-nodes (lambda (node) 
    …… 
    291342                   (return node))) 
    292343               node 
    293                :prune-test prune-test) 
     344               :prune-test prune-test 
     345               :order order) 
    294346    nil)) 
    295347 
    296 (defun collect-nodes (test node &key (prune-test (constantly nil))) 
     348(defun collect-nodes (test node &key (prune-test (constantly nil)) (order :depth-first)) 
    297349  (let (nodes) 
    298350    (map-nodes (lambda (node) 
    …… 
    300352                   (push node nodes))) 
    301353               node 
    302                :prune-test prune-test) 
     354               :prune-test prune-test 
     355               :order order) 
    303356    (nreverse nodes))) 
    304357 
    305 ;;; *quad-tree* 
    306 (defvar *quad-tree*) 
    307  
    308 (defun make-quad-tree () 
    309   (setq *quad-tree* (make-instance 'quad-node :geo-box *m2-geo-box*))) 
    310  
    311 (register-store-transient-init-function 'make-quad-tree) 
    312  
    313 (defun node-path (node) 
     358(defmethod node-path ((node quad-node)) 
    314359  (let (prev-n path) 
    315360    (map-nodes (lambda (n) 
    …… 
    321366               *quad-tree* 
    322367               :prune-test (lambda (n) (not (geo-box-intersect-p (geo-box n) 
    323                                                                  (geo-box node))))))) 
    324  
     368                                                                 (geo-box node)))) 
     369               :order :depth-first))) 
     370 
     371(defmethod node-path ((node node-extension)) 
     372  (node-path (base-node node))) 
     373 
     374;;; *quad-tree* 
     375(defvar *quad-tree*) 
     376 
     377(defun make-quad-tree () 
     378  (setq *quad-tree* (make-instance 'quad-node :geo-box *m2-geo-box*))) 
     379 
     380(register-store-transient-init-function 'make-quad-tree) 
     381