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

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

16 Jul '08

Revision: 3470 Author: ksprotte URL: http://bknr.net/trac/changeset/3470 renamed allocation-cache to allocation-area-inclusion-cache U trunk/projects/bos/m2/map.lisp U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/m2/map.lisp =================================================================== --- trunk/projects/bos/m2/map.lisp 2008-07-16 14:50:25 UTC (rev 3469) +++ trunk/projects/bos/m2/map.lisp 2008-07-16 15:05:15 UTC (rev 3470) @@ -79,11 +79,12 @@ (setf (ldb (byte 8 0) pixel-rgb-value) blue) pixel-rgb-value)) -(defstruct (allocation-cache (:conc-name ac-)) +;;; allocation-area-inclusion-cache +(defstruct (allocation-area-inclusion-cache (:conc-name ac-)) x y width height array areas) -(defvar *allocation-cache* nil - "allocation-cache struct indicating whether a certain square meter is inside of an allocation area") +(defvar *allocation-area-inclusion-cache* nil + "allocation-area-inclusion-cache struct indicating whether a certain square meter is inside of an allocation area") (defun point-in-any-allocation-area-p% (x-coord y-coord) (find-if #'(lambda (allocation-area) @@ -92,13 +93,13 @@ (point-in-polygon-p x-coord y-coord (allocation-area-vertices allocation-area)))) (store-objects-with-class 'allocation-area))) -(defun initialize-allocation-cache () +(defun initialize-allocation-area-inclusion-cache () (destructuring-bind (x y width height) (allocation-areas-bounding-box) - (setf *allocation-cache* - (make-allocation-cache :x x :y y :width width :height height + (setf *allocation-area-inclusion-cache* + (make-allocation-area-inclusion-cache :x x :y y :width width :height height :array (make-array (list width height) :element-type '(unsigned-byte 1)) :areas (class-instances 'allocation-area)))) - (dolist (area (ac-areas *allocation-cache*)) + (dolist (area (ac-areas *allocation-area-inclusion-cache*)) (destructuring-bind (top-left-x top-left-y width height) (allocation-area-bounding-box2 area) (dotimes (x width) (dotimes (y height) @@ -106,26 +107,26 @@ (y-coord (+ y top-left-y))) (when (and (point-in-polygon-p x-coord y-coord (allocation-area-bounding-box area)) (point-in-polygon-p x-coord y-coord (allocation-area-vertices area))) - (setf (aref (ac-array *allocation-cache*) - (- x-coord (ac-x *allocation-cache*)) - (- y-coord (ac-y *allocation-cache*))) + (setf (aref (ac-array *allocation-area-inclusion-cache*) + (- x-coord (ac-x *allocation-area-inclusion-cache*)) + (- y-coord (ac-y *allocation-area-inclusion-cache*))) 1)))))))) -(defvar *allocation-cache-lock* (bt:make-lock "Area Cache Lock")) +(defvar *allocation-area-inclusion-cache-lock* (bt:make-lock "Area Cache Lock")) -(defun validate-allocation-cache () - (bt:with-lock-held (*allocation-cache-lock*) - (unless (and *allocation-cache* +(defun validate-allocation-area-inclusion-cache () + (bt:with-lock-held (*allocation-area-inclusion-cache-lock*) + (unless (and *allocation-area-inclusion-cache* (equal (class-instances 'allocation-area) - (ac-areas *allocation-cache*))) - (initialize-allocation-cache)))) + (ac-areas *allocation-area-inclusion-cache*))) + (initialize-allocation-area-inclusion-cache)))) (defun point-in-any-allocation-area-p (x-coord y-coord) - (and (< -1 (- x-coord (ac-x *allocation-cache*)) (ac-width *allocation-cache*)) - (< -1 (- y-coord (ac-y *allocation-cache*)) (ac-height *allocation-cache*)) - (plusp (aref (ac-array *allocation-cache*) - (- x-coord (ac-x *allocation-cache*)) - (- y-coord (ac-y *allocation-cache*)))))) + (and (< -1 (- x-coord (ac-x *allocation-area-inclusion-cache*)) (ac-width *allocation-area-inclusion-cache*)) + (< -1 (- y-coord (ac-y *allocation-area-inclusion-cache*)) (ac-height *allocation-area-inclusion-cache*)) + (plusp (aref (ac-array *allocation-area-inclusion-cache*) + (- x-coord (ac-x *allocation-area-inclusion-cache*)) + (- y-coord (ac-y *allocation-area-inclusion-cache*)))))) (defclass image-tile (tile) ((original-image :documentation "Original satellite image" @@ -152,7 +153,7 @@ (copy-image original-image *default-image* 0 0 0 0 (image-width) (image-height))))) (defmethod image-tile-process ((tile image-tile) (operation (eql :areas))) - (validate-allocation-cache) + (validate-allocation-area-inclusion-cache) (do-rows (y) (do-pixels-in-row (x) (when (point-in-any-allocation-area-p (tile-absolute-x tile x) Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-16 14:50:25 UTC (rev 3469) +++ trunk/projects/bos/test/allocation.lisp 2008-07-16 15:05:15 UTC (rev 3470) @@ -208,7 +208,7 @@ (make-allocation-rectangle 0 0 8 8) (finishes (delete-object (make-contract (make-sponsor :login "test-sponsor") 1 :paidp nil)))) -(test validate-allocation-cache +(test validate-allocation-area-inclusion-cache (with-fixture initial-bos-store () (let ((area1 (make-allocation-rectangle 0 0 8 8))) - (finishes (bos.m2::validate-allocation-cache))))) \ No newline at end of file + (finishes (bos.m2::validate-allocation-area-inclusion-cache))))) \ No newline at end of file

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3469 Author: ksprotte URL: http://bknr.net/trac/changeset/3469 use with-transaction around setf allocation-area bounding-box U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-16 14:41:37 UTC (rev 3468) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-16 14:50:25 UTC (rev 3469) @@ -164,11 +164,12 @@ (defmethod allocation-area-bounding-box ((allocation-area allocation-area)) (with-slots (left top width height bounding-box) allocation-area (unless (slot-boundp allocation-area 'bounding-box) - (setf bounding-box (coerce (list (cons left top) - (cons (+ left width) top) - (cons (+ left width) (+ top height)) - (cons left (+ top height))) - 'vector))) + (with-transaction ("setf allocation-area bounding-box") + (setf bounding-box (coerce (list (cons left top) + (cons (+ left width) top) + (cons (+ left width) (+ top height)) + (cons left (+ top height))) + 'vector)))) bounding-box)) (defmethod allocation-area-bounding-box2 ((allocation-area allocation-area))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/allocation.lisp
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3468 Author: ksprotte URL: http://bknr.net/trac/changeset/3468 new test: validate-allocation-cache U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-16 13:51:58 UTC (rev 3467) +++ trunk/projects/bos/test/allocation.lisp 2008-07-16 14:41:37 UTC (rev 3468) @@ -208,3 +208,7 @@ (make-allocation-rectangle 0 0 8 8) (finishes (delete-object (make-contract (make-sponsor :login "test-sponsor") 1 :paidp nil)))) +(test validate-allocation-cache + (with-fixture initial-bos-store () + (let ((area1 (make-allocation-rectangle 0 0 8 8))) + (finishes (bos.m2::validate-allocation-cache))))) \ No newline at end of file

