Revision: 3597 Author: ksprotte URL: http://bknr.net/trac/changeset/3597
test allocation.disconnected-m2s.1 passes for the first time U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/test/allocation.lisp
Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-23 18:55:53 UTC (rev 3596) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 19:12:54 UTC (rev 3597) @@ -342,32 +342,35 @@ (labels ((allocatable-p (x y) (and (in-polygon-p x y (allocation-area-vertices area)) (not (m2-contract (ensure-m2 x y)))))) - (loop - (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))) - (return (mapcar (lambda (x-y) - (destructuring-bind (x y) - x-y - (ensure-m2 x y))) - result)))))))))) + (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))))))))))
(defun allocate-m2s-for-sale (n) - "The main entry point to the allocation machinery. Will return - a list of N m2 instances or NIL if the requested amount cannot - be allocated. Returned m2s will not be allocated - again (i.e. there are marked as in use) by the allocation - algorithm, but see RETURN-CONTRACT-M2S." + "The main entry point to the allocation machinery. Will return a + list of N m2 instances or NIL if the requested amount cannot be + allocated." (dolist (area (active-allocation-areas)) (let ((m2s (allocate-in-area area n))) - (when m2s (return-from allocate-m2s-for-sale m2s)))) + (when m2s + (return-from allocate-m2s-for-sale m2s)))) (dolist (area (inactive-nonempty-allocation-areas)) (let ((m2s (allocate-in-area area n))) - (when m2s (return-from allocate-m2s-for-sale m2s))))) + (when m2s + (activate-allocation-area area) + (return-from allocate-m2s-for-sale m2s)))))
(defgeneric return-contract-m2s (m2s) (:documentation "Mark the given square meters as free, so that
Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-23 18:55:53 UTC (rev 3596) +++ trunk/projects/bos/test/allocation.lisp 2008-07-23 19:12:54 UTC (rev 3597) @@ -238,8 +238,7 @@ (m2-counts '(12 43 29 3))) (declare (ignore area)) (dolist (m2-count m2-counts) - (let ((contract (make-contract sponsor m2-count))) - (print (list 'make-contract-returned contract)))) + (make-contract sponsor m2-count)) ;; This following check reported: ;; WARNING: #<CONTRACT ID: 32131, unpaid> has m2s that are not ;; connected