Changeset 3205

Show
Ignore:
Timestamp:
05/29/08 22:58:33 (8 months ago)
Author:
ksprotte
Message:

added the first version of sat-layer-top-level-nodes

It will be needed for generating kml for a given sat-layer.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r3204 r3205  
    66(defpersistent-class sat-layer () 
    77  ((name :reader name :initarg :name 
    8          :index-type unique-index 
    9          :index-reader find-sat-layer))) 
     8                               :index-type unique-index 
     9                               :index-reader find-sat-layer) 
     10   (geo-box :reader geo-box :initarg :geo-box))) 
     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))))) 
     28    (nreverse nodes))) 
    1029 
    1130(defpersistent-class sat-image (store-image) 
    …… 
    1332   (node :reader node :initarg :node :transient t) 
    1433   (path :reader path :initarg :path) 
    15    (image-geo-box :accessor image-geo-box :initarg :image-geo-box 
     34   (image-geo-box :accessor image-geo-box 
     35                  :initarg :image-geo-box 
    1636                  :type geo-box 
    1737                  :documentation "can be different from base-node's geo-box"))) 
    …… 
    7393                          :resize t :resample t 
    7494                          :dest-width tw :dest-height th) 
    75         (make-instance 'node-extension 
     95        (make-instance 'sat-node 
    7696                       :name name 
    7797                       :base-node quad-node 
    …… 
    7999                                                :name (format nil "~A-~{~D~}" name path) 
    80100                                                :initargs `(:path ,path 
    81                                                                   :image-geo-box ,rounded-geo-box))))))) 
     101                                                            :image-geo-box ,rounded-geo-box))))))) 
    82102 
    83103(defun make-sat-layer (image geo-box name &optional (start-depth 0))   
    84104  (check-type name symbol) 
    85   (assert (not (find-sat-layer name))) 
     105  (assert (not (find-sat-layer name)) (name) 
     106          "A sat-layer of name ~S already exists." name) 
    86107  (check-type image cl-gd::image) 
    87108  (assert (geo-box-encloses-p *m2-geo-box* geo-box))   
    …… 
    107128             (reduce #'max nodes 
    108129                     :key (lambda (node) 
    109                             (sat-image-tile-properties image geo-box (tile-geo-box node))))))     
     130                            (sat-image-tile-properties image geo-box (tile-geo-box node))))))         
    110131    (let* ((nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes)))            
    111132           (max-scaling (max-scaling nodes))) 
    112133      (dolist (node nodes) 
    113134        (make-sat-image-tile image geo-box (quad-node node) 
    114                              (tile-geo-box node) name max-scaling))))) 
     135                             (tile-geo-box node) name max-scaling))) 
     136    (make-object 'sat-layer :name name :geo-box geo-box))) 
    115137 
    116138;; (with-store-image (image (first (class-instances 'store-image)))