- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[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

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 10 Jul '08

10 Jul '08

Revision: 3423 Author: ksprotte URL: http://bknr.net/trac/changeset/3423 fixed again sat-layer destroy-object, so that deleting a sat-layer is possible without breaking the store U trunk/projects/bos/test/web/sat-tree.lisp U trunk/projects/bos/web/sat-tree.lisp Modified: trunk/projects/bos/test/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 14:31:04 UTC (rev 3422) +++ trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 15:41:02 UTC (rev 3423) @@ -6,5 +6,7 @@ (cl-gd:with-image (image 1000 1000) (with-store-reopenings () (bos.web::make-sat-layer image geo-box :test 0) - (delete-object (first (class-instances 'bos.web::sat-layer))) + (progn + (bos.web::remove-sat-layer-from-quad-tree (find-store-object 1)) + (delete-object (first (class-instances 'bos.web::sat-layer)))) (pass))))) Modified: trunk/projects/bos/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/web/sat-tree.lisp 2008-07-10 14:31:04 UTC (rev 3422) +++ trunk/projects/bos/web/sat-tree.lisp 2008-07-10 15:41:02 UTC (rev 3423) @@ -3,9 +3,6 @@ (defclass sat-node (node-extension) ((image :accessor image :initarg :image))) -(defmethod delete-node-extension :before ((obj sat-node)) - (delete-object (image obj))) - (defpersistent-class sat-layer () ((name :reader name :initarg :name :index-type unique-index @@ -18,11 +15,23 @@ (format stream "name: ~s" (name obj)))) (defmethod destroy-object :before ((obj sat-layer)) - ;; (dolist (top-level-node (sat-layer-top-level-nodes obj)) - ;; (delete-node-extension top-level-node)) + (when (boundp '*quad-tree*) + ;; when the transaction log is being loaded, *quad-tree* is still + ;; unbound, because it is only initialized, when the entire store + ;; has been loaded -- an example for the fact that the quad-tree + ;; should have been implemented as a proper store index + (assert (null (sat-layer-top-level-nodes obj)) nil + "Please invoke (remove-sat-layer-from-quad-tree (find-store-object ~D)) before deleting ~s." + (store-object-id obj) obj)) (dolist (sat-image (class-instances 'sat-image)) - (delete-object sat-image))) + (when (eq obj (layer sat-image)) + (delete-object sat-image)))) +(defun remove-sat-layer-from-quad-tree (sat-layer) + (let ((nodes (collect-nodes (constantly t) (first (sat-layer-top-level-nodes sat-layer))))) + (mapc #'delete-node-extension nodes) + (values))) + (defun sat-layer-top-level-nodes (sat-layer) (check-type sat-layer sat-layer) (let ((nodes ()) @@ -160,7 +169,7 @@ (let* ((name (name layer)) (nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes))) (max-scaling (max-scaling nodes))) - (format t "; creating ~a at depth ~a~%" name start-depth) + (format t "; creating ~a at depth ~a~%" name start-depth) ; (dolist (node nodes layer) (make-sat-image-tile image geo-box (quad-node node) (tile-geo-box node) name max-scaling))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/
by BKNR Commits 10 Jul '08

10 Jul '08

Revision: 3422 Author: ksprotte URL: http://bknr.net/trac/changeset/3422 quick fix to test delete-sat-layer-and-snapshot U trunk/projects/bos/test/fixtures.lisp U trunk/projects/bos/test/web/sat-tree.lisp Modified: trunk/projects/bos/test/fixtures.lisp =================================================================== --- trunk/projects/bos/test/fixtures.lisp 2008-07-10 13:37:33 UTC (rev 3421) +++ trunk/projects/bos/test/fixtures.lisp 2008-07-10 14:31:04 UTC (rev 3422) @@ -18,24 +18,28 @@ `(let (,@(iter (for id-var in id-vars) (for store-object-var in store-object-vars) - (collect `(,id-var (store-object-id ,store-object-var))))) + (collect `(,id-var (when (and ,store-object-var + (not (object-destroyed-p ,store-object-var))) + (store-object-id ,store-object-var)))))) (%reopen-store :snapshot ,snapshot) (setf ,@(iter (for id-var in id-vars) (for store-object-var in store-object-vars) (collect store-object-var) - (collect `(find-store-object ,id-var))))))) + (collect `(when ,id-var (find-store-object ,id-var)))))))) (defmacro %with-store-reopenings ((&key snapshot bypass) (&rest store-object-vars) &body body) - `(progn - ,@(if bypass - body - (iter - (for form in body) - (unless (first-time-p) - (collect `(reopen-store (:snapshot ,snapshot) ,@store-object-vars))) - (collect form))))) + `(let ((snapshot ,snapshot) + (bypass ,bypass)) + (if bypass + (progn ,@body) + (progn + ,@(iter + (for form in body) + (unless (first-time-p) + (collect `(reopen-store (:snapshot ,snapshot) ,@store-object-vars))) + (collect form)))))) (defmacro with-store-reopenings ((&rest store-object-vars) &body body) `(%with-store-reopenings (:snapshot snapshot :bypass bypass) Modified: trunk/projects/bos/test/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 13:37:33 UTC (rev 3421) +++ trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 14:31:04 UTC (rev 3422) @@ -1,19 +1,10 @@ (in-package :bos.test) (in-suite :bos.test.web) -(test delete-sat-layer-and-snapshot - (with-fixture initial-bos-store () - (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) - (cl-gd:with-image (image 1000 1000) +(store-test delete-sat-layer-and-snapshot + (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) + (cl-gd:with-image (image 1000 1000) + (with-store-reopenings () (bos.web::make-sat-layer image geo-box :test 0) (delete-object (first (class-instances 'bos.web::sat-layer))) - (finishes (snapshot)))))) - -;; (store-test delete-sat-layer-and-snapshot.2 -;; (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) -;; (cl-gd:with-image (image 1000 1000) -;; (with-store-reopenings () -;; (bos.web::make-sat-layer image geo-box :test 0) -;; (delete-object (first (class-instances 'bos.web::sat-layer))) -;; (pass))))) - + (pass)))))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 10 Jul '08

10 Jul '08

Revision: 3421 Author: ksprotte URL: http://bknr.net/trac/changeset/3421 fixed a problem with sat-layer destroy-object, where snapshot would fail afterwards _U trunk/projects/bos/ U trunk/projects/bos/test/bos.test.asd A trunk/projects/bos/test/web/sat-tree.lisp U trunk/projects/bos/web/sat-tree.lisp Property changes on: trunk/projects/bos ___________________________________________________________________ Name: svn:ignore - datastore web.rc m2.rc TAGS bos.core screenrc + datastore web.rc m2.rc TAGS bos.core screenrc hunchentoot-access.log hunchentoot-error.log Modified: trunk/projects/bos/test/bos.test.asd =================================================================== --- trunk/projects/bos/test/bos.test.asd 2008-07-10 09:32:53 UTC (rev 3420) +++ trunk/projects/bos/test/bos.test.asd 2008-07-10 13:37:33 UTC (rev 3421) @@ -14,4 +14,5 @@ :depends-on ("suites" "fixtures") :components ((:file "drakma-requests") - (:file "quad-tree"))))) + (:file "quad-tree") + (:file "sat-tree"))))) Added: trunk/projects/bos/test/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/test/web/sat-tree.lisp (rev 0) +++ trunk/projects/bos/test/web/sat-tree.lisp 2008-07-10 13:37:33 UTC (rev 3421) @@ -0,0 +1,19 @@ +(in-package :bos.test) +(in-suite :bos.test.web) + +(test delete-sat-layer-and-snapshot + (with-fixture initial-bos-store () + (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) + (cl-gd:with-image (image 1000 1000) + (bos.web::make-sat-layer image geo-box :test 0) + (delete-object (first (class-instances 'bos.web::sat-layer))) + (finishes (snapshot)))))) + +;; (store-test delete-sat-layer-and-snapshot.2 +;; (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100))))) +;; (cl-gd:with-image (image 1000 1000) +;; (with-store-reopenings () +;; (bos.web::make-sat-layer image geo-box :test 0) +;; (delete-object (first (class-instances 'bos.web::sat-layer))) +;; (pass))))) + Modified: trunk/projects/bos/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/web/sat-tree.lisp 2008-07-10 09:32:53 UTC (rev 3420) +++ trunk/projects/bos/web/sat-tree.lisp 2008-07-10 13:37:33 UTC (rev 3421) @@ -18,8 +18,10 @@ (format stream "name: ~s" (name obj)))) (defmethod destroy-object :before ((obj sat-layer)) - (dolist (top-level-node (sat-layer-top-level-nodes obj)) - (delete-node-extension top-level-node))) + ;; (dolist (top-level-node (sat-layer-top-level-nodes obj)) + ;; (delete-node-extension top-level-node)) + (dolist (sat-image (class-instances 'sat-image)) + (delete-object sat-image))) (defun sat-layer-top-level-nodes (sat-layer) (check-type sat-layer sat-layer)

1 0