Changeset 3250

Show
Ignore:
Timestamp:
06/02/08 19:55:03 (7 months ago)
Author:
ksprotte
Message:

can now create a sat layer with multiple levels

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r3248 r3250  
    133133                                             :image-geo-box ,rounded-geo-box))))))) 
    134134 
    135 (defun make-sat-layer (image geo-box name &optional (start-depth 0)) 
    136   (check-type name symbol) 
    137   (assert (not (find-sat-layer name)) (name) 
    138           "A sat-layer of name ~S already exists." name) 
    139   (check-type image cl-gd::image) 
    140   (assert (geo-box-encloses-p *m2-geo-box* geo-box)) 
    141   (check-type start-depth (integer 0)) 
     135(defun make-sat-image-tiles-for-depth (image geo-box layer start-depth) 
    142136  (labels ((layer-quad-nodes () 
    143137             (let (nodes) 
    …… 
    160154             (reduce #'max nodes 
    161155                     :key (lambda (node) 
    162                             (sat-image-tile-properties image geo-box (tile-geo-box node)))))) 
    163     (let* ((nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes))) 
    164            (max-scaling (max-scaling nodes)) 
    165            (layer (make-object 'sat-layer :name name :geo-box geo-box))) 
     156                            (sat-image-tile-properties image geo-box (tile-geo-box node))))))     
     157    (let* ((name (name layer)) 
     158           (nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes))) 
     159           (max-scaling (max-scaling nodes))) 
     160      (format t "; creating ~a at depth ~a~%" name start-depth) 
    166161      (dolist (node nodes layer) 
    167162        (make-sat-image-tile image geo-box (quad-node node) 
    168                              (tile-geo-box node) name max-scaling))))) 
     163                             (tile-geo-box node) name max-scaling)) 
     164      (unless (= 1 max-scaling) 
     165        (make-sat-image-tiles-for-depth image geo-box layer (1+ start-depth)))))) 
     166 
     167(defun make-sat-layer (image geo-box name &optional (start-depth 0)) 
     168  (check-type name symbol) 
     169  (assert (not (find-sat-layer name)) (name) 
     170          "A sat-layer of name ~S already exists." name) 
     171  (check-type image cl-gd::image) 
     172  (assert (geo-box-encloses-p *m2-geo-box* geo-box)) 
     173  (check-type start-depth (integer 0)) 
     174  (let ((layer (make-object 'sat-layer :name name :geo-box geo-box))) 
     175    (make-sat-image-tiles-for-depth image geo-box layer start-depth))) 
    169176 
    170177;; (with-store-image (image (first (class-instances 'store-image)))