[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp

[BKNR Commits]

Revision: 3426
Author: ksprotte
URL: http://bknr.net/trac/changeset/3426

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

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

Modified: trunk/projects/bos/web/contract-tree.lisp
===================================================================
--- trunk/projects/bos/web/contract-tree.lisp	2008-07-11 15:14:44 UTC (rev 3425)
+++ trunk/projects/bos/web/contract-tree.lisp	2008-07-14 08:38:03 UTC (rev 3426)
@@ -5,6 +5,7 @@
   ((name :allocation :class :initform 'contract-node)
    (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)))
 
@@ -193,40 +194,61 @@
                    :lod (node-lod child)))))))))))
 
 
+;;; 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)
   ())
 
-(defmethod handle ((handler contract-tree-image-handler))  
+(defmethod handle ((handler contract-tree-image-handler))
   (with-query-params (path)
-    (handle-if-node-modified
-      (incf (image-req-count node))
-      (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 ((white (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 (m2-contract m2))
-                                 (contract (and m2
-                                                %contract
-                                                (contract-paidp %contract)
-                                                %contract)))
-                            (if contract
-                                (destructuring-bind (r g b)
-                                    (contract-color contract)
-                                  (cl-gd:find-color r g b :alpha 40))
-                                white))))))))
-          (emit-image-to-browser cl-gd:*default-image* :png :date (timestamp node)))))))
+    (let* ((path (parse-path path))
+           (node (find-node-with-path *contract-tree* path))
+           (image (image node)))
+      (hunchentoot:handle-if-modified-since (timestamp image))
+      (with-store-image* (image)
+        (emit-image-to-browser cl-gd:*default-image* :png :date (timestamp image))))))
 
 ;;; make-contract-tree-from-m2
 (defun make-contract-tree-from-m2 ()  
@@ -238,6 +260,10 @@
   (dolist (contract (class-instances 'contract))
     (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+)
                                      #'contract-tree-changed))