bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

[bknr-cvs] ksprotte changed trunk/projects/bos/web/
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3613 Author: ksprotte URL: http://bknr.net/trac/changeset/3613 added new handler look-at-allocation-area U trunk/projects/bos/web/allocation-area-handlers.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/allocation-area-handlers.lisp =================================================================== --- trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -15,16 +15,19 @@ (:th "active?") (:th "total") (:th "free") - (:th "%used")) + (:th "%used") + (:th "Google Earth view")) (loop for allocation-area in (all-allocation-areas) - do (html - (:tr - (:td (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area)) - (:princ-safe (store-object-id allocation-area)))) - (:td (if (allocation-area-active-p allocation-area) (html "yes") (html "no"))) - (:td (:princ-safe (allocation-area-total-m2s allocation-area))) - (:td (:princ-safe (allocation-area-free-m2s allocation-area))) - (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%"))))) + do (html + (:tr + (:td (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area)) + (:princ-safe (store-object-id allocation-area)))) + (:td (if (allocation-area-active-p allocation-area) (html "yes") (html "no"))) + (:td (:princ-safe (allocation-area-total-m2s allocation-area))) + (:td (:princ-safe (allocation-area-free-m2s allocation-area))) + (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%") + (:td (cmslink (format nil "look-at-allocation-area/~D" (store-object-id allocation-area)) + "fly to view")))))) (:p (cmslink "create-allocation-area" "Create new allocation area"))))) (defmethod handle-object-form ((handler allocation-area-handler) action allocation-area) Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -243,3 +243,15 @@ +(defclass look-at-allocation-area-handler (object-handler) + ()) + +(defmethod handle-object ((handler look-at-allocation-area-handler) + (area allocation-area)) + (with-xml-response (:content-type "application/vnd.google-earth.kml+xml; charset=utf-8" + :root-element "kml") + (with-element "Document" + (with-element "name" (text (format nil "allocation-area ~D" (store-object-id area)))) + (kml-region (make-rectangle2 (allocation-area-bounding-box2 area)) + nil)))) + Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/webserver.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -208,6 +208,7 @@ ("/contract" contract-handler) ("/sat-tree-kml" sat-tree-kml-handler) ("/sat-root-kml" sat-root-kml-handler) + ("/look-at-allocation-area" look-at-allocation-area-handler) ("/reports-xml" reports-xml-handler) ("/complete-transfer" complete-transfer-handler) ("/edit-news" edit-news-handler)

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3612 Author: hans URL: http://bknr.net/trac/changeset/3612 Fix docstring of SEARCH-ADJACENT. U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:11:05 UTC (rev 3611) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:37:33 UTC (rev 3612) @@ -292,9 +292,9 @@ (defun search-adjacent (n m2 pred) "Try to find N free square meters that are adjacent and that begin -at square meter M2. PRED is a predicate function of two arguments that -returns a true value if the arguments specify the coordinates of an -allocatable square meter." +at square meter M2. PRED is a predicate function of one argument that +returns a true value if the argument specifies an allocatable square +meter." (when (funcall pred m2) (let* ((allocated (make-hash-table :test #'eq)) (border-queue (make-queue))

1 0

