Changeset 3261

Timestamp:

06/04/08 19:14:21 (7 months ago)

Author:

ksprotte

Message:

merge from branches/bos-trunk-sat

The kml-root-handler now contains a link to each existing (persistent)
instance of sat-layer. Thus allowing to switch between different
satellite images.

The old image-tree still exists, but shall be removed later.

A new layer can be created by MAKE-SAT-LAYER with the following lambda-list:
(image geo-box name local-draw-order &optional (start-depth 0))

New is local-draw-order, which can be an integer between 0 and (-
+max-num-of-local-draw-order-levels+ 2). The contract layer is
automatically assigned (- +max-num-of-local-draw-order-levels+ 1),
placing it always on top.

Contracts (transparent png's) and satellite images (jpg's) now play
nicely together.

Files:

• trunk/projects/bos/web/bos.web.asd (modified) (1 diff)
• trunk/projects/bos/web/contract-tree.lisp (modified) (4 diffs)
• trunk/projects/bos/web/image-tree.lisp (modified) (3 diffs)
• trunk/projects/bos/web/kml-handlers.lisp (modified) (5 diffs)
• trunk/projects/bos/web/quad-tree.lisp (modified) (6 diffs)
• trunk/projects/bos/web/sat-tree.lisp (modified) (8 diffs)
• trunk/projects/bos/web/utils.lisp (modified) (1 diff)
• trunk/projects/bos/web/webserver.lisp (modified) (1 diff)

trunk/projects/bos/web/bos.web.asd

@@ -35 +35 @@
-               (:file "quad-tree" :depends-on ("packages"))
-               (:file "contract-tree" :depends-on ("quad-tree"))
-
+ "contract-tree"
-               (:file "countries" :depends-on ("packages"))
-               (:file "kml-handlers" :depends-on ("packages" "web-macros" "countries"))

trunk/projects/bos/web/contract-tree.lisp

