bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

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

24 Jul '08

Revision: 3600 Author: edi URL: http://bknr.net/trac/changeset/3600 Tag cl-interpol 0.2.0 A tags/thirdparty/cl-interpol-0.2.0/ Copied: tags/thirdparty/cl-interpol-0.2.0 (from rev 3599, trunk/thirdparty/cl-interpol)

1 0

[bknr-cvs] edi changed trunk/thirdparty/cl-interpol/CHANGELOG
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3599 Author: edi URL: http://bknr.net/trac/changeset/3599 Update release date U trunk/thirdparty/cl-interpol/CHANGELOG Modified: trunk/thirdparty/cl-interpol/CHANGELOG =================================================================== --- trunk/thirdparty/cl-interpol/CHANGELOG 2008-07-23 20:05:51 UTC (rev 3598) +++ trunk/thirdparty/cl-interpol/CHANGELOG 2008-07-23 22:58:26 UTC (rev 3599) @@ -1,5 +1,5 @@ Version 0.2.0 -2008-07-23 +2008-07-24 Base Unicode support on CL-UNICODE Add new CL-PPCRE special characters for named registers and named properties Re-architecture test suite

1 0

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

23 Jul '08

Revision: 3598 Author: ksprotte URL: http://bknr.net/trac/changeset/3598 all bos tests pass again :) U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-23 19:12:54 UTC (rev 3597) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 20:05:51 UTC (rev 3598) @@ -320,16 +320,16 @@ (append connected (queue-elements border-queue))) (tagbody retry - (destructuring-bind (x y) (peek-queue border-queue) - (let ((next (get-next-neighbor x y))) - (cond - (next - (apply #'enqueue* next)) - ((queue-empty-p border-queue) - (return nil)) - (t - (push (dequeue border-queue) connected) - (go retry)))))))))) + (if (queue-empty-p border-queue) + (return nil) + (destructuring-bind (x y) (peek-queue border-queue) + (let ((next (get-next-neighbor x y))) + (cond + (next + (apply #'enqueue* next)) + (t + (push (dequeue border-queue) connected) + (go retry))))))))))) (defun allocate-in-area (area n) (let* ((area-left (allocation-area-left area)) @@ -344,7 +344,7 @@ (not (m2-contract (ensure-m2 x y)))))) (dotimes (i 10) (let ((x (+ area-left (random area-width))) - (y (+ area-top (random area-height)))) + (y (+ area-top (random area-height)))) (when (allocatable-p x y) (let ((result (try-allocation n x y #'allocatable-p))) (when result @@ -363,38 +363,23 @@ list of N m2 instances or NIL if the requested amount cannot be allocated." (dolist (area (active-allocation-areas)) - (let ((m2s (allocate-in-area area n))) - (when m2s - (return-from allocate-m2s-for-sale m2s)))) + (when (<= n (allocation-area-free-m2s area)) + (let ((m2s (allocate-in-area area n))) + (when m2s + (return-from allocate-m2s-for-sale m2s))))) (dolist (area (inactive-nonempty-allocation-areas)) - (let ((m2s (allocate-in-area area n))) - (when m2s - (activate-allocation-area area) - (return-from allocate-m2s-for-sale m2s))))) + (when (<= n (allocation-area-free-m2s area)) + (let ((m2s (allocate-in-area area n))) + (when m2s + (activate-allocation-area area) + (return-from allocate-m2s-for-sale m2s)))))) (defgeneric return-contract-m2s (m2s) (:documentation "Mark the given square meters as free, so that they can be re-allocated.")) (defmethod return-contract-m2s (m2s) - (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) - - - - + (loop for m2 in m2s + for allocation-area = (m2-allocation-area m2) + when allocation-area + do (incf (allocation-area-free-m2s allocation-area)))) Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-23 19:12:54 UTC (rev 3597) +++ trunk/projects/bos/test/allocation.lisp 2008-07-23 20:05:51 UTC (rev 3598) @@ -90,6 +90,9 @@ (decf total-free size))))))) (test allocation-area.auto-activation.2 + (skip "the new allocation alogorithm produces more fragmentation, so + this test does not work anymore as precisely as before") + #+nil (with-fixture initial-bos-store () (let* ((area1 (make-allocation-rectangle 0 0 8 8)) (area2 (make-allocation-rectangle 10 10 8 8)) @@ -186,17 +189,13 @@ (test allocation-area.delete (with-fixture initial-bos-store () (let ((area (make-allocation-rectangle 0 0 10 10)) - (sponsor (make-sponsor :login "testuser")) - stripes) + (sponsor (make-sponsor :login "testuser"))) (make-contract sponsor 10) (make-contract sponsor 1) (make-contract sponsor 10) - (make-contract sponsor 3) - (setq stripes (bos.m2::allocation-area-stripes area)) - (is (not (null stripes))) + (make-contract sponsor 3) (delete-object area) - (is (object-destroyed-p area)) - (is (every #'object-destroyed-p stripes)) + (is (object-destroyed-p area)) (finishes (snapshot))))) (store-test contract-tree.1

