Revision: 3400 Author: hans URL: http://bknr.net/trac/changeset/3400

Drawing cache for allocation area fixed.

U trunk/projects/bos/m2/map.lisp

Modified: trunk/projects/bos/m2/map.lisp =================================================================== --- trunk/projects/bos/m2/map.lisp 2008-07-01 11:54:03 UTC (rev 3399) +++ trunk/projects/bos/m2/map.lisp 2008-07-01 14:06:11 UTC (rev 3400) @@ -79,17 +79,11 @@ (setf (ldb (byte 8 0) pixel-rgb-value) blue) pixel-rgb-value))

-(defvar *allocation-area-cache* nil - "Array of bits indicating whether a certain square meter is inside of an allocation area") +(defstruct (allocation-cache (:conc-name ac-)) + x y width height array areas)

-(defvar *allocation-cache-x* nil - "Top left X coordinate of the allocation cache") -(defvar *allocation-cache-y* nil - "Top left Y coordinate of the allocation cache") -(defvar *allocation-cache-width* nil - "Width of the allocation cache") -(defvar *allocation-cache-height* nil - "Height of the allocation cache") +(defvar *allocation-cache* nil + "allocation-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) @@ -99,23 +93,39 @@ (store-objects-with-class 'allocation-area)))

(defun initialize-allocation-cache () - (destructuring-bind (top-left-x top-left-y width height) (allocation-areas-bounding-box) - (setf *allocation-area-cache* (make-array (list width height) :element-type '(unsigned-byte 1)) - *allocation-cache-x* top-left-x - *allocation-cache-y* top-left-y - *allocation-cache-width* width - *allocation-cache-height* height) - (dotimes (x width) - (dotimes (y height) - (when (point-in-any-allocation-area-p (+ x top-left-x) (+ y top-left-y)) - (setf (aref *allocation-area-cache* x y) 1)))))) + (destructuring-bind (x y width height) (allocation-areas-bounding-box) + (setf *allocation-cache* + (make-allocation-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*)) + (destructuring-bind (top-left-x top-left-y width height) (allocation-area-bounding-box2 area) + (dotimes (x width) + (dotimes (y height) + (let ((x-coord (+ x top-left-x)) + (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*))) + 1))))))))

+(defvar *allocation-cache-lock* (bt:make-lock "Area Cache Lock")) + +(defun validate-allocation-cache () + (bt:with-lock-held (*allocation-cache-lock*) + (unless (and *allocation-cache* + (equal (class-instances 'allocation-area) + (ac-areas *allocation-cache*))) + (initialize-allocation-cache)))) + (defun point-in-any-allocation-area-p (x-coord y-coord) - (and (< -1 (- x-coord *allocation-cache-x*) *allocation-cache-width*) - (< -1 (- y-coord *allocation-cache-y*) *allocation-cache-height*) - (plusp (aref *allocation-area-cache* - (- x-coord *allocation-cache-x*) - (- y-coord *allocation-cache-y*))))) + (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*))))))

(defclass image-tile (tile) ((original-image :documentation "Original satellite image" @@ -142,11 +152,12 @@ (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) (do-rows (y) (do-pixels-in-row (x) (when (point-in-any-allocation-area-p (tile-absolute-x tile x) - (tile-absolute-y tile y)) - (setf (raw-pixel) (apply #'colorize-pixel (raw-pixel) '(220 220 220))))))) + (tile-absolute-y tile y)) + (setf (raw-pixel) (apply #'colorize-pixel (raw-pixel) '(220 220 220)))))))

(defmethod image-tile-process ((tile image-tile) (operation (eql :contracts))) (do-rows (y)