Changeset 3426

Timestamp:

07/14/08 10:38:03 (4 months ago)

Author:

ksprotte

Message:

contract-tree-image-handler now serves its images from independently computed store-images

Files:

• trunk/projects/bos/web/contract-tree.lisp (modified) (3 diffs)

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

@@ -6 +6 @@
-   (timestamp :accessor timestamp :initform (get-universal-time))
-   (placemark-contracts :initform nil :accessor placemark-contracts)
+   (image :initform nil :accessor image)
-   (kml-req-count :initform 0 :accessor kml-req-count)
-   (image-req-count :initform 0 :accessor image-req-count)))
@@ -194 +195 @@
-
-
+;;; image
+
+;; contract-images are stored as store-images. The image slot of
+;; contract-node points to the current store-image.
+
+(defun contract-node-store-image-name (node)
+  (format nil "contract-node~{~D~}" (node-path node)))
+
+(defun contract-node-update-image (node)
+  (labels ((find-contract-color (contract)
+             (destructuring-bind (r g b)
+                 (contract-color contract)
+               (cl-gd:find-color r g b :alpha 40))))
+    (let ((box (geo-box node))
+          (image-size *contract-tree-images-size*))
+      (cl-gd:with-image (cl-gd:*default-image* image-size image-size t)
+        (setf (cl-gd:save-alpha-p) t
+              (cl-gd:alpha-blending-p) nil)
+        ;; (cl-gd:draw-rectangle* 0 0 127 127 :filled nil :color (cl-gd:find-color 255 0 0))
+        (let ((transparent (cl-gd:find-color 255 255 255 :alpha 127))
+              (subbox (make-geo-box 0d0 0d0 0d0 0d0)))
+          (cl-gd:do-rows (y)
+            (cl-gd:do-pixels-in-row (x)
+              (let ((subbox (geo-subbox box x y image-size subbox)))
+                (multiple-value-bind (m2x m2y)
+                    (geo-box-middle-m2coord subbox)
+                  (setf (cl-gd:raw-pixel)
+                        (let* ((m2 (ignore-errors (get-m2 m2x m2y)))
+                               (contract (and m2 (m2-contract m2))))
+                          (if (and contract (contract-paidp contract))
+                              (find-contract-color contract)
+                              transparent))))))))
+        (let* ((image-name (contract-node-store-image-name node))
+               (old-store-image (store-image-with-name image-name)))
+          (when old-store-image (delete-object old-store-image))
+          (make-store-image :name image-name
+                            :type :png))))))
+
+(defun contract-node-update-image-if-needed (node)
+  (when (or (null (image node))
+            (> (timestamp node) (blob-timestamp (image node))))
+    (contract-node-update-image node)))
+
-;;; image handler
-(defclass contract-tree-image-handler (page-handler)
-  ())
-
-  
+
-  (with-query-params (path)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
-
-;;; make-contract-tree-from-m2
@@ -239 +261 @@
-    (when (contract-published-p contract)
-      (insert-contract *contract-tree* contract)))
+  (format t "~&rendering contract-tree images...")
+  (map-nodes #'contract-node-update-image-if-needed *contract-tree*)
+  (format t "done.~%")
+  (bknr.datastore::delete-orphaned-blob-files nil)
-  (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree*
-                                     (list 0 0 +width+ +width+)