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))