bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

[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

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

23 Jul '08

Revision: 3583 Author: hans URL: http://bknr.net/trac/changeset/3583 *** empty log message *** U trunk/projects/bos/m2/test-allocation.lisp Modified: trunk/projects/bos/m2/test-allocation.lisp =================================================================== --- trunk/projects/bos/m2/test-allocation.lisp 2008-07-23 12:29:36 UTC (rev 3582) +++ trunk/projects/bos/m2/test-allocation.lisp 2008-07-23 12:48:58 UTC (rev 3583) @@ -36,4 +36,27 @@ (push (list x y) connected) (multiple-value-setq (x y) (values-list (bos.web::dequeue border-queue))) - (go retry)))))))))) \ No newline at end of file + (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))))))))) + + +

1 0

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

23 Jul '08

Revision: 3582 Author: hans URL: http://bknr.net/trac/changeset/3582 Experimental new allocator A trunk/projects/bos/m2/test-allocation.lisp Added: trunk/projects/bos/m2/test-allocation.lisp =================================================================== --- trunk/projects/bos/m2/test-allocation.lisp (rev 0) +++ trunk/projects/bos/m2/test-allocation.lisp 2008-07-23 12:29:36 UTC (rev 3582) @@ -0,0 +1,39 @@ +(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)))))))))) \ No newline at end of file

1 0

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

23 Jul '08

Revision: 3581 Author: edi URL: http://bknr.net/trac/changeset/3581 Update to current dev version U trunk/thirdparty/cl-ppcre/CHANGELOG D trunk/thirdparty/cl-ppcre/README U trunk/thirdparty/cl-ppcre/api.lisp A trunk/thirdparty/cl-ppcre/charmap.lisp U trunk/thirdparty/cl-ppcre/charset.lisp A trunk/thirdparty/cl-ppcre/chartest.lisp D trunk/thirdparty/cl-ppcre/cl-ppcre-test.system A trunk/thirdparty/cl-ppcre/cl-ppcre-unicode/ A trunk/thirdparty/cl-ppcre/cl-ppcre-unicode/packages.lisp A trunk/thirdparty/cl-ppcre/cl-ppcre-unicode/resolver.lisp A trunk/thirdparty/cl-ppcre/cl-ppcre-unicode.asd U trunk/thirdparty/cl-ppcre/cl-ppcre.asd D trunk/thirdparty/cl-ppcre/cl-ppcre.system U trunk/thirdparty/cl-ppcre/closures.lisp U trunk/thirdparty/cl-ppcre/convert.lisp D trunk/thirdparty/cl-ppcre/doc/benchmarks.2002-12-22.txt U trunk/thirdparty/cl-ppcre/doc/index.html U trunk/thirdparty/cl-ppcre/errors.lisp U trunk/thirdparty/cl-ppcre/lexer.lisp D trunk/thirdparty/cl-ppcre/lispworks-defsystem.lisp D trunk/thirdparty/cl-ppcre/load.lisp U trunk/thirdparty/cl-ppcre/optimize.lisp U trunk/thirdparty/cl-ppcre/packages.lisp U trunk/thirdparty/cl-ppcre/parser.lisp D trunk/thirdparty/cl-ppcre/perltest.pl D trunk/thirdparty/cl-ppcre/ppcre-tests.lisp A trunk/thirdparty/cl-ppcre/regex-class-util.lisp U trunk/thirdparty/cl-ppcre/regex-class.lisp U trunk/thirdparty/cl-ppcre/repetition-closures.lisp U trunk/thirdparty/cl-ppcre/scanner.lisp U trunk/thirdparty/cl-ppcre/specials.lisp A trunk/thirdparty/cl-ppcre/test/ A trunk/thirdparty/cl-ppcre/test/packages.lisp A trunk/thirdparty/cl-ppcre/test/perl-tests.lisp A trunk/thirdparty/cl-ppcre/test/perltest.pl A trunk/thirdparty/cl-ppcre/test/perltestdata A trunk/thirdparty/cl-ppcre/test/perltestinput A trunk/thirdparty/cl-ppcre/test/simple A trunk/thirdparty/cl-ppcre/test/tests.lisp A trunk/thirdparty/cl-ppcre/test/unicode-tests.lisp A trunk/thirdparty/cl-ppcre/test/unicodetestdata D trunk/thirdparty/cl-ppcre/testdata D trunk/thirdparty/cl-ppcre/testinput U trunk/thirdparty/cl-ppcre/util.lisp Change set too large, please see URL above

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