bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 14 Jul '08

14 Jul '08

Revision: 3433 Author: ksprotte URL: http://bknr.net/trac/changeset/3433 contract-tree-image-handler uses :max-age 600 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-14 11:06:52 UTC (rev 3432) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-14 12:00:51 UTC (rev 3433) @@ -242,14 +242,16 @@ (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) (let* ((path (parse-path path)) - (node (find-node-with-path *contract-tree* path)) - (image (image node))) + (node (find-node-with-path *contract-tree* path)) + (image (image node))) (hunchentoot:handle-if-modified-since (blob-timestamp image)) (with-store-image* (image) - (emit-image-to-browser cl-gd:*default-image* :png :date (blob-timestamp image)))))) + (emit-image-to-browser cl-gd:*default-image* :png + :date (blob-timestamp image) + :max-age 600))))) ;;; make-contract-tree-from-m2 (defun make-contract-tree-from-m2 ()

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/startup.lisp
by BKNR Commits 14 Jul '08

14 Jul '08

Revision: 3432 Author: ksprotte URL: http://bknr.net/trac/changeset/3432 bos start hunchentoot with :persistent-connections-p nil squid frontend does not seem to have a way to reuse the connection to the hunchentoot backend. U trunk/projects/bos/web/startup.lisp Modified: trunk/projects/bos/web/startup.lisp =================================================================== --- trunk/projects/bos/web/startup.lisp 2008-07-14 09:46:45 UTC (rev 3431) +++ trunk/projects/bos/web/startup.lisp 2008-07-14 11:06:52 UTC (rev 3432) @@ -46,7 +46,8 @@ (hunchentoot:stop-server *webserver*)) (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf) hunchentoot:*rewrite-for-session-urls* nil) - (setq *webserver* (hunchentoot:start-server :port *port* #+not-yet :threaded #+not-yet (not debug))) + (setq *webserver* (hunchentoot:start-server :port *port* #+not-yet :threaded #+not-yet (not debug) + :persistent-connections-p nil)) (if start-frontend (start-frontend :host host :backend-port port :port frontend-port) (warn "frontend not started - to achieve this specify :start-frontend t"))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 14 Jul '08

14 Jul '08

Revision: 3431 Author: ksprotte URL: http://bknr.net/trac/changeset/3431 fixed CONTRACT-TREE-IMAGE-HANDLER 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-14 09:43:17 UTC (rev 3430) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-14 09:46:45 UTC (rev 3431) @@ -229,8 +229,9 @@ (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)))))) + (setf (image node) + (make-store-image :name image-name + :type :png))))))) (defun contract-node-update-image-if-needed (node) (when (or (null (image node)) @@ -245,10 +246,10 @@ (with-query-params (path) (let* ((path (parse-path path)) (node (find-node-with-path *contract-tree* path)) - (image (image node))) - (hunchentoot:handle-if-modified-since (timestamp image)) + (image (image node))) + (hunchentoot:handle-if-modified-since (blob-timestamp image)) (with-store-image* (image) - (emit-image-to-browser cl-gd:*default-image* :png :date (timestamp image)))))) + (emit-image-to-browser cl-gd:*default-image* :png :date (blob-timestamp image)))))) ;;; make-contract-tree-from-m2 (defun make-contract-tree-from-m2 ()

1 0

[bknr-cvs] ksprotte changed trunk/bknr/web/src/images/image.lisp
by BKNR Commits 14 Jul '08

14 Jul '08

Revision: 3430 Author: ksprotte URL: http://bknr.net/trac/changeset/3430 again changed WITH-STORE-IMAGE* to expand to WITH-STORE-IMAGE, so they stay in sync! :) U trunk/bknr/web/src/images/image.lisp Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-07-14 09:41:08 UTC (rev 3429) +++ trunk/bknr/web/src/images/image.lisp 2008-07-14 09:43:17 UTC (rev 3430) @@ -58,8 +58,8 @@ ,@body)) (defmacro with-store-image* ((image) &body body) - `(with-image-from-file (cl-gd:*default-image* (blob-pathname ,image) (image-type-keyword ,image)) - ,@body)) + `(with-store-image (cl-gd:*default-image* ,image) + ,@body)) (defun make-store-image (&key (image *default-image*) name

1 0

[bknr-cvs] ksprotte changed trunk/bknr/web/src/images/image.lisp
by BKNR Commits 14 Jul '08

14 Jul '08