[bknr-cvs] ksprotte changed trunk/thirdparty/cl-unicode/
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3611 Author: ksprotte URL: http://bknr.net/trac/changeset/3611 set property ignore for files auto-generated by the BUILD-CL-UNICODE system _U trunk/thirdparty/cl-unicode/ _U trunk/thirdparty/cl-unicode/test/ Property changes on: trunk/thirdparty/cl-unicode ___________________________________________________________________ Name: svn:ignore + hash-tables.lisp lists.lisp methods.lisp Property changes on: trunk/thirdparty/cl-unicode/test ___________________________________________________________________ Name: svn:ignore + derived-properties

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3610 Author: ksprotte URL: http://bknr.net/trac/changeset/3610 small correction for the fact that search-adjacent now returns m2 objects U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 10:11:59 UTC (rev 3609) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 10:59:03 UTC (rev 3610) @@ -350,7 +350,7 @@ (assert (alexandria:setp result :test #'equal)) (assert (= n (length result))) (decf (allocation-area-free-m2s area) n) - (return (mapcar (alexandria:curry #'apply #'ensure-m2) result))) + (return result)) (when (> (get-internal-real-time) deadline) (return nil)))))))

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3609 Author: hans URL: http://bknr.net/trac/changeset/3609 Use apply, not funcall now. U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 10:01:26 UTC (rev 3608) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 10:11:59 UTC (rev 3609) @@ -306,7 +306,7 @@ (try-get (x y) (let ((m2 (ensure-m2 x y))) (when (and (not (gethash m2 allocated)) - (apply pred m2)) + (funcall pred m2)) m2))) (get-next-neighbor (m2) (let ((x (m2-x m2))

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3608 Author: hans URL: http://bknr.net/trac/changeset/3608 Refactored... U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 09:19:16 UTC (rev 3607) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 10:01:26 UTC (rev 3608) @@ -7,7 +7,7 @@ (width :update) (height :update) (vertices :update) - (y :update) + (y :update) (total-m2s :read) (free-m2s :update) (bounding-box :update :transient t)) @@ -45,7 +45,7 @@ (defmethod notify-tiles ((allocation-area allocation-area)) (mapc #'(lambda (tile) (image-tile-changed tile)) (allocation-area-tiles allocation-area))) -(defmethod destroy-object :before ((allocation-area allocation-area)) +(defmethod destroy-object :before ((allocation-area allocation-area)) (notify-tiles allocation-area)) (defmethod initialize-transient-instance :after ((allocation-area allocation-area)) @@ -119,7 +119,7 @@ (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) @@ -132,8 +132,8 @@ :width width :height height :y top - :active-p nil - :vertices vertices))) + :active-p nil + :vertices vertices))) result))) (defmethod allocation-area-bounding-box ((allocation-area allocation-area)) @@ -161,7 +161,7 @@ (defun allocation-areas-plus-contracts-bounding-box () "Returns the bounding-box as with ALLOCATION-AREAS-BOUNDING-BOX, but possibly augmented by any contracts that dont have an allocation-area -anymore." +anymore." (geometry:with-bounding-box-collect (collect) (awhen (allocation-areas-bounding-box) (geometry:with-rectangle (it) @@ -290,77 +290,69 @@ (setf consistent-p nil)) consistent-p)) -;;; allocation -(defun try-allocation (n start-x start-y pred) +(defun search-adjacent (n m2 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 +at square meter M2. 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 start-x start-y) - (error "sqm ~A/~A not allocatable" start-x start-y)) - (let* ((allocated (make-hash-table :test #'equal)) - (border-queue (make-queue)) - connected) - (labels - ((enqueue* (x y) - (let ((key (list x y))) - (setf (gethash key allocated) t) - (enqueue key border-queue))) - (try-get (&rest key) - (and (not (gethash key allocated)) - (apply pred key) - key)) - (get-next-neighbor (x y) - (or (try-get (1+ x) y) - (try-get x (1+ y)) - (try-get (1- x) y) - (try-get x (1- y))))) - (enqueue* start-x start-y) - (dotimes (i (1- n) - (append connected (queue-elements border-queue))) - (tagbody - retry - (if (queue-empty-p border-queue) - (return nil) - (destructuring-bind (x y) (peek-queue border-queue) - (let ((next (get-next-neighbor x y))) + (when (funcall pred m2) + (let* ((allocated (make-hash-table :test #'eq)) + (border-queue (make-queue)) + completely-checked) + (labels + ((to-border-queue (m2) + (setf (gethash m2 allocated) t) + (enqueue m2 border-queue)) + (try-get (x y) + (let ((m2 (ensure-m2 x y))) + (when (and (not (gethash m2 allocated)) + (apply pred m2)) + m2))) + (get-next-neighbor (m2) + (let ((x (m2-x m2)) + (y (m2-y m2))) + (or (try-get (1+ x) y) + (try-get x (1+ y)) + (try-get (1- x) y) + (try-get x (1- y)))))) + (to-border-queue m2) + (dotimes (i (1- n) + (nconc completely-checked (queue-elements border-queue))) + (tagbody + check-next + (if (queue-empty-p border-queue) + (return nil) + (let ((next (get-next-neighbor (peek-queue border-queue)))) (cond (next - (apply #'enqueue* next)) + (to-border-queue next)) (t - (push (dequeue border-queue) connected) - (go retry))))))))))) + (push (dequeue border-queue) completely-checked) + (go check-next))))))))))) (defun allocate-in-area (area n) (let* ((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 (in-polygon-p x y (allocation-area-vertices area)) - (not (m2-contract (ensure-m2 x y)))))) - (loop with deadline = (+ (get-internal-real-time) - ;; give up after 10 ms - (* (/ 10 1000) internal-time-units-per-second)) - do (let ((x (+ area-left (random area-width))) - (y (+ area-top (random area-height)))) - (when (allocatable-p x y) - (let ((result (try-allocation n x y #'allocatable-p))) - (when result - (assert (alexandria:setp result :test #'equal)) - (assert (= n (length result))) - (decf (allocation-area-free-m2s area) n) - (return-from allocate-in-area - (mapcar (lambda (x-y) - (destructuring-bind (x y) - x-y - (ensure-m2 x y))) - result)))))) - when (> (get-internal-real-time) deadline) - return nil)))) + (deadline (+ (get-internal-real-time) + ;; give up after 10 ms + (* (/ 10 1000) internal-time-units-per-second)))) + (labels ((allocatable-p (m2) + (and (in-polygon-p (m2-x m2) (m2-y m2) (allocation-area-vertices area)) + (not (m2-contract m2))))) + (loop + (let* ((x (+ area-left (random area-width))) + (y (+ area-top (random area-height))) + (m2 (ensure-m2 x y)) + (result (search-adjacent n m2 #'allocatable-p))) + (when result + (assert (alexandria:setp result :test #'equal)) + (assert (= n (length result))) + (decf (allocation-area-free-m2s area) n) + (return (mapcar (alexandria:curry #'apply #'ensure-m2) result))) + (when (> (get-internal-real-time) deadline) + (return nil))))))) (defun allocate-m2s-for-sale (n) "The main entry point to the allocation machinery. Will return a @@ -369,7 +361,7 @@ (dolist (area (active-allocation-areas)) (when (<= n (allocation-area-free-m2s area)) (let ((m2s (allocate-in-area area n))) - (when m2s + (when m2s (return-from allocate-m2s-for-sale m2s))))) (dolist (area (inactive-nonempty-allocation-areas)) (when (<= n (allocation-area-free-m2s area)) @@ -382,7 +374,7 @@ (:documentation "Mark the given square meters as free, so that they can be re-allocated.")) -(defmethod return-contract-m2s (m2s) +(defmethod return-contract-m2s (m2s) (loop for m2 in m2s for allocation-area = (m2-allocation-area m2) when allocation-area

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3607 Author: ksprotte URL: http://bknr.net/trac/changeset/3607 allocation-area more readable using DEADLINE timestamp U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 09:11:18 UTC (rev 3606) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 09:19:16 UTC (rev 3607) @@ -342,7 +342,9 @@ (labels ((allocatable-p (x y) (and (in-polygon-p x y (allocation-area-vertices area)) (not (m2-contract (ensure-m2 x y)))))) - (loop with start-time = (get-internal-real-time) + (loop with deadline = (+ (get-internal-real-time) + ;; give up after 10 ms + (* (/ 10 1000) internal-time-units-per-second)) do (let ((x (+ area-left (random area-width))) (y (+ area-top (random area-height)))) (when (allocatable-p x y) @@ -357,9 +359,7 @@ x-y (ensure-m2 x y))) result)))))) - when (> (- (get-internal-real-time) start-time) - ;; give up after 10 ms - (* (/ 10 1000) internal-time-units-per-second)) + when (> (get-internal-real-time) deadline) return nil)))) (defun allocate-m2s-for-sale (n)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3606 Author: ksprotte URL: http://bknr.net/trac/changeset/3606 allocate-in-area now gives up after 10ms U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-23 23:45:26 UTC (rev 3605) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 09:11:18 UTC (rev 3606) @@ -342,21 +342,25 @@ (labels ((allocatable-p (x y) (and (in-polygon-p x y (allocation-area-vertices area)) (not (m2-contract (ensure-m2 x y)))))) - (dotimes (i 10) - (let ((x (+ area-left (random area-width))) - (y (+ area-top (random area-height)))) - (when (allocatable-p x y) - (let ((result (try-allocation n x y #'allocatable-p))) - (when result - (assert (alexandria:setp result :test #'equal)) - (assert (= n (length result))) - (decf (allocation-area-free-m2s area) n) - (return-from allocate-in-area - (mapcar (lambda (x-y) - (destructuring-bind (x y) - x-y - (ensure-m2 x y))) - result)))))))))) + (loop with start-time = (get-internal-real-time) + do (let ((x (+ area-left (random area-width))) + (y (+ area-top (random area-height)))) + (when (allocatable-p x y) + (let ((result (try-allocation n x y #'allocatable-p))) + (when result + (assert (alexandria:setp result :test #'equal)) + (assert (= n (length result))) + (decf (allocation-area-free-m2s area) n) + (return-from allocate-in-area + (mapcar (lambda (x-y) + (destructuring-bind (x y) + x-y + (ensure-m2 x y))) + result)))))) + when (> (- (get-internal-real-time) start-time) + ;; give up after 10 ms + (* (/ 10 1000) internal-time-units-per-second)) + return nil)))) (defun allocate-m2s-for-sale (n) "The main entry point to the allocation machinery. Will return a

1 0

[bknr-cvs] edi changed trunk/thirdparty/cl-ppcre/doc/index.html
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3605 Author: edi URL: http://bknr.net/trac/changeset/3605 Fix two typos U trunk/thirdparty/cl-ppcre/doc/index.html Modified: trunk/thirdparty/cl-ppcre/doc/index.html =================================================================== --- trunk/thirdparty/cl-ppcre/doc/index.html 2008-07-23 23:03:10 UTC (rev 3604) +++ trunk/thirdparty/cl-ppcre/doc/index.html 2008-07-23 23:45:26 UTC (rev 3605) @@ -2123,7 +2123,7 @@ in <code>"[a-ge-kf]"</code>) or to otherwise optimize these tests for speed. However, you can play with <a href="#*optimize-char-classes*"><code>*OPTIMIZE-CHAR-CLASSES*</code></a> - if you've identified character classes as bottleneck and want to + if you've identified character classes as a bottleneck and want to make sure that you have <em>O(1)</em> test functions. <li>If you know that the expression you're looking for is anchored, @@ -2131,7 +2131,7 @@ your scanners more efficient. <li>In addition to anchors, constant strings at the start or end of a - regular expression can help the engine to quickly scan a strang. + regular expression can help the engine to quickly scan a string. Note that for example <code>"(a-d|aebf)"</code> and <code>"ab(cd|ef)"</code> are equivalent, but only the second form has a constant start the regex engine can recognize. @@ -2208,7 +2208,7 @@ OpenMCL. <p> -$Header: /usr/local/cvsrep/cl-ppcre/doc/index.html,v 1.195 2008/07/23 22:24:52 edi Exp $ +$Header: /usr/local/cvsrep/cl-ppcre/doc/index.html,v 1.197 2008/07/23 23:45:18 edi Exp $ <p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> </body>

1 0

[bknr-cvs] edi changed tags/thirdparty/cl-unicode-0.1.0/
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3604 Author: edi URL: http://bknr.net/trac/changeset/3604 Tag cl-unicode 0.1.0 A tags/thirdparty/cl-unicode-0.1.0/ Copied: tags/thirdparty/cl-unicode-0.1.0 (from rev 3603, trunk/thirdparty/cl-unicode)

1 0

← Newer
1
...
8
9
10
11
12
13
14
...
33
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs July 2008