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

[BKNR Commits]

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