1 0

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

23 Jul '08

Revision: 3597 Author: ksprotte URL: http://bknr.net/trac/changeset/3597 test allocation.disconnected-m2s.1 passes for the first time U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-23 18:55:53 UTC (rev 3596) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 19:12:54 UTC (rev 3597) @@ -342,32 +342,35 @@ (labels ((allocatable-p (x y) (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)))) - (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))) - (return (mapcar (lambda (x-y) - (destructuring-bind (x y) - x-y - (ensure-m2 x y))) - result)))))))))) + (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)))))))))) (defun allocate-m2s-for-sale (n) - "The main entry point to the allocation machinery. Will return - a list of N m2 instances or NIL if the requested amount cannot - be allocated. Returned m2s will not be allocated - again (i.e. there are marked as in use) by the allocation - algorithm, but see RETURN-CONTRACT-M2S." + "The main entry point to the allocation machinery. Will return a + list of N m2 instances or NIL if the requested amount cannot be + allocated." (dolist (area (active-allocation-areas)) (let ((m2s (allocate-in-area area n))) - (when m2s (return-from allocate-m2s-for-sale m2s)))) + (when m2s + (return-from allocate-m2s-for-sale m2s)))) (dolist (area (inactive-nonempty-allocation-areas)) (let ((m2s (allocate-in-area area n))) - (when m2s (return-from allocate-m2s-for-sale m2s))))) + (when m2s + (activate-allocation-area area) + (return-from allocate-m2s-for-sale m2s))))) (defgeneric return-contract-m2s (m2s) (:documentation "Mark the given square meters as free, so that Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-23 18:55:53 UTC (rev 3596) +++ trunk/projects/bos/test/allocation.lisp 2008-07-23 19:12:54 UTC (rev 3597) @@ -238,8 +238,7 @@ (m2-counts '(12 43 29 3))) (declare (ignore area)) (dolist (m2-count m2-counts) - (let ((contract (make-contract sponsor m2-count))) - (print (list 'make-contract-returned contract)))) + (make-contract sponsor m2-count)) ;; This following check reported: ;; WARNING: #<CONTRACT ID: 32131, unpaid> has m2s that are not ;; connected

1 0

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

23 Jul '08

Revision: 3596 Author: ksprotte URL: http://bknr.net/trac/changeset/3596 indentation U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-23 18:25:16 UTC (rev 3595) +++ trunk/projects/bos/test/allocation.lisp 2008-07-23 18:55:53 UTC (rev 3596) @@ -214,14 +214,26 @@ (test allocation.disconnected-m2s.1 (with-fixture initial-bos-store () - (let ((area (make-allocation-area #((7193 . 5195) (7351 . 5193) (7340 . 5377) (7185 . 5390) (7174 . 5385) - (7166 . 5387) (7156 . 5381) (7150 . 5379) (7143 . 5374) (7136 . 5368) - (7135 . 5364) (7135 . 5359) (7140 . 5347) (7145 . 5342) (7148 . 5329) - (7156 . 5329) (7157 . 5334) (7166 . 5331) (7170 . 5329) (7171 . 5327) - (7174 . 5316) (7184 . 5306) (7185 . 5291) (7196 . 5286) (7197 . 5287) - (7200 . 5287) (7201 . 5284) (7203 . 5275) (7201 . 5264) (7191 . 5249) - (7203 . 5237) (7199 . 5235) (7195 . 5233) (7198 . 5222) (7202 . 5219) - (7202 . 5214) (7204 . 5205) (7195 . 5197)))) + (let ((area (make-allocation-area + #((7193 . 5195) (7351 . 5193) + (7340 . 5377) (7185 . 5390) + (7174 . 5385) (7166 . 5387) + (7156 . 5381) (7150 . 5379) + (7143 . 5374) (7136 . 5368) + (7135 . 5364) (7135 . 5359) + (7140 . 5347) (7145 . 5342) + (7148 . 5329) (7156 . 5329) + (7157 . 5334) (7166 . 5331) + (7170 . 5329) (7171 . 5327) + (7174 . 5316) (7184 . 5306) + (7185 . 5291) (7196 . 5286) + (7197 . 5287) (7200 . 5287) + (7201 . 5284) (7203 . 5275) + (7201 . 5264) (7191 . 5249) + (7203 . 5237) (7199 . 5235) + (7195 . 5233) (7198 . 5222) + (7202 . 5219) (7202 . 5214) + (7204 . 5205) (7195 . 5197)))) (sponsor (make-sponsor :login "test-sponsor")) (m2-counts '(12 43 29 3))) (declare (ignore area))

