Revision: 3606 Author: ksprotte URL: http://bknr.net/trac/changeset/3606
allocate-in-area now gives up after 10ms
U trunk/projects/bos/m2/allocation.lisp
Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-23 23:45:26 UTC (rev 3605) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 09:11:18 UTC (rev 3606) @@ -342,21 +342,25 @@ (labels ((allocatable-p (x y) (and (in-polygon-p x y (allocation-area-vertices area)) (not (m2-contract (ensure-m2 x y)))))) - (dotimes (i 10) - (let ((x (+ area-left (random area-width))) - (y (+ area-top (random area-height)))) - (when (allocatable-p x y) - (let ((result (try-allocation n x y #'allocatable-p))) - (when result - (assert (alexandria:setp result :test #'equal)) - (assert (= n (length result))) - (decf (allocation-area-free-m2s area) n) - (return-from allocate-in-area - (mapcar (lambda (x-y) - (destructuring-bind (x y) - x-y - (ensure-m2 x y))) - result)))))))))) + (loop with start-time = (get-internal-real-time) + do (let ((x (+ area-left (random area-width))) + (y (+ area-top (random area-height)))) + (when (allocatable-p x y) + (let ((result (try-allocation n x y #'allocatable-p))) + (when result + (assert (alexandria:setp result :test #'equal)) + (assert (= n (length result))) + (decf (allocation-area-free-m2s area) n) + (return-from allocate-in-area + (mapcar (lambda (x-y) + (destructuring-bind (x y) + x-y + (ensure-m2 x y))) + result)))))) + when (> (- (get-internal-real-time) start-time) + ;; give up after 10 ms + (* (/ 10 1000) internal-time-units-per-second)) + return nil))))
(defun allocate-m2s-for-sale (n) "The main entry point to the allocation machinery. Will return a