Changeset 3608

Show
Ignore:
Timestamp:
07/24/08 12:01:26 (4 months ago)
Author:
hans
Message:

Refactored...

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r3607 r3608  
    88   (height :update) 
    99   (vertices :update) 
    10    (y :update)   
     10   (y :update) 
    1111   (total-m2s :read) 
    1212   (free-m2s :update) 
    …… 
    4646  (mapc #'(lambda (tile) (image-tile-changed tile)) (allocation-area-tiles allocation-area))) 
    4747 
    48 (defmethod destroy-object :before ((allocation-area allocation-area))   
     48(defmethod destroy-object :before ((allocation-area allocation-area)) 
    4949  (notify-tiles allocation-area)) 
    5050 
    …… 
    120120                    (error "new allocation area must not intersect with existing allocation area ~A" 
    121121                           allocation-area)))))) 
    122    
     122 
    123123  (make-allocation-area/unchecked vertices)) 
    124124 
    …… 
    133133                        :height height 
    134134                        :y top 
    135                         :active-p nil                       
    136                         :vertices vertices)))       
     135                        :active-p nil 
     136                        :vertices vertices))) 
    137137      result))) 
    138138 
    …… 
    162162  "Returns the bounding-box as with ALLOCATION-AREAS-BOUNDING-BOX, but 
    163163possibly augmented by any contracts that dont have an allocation-area 
    164 anymore."   
     164anymore." 
    165165  (geometry:with-bounding-box-collect (collect) 
    166166    (awhen (allocation-areas-bounding-box) 
    …… 
    291291    consistent-p)) 
    292292 
    293 ;;; allocation 
    294 (defun try-allocation (n start-x start-y pred) 
     293(defun search-adjacent (n m2 pred) 
    295294  "Try to find N free square meters that are adjacent and that begin 
    296 at X and Y.  PRED is a predicate function of two arguments that 
     295at square meter M2.  PRED is a predicate function of two arguments that 
    297296returns a true value if the arguments specify the coordinates of an 
    298297allocatable square meter." 
    299   (unless (funcall pred start-x start-y) 
    300     (error "sqm ~A/~A not allocatable" start-x start-y)) 
    301   (let* ((allocated (make-hash-table :test #'equal)) 
    302          (border-queue (make-queue)) 
    303          connected) 
    304     (labels 
    305         ((enqueue* (x y) 
    306            (let ((key (list x y))) 
    307              (setf (gethash key allocated) t) 
    308              (enqueue key border-queue))) 
    309          (try-get (&rest key)            
    310            (and (not (gethash key allocated)) 
    311                 (apply pred key) 
    312                 key)) 
    313          (get-next-neighbor (x y) 
    314            (or (try-get (1+ x) y) 
    315                (try-get x (1+ y)) 
    316                (try-get (1- x) y) 
    317                (try-get x (1- y))))) 
    318       (enqueue* start-x start-y) 
    319       (dotimes (i (1- n) 
    320                 (append connected (queue-elements border-queue))) 
    321         (tagbody 
    322          retry 
    323            (if (queue-empty-p border-queue) 
    324                (return nil) 
    325                (destructuring-bind (x y) (peek-queue border-queue) 
    326                  (let ((next (get-next-neighbor x y))) 
     298  (when (funcall pred m2) 
     299    (let* ((allocated (make-hash-table :test #'eq)) 
     300           (border-queue (make-queue)) 
     301           completely-checked) 
     302      (labels 
     303          ((to-border-queue (m2) 
     304             (setf (gethash m2 allocated) t) 
     305             (enqueue m2 border-queue)) 
     306           (try-get (x y) 
     307             (let ((m2 (ensure-m2 x y))) 
     308               (when (and (not (gethash m2 allocated)) 
     309                          (apply pred m2)) 
     310                m2))) 
     311           (get-next-neighbor (m2) 
     312             (let ((x (m2-x m2)) 
     313                   (y (m2-y m2))) 
     314               (or (try-get (1+ x) y) 
     315                   (try-get x (1+ y)) 
     316                   (try-get (1- x) y) 
     317                   (try-get x (1- y)))))) 
     318        (to-border-queue m2) 
     319        (dotimes (i (1- n) 
     320                  (nconc completely-checked (queue-elements border-queue))) 
     321          (tagbody 
     322           check-next 
     323             (if (queue-empty-p border-queue) 
     324                 (return nil) 
     325                 (let ((next (get-next-neighbor (peek-queue border-queue)))) 
    327326                   (cond 
    328327                     (next 
    329                       (apply #'enqueue* next))                      
     328                      (to-border-queue next)) 
    330329                     (t 
    331                       (push (dequeue border-queue) connected) 
    332                       (go retry))))))))))) 
     330                      (push (dequeue border-queue) completely-checked) 
     331                      (go check-next))))))))))) 
    333332 
    334333(defun allocate-in-area (area n) 
    …… 
    337336         (area-width (allocation-area-width area)) 
    338337         (area-height (allocation-area-height area)) 
    339          ;; (area-right (+ area-left area-width)) 
    340          ;; (area-bottom (+ area-top area-height)) 
    341          ) 
    342     (labels ((allocatable-p (x y) 
    343                (and (in-polygon-p x y (allocation-area-vertices area)) 
    344                     (not (m2-contract (ensure-m2 x y)))))) 
    345       (loop with deadline = (+ (get-internal-real-time) 
    346                                ;; give up after 10 ms 
    347                                (* (/ 10 1000) internal-time-units-per-second))  
    348          do (let ((x (+ area-left (random area-width))) 
    349                   (y (+ area-top (random area-height))))           
    350               (when (allocatable-p x y) 
    351                 (let ((result (try-allocation n x y #'allocatable-p))) 
    352                   (when result 
    353                     (assert (alexandria:setp result :test #'equal)) 
    354                     (assert (= n (length result))) 
    355                     (decf (allocation-area-free-m2s area) n) 
    356                     (return-from allocate-in-area 
    357                       (mapcar (lambda (x-y) 
    358                                 (destructuring-bind (x y) 
    359                                     x-y 
    360                                   (ensure-m2 x y))) 
    361                               result)))))) 
    362          when (> (get-internal-real-time) deadline) 
    363          return nil)))) 
     338         (deadline (+ (get-internal-real-time) 
     339                      ;; give up after 10 ms 
     340                      (* (/ 10 1000) internal-time-units-per-second)))) 
     341    (labels ((allocatable-p (m2) 
     342               (and (in-polygon-p (m2-x m2) (m2-y m2) (allocation-area-vertices area)) 
     343                    (not (m2-contract m2))))) 
     344      (loop 
     345         (let* ((x (+ area-left (random area-width))) 
     346                (y (+ area-top (random area-height))) 
     347                (m2 (ensure-m2 x y)) 
     348                (result (search-adjacent n m2 #'allocatable-p))) 
     349             (when result 
     350               (assert (alexandria:setp result :test #'equal)) 
     351               (assert (= n (length result))) 
     352               (decf (allocation-area-free-m2s area) n) 
     353               (return (mapcar (alexandria:curry #'apply #'ensure-m2) result))) 
     354             (when (> (get-internal-real-time) deadline) 
     355               (return nil))))))) 
    364356 
    365357(defun allocate-m2s-for-sale (n) 
    …… 
    370362    (when (<= n (allocation-area-free-m2s area)) 
    371363      (let ((m2s (allocate-in-area area n))) 
    372         (when m2s         
     364        (when m2s 
    373365          (return-from allocate-m2s-for-sale m2s))))) 
    374366  (dolist (area (inactive-nonempty-allocation-areas)) 
    …… 
    383375    they can be re-allocated.")) 
    384376 
    385 (defmethod return-contract-m2s (m2s)   
     377(defmethod return-contract-m2s (m2s) 
    386378  (loop for m2 in m2s 
    387379     for allocation-area = (m2-allocation-area m2)