Changeset 3900

Show
Ignore:
Timestamp:
09/15/08 16:46:00 (2 months ago)
Author:
ksprotte
Message:

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.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r3899 r3900  
    99   (vertices :reader allocation-area-vertices :initarg :vertices) 
    1010   (total-m2s :reader allocation-area-total-m2s) 
    11    (free-m2s :transient t :writer (setf allocation-area-free-m2s)) ;free-m2s reader defined below 
     11   (free-m2s :accessor allocation-area-free-m2s) 
    1212   (bounding-box :transient t :reader allocation-area-bounding-box)) 
    1313  (:documentation 
    …… 
    2828            (allocation-area-width allocation-area) 
    2929            (allocation-area-height allocation-area) 
    30             (allocation-area-active-p allocation-area)             
     30            (allocation-area-active-p allocation-area) 
    3131            (store-object-id allocation-area)))) 
    3232 
    33 (defmethod allocation-area-free-m2s ((area allocation-area)) 
    34   (flet ((compute-free-m2s () 
    35            (with-slots (total-m2s free-m2s) area 
    36              (setf free-m2s (- total-m2s (calculate-allocated-m2-count area))))))     
    37     (if (slot-boundp area 'free-m2s) 
    38         (slot-value area 'free-m2s) 
    39         (compute-free-m2s)))) 
    40  
    4133(defmethod initialize-persistent-instance :after ((allocation-area allocation-area) &key) 
    42   (with-slots (total-m2s) allocation-area 
    43     (setf total-m2s (calculate-total-m2-count allocation-area))) 
     34  (with-slots (total-m2s free-m2s) allocation-area 
     35    (setf total-m2s (calculate-total-m2-count allocation-area)) 
     36    (setf free-m2s (- total-m2s (calculate-allocated-m2-count allocation-area)))) 
    4437  ;; FIXME probably we dont need this and should rely on *rect-publisher* 
    4538  (dolist (tile (allocation-area-tiles allocation-area)) 
    …… 
    5245  (notify-tiles allocation-area)) 
    5346 
    54 (defmethod initialize-transient-instance :after ((allocation-area allocation-area))   
     47(defmethod initialize-transient-instance :after ((allocation-area allocation-area)) 
    5548  (notify-tiles allocation-area)) 
    5649 
    …… 
    352345           (when result 
    353346             (assert (alexandria:setp result :test #'equal)) 
    354              (assert (= n (length result)))              
     347             (assert (= n (length result))) 
    355348             (return result)) 
    356349           (when (> (get-internal-real-time) deadline) 

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

    r3895 r3900  
    3535                            :index-reader m2-at 
    3636                            :index-initargs (:width +width+ 
    37                                              :height +width+ 
    38                                              :tile-size +m2tile-width+ 
    39                                              :tile-class 'image-tile)))) 
     37                                                    :height +width+ 
     38                                                    :tile-size +m2tile-width+ 
     39                                                    :tile-class 'image-tile)))) 
    4040 
    4141(defmethod print-object ((m2 m2) stream) 
    …… 
    5656(defun ensure-m2 (&rest coords) 
    5757  (or (m2-at coords) 
    58       (destructuring-bind (x y) coords           
     58      (destructuring-bind (x y) coords 
    5959        (make-object 'm2 :x x :y y)))) 
    6060 
    …… 
    265265   (expires :read :documentation "universal time which specifies the 
    266266     time the contract expires (is deleted) when it has not been paid for" 
    267                   :initform nil) 
     267            :initform nil) 
    268268   (largest-rectangle :update)) 
    269269  (:default-initargs 
    …… 
    284284  (equal (class-of object) (find-class 'contract))) 
    285285 
    286 (defmethod initialize-persistent-instance :after ((contract contract) &key) 
     286(defmethod initialize-persistent-instance :after ((contract contract) &key area) 
    287287  (pushnew contract (sponsor-contracts (contract-sponsor contract))) 
    288288  (dolist (m2 (contract-m2s contract)) 
    289     (setf (m2-contract m2) contract)) 
     289    (setf (m2-contract m2) contract) 
     290    (decf (allocation-area-free-m2s area))) 
    290291  (setf (contract-largest-rectangle contract) 
    291292        (contract-compute-largest-rectangle contract)) 
    …… 
    529530" 
    530531                                        m2-count (store-object-id sponsor))) 
    531         (error 'allocation-areas-exhausted :numsqm m2-count))       
    532       ;; FREE-M2S might be lazily computed at his point, before it is 
    533       ;; decremented. If this happens, the m2s must still be free. 
    534       (decf (allocation-area-free-m2s area) m2-count) 
     532        (error 'allocation-areas-exhausted :numsqm m2-count)) 
    535533      (make-object 'contract 
    536534                   :sponsor sponsor 
    537535                   :date date 
    538536                   :m2s m2s 
     537                   :area area 
    539538                   :expires expires 
    540539                   :download-only download-only