Changeset 3586

Show
Ignore:
Timestamp:
07/23/08 17:07:18 (4 months ago)
Author:
ksprotte
Message:

removed stripes from allocation - still ongoing work with try-allocation

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/projects/bos/m2/allocation.lisp

    r3574 r3586  
    1 ;;;; Quadratmeterbelegungsroutine: 
    2 ;;;; 
    3 ;;;; Oeffentliche API: 
    4 ;;;;   - MAKE-ALLOCATION-AREA (polygon-ecken) 
    5 ;;;;     Dabei uebergebe man einen Vektor von (x . y) Conses, z.B. 
    6 ;;;;       (MAKE-ALLOCATION-AREA #((0 . 0) (200 . 0) (200 . 200) (0 . 200))) 
    7 ;;;;     fuer ein Rechteck.  Die Koordinaten muessen im Gesamtgebiet liegen. 
    8 ;;;; Diese Funktion ist eine Transaktion. 
    9 ;;;; 
    10 ;;;; Halboeffentliche API: 
    11 ;;;;   - FIND-FREE-M2S (N) 
    12 ;;;;     Liefere eine Liste von N zusammenhaengenden derzeit freien 
    13 ;;;;     Quadratmetern (oder einen Fehler). 
    14 ;;;; Diese Funktion wird von MAKE-CONTRACT automatisch aufgerufen und sollte 
    15 ;;;; auch auf diesem Wege verwendet werden. 
    16  
    171(in-package :bos.m2) 
    18  
    19 (defvar *preallocate-stripes* nil) 
    202 
    213(define-persistent-class allocation-area () 
    …… 
    268   (height :update) 
    279   (vertices :update) 
    28    (y :update) 
    29    (stripes :update) 
     10   (y :update)   
    3011   (total-m2s :read) 
    3112   (free-m2s :update) 
    3213   (bounding-box :update :transient t)) 
    3314  (:documentation 
    34    "A polygon in which to allocate meters.  LEFT, TOP, WIDTH, and HEIGHT 
    35      designate the bounding rectangle of the polygon.  VERTICES is the 
    36      list of coordinates (x . y) of the polygon vertices.  Initially the area 
    37      is unallocated.  Is is then partitioned into stripes by the allocation 
    38      algorithm.  Y is the smallest row not allocated to a stripe yet. 
    39      When Y >= (TOP+HEIGHT), the partition is complete and no more stripes 
    40      can be added to the area.  Active areas (with ACTIVE-P set) are 
    41      considered for allocation before inactive areas.  Inactive areas are 
    42      activated automatically when the previously active areas do not 
    43      provide enough space to meet allocation guarantees.  When such activation 
    44      is done, a warning message is sent, to avoid running out of allocation 
    45      areas.")) 
     15   "A polygon in which to allocate meters.  LEFT, TOP, WIDTH, and 
     16    HEIGHT designate the bounding rectangle of the polygon. 
     17    VERTICES is the list of coordinates (x . y) of the polygon 
     18    vertices.  Initially the area is unallocated. Active 
     19    areas (with ACTIVE-P set) are considered for allocation 
     20    before inactive areas.  Inactive areas are activated 
     21    automatically when the previously active areas do not provide 
     22    enough space to meet allocation guarantees.  When such 
     23    activation is done, a warning message is sent, to avoid 
     24    running out of allocation areas.")) 
    4625 
    4726(defmethod print-object ((allocation-area allocation-area) stream) 
    …… 
    6746  (mapc #'(lambda (tile) (image-tile-changed tile)) (allocation-area-tiles allocation-area))) 
    6847 
    69 (defmethod destroy-object :before ((allocation-area allocation-area)) 
    70   (dolist (stripe (allocation-area-stripes allocation-area)) 
    71     (delete-object stripe)) 
     48(defmethod destroy-object :before ((allocation-area allocation-area))   
    7249  (notify-tiles allocation-area)) 
    7350 
    …… 
    7653 
    7754(defun compute-bounding-box (vertices) 
    78   "Compute the smallest bounding box of the (x . y) points in VERTICES 
    79    and return it as multiple values (LEFT TOP WIDTH HEIGHT), chosen to be  
    80    inclusive of the leftmost/topmost points but exclusive (!) of the 
    81    rightmost/bottommost points." 
     55  "Compute the smallest bounding box of the (x . y) points in 
     56   VERTICES and return it as multiple values (LEFT TOP WIDTH 
     57   HEIGHT), chosen to be inclusive of the leftmost/topmost points 
     58   but exclusive (!) of the rightmost/bottommost points." 
    8259  (let* ((left (car (elt vertices 0))) 
    8360         (top (cdr (elt vertices 0))) 
    …… 
    141118             do (dolist (allocation-area (class-instances 'allocation-area)) 
    142119                  (when (point-in-polygon-p x y (allocation-area-vertices allocation-area)) 
    143                     (error "new allocation area must not intersect with existing allocation area ~A" allocation-area)))))) 
     120                    (error "new allocation area must not intersect with existing allocation area ~A" 
     121                           allocation-area)))))) 
    144122   
    145123  (make-allocation-area/unchecked vertices)) 
    …… 
    155133                        :height height 
    156134                        :y top 
    157                         :active-p nil 
    158                         :stripes '() 
    159                         :vertices vertices))) 
    160       (when *preallocate-stripes* 
    161         (make-stripe result left top width height)) 
     135                        :active-p nil                       
     136                        :vertices vertices)))       
    162137      result))) 
    163138 
    …… 
    212187  (remove-if-not #'allocation-area-active-p (all-allocation-areas))) 
    213188 
    214 (defun find-inactive-nonempty-allocation-areas () 
     189(defun inactive-nonempty-allocation-areas () 
    215190  (remove-if-not #'(lambda (allocation-area) 
    216191                     (not (or (allocation-area-active-p allocation-area) 
    …… 
    302277    (tiles-crossing left top width height))) 
    303278 
    304 (define-persistent-class stripe () 
    305   ((left :update) 
    306    (top :update) 
    307    (width :update) 
    308    (height :update) 
    309    (x :update) 
    310    (y :update) 
    311    (area :update) 
    312    (seen :update)) 
    313   (:documentation 
    314    "A rectangle in which to allocate meters.  LEFT, TOP, WIDTH, and HEIGHT 
    315      designate the dimensions of the stripe.  X and Y point to the next free 
    316      square meter.  If X or Y point to a square meter outside of the stripe, 
    317      and no square meters have already been SEEN, there are not free square 
    318      meters left.  SEEN lists square meters known to be inside the allocation 
    319      polygon for this stripe in the appropriate allocation order.  Elements of 
    320      SEEN can be sold immediately unless they turn out to have been sold by 
    321      other means in the meantime. 
    322  
    323          left    x 
    324             |    | 
    325             v    v 
    326      top -> xxxxxx..........................  - 
    327             xxxxxx..........................  | height 
    328             xxxxxx..........................  | 
    329        y -> xxxxx...........................  - 
    330  
    331             |------------------------------| 
    332                         width 
    333     Legend: 
    334       x = allocated 
    335       . = unallocated")) 
    336  
    337 (defmethod initialize-persistent-instance :after ((instance stripe)) 
    338   (with-slots (stripes y) (stripe-area instance) 
    339     (setf stripes (sort-area-stripes (cons instance stripes))) 
    340     (setf y (max y (+ (stripe-top instance) (stripe-height instance)))))) 
    341  
    342 (defmethod destroy-object :before ((stripe stripe)) 
    343   (with-slots (stripes) (stripe-area stripe) 
    344     (setf stripes (remove stripe stripes)))) 
    345  
    346 (defmethod print-object ((object stripe) stream) 
    347   (print-unreadable-object (object stream :type t :identity nil) 
    348     (format stream "~D at (~D,~D) sized (~D,~D) ptr (~D,~D)" 
    349             (store-object-id object) 
    350             (stripe-left object) 
    351             (stripe-top object) 
    352             (stripe-width object) 
    353             (stripe-height object) 
    354             (stripe-x object) 
    355             (stripe-y object)))) 
    356  
    357 (defun make-stripe (area left top width height) 
    358   (make-object 'stripe 
    359                :area area 
    360                :left left 
    361                :top top 
    362                :width width 
    363                :height height 
    364                :x left 
    365                :y (if (evenp left) top (+ top height -1)) 
    366                :seen '())) 
    367  
    368 (defun sort-area-stripes (stripes) 
    369   "Liefere STRIPES sortiert erstens nach aufsteigender Hoehe, zweitens 
    370    von oben nach unten." 
    371   (sort (copy-list stripes) 
    372         (lambda (a b) 
    373           (let ((ha (stripe-height a)) 
    374                 (hb (stripe-height b))) 
    375             (cond 
    376               ((< ha hb) 
    377                t) 
    378               ((eql ha hb) 
    379                (< (stripe-top a) (stripe-top b))) 
    380               (t 
    381                nil)))))) 
    382  
    383 (defun store-stripes () 
    384   "Liefere alle STRIPES, sortiert erstens nach ihrer Area, zweitens nach 
    385    aufsteigender Hoehe, drittens von oben nach unten." 
    386   (loop for area in (active-allocation-areas) 
    387      append (allocation-area-stripes area))) 
    388  
    389 (defun add-new-stripe/area (n area) 
    390   "Return a newly allocated stripe contained in AREA suitable for allocation 
    391    of N square meters, or NIL if place for such a stripe was left." 
    392   (let ((h (ceiling (sqrt n)))) 
    393     (with-slots (y left top height width stripes) area 
    394       (when (<= (+ y h) (+ top height)) 
    395         (make-stripe area left y width h))))) 
    396  
    397 (defun used-stripe-width (stripe) 
    398   (with-slots (x y left top height) stripe 
    399     (- (if (if (evenp x) 
    400                (eql y top) 
    401                (eql y (+ top height -1))) 
    402            x 
    403            (1+ x)) 
    404        left))) 
    405  
    406 (defun split-stripe-horizontally (stripe) 
    407   "Split STRIPE into three parts. 
    408  
    409    Example: 
    410      xxxxx........................... 
    411      xxxxx........................... 
    412      xxxxx........................... 
    413      xxxx............................ 
    414  
    415    Example after: 
    416      xxxxxAAAAAAAAAAAAAAAAAAAAAAAAAAA 
    417      xxxxxAAAAAAAAAAAAAAAAAAAAAAAAAAA 
    418      xxxxxBBBBBBBBBBBBBBBBBBBBBBBBBBB 
    419      xxxx.BBBBBBBBBBBBBBBBBBBBBBBBBBB 
    420  
    421    Legend: 
    422      x = old stripe, allocated 
    423      . = old stripe, unallocated 
    424      A = new stripe, unallocated 
    425      B = new stripe, unallocated" 
    426   (assert (> (stripe-width stripe) 1)) 
    427   (with-slots (left top width height x y area) stripe 
    428     (let ((old-width width)) 
    429       ;; cut stripe to actually allocated width 
    430       (setf width (used-stripe-width stripe)) 
    431       ;; add upper half of removed right part  
    432       (make-stripe area 
    433                    (+ left width) 
    434                    top 
    435                    (- old-width width) 
    436                    (truncate height 2)) 
    437       ;; add lower half of removed right part  
    438       (make-stripe area 
    439                    (+ left width) 
    440                    (+ top (truncate height 2)) 
    441                    (- old-width width) 
    442                    (ceiling height 2))))) 
    443  
    444 (defun split-stripe-vertically (stripe) 
    445   "Split STRIPE into two parts and return true if possible, else do nothing 
    446    and return NIL. 
    447  
    448    Example: 
    449      XXXXXxxxxxxxxxxxxxxxxxxxxxxxxxxx 
    450      XXXXXxxxxxxxxxxxxxxxxxxxxxxxxxxx 
    451      XXXXxxxxxxxxxxxxxxxxxxxxxxxxxxxx 
    452      XXXXxxxxxxxxxxxxxxxxxxxxxxxxxxxx 
    453  
    454    Example after: 
    455      XXXXXyyyyyyyyyyyyyyyyyyyyyyyyyyy 
    456      XXXXXyyyyyyyyyyyyyyyyyyyyyyyyyyy 
    457      XXXXxyyyyyyyyyyyyyyyyyyyyyyyyyyy 
    458      XXXXxyyyyyyyyyyyyyyyyyyyyyyyyyyy 
    459  
    460    Legend: 
    461      X = old stripe, allocated 
    462      x = old stripe, unallocated 
    463      y = new stripe, unallocated" 
    464   (with-slots (left top width height x y area) stripe 
    465     (let ((old-width width)) 
    466       (setf width (used-stripe-width stripe)) 
    467       (if (eql width old-width) 
    468           nil 
    469           (make-stripe area 
    470                        (+ left width) 
    471                        top 
    472                        (- old-width width) 
    473                        height))))) 
    474  
    475 (defun classify-stripe (n stripe) 
    476   "Passen N Quadratmeter in den STRIPE unter Wahrung des gewuenschten 
    477    Rechtecksverhaeltnisses von maximal 1x2? 
    478      STRIPE-TOO-SMALL: Nein, weil der Stripe zu schmal ist. 
    479      STRIPE-NEARLY-FULL: Sonderfall: Der Stripe ist eigentlich zu hoch, 
    480        aber schon am rechten Rand angekommen.  Hier wird man in der Praxis 
    481        im Gegenteil nur winzige Bloecke noch unterbringen koennen. 
    482      STRIPE-TOO-LARGE: Nein, weil der Stripe zu hoch ist (und nicht voll) 
    483      STRIPE-MATCHES: sonst" 
    484   (let ((wanted-height (ceiling (sqrt n))) 
    485         (stripe-height (stripe-height stripe))) 
    486     (cond 
    487       ((<= (* 2 stripe-height) wanted-height) 
    488        :stripe-too-small) 
    489       ((< wanted-height stripe-height) 
    490        (if (< (stripe-x stripe) 
    491               (+ (stripe-left stripe) (stripe-width stripe) -1)) 
    492            :stripe-too-large 
    493            :stripe-nearly-full)) 
    494       (t 
    495        :stripe-matches)))) 
    496  
    497 (defun stripe-dissection-p (x stripe) 
    498   "Ist STRIPE an der angegebenen X-Koordinate senkrecht durch das Polygon 
    499    zerschnitten?" 
    500   ;; fixme: das ist kein 100%ig perfekter Test, aber er sollte genuegen, um 
    501   ;; optisch sichtbare Trennung in einem Contract zu verhindern. 
    502   (with-slots (top height area) stripe 
    503     (loop with vertices = (allocation-area-vertices area) 
    504        for y from top below (+ top height) 
    505        never (in-polygon-p x y vertices)))) 
    506  
    507 (defun stripe-full-p (stripe) 
    508   (with-slots (left top width height x y seen) stripe 
    509     (let ((right (+ left width)) 
    510           (bottom (+ top height))) 
    511       (not (or (and (<= left x (1- right)) (<= top y (1- bottom))) seen))))) 
    512  
    513 (defun find-free-m2s/stripe (n stripe) 
    514   "Find N connected free square meterns in STRIPE, or return NIL. 
    515    Square meters are allocated left-to-right, in a top-down, then  
    516    bottom-up pattern,in order to ensure (a) connectivity and (b) that the 
    517    space does not become fragmented." 
    518   (with-slots (left top width height x y seen) stripe 
    519     (let ((new-x x)                     ;working copy of x 
    520           (new-y y)                     ;working copy of y 
    521           (new-seen seen)               ;working copy of free 
    522           (result '()) 
    523           (right (+ left width)) 
    524           (bottom (+ top height)) 
    525           (vertices (allocation-area-vertices (stripe-area stripe)))) 
    526       (when (stripe-full-p stripe) 
    527         ;; Gleich NIL liefern, und den Stripe beseitigen, damit wir ihn nicht 
    528         ;; wieder antreffen in Zukunft. 
    529         (delete-object stripe) 
    530         (return-from find-free-m2s/stripe nil)) 
    531       (labels ((find-next-m2 () 
    532                  "Return the next square meter in stripe, using the  
    533                   temporary counters, or NIL if stripe is fully allocated." 
    534                  (let ((this-x new-x) 
    535                        (this-y new-y)) 
    536                    (when (and (<= left this-x (1- right)) 
    537                               (<= top this-y (1- bottom))) 
    538                      (cond 
    539                        ((evenp new-x)   ;top-down 
    540                         (incf new-y) 
    541                         (when (>= new-y bottom) 
    542                           (decf new-y) 
    543                           (incf new-x))) 
    544                        (t               ;bottom-up 
    545                         (decf new-y) 
    546                         (when (< new-y top) 
    547                           (incf new-y) 
    548                           (incf new-x)))) 
    549                      (ensure-m2 this-x this-y)))) 
    550                (find-free-m2 () 
    551                  "Return the next *free* square meter in stripe, using the 
    552                   temporary counters, or NIL if stripe is fully allocated." 
    553                  (or (loop 
    554                         (let ((m2 (pop new-seen))) 
    555                           (cond 
    556                             ((null m2) 
    557                              (return nil)) 
    558                             ((null (m2-contract m2)) 
    559                              (return m2))))) 
    560                      (loop 
    561                         (let ((m2 (find-next-m2))) 
    562                           (cond 
    563                             ((null m2) 
    564                              (return nil))                                                                                      
    565                             ((or (not (m2s-connected-p result)) 
    566                                  (and (not (in-polygon-p (m2-x m2) (m2-y m2) vertices)) 
    567                                       (stripe-dissection-p (m2-x m2) stripe) 
    568                                       (or result new-seen)))                         
    569                              ;; Wenn wir hier weitermachen und das Polygon 
    570                              ;; nicht konvex ist, ist das Ergebnis nicht 
    571                              ;; zusammenhaengend.  Also aufgeben und in der 
    572                              ;; rechten Haelfe des Stripes weitermachen. 
    573                              (setf x new-x 
    574                                    y new-y 
    575                                    seen (append new-seen (reverse result))) 
    576                              (let ((right (split-stripe-vertically stripe))) 
    577                                (return-from find-free-m2s/stripe 
    578                                  (if right 
    579                                      (find-free-m2s/stripe n right) 
    580                                      nil)))) 
    581                             ((null (m2-contract m2)) 
    582                              (return m2)))))))) 
    583         (dotimes (dummy n 
    584                   (progn                ;success 
    585                     (setf x new-x 
    586                           y new-y 
    587                           seen new-seen) 
    588                     (when result 
    589                       (assert (= (length result) n)) 
    590                       (with-slots (area) stripe 
    591                         (print (list '********** 'will-decrease-count-by n))                         
    592                         (decf (allocation-area-free-m2s area) n) 
    593                         (when (null (allocation-area-free-m2s area)) 
    594                           (deactivate-allocation-area area)))) 
    595                     result)) 
    596           (let ((m2 (find-free-m2))) 
    597             (unless m2                  ;failure 
    598               (setf x new-x 
    599                     y new-y 
    600                     seen (append new-seen (reverse result))) 
    601               (return nil)) 
    602             (push m2 result))))))) 
    603  
    604 (defun find-free-m2s/exact (n area) 
    605   "Find an allocation stripe in AREA of size HEIGHT with N free square 
    606    meters.  Return the square meters found or return NIL if no such stripe 
    607    is found." 
    608   (dolist (stripe (allocation-area-stripes area)) 
    609     (when (eq (classify-stripe n stripe) :stripe-matches) 
    610       (let ((result (find-free-m2s/stripe n stripe))) 
    611         (when result 
    612           (return result)))))) 
    613  
    614 (defun find-free-m2s/grow (n area) 
    615   "Create a new stripe of suitable size for N square meters in AREA.  If no 
    616    such stripe can be created, return NIL.  If a stripe could be created but 
    617    N square meters could not actually be allocated in the stripe, repeat." 
    618   (loop for stripe = (add-new-stripe/area n area) 
    619      while stripe 
    620      do 
    621      (let ((result (find-free-m2s/stripe n stripe))) 
    622        (when result 
    623          (return result))))) 
    624  
    625 (defun find-free-m2s/overflow (n area) 
    626   "Find an allocation stripe in store of size HEIGHT with N free square 
    627    meters.  Return the square meters found.  If no such stripe exists, split 
    628    the next biggest stripe into two and try again." 
    629   (let ((stripes (allocation-area-stripes area)) 
    630         (result nil)) 
    631     (loop 
    632        for stripe = (pop stripes) 
    633        while stripe 
    634        until result 
    635        do 
    636        (ecase (classify-stripe n stripe) 
    637          (:stripe-too-small) 
    638          (:stripe-matches 
    639           (setf result (find-free-m2s/stripe n stripe))) 
    640          (:stripe-too-large 
    641           (split-stripe-horizontally stripe) 
    642           (setf stripes (allocation-area-stripes area))) 
    643          (:stripe-nearly-full 
    644           (when (<= n 2) 
    645             (setf result (find-free-m2s/stripe n stripe)))))) 
    646     result)) 
    647  
    648 (defmethod allocation-area-find-free-m2s ((area allocation-area) n) 
    649   (assert (plusp n)) 
    650   (when (<= n (allocation-area-free-m2s area)) 
    651     (let ((m2s (or (find-free-m2s/exact n area) 
    652                    (find-free-m2s/grow n area) 
    653                    (find-free-m2s/overflow n area)))) 
    654       m2s))) 
    655  
    656 (defmethod return-m2 ((allocation-area allocation-area)) 
    657   (incf (allocation-area-free-m2s allocation-area))) 
    658  
    659 (defun find-free-m2s/underflow (n) 
    660   "Find the largest allocation stripe in store able to hold N free square 
    661    meters and return the square meters found, or NIL if no such stripe exists." 
    662   (some (lambda (stripe) 
    663           (find-free-m2s/stripe n stripe)) 
    664         (loop for area in (reverse (active-allocation-areas)) 
    665            append (allocation-area-stripes area)))) 
     279(defun allocation-area-consistent-p (allocation-area) 
     280  (let ((total (calculate-total-m2-count allocation-area)) 
     281        (allocated (calculate-allocated-m2-count allocation-area)) 
     282        (consistent-p t)) 
     283    (unless (= total (allocation-area-total-m2s allocation-area)) 
     284      (warn "~s's total count is ~d but should be ~d" 
     285            allocation-area (allocation-area-total-m2s allocation-area) total) 
     286      (setf consistent-p nil)) 
     287    (unless (= (- total allocated) (allocation-area-free-m2s allocation-area)) 
     288      (warn "~s's free count is ~d but should be ~d" 
     289            allocation-area (allocation-area-free-m2s allocation-area) (- total allocated)) 
     290      (setf consistent-p nil)) 
     291    consistent-p)) 
     292 
     293;;; allocation 
     294(defun try-allocation (n x y pred) 
     295  "Try to find N free square meters that are adjacent and that begin 
     296at X and Y.  PRED is a predicate function of two arguments that 
     297returns a true value if the arguments specify the coordinates of an 
     298allocatable square meter." 
     299  (unless (funcall pred x y) 
     300    (error "sqm ~A/~A not allocatable" x y)) 
     301  (let* ((allocated (make-hash-table :test #'equal)) 
     302         (initial-key (list x y)) 
     303         (border-queue (bos.web::make-queue)) 
     304         connected) 
     305    (setf (gethash initial-key allocated) t) 
     306    (labels 
     307        ((try-get (&rest key)            
     308           (when (and (not (gethash key allocated)) 
     309                      (apply pred key))              
     310             (setf key (copy-list key)) 
     311             (setf (gethash key allocated) t) 
     312             (bos.web::enqueue key border-queue) 
     313             key)) 
     314         (get-next-neighbor (x y) 
     315           "Return the next neighbor of M2 that can be allocated or NIL if none of the neighbor can be allocated." 
     316           (or (try-get (1+ x) y) 
     317               (try-get x (1+ y)) 
     318               (try-get (1- x) y) 
     319               (try-get x (1- y))))) 
     320      (dotimes (i (1- n) 
     321                (append #+nil(list initial-key) 
     322                        connected 
     323                        (bos.web::queue-elements border-queue))) 
     324        (tagbody 
     325         retry 
     326           (let ((next (get-next-neighbor x y))) 
     327             (unless next 
     328               (cond 
     329                 ((bos.web::queue-empty-p border-queue) 
     330                  (return nil)) 
     331                 (t 
     332                  (push (list x y) connected) 
     333                  (multiple-value-setq (x y) 
     334                    (values-list (bos.web::dequeue border-queue))) 
     335                  (go retry)))))))))) 
     336 
     337(defun allocate-in-area (area n) 
     338  (let* ((area-left (allocation-area-left area)) 
     339         (area-top (allocation-area-top area)) 
     340         (area-width (allocation-area-width area)) 
     341         (area-height (allocation-area-height area)) 
     342         (area-right (+ area-left area-width)) 
     343         (area-bottom (+ area-top area-height))) 
     344    (labels ((allocatable-p (x y) 
     345               (and (<= area-left x area-right) 
     346                    (<= area-top y area-bottom) 
     347                    (let ((m2 (ensure-m2 x y))) 
     348                      (and (not (m2-contract m2)) 
     349                           m2))))) 
     350      (loop 
     351         (let ((x (+ area-left (random area-width))) 
     352               (y (+ area-top (random area-height)))) 
     353           (unless (m2-contract (ensure-m2 x y)) 
     354             (let ((result (try-allocation n x y #'allocatable-p))) 
     355               (when result 
     356                 (assert (alexandria:setp result :test #'equal)) 
     357                 (assert (= n (length result))) 
     358                 (return (mapcar (lambda (x-y) 
     359                                   (destructuring-bind (x y) 
     360                                       x-y 
     361                                     (ensure-m2 x y))) 
     362                                 result)))))))))) 
    666363 
    667364(defun allocate-m2s-for-sale (n) 
    668   "The main entry point to the allocation machinery.  Will return a 
    669 list of N m2 instances or NIL if the requested amount cannot be 
    670 allocated. 
    671 Returned m2s will not be allocated again (i.e. there are 
    672 marked as in use) by the allocation algorithm, but see RETURN-CONTRACT-M2S." 
    673   (labels ((allocate-in-active-areas (n) 
    674              (or (bos.m2.allocation-cache:find-exact-match n :remove t)  
    675                  (some (lambda (area) (allocation-area-find-free-m2s area n)) 
    676                        (active-allocation-areas)))) 
    677            (can-possibly-allocate-request (n) 
    678              (find n (all-allocation-areas) :key #'allocation-area-free-m2s :test #'<=)) 
    679            (allocate-without-activation (area n)                
    680              (let ((status (allocation-area-active-p area))) 
    681                (unwind-protect 
    682                     (progn 
    683                       (setf (slot-value area 'active-p) t) 
    684                       (allocate-in-active-areas n)) 
    685                  (setf (slot-value area 'active-p) status))))) 
    686     (assert (plusp n)) 
    687     (unless (in-transaction-p) 
    688       (error "find-free-m2s called outside of the allocation transaction")) 
    689     (or (allocate-in-active-areas n) 
    690         (unless (can-possibly-allocate-request n) 
    691           (return-from allocate-m2s-for-sale nil))           
    692         (loop 
    693            for area in (find-inactive-nonempty-allocation-areas) 
    694            for m2s = (allocate-without-activation area n)  
    695            when m2s 
    696            do (activate-allocation-area area) and 
    697            return m2s) 
    698         (find-free-m2s/underflow n) 
    699         nil))) 
    700  
    701 (defmethod return-contract-m2s (m2s) 
     365  "The main entry point to the allocation machinery.  Will return 
     366   a list of N m2 instances or NIL if the requested amount cannot 
     367   be allocated.  Returned m2s will not be allocated 
     368   again (i.e. there are marked as in use) by the allocation 
     369   algorithm, but see RETURN-CONTRACT-M2S." 
     370  (dolist (area (active-allocation-areas)) 
     371    (let ((m2s (allocate-in-area area n))) 
     372      (when m2s (return-from allocate-m2s-for-sale m2s)))) 
     373  (dolist (area (inactive-nonempty-allocation-areas)) 
     374    (let ((m2s (allocate-in-area area n))) 
     375      (when m2s (return-from allocate-m2s-for-sale m2s))))) 
     376 
     377(defun return-contract-m2s (m2s) 
    702378  "Mark the given square meters as free, so that they can be re-allocated." 
    703379  (when m2s 
    …… 
    719395  t) 
    720396 
    721 ;; debugging 
    722 (defun find-stripes-around-point (x y) 
    723   (remove-if-not (lambda (s) 
    724                    (with-slots (left top width height) s 
    725                      (and (<= left x (+ left width -1)) 
    726                           (<= top y (+ top height -1))))) 
    727                  (store-stripes))) 
    728  
    729 (defun delete-full-stripes () 
    730   (bknr.datastore::without-sync () 
    731     (dolist (stripe (store-stripes)) 
    732       (when (stripe-full-p stripe) 
    733         (delete-object stripe))))) 
    734  
    735 (defun estimate-fill-ratio () 
    736   "Liefere eine Schaetzung (!) der aktuellen Vergabequote in den vorhandenen 
    737    Allocation Areas als Gleitkommazahl." 
    738   (float (multiple-value-call #'/ (estimate-fill-counters)))) 
    739  
    740 (defun estimate-fill-counters () 
    741   "Liefere eine Schaetzung (!) der Anzahl 1. der aktuell vergebenen und 
    742    2. der insgesamt verfuegbaren Quadratmeter im Store als multiple values." 
    743   (let ((nallocated 0) 
    744         (ntotal 0)) 
    745     (dolist (area (all-allocation-areas)) 
    746       (multiple-value-bind (a b) 
    747           (estimate-fill-counters/area area) 
    748         (incf nallocated a) 
    749         (incf ntotal b))) 
    750     (values nallocated ntotal))) 
    751  
    752 (defun estimate-fill-counters/area (area) 
    753   "Liefere eine Schaetzung (!) der Anzahl 1. der aktuell vergebenen und 
    754    2. der insgesamt verfuegbaren Quadratmeter in AREA als multiple values." 
    755   (let ((nallocated 0) 
    756         (ntotal 0)) 
    757     (dolist (stripe (allocation-area-stripes area)) 
    758       (multiple-value-bind (a b) 
    759           (estimate-fill-counters/stripe stripe) 
    760         (incf nallocated a) 
    761         (incf ntotal b))) 
    762     (values nallocated ntotal))) 
    763  
    764 (defun estimate-fill-counters/stripe (stripe) 
    765   "Liefere eine Schaetzung (!) der Anzahl 1. der aktuell vergebenen und 
    766    2. der insgesamt verfuegbaren Quadratmeter in STRIPE als multiple values." 
    767   (values (+ (* (- (stripe-x stripe) (stripe-left stripe)) 
    768                 (stripe-height stripe)) 
    769              (- (stripe-y stripe) (stripe-top stripe))) 
    770           (* (stripe-width stripe) (stripe-height stripe)))) 
    771  
    772  
    773 (defun allocation-area-consistent-p (allocation-area) 
    774   (let ((total (calculate-total-m2-count allocation-area)) 
    775         (allocated (calculate-allocated-m2-count allocation-area)) 
    776         (consistent-p t)) 
    777     (unless (= total (allocation-area-total-m2s allocation-area)) 
    778       (warn "~s's total count is ~d but should be ~d" 
    779             allocation-area (allocation-area-total-m2s allocation-area) total) 
    780       (setf consistent-p nil)) 
    781     (unless (= (- total allocated) (allocation-area-free-m2s allocation-area)) 
    782       (warn "~s's free count is ~d but should be ~d" 
    783             allocation-area (allocation-area-free-m2s allocation-area) (- total allocated)) 
    784       (setf consistent-p nil)) 
    785     consistent-p)) 
    786  
     397 
     398 
     399