bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

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

24 Jul '08

Revision: 3603 Author: edi URL: http://bknr.net/trac/changeset/3603 Update cl-unicode to release version U trunk/thirdparty/cl-unicode/CHANGELOG.txt U trunk/thirdparty/cl-unicode/doc/index.html U trunk/thirdparty/cl-unicode/test/simple U trunk/thirdparty/cl-unicode/util.lisp Modified: trunk/thirdparty/cl-unicode/CHANGELOG.txt =================================================================== --- trunk/thirdparty/cl-unicode/CHANGELOG.txt 2008-07-23 23:01:07 UTC (rev 3602) +++ trunk/thirdparty/cl-unicode/CHANGELOG.txt 2008-07-23 23:02:44 UTC (rev 3603) @@ -1,3 +1,3 @@ Version 0.1.0 -2008-07-23 +2008-07-24 Initial release Modified: trunk/thirdparty/cl-unicode/doc/index.html =================================================================== --- trunk/thirdparty/cl-unicode/doc/index.html 2008-07-23 23:01:07 UTC (rev 3602) +++ trunk/thirdparty/cl-unicode/doc/index.html 2008-07-23 23:02:44 UTC (rev 3603) @@ -867,8 +867,8 @@ look-ups by removing all whitespace, hyphens, and underline characters. -Tries not to remove hyphens preceded by spaces if this could lead to -ambiguities as described in +Tries not to remove hyphens preceded by spaces or underlines if this +could lead to ambiguities as described in <a href="http://unicode.org/unicode/reports/tr18/#Name_Properties">http://unicode.org/unicode/reports/tr18/#Name_Properties</a>. All CL-UNICODE functions which accept string names for characters @@ -895,8 +895,11 @@ CL-USER 7 > (canonicalize-name (canonicalize-name "TIBETAN LETTER -A")) "TIBETANLETTER -A" + +CL-USER 8 > (canonicalize-name "Tibetan_Letter_-A") +"TibetanLetter -A" </pre> -Note that the preceding space is relevant in the ambiguous cases (but +Note that the preceding chracter is relevant in the ambiguous cases (but there are only three of them): <pre> CL-USER 8 > (char= (<a href="#character-named" class=none>character-named</a> "TibetanLetter A") (<a href="#character-named" class=none>character-named</a> "TibetanLetter -A")) @@ -1160,6 +1163,9 @@ set <a href="#*try-lisp-syntax-p*"><code>*TRY-LISP-SYNTAX-P*</code></a> to a true value when enabling the alternative syntax, so that you can still use the short syntax (like <code>#\a</code>) for characters.) + +For an alternative syntax for strings +see <a href="http://weitz.de/cl-interpol/">CL-INTERPOL</a>. </blockquote>  @@ -1264,7 +1270,7 @@ This documentation was prepared with <a href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>. -$Header: /usr/local/cvsrep/cl-unicode/doc/index.html,v 1.10 2008/07/23 02:22:20 edi Exp $ +$Header: /usr/local/cvsrep/cl-unicode/doc/index.html,v 1.12 2008/07/23 14:55:26 edi Exp $ <a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> </body> Modified: trunk/thirdparty/cl-unicode/test/simple =================================================================== --- trunk/thirdparty/cl-unicode/test/simple 2008-07-23 23:01:07 UTC (rev 3602) +++ trunk/thirdparty/cl-unicode/test/simple 2008-07-23 23:02:44 UTC (rev 3603) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE-TEST; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-unicode/test/simple,v 1.13 2008/07/21 23:12:56 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-unicode/test/simple,v 1.14 2008/07/23 14:11:42 edi Exp $ ;;; some simple tests for CL-UNICODE - entered manually and to be read ;;; in the CL-UNICODE-TEST package; all forms are expected to return a @@ -390,8 +390,10 @@ ;; ambiguous names (see NORMALIZE-NAME) (= #xf68 (character-named "TIBETAN LETTER A" :want-code-point-p t)) +(= #xf68 (character-named "Tibetan_Letter_A" :want-code-point-p t)) (= #xf68 (character-named "TIBETANLETTERA" :want-code-point-p t)) (= #xf60 (character-named "TIBETAN LETTER -A" :want-code-point-p t)) +(= #xf60 (character-named "Tibetan_Letter_-A" :want-code-point-p t)) (= #xfb8 (character-named "TIBETAN SUBJOINED LETTER A" :want-code-point-p t)) (= #xfb8 (character-named "TIBETANSUBJOINEDLETTERA" :want-code-point-p t)) (= #xfb0 (character-named "TIBETAN SUBJOINED LETTER -A" :want-code-point-p t)) Modified: trunk/thirdparty/cl-unicode/util.lisp =================================================================== --- trunk/thirdparty/cl-unicode/util.lisp 2008-07-23 23:01:07 UTC (rev 3602) +++ trunk/thirdparty/cl-unicode/util.lisp 2008-07-23 23:02:44 UTC (rev 3603) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-unicode/util.lisp,v 1.26 2008/07/22 12:20:14 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-unicode/util.lisp,v 1.27 2008/07/23 14:11:40 edi Exp $ ;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved. @@ -45,10 +45,11 @@ All CL-UNICODE functions which accept string \"names\" for characters or properties will canonicalize the name first using this function and will then look up the name case-insensitively." - (values (ppcre:regex-replace-all "( -A| O-E)$|[-_\\s]" name + (values (ppcre:regex-replace-all "[ _](-A|O-E)$|[-_\\s]" name (lambda (match register) (declare (ignore match)) - (or register "")) + (cond (register (format nil " ~A" register)) + (t ""))) :simple-calls t))) (defun property-symbol (name)

