Changeset 3219
- Timestamp:
- 05/30/08 13:50:02 (7 months ago)
- Files:
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
branches/bos-trunk-sat/projects/bos/web/sat-tree.lisp
r3205 r3219 6 6 (defpersistent-class sat-layer () 7 7 ((name :reader name :initarg :name 8 9 8 :index-type unique-index 9 :index-reader find-sat-layer) 10 10 (geo-box :reader geo-box :initarg :geo-box))) 11 11 12 (defun sat-layer-top-level-nodes (sat-layer) 13 (warn "this function is till buggy") 14 (let (nodes 15 top-level-depth) 16 (map-nodes (lambda (n) 17 (let ((sat-node (find-if (lambda (e) (and (eql (name e) (name sat-layer)) 18 (typep e 'sat-node))) 19 (extensions n)))) 20 (when sat-node 21 (unless top-level-depth 22 (setq top-level-depth (depth n))) 23 (if (= top-level-depth (depth n)) 24 (push sat-node nodes) 25 nil)))) 26 *quad-tree* 27 :prune-test (lambda (n) (not (geo-box-intersect-p (geo-box n) (geo-box sat-layer))))) 12 (defun sat-layer-top-level-nodes (sat-layer) 13 (let ((nodes ()) 14 top-level-depth 15 (state 'no-layer-node)) 16 (block collect 17 (map-nodes (lambda (n) 18 (let ((layer-node (find-if (lambda (e) (and (eql (name e) (name sat-layer)) 19 (typep e 'sat-node))) 20 (extensions n)))) 21 (ecase state 22 (no-layer-node 23 (when layer-node 24 (push layer-node nodes) 25 (setq state 'got-top-level-layer-node))) 26 (got-top-level-layer-node 27 (unless top-level-depth 28 (setq top-level-depth (depth n))) 29 (if (and layer-node (= (depth n) top-level-depth)) 30 (push layer-node nodes) 31 (return-from collect)))))) 32 *quad-tree* 33 :prune-test (lambda (n) (not (geo-box-intersect-p (geo-box n) (geo-box sat-layer)))) 34 :order :breadth-first)) 28 35 (nreverse nodes))) 29 36 … … 54 61 (n (geo-box-north geo-box)) 55 62 (e (geo-box-east geo-box)) 56 (s (geo-box-south geo-box)) 63 (s (geo-box-south geo-box)) 57 64 (bw (geo-box-west tile-geo-box)) 58 65 (bn (geo-box-north tile-geo-box)) … … 77 84 (th (round (/ ph scaling)))) 78 85 (values scaling 79 pw ph px py px2 py2 86 pw ph px py px2 py2 80 87 tw th rounded-geo-box))) 81 88 82 89 (defun make-sat-image-tile (image geo-box quad-node tile-geo-box name max-scaling) 83 90 (multiple-value-bind (scaling 84 pw ph px py px2 py2 91 pw ph px py px2 py2 85 92 tw th rounded-geo-box) 86 93 (sat-image-tile-properties image geo-box tile-geo-box max-scaling) … … 99 106 :name (format nil "~A-~{~D~}" name path) 100 107 :initargs `(:path ,path 101 :image-geo-box ,rounded-geo-box)))))))108 :image-geo-box ,rounded-geo-box))))))) 102 109 103 (defun make-sat-layer (image geo-box name &optional (start-depth 0)) 110 (defun make-sat-layer (image geo-box name &optional (start-depth 0)) 104 111 (check-type name symbol) 105 112 (assert (not (find-sat-layer name)) (name) 106 113 "A sat-layer of name ~S already exists." name) 107 114 (check-type image cl-gd::image) 108 (assert (geo-box-encloses-p *m2-geo-box* geo-box)) 115 (assert (geo-box-encloses-p *m2-geo-box* geo-box)) 109 116 (check-type start-depth (integer 0)) 110 117 (labels ((layer-quad-nodes () … … 113 120 (lambda (n) (when (= start-depth (depth n)) 114 121 (push n nodes))) 115 (lambda (n) (= start-depth (depth n)))) 122 (lambda (n) (= start-depth (depth n)))) 116 123 (mapcar 117 124 (lambda (quad-node) … … 128 135 (reduce #'max nodes 129 136 :key (lambda (node) 130 (sat-image-tile-properties image geo-box (tile-geo-box node)))))) 131 (let* ((nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes))) 137 (sat-image-tile-properties image geo-box (tile-geo-box node)))))) 138 (let* ((nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes))) 132 139 (max-scaling (max-scaling nodes))) 133 140 (dolist (node nodes)
