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)