[bknr-cvs] r2051 - trunk/projects/bos/m2
bknr at bknr.net
bknr at bknr.net
Sat Nov 4 06:01:18 UTC 2006
Author: hhubner
Date: 2006-11-04 01:01:17 -0500 (Sat, 04 Nov 2006)
New Revision: 2051
Added:
trunk/projects/bos/m2/allocation-experimental.lisp
Modified:
trunk/projects/bos/m2/bos.m2.asd
trunk/projects/bos/m2/m2.lisp
trunk/projects/bos/m2/mail-generator.lisp
trunk/projects/bos/m2/packages.lisp
Log:
Urkundenerzeugung beim Kauf und Versand per Mail.
Added: trunk/projects/bos/m2/allocation-experimental.lisp
===================================================================
--- trunk/projects/bos/m2/allocation-experimental.lisp 2006-11-04 05:52:49 UTC (rev 2050)
+++ trunk/projects/bos/m2/allocation-experimental.lisp 2006-11-04 06:01:17 UTC (rev 2051)
@@ -0,0 +1,731 @@
+;;;; Quadratmeterbelegungsroutine:
+;;;;
+;;;; Oeffentliche API:
+;;;; - MAKE-ALLOCATION-AREA (polygon-ecken)
+;;;; Dabei uebergebe man einen Vektor von (x . y) Conses, z.B.
+;;;; (MAKE-ALLOCATION-AREA #((0 . 0) (200 . 0) (200 . 200) (0 . 200)))
+;;;; fuer ein Rechteck. Die Koordinaten muessen im Gesamtgebiet liegen.
+;;;; Diese Funktion ist eine Transaktion.
+;;;;
+;;;; Halboeffentliche API:
+;;;; - FIND-FREE-M2S (N)
+;;;; Liefere eine Liste von N zusammenhaengenden derzeit freien
+;;;; Quadratmetern (oder einen Fehler).
+;;;; Diese Funktion wird von MAKE-CONTRACT automatisch aufgerufen und sollte
+;;;; auch auf diesem Wege verwendet werden.
+
+(in-package :bos.m2)
+
+(defvar *preallocate-stripes* nil)
+
+(define-persistent-class allocation-area ()
+ ((active-p :update)
+ (left :update)
+ (top :update)
+ (width :update)
+ (height :update)
+ (vertices :update)
+ (y :update)
+ (stripes :update)
+ (total-m2s :read)
+ (free-m2s :update)
+ (allocator-maps :update :transient t)
+ (full-for :update :transient t)
+ (bounding-box :update :transient t))
+ (:documentation
+ "A polygon in which to allocate meters. LEFT, TOP, WIDTH, and HEIGHT
+ designate the bounding rectangle of the polygon. VERTICES is the
+ list of coordinates (x . y) of the polygon vertices. Initially the area
+ is unallocated. Is is then partitioned into stripes by the allocation
+ algorithm. Y is the smallest row not allocated to a stripe yet.
+ When Y >= (TOP+HEIGHT), the partition is complete and no more stripes
+ can be added to the area. Active areas (with ACTIVE-P set) are
+ considered for allocation before inactive areas. Inactive areas are
+ activated automatically when the previously active areas do not
+ provide enough space to meet allocation guarantees. When such activation
+ is done, a warning message is sent, to avoid running out of allocation
+ areas."))
+
+(defmethod initialize-persistent-instance :after ((allocation-area allocation-area))
+ (with-slots (total-m2s free-m2s) allocation-area
+ (setf total-m2s (calculate-total-m2-count allocation-area))
+ (setf free-m2s (- total-m2s (calculate-allocated-m2-count allocation-area))))
+ (dolist (tile (allocation-area-tiles allocation-area))
+ (image-tile-changed tile)))
+
+(defmethod notify-tiles ((allocation-area allocation-area))
+ (mapc #'image-tile-changed (allocation-area-tiles allocation-area)))
+
+(defmethod destroy-object :before ((allocation-area allocation-area))
+ (dolist (stripe (allocation-area-stripes allocation-area))
+ (delete-object stripe))
+ (notify-tiles allocation-area))
+
+(defmethod initialize-transient-instance :after ((allocation-area allocation-area))
+ (setf (allocation-area-allocator-maps allocation-area) (make-hash-table :test #'eql))
+ (notify-tiles allocation-area))
+
+(defun compute-bounding-box (vertices)
+ "Compute the smallest bounding box of the (x . y) points in VERTICES
+ and return it as multiple values (LEFT TOP WIDTH HEIGHT), chosen to be
+ inclusive of the leftmost/topmost points but exclusive (!) of the
+ rightmost/bottommost points."
+ (let* ((left (car (elt vertices 0)))
+ (top (cdr (elt vertices 0)))
+ (right left)
+ (bottom top))
+ (loop for i from 1 below (length vertices) do
+ (let* ((v (elt vertices i))
+ (x (car v))
+ (y (cdr v)))
+ (setf left (min left x)
+ right (max right x)
+ top (min top y)
+ bottom (max bottom y))))
+ (values left top (- right left) (- bottom top))))
+
+(defmethod allocation-area-center ((allocation-area allocation-area))
+ (with-slots (left top width height) allocation-area
+ (list (floor (+ left (/ width 2)))
+ (floor (+ top (/ height 2))))))
+
+(defun make-allocation-rectangle (left top width height)
+ (make-allocation-area (coerce (list (cons left top)
+ (cons (+ left width) top)
+ (cons (+ left width) (+ top height))
+ (cons left (+ top height)))
+ 'vector)))
+
+(defun make-allocation-area (vertices)
+ (assert (>= (length vertices) 3))
+ (map-edges (lambda (a b)
+ (check-type (car a) integer)
+ (check-type (cdr a) integer)
+ (check-type (car b) integer)
+ (check-type (cdr b) integer)
+ ;; Kanten duerfen nicht auf einen Punkt zusammenfallen.
+ (assert (not (and (zerop (- (car a) (car b)))
+ (zerop (- (cdr a) (cdr b)))))))
+ (coerce vertices 'vector))
+ ;; Punkte muessen im Vergabegebiet liegen
+ (map nil
+ (lambda (v)
+ (assert (<= 0 (car v) (1- +width+)))
+ (assert (<= 0 (cdr v) (1- +width+))))
+ vertices)
+
+ ;; Kein Punkt darf in einer anderen allocation area vorhanden sein.
+ ;; Ermangels einer polygon-Schneidefunktion iterieren wir durch alle
+ ;; Punkt der neuen allocation area.
+ (multiple-value-bind (left top width height)
+ (compute-bounding-box vertices)
+ (loop for y from top upto (+ top height)
+ do (loop for x from left upto (+ left width)
+ when (point-in-polygon-p x y vertices)
+ do (dolist (allocation-area (class-instances 'allocation-area))
+ (when (point-in-polygon-p x y (allocation-area-vertices allocation-area))
+ (error "new allocation area must not intersect with existing allocation area ~A" allocation-area))))))
+
+ (make-allocation-area/unchecked vertices))
+
+(deftransaction make-allocation-area/unchecked (vertices)
+ (multiple-value-bind (left top width height)
+ (compute-bounding-box vertices)
+ (let ((result
+ (make-object 'allocation-area
+ :left left
+ :top top
+ :width width
+ :height height
+ :y top
+ :active-p nil
+ :stripes '()
+ :vertices vertices)))
+ (when *preallocate-stripes*
+ (make-stripe result left top width height))
+ result)))
+
+(defmethod allocation-area-bounding-box ((allocation-area allocation-area))
+ (with-slots (left top width height bounding-box) allocation-area
+ (unless (slot-boundp allocation-area 'bounding-box)
+ (setf bounding-box (coerce (list (cons left top)
+ (cons (+ left width) top)
+ (cons (+ left width) (+ top height))
+ (cons left (+ top height)))
+ 'vector)))
+ bounding-box))
+
+(defun gauge (area)
+ "Liefere den Fuellpegel des Vergabegebiets (0 <= gauge <= 1)"
+ (with-slots (y top height) area
+ (/ (- y top) height)))
+
+(defun all-allocation-areas ()
+ "Liefere alle Vergabegebiete, nach Alter sortiert."
+ (let ((unsorted (store-objects-with-class 'allocation-area)))
+ (sort (copy-list unsorted) #'< :key #'store-object-id)))
+
+(defun active-allocation-areas ()
+ "Liefere alle aktiven Vergabegebiete, nach Alter sortiert."
+ (remove-if-not #'allocation-area-active-p (all-allocation-areas)))
+
+(defun find-inactive-allocation-area ()
+ (find-if #'(lambda (allocation-area) (not (or (allocation-area-active-p allocation-area)
+ (null (allocation-area-free-m2s allocation-area)))))
+ (all-allocation-areas)))
+
+(defun activate-allocation-area (area)
+ (warn "activating ~S" area)
+ (setf (slot-value area 'active-p) t)
+ area)
+
+(defun deactivate-allocation-area (area)
+ (warn "deactivating ~S" area)
+ (setf (slot-value area 'active-p) nil)
+ area)
+
+(defun map-edges (fn vertices)
+ (loop
+ for i from 0 below (length vertices)
+ for a = (elt vertices (1- (length vertices))) then b
+ for b = (elt vertices i)
+ do (funcall fn a b)))
+
+(defun in-polygon-p (x y vertices)
+ (let ((c 0))
+ (map-edges (lambda (a b)
+ (let ((x1 (car a))
+ (y1 (cdr a))
+ (x2 (car b))
+ (y2 (cdr b)))
+ (when (or (and (<= y1 y) (> y2 y))
+ (and (> y1 y) (<= y2 y)))
+ (let ((m (/ (- y y1) (- y2 y1))))
+ (when (< x (+ x1 (* m (- x2 x1))))
+ (incf c))))))
+ vertices)
+ (oddp c)))
+
+(defmethod allocation-area-contracts ((allocation-area allocation-area))
+ "Return contracts within an allocation area. XXX Only considers the first sqm of a
+contract, so if a contract is allocated in multiple allocation areas, it may or may
+not be returned by this function"
+ (remove-if #'(lambda (contract)
+ (not (in-polygon-p (m2-x (first (contract-m2s contract)))
+ (m2-y (first (contract-m2s contract)))
+ (allocation-area-vertices allocation-area))))
+ (store-objects-with-class 'contract)))
+
+(defmethod calculate-total-m2-count ((allocation-area allocation-area))
+ "Returns the total number of sqms in the allocation area (note: brute force)"
+ (with-slots (left top width height vertices) allocation-area
+ (loop for x from left upto (+ left width)
+ with retval = 0
+ do (loop for y from top upto (+ top height)
+ when (in-polygon-p x y vertices)
+ do (incf retval))
+ finally (return retval))))
+
+(defmethod calculate-allocated-m2-count ((allocation-area allocation-area))
+ "Returns the number of sqms allocated within an allocation area"
+ (let ((retval 0))
+ (dolist (contract (store-objects-with-class 'contract))
+ (dolist (m2 (contract-m2s contract))
+ (unless m2
+ (error "contract ~A has no m2s" contract))
+ (when (in-polygon-p (m2-x m2) (m2-y m2) (allocation-area-vertices allocation-area))
+ (incf retval))))
+ retval))
+
+(defmethod allocation-area-percent-used ((allocation-area allocation-area))
+ (/ (- (allocation-area-total-m2s allocation-area) (allocation-area-free-m2s allocation-area))
+ (/ (allocation-area-total-m2s allocation-area) 100)))
+
+(defun tiles-crossing (left top width height)
+ (let (tiles
+ (right (* 90 (ceiling (+ left width) 90)))
+ (bottom (* 90 (ceiling (+ top height) 90))))
+ (loop for x from left upto right by 90
+ do (loop for y from top upto bottom by 90
+ do (pushnew (ensure-map-tile x y) tiles)))
+ tiles))
+
+(defmethod allocation-area-tiles ((allocation-area allocation-area))
+ (with-slots (left top width height) allocation-area
+ (tiles-crossing left top width height)))
+
+(defun allocation-area-inuse-map (area)
+ (with-slots (left top width height) area
+ (let ((map (make-array (list width height) :element-type 'boolean)))
+ (dotimes (x width)
+ (dotimes (y height)
+ (setf (aref map x y)
+ (awhen (get-m2 (+ left x) (+ top y))
+ (if (m2-contract it)
+ t
+ (not (point-in-polygon-p (+ left x) (+ top y) (allocation-area-vertices area))))))))
+ map)))
+
+(defun print-inuse-map (map image-namep)
+ (destructuring-bind (width height) (array-dimensions map)
+ (cl-gd:with-image* (width height)
+ (cl-gd:do-rows (y)
+ (cl-gd:do-pixels-in-row (x)
+ (setf (cl-gd:raw-pixel) (if (aref map x y) 255 0))))
+ (cl-gd:write-image-to-file image-name :type :png))))
+
+(defstruct (allocator-map :conc-name am-) size inuse-map)
+
+(defmethod allocation-area-find-free-m2s ((area allocation-area) count)
+ (unless (>= count (allocation-area-full-for area))
+ (let ((key (ceiling (sqrt n)))
+ (map (or (gethash key (allocation-area-allocator-maps area))
+ (setf (gethash key (allocation-area-allocator-maps area))
+ (make-allocator-map :size n
+ :inuse-map (make-array (list (allocation-area-width area)
+ (allocation-area-height area)))))))))))
+
+(define-persistent-class stripe ()
+ ((left :update)
+ (top :update)
+ (width :update)
+ (height :update)
+ (x :update)
+ (y :update)
+ (area :update)
+ (seen :update))
+ (:documentation
+ "A rectangle in which to allocate meters. LEFT, TOP, WIDTH, and HEIGHT
+ designate the dimensions of the stripe. X and Y point to the next free
+ square meter. If X or Y point to a square meter outside of the stripe,
+ and no square meters have already been SEEN, there are not free square
+ meters left. SEEN lists square meters known to be inside the allocation
+ polygon for this stripe in the appropriate allocation order. Elements of
+ SEEN can be sold immediately unless they turn out to have been sold by
+ other means in the meantime.
+
+ left x
+ | |
+ v v
+ top -> xxxxxx.......................... -
+ xxxxxx.......................... | height
+ xxxxxx.......................... |
+ y -> xxxxx........................... -
+
+ |------------------------------|
+ width
+ Legend:
+ x = allocated
+ . = unallocated"))
+
+(defmethod initialize-persistent-instance :after ((instance stripe))
+ (with-slots (stripes y) (stripe-area instance)
+ (setf stripes (sort-area-stripes (cons instance stripes)))
+ (setf y (max y (+ (stripe-top instance) (stripe-height instance))))))
+
+(defmethod destroy-object :before ((stripe stripe))
+ (with-slots (stripes) (stripe-area stripe)
+ (setf stripes (remove stripe stripes))))
+
+(defmethod print-object ((object stripe) stream)
+ (print-unreadable-object (object stream :type t :identity nil)
+ (format stream "~D at (~D,~D) sized (~D,~D) ptr (~D,~D)"
+ (store-object-id object)
+ (stripe-left object)
+ (stripe-top object)
+ (stripe-width object)
+ (stripe-height object)
+ (stripe-x object)
+ (stripe-y object))))
+
+(defun make-stripe (area left top width height)
+ (make-object 'stripe
+ :area area
+ :left left
+ :top top
+ :width width
+ :height height
+ :x left
+ :y (if (evenp left) top (+ top height -1))
+ :seen '()))
+
+(defun sort-area-stripes (stripes)
+ "Liefere STRIPES sortiert erstens nach aufsteigender Hoehe, zweitens
+ von oben nach unten."
+ (sort (copy-list stripes)
+ (lambda (a b)
+ (let ((ha (stripe-height a))
+ (hb (stripe-height b)))
+ (cond
+ ((< ha hb)
+ t)
+ ((eql ha hb)
+ (< (stripe-top a) (stripe-top b)))
+ (t
+ nil))))))
+
+(defun store-stripes ()
+ "Liefere alle STRIPES, sortiert erstens nach ihrer Area, zweitens nach
+ aufsteigender Hoehe, drittens von oben nach unten."
+ (loop for area in (active-allocation-areas)
+ append (allocation-area-stripes area)))
+
+(defun add-new-stripe/area (n area)
+ "Return a newly allocated stripe contained in AREA suitable for allocation
+ of N square meters, or NIL if place for such a stripe was left."
+ (let ((h (ceiling (sqrt n))))
+ (with-slots (y left top height width stripes) area
+ (when (<= (+ y h) (+ top height))
+ (make-stripe area left y width h)))))
+
+(defun used-stripe-width (stripe)
+ (with-slots (x y left top height) stripe
+ (- (if (if (evenp x)
+ (eql y top)
+ (eql y (+ top height -1)))
+ x
+ (1+ x))
+ left)))
+
+(defun split-stripe-horizontally (stripe)
+ "Split STRIPE into three parts.
+
+ Example:
+ xxxxx...........................
+ xxxxx...........................
+ xxxxx...........................
+ xxxx............................
+
+ Example after:
+ xxxxxAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ xxxxxAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ xxxxxBBBBBBBBBBBBBBBBBBBBBBBBBBB
+ xxxx.BBBBBBBBBBBBBBBBBBBBBBBBBBB
+
+ Legend:
+ x = old stripe, allocated
+ . = old stripe, unallocated
+ A = new stripe, unallocated
+ B = new stripe, unallocated"
+ (assert (> (stripe-width stripe) 1))
+ (with-slots (left top width height x y area) stripe
+ (let ((old-width width))
+ ;; cut stripe to actually allocated width
+ (setf width (used-stripe-width stripe))
+ ;; add upper half of removed right part
+ (make-stripe area
+ (+ left width)
+ top
+ (- old-width width)
+ (truncate height 2))
+ ;; add lower half of removed right part
+ (make-stripe area
+ (+ left width)
+ (+ top (truncate height 2))
+ (- old-width width)
+ (ceiling height 2)))))
+
+(defun split-stripe-vertically (stripe)
+ "Split STRIPE into two parts and return true if possible, else do nothing
+ and return NIL.
+
+ Example:
+ XXXXXxxxxxxxxxxxxxxxxxxxxxxxxxxx
+ XXXXXxxxxxxxxxxxxxxxxxxxxxxxxxxx
+ XXXXxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+ XXXXxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+
+ Example after:
+ XXXXXyyyyyyyyyyyyyyyyyyyyyyyyyyy
+ XXXXXyyyyyyyyyyyyyyyyyyyyyyyyyyy
+ XXXXxyyyyyyyyyyyyyyyyyyyyyyyyyyy
+ XXXXxyyyyyyyyyyyyyyyyyyyyyyyyyyy
+
+ Legend:
+ X = old stripe, allocated
+ x = old stripe, unallocated
+ y = new stripe, unallocated"
+ (with-slots (left top width height x y area) stripe
+ (let ((old-width width))
+ (setf width (used-stripe-width stripe))
+ (if (eql width old-width)
+ nil
+ (make-stripe area
+ (+ left width)
+ top
+ (- old-width width)
+ height)))))
+
+(defun classify-stripe (n stripe)
+ "Passen N Quadratmeter in den STRIPE unter Wahrung des gewuenschten
+ Rechtecksverhaeltnisses von maximal 1x2?
+ STRIPE-TOO-SMALL: Nein, weil der Stripe zu schmal ist.
+ STRIPE-NEARLY-FULL: Sonderfall: Der Stripe ist eigentlich zu hoch,
+ aber schon am rechten Rand angekommen. Hier wird man in der Praxis
+ im Gegenteil nur winzige Bloecke noch unterbringen koennen.
+ STRIPE-TOO-LARGE: Nein, weil der Stripe zu hoch ist (und nicht voll)
+ STRIPE-MATCHES: sonst"
+ (let ((wanted-height (ceiling (sqrt n)))
+ (stripe-height (stripe-height stripe)))
+ (cond
+ ((<= (* 2 stripe-height) wanted-height)
+ :stripe-too-small)
+ ((< wanted-height stripe-height)
+ (if (< (stripe-x stripe)
+ (+ (stripe-left stripe) (stripe-width stripe) -1))
+ :stripe-too-large
+ :stripe-nearly-full))
+ (t
+ :stripe-matches))))
+
+(defun stripe-dissection-p (x stripe)
+ "Ist STRIPE an der angegebenen X-Koordinate senkrecht durch das Polygon
+ zerschnitten?"
+ ;; fixme: das ist kein 100%ig perfekter Test, aber er sollte genuegen, um
+ ;; optisch sichtbare Trennung in einem Contract zu verhindern.
+ (with-slots (top height area) stripe
+ (loop with vertices = (allocation-area-vertices area)
+ for y from top below (+ top height)
+ never (in-polygon-p x y vertices))))
+
+(defun stripe-full-p (stripe)
+ (with-slots (left top width height x y seen) stripe
+ (let ((right (+ left width))
+ (bottom (+ top height)))
+ (not (or (and (<= left x (1- right)) (<= top y (1- bottom))) seen)))))
+
+(defun find-free-m2s/stripe (n stripe)
+ "Find N connected free square meterns in STRIPE, or return NIL.
+ Square meters are allocated left-to-right, in a top-down, then
+ bottom-up pattern,in order to ensure (a) connectivity and (b) that the
+ space does not become fragmented."
+ (with-slots (left top width height x y seen) stripe
+ (let ((new-x x) ;working copy of x
+ (new-y y) ;working copy of y
+ (new-seen seen) ;working copy of free
+ (result '())
+ (right (+ left width))
+ (bottom (+ top height))
+ (vertices (allocation-area-vertices (stripe-area stripe))))
+ (when (stripe-full-p stripe)
+ ;; Gleich NIL liefern, und den Stripe beseitigen, damit wir ihn nicht
+ ;; wieder antreffen in Zukunft.
+ (delete-object stripe)
+ (return-from find-free-m2s/stripe nil))
+ (labels ((find-next-m2 ()
+ "Return the next square meter in stripe, using the
+ temporary counters, or NIL if stripe is fully allocated."
+ (let ((this-x new-x)
+ (this-y new-y))
+ (when (and (<= left this-x (1- right))
+ (<= top this-y (1- bottom)))
+ (cond
+ ((evenp new-x) ;top-down
+ (incf new-y)
+ (when (>= new-y bottom)
+ (decf new-y)
+ (incf new-x)))
+ (t ;bottom-up
+ (decf new-y)
+ (when (< new-y top)
+ (incf new-y)
+ (incf new-x))))
+ (ensure-m2 this-x this-y))))
+ (find-free-m2 ()
+ "Return the next *free* square meter in stripe, using the
+ temporary counters, or NIL if stripe is fully allocated."
+ (or (loop
+ (let ((m2 (pop new-seen)))
+ (cond
+ ((null m2)
+ (return nil))
+ ((null (m2-contract m2))
+ (return m2)))))
+ (loop
+ (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)))))
+ ((null (m2-contract m2))
+ (return m2))))))))
+ (dotimes (dummy n
+ (progn ;success
+ (setf x new-x
+ y new-y
+ seen new-seen)
+ (when result
+ (with-slots (area) stripe
+ (decf (allocation-area-free-m2s area) n)
+ (when (null (allocation-area-free-m2s area))
+ (deactivate-allocation-area area))))
+ result))
+ (let ((m2 (find-free-m2)))
+ (unless m2 ;failure
+ (setf x new-x
+ y new-y
+ seen (append new-seen (reverse result)))
+ (return nil))
+ (push m2 result)))))))
+
+(defun find-free-m2s/exact (n area)
+ "Find an allocation stripe in AREA of size HEIGHT with N free square
+ meters. Return the square meters found or return NIL if no such stripe
+ is found."
+ (dolist (stripe (allocation-area-stripes area))
+ (when (eq (classify-stripe n stripe) :stripe-matches)
+ (let ((result (find-free-m2s/stripe n stripe)))
+ (when result
+ (return result))))))
+
+(defun find-free-m2s/grow (n area)
+ "Create a new stripe of suitable size for N square meters in AREA. If no
+ such stripe can be created, return NIL. If a stripe could be created but
+ N square meters could not actually be allocated in the stripe, repeat."
+ (loop for stripe = (add-new-stripe/area n area)
+ while stripe
+ do
+ (let ((result (find-free-m2s/stripe n stripe)))
+ (when result
+ (return result)))))
+
+(defun find-free-m2s/overflow (n area)
+ "Find an allocation stripe in store of size HEIGHT with N free square
+ meters. Return the square meters found. If no such stripe exists, split
+ the next biggest stripe into two and try again."
+ (let ((stripes (allocation-area-stripes area))
+ (result nil))
+ (loop
+ for stripe = (pop stripes)
+ while stripe
+ until result
+ do
+ (ecase (classify-stripe n stripe)
+ (:stripe-too-small)
+ (:stripe-matches
+ (setf result (find-free-m2s/stripe n stripe)))
+ (:stripe-too-large
+ (split-stripe-horizontally stripe)
+ (setf stripes (allocation-area-stripes area)))
+ (:stripe-nearly-full
+ (when (<= n 2)
+ (setf result (find-free-m2s/stripe n stripe))))))
+ result))
+
+(defmethod allocation-area-find-free-m2s ((area allocation-area) n)
+ (assert (plusp n))
+ (when (<= n (allocation-area-free-m2s area))
+ (let ((m2s (or (find-free-m2s/exact n area)
+ (find-free-m2s/grow n area)
+ (find-free-m2s/overflow n area))))
+ m2s)))
+
+(defmethod return-m2 ((allocation-area allocation-area))
+ (incf (allocation-area-free-m2s allocation-area)))
+
+(defun find-free-m2s/underflow (n)
+ "Find the largest allocation stripe in store able to hold N free square
+ meters and return the square meters found, or NIL if no such stripe exists."
+ (some (lambda (stripe)
+ (find-free-m2s/stripe n stripe))
+ (loop for area in (reverse (active-allocation-areas))
+ append (allocation-area-stripes area))))
+
+(defun find-free-m2s (n)
+ (assert (plusp n))
+ (unless (in-transaction-p)
+ (error "find-free-m2s called outside of the allocation transaction"))
+ (or (some (lambda (area) (allocation-area-find-free-m2s area n))
+ (active-allocation-areas))
+ (let ((area (find-inactive-allocation-area)))
+ (when area
+ (activate-allocation-area area)
+ (find-free-m2s n)))
+ (find-free-m2s/underflow n)
+ (warn "all allocation areas exhausted")
+ nil))
+
+(defun return-m2s (m2s)
+ "Mark the given square meters as free, so that they can be re-allocated."
+ (when m2s
+ (loop for m2 in m2s
+ for allocation-area = (m2-allocation-area m2)
+ when allocation-area
+ do (return-m2 allocation-area))
+ (multiple-value-bind (left top width height)
+ (compute-bounding-box
+ (mapcar (lambda (m2) (cons (m2-x m2) (m2-y m2))) m2s))
+ (incf width)
+ (incf height)
+ (dolist (area (all-allocation-areas))
+ (let ((vertices (allocation-area-vertices area)))
+ (when (every (lambda (m2)
+ (in-polygon-p (m2-x m2) (m2-y m2) vertices))
+ m2s)
+ (make-stripe area left top width height))))))
+ t)
+
+;; debugging
+(defun find-stripes-around-point (x y)
+ (remove-if-not (lambda (s)
+ (with-slots (left top width height) s
+ (and (<= left x (+ left width -1))
+ (<= top y (+ top height -1)))))
+ (store-stripes)))
+
+(defun delete-full-stripes ()
+ (bknr.datastore::without-sync ()
+ (dolist (stripe (store-stripes))
+ (when (stripe-full-p stripe)
+ (delete-object stripe)))))
+
+(defun estimate-fill-ratio ()
+ "Liefere eine Schaetzung (!) der aktuellen Vergabequote in den vorhandenen
+ Allocation Areas als Gleitkommazahl."
+ (float (multiple-value-call #'/ (estimate-fill-counters))))
+
+(defun estimate-fill-counters ()
+ "Liefere eine Schaetzung (!) der Anzahl 1. der aktuell vergebenen und
+ 2. der insgesamt verfuegbaren Quadratmeter im Store als multiple values."
+ (let ((nallocated 0)
+ (ntotal 0))
+ (dolist (area (all-allocation-areas))
+ (multiple-value-bind (a b)
+ (estimate-fill-counters/area area)
+ (incf nallocated a)
+ (incf ntotal b)))
+ (values nallocated ntotal)))
+
+(defun estimate-fill-counters/area (area)
+ "Liefere eine Schaetzung (!) der Anzahl 1. der aktuell vergebenen und
+ 2. der insgesamt verfuegbaren Quadratmeter in AREA als multiple values."
+ (let ((nallocated 0)
+ (ntotal 0))
+ (dolist (stripe (allocation-area-stripes area))
+ (multiple-value-bind (a b)
+ (estimate-fill-counters/stripe stripe)
+ (incf nallocated a)
+ (incf ntotal b)))
+ (values nallocated ntotal)))
+
+(defun estimate-fill-counters/stripe (stripe)
+ "Liefere eine Schaetzung (!) der Anzahl 1. der aktuell vergebenen und
+ 2. der insgesamt verfuegbaren Quadratmeter in STRIPE als multiple values."
+ (values (+ (* (- (stripe-x stripe) (stripe-left stripe))
+ (stripe-height stripe))
+ (- (stripe-y stripe) (stripe-top stripe)))
+ (* (stripe-width stripe) (stripe-height stripe))))
Modified: trunk/projects/bos/m2/bos.m2.asd
===================================================================
--- trunk/projects/bos/m2/bos.m2.asd 2006-11-04 05:52:49 UTC (rev 2050)
+++ trunk/projects/bos/m2/bos.m2.asd 2006-11-04 06:01:17 UTC (rev 2051)
@@ -1,7 +1,7 @@
(in-package :cl-user)
(asdf:defsystem :bos.m2
- :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv)
+ :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl)
:components ((:file "packages")
(:file "config" :depends-on ("packages"))
(:file "utils" :depends-on ("config"))
Modified: trunk/projects/bos/m2/m2.lisp
===================================================================
--- trunk/projects/bos/m2/m2.lisp 2006-11-04 05:52:49 UTC (rev 2050)
+++ trunk/projects/bos/m2/m2.lisp 2006-11-04 06:01:17 UTC (rev 2051)
@@ -260,8 +260,6 @@
(warn "can't re-issue cert for ~A" contract)
(progn
(make-certificate contract name :address address :language language)
- (unless (contract-download-only-p contract)
- (mail-certificate-to-office contract address))
(change-slot-values contract 'cert-issued t))))
(defmethod contract-image-tiles ((contract contract))
@@ -332,17 +330,17 @@
""))
(defun make-m2-javascript (sponsor)
- "Erzeugt das Quadratmeter-Javascript für die angegebenen Contracts"
+ "Erzeugt das Quadratmeter-Javascript für die angegebenen Contracts"
(with-output-to-string (*standard-output*)
(let ((paid-contracts (remove nil (sponsor-contracts sponsor) :key #'contract-paidp)))
(format t "profil = {};~%")
- (format t "profil['id'] = ~D;~%" (store-object-id sponsor))
- (format t "profil['name'] = ~S;~%" (string-safe (or (user-full-name sponsor) "[anonym]")))
- (format t "profil['country'] = ~S;~%" (or (sponsor-country sponsor) "[unbekannt]"))
- (format t "profil['anzahl'] = ~D;~%" (loop for contract in paid-contracts
+ (format t "profil.id = ~D;~%" (store-object-id sponsor))
+ (format t "profil.name = ~S;~%" (string-safe (or (user-full-name sponsor) "[anonym]")))
+ (format t "profil.country = ~S;~%" (or (sponsor-country sponsor) "[unbekannt]"))
+ (format t "profil.anzahl = ~D;~%" (loop for contract in paid-contracts
sum (length (contract-m2s contract))))
- (format t "profil['nachricht'] = '~A';~%" (string-safe (sponsor-info-text sponsor)))
- (format t "profil['contracts'] = [ ];~%")
+ (format t "profil.nachricht = '~A';~%" (string-safe (sponsor-info-text sponsor)))
+ (format t "profil.contracts = [ ];~%")
(loop for contract in paid-contracts
do (destructuring-bind (left top width height) (contract-bounding-box contract)
(format t "profil.contracts.push({ id: ~A, left: ~A, top: ~A, width: ~A, height: ~A, date: ~S });~%"
Modified: trunk/projects/bos/m2/mail-generator.lisp
===================================================================
--- trunk/projects/bos/m2/mail-generator.lisp 2006-11-04 05:52:49 UTC (rev 2050)
+++ trunk/projects/bos/m2/mail-generator.lisp 2006-11-04 06:01:17 UTC (rev 2051)
@@ -27,17 +27,6 @@
$(email)
"))
-(defun mail-certificate-to-office (contract address)
- (let ((contract-id (store-object-id contract)))
- (send-system-mail :subject #?"Druckauftrag fuer Spender-Urkunde"
- :text #?"Bitte die folgende Urkunde ausdrucken und versenden:
-
-$(*website-url*)/print-certificate/$(contract-id)
-
-Versandadresse:
-
-$(address)")))
-
(defun mail-fiscal-certificate-to-office (contract name address country)
(format t "mail-fiscal-certificate-to-office: ~a name: ~a address: ~a country: ~a~%" contract name address country))
@@ -232,7 +221,12 @@
:postcode plz
:ort ort
:email email
- :tel telefon))))))
+ :tel telefon))
+ (make-instance 'mime
+ :type "application"
+ :subtype (format nil "pdf; name=\"contract-~A.pdf\"" contract-id)
+ :encoding :base64
+ :content (file-contents (contract-pdf-pathname contract)))))))
(send-system-mail :subject (format nil "Ueberweisungsformular-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
sponsor-id contract-id)
:content-type "multipart/mixed"
Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp 2006-11-04 05:52:49 UTC (rev 2050)
+++ trunk/projects/bos/m2/packages.lisp 2006-11-04 06:01:17 UTC (rev 2051)
@@ -37,6 +37,7 @@
:bknr.rss
:bos.m2.config
:net.post-office
+ :kmrcl
:cxml
:cl-mime
:cl-gd)
More information about the Bknr-cvs
mailing list