1 0

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

23 Jul '08

Revision: 3595 Author: ksprotte URL: http://bknr.net/trac/changeset/3595 return-contract-m2s has to be a generic function (mistakenly changed that earlier) U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/utils.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-23 18:06:05 UTC (rev 3594) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 18:25:16 UTC (rev 3595) @@ -369,8 +369,11 @@ (let ((m2s (allocate-in-area area n))) (when m2s (return-from allocate-m2s-for-sale m2s))))) -(defun return-contract-m2s (m2s) - "Mark the given square meters as free, so that they can be re-allocated." +(defgeneric return-contract-m2s (m2s) + (:documentation "Mark the given square meters as free, so that + they can be re-allocated.")) + +(defmethod return-contract-m2s (m2s) (when m2s (loop for m2 in m2s for allocation-area = (m2-allocation-area m2) Modified: trunk/projects/bos/m2/utils.lisp =================================================================== --- trunk/projects/bos/m2/utils.lisp 2008-07-23 18:06:05 UTC (rev 3594) +++ trunk/projects/bos/m2/utils.lisp 2008-07-23 18:25:16 UTC (rev 3595) @@ -66,8 +66,8 @@ (defun enqueue (x queue) (if (null (car queue)) (setf (cdr queue) (setf (car queue) (list x))) - (setf (cdr (cdr queue)) (list x) - (cdr queue) (cdr (cdr queue)))) + (setf (cdr (cdr queue)) (list x) + (cdr queue) (cdr (cdr queue)))) (caar queue)) (defun dequeue (queue)

1 0

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

23 Jul '08

Revision: 3594 Author: ksprotte URL: http://bknr.net/trac/changeset/3594 one more package problem.... needed add shadowing-import-from to package bos.m2.allocation-cache U trunk/projects/bos/m2/packages.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-23 17:53:36 UTC (rev 3593) +++ trunk/projects/bos/m2/packages.lisp 2008-07-23 18:06:05 UTC (rev 3594) @@ -293,7 +293,12 @@ :bos.m2 :bos.m2.config :iterate - :arnesi) + :arnesi) + (:shadowing-import-from :bos.m2 + #:enqueue + #:dequeue + #:peek-queue + #:queue-empty-p) (:export #:find-exact-match #:add-area #:count-cache-entries

1 0

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

23 Jul '08