1 0

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

16 Jul '08

Revision: 3467 Author: ksprotte URL: http://bknr.net/trac/changeset/3467 compute timestamp with less consing in country-stats-handler U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-16 13:38:42 UTC (rev 3466) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-16 13:51:58 UTC (rev 3467) @@ -129,8 +129,11 @@ ()) (defmethod handle ((handler country-stats-handler)) - (let* ((paid-contracts (remove-if-not #'contract-paidp (class-instances 'contract))) - (timestamp (reduce #'max paid-contracts :key (lambda (contract) (store-object-last-change contract 0))))) + (let* ((contracts (class-instances 'contract)) + (timestamp (reduce #'max contracts :key (lambda (contract) + (if (contract-paidp contract) + (store-object-last-change contract 0) + 0))))) (hunchentoot:handle-if-modified-since timestamp) (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date timestamp)) @@ -152,7 +155,7 @@ (with-element "Icon" ;; (with-element "href" (text "http://maps.google.com/mapfiles/kml/pal3/icon23.png")) (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) - (dolist (country-contracts (sort (group-on paid-contracts + (dolist (country-contracts (sort (group-on (remove-if-not #'contract-paidp contracts) :test #'equal :key (lambda (contract) (string-upcase (sponsor-country (contract-sponsor contract)))))

1 0

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

16 Jul '08

Revision: 3466 Author: ksprotte URL: http://bknr.net/trac/changeset/3466 added timestamp to country-stats-handler U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-16 13:30:21 UTC (rev 3465) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-16 13:38:42 UTC (rev 3466) @@ -129,7 +129,11 @@ ()) (defmethod handle ((handler country-stats-handler)) - (handle-every-n-seconds (60) + (let* ((paid-contracts (remove-if-not #'contract-paidp (class-instances 'contract))) + (timestamp (reduce #'max paid-contracts :key (lambda (contract) (store-object-last-change contract 0))))) + (hunchentoot:handle-if-modified-since timestamp) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date timestamp)) (with-xml-response (:content-type #+nil "text/xml" "application/vnd.google-earth.kml+xml; charset=utf-8" :root-element "kml") (with-query-params ((lang "en")) @@ -148,7 +152,7 @@ (with-element "Icon" ;; (with-element "href" (text "http://maps.google.com/mapfiles/kml/pal3/icon23.png")) (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) - (dolist (country-contracts (sort (group-on (all-contracts) + (dolist (country-contracts (sort (group-on paid-contracts :test #'equal :key (lambda (contract) (string-upcase (sponsor-country (contract-sponsor contract)))))

1 0

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

16 Jul '08

Revision: 3465 Author: ksprotte URL: http://bknr.net/trac/changeset/3465 added timestamp for poi-xml-handler U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-16 13:24:40 UTC (rev 3464) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-16 13:30:21 UTC (rev 3465) @@ -562,9 +562,13 @@ (defmethod handle-object ((handler poi-xml-handler) poi) - (with-query-params ((lang "en")) - (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") - (write-poi-xml poi lang)))) + (let ((timestamp (store-object-last-change poi 1))) + (hunchentoot:handle-if-modified-since timestamp) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date timestamp)) + (with-query-params ((lang "en")) + (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") + (write-poi-xml poi lang))))) (defclass poi-kml-handler (object-handler) ()

1 0

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

16 Jul '08

Revision: 3464 Author: ksprotte URL: http://bknr.net/trac/changeset/3464 again whitespace... U trunk/projects/bos/web/poi-handlers.lisp Change set too large, please see URL above

1 0

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

16 Jul '08

Revision: 3463 Author: ksprotte URL: http://bknr.net/trac/changeset/3463 just indentation, sorry U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-16 13:19:28 UTC (rev 3462) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-16 13:20:44 UTC (rev 3463) @@ -383,7 +383,8 @@ (error "poi not found")) (defmethod handle-object ((handler poi-image-handler) poi) - (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler)) + (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) + (multiple-value-list (parse-handler-url handler)) (declare (ignore poi-name)) (let ((image-index (1- (parse-integer image-index-string)))) (if (and (not (minusp image-index))

1 0

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

16 Jul '08