1 0

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

24 Jul '08

Revision: 3602 Author: edi URL: http://bknr.net/trac/changeset/3602 Tag cl-ppcre 2.0.0 A tags/thirdparty/cl-ppcre-2.0.0/ Copied: tags/thirdparty/cl-ppcre-2.0.0 (from rev 3601, trunk/thirdparty/cl-ppcre)

1 0

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

24 Jul '08

Revision: 3601 Author: edi URL: http://bknr.net/trac/changeset/3601 Update to release version U trunk/thirdparty/cl-ppcre/CHANGELOG U trunk/thirdparty/cl-ppcre/doc/index.html U trunk/thirdparty/cl-ppcre/scanner.lisp U trunk/thirdparty/cl-ppcre/specials.lisp Modified: trunk/thirdparty/cl-ppcre/CHANGELOG =================================================================== --- trunk/thirdparty/cl-ppcre/CHANGELOG 2008-07-23 22:58:59 UTC (rev 3600) +++ trunk/thirdparty/cl-ppcre/CHANGELOG 2008-07-23 23:00:43 UTC (rev 3601) @@ -1,12 +1,13 @@ Version 2.0.0 -2008-07-23 +2008-07-24 Added named properties (\p{foo}) Added Unicode support Introduced test functions for character classes Added optional test function optimization Cleaned up test suite, removed performance cruft Removed the various alternative system definitions (too much maintenance work) -Exported PARSE-STRING +Exported PARSE-STRING +Changed default value of *USE-BMH-MATCHERS* General cleanup Lots of documentation additions Modified: trunk/thirdparty/cl-ppcre/doc/index.html =================================================================== --- trunk/thirdparty/cl-ppcre/doc/index.html 2008-07-23 22:58:59 UTC (rev 3600) +++ trunk/thirdparty/cl-ppcre/doc/index.html 2008-07-23 23:00:43 UTC (rev 3601) @@ -143,6 +143,7 @@ <li><a href="#backslash">Backslashes may confuse you...</a> </ol> <li><a href="#allegro">AllegroCL compatibility mode</a> + <li><a href="#blabla">Hints, comments, performance considerations</a> <li><a href="#ack">Acknowledgements</a> </ol> @@ -223,8 +224,7 @@ <li><code>\N{name}</code> (named characters), <code>\x{263a}</code> (wide hex characters), <code>\l</code>, <code>\u</code>, <code>\L</code>, and <code>\U</code> -because they're actually not part of Perl's regex syntax and -(honestly) because I was too lazy - but see <a href="http://weitz.de/cl-interpol/">CL-INTERPOL</a>. +because they're actually not part of Perl's regex syntax - but see <a href="http://weitz.de/cl-interpol/">CL-INTERPOL</a>. <li><code>\X</code> (extended Unicode), and <code>\C</code> (single character). But you can of course use all characters @@ -1192,20 +1192,19 @@ [Special variable] <a class=none name="*use-bmh-matchers*">*use-bmh-matchers*</a> -<blockquote> Usually, the scanners created by <a -href="#create-scanner"><code>CREATE-SCANNER</code></a> (or -implicitly by other functions and macros) will use fast <a -href="http://www-igm.univ-mlv.fr/~lecroq/string/node18.html">Boyer-Moore-Horspool -matchers</a> to check for constant strings at the start or end of the -regular expression. If <code>*USE-BMH-MATCHERS*</code> is -<code>NIL</code> (the default is <code>T</code>), the standard -function <a -href="http://www.lispworks.com/documentation/HyperSpec/Body/f_search.htm"><code>SEARCH</code></a> -will be used instead. This will usually be a bit slower but can save -lots of space if you're storing many scanners. The <a -href="#test">test suite</a> will automatically set -<code>*USE-BMH-MATCHERS*</code> to <code>NIL</code> while you're running -the default test. +<blockquote> Usually, the scanners created +by <a href="#create-scanner"><code>CREATE-SCANNER</code></a> (or +implicitly by other functions and macros) will use the standard +function <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_search.htm"><code>SEARCH</code></a> +to check for constant strings at the start or end of the regular +expression. If <code>*USE-BMH-MATCHERS*</code> is true (the default +is <code>NIL</code>), +fast <a href="http://www-igm.univ-mlv.fr/~lecroq/string/node18.html">Boyer-Moore-Horspool +matchers</a> will be used instead. This will usually be faster but +can make the scanners considerably bigger. Per BMH matcher - there +can be up to two per scanner - a fixnum array of +size <a href="#*regex-char-code-limit*"><code>*REGEX-CHAR-CODE-LIMIT*</code></a> +is allocated and closed over. Note: Due to the nature of <a href="http://www.lispworks.com/documentation/HyperSpec/Body/s_ld_tim.htm"><code>LOAD-TIME-VALUE</code></a> and the <a href="#compiler-macro">compiler macro for <code>SCAN</code> and other functions</a>, some @@ -1638,7 +1637,7 @@   <h3><a name="unicode" class=none>Unicode properties</a></h3> You can add support for Unicode properties to CL-PPCRE by loading -the CL-PPCRE-UNICODE system: +the CL-PPCRE-UNICODE system (which depends on <a href="http://weitz.de/cl-unicode/">CL-UNICODE</a>): <pre> (asdf:oos 'asdf:load-op :cl-ppcre-unicode) </pre> @@ -2039,6 +2038,148 @@ </pre> before you compile CL-PPCRE. +   <h3><a class=none name="blabla">Hints, comments, performance considerations</a></h3> + +Here are, in no particular order, a couple of things about CL-PPCRE +and regular expressions in general that you might or might not want to +read. + +<ul> + <li>A lot of hackers (especially users of Perl and other scripting + languages) think that regular expressions are the greatest thing + since slice bread and use it for almost everything. That is just + plain wrong. Other hackers (especially Lispers) tend to think that + regular expressions are the work of the devil and try to avoid them + at all cost. That's also wrong. Regular expressions are a handy + and useful addition to your toolkit which you should use when + appropriate - you should just try to figure out first if + they're appropriate for the task at hand. + + <li>If you're concerned about the string syntax of regular + expressions which can look like line noise and is really hard to + read for long expressions, consider using + CL-PPCRE's <a href="#create-scanner2">S-expression syntax</a> + instead. It is less error-prone and you don't have to worry about + escaping characters. It is also easier to manipulate + programmatically. + + <li>For alternations, order is important. The general rule is that + the regex engine tries from left to right and tries to match as much + as possible. +<pre> +CL-USER 1 > (scan-to-strings "<=|<" "<=") +"<=" +#() + +CL-USER 2 > (scan-to-strings "<|<=" "<=") +"<" +#() +</pre> + + <li><a class=none name="compiler-macro">CL-PPCRE</a> + uses <a href="http://www.lispworks.com/documentation/HyperSpec/Body/03_bba.htm">compiler + macros</a> to pre-compile scanners + at <a href=="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_l.htm#load_time">load + time</a> if possible. This happens if the compiler can determine + that the regular expression (no matter if it's a string or an + S-expression) + is <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_consta.htm">constant</a> + at <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#compile_…">compile + time</a> and is intended to save the time for creating scanners + at <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#executio…">execution + time</a> (probably creating the same scanner over and over in a + loop). Make sure you don't prevent the compiler from helping you. + For example, a definition like this one is usually not a good idea: +<pre> +(defun regex-match (regex target) + ;; don't do that! + (scan regex target)) +</pre> + + <li>If you want to search for a substring in a large string or if + you search for the same string very + often, <a href="#scan"><code>SCAN</code></a> will usually be faster + than Common + Lisp's <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_search.htm"><code>SEARCH</code></a> + if you <a href="#*use-bmh-matchers*">use BMH matchers</a>. However, + this only makes sense if scanner creation time is not the + limiting factor, i.e. if the search target is very large or + if you're using the same scanner very often. + + <li>Complementary to the last hint, don't use regular + expressions for one-time searches for constant strings. That's a + terrible waste of resources. + + <li><a href="#*use-bmh-matchers*"><code>*USE-BMH-MATCHERS*</code></a> together with a large value for + <a href="#*regex-char-code-limit*"><code>*REGEX-CHAR-CODE-LIMIT*</code></a> + can lead to huge scanners. + + <li>A character class is by default translated into a sequence of + tests exactly as you might expect. For + example, <code>"[af-l\\d]"</code> means to test if the character is + equal to <code>#\a</code>, then to test if it's + between <code>#\f</code> and <code>#\l</code>, then if it's a digit. + There's by default no attempt to remove redundancy (as + 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 + make sure that you have O(1) test functions. + + <li>If you know that the expression you're looking for is anchored, + use anchors in your regex. This can help the engine a lot to make + 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. + 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. + + <li>Try to avoid alternations if possible or at least factor them + out as in the example above. + + <li>If neither anchors nor constant strings are in sight, maybe + "standalone" (sometimes also called "possessive") regular + expressions can be helpful. Try the following: +<pre> +(let ((target (make-string 10000 :initial-element #\a)) + (scanner-1 (create-scanner "a*\\d")) + (scanner-2 (create-scanner "(?>a*)\\d"))) + (time (scan scanner-1 target)) + (time (scan scanner-2 target))) +</pre> + + <li>Consider using <a href="#create-scanner">"single-line mode"</a> + if it makes sense for your task. By default (following Perl's + practice), a dot means to search for any character except + line breaks. In single-line mode a dot searches for any + character which in some cases means that large parts of the target + can actually be skipped. This can be vastly more efficient for + large targets. + + <li>Don't use capturing register groups where a non-capturing group + would do, i.e. only use registers if you need to refer to + them later. If you use a register, each scan process needs to + allocate space for it and update its contents (possibly many times) + until it's finished. (In Perl parlance - use <code>"(?:foo)"</code> instead of + <code>"(foo)"</code> whenever possible.) + + <li>In addition to what has been said in the last hint, note that + Perl semantics force the regex engine to report the last + match for each register. This implies for example + that <code>"([a-c])+"</code> and <code>"[a-c]*([a-c])"</code> have + exactly the same semantics but completely different performance + characteristics. (Actually, in some cases CL-PPCRE automatically + converts expressions from the first type into the second type. + That's not always possible, though, and you shouldn't rely on it.) + + <li>By default, repetitions are "greedy" in Perl (and thus in + CL-PPCRE). This has an impact on performance and also on the actual + outcome of a scan. Look at your repetitions and ponder if a greedy + repetition is really what you want. +</ul> +   <h3><a class=none name="ack">Acknowledgements</a></h3> Although I didn't use their code, I was heavily inspired by looking at @@ -2067,7 +2208,7 @@ OpenMCL. -$Header: /usr/local/cvsrep/cl-ppcre/doc/index.html,v 1.191 2008/07/23 02:14:09 edi Exp $ +$Header: /usr/local/cvsrep/cl-ppcre/doc/index.html,v 1.195 2008/07/23 22:24:52 edi Exp $ <a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> </body> Modified: trunk/thirdparty/cl-ppcre/scanner.lisp =================================================================== --- trunk/thirdparty/cl-ppcre/scanner.lisp 2008-07-23 22:58:59 UTC (rev 3600) +++ trunk/thirdparty/cl-ppcre/scanner.lisp 2008-07-23 23:00:43 UTC (rev 3601) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/scanner.lisp,v 1.34 2008/07/06 18:12:05 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/scanner.lisp,v 1.35 2008/07/23 22:25:15 edi Exp $ ;;; Here the scanner for the actual regex as well as utility scanners ;;; for the constant start and end strings are created. @@ -36,21 +36,21 @@ "Auxiliary macro used by CREATE-BMH-MATCHER." (let ((char-compare (if case-insensitive-p 'char-equal 'char=))) `(lambda (start-pos) - (declare (fixnum start-pos)) - (if (or (minusp start-pos) - (> (the fixnum (+ start-pos m)) *end-pos*)) - nil - (loop named bmh-matcher - for k of-type fixnum = (+ start-pos m -1) - then (+ k (max 1 (aref skip (char-code (schar *string* k))))) - while (< k *end-pos*) - do (loop for j of-type fixnum downfrom (1- m) - for i of-type fixnum downfrom k - while (and (>= j 0) - (,char-compare (schar *string* i) - (schar pattern j))) - finally (if (minusp j) - (return-from bmh-matcher (1+ i))))))))) + (declare (fixnum start-pos)) + (if (or (minusp start-pos) + (> (the fixnum (+ start-pos m)) *end-pos*)) + nil + (loop named bmh-matcher + for k of-type fixnum = (+ start-pos m -1) + then (+ k (max 1 (aref skip (char-code (schar *string* k))))) + while (< k *end-pos*) + do (loop for j of-type fixnum downfrom (1- m) + for i of-type fixnum downfrom k + while (and (>= j 0) + (,char-compare (schar *string* i) + (schar pattern j))) + finally (if (minusp j) + (return-from bmh-matcher (1+ i))))))))) (defun create-bmh-matcher (pattern case-insensitive-p) "Returns a Boyer-Moore-Horspool matcher which searches the (special) @@ -76,15 +76,15 @@ :test test)))))) (let* ((m (length pattern)) (skip (make-array *regex-char-code-limit* - :element-type 'fixnum - :initial-element m))) + :element-type 'fixnum + :initial-element m))) (declare (fixnum m)) (loop for k of-type fixnum below m if case-insensitive-p - do (setf (aref skip (char-code (char-upcase (schar pattern k)))) (- m k 1) - (aref skip (char-code (char-downcase (schar pattern k)))) (- m k 1)) + do (setf (aref skip (char-code (char-upcase (schar pattern k)))) (- m k 1) + (aref skip (char-code (char-downcase (schar pattern k)))) (- m k 1)) else - do (setf (aref skip (char-code (schar pattern k))) (- m k 1))) + do (setf (aref skip (char-code (schar pattern k))) (- m k 1))) (if case-insensitive-p (bmh-matcher-aux :case-insensitive-p t) (bmh-matcher-aux)))) Modified: trunk/thirdparty/cl-ppcre/specials.lisp =================================================================== --- trunk/thirdparty/cl-ppcre/specials.lisp 2008-07-23 22:58:59 UTC (rev 3600) +++ trunk/thirdparty/cl-ppcre/specials.lisp 2008-07-23 23:00:43 UTC (rev 3601) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/specials.lisp,v 1.40 2008/07/23 02:14:06 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/specials.lisp,v 1.41 2008/07/23 22:25:15 edi Exp $ ;;; globally declared special variables @@ -120,7 +120,7 @@ Only used for patterns which might have zero length.") (declaim (simple-vector *last-pos-stores*)) -(defvar *use-bmh-matchers* t +(defvar *use-bmh-matchers* nil "Whether the scanners created by CREATE-SCANNER should use the \(fast but large) Boyer-Moore-Horspool matchers.")

1 0

[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

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