bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

[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

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

23 Jul '08

Revision: 3590 Author: edi URL: http://bknr.net/trac/changeset/3590 Rename A trunk/thirdparty/cl-interpol/ D trunk/thirdparty/cl-interpol-0.1.2/ Copied: trunk/thirdparty/cl-interpol (from rev 3589, trunk/thirdparty/cl-interpol-0.1.2)

1 0

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

23 Jul '08

Revision: 3589 Author: edi URL: http://bknr.net/trac/changeset/3589 Tagging A tags/thirdparty/cl-interpol-0.1.2/ Copied: tags/thirdparty/cl-interpol-0.1.2 (from rev 3588, trunk/thirdparty/cl-interpol-0.1.2)

1 0

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

23 Jul '08

Revision: 3588 Author: ksprotte URL: http://bknr.net/trac/changeset/3588 checkpoint - some more work on allocation U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/geometry.lisp D trunk/projects/bos/m2/test-allocation.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 15:28:01 UTC (rev 3587) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 15:44:13 UTC (rev 3588) @@ -297,7 +297,7 @@ 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" x y)) + (error "sqm ~A/~A not allocatable" start-x start-y)) (let* ((allocated (make-hash-table :test #'equal)) (border-queue (bos.web::make-queue)) connected) @@ -308,7 +308,8 @@ (bos.web::enqueue key border-queue))) (try-get (&rest key) (and (not (gethash key allocated)) - (apply pred key))) + (apply pred key) + key)) (get-next-neighbor (x y) (or (try-get (1+ x) y) (try-get x (1+ y)) @@ -335,18 +336,16 @@ (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))) + ;; (area-right (+ area-left area-width)) + ;; (area-bottom (+ area-top area-height)) + ) (labels ((allocatable-p (x y) - (and (<= area-left x area-right) - (<= area-top y area-bottom) - (let ((m2 (ensure-m2 x y))) - (and (not (m2-contract m2)) - m2))))) + (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)))) - (unless (m2-contract (ensure-m2 x y)) + (when (allocatable-p x y) (let ((result (try-allocation n x y #'allocatable-p))) (when result (assert (alexandria:setp result :test #'equal)) Modified: trunk/projects/bos/m2/geometry.lisp =================================================================== --- trunk/projects/bos/m2/geometry.lisp 2008-07-23 15:28:01 UTC (rev 3587) +++ trunk/projects/bos/m2/geometry.lisp 2008-07-23 15:44:13 UTC (rev 3588) @@ -450,3 +450,15 @@ (traverse (list (first nodes))) (= (length nodes) (hash-table-count hash))))) + +(defun ascii-plot-points (objects &key key) + (fresh-line) + (let ((bbox (bounding-box objects :key key))) + (with-rectangle bbox + (loop for y from top below (+ top height) + do (loop for x from left below (+ left width) + if (member (list x y) objects :key key :test #'equal) + do (princ "x") + else do (princ ".")) + do (terpri))))) + Deleted: trunk/projects/bos/m2/test-allocation.lisp =================================================================== --- trunk/projects/bos/m2/test-allocation.lisp 2008-07-23 15:28:01 UTC (rev 3587) +++ trunk/projects/bos/m2/test-allocation.lisp 2008-07-23 15:44:13 UTC (rev 3588) @@ -1,62 +0,0 @@ -(in-package :bos.m2) - -(defun try-allocation (n x y 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 -returns a true value if the arguments specify the coordinates of an -allocatable square meter." - (unless (funcall pred x y) - (error "sqm ~A/~A not allocatable" x y)) - (let ((allocated (make-hash-table :test #'equal)) - (connected (list (list x y))) - (border-queue (bos.web::make-queue))) - (labels - ((try-get (&rest key) - (when (and (not (gethash key allocated)) - (apply pred key)) - (setf (gethash key allocated) t) - (bos.web::enqueue key border-queue) - key)) - (get-next-neighbor (x y) - "Return the next neighbor of M2 that can be allocated or NIL if none of the neighbor can be allocated." - (or (try-get (1+ x) y) - (try-get x (1+ y)) - (try-get (1- x) y) - (try-get x (1- y))))) - (dotimes (i (1- n) - (append connected (bos.web::elements border-queue))) - (tagbody - retry - (let ((next (get-next-neighbor x y))) - (unless next - (cond - ((bos.web::queue-empty-p border-queue) - (return nil)) - (t - (push (list x y) connected) - (multiple-value-setq (x y) - (values-list (bos.web::dequeue border-queue))) - (go retry)))))))))) - -(defun try-alloc (n) - (let* ((area (first (remove-if-not #'allocation-area-active-p (class-instances 'allocation-area)))) - (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 (<= area-left x area-right) - (<= area-top y area-bottom) - (not (m2-contract (ensure-m2 x y)))))) - (loop - (let ((x (+ area-left (random area-width))) - (y (+ area-top (random area-height)))) - (unless (m2-contract (ensure-m2 x y)) - (let ((result (try-allocation n x y #'allocatable-p))) - (when result - (return result))))))))) - - - Modified: trunk/projects/bos/web/quad-tree.lisp =================================================================== --- trunk/projects/bos/web/quad-tree.lisp 2008-07-23 15:28:01 UTC (rev 3587) +++ trunk/projects/bos/web/quad-tree.lisp 2008-07-23 15:44:13 UTC (rev 3588) @@ -130,11 +130,17 @@ (setf (cdr queue) (setf (car queue) (list x))) (setf (cdr (cdr queue)) (list x) (cdr queue) (cdr (cdr queue)))) - (car 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] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3587 Author: hans URL: http://bknr.net/trac/changeset/3587 try again! U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-23 15:07:18 UTC (rev 3586) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-23 15:28:01 UTC (rev 3587) @@ -291,47 +291,43 @@ consistent-p)) ;;; allocation -(defun try-allocation (n x y pred) +(defun try-allocation (n start-x start-y 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 returns a true value if the arguments specify the coordinates of an allocatable square meter." - (unless (funcall pred x y) + (unless (funcall pred start-x start-y) (error "sqm ~A/~A not allocatable" x y)) (let* ((allocated (make-hash-table :test #'equal)) - (initial-key (list x y)) (border-queue (bos.web::make-queue)) connected) - (setf (gethash initial-key allocated) t) (labels - ((try-get (&rest key) - (when (and (not (gethash key allocated)) - (apply pred key)) - (setf key (copy-list key)) + ((enqueue (x y) + (let ((key (list x y))) (setf (gethash key allocated) t) - (bos.web::enqueue key border-queue) - key)) + (bos.web::enqueue key border-queue))) + (try-get (&rest key) + (and (not (gethash key allocated)) + (apply pred key))) (get-next-neighbor (x y) - "Return the next neighbor of M2 that can be allocated or NIL if none of the neighbor can be allocated." (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 #+nil(list initial-key) - connected - (bos.web::queue-elements border-queue))) + (append connected (bos.web::queue-elements border-queue))) (tagbody retry - (let ((next (get-next-neighbor x y))) - (unless next + (destructuring-bind (x y) (bos.web::peek-queue border-queue) + (let ((next (get-next-neighbor x y))) (cond + (next + (apply #'enqueue next)) ((bos.web::queue-empty-p border-queue) (return nil)) (t - (push (list x y) connected) - (multiple-value-setq (x y) - (values-list (bos.web::dequeue border-queue))) + (push (bos.web::dequeue border-queue) connected) (go retry)))))))))) (defun allocate-in-area (area n)

1 0

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

23 Jul '08

Revision: 3586 Author: ksprotte URL: http://bknr.net/trac/changeset/3586 removed stripes from allocation - still ongoing work with try-allocation U trunk/projects/bos/m2/allocation.lisp Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3585 Author: hans URL: http://bknr.net/trac/changeset/3585 Print newline after message U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-23 13:05:11 UTC (rev 3584) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-23 13:13:08 UTC (rev 3585) @@ -54,7 +54,7 @@ (when (and (boundp '*store*) *store*) (update-instances-for-changed-class (class-name class)) (unless *suppress-schema-warnings* - (format *trace-output* "Class ~A has been changed. To ensure correct schema evolution, please snapshot your datastore." + (format *trace-output* "~&; class ~A has been changed. To ensure correct schema evolution, please snapshot your datastore.~%" (class-name class))))) (defclass persistent-direct-slot-definition (index-direct-slot-definition) @@ -554,7 +554,7 @@ (clear-class-indices (find-class class-name))) (setf (next-object-id subsystem) 0) (when (probe-file snapshot) - (format *trace-output* "loading snapshot file ~A~%" snapshot) + (format *trace-output* "~&; loading snapshot file ~A~%" snapshot) (with-open-file (s snapshot :element-type '(unsigned-byte 8) :direction :input)

1 0

[bknr-cvs] hans changed trunk/build.lisp
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3584 Author: hans URL: http://bknr.net/trac/changeset/3584 Comment out PPCRE testing for a moment. U trunk/build.lisp Modified: trunk/build.lisp =================================================================== --- trunk/build.lisp 2008-07-23 12:48:58 UTC (rev 3583) +++ trunk/build.lisp 2008-07-23 13:05:11 UTC (rev 3584) @@ -120,6 +120,7 @@ forms) (exit (if any-failed 1 0)))) +#+(or) (defun cl-ppcre-run-no-failures-p () (let ((expected ".......... .......... @@ -193,6 +194,7 @@ (cl-gd::load-gd-glue) (format t "~&;;; --- running tests~%") (run-tests + #+(or) (cl-ppcre-run-no-failures-p) (cl-gd-run-no-failures-p) (flexi-streams-no-failures-p)

1 0

← Newer
1
...
10
11
12
13
14
15
16
...
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