Revision: 3593 Author: ksprotte URL: http://bknr.net/trac/changeset/3593 moved simple queue to bos.m2 U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/utils.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 16:19:59 UTC (rev 3592) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 17:53:36 UTC (rev 3593) @@ -299,13 +299,13 @@ (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 (bos.web::make-queue)) + (border-queue (make-queue)) connected) (labels - ((enqueue (x y) + ((enqueue* (x y) (let ((key (list x y))) (setf (gethash key allocated) t) - (bos.web::enqueue key border-queue))) + (enqueue key border-queue))) (try-get (&rest key) (and (not (gethash key allocated)) (apply pred key) @@ -315,20 +315,20 @@ (try-get x (1+ y)) (try-get (1- x) y) (try-get x (1- y))))) - (enqueue start-x start-y) + (enqueue* start-x start-y) (dotimes (i (1- n) - (append connected (bos.web::queue-elements border-queue))) + (append connected (queue-elements border-queue))) (tagbody retry - (destructuring-bind (x y) (bos.web::peek-queue border-queue) + (destructuring-bind (x y) (peek-queue border-queue) (let ((next (get-next-neighbor x y))) (cond (next - (apply #'enqueue next)) - ((bos.web::queue-empty-p border-queue) + (apply #'enqueue* next)) + ((queue-empty-p border-queue) (return nil)) (t - (push (bos.web::dequeue border-queue) connected) + (push (dequeue border-queue) connected) (go retry)))))))))) (defun allocate-in-area (area n) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-23 16:19:59 UTC (rev 3592) +++ trunk/projects/bos/m2/packages.lisp 2008-07-23 17:53:36 UTC (rev 3593) @@ -260,6 +260,13 @@ #:mail-print-pdf #:*cert-download-directory* + + #:make-queue + #:queue-empty-p + #:enqueue + #:dequeue + #:queue-elements + #:peek-queue )) (defpackage :bos.m2.cert-generator Modified: trunk/projects/bos/m2/utils.lisp =================================================================== --- trunk/projects/bos/m2/utils.lisp 2008-07-23 16:19:59 UTC (rev 3592) +++ trunk/projects/bos/m2/utils.lisp 2008-07-23 17:53:36 UTC (rev 3593) @@ -54,4 +54,28 @@ (t (let ((obj (funcall tie-breaker free-objs result))) (setf free-objs (remove obj free-objs)) - (next-result obj)))))))) \ No newline at end of file + (next-result obj)))))))) + +;;; simple queue +(defun make-queue () + (cons nil nil)) + +(defun queue-empty-p (queue) + (null (car queue))) + +(defun enqueue (x queue) + (if (null (car queue)) + (setf (cdr queue) (setf (car queue) (list x))) + (setf (cdr (cdr queue)) (list x) + (cdr queue) (cdr (cdr queue)))) + (caar queue)) + +(defun dequeue (queue) + (pop (car queue))) + +(defun queue-elements (queue) + (car queue)) + +(defun peek-queue (queue) + (caar queue)) + Modified: trunk/projects/bos/web/quad-tree.lisp =================================================================== --- trunk/projects/bos/web/quad-tree.lisp 2008-07-23 16:19:59 UTC (rev 3592) +++ trunk/projects/bos/web/quad-tree.lisp 2008-07-23 17:53:36 UTC (rev 3593) @@ -118,29 +118,6 @@ (defvar *m2-geo-box* (make-geo-box 116.92538417241805d0 -0.9942953097298868d0 117.02245623511905d0 -1.0920067364569994d0)) -;;; simple queue -(defun make-queue () - (cons nil nil)) - -(defun queue-empty-p (queue) - (null (car queue))) - -(defun enqueue (x queue) - (if (null (car queue)) - (setf (cdr queue) (setf (car queue) (list x))) - (setf (cdr (cdr queue)) (list x) - (cdr queue) (cdr (cdr 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)

1 0

[bknr-cvs] edi changed trunk/thirdparty/cl-interpol/
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3592 Author: edi URL: http://bknr.net/trac/changeset/3592 Update to dev version U trunk/thirdparty/cl-interpol/CHANGELOG D trunk/thirdparty/cl-interpol/README A trunk/thirdparty/cl-interpol/alias.lisp U trunk/thirdparty/cl-interpol/cl-interpol.asd D trunk/thirdparty/cl-interpol/cl-interpol.system U trunk/thirdparty/cl-interpol/doc/index.html D trunk/thirdparty/cl-interpol/load.lisp U trunk/thirdparty/cl-interpol/packages.lisp U trunk/thirdparty/cl-interpol/read.lisp U trunk/thirdparty/cl-interpol/specials.lisp A trunk/thirdparty/cl-interpol/test/ A trunk/thirdparty/cl-interpol/test/create_perl_tests.pl A trunk/thirdparty/cl-interpol/test/packages.lisp A trunk/thirdparty/cl-interpol/test/perltests A trunk/thirdparty/cl-interpol/test/simple A trunk/thirdparty/cl-interpol/test/tests.lisp D trunk/thirdparty/cl-interpol/test.lisp D trunk/thirdparty/cl-interpol/test.pl D trunk/thirdparty/cl-interpol/test2.lisp D trunk/thirdparty/cl-interpol/unicode.lisp U trunk/thirdparty/cl-interpol/util.lisp Change set too large, please see URL above

1 0

[bknr-cvs] edi changed ediware/
by BKNR Commits 23 Jul '08

23 Jul '08

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs