Changeset 2851

Timestamp:

04/02/08 13:25:41 (9 months ago)

Author:

ksprotte

Message:

contract tree handler works fine

Files:

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

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

@@ -26 +26 @@
-(defclass contract-tree-node ()
-  ((id :accessor id)
+   (timestamp :accessor timestamp :initform (get-universal-time))
-   (geo-location :initarg :geo-location :reader geo-location)
-   (children :initarg :children :reader children)
@@ -66 +67 @@
-                           (pixelize 1)
-                           (max-pixel-per-meter 5))
-
+
+
+
+
+
+
+
-             (let* ((list (copy-list list))
-                    (last (last list)))
@@ -93 +100 @@
-                         (incf safe-top h)))
-                     (incf left w))))))
-&optional 
+
-             (setf (root node) root)
-(if root root node)
+root
-             node)
-           (setf-root-slots (root)
@@ -114 +121 @@
-                              :pixelize (car pixelize)))))
-    (let ((tree (rec (stick-on-last '(contract-tree contract-tree-node))
-geo-location
+(ensure-square geo-location)
-                     (stick-on-last (alexandria:ensure-list pixelize)))))
-
+ tree
-
+;;; handlers
+(defclass contract-tree-handler (object-handler)
+  ()
+  (:documentation "A simple html inspector for contract-trees. Mainly
+  used for debugging."))
+
+(defun img-contract-tree (object)
+  (html
+   ((:a :href (website-make-path *website*
+                                 (format nil "contract-tree/~d" (id object))))
+    ((:img :src (website-make-path *website*
+                                   (format nil "contract-tree-image/~d" (id object))))))))
+
+(defmethod object-handler-get-object ((handler contract-tree-handler))
+  (let ((id (parse-url)))
+    (when id
+      (let ((object (find-contract-tree-node (parse-integer id))))
+        (when (typep object 'contract-tree-node)
+          object)))))
+
+(defmethod handle-object ((contract-tree-handler contract-tree-handler) (object contract-tree-node))
+  (with-bknr-page (:title (prin1-to-string object))
+    (:pre
+     (:princ
+      (arnesi:escape-as-html
+       (with-output-to-string (*standard-output*)
+         (describe object)))))
+    (img-contract-tree object)
+    (when (root object)
+      (html
+       (:p
+        ((:a :href (website-make-path *website*
+                                      (format nil "contract-tree/~d" (id (root object)))))
+         "go to root"))))
+    ;; (:p "depth: " (:princ (depth object)) "lod-min:" (:princ (lod-min object)) "lod-max:" (:princ (lod-max object)))
+    (:table
+     (dolist (row (group-on (children object) :key #'(lambda (obj) (second (geo-location obj))) :include-key nil))
+       (html (:tr
+              (dolist (child row)
+                (html (:td (img-contract-tree child))))))))
+    ))
+
+(defclass contract-tree-image-handler (contract-tree-handler)
+  ())
+
+(defmethod handle-object ((handler contract-tree-image-handler) (object contract-tree-node))
+  (hunchentoot:handle-if-modified-since (timestamp object))
+  (let ((image-size (output-images-size (root object))))
+    (cl-gd:with-image (image image-size image-size t)      
+      (draw-contract-image image image-size (geo-location object) (pixelize object))
+      (emit-image-to-browser image :png :date (timestamp object)))))
+

trunk/projects/bos/web/webserver.lisp

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