Changeset 3253

Show
Ignore:
Timestamp:
06/04/08 12:37:35 (7 months ago)
Author:
ksprotte
Message:

added sat-tree-kml-handler

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • branches/bos-trunk-sat/projects/bos/web/bos.web.asd

    r3204 r3253  
    3535               (:file "quad-tree" :depends-on ("packages")) 
    3636               (:file "contract-tree" :depends-on ("quad-tree")) 
    37                (:file "sat-tree" :depends-on ("quad-tree")) 
     37               (:file "sat-tree" :depends-on ("quad-tree" "contract-tree")) 
    3838               (:file "countries" :depends-on ("packages")) 
    3939               (:file "kml-handlers" :depends-on ("packages" "web-macros" "countries")) 

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

    r3222 r3253  
    399399  (setq *quad-tree* (make-instance 'quad-node :geo-box *m2-geo-box*))) 
    400400 
     401(defun node-lod (node) 
     402  (if (zerop (depth node)) 
     403      '(:min 16 :max -1) 
     404      '(:min 512 :max -1))) 
     405 
     406(defconstant +max-local-draw-order+ 10) 
     407 
     408(defun compute-draw-order (node local-draw-order) 
     409  (+ local-draw-order 
     410     (* (depth node) +max-local-draw-order+))) 
     411 
    401412(register-store-transient-init-function 'make-quad-tree) 
    402413 

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

    r3250 r3253  
    1111         :index-type unique-index 
    1212         :index-reader find-sat-layer) 
    13    (geo-box :reader geo-box :initarg :geo-box))) 
     13   (geo-box :reader geo-box :initarg :geo-box) 
     14   (local-draw-order :reader local-draw-order :initarg :local-draw-order))) 
    1415 
    1516(defmethod print-object ((obj sat-layer) stream) 
    …… 
    181182;;                   3)) 
    182183 
    183 ;; (pushnew 'hunchentoot:dispatch-easy-handlers hunchentoot:*dispatch-table*) 
    184  
    185  
    186 (defmethod handle-object ((handler image-tree-kml-handler) (obj image-tree-node)) 
    187   (hunchentoot:handle-if-modified-since (blob-timestamp obj)) 
    188   (with-xml-response (:content-type "text/xml; charset=utf-8" #+nil"application/vnd.google-earth.kml+xml" 
    189                                     :root-element "kml") 
    190     (setf (hunchentoot:header-out :last-modified) 
    191           (hunchentoot:rfc-1123-date (blob-timestamp obj))) 
    192     (let ((lod `(:min ,(lod-min obj) :max ,(lod-max obj))) 
    193           (rect (make-rectangle2 (list (geo-x obj) (geo-y obj) (geo-width obj) (geo-height obj))))) 
    194       (with-element "Document" 
    195         (kml-region rect lod) 
    196         (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id obj)) 
    197                      rect 
    198                      :draw-order (depth obj) 
    199                      ;; :absolute 0 
    200                      ) 
    201         (dolist (child (children obj)) 
    202           (kml-network-link (format nil "http://~a/image-tree-kml/~d" (website-host) (store-object-id child)) 
    203                             :rect (make-rectangle2 (list (geo-x child) (geo-y child) 
    204                                                          (geo-width child) (geo-height child))) 
    205                             :lod `(:min ,(lod-min child) :max ,(lod-max child)))))))) 
    206  
    207 (hunchentoot:define-easy-handler (sat-layer-kml :uri "/sat-layer-kml") 
    208     ((name :parameter-type 'keyword))   
    209   (handler-case 
    210       (progn 
    211         (assert (find-sat-layer name))  
    212         (with-xml-response (:content-type "text/xml; charset=utf-8" #+nil"application/vnd.google-earth.kml+xml" 
    213                                           :root-element "kml")     
    214           (with-element "Document"       
    215             (loop for sat-node in (sat-layer-top-level-nodes (find-sat-layer name)) 
    216                for sat-image = (image sat-node) 
    217                do (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id sat-image)) 
    218                                (geo-box-rectangle (image-geo-box sat-image)) 
    219                                :draw-order 1000 
    220                                ;; :absolute 0 
    221                                ))))) 
    222     (error (c) (format nil "An error occured:~%~a" c)))) 
    223  
     184 
     185;;; handlers 
     186 
     187(defclass sat-tree-kml-handler (page-handler) 
     188  ()) 
     189 
     190(defmethod handle ((handler sat-tree-kml-handler)) 
     191  (with-query-params ((path) (name)) 
     192    (let ((path (parse-path path)) 
     193          (layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD"))))) 
     194      (assert layer nil "Cannnot find layer of name ~s." name) 
     195      (let* ((quad-node (find-node-with-path *quad-tree* path)) 
     196             (sat-node (find-if (lambda (e) (and (eql (name e) (name layer)) 
     197                                                 (typep e 'sat-node))) 
     198                                (extensions quad-node)))) 
     199        (assert sat-node nil "There is no sat-node of name ~s at path ~s." name path) 
     200        (let ((sat-image (image sat-node))) 
     201          (hunchentoot:handle-if-modified-since (blob-timestamp sat-image)) 
     202          (with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml" 
     203                                            :root-element "kml") 
     204            (setf (hunchentoot:header-out :last-modified) 
     205                  (hunchentoot:rfc-1123-date (blob-timestamp sat-image))) 
     206            (let ((lod (node-lod sat-node)) 
     207                  (rect (geo-box-rectangle (geo-box sat-node)))) 
     208              (with-element "Document" 
     209                (kml-region rect lod) 
     210                (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id sat-image)) 
     211                             (geo-box-rectangle (image-geo-box sat-image)) 
     212                             :draw-order (compute-draw-order sat-node (local-draw-order layer)) 
     213                             ;; :absolute 0 
     214                             ) 
     215                (let ((*print-case* :downcase)) 
     216                  (dotimes (i 4) 
     217                    (let ((child (child sat-node i))) 
     218                      (when child 
     219                        (kml-network-link (format nil "http://~A/sat-tree-kml?name=~A&path=~{~D~}" 
     220                                                  (website-host) (name layer) (append path (list i))) 
     221                                          :rect (geo-box-rectangle (geo-box child)) 
     222                                          :lod (node-lod child)))))))))))))) 
     223 

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

    r3074 r3253  
    205205                                        ("/image-tree" image-tree-handler) 
    206206                                        ("/contract-tree-kml" contract-tree-kml-handler) 
    207                                         ("/contract-tree-image" contract-tree-image-handler)                                     
     207                                        ("/contract-tree-image" contract-tree-image-handler)                                                                             
    208208                                        ("/contract-image" contract-image-handler) 
    209209                                        ("/contract" contract-handler) 
     210                                        ("/sat-tree-kml" sat-tree-kml-handler) 
    210211                                        ("/reports-xml" reports-xml-handler) 
    211212                                        ("/complete-transfer" complete-transfer-handler)