Changeset 2853

Timestamp:

04/02/08 15:40:19 (9 months ago)

Author:

ksprotte

Message:

added contract-tree-kml handler, alpha works

Files:

• trunk/projects/bos/web/contract-tree.lisp (modified) (5 diffs)
• trunk/projects/bos/web/image-tree.lisp (modified) (1 diff)
• trunk/projects/bos/web/webserver.lisp (modified) (1 diff)

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

@@ -5 +5 @@
-    (let ((step (float (/ (max height width) image-size))))
-      (cl-gd:with-default-image (image)        
-
+
+
+
-        (cl-gd:do-rows (y)
-          (cl-gd:do-pixels-in-row (x)
@@ -12 +14 @@
-                   (contract (and m2 (m2-contract m2))))          
-              (when (and contract (contract-paidp contract))                
-
-
+
-
-
@@ -30 +31 @@
-   (children :initarg :children :reader children)
-   (pixelize :initarg :pixelize :reader pixelize)
-
+
+
-  (:metaclass indexed-class)
-  (:class-indices (ids :index-type contract-tree-node-index
@@ -118 +120 @@
-               (>= (/ output-images-size (max width height))
-                   max-pixel-per-meter)))
-
+ &optional (depth 0)
-             (let ((children (unless (leaf-node-p geo-location)
-
+ (1+ depth)
-                                       (children-geo-locations geo-location)))))
-               (make-instance (car class)
-                              :geo-location geo-location
-                              :children children
-
+
+
-    (let ((tree (rec (stick-on-last '(contract-tree contract-tree-node))
-                     (ensure-square geo-location)
@@ -184 +187 @@
-      (emit-image-to-browser image :png :date (timestamp object)))))
-
+(defclass contract-tree-kml-handler (contract-tree-handler)
+  ()
+  (:documentation "Generates a kml representation of the queried
+contract-tree-node.  If the node has children, corresponding network
+links are created."))
+
+(defmethod handle-object ((handler contract-tree-kml-handler) (obj contract-tree-node))
+  (with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml"
+                                    :root-element "kml")
+    (let ((lod '(:min 256 :max 1024))
+          (rect (make-rectangle2 (geo-location obj))))
+      (with-element "Document"
+        (kml-region rect lod)
+        (kml-overlay (format nil "~a:~a/contract-tree-image/~d" *website-url* *port* (id obj))
+                     rect (+ 100 (depth obj)))
+        (dolist (child (children obj))
+          (kml-network-link (format nil "~a:~a/contract-tree-kml/~d" *website-url* *port* (id child))
+                            (make-rectangle2 (geo-location child))
+                            '(:min 256 :max 1024)))))))
+

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

@@ -466 +466 @@
-                                       :dest-width output-images-size
-                                       :dest-height output-images-size)
+                     #+nil
-                     (cl-gd:with-default-color ((cl-gd:allocate-color 255 0 0 :image image))
-                       ;; (cl-gd:draw-string 10 10 (format nil "~D,~D (~D x ~D)" image-x image-y image-width image-height)

trunk/projects/bos/web/webserver.lisp

@@ -204 +204 @@
-                                        ("/image-tree-kml" image-tree-kml-handler)                                        
-                                        ("/image-tree" image-tree-handler)
+                                        ("/contract-tree-kml" contract-tree-kml-handler)
-                                        ("/contract-tree-image" contract-tree-image-handler)
-                                        ("/contract-tree" contract-tree-handler)