@@ -98 +98 @@
-
-;;; kml handler
-(defmethod network-link-lod-min ((node contract-node))
-  (if (zerop (depth node))
-      16
-      512))
-
-(defmethod network-link-lod-max ((node contract-node))
-  -1)
-
-(defclass contract-tree-kml-handler (page-handler)
-  ()
@@ -138 +130 @@
-        (setf (hunchentoot:header-out :last-modified)
-              (hunchentoot:rfc-1123-date (timestamp node)))
-`(:min ,(network-link-lod-min node) :max ,(network-link-lod-max node)
+(node-lod node
-               (box (geo-box node))
-               (rect (geo-box-rectangle box))
@@ -155 +147 @@
-            (kml-overlay (format nil "http://~a/contract-tree-image?path=~{~d~}" (website-host) path)
-                         rect
-+ 1000 (depth node
+compute-draw-order node (1- +max-num-of-local-draw-order-levels+
-                         ;; :absolute 0
-                         ;; GroundOverlay specific LOD
-
-
-
-
+
-            ;; placemark-contracts
-            (let ((placemark-contracts
@@ -202 +191 @@
-                       (format nil "http://~A/contract-tree-kml?path=~{~D~}~D" (website-host) path i))
-                   :rect (geo-box-rectangle (geo-box child))
-`(:min ,(network-link-lod-min child) :max ,(network-link-lod-max child)
+(node-lod child
-
-

trunk/projects/bos/web/image-tree.lisp

@@ -256 +256 @@
-  (format nil "~2,'0X~{~2,'0X~}" opacity (reverse color)))
-
-
+ &key (http-query "lang=[language]")
-  (with-element "Link"
-    (with-element "href" (text href))
-    (with-element "viewRefreshMode" (text "onRegion"))
-
+
+
-
-;; (defmethod kml-link ((href puri:uri))
@@ -267 +268 @@
-;;     (kml-link string)))
-
-
+ (http-query "lang=[language]")
-  (with-element "NetworkLink"
-    (when name (with-element "name" (text name)))
-    (when rect (kml-region rect lod))
-
+ :http-query http-query
-
-(defun kml-lat-lon-box (rect &optional (element "LatLonBox"))
@@ -630 +631 @@
-                            :rect (make-rectangle2 (list (geo-x child) (geo-y child)
-                                                         (geo-width child) (geo-height child)))
-
+
+
-
-(defclass image-tree-kml-latest-handler (page-handler)

trunk/projects/bos/web/kml-handlers.lisp

@@ -64 +64 @@
-
-(defclass kml-root-handler (object-handler)
-
+(timestamp :accessor timestamp :initform (get-universal-time))
-
-
-
+
+
+
+
-    ;; only the first contract of SPONSOR will be shown
-    (with-xml-response (:content-type #+nil "text/xml" "application/vnd.google-earth.kml+xml; charset=utf-8"
-                                      :root-element "kml")
+      (setf (hunchentoot:header-out :last-modified)
+            (hunchentoot:rfc-1123-date (timestamp handler)))
-      (with-query-params ((lang "en"))
-        (with-element "Document"
@@ -96 +100 @@
-                              :rect (make-rectangle2 (geo-location image-tree))
-                              :lod `(:min ,(lod-min image-tree) :max ,(lod-max image-tree))
-
+
+
+
+
+
+
+
+
-          (let ((href (if (not contract)
-                          (format nil "http://~a/contract-tree-kml" (website-host))
@@ -106 +117 @@
-            (kml-network-link href
-                              :rect (geo-box-rectangle (geo-box *contract-tree*))
-
-
+
-                              :name "contracts"))
-          (kml-network-link (format nil "http://~a/poi-kml-all" (website-host))
@@ -147 +157 @@
-
-(defmethod handle-object ((handler kml-root-handler) (object sponsor))
-
+handler 
-
-(defmethod handle-object ((handler kml-root-handler) (object contract))
@@ -153 +163 @@
-
-(defmethod handle-object ((handler kml-root-handler) (object null))
-
+ handler nil
-

trunk/projects/bos/web/quad-tree.lisp

@@ -119 +119 @@
-                                   117.02245623511905d0 -1.0920067364569994d0))
-
+;;; simple queue
+(defun make-queue ()
+  (cons nil nil))
+
+(defun queue-empty-p (queue)
+  (null (car queue)))
+
+(defun enqueue (x queue)
+  (if (null (car queue))
+      (setf (cdr queue) (setf (car queue) (list x)))
+    (setf (cdr (cdr queue)) (list x)
+          (cdr queue) (cdr (cdr queue))))
+  (car queue))
+
+(defun dequeue (queue)
+  (pop (car queue)))
+
-;;; quad-node
-(defclass quad-node ()
@@ -179 +196 @@
-(defmethod print-object ((node node-extension) stream)
-  (print-unreadable-object (node stream :type t :identity t)
-
+
+
+
+
+
-
-(defun equal-extension-type (a b)
@@ -278 +299 @@
-      (ensure-intersecting-children (ensure-child node index) geo-box function leaf-test))))
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-  (block nil
-    (map-nodes (lambda (node)
@@ -291 +363 @@
-                   (return node)))
-               node
-
+
+
-    nil))
-
-
+ (order :depth-first)
-  (let (nodes)
-    (map-nodes (lambda (node)
@@ -300 +373 @@
-                   (push node nodes)))
-               node
-
+
+
-    (nreverse nodes)))
-
-
-
-
-
-
-
-
-
-
+
-  (let (prev-n path)
-    (map-nodes (lambda (n)
@@ -321 +387 @@
-               *quad-tree*
-               :prune-test (lambda (n) (not (geo-box-intersect-p (geo-box n)
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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

@@ -2 +2 @@
-
-(defclass sat-node (node-extension)
-
+
+
+
+
-
-(defpersistent-class sat-layer ()
-  ((name :reader name :initarg :name
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-(defun sat-layer-top-level-nodes (sat-layer)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-    (nreverse nodes)))
-
-(defpersistent-class sat-image (store-image)
-
-
+
-   (path :reader path :initarg :path)
-   (image-geo-box :accessor image-geo-box
@@ -38 +56 @@
-
-(defmethod print-object ((obj sat-image) stream)
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-(defmethod name ((obj sat-image))
@@ -54 +86 @@
-         (n (geo-box-north geo-box))
-         (e (geo-box-east geo-box))
-        
+
-         (bw (geo-box-west tile-geo-box))
-         (bn (geo-box-north tile-geo-box))
@@ -77 +109 @@
-         (th (round (/ ph scaling))))
-    (values scaling
- 
+
-            tw th rounded-geo-box)))
-
-(defun make-sat-image-tile (image geo-box quad-node tile-geo-box name max-scaling)
+  (assert (find-sat-layer name))
-  (multiple-value-bind (scaling
- 
+
-                        tw th rounded-geo-box)
-      (sat-image-tile-properties image geo-box tile-geo-box max-scaling)
@@ -93 +126 @@
-                          :resize t :resample t
-                          :dest-width tw :dest-height th)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-  (labels ((layer-quad-nodes ()
-             (let (nodes)
@@ -113 +140 @@
-                                             (lambda (n) (when (= start-depth (depth n))
-                                                           (push n nodes)))
-               
+
-               (mapcar
-                (lambda (quad-node)
@@ -128 +155 @@
-             (reduce #'max nodes
-                     :key (lambda (node)
-
-
+
+
+
-           (max-scaling (max-scaling nodes)))
-
+
+
-        (make-sat-image-tile image geo-box (quad-node node)
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-;; (with-store-image (image (first (class-instances 'store-image)))
@@ -142 +186 @@
-;;                   3))
-
+
+;;; handlers
+
+(defclass sat-tree-kml-handler (page-handler)
+  ())
+
+(defmethod handle ((handler sat-tree-kml-handler))
+  (with-query-params ((path) (name))
+    (let ((path (parse-path path))
+          (layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD")))))
+      (assert layer nil "Cannnot find layer of name ~s." name)
+      (let* ((quad-node (find-node-with-path *quad-tree* path))
+             (sat-node (find-if (lambda (e) (and (eql (name e) (name layer))
+                                                 (typep e 'sat-node)))
+                                (extensions quad-node))))
+        (assert sat-node nil "There is no sat-node of name ~s at path ~s." name path)
+        (let ((sat-image (image sat-node)))
+          (hunchentoot:handle-if-modified-since (blob-timestamp sat-image))
+          (with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml"
+                                            :root-element "kml")
+            (setf (hunchentoot:header-out :last-modified)
+                  (hunchentoot:rfc-1123-date (blob-timestamp sat-image)))
+            (let ((lod (node-lod sat-node))
+                  (rect (geo-box-rectangle (geo-box sat-node))))
+              (with-element "Document"
+                (kml-region rect lod)
+                (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id sat-image))
+                             (geo-box-rectangle (image-geo-box sat-image))
+                             :draw-order (compute-draw-order sat-node (local-draw-order layer))
+                             ;; :absolute 0
+                             )
+                (let ((*print-case* :downcase))
+                  (dotimes (i 4)
+                    (let ((child (child sat-node i)))
+                      (when child
+                        (kml-network-link (format nil "http://~A/sat-tree-kml?name=~A&path=~{~D~}"
+                                                  (website-host) (name layer) (append path (list i)))
+                                          :rect (geo-box-rectangle (geo-box child))
+                                          :lod (node-lod child)
+                                          :http-query nil)))))))))))))
+
+(defclass sat-root-kml-handler (page-handler)
+  ())
+
+(defmethod handle ((handler sat-root-kml-handler))
+  (with-query-params ((name))
+    (let ((*print-case* :downcase)
+          (layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD")))))
+      (assert layer nil "Cannnot find layer of name ~s." name)
+      (let ((top-level-nodes (sat-layer-top-level-nodes layer)))
+        (assert top-level-nodes)
+        (hunchentoot:handle-if-modified-since (blob-timestamp (image (first top-level-nodes))))
+        (with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml"
+                                          :root-element "kml")
+          (setf (hunchentoot:header-out :last-modified)
+                (hunchentoot:rfc-1123-date (blob-timestamp (image (first top-level-nodes)))))
+          (with-element "Document"
+            (dolist (node top-level-nodes)
+              (kml-network-link (format nil "http://~A/sat-tree-kml?name=~A&path=~{~D~}"
+                                        (website-host) (name layer) (node-path node))
+                                :rect (geo-box-rectangle (geo-box node))
+                                :lod (node-lod node)
+                                :http-query nil))))))))
+

trunk/projects/bos/web/utils.lisp

@@ -440 +440 @@
-        do (vector-push-extend c result)
-        finally (return result)))
+

trunk/projects/bos/web/webserver.lisp

@@ -205 +205 @@
-                                        ("/image-tree" image-tree-handler)
-                                        ("/contract-tree-kml" contract-tree-kml-handler)
-
+                                        
-                                        ("/contract-image" contract-image-handler)
-                                        ("/contract" contract-handler)
+                                        ("/sat-tree-kml" sat-tree-kml-handler)
+                                        ("/sat-root-kml" sat-root-kml-handler)                                        
-                                        ("/reports-xml" reports-xml-handler)
-                                        ("/complete-transfer" complete-transfer-handler)