[bknr-cvs] ksprotte changed trunk/projects/bos/

[BKNR Commits]

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