[bknr-cvs] ksprotte changed trunk/projects/bos/
BKNR Commits
bknr at bknr.net
Wed Jul 23 15:44:13 UTC 2008
Revision: 3588
Author: ksprotte
URL: http://bknr.net/trac/changeset/3588
checkpoint - some more work on allocation
U trunk/projects/bos/m2/allocation.lisp
U trunk/projects/bos/m2/geometry.lisp
D trunk/projects/bos/m2/test-allocation.lisp
U trunk/projects/bos/web/quad-tree.lisp
Modified: trunk/projects/bos/m2/allocation.lisp
===================================================================
--- trunk/projects/bos/m2/allocation.lisp 2008-07-23 15:28:01 UTC (rev 3587)
+++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 15:44:13 UTC (rev 3588)
@@ -297,7 +297,7 @@
returns a true value if the arguments specify the coordinates of an
allocatable square meter."
(unless (funcall pred start-x start-y)
- (error "sqm ~A/~A not allocatable" x y))
+ (error "sqm ~A/~A not allocatable" start-x start-y))
(let* ((allocated (make-hash-table :test #'equal))
(border-queue (bos.web::make-queue))
connected)
@@ -308,7 +308,8 @@
(bos.web::enqueue key border-queue)))
(try-get (&rest key)
(and (not (gethash key allocated))
- (apply pred key)))
+ (apply pred key)
+ key))
(get-next-neighbor (x y)
(or (try-get (1+ x) y)
(try-get x (1+ y))
@@ -335,18 +336,16 @@
(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)))
+ ;; (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)
- (let ((m2 (ensure-m2 x y)))
- (and (not (m2-contract m2))
- m2)))))
+ (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))))
- (unless (m2-contract (ensure-m2 x y))
+ (when (allocatable-p x y)
(let ((result (try-allocation n x y #'allocatable-p)))
(when result
(assert (alexandria:setp result :test #'equal))
Modified: trunk/projects/bos/m2/geometry.lisp
===================================================================
--- trunk/projects/bos/m2/geometry.lisp 2008-07-23 15:28:01 UTC (rev 3587)
+++ trunk/projects/bos/m2/geometry.lisp 2008-07-23 15:44:13 UTC (rev 3588)
@@ -450,3 +450,15 @@
(traverse (list (first nodes)))
(= (length nodes)
(hash-table-count hash)))))
+
+(defun ascii-plot-points (objects &key key)
+ (fresh-line)
+ (let ((bbox (bounding-box objects :key key)))
+ (with-rectangle bbox
+ (loop for y from top below (+ top height)
+ do (loop for x from left below (+ left width)
+ if (member (list x y) objects :key key :test #'equal)
+ do (princ "x")
+ else do (princ "."))
+ do (terpri)))))
+
Deleted: trunk/projects/bos/m2/test-allocation.lisp
===================================================================
--- trunk/projects/bos/m2/test-allocation.lisp 2008-07-23 15:28:01 UTC (rev 3587)
+++ trunk/projects/bos/m2/test-allocation.lisp 2008-07-23 15:44:13 UTC (rev 3588)
@@ -1,62 +0,0 @@
-(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))))))))))
-
-(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)))))))))
-
-
-
Modified: trunk/projects/bos/web/quad-tree.lisp
===================================================================
--- trunk/projects/bos/web/quad-tree.lisp 2008-07-23 15:28:01 UTC (rev 3587)
+++ trunk/projects/bos/web/quad-tree.lisp 2008-07-23 15:44:13 UTC (rev 3588)
@@ -130,11 +130,17 @@
(setf (cdr queue) (setf (car queue) (list x)))
(setf (cdr (cdr queue)) (list x)
(cdr queue) (cdr (cdr queue))))
- (car queue))
+ (caar queue))
(defun dequeue (queue)
(pop (car queue)))
+(defun queue-elements (queue)
+ (car queue))
+
+(defun peek-queue (queue)
+ (caar queue))
+
;;; quad-node
(defclass quad-node ()
((geo-box :reader geo-box :initarg :geo-box :type geo-box)
More information about the Bknr-cvs
mailing list