Revision: 3574 Author: ksprotte URL: http://bknr.net/trac/changeset/3574

working on allocation U trunk/projects/bos/m2/allocation.lisp

Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-23 09:34:27 UTC (rev 3573) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 11:02:25 UTC (rev 3574) @@ -561,22 +561,23 @@ (let ((m2 (find-next-m2))) (cond ((null m2) - (return nil)) - ((not (in-polygon-p (m2-x m2) (m2-y m2) vertices)) - (when (and (stripe-dissection-p (m2-x m2) stripe) - (or result new-seen)) - ;; Wenn wir hier weitermachen und das Polygon - ;; nicht konvex ist, ist das Ergebnis nicht - ;; zusammenhaengend. Also aufgeben und in der - ;; rechten Haelfe des Stripes weitermachen. - (setf x new-x - y new-y - seen (append new-seen (reverse result))) - (let ((right (split-stripe-vertically stripe))) - (return-from find-free-m2s/stripe - (if right - (find-free-m2s/stripe n right) - nil))))) + (return nil)) + ((or (not (m2s-connected-p result)) + (and (not (in-polygon-p (m2-x m2) (m2-y m2) vertices)) + (stripe-dissection-p (m2-x m2) stripe) + (or result new-seen))) + ;; Wenn wir hier weitermachen und das Polygon + ;; nicht konvex ist, ist das Ergebnis nicht + ;; zusammenhaengend. Also aufgeben und in der + ;; rechten Haelfe des Stripes weitermachen. + (setf x new-x + y new-y + seen (append new-seen (reverse result))) + (let ((right (split-stripe-vertically stripe))) + (return-from find-free-m2s/stripe + (if right + (find-free-m2s/stripe n right) + nil)))) ((null (m2-contract m2)) (return m2)))))))) (dotimes (dummy n @@ -585,8 +586,10 @@ y new-y seen new-seen) (when result + (assert (= (length result) n)) (with-slots (area) stripe - (decf (allocation-area-free-m2s area) n) + (print (list '********** 'will-decrease-count-by n)) + (decf (allocation-area-free-m2s area) n) (when (null (allocation-area-free-m2s area)) (deactivate-allocation-area area)))) result))