Changeset 3400

Show
Ignore:
Timestamp:
07/01/08 16:06:11 (6 months ago)
Author:
hans
Message:

Drawing cache for allocation area fixed.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r3398 r3400  
    8080    pixel-rgb-value)) 
    8181 
    82 (defvar *allocation-area-cache* nil 
    83   "Array of bits indicating whether a certain square meter is inside of an allocation area") 
    84  
    85 (defvar *allocation-cache-x* nil 
    86   "Top left X coordinate of the allocation cache") 
    87 (defvar *allocation-cache-y* nil 
    88   "Top left Y coordinate of the allocation cache") 
    89 (defvar *allocation-cache-width* nil 
    90   "Width of the allocation cache") 
    91 (defvar *allocation-cache-height* nil 
    92   "Height of the allocation cache") 
     82(defstruct (allocation-cache (:conc-name ac-)) 
     83  x y width height array areas) 
     84 
     85(defvar *allocation-cache* nil 
     86  "allocation-cache struct indicating whether a certain square meter is inside of an allocation area") 
    9387 
    9488(defun point-in-any-allocation-area-p% (x-coord y-coord) 
    …… 
    10094 
    10195(defun initialize-allocation-cache () 
    102   (destructuring-bind (top-left-x top-left-y width height) (allocation-areas-bounding-box) 
    103     (setf *allocation-area-cache* (make-array (list width height) :element-type '(unsigned-byte 1)) 
    104           *allocation-cache-x* top-left-x 
    105           *allocation-cache-y* top-left-y 
    106           *allocation-cache-width* width 
    107           *allocation-cache-height* height) 
    108     (dotimes (x width) 
    109       (dotimes (y height) 
    110         (when (point-in-any-allocation-area-p (+ x top-left-x) (+ y top-left-y)) 
    111           (setf (aref *allocation-area-cache* x y) 1)))))) 
     96  (destructuring-bind (x y width height) (allocation-areas-bounding-box) 
     97    (setf *allocation-cache* 
     98          (make-allocation-cache :x x :y y :width width :height height 
     99                                 :array (make-array (list width height) :element-type '(unsigned-byte 1)) 
     100                                 :areas (class-instances 'allocation-area)))) 
     101  (dolist (area (ac-areas *allocation-cache*)) 
     102    (destructuring-bind (top-left-x top-left-y width height) (allocation-area-bounding-box2 area) 
     103      (dotimes (x width) 
     104        (dotimes (y height) 
     105          (let ((x-coord (+ x top-left-x)) 
     106                (y-coord (+ y top-left-y))) 
     107            (when (and (point-in-polygon-p x-coord y-coord (allocation-area-bounding-box area)) 
     108                       (point-in-polygon-p x-coord y-coord (allocation-area-vertices area))) 
     109              (setf (aref (ac-array *allocation-cache*) 
     110                          (- x-coord (ac-x *allocation-cache*)) 
     111                          (- y-coord (ac-y *allocation-cache*))) 
     112                    1)))))))) 
     113 
     114(defvar *allocation-cache-lock* (bt:make-lock "Area Cache Lock")) 
     115 
     116(defun validate-allocation-cache () 
     117  (bt:with-lock-held (*allocation-cache-lock*) 
     118    (unless (and *allocation-cache* 
     119                 (equal (class-instances 'allocation-area) 
     120                        (ac-areas *allocation-cache*))) 
     121      (initialize-allocation-cache)))) 
    112122 
    113123(defun point-in-any-allocation-area-p (x-coord y-coord) 
    114   (and (< -1 (- x-coord *allocation-cache-x*) *allocation-cache-width*) 
    115        (< -1 (- y-coord *allocation-cache-y*) *allocation-cache-height*) 
    116        (plusp (aref *allocation-area-cache* 
    117                     (- x-coord *allocation-cache-x*) 
    118                     (- y-coord *allocation-cache-y*))))) 
     124  (and (< -1 (- x-coord (ac-x *allocation-cache*)) (ac-width *allocation-cache*)) 
     125       (< -1 (- y-coord (ac-y *allocation-cache*)) (ac-height *allocation-cache*)) 
     126       (plusp (aref (ac-array *allocation-cache*) 
     127                    (- x-coord (ac-x *allocation-cache*)) 
     128                    (- y-coord (ac-y *allocation-cache*)))))) 
    119129   
    120130(defclass image-tile (tile) 
    …… 
    143153 
    144154(defmethod image-tile-process ((tile image-tile) (operation (eql :areas))) 
     155  (validate-allocation-cache) 
    145156  (do-rows (y) 
    146157    (do-pixels-in-row (x) 
    147158      (when (point-in-any-allocation-area-p (tile-absolute-x tile x) 
    148                                            (tile-absolute-y tile y)) 
    149        (setf (raw-pixel) (apply #'colorize-pixel (raw-pixel) '(220 220 220))))))) 
     159                                            (tile-absolute-y tile y)) 
     160        (setf (raw-pixel) (apply #'colorize-pixel (raw-pixel) '(220 220 220))))))) 
    150161 
    151162(defmethod image-tile-process ((tile image-tile) (operation (eql :contracts)))