Revision: 3462 Author: ksprotte URL: http://bknr.net/trac/changeset/3462 equipped poi-javascript-handler with last-modified U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-16 12:49:49 UTC (rev 3461) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-16 13:19:28 UTC (rev 3462) @@ -359,16 +359,21 @@ (length (contract-m2s contract)))) (defmethod handle ((handler poi-javascript-handler)) - (with-http-response (:content-type "text/html; charset=UTF-8") - (setf (hunchentoot:header-out :cache-control) "no-cache") - (setf (hunchentoot:header-out :pragma) "no-cache") - (setf (hunchentoot:header-out :expires) "-1") - (with-http-body () - (html - ((:script :language "JavaScript") - (:princ (make-poi-javascript (or (hunchentoot:session-value :language) *default-language*))) - (:princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") - (:princ (format nil "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))))))))) + (let* ((last-paid-contracts (last-paid-contracts)) + (timestamp (max (reduce #'max (class-instances 'poi) + :key (lambda (poi) (store-object-last-change poi 1))) + (reduce #'max last-paid-contracts + :key (lambda (contract) (store-object-last-change contract 0)))))) + (hunchentoot:handle-if-modified-since timestamp) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date timestamp)) + (with-http-response (:content-type "text/html; charset=UTF-8") + (with-http-body () + (html + ((:script :language "JavaScript") + (:princ (make-poi-javascript (or (hunchentoot:session-value :language) *default-language*))) + (:princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") + (:princ (format nil "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js last-paid-contracts))))))))) (defclass poi-image-handler (object-handler) ()

1 0

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

16 Jul '08

Revision: 3461 Author: ksprotte URL: http://bknr.net/trac/changeset/3461 dont start contract-tree-image-update-daemon when testing U trunk/projects/bos/test/fixtures.lisp U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/test/fixtures.lisp =================================================================== --- trunk/projects/bos/test/fixtures.lisp 2008-07-16 12:28:41 UTC (rev 3460) +++ trunk/projects/bos/test/fixtures.lisp 2008-07-16 12:49:49 UTC (rev 3461) @@ -5,8 +5,9 @@ (when snapshot (format t "~&;; ++ taking snapshot~%") (snapshot)) - (bos.m2::reinit :directory (bknr.datastore::store-directory *store*) - :website-url bos.m2::*website-url*) + (let ((bos.web::*start-contract-tree-image-update-daemon* nil)) + (bos.m2::reinit :directory (bknr.datastore::store-directory *store*) + :website-url bos.m2::*website-url*)) (format t "~&;; ++ reopen-store done~%")) (defmacro reopen-store ((&key snapshot) &rest store-object-vars) @@ -50,7 +51,7 @@ (let ((store-path (parse-namestring (format nil "/tmp/test-store-~D.tmp/" (get-universal-time))))) (unwind-protect - (progn + (let ((bos.web::*start-contract-tree-image-update-daemon* nil)) (bos.m2::reinit :delete t :directory store-path :website-url bos.m2::*website-url*) Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-16 12:28:41 UTC (rev 3460) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-16 12:49:49 UTC (rev 3461) @@ -306,6 +306,7 @@ ;; contract-tree image update daemon (defvar *contract-tree-image-update-daemon* nil) (defvar *contract-tree-image-update-daemon-halt*) +(defvar *start-contract-tree-image-update-daemon* t) (defun contract-tree-image-update-daemon-loop () (loop (when *contract-tree-image-update-daemon-halt* (return)) @@ -322,10 +323,18 @@ (bt:make-thread #'contract-tree-image-update-daemon-loop :name "contract-tree-image-update-daemon"))) -(defun stop-contract-tree-image-update-daemon () +(defun stop-contract-tree-image-update-daemon (&key wait) (when (contract-tree-image-update-daemon-running-p) (setq *contract-tree-image-update-daemon-halt* t) - (warn "contract-tree-image-update-daemon will stop soon"))) + (warn "contract-tree-image-update-daemon will stop soon") + (when wait + (loop repeat 20 + do (progn (sleep 1) + (when (not (contract-tree-image-update-daemon-running-p)) + (return)))) + (if (contract-tree-image-update-daemon-running-p) + (error "Failed to stop contract-tree-image-update-daemon") + (warn "contract-tree-image-update-daemon stopped"))))) ;;; make-contract-tree-from-m2 (defun make-contract-tree-from-m2 () @@ -338,7 +347,8 @@ (when (contract-published-p contract) (insert-contract *contract-tree* contract))) (format t "~&rendering contract-tree images if needed...") (force-output) - (start-contract-tree-image-update-daemon) + (when *start-contract-tree-image-update-daemon* + (start-contract-tree-image-update-daemon)) (format t "done.~%") (force-output) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* (list 0 0 +width+ +width+)

1 0