Revision: 3429 Author: ksprotte URL: http://bknr.net/trac/changeset/3429 changed WITH-STORE-IMAGE* so that the only difference to WITH-STORE-IMAGE is that it uses CL-GD:*DEFAULT-IMAGE* as VAR. I suspect that WITH-STORE-IMAGE was changed earlier to use (image-type-keyword ,image) and this change was forgotten for WITH-STORE-IMAGE*. U trunk/bknr/web/src/images/image.lisp Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-07-14 09:05:11 UTC (rev 3428) +++ trunk/bknr/web/src/images/image.lisp 2008-07-14 09:41:08 UTC (rev 3429) @@ -58,7 +58,7 @@ ,@body)) (defmacro with-store-image* ((image) &body body) - `(with-image-from-file (cl-gd:*default-image* (blob-pathname ,image) (image-type-symbol (blob-mime-type ,image))) + `(with-image-from-file (cl-gd:*default-image* (blob-pathname ,image) (image-type-keyword ,image)) ,@body)) (defun make-store-image (&key (image *default-image*)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/sat-tree.lisp
by BKNR Commits 14 Jul '08

14 Jul '08

Revision: 3428 Author: ksprotte URL: http://bknr.net/trac/changeset/3428 just a tiny change U trunk/projects/bos/web/sat-tree.lisp Modified: trunk/projects/bos/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/web/sat-tree.lisp 2008-07-14 09:01:09 UTC (rev 3427) +++ trunk/projects/bos/web/sat-tree.lisp 2008-07-14 09:05:11 UTC (rev 3428) @@ -188,7 +188,8 @@ (when (find local-draw-order (class-instances 'sat-layer) :key #'local-draw-order) (cerror "create the new layer anyway" "There is already a sat-layer with the same local-draw-order '~A'." local-draw-order)) (let ((layer (make-object 'sat-layer :name name :geo-box geo-box :local-draw-order local-draw-order))) - (make-sat-image-tiles-for-depth image geo-box layer start-depth))) + (make-sat-image-tiles-for-depth image geo-box layer start-depth) + layer)) ;; (with-store-image (image (first (class-instances 'store-image))) ;; (make-sat-layer image

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/web/sat-tree.lisp
by BKNR Commits 14 Jul '08

14 Jul '08

Revision: 3427 Author: ksprotte URL: http://bknr.net/trac/changeset/3427 fixed test DELETE-SAT-LAYER-AND-SNAPSHOT U trunk/projects/bos/test/web/sat-tree.lisp Modified: trunk/projects/bos/test/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/test/web/sat-tree.lisp 2008-07-14 08:38:03 UTC (rev 3426) +++ trunk/projects/bos/test/web/sat-tree.lisp 2008-07-14 09:01:09 UTC (rev 3427) @@ -6,7 +6,7 @@ (cl-gd:with-image (image 1000 1000) (with-store-reopenings () (bos.web::make-sat-layer image geo-box :test 0) - (progn - (bos.web::remove-sat-layer-from-quad-tree (find-store-object 1)) - (delete-object (first (class-instances 'bos.web::sat-layer)))) + (let ((sat-layer (first (class-instances 'bos.web::sat-layer)))) + (bos.web::remove-sat-layer-from-quad-tree sat-layer) + (delete-object sat-layer)) (pass)))))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 14 Jul '08

14 Jul '08

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

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 11 Jul '08

11 Jul '08

Revision: 3425 Author: ksprotte URL: http://bknr.net/trac/changeset/3425 small fix, used *contract-tree-images-size* in a bad way 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 14:44:23 UTC (rev 3424) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-11 15:14:44 UTC (rev 3425) @@ -9,7 +9,7 @@ (image-req-count :initform 0 :accessor image-req-count))) (defvar *contract-tree* nil) -(defparameter *contract-tree-images-size* 256) +(defparameter *contract-tree-images-size* 128) ; was 256 ;;; XXX soll spaeter von was anderem abhaengen (defmethod leaf-node-p ((node contract-node)) @@ -202,7 +202,7 @@ (handle-if-node-modified (incf (image-req-count node)) (let ((box (geo-box node)) - (image-size (progn *contract-tree-images-size* 128))) + (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)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 11 Jul '08

11 Jul '08

Revision: 3424 Author: ksprotte URL: http://bknr.net/trac/changeset/3424 contract-tree image handler dont call (m2-contract m2) more often than needed 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-10 15:41:02 UTC (rev 3423) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-11 14:44:23 UTC (rev 3424) @@ -216,10 +216,11 @@ (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 - (m2-contract m2) - (contract-paidp (m2-contract m2)) - (m2-contract m2)))) + %contract + (contract-paidp %contract) + %contract))) (if contract (destructuring-bind (r g b) (contract-color contract)

1 0

← Newer
1
...
26
27
28
29
30
31
32
33
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs July 2008