[bknr-cvs] hans changed trunk/projects/bos/m2/test-allocation.lisp

[BKNR Commits]

Revision: 3583
Author: hans
URL: http://bknr.net/trac/changeset/3583

*** empty log message ***
U   trunk/projects/bos/m2/test-allocation.lisp

Modified: trunk/projects/bos/m2/test-allocation.lisp
===================================================================
--- trunk/projects/bos/m2/test-allocation.lisp	2008-07-23 12:29:36 UTC (rev 3582)
+++ trunk/projects/bos/m2/test-allocation.lisp	2008-07-23 12:48:58 UTC (rev 3583)
@@ -36,4 +36,27 @@
                   (push (list x y) connected)
                   (multiple-value-setq (x y)
                     (values-list (bos.web::dequeue border-queue)))
-                  (go retry))))))))))
\ No newline at end of file
+                  (go retry))))))))))
+
+(defun try-alloc (n)
+  (let* ((area (first (remove-if-not #'allocation-area-active-p (class-instances 'allocation-area))))
+         (area-left (allocation-area-left area))
+         (area-top (allocation-area-top area))
+         (area-width (allocation-area-width area))
+         (area-height (allocation-area-height area))
+         (area-right (+ area-left area-width))
+         (area-bottom (+ area-top area-height)))
+    (labels ((allocatable-p (x y)
+               (and (<= area-left x area-right)
+                    (<= area-top y area-bottom)
+                    (not (m2-contract (ensure-m2 x y))))))
+      (loop
+           (let ((x (+ area-left (random area-width)))
+                 (y (+ area-top (random area-height))))
+             (unless (m2-contract (ensure-m2 x y))
+               (let ((result (try-allocation n x y #'allocatable-p)))
+                 (when result
+                   (return result)))))))))
+        
+
+