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

[BKNR Commits]

Revision: 3900
Author: ksprotte
URL: http://bknr.net/trac/changeset/3900

free-m2s again persistent

There have been problems with the transient approach (as proven by the failing test). In order to fix this fast and cleanly, it seems to be the best solution to make it persistent again.

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

Modified: trunk/projects/bos/m2/allocation.lisp
===================================================================
--- trunk/projects/bos/m2/allocation.lisp	2008-09-15 13:14:44 UTC (rev 3899)
+++ trunk/projects/bos/m2/allocation.lisp	2008-09-15 14:46:00 UTC (rev 3900)
@@ -8,7 +8,7 @@
    (height :reader allocation-area-height :initarg :height)
    (vertices :reader allocation-area-vertices :initarg :vertices)
    (total-m2s :reader allocation-area-total-m2s)
-   (free-m2s :transient t :writer (setf allocation-area-free-m2s)) ;free-m2s reader defined below
+   (free-m2s :accessor allocation-area-free-m2s)
    (bounding-box :transient t :reader allocation-area-bounding-box))
   (:documentation
    "A polygon in which to allocate meters.  LEFT, TOP, WIDTH, and
@@ -27,20 +27,13 @@
     (format stream "~a x ~a ~:[inactive~;active~] ID: ~a"
             (allocation-area-width allocation-area)
             (allocation-area-height allocation-area)
-            (allocation-area-active-p allocation-area)            
+            (allocation-area-active-p allocation-area)
             (store-object-id allocation-area))))
 
-(defmethod allocation-area-free-m2s ((area allocation-area))
-  (flet ((compute-free-m2s ()
-           (with-slots (total-m2s free-m2s) area
-             (setf free-m2s (- total-m2s (calculate-allocated-m2-count area))))))    
-    (if (slot-boundp area 'free-m2s)
-        (slot-value area 'free-m2s)
-        (compute-free-m2s))))
-
 (defmethod initialize-persistent-instance :after ((allocation-area allocation-area) &key)
-  (with-slots (total-m2s) allocation-area
-    (setf total-m2s (calculate-total-m2-count allocation-area)))
+  (with-slots (total-m2s free-m2s) allocation-area
+    (setf total-m2s (calculate-total-m2-count allocation-area))
+    (setf free-m2s (- total-m2s (calculate-allocated-m2-count allocation-area))))
   ;; FIXME probably we dont need this and should rely on *rect-publisher*
   (dolist (tile (allocation-area-tiles allocation-area))
     (image-tile-changed tile)))
@@ -51,7 +44,7 @@
 (defmethod destroy-object :before ((allocation-area allocation-area))
   (notify-tiles allocation-area))
 
-(defmethod initialize-transient-instance :after ((allocation-area allocation-area))  
+(defmethod initialize-transient-instance :after ((allocation-area allocation-area))
   (notify-tiles allocation-area))
 
 (defun compute-bounding-box (vertices)
@@ -351,7 +344,7 @@
                 (result (search-adjacent n m2 #'allocatable-p)))
            (when result
              (assert (alexandria:setp result :test #'equal))
-             (assert (= n (length result)))             
+             (assert (= n (length result)))
              (return result))
            (when (> (get-internal-real-time) deadline)
              (return nil)))))))

Modified: trunk/projects/bos/m2/m2.lisp
===================================================================
--- trunk/projects/bos/m2/m2.lisp	2008-09-15 13:14:44 UTC (rev 3899)
+++ trunk/projects/bos/m2/m2.lisp	2008-09-15 14:46:00 UTC (rev 3900)
@@ -34,9 +34,9 @@
                             :slots (x y)
                             :index-reader m2-at
                             :index-initargs (:width +width+
-                                             :height +width+
-                                             :tile-size +m2tile-width+
-                                             :tile-class 'image-tile))))
+                                                    :height +width+
+                                                    :tile-size +m2tile-width+
+                                                    :tile-class 'image-tile))))
 
 (defmethod print-object ((m2 m2) stream)
   (if (and (slot-boundp m2 'x)
@@ -55,7 +55,7 @@
 
 (defun ensure-m2 (&rest coords)
   (or (m2-at coords)
-      (destructuring-bind (x y) coords          
+      (destructuring-bind (x y) coords
         (make-object 'm2 :x x :y y))))
 
 (defmethod get-m2-with-num ((num integer))
@@ -264,7 +264,7 @@
    (worldpay-trans-id :update :initform nil)
    (expires :read :documentation "universal time which specifies the
      time the contract expires (is deleted) when it has not been paid for"
-                  :initform nil)
+            :initform nil)
    (largest-rectangle :update))
   (:default-initargs
       :m2s nil
@@ -283,10 +283,11 @@
 (defun contract-p (object)
   (equal (class-of object) (find-class 'contract)))
 
-(defmethod initialize-persistent-instance :after ((contract contract) &key)
+(defmethod initialize-persistent-instance :after ((contract contract) &key area)
   (pushnew contract (sponsor-contracts (contract-sponsor contract)))
   (dolist (m2 (contract-m2s contract))
-    (setf (m2-contract m2) contract))
+    (setf (m2-contract m2) contract)
+    (decf (allocation-area-free-m2s area)))
   (setf (contract-largest-rectangle contract)
         (contract-compute-largest-rectangle contract))
   (publish-contract-change contract))
@@ -528,14 +529,12 @@
 Sponsor-ID: ~A
 "
                                         m2-count (store-object-id sponsor)))
-        (error 'allocation-areas-exhausted :numsqm m2-count))      
-      ;; FREE-M2S might be lazily computed at his point, before it is
-      ;; decremented. If this happens, the m2s must still be free.
-      (decf (allocation-area-free-m2s area) m2-count)
+        (error 'allocation-areas-exhausted :numsqm m2-count))
       (make-object 'contract
                    :sponsor sponsor
                    :date date
                    :m2s m2s
+                   :area area
                    :expires expires
                    :download-only download-only
                    :paidp paidp))))