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

[BKNR Commits]

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

Experimental new allocator

A   trunk/projects/bos/m2/test-allocation.lisp

Added: trunk/projects/bos/m2/test-allocation.lisp
===================================================================
--- trunk/projects/bos/m2/test-allocation.lisp	                        (rev 0)
+++ trunk/projects/bos/m2/test-allocation.lisp	2008-07-23 12:29:36 UTC (rev 3582)
@@ -0,0 +1,39 @@
+(in-package :bos.m2)
+
+(defun try-allocation (n x y pred)
+  "Try to find N free square meters that are adjacent and that begin
+at X and Y.  PRED is a predicate function of two arguments that
+returns a true value if the arguments specify the coordinates of an
+allocatable square meter."
+  (unless (funcall pred x y)
+    (error "sqm ~A/~A not allocatable" x y))
+  (let ((allocated (make-hash-table :test #'equal))
+        (connected (list (list x y)))
+        (border-queue (bos.web::make-queue)))
+    (labels
+        ((try-get (&rest key)
+           (when (and (not (gethash key allocated))
+                      (apply pred key))
+             (setf (gethash key allocated) t)
+             (bos.web::enqueue key border-queue)
+             key))
+         (get-next-neighbor (x y)
+           "Return the next neighbor of M2 that can be allocated or NIL if none of the neighbor can be allocated."
+           (or (try-get (1+ x) y)
+               (try-get x (1+ y))
+               (try-get (1- x) y)
+               (try-get x (1- y)))))
+      (dotimes (i (1- n)
+                (append connected (bos.web::elements border-queue)))
+        (tagbody
+         retry
+           (let ((next (get-next-neighbor x y)))
+             (unless next
+               (cond
+                 ((bos.web::queue-empty-p border-queue)
+                  (return nil))
+                 (t
+                  (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