January 2008 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2384 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 22 Jan '08

22 Jan '08

Author: hhubner Date: Tue Jan 22 01:59:19 2008 New Revision: 2384 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp Log: Slightly beautify table. Please use upper case letters for format directives so that they are easier to identify visually. Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Tue Jan 22 01:59:19 2008 @@ -197,13 +197,15 @@ (summing (length regions)))) (defun pprint-cache () + (format t "~5A~10T~A~%" "size" "count") + (format t "~5A~10T~A~%" "-----" "-----") (iter - (for regions in-vector (allocation-cache-index *allocation-cache*)) + (for cache-entries in-vector (allocation-cache-index *allocation-cache*)) (for size upfrom 1) - (for region-count = (length regions)) - (unless (zerop region-count) - (format t "~a~10T~a~%" size region-count))) - (format t "area size ignored by cache: ~a~%" (ignored-size *allocation-cache*))) + (for count = (length cache-entries)) + (unless (zerop count) + (format t "~5D~10T~5D~%" size count))) + (format t "~%Area size ignored by cache: ~A~%" (ignored-size *allocation-cache*))) (defun rebuild-cache () (setq *allocation-cache* (make-allocation-cache))

1 0

[bknr-cvs] r2383 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 22 Jan '08

22 Jan '08

Author: hhubner Date: Tue Jan 22 01:58:29 2008 New Revision: 2383 Modified: branches/bos/projects/bos/web/allocation-cache-handlers.lisp Log: Remove "disclaimer" Modified: branches/bos/projects/bos/web/allocation-cache-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/allocation-cache-handlers.lisp (original) +++ branches/bos/projects/bos/web/allocation-cache-handlers.lisp Tue Jan 22 01:58:29 2008 @@ -7,8 +7,7 @@ (defmethod handle ((handler allocation-cache-handler) req) (with-bos-cms-page (req :title "Allocation Cache") - (html - (:p (:i "not yet very meaningful...")) + (html (:pre (:princ (with-output-to-string (*standard-output*) (bos.m2.allocation-cache:pprint-cache)))))))

1 0

[bknr-cvs] r2382 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 22 Jan '08

22 Jan '08

Author: hhubner Date: Tue Jan 22 01:54:54 2008 New Revision: 2382 Modified: branches/bos/projects/bos/web/allocation-cache-handlers.lisp Log: Fix output formatting so that line breaks actually make it into the generated HTML. Modified: branches/bos/projects/bos/web/allocation-cache-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/allocation-cache-handlers.lisp (original) +++ branches/bos/projects/bos/web/allocation-cache-handlers.lisp Tue Jan 22 01:54:54 2008 @@ -9,7 +9,7 @@ (with-bos-cms-page (req :title "Allocation Cache") (html (:p (:i "not yet very meaningful...")) - (:pre (:princ-safe + (:pre (:princ (with-output-to-string (*standard-output*) (bos.m2.allocation-cache:pprint-cache)))))))

1 0

[bknr-cvs] r2381 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 12:30:43 2008 New Revision: 2381 Added: branches/bos/projects/bos/web/allocation-cache-handlers.lisp Modified: branches/bos/projects/bos/web/bos.web.asd branches/bos/projects/bos/web/webserver.lisp Log: added basic allocation-cache handler pre output not very meaningful yet due to missing linebreaks (?) Added: branches/bos/projects/bos/web/allocation-cache-handlers.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/web/allocation-cache-handlers.lisp Mon Jan 21 12:30:43 2008 @@ -0,0 +1,15 @@ +(in-package :bos.web) + +(enable-interpol-syntax) + +(defclass allocation-cache-handler (admin-only-handler page-handler) + ()) + +(defmethod handle ((handler allocation-cache-handler) req) + (with-bos-cms-page (req :title "Allocation Cache") + (html + (:p (:i "not yet very meaningful...")) + (:pre (:princ-safe + (with-output-to-string (*standard-output*) + (bos.m2.allocation-cache:pprint-cache))))))) + Modified: branches/bos/projects/bos/web/bos.web.asd ============================================================================== --- branches/bos/projects/bos/web/bos.web.asd (original) +++ branches/bos/projects/bos/web/bos.web.asd Mon Jan 21 12:30:43 2008 @@ -33,6 +33,7 @@ (:file "sponsor-handlers" :depends-on ("web-utils")) (:file "news-handlers" :depends-on ("web-utils")) (:file "allocation-area-handlers" :depends-on ("web-utils")) + (:file "allocation-cache-handlers" :depends-on ("web-utils")) (:file "languages-handler" :depends-on ("web-utils")) (:file "tags" :depends-on ("web-utils")) (:file "news-tags" :depends-on ("web-utils")) Modified: branches/bos/projects/bos/web/webserver.lisp ============================================================================== --- branches/bos/projects/bos/web/webserver.lisp (original) +++ branches/bos/projects/bos/web/webserver.lisp Mon Jan 21 12:30:43 2008 @@ -210,6 +210,7 @@ ("/create-allocation-area" create-allocation-area-handler) ("/allocation-area" allocation-area-handler) ("/allocation-area-gfx" allocation-area-gfx-handler) + ("/allocation-cache" allocation-cache-handler) ("/contract-image" contract-image-handler) ("/certificate" certificate-handler) ("/cert-regen" cert-regen-handler) @@ -239,7 +240,8 @@ ("logout" . "logout")) :admin-navigation '(("user" . "user/") ("languages" . "languages") - ("allocation area" . "allocation-area/")) + ("allocation area" . "allocation-area/") + ("allocation cache" . "allocation-cache")) :authorizer (make-instance 'bos-authorizer) :site-logo-url "/images/bos-logo.gif" :style-sheet-urls '("/static/cms.css")

1 0

[bknr-cvs] r2380 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 11:36:19 2008 New Revision: 2380 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/packages.lisp Log: renamed allocation-cache functions Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Mon Jan 21 11:36:19 2008 @@ -191,12 +191,12 @@ :region region)) (incf (ignored-size *allocation-cache*) size))))) -(defun free-regions-count () +(defun count-cache-entries () (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) (summing (length regions)))) -(defun free-regions-pprint () +(defun pprint-cache () (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) (for size upfrom 1) Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 11:36:19 2008 @@ -25,7 +25,7 @@ (bos.m2::activate-allocation-area area)) (with-store-reopenings (area sponsor) (finishes (allocation-area-free-m2s area)) - (is (= 1 (bos.m2.allocation-cache:free-regions-count))) + (is (= 1 (bos.m2.allocation-cache:count-cache-entries))) (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Mon Jan 21 11:36:19 2008 @@ -237,8 +237,8 @@ :arnesi) (:export #:find-exact-match #:add-area - #:free-regions-count - #:free-regions-pprint + #:count-cache-entries + #:pprint-cache #:rebuild-cache #:allocation-cache-subsystem))

1 0

[bknr-cvs] r2379 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 21 Jan '08

21 Jan '08

Author: hhubner Date: Mon Jan 21 11:18:10 2008 New Revision: 2379 Modified: branches/bos/projects/bos/m2/mail-generator.lisp Log: Ignore errors while deleting print certificate. Modified: branches/bos/projects/bos/m2/mail-generator.lisp ============================================================================== --- branches/bos/projects/bos/m2/mail-generator.lisp (original) +++ branches/bos/projects/bos/m2/mail-generator.lisp Mon Jan 21 11:18:10 2008 @@ -222,7 +222,7 @@ :subtype "mixed" :content parts) t t)))) - (when (contract-pdf-pathname contract :print t) + (ignore-errors (delete-file (contract-pdf-pathname contract :print t)))) (defun mail-print-pdf (contract) @@ -248,7 +248,8 @@ :encoding :base64 :content (file-contents (contract-pdf-pathname contract :print t))))) t t))) - (delete-file (contract-pdf-pathname contract :print t))) + (ignore-errors + (delete-file (contract-pdf-pathname contract :print t)))) (defun mail-backoffice-sponsor-data (contract req) (with-query-params (req numsqm country email name address date language)

1 0

[bknr-cvs] r2378 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 10:39:51 2008 New Revision: 2378 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/allocation.lisp branches/bos/projects/bos/m2/packages.lisp Log: allocation-cache now updated for RETURN-M2S Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Mon Jan 21 10:39:51 2008 @@ -219,6 +219,15 @@ (unless (zerop region-count) (leave size)))) +(defmethod return-m2s :after (m2s) + ;; bos.m2::m2-allocation-area is quite + ;; expensive... + ;; (assert (every #'(lambda (m2) (eq (bos.m2::m2-allocation-area (first m2s)) (bos.m2::m2-allocation-area m2))) + ;; (rest m2s))) + (let ((allocation-area (bos.m2::m2-allocation-area (first m2s)))) + (index-push (length m2s) (make-cache-entry :area allocation-area + :region m2s)))) + ;;; subsystem (defclass allocation-cache-subsystem () ()) Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 10:39:51 2008 @@ -55,3 +55,39 @@ (is (= (- 64 10) (allocation-area-free-m2s area))) (signals (error) (make-contract sponsor 64))))) +(store-test allocation-area.return-m2s + (let* ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor")) + (contract (make-contract sponsor 64))) + (with-store-reopenings (area sponsor contract) + (is (zerop (allocation-area-free-m2s area))) + (signals (error) (make-contract sponsor 64)) + (with-transaction () + (destroy-object contract)) + (is-true (bos.m2.allocation-cache:find-exact-match 64)) + (finishes (make-contract sponsor 10)) + (is (= (- (* 8 8) 10) (allocation-area-free-m2s area)))))) + +(test allocation-area.two-areas + (with-fixture empty-store () + (let ((snapshot nil) (bypass t)) + (declare (ignorable snapshot bypass)) + (let* ((area1 (make-allocation-rectangle 0 0 8 8)) + (area2 (make-allocation-rectangle 10 10 8 8)) + (sponsor (make-sponsor :login "test-sponsor")) + (total-free (+ 64 64))) + (progn + (iter (while (> total-free 20)) + (bos.m2.allocation-cache:rebuild-cache) + (for size = (1+ (random 3))) + (is (= total-free (+ (allocation-area-free-m2s area1) + (allocation-area-free-m2s area2)))) + (with-transaction () + (iter + (while (> size total-free)) + (for contract = (first (class-instances 'contract))) + (incf total-free (length (contract-m2s contract))) + (destroy-object contract))) + (finishes (make-contract sponsor size)) + (decf total-free size))))))) + Modified: branches/bos/projects/bos/m2/allocation.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation.lisp (original) +++ branches/bos/projects/bos/m2/allocation.lisp Mon Jan 21 10:39:51 2008 @@ -641,7 +641,7 @@ (warn "all allocation areas exhausted") nil)) -(defun return-m2s (m2s) +(defmethod return-m2s (m2s) "Mark the given square meters as free, so that they can be re-allocated." (when m2s (loop for m2 in m2s Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Mon Jan 21 10:39:51 2008 @@ -87,6 +87,7 @@ #:m2-utm-x #:m2-utm-y #:escape-nl + #:return-m2s #:sponsor #:make-sponsor

1 0

[bknr-cvs] r2377 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 21 Jan '08

21 Jan '08

Author: hhubner Date: Mon Jan 21 09:14:09 2008 New Revision: 2377 Modified: branches/bos/projects/bos/m2/test-fixtures.lisp Log: &rest statt &body Modified: branches/bos/projects/bos/m2/test-fixtures.lisp ============================================================================== --- branches/bos/projects/bos/m2/test-fixtures.lisp (original) +++ branches/bos/projects/bos/m2/test-fixtures.lisp Mon Jan 21 09:14:09 2008 @@ -9,7 +9,7 @@ :website-url bos.m2::*website-url*) (format t "~&;; ++ reopen-store done~%")) -(defmacro reopen-store ((&key snapshot) &body store-object-vars) +(defmacro reopen-store ((&key snapshot) &rest store-object-vars) (let ((id-vars (iter (with *print-case* = :upcase) (for store-object-var in store-object-vars)

1 0

[bknr-cvs] r2376 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 09:03:34 2008 New Revision: 2376 Removed: branches/bos/projects/bos/m2/allocation-cache-test.lisp Modified: branches/bos/projects/bos/m2/bos.test.asd Log: no need to have separate allocation-cache-test.lisp Modified: branches/bos/projects/bos/m2/bos.test.asd ============================================================================== --- branches/bos/projects/bos/m2/bos.test.asd (original) +++ branches/bos/projects/bos/m2/bos.test.asd Mon Jan 21 09:03:34 2008 @@ -6,7 +6,6 @@ :components ((:file "packages-test") (:file "test-suites" :depends-on ("packages-test")) (:file "test-fixtures" :depends-on ("packages-test")) - (:file "allocation-test" :depends-on ("test-suites" "test-fixtures")) - (:file "allocation-cache-test" :depends-on ("test-suites" "test-fixtures")) + (:file "allocation-test" :depends-on ("test-suites" "test-fixtures")) ;; (:file "utils" :depends-on ("config")) ))

1 0

[bknr-cvs] r2375 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 08:59:03 2008 New Revision: 2375 Modified: branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/test-fixtures.lisp Log: now using STORE-TEST + WITH-STORE-REOPENINGS to define tests Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 08:59:03 2008 @@ -1,50 +1,56 @@ (in-package :bos.test) (in-suite :bos.test.allocation-area) -(test allocation-area.none-at-startup - (with-fixture empty-store () - (is (null (class-instances 'bos.m2:allocation-area))))) +(store-test allocation-area.none-at-startup + (is (null (class-instances 'bos.m2:allocation-area)))) -(test allocation-area.no-intersection - (with-fixture empty-store () +(store-test allocation-area.no-intersection + (with-store-reopenings () (finishes (make-allocation-rectangle 0 0 100 100)) (signals (error) (make-allocation-rectangle 0 0 100 100)))) -(test allocation-area.one-contract.no-cache - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 100 100)) - (sponsor (make-sponsor :login "test-sponsor")) - (m2-count 10)) +(store-test allocation-area.one-contract.no-cache + (let ((area (make-allocation-rectangle 0 0 100 100)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor m2-count)) (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area)))))) -(test allocation-area.one-contract.with-cache.1 - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 2 5)) - (sponsor (make-sponsor :login "test-sponsor")) - (m2-count 10)) - (with-transaction () - (bos.m2::activate-allocation-area area)) +(store-test allocation-area.one-contract.with-cache.1 + (let ((area (make-allocation-rectangle 0 0 2 5)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (with-transaction () + (bos.m2::activate-allocation-area area)) + (with-store-reopenings (area sponsor) (finishes (allocation-area-free-m2s area)) - (is (= 1 (bos.m2.allocation-cache:free-regions-count))) - (reopen-store (:snapshot nil) area sponsor) + (is (= 1 (bos.m2.allocation-cache:free-regions-count))) (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) -(test allocation-area.one-contract.allocate-all-without-cache - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 100 100)) - (sponsor (make-sponsor :login "test-sponsor")) - (m2-count (* 100 100))) +(store-test allocation-area.one-contract.allocate-all-without-cache + (let ((area (make-allocation-rectangle 0 0 100 100)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count (* 100 100))) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor m2-count)) (signals (error) (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) -(test allocation-area.one-contract.notany-m2-contract - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 8 8)) - (sponsor (make-sponsor :login "test-sponsor"))) +(store-test allocation-area.one-contract.notany-m2-contract + (let ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor"))) + (with-store-reopenings (area sponsor) + (finishes (make-contract sponsor 10)) + (is (= (- 64 10) (allocation-area-free-m2s area))) + (signals (error) (make-contract sponsor 64))))) + +(store-test allocation-area.one-contract.notany-m2-contract + (let ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor"))) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor 10)) (is (= (- 64 10) (allocation-area-free-m2s area))) (signals (error) (make-contract sponsor 64))))) Modified: branches/bos/projects/bos/m2/test-fixtures.lisp ============================================================================== --- branches/bos/projects/bos/m2/test-fixtures.lisp (original) +++ branches/bos/projects/bos/m2/test-fixtures.lisp Mon Jan 21 08:59:03 2008 @@ -26,6 +26,22 @@ (collect store-object-var) (collect `(find-store-object ,id-var))))))) +(defmacro %with-store-reopenings ((&key snapshot bypass) + (&rest store-object-vars) &body body) + `(progn + ,@(if bypass + body + (iter + (for form in body) + (unless (first-time-p) + (collect `(reopen-store (:snapshot ,snapshot) ,@store-object-vars))) + (collect form))))) + +(defmacro with-store-reopenings ((&rest store-object-vars) &body body) + `(%with-store-reopenings (:snapshot snapshot :bypass bypass) + (,@store-object-vars) + ,@body)) + (def-fixture empty-store () (unwind-protect (progn @@ -35,3 +51,19 @@ (&body)) (close-store))) +(defmacro store-test (name &body body) + `(progn + ,@(iter + (for config in '((:suffix reopenings-no-snapshot :snapshot nil :bypass nil) + (:suffix reopenings-with-snapshot :snapshot t :bypass nil) + (:suffix nil :snapshot nil :bypass t))) + (for test-name = (if (getf config :suffix) + (intern (format nil "~a.~a" name (getf config :suffix))) + name)) + (collect `(test ,test-name + (with-fixture empty-store () + (let ((snapshot ,(getf config :snapshot)) + (bypass ,(getf config :bypass))) + (declare (ignorable snapshot bypass)) + ,@body))))))) +

1 0

[bknr-cvs] r2374 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 07:40:18 2008 New Revision: 2374 Modified: branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/allocation.lisp branches/bos/projects/bos/m2/test-fixtures.lisp Log: Started some testing using REOPEN-STORE. Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 07:40:18 2008 @@ -25,7 +25,9 @@ (m2-count 10)) (with-transaction () (bos.m2::activate-allocation-area area)) + (finishes (allocation-area-free-m2s area)) (is (= 1 (bos.m2.allocation-cache:free-regions-count))) + (reopen-store (:snapshot nil) area sponsor) (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) Modified: branches/bos/projects/bos/m2/allocation.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation.lisp (original) +++ branches/bos/projects/bos/m2/allocation.lisp Mon Jan 21 07:40:18 2008 @@ -46,10 +46,13 @@ (defmethod print-object ((allocation-area allocation-area) stream) (print-unreadable-object (allocation-area stream :type t) - (format stream "~a x ~a ~:[inactive~;active~] ID: ~a" + (format stream "~a x ~a ~:[inactive~;active~] free: ~s ID: ~a" (allocation-area-width allocation-area) (allocation-area-height allocation-area) (allocation-area-active-p allocation-area) + (if (slot-boundp allocation-area 'free-m2s) + (allocation-area-free-m2s allocation-area) + :unbound) (store-object-id allocation-area)))) (defmethod initialize-persistent-instance :after ((allocation-area allocation-area)) @@ -181,13 +184,13 @@ (null (allocation-area-free-m2s allocation-area))))) (all-allocation-areas))) -(defun activate-allocation-area (area) +(deftransaction activate-allocation-area (area) (warn "activating ~S" area) (setf (slot-value area 'active-p) t) (bos.m2.allocation-cache:rebuild-cache) area) -(defun deactivate-allocation-area (area) +(deftransaction deactivate-allocation-area (area) (warn "deactivating ~S" area) (setf (slot-value area 'active-p) nil) (bos.m2.allocation-cache:rebuild-cache) Modified: branches/bos/projects/bos/m2/test-fixtures.lisp ============================================================================== --- branches/bos/projects/bos/m2/test-fixtures.lisp (original) +++ branches/bos/projects/bos/m2/test-fixtures.lisp Mon Jan 21 07:40:18 2008 @@ -1,5 +1,31 @@ (in-package :bos.test) +(defun %reopen-store (&key snapshot) + (format t "~&;; ++ reopen-store~%") + (when snapshot + (format t "~&;; ++ taking snapshot~%") + (snapshot)) + (bos.m2::reinit :directory (bknr.datastore::store-directory *store*) + :website-url bos.m2::*website-url*) + (format t "~&;; ++ reopen-store done~%")) + +(defmacro reopen-store ((&key snapshot) &body store-object-vars) + (let ((id-vars (iter + (with *print-case* = :upcase) + (for store-object-var in store-object-vars) + (for id-var = (gensym (format nil "~A-ID" store-object-var))) + (collect id-var)))) + `(let (,@(iter + (for id-var in id-vars) + (for store-object-var in store-object-vars) + (collect `(,id-var (store-object-id ,store-object-var))))) + (%reopen-store :snapshot ,snapshot) + (setf ,@(iter + (for id-var in id-vars) + (for store-object-var in store-object-vars) + (collect store-object-var) + (collect `(find-store-object ,id-var))))))) + (def-fixture empty-store () (unwind-protect (progn

1 0

[bknr-cvs] r2373 - branches/bos/bknr/src/data
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 07:38:57 2008 New Revision: 2373 Modified: branches/bos/bknr/src/data/object.lisp Log: !! crucial ch to BKNR.DATASTORE (object.lisp): (INITIALIZE-PERSISTENT-INSTANCE obj) is now always called (independently of the store-state). The result is that it will also be called inside LOAD-TRANSACTION-LOG. As TX-MAKE-OBJECT (being a transaction) is never called when restoring the object subsystem snapshot, the former check with unless (unless (eq (store-state *store*) :restore) (initialize-persistent-instance obj)) seems to be not needed / useful. Modified: branches/bos/bknr/src/data/object.lisp ============================================================================== --- branches/bos/bknr/src/data/object.lisp (original) +++ branches/bos/bknr/src/data/object.lisp Mon Jan 21 07:38:57 2008 @@ -571,8 +571,7 @@ (if restoring (remove-transient-slot-initargs (find-class class-name) initargs) initargs))) - (unless restoring - (initialize-persistent-instance obj)) + (initialize-persistent-instance obj) (initialize-transient-instance obj) (setf error nil) obj)

1 0

[bknr-cvs] r2372 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 07:27:05 2008 New Revision: 2372 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp Log: new SNAPSHOT-SUBSYSTEM method for ALLOCATION-CACHE-SUBSYSTEM, which simply does nothing Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Mon Jan 21 07:27:05 2008 @@ -227,3 +227,6 @@ (store (subsystem allocation-cache-subsystem) &key until) (declare (ignore until)) (rebuild-cache)) + +(defmethod bknr.datastore::snapshot-subsystem (store (subsystem allocation-cache-subsystem)) + ) \ No newline at end of file

1 0

[bknr-cvs] r2371 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 21 Jan '08

21 Jan '08

Author: hhubner Date: Mon Jan 21 06:10:27 2008 New Revision: 2371 Added: branches/bos/projects/bos/m2/geo-utm.lisp branches/bos/projects/bos/m2/geometry.lisp Modified: branches/bos/projects/bos/m2/bos.m2.asd branches/bos/projects/bos/m2/map.lisp branches/bos/projects/bos/m2/packages.lisp Log: Application-agnostic geometry functions should be put into geometry.lisp now, point-in-polygon-p has been moved. Add Common Lisp version of the Javascript UTM<->Lat/Lon converter, does not yet work. Modified: branches/bos/projects/bos/m2/bos.m2.asd ============================================================================== --- branches/bos/projects/bos/m2/bos.m2.asd (original) +++ branches/bos/projects/bos/m2/bos.m2.asd Mon Jan 21 06:10:27 2008 @@ -3,19 +3,25 @@ (asdf:defsystem :bos.m2 :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate :arnesi) :components ((:file "packages") + (:file "geo-utm" :depends-on ("packages")) + (:file "geometry" :depends-on ("packages")) (:file "config" :depends-on ("packages")) (:file "utils" :depends-on ("config")) (:file "news" :depends-on ("poi")) (:file "tiled-index" :depends-on ("config")) (:file "mail-generator" :depends-on ("config")) (:file "make-certificate" :depends-on ("config")) - (:file "m2" :depends-on ("tiled-index" "utils" "make-certificate" "mail-generator")) + (:file "m2" :depends-on ("tiled-index" + "utils" + "make-certificate" + "mail-generator" + "geo-utm")) (:file "contract-expiry" :depends-on ("m2")) (:file "allocation" :depends-on ("m2")) - (:file "allocation-cache" :depends-on ("packages")) + (:file "allocation-cache" :depends-on ("packages" "geometry")) (:file "poi" :depends-on ("utils" "allocation")) (:file "bitmap" :depends-on ("allocation")) (:file "import" :depends-on ("m2")) - (:file "map" :depends-on ("m2" "allocation")) + (:file "map" :depends-on ("m2" "allocation" "geometry")) (:file "export" :depends-on ("m2")) (:file "cert-daemon" :depends-on ("config")))) Added: branches/bos/projects/bos/m2/geo-utm.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/m2/geo-utm.lisp Mon Jan 21 06:10:27 2008 @@ -0,0 +1,152 @@ +(in-package :geo-utm) + +;; Converted from Javascript + +;; Origin: http:;;home.hiwaay.net/~taylorc/toolbox/geography/geoutm.html +;; Copyright 1997-1998 by Charles L. Taylor + +;; Page says: + +;; <P>Programmers: The JavaScript source code in this document may be copied +;; and reused without restriction.</P> + +(defconstant sm_a 6378137.0) +(defconstant sm_b 6356752.314) +(defconstant sm_EccSquared 6.69437999013e-03) + +(defconstant UTMScaleFactor 0.9996) + +(defun DegToRad (deg) + (* (/ deg 180.0) pi)) + +(defun RadToDeg (rad) + (/ rad (* pi 180.0))) + +(defun ArcLengthOfMeridian (phi) + (let* ((n (/ (- sm_a sm_b) (+ sm_a sm_b))) + (alpha (* (/ (+ sm_a sm_b) 2) + (+ 1 + (/ (expt n 2) 4) + (/ (expt n 4) 64)))) + (beta (+ (/ (* -3 n) 2) + (/ (* 9 (expt n 3)) 16) + (/ (* -3 (expt n 5)) 32))) + (gamma (+ (/ (* 15 (expt n 2)) 16) + (/ (* -15 (expt n 4)) 32))) + (delta (+ (/ (* -35 (expt n 3)) 48) + (/ (* 105 (expt n 5)) 256))) + (epsilon (/ (* 315 (expt n 4)) 512))) + (* alpha + (+ phi + (* beta (sin (* 2 phi))) + (* gamma (sin (* 4 phi))) + (* delta (sin (* 6 phi))) + (* epsilon (sin (* 8 phi))))))) + +(defun UTMCentralMeridian (zone) + (DegToRad (+ -183 (* zone 6)))) + +(defun FootpointLatitude (y) + (let* ((n (/ (- sm_a sm_b) (+ sm_a sm_b))) + (alpha (* (/ (+ sm_a sm_b) 2) + (+ 1 + (/ (expt n 2) 4) + (/ (expt n 4) 64)))) + (y (/ y alpha)) + (beta (+ (/ (* 3 n) 2) + (/ (* -27 (expt n 3)) 32) + (/ (* 269 (expt n 5) 512)))) + (gamma (+ (/ (* 21 (expt n 2)) 16) + (/ (* -55 (expt n 4)) 32))) + (delta (+ (/ (* 151 (expt n 3)) 96) + (/ (* -417 (expt n 5)) 128))) + (epsilon (/ (* 1097 (expt n 4)) 512))) + (+ y + (* beta (sin (* 2 y))) + (* gamma (sin (* 4 y))) + (* delta (sin (* 6 y))) + (* epsilon (sin (* 8 y)))))) + +(defun MapLatLonToXY (phi lambda lambda0) + (let* ((ep2 (/ (- (expt sm_a 2) (expt sm_b 2)) (expt sm_b 2))) + (nu2 (* ep2 (expt (cos phi) 2))) + (N (/ (expt sm_a 2) (* sm_b (sqrt (+ 1 nu2))))) + (t- (tan phi)) + (t2 (* t- t-)) + (l (- lambda lambda0)) + (l3coef (+ 1 (- t2) nu2)) + (l4coef (+ 5 (- t2) (* 9 nu2) (* 4 nu2 nu2))) + (l5coef (+ 5 (- (* 18 t2)) (* t2 t2) (* 14 nu2) (- (* 58 t2 nu2)))) + (l6coef (+ 61 (- (* 58 t2)) (* t2 t2) (* 270 nu2) (- (* 330 t2 nu2)))) + (l7coef (+ 61 (- (* 479 t2)) (* 179 t2 t2) (- (* t2 t2 t2)))) + (l8coef (+ 1385 (- (* 3111 t2)) (* 543 t2 t2) (- (* t2 t2 t2)))) + (easting (+ (* N (cos phi) l) + (/ N (* 6 (expt (cos phi) 3) l3coef (expt l 3))) + (/ N (* 120 (expt (cos phi) 5) l5coef (expt l 5))) + (/ N (* 5040 (expt (cos phi) 7) l7coef (expt l 7))))) + (northing (+ (ArcLengthOfMeridian phi) + (/ t- (* 2 N (expt (cos phi) 2) (expt l 2))) + (/ t- (* 24 N (expt (cos phi) 4) l4coef (expt l 4))) + (/ t- (* 720 N (expt (cos phi) 6) l6coef (expt l 6))) + (/ t- (* 40320 N (expt (cos phi) 8) l8coef (expt l 8)))))) + (list easting northing))) + +(defun MapXYToLatLon (x y lambda0) + (let* ((phif (FootpointLatitude y)) + (ep2 (/ (- (expt sm_a 2) (expt sm_b 2)) (expt sm_b 2))) + (cf (cos phif)) + (nuf2 (* ep2 (expt cf 2))) + (Nf (/ (expt sm_a 2) (* sm_b (sqrt (+ 1 nuf2))))) + (tf (tan phif)) + (tf2 (* tf tf)) + (tf4 (* tf2 tf2)) + (x1frac (/ 1.0 (* Nf cf))) + (x2frac (/ tf (* 2 (expt Nf 2)))) + (x3frac (/ 1.0 (* 6 (expt Nf 3) cf))) + (x4frac (/ tf (* 24 (expt Nf 4)))) + (x5frac (/ 1.0 (* 120 (expt Nf 5) cf))) + (x6frac (/ tf (* 720 (expt Nf 6)))) + (x7frac (/ 1.0 (* 5040 (expt Nf 7) cf))) + (x8frac (/ tf (* 40320 (expt Nf 8)))) + (x2poly (- -1 nuf2)) + (x3poly (- -1 (* 2 tf2) nuf2)) + (x4poly (+ 5 + (* 3 tf2) + (* 6 nuf2) + (- (* 6 tf2 nuf2)) + (- (* 3 nuf2 nuf2)) + (- (* 9 tf2 nuf2 nuf2)))) + (x5poly (+ 5 (* 28 tf2) (* 24 tf4) (* 6 nuf2) (* 8 tf2 nuf2))) + (x6poly (+ -61 (- (* 90 tf2)) (- (* 45 tf4)) (- (* 107 nuf2)) (* 162 tf2 nuf2))) + (x7poly (- 6 (* 662 tf2) (* 1320 tf4) (* 720 tf4 tf2))) + (x8poly (+ 1385 (* 3633 tf2) (* 4095 tf4) (* 1575 tf4 tf2))) + (latitude (+ phif + (* x2frac x2poly x x) + (* x4frac x4poly (expt x 4)) + (* x6frac x6poly (expt x 6)) + (* x8frac x8poly (expt x 8)))) + (longitude (+ lambda0 + (* x1frac x) + (* x3frac x3poly (expt x 3)) + (* x5frac x5poly (expt x 5)) + (* x7frac x7poly (expt x 7))))) + (list latitude longitude))) + +(defun lat-lon-to-utm-x-y (lat lon &optional (zone 50)) + ;; The Javascript version claims that the zone is calculated if not + ;; provided, but I could not find the code that does it. This + ;; should be added. This version of the code requires that the + ;; correct zone is provided. + (destructuring-bind (easting northing) + (MapLatLonToXY (DegToRad lat) (DegToRad lon) (UTMCentralMeridian zone)) + (list (+ (* easting UTMScaleFactor) 500000) + (+ (* northing UTMScaleFactor) + (if (minusp northing) 10000000 0)) + zone))) + +(defun utm-x-y-to-lat-lon (x y zone southhemi) + (destructuring-bind (lat lon) + (MapXYToLatLon (/ (- x 500000) UTMScaleFactor) + (/ (- y (if southhemi 10000000 0)) UTMScaleFactor) + (UTMCentralMeridian zone)) + (list (RadToDeg lat) (RadToDeg lon)))) \ No newline at end of file Added: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/m2/geometry.lisp Mon Jan 21 06:10:27 2008 @@ -0,0 +1,19 @@ + +(in-package :geometry) + +(defun point-in-polygon-p (x y polygon) + (let (result + (py y)) + (loop with (pjx . pjy) = (aref polygon (1- (length polygon))) + for (pix . piy) across polygon + when (and (or (and (<= piy py) (< py pjy)) + (and (<= pjy py) (< py piy))) + (< x + (+ (/ (* (- pjx pix) (- py piy)) + (- pjy piy)) + pix))) + do (setf result (not result)) + do (setf pjx pix + pjy piy)) + result)) + Modified: branches/bos/projects/bos/m2/map.lisp ============================================================================== --- branches/bos/projects/bos/m2/map.lisp (original) +++ branches/bos/projects/bos/m2/map.lisp Mon Jan 21 06:10:27 2008 @@ -60,22 +60,6 @@ ;;;; kann, sie ist jedoch makrobasiert und nicht flexibel - Sie ;;;; erlaubt ausschlie�lich das Iterieren �ber ein Image. -(defun point-in-polygon-p (x y polygon) - (let (result - (py y)) - (loop with (pjx . pjy) = (aref polygon (1- (length polygon))) - for (pix . piy) across polygon - when (and (or (and (<= piy py) (< py pjy)) - (and (<= pjy py) (< py piy))) - (< x - (+ (/ (* (- pjx pix) (- py piy)) - (- pjy piy)) - pix))) - do (setf result (not result)) - do (setf pjx pix - pjy piy)) - result)) - (defun colorize-pixel (pixel-rgb-value color-red color-green color-blue) "Colorize the given PIXEL-RGB-VALUE in the COLOR given. PIXEL-RGB-VALUE is a raw truecolor pixel with RGB components. COLOR Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Mon Jan 21 06:10:27 2008 @@ -1,5 +1,14 @@ (in-package :cl-user) +(defpackage :geometry + (:use :cl) + (:export #:point-in-polygon-p)) + +(defpackage :geo-utm + (:use :cl) + (:export #:lat-lon-to-utm-x-y + #:utm-x-y-to-lat-lon)) + (defpackage :bos.m2.config (:export #:+width+ #:+nw-utm-x+ @@ -27,6 +36,7 @@ (:use :cl :cl-ppcre :cl-interpol + :geometry :bknr.utils :bknr.indices :bknr.datastore @@ -211,12 +221,9 @@ (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:export #:cert-daemon)) -;;; maybe there is a nicer way to do this -;;; if you want to test this run ./build.sh at least twice ! -(intern "POINT-IN-POLYGON-P" :bos.m2) - (defpackage :bos.m2.allocation-cache - (:use :cl + (:use :cl + :geometry :bknr.indices :bknr.datastore :bknr.user @@ -227,10 +234,10 @@ :bos.m2.config :iterate :arnesi) - (:import-from :bos.m2 bos.m2::point-in-polygon-p) (:export #:find-exact-match #:add-area #:free-regions-count #:free-regions-pprint #:rebuild-cache #:allocation-cache-subsystem)) +

1 0

[bknr-cvs] r2370 - in branches/bos: bknr/src projects/bos/payment-website/static projects/bos/web
by hhubner＠common-lisp.net 20 Jan '08

20 Jan '08

Author: hhubner Date: Sun Jan 20 02:53:23 2008 New Revision: 2370 Added: branches/bos/projects/bos/payment-website/static/geoutm.js Modified: branches/bos/bknr/src/packages.lisp branches/bos/projects/bos/web/webserver.lisp Log: Add tool to convert between UTM and lat/lon. Fix template handler hack so that it works with language neutral templates which are placed in the top-level templated directory. Modified: branches/bos/bknr/src/packages.lisp ============================================================================== --- branches/bos/bknr/src/packages.lisp (original) +++ branches/bos/bknr/src/packages.lisp Sun Jan 20 02:53:23 2008 @@ -315,6 +315,7 @@ #:object-handler #:edit-object-handler #:template-handler + #:template-handler-destination #:page-handler #:page-handler-prefix #:page-handler-site Added: branches/bos/projects/bos/payment-website/static/geoutm.js ============================================================================== --- (empty file) +++ branches/bos/projects/bos/payment-website/static/geoutm.js Sun Jan 20 02:53:23 2008 @@ -0,0 +1,555 @@ +// Copyright 1997-1998 by Charles L. Taylor + +// Origin: http://home.hiwaay.net/~taylorc/toolbox/geography/geoutm.html +// Page says: + +// <P>Programmers: The JavaScript source code in this document may be copied +// and reused without restriction.</P> + +var pi = 3.14159265358979; + +/* Ellipsoid model constants (actual values here are for WGS84) */ +var sm_a = 6378137.0; +var sm_b = 6356752.314; +var sm_EccSquared = 6.69437999013e-03; + +var UTMScaleFactor = 0.9996; + +/* + * DegToRad + * + * Converts degrees to radians. + * + */ +function DegToRad (deg) +{ + return (deg / 180.0 * pi); +} + +/* + * RadToDeg + * + * Converts radians to degrees. + * + */ +function RadToDeg (rad) +{ + return (rad / pi * 180.0); +} + +/* + * ArcLengthOfMeridian + * + * Computes the ellipsoidal distance from the equator to a point at a + * given latitude. + * + * Reference: Hoffmann-Wellenhof, B., Lichtenegger, H., and Collins, J., + * GPS: Theory and Practice, 3rd ed. New York: Springer-Verlag Wien, 1994. + * + * Inputs: + * phi - Latitude of the point, in radians. + * + * Globals: + * sm_a - Ellipsoid model major axis. + * sm_b - Ellipsoid model minor axis. + * + * Returns: + * The ellipsoidal distance of the point from the equator, in meters. + * + */ +function ArcLengthOfMeridian (phi) +{ + var alpha, beta, gamma, delta, epsilon, n; + var result; + + /* Precalculate n */ + n = (sm_a - sm_b) / (sm_a + sm_b); + + /* Precalculate alpha */ + alpha = ((sm_a + sm_b) / 2.0) + * (1.0 + (Math.pow (n, 2.0) / 4.0) + (Math.pow (n, 4.0) / 64.0)); + + /* Precalculate beta */ + beta = (-3.0 * n / 2.0) + (9.0 * Math.pow (n, 3.0) / 16.0) + + (-3.0 * Math.pow (n, 5.0) / 32.0); + + /* Precalculate gamma */ + gamma = (15.0 * Math.pow (n, 2.0) / 16.0) + + (-15.0 * Math.pow (n, 4.0) / 32.0); + + /* Precalculate delta */ + delta = (-35.0 * Math.pow (n, 3.0) / 48.0) + + (105.0 * Math.pow (n, 5.0) / 256.0); + + /* Precalculate epsilon */ + epsilon = (315.0 * Math.pow (n, 4.0) / 512.0); + + /* Now calculate the sum of the series and return */ + result = alpha + * (phi + (beta * Math.sin (2.0 * phi)) + + (gamma * Math.sin (4.0 * phi)) + + (delta * Math.sin (6.0 * phi)) + + (epsilon * Math.sin (8.0 * phi))); + + return result; +} + +/* + * UTMCentralMeridian + * + * Determines the central meridian for the given UTM zone. + * + * Inputs: + * zone - An integer value designating the UTM zone, range [1,60]. + * + * Returns: + * The central meridian for the given UTM zone, in radians, or zero + * if the UTM zone parameter is outside the range [1,60]. + * Range of the central meridian is the radian equivalent of [-177,+177]. + * + */ +function UTMCentralMeridian (zone) +{ + var cmeridian; + + cmeridian = DegToRad (-183.0 + (zone * 6.0)); + + return cmeridian; +} + +/* + * FootpointLatitude + * + * Computes the footpoint latitude for use in converting transverse + * Mercator coordinates to ellipsoidal coordinates. + * + * Reference: Hoffmann-Wellenhof, B., Lichtenegger, H., and Collins, J., + * GPS: Theory and Practice, 3rd ed. New York: Springer-Verlag Wien, 1994. + * + * Inputs: + * y - The UTM northing coordinate, in meters. + * + * Returns: + * The footpoint latitude, in radians. + * + */ + +function FootpointLatitude (y) +{ + var y_, alpha_, beta_, gamma_, delta_, epsilon_, n; + var result; + + /* Precalculate n (Eq. 10.18) */ + n = (sm_a - sm_b) / (sm_a + sm_b); + + /* Precalculate alpha_ (Eq. 10.22) */ + /* (Same as alpha in Eq. 10.17) */ + alpha_ = ((sm_a + sm_b) / 2.0) + * (1 + (Math.pow (n, 2.0) / 4) + (Math.pow (n, 4.0) / 64)); + + /* Precalculate y_ (Eq. 10.23) */ + y_ = y / alpha_; + + /* Precalculate beta_ (Eq. 10.22) */ + beta_ = (3.0 * n / 2.0) + (-27.0 * Math.pow (n, 3.0) / 32.0) + + (269.0 * Math.pow (n, 5.0) / 512.0); + + /* Precalculate gamma_ (Eq. 10.22) */ + gamma_ = (21.0 * Math.pow (n, 2.0) / 16.0) + + (-55.0 * Math.pow (n, 4.0) / 32.0); + + /* Precalculate delta_ (Eq. 10.22) */ + delta_ = (151.0 * Math.pow (n, 3.0) / 96.0) + + (-417.0 * Math.pow (n, 5.0) / 128.0); + + /* Precalculate epsilon_ (Eq. 10.22) */ + epsilon_ = (1097.0 * Math.pow (n, 4.0) / 512.0); + + /* Now calculate the sum of the series (Eq. 10.21) */ + result = y_ + (beta_ * Math.sin (2.0 * y_)) + + (gamma_ * Math.sin (4.0 * y_)) + + (delta_ * Math.sin (6.0 * y_)) + + (epsilon_ * Math.sin (8.0 * y_)); + + return result; +} + +/* + * MapLatLonToXY + * + * Converts a latitude/longitude pair to x and y coordinates in the + * Transverse Mercator projection. Note that Transverse Mercator is not + * the same as UTM; a scale factor is required to convert between them. + * + * Reference: Hoffmann-Wellenhof, B., Lichtenegger, H., and Collins, J., + * GPS: Theory and Practice, 3rd ed. New York: Springer-Verlag Wien, 1994. + * + * Inputs: + * phi - Latitude of the point, in radians. + * lambda - Longitude of the point, in radians. + * lambda0 - Longitude of the central meridian to be used, in radians. + * + * Outputs: + * xy - A 2-element array containing the x and y coordinates + * of the computed point. + * + * Returns: + * The function does not return a value. + * + */ +function MapLatLonToXY (phi, lambda, lambda0, xy) +{ + var N, nu2, ep2, t, t2, l; + var l3coef, l4coef, l5coef, l6coef, l7coef, l8coef; + var tmp; + + /* Precalculate ep2 */ + ep2 = (Math.pow (sm_a, 2.0) - Math.pow (sm_b, 2.0)) / Math.pow (sm_b, 2.0); + + /* Precalculate nu2 */ + nu2 = ep2 * Math.pow (Math.cos (phi), 2.0); + + /* Precalculate N */ + N = Math.pow (sm_a, 2.0) / (sm_b * Math.sqrt (1 + nu2)); + + /* Precalculate t */ + t = Math.tan (phi); + t2 = t * t; + tmp = (t2 * t2 * t2) - Math.pow (t, 6.0); + + /* Precalculate l */ + l = lambda - lambda0; + + /* Precalculate coefficients for l**n in the equations below + so a normal human being can read the expressions for easting + and northing + -- l**1 and l**2 have coefficients of 1.0 */ + l3coef = 1.0 - t2 + nu2; + + l4coef = 5.0 - t2 + 9 * nu2 + 4.0 * (nu2 * nu2); + + l5coef = 5.0 - 18.0 * t2 + (t2 * t2) + 14.0 * nu2 + - 58.0 * t2 * nu2; + + l6coef = 61.0 - 58.0 * t2 + (t2 * t2) + 270.0 * nu2 + - 330.0 * t2 * nu2; + + l7coef = 61.0 - 479.0 * t2 + 179.0 * (t2 * t2) - (t2 * t2 * t2); + + l8coef = 1385.0 - 3111.0 * t2 + 543.0 * (t2 * t2) - (t2 * t2 * t2); + + /* Calculate easting (x) */ + xy[0] = N * Math.cos (phi) * l + + (N / 6.0 * Math.pow (Math.cos (phi), 3.0) * l3coef * Math.pow (l, 3.0)) + + (N / 120.0 * Math.pow (Math.cos (phi), 5.0) * l5coef * Math.pow (l, 5.0)) + + (N / 5040.0 * Math.pow (Math.cos (phi), 7.0) * l7coef * Math.pow (l, 7.0)); + + /* Calculate northing (y) */ + xy[1] = ArcLengthOfMeridian (phi) + + (t / 2.0 * N * Math.pow (Math.cos (phi), 2.0) * Math.pow (l, 2.0)) + + (t / 24.0 * N * Math.pow (Math.cos (phi), 4.0) * l4coef * Math.pow (l, 4.0)) + + (t / 720.0 * N * Math.pow (Math.cos (phi), 6.0) * l6coef * Math.pow (l, 6.0)) + + (t / 40320.0 * N * Math.pow (Math.cos (phi), 8.0) * l8coef * Math.pow (l, 8.0)); + + return; +} + +/* + * MapXYToLatLon + * + * Converts x and y coordinates in the Transverse Mercator projection to + * a latitude/longitude pair. Note that Transverse Mercator is not + * the same as UTM; a scale factor is required to convert between them. + * + * Reference: Hoffmann-Wellenhof, B., Lichtenegger, H., and Collins, J., + * GPS: Theory and Practice, 3rd ed. New York: Springer-Verlag Wien, 1994. + * + * Inputs: + * x - The easting of the point, in meters. + * y - The northing of the point, in meters. + * lambda0 - Longitude of the central meridian to be used, in radians. + * + * Outputs: + * philambda - A 2-element containing the latitude and longitude + * in radians. + * + * Returns: + * The function does not return a value. + * + * Remarks: + * The local variables Nf, nuf2, tf, and tf2 serve the same purpose as + * N, nu2, t, and t2 in MapLatLonToXY, but they are computed with respect + * to the footpoint latitude phif. + * + * x1frac, x2frac, x2poly, x3poly, etc. are to enhance readability and + * to optimize computations. + * + */ + +function MapXYToLatLon (x, y, lambda0, philambda) +{ + var phif, Nf, Nfpow, nuf2, ep2, tf, tf2, tf4, cf; + var x1frac, x2frac, x3frac, x4frac, x5frac, x6frac, x7frac, x8frac; + var x2poly, x3poly, x4poly, x5poly, x6poly, x7poly, x8poly; + + /* Get the value of phif, the footpoint latitude. */ + phif = FootpointLatitude (y); + + /* Precalculate ep2 */ + ep2 = (Math.pow (sm_a, 2.0) - Math.pow (sm_b, 2.0)) + / Math.pow (sm_b, 2.0); + + /* Precalculate cos (phif) */ + cf = Math.cos (phif); + + /* Precalculate nuf2 */ + nuf2 = ep2 * Math.pow (cf, 2.0); + + /* Precalculate Nf and initialize Nfpow */ + Nf = Math.pow (sm_a, 2.0) / (sm_b * Math.sqrt (1 + nuf2)); + Nfpow = Nf; + + /* Precalculate tf */ + tf = Math.tan (phif); + tf2 = tf * tf; + tf4 = tf2 * tf2; + + /* Precalculate fractional coefficients for x**n in the equations + below to simplify the expressions for latitude and longitude. */ + x1frac = 1.0 / (Nfpow * cf); + + Nfpow *= Nf; /* now equals Nf**2) */ + x2frac = tf / (2.0 * Nfpow); + + Nfpow *= Nf; /* now equals Nf**3) */ + x3frac = 1.0 / (6.0 * Nfpow * cf); + + Nfpow *= Nf; /* now equals Nf**4) */ + x4frac = tf / (24.0 * Nfpow); + + Nfpow *= Nf; /* now equals Nf**5) */ + x5frac = 1.0 / (120.0 * Nfpow * cf); + + Nfpow *= Nf; /* now equals Nf**6) */ + x6frac = tf / (720.0 * Nfpow); + + Nfpow *= Nf; /* now equals Nf**7) */ + x7frac = 1.0 / (5040.0 * Nfpow * cf); + + Nfpow *= Nf; /* now equals Nf**8) */ + x8frac = tf / (40320.0 * Nfpow); + + /* Precalculate polynomial coefficients for x**n. + -- x**1 does not have a polynomial coefficient. */ + x2poly = -1.0 - nuf2; + + x3poly = -1.0 - 2 * tf2 - nuf2; + + x4poly = 5.0 + 3.0 * tf2 + 6.0 * nuf2 - 6.0 * tf2 * nuf2 + - 3.0 * (nuf2 *nuf2) - 9.0 * tf2 * (nuf2 * nuf2); + + x5poly = 5.0 + 28.0 * tf2 + 24.0 * tf4 + 6.0 * nuf2 + 8.0 * tf2 * nuf2; + + x6poly = -61.0 - 90.0 * tf2 - 45.0 * tf4 - 107.0 * nuf2 + + 162.0 * tf2 * nuf2; + + x7poly = -61.0 - 662.0 * tf2 - 1320.0 * tf4 - 720.0 * (tf4 * tf2); + + x8poly = 1385.0 + 3633.0 * tf2 + 4095.0 * tf4 + 1575 * (tf4 * tf2); + + /* Calculate latitude */ + philambda[0] = phif + x2frac * x2poly * (x * x) + + x4frac * x4poly * Math.pow (x, 4.0) + + x6frac * x6poly * Math.pow (x, 6.0) + + x8frac * x8poly * Math.pow (x, 8.0); + + /* Calculate longitude */ + philambda[1] = lambda0 + x1frac * x + + x3frac * x3poly * Math.pow (x, 3.0) + + x5frac * x5poly * Math.pow (x, 5.0) + + x7frac * x7poly * Math.pow (x, 7.0); + + return; +} + +/* + * LatLonToUTMXY + * + * Converts a latitude/longitude pair to x and y coordinates in the + * Universal Transverse Mercator projection. + * + * Inputs: + * lat - Latitude of the point, in radians. + * lon - Longitude of the point, in radians. + * zone - UTM zone to be used for calculating values for x and y. + * If zone is less than 1 or greater than 60, the routine + * will determine the appropriate zone from the value of lon. + * + * Outputs: + * xy - A 2-element array where the UTM x and y values will be stored. + * + * Returns: + * The UTM zone used for calculating the values of x and y. + * + */ +function LatLonToUTMXY (lat, lon, zone, xy) +{ + MapLatLonToXY (lat, lon, UTMCentralMeridian (zone), xy); + + /* Adjust easting and northing for UTM system. */ + xy[0] = xy[0] * UTMScaleFactor + 500000.0; + xy[1] = xy[1] * UTMScaleFactor; + if (xy[1] < 0.0) + xy[1] = xy[1] + 10000000.0; + + return zone; +} + +/* + * UTMXYToLatLon + * + * Converts x and y coordinates in the Universal Transverse Mercator + * projection to a latitude/longitude pair. + * + * Inputs: + * x - The easting of the point, in meters. + * y - The northing of the point, in meters. + * zone - The UTM zone in which the point lies. + * southhemi - True if the point is in the southern hemisphere; + * false otherwise. + * + * Outputs: + * latlon - A 2-element array containing the latitude and + * longitude of the point, in radians. + * + * Returns: + * The function does not return a value. + * + */ +function UTMXYToLatLon (x, y, zone, southhemi, latlon) +{ + var cmeridian; + + x -= 500000.0; + x /= UTMScaleFactor; + + /* If in southern hemisphere, adjust y accordingly. */ + if (southhemi) + y -= 10000000.0; + + y /= UTMScaleFactor; + + cmeridian = UTMCentralMeridian (zone); + MapXYToLatLon (x, y, cmeridian, latlon); + + return; +} + +/* + * btnToUTM_OnClick + * + * Called when the btnToUTM button is clicked. + * + */ + +function btnToUTM_OnClick () +{ + var xy = new Array(2); + + if (isNaN (parseFloat (document.frmConverter.txtLongitude.value))) { + alert ("Please enter a valid longitude in the lon field."); + return false; + } + + lon = parseFloat (document.frmConverter.txtLongitude.value); + + if ((lon < -180.0) || (180.0 <= lon)) { + alert ("The longitude you entered is out of range. " + + "Please enter a number in the range [-180, 180)."); + return false; + } + + if (isNaN (parseFloat (document.frmConverter.txtLatitude.value))) { + alert ("Please enter a valid latitude in the lat field."); + return false; + } + + lat = parseFloat (document.frmConverter.txtLatitude.value); + + if ((lat < -90.0) || (90.0 < lat)) { + alert ("The latitude you entered is out of range. " + + "Please enter a number in the range [-90, 90]."); + return false; + } + + // Compute the UTM zone. + zone = Math.floor ((lon + 180.0) / 6) + 1; + + zone = LatLonToUTMXY (DegToRad (lat), DegToRad (lon), zone, xy); + + /* Set the output controls. */ + document.frmConverter.txtX.value = xy[0]; + document.frmConverter.txtY.value = xy[1]; + document.frmConverter.txtZone.value = zone; + if (lat < 0) + // Set the S button. + document.frmConverter.rbtnHemisphere[1].checked = true; + else + // Set the N button. + document.frmConverter.rbtnHemisphere[0].checked = true; + + + return true; +} + +/* + * btnToGeographic_OnClick + * + * Called when the btnToGeographic button is clicked. + * + */ + +function btnToGeographic_OnClick () +{ + latlon = new Array(2); + var x, y, zone, southhemi; + + if (isNaN (parseFloat (document.frmConverter.txtX.value))) { + alert ("Please enter a valid easting in the x field."); + return false; + } + + x = parseFloat (document.frmConverter.txtX.value); + + if (isNaN (parseFloat (document.frmConverter.txtY.value))) { + alert ("Please enter a valid northing in the y field."); + return false; + } + + y = parseFloat (document.frmConverter.txtY.value); + + if (isNaN (parseInt (document.frmConverter.txtZone.value))) { + alert ("Please enter a valid UTM zone in the zone field."); + return false; + } + + zone = parseFloat (document.frmConverter.txtZone.value); + + if ((zone < 1) || (60 < zone)) { + alert ("The UTM zone you entered is out of range. " + + "Please enter a number in the range [1, 60]."); + return false; + } + + if (document.frmConverter.rbtnHemisphere[1].checked == true) + southhemi = true; + else + southhemi = false; + + UTMXYToLatLon (x, y, zone, southhemi, latlon); + + document.frmConverter.txtLongitude.value = RadToDeg (latlon[1]); + document.frmConverter.txtLatitude.value = RadToDeg (latlon[0]); + + return true; +} Modified: branches/bos/projects/bos/web/webserver.lisp ============================================================================== --- branches/bos/projects/bos/web/webserver.lisp (original) +++ branches/bos/projects/bos/web/webserver.lisp Sun Jan 20 02:53:23 2008 @@ -24,7 +24,9 @@ (defmethod find-template-pathname ((handler worldpay-template-handler) template-name &key request) (cond - ((not (scan "/" template-name)) + ((and (not (scan "/" template-name)) + (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml") + (template-handler-destination handler))))) (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request) *default-language*) (if (equal "" template-name)

1 0

[bknr-cvs] r2369 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 19 Jan '08

19 Jan '08

Author: ksprotte Date: Sat Jan 19 06:57:38 2008 New Revision: 2369 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/allocation-test.lisp Log: added test allocation-area.one-contract.notany-m2-contract, which now also passes based on new function cache-entry-valid-p in allocation-cache.lisp Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Sat Jan 19 06:57:38 2008 @@ -119,16 +119,43 @@ (defstruct cache-entry area region) -(declaim (inline index-lookup index-pop index-push size-indexed-p)) -(defun index-lookup (n) +(defun cache-entry-valid-p (cache-entry) + (notany #'m2-contract (cache-entry-region cache-entry))) + +(declaim (inline %index-lookup %index-pop index-lookup index-pop index-push size-indexed-p)) +(defun %index-lookup (n) "Will return the first index cache-entry of size N or -nil if it does not exist." +nil if it does not exist. The entry is not validated!" (first (aref (allocation-cache-index *allocation-cache*) (1- n)))) +(defun %index-pop (n) + "As INDEX-LOOKUP, but will remove the cache-entry +from the index. The entry is not validated!" + (pop (aref (allocation-cache-index *allocation-cache*) (1- n)))) + +(defun index-ensure-valid-entry-for-n (n) + "Ensures that the next available entry (the next +one that would be popped) is valid. If not, the entry +is removed recursively until a valid entry is available +or no entries for N are left." + (awhen (%index-lookup n) + (if (cache-entry-valid-p it) + it + (progn + (%index-pop n) + (index-ensure-valid-entry-for-n n))))) + +(defun index-lookup (n) + "Will return the first valid cache-entry of size N or +nil if it does not exist." + (index-ensure-valid-entry-for-n n)) + (defun index-pop (n) "As INDEX-LOOKUP, but will remove the cache-entry from the index." - (pop (aref (allocation-cache-index *allocation-cache*) (1- n)))) + (awhen (index-lookup n) + (%index-pop n) + it)) (defun index-push (n cache-entry) "Add cache-entry (which has to be of size N) to index." Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Sat Jan 19 06:57:38 2008 @@ -37,4 +37,13 @@ (m2-count (* 100 100))) (finishes (make-contract sponsor m2-count)) (signals (error) (make-contract sponsor m2-count)) - (is (zerop (allocation-area-free-m2s area)))))) \ No newline at end of file + (is (zerop (allocation-area-free-m2s area)))))) + +(test allocation-area.one-contract.notany-m2-contract + (with-fixture empty-store () + (let ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor"))) + (finishes (make-contract sponsor 10)) + (is (= (- 64 10) (allocation-area-free-m2s area))) + (signals (error) (make-contract sponsor 64))))) +

1 0

[bknr-cvs] r2368 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 19 Jan '08

19 Jan '08

Author: hhubner Date: Sat Jan 19 04:55:29 2008 New Revision: 2368 Modified: branches/bos/projects/bos/web/config.lisp Log: Wrong GA account corrected Modified: branches/bos/projects/bos/web/config.lisp ============================================================================== --- branches/bos/projects/bos/web/config.lisp (original) +++ branches/bos/projects/bos/web/config.lisp Sat Jan 19 04:55:29 2008 @@ -8,7 +8,7 @@ (defparameter *worldpay-test-mode* t) ;; Account fuer Google Analytics -(defparameter *google-analytics-account* "UA-3432040-2") +(defparameter *google-analytics-account* "UA-3432041-1") ;; URL für BASE HREFs (defparameter *website-url* "http://create-rainforest.org")

1 0

[bknr-cvs] r2367 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 19 Jan '08

19 Jan '08

Author: hhubner Date: Sat Jan 19 04:41:54 2008 New Revision: 2367 Modified: branches/bos/projects/bos/web/webserver.lisp Log: Experiment to stop redirection on / - Instead, default the template pathname to the index page. This may screw up language detection, which used to work by parsing the URL. Modified: branches/bos/projects/bos/web/webserver.lisp ============================================================================== --- branches/bos/projects/bos/web/webserver.lisp (original) +++ branches/bos/projects/bos/web/webserver.lisp Sat Jan 19 04:41:54 2008 @@ -23,26 +23,32 @@ ;; and change the template name according to the outcome. (defmethod find-template-pathname ((handler worldpay-template-handler) template-name &key request) - (when (scan #?r"(^|.*/)handle-sale" template-name) - (with-query-params (request cartId name address country transStatus lang MC_gift) - (unless (website-supports-language lang) - (setf lang *default-language*)) - (bos.m2::remember-worldpay-params cartId (all-request-params request)) - (let ((contract (get-contract (parse-integer cartId)))) - (sponsor-set-language (contract-sponsor contract) lang) - (cond - ((not (typep contract 'contract)) - (user-error "Error: Invalid transaction ID.")) - ((contract-paidp contract) - (user-error "Error: Transaction already processed.")) - ((equal "C" transStatus) - (setf template-name #?"/$(lang)/sponsor_canceled")) - ((< (contract-price contract) *mail-certificate-threshold*) - (setf template-name #?"/$(lang)/quittung")) - (t - (when (<= *mail-fiscal-certificate-threshold* (contract-price contract)) - (mail-fiscal-certificate-to-office contract name address country)) - (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info"))))))) + (cond + ((not (scan "/" template-name)) + (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request) + *default-language*) + (if (equal "" template-name) + "index" template-name)))) + ((scan #?r"(^|.*/)handle-sale" template-name) + (with-query-params (request cartId name address country transStatus lang MC_gift) + (unless (website-supports-language lang) + (setf lang *default-language*)) + (bos.m2::remember-worldpay-params cartId (all-request-params request)) + (let ((contract (get-contract (parse-integer cartId)))) + (sponsor-set-language (contract-sponsor contract) lang) + (cond + ((not (typep contract 'contract)) + (user-error "Error: Invalid transaction ID.")) + ((contract-paidp contract) + (user-error "Error: Transaction already processed.")) + ((equal "C" transStatus) + (setf template-name #?"/$(lang)/sponsor_canceled")) + ((< (contract-price contract) *mail-certificate-threshold*) + (setf template-name #?"/$(lang)/quittung")) + (t + (when (<= *mail-fiscal-certificate-threshold* (contract-price contract)) + (mail-fiscal-certificate-to-office contract name address country)) + (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info")))))))) (call-next-method handler template-name)) (defmethod initial-template-environment ((expander worldpay-template-handler) req) @@ -215,6 +221,7 @@ ("/cancel-contract" cancel-contract-handler) ("/statistics" statistics-handler) ("/rss" rss-handler) + #+(or) ("/" redirect-handler :to "/index") ("/index" index-handler)

1 0

[bknr-cvs] r2366 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 19 Jan '08

19 Jan '08

Author: hhubner Date: Sat Jan 19 03:49:22 2008 New Revision: 2366 Modified: branches/bos/projects/bos/m2/allocation-test.lisp Log: Change allocation size in test so that it is always larger than the cache threshold. Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Sat Jan 19 03:49:22 2008 @@ -32,9 +32,9 @@ (test allocation-area.one-contract.allocate-all-without-cache (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 2 5)) + (let ((area (make-allocation-rectangle 0 0 100 100)) (sponsor (make-sponsor :login "test-sponsor")) - (m2-count 10)) + (m2-count (* 100 100))) (finishes (make-contract sponsor m2-count)) (signals (error) (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) \ No newline at end of file

1 0

[bknr-cvs] r2365 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 19 Jan '08

19 Jan '08

Author: hhubner Date: Sat Jan 19 03:41:47 2008 New Revision: 2365 Modified: branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/m2.lisp Log: Add test that verifies that the "old" allocation algorithm can allocate all sqms in an area at once. Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Sat Jan 19 03:41:47 2008 @@ -30,3 +30,11 @@ (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) +(test allocation-area.one-contract.allocate-all-without-cache + (with-fixture empty-store () + (let ((area (make-allocation-rectangle 0 0 2 5)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (finishes (make-contract sponsor m2-count)) + (signals (error) (make-contract sponsor m2-count)) + (is (zerop (allocation-area-free-m2s area)))))) \ No newline at end of file Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Sat Jan 19 03:41:47 2008 @@ -459,6 +459,7 @@ (when delete (delete-directory directory) (assert (not (probe-file directory)))) + (close-store) (make-instance 'm2-store :directory directory :subsystems (list (make-instance 'store-object-subsystem)

1 0

[bknr-cvs] r2364 - in branches/bos/projects/bos: m2 test
by hhubner＠common-lisp.net 19 Jan '08

19 Jan '08

Author: hhubner Date: Sat Jan 19 03:34:09 2008 New Revision: 2364 Added: branches/bos/projects/bos/m2/allocation-cache-test.lisp - copied unchanged from r2363, branches/bos/projects/bos/test/allocation-cache.lisp branches/bos/projects/bos/m2/allocation-test.lisp - copied unchanged from r2363, branches/bos/projects/bos/test/allocation-area.lisp branches/bos/projects/bos/m2/bos.test.asd - copied, changed from r2363, branches/bos/projects/bos/test/bos.test.asd branches/bos/projects/bos/m2/packages-test.lisp branches/bos/projects/bos/m2/test-fixtures.lisp - copied unchanged from r2363, branches/bos/projects/bos/test/fixtures.lisp branches/bos/projects/bos/m2/test-suites.lisp - copied unchanged from r2363, branches/bos/projects/bos/test/suites.lisp Removed: branches/bos/projects/bos/test/ Modified: branches/bos/projects/bos/m2/packages.lisp Log: Move tests into m2/ directory, performing the neccessary renames. Copied: branches/bos/projects/bos/m2/bos.test.asd (from r2363, branches/bos/projects/bos/test/bos.test.asd) ============================================================================== --- branches/bos/projects/bos/test/bos.test.asd (original) +++ branches/bos/projects/bos/m2/bos.test.asd Sat Jan 19 03:34:09 2008 @@ -3,10 +3,10 @@ (asdf:defsystem :bos.test :description "BOS Online-System test-suite" :depends-on (:bos.web :fiveam) - :components ((:file "packages") - (:file "suites" :depends-on ("packages")) - (:file "fixtures" :depends-on ("packages")) - (:file "allocation-area" :depends-on ("suites" "fixtures")) - (:file "allocation-cache" :depends-on ("suites" "fixtures")) + :components ((:file "packages-test") + (:file "test-suites" :depends-on ("packages-test")) + (:file "test-fixtures" :depends-on ("packages-test")) + (:file "allocation-test" :depends-on ("test-suites" "test-fixtures")) + (:file "allocation-cache-test" :depends-on ("test-suites" "test-fixtures")) ;; (:file "utils" :depends-on ("config")) )) Added: branches/bos/projects/bos/m2/packages-test.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/m2/packages-test.lisp Sat Jan 19 03:34:09 2008 @@ -0,0 +1,20 @@ + +(defpackage :bos.test + (:use :cl + :fiveam + :iterate + ;; maybe later + ;; :cl-ppcre + ;; :cl-interpol + :bknr.utils + :bknr.indices + :bknr.datastore + :bknr.user + :bknr.web + :bknr.images + :bknr.statistics + :bknr.rss + :bos.m2 + :bos.m2.config + )) + Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Sat Jan 19 03:34:09 2008 @@ -234,4 +234,3 @@ #:free-regions-pprint #:rebuild-cache #:allocation-cache-subsystem)) -

1 0

[bknr-cvs] r2363 - branches/bos-ksprotte
by ksprotte＠common-lisp.net 18 Jan '08

18 Jan '08

Author: ksprotte Date: Fri Jan 18 14:36:53 2008 New Revision: 2363 Removed: branches/bos-ksprotte/ Log: dont need this bos-ksprotte branch right now ...

1 0

[bknr-cvs] r2362 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 18 Jan '08

18 Jan '08

Author: ksprotte Date: Fri Jan 18 13:50:57 2008 New Revision: 2362 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/bos.m2.asd branches/bos/projects/bos/m2/packages.lisp Log: using awhen from arnesi for allocation cache Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Fri Jan 18 13:50:57 2008 @@ -78,7 +78,7 @@ (setf (aref array next-x next-y) nil)) (do-neighbour-coordinates next-x next-y (x y) (when (and (in-array-bounds-p array x y) - (free-spot-p array x y)) + (free-spot-p array x y)) (collect (aref array x y)) (setf (aref array x y) nil) (point-stack-push x y stack))))) @@ -148,15 +148,12 @@ is decremented." (cond ((not (size-indexed-p n)) nil) - (remove (let ((cache-entry (index-pop n))) - (when cache-entry - (with-slots (area region) - cache-entry - (decf (allocation-area-free-m2s area) n) - region)))) - (t (let ((cache-entry (index-lookup n))) - (when cache-entry - (cache-entry-region cache-entry)))))) + (remove (awhen (index-pop n) + (with-slots (area region) it + (decf (allocation-area-free-m2s area) n) + region))) + (t (awhen (index-lookup n) + (cache-entry-region it))))) (defun add-area (allocation-area) (dolist (region (free-regions allocation-area) @@ -176,7 +173,7 @@ (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) (for size upfrom 1) - (for region-count = (length regions)) + (for region-count = (length regions)) (unless (zerop region-count) (format t "~a~10T~a~%" size region-count))) (format t "area size ignored by cache: ~a~%" (ignored-size *allocation-cache*))) @@ -191,7 +188,7 @@ (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) (for size upfrom 1) - (for region-count = (length regions)) + (for region-count = (length regions)) (unless (zerop region-count) (leave size)))) @@ -199,7 +196,7 @@ (defclass allocation-cache-subsystem () ()) -(defmethod bknr.datastore::restore-subsystem (store (subsystem allocation-cache-subsystem) &key until) +(defmethod bknr.datastore::restore-subsystem + (store (subsystem allocation-cache-subsystem) &key until) (declare (ignore until)) (rebuild-cache)) - Modified: branches/bos/projects/bos/m2/bos.m2.asd ============================================================================== --- branches/bos/projects/bos/m2/bos.m2.asd (original) +++ branches/bos/projects/bos/m2/bos.m2.asd Fri Jan 18 13:50:57 2008 @@ -1,7 +1,7 @@ (in-package :cl-user) (asdf:defsystem :bos.m2 - :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate) + :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate :arnesi) :components ((:file "packages") (:file "config" :depends-on ("packages")) (:file "utils" :depends-on ("config")) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Fri Jan 18 13:50:57 2008 @@ -216,12 +216,10 @@ (intern "POINT-IN-POLYGON-P" :bos.m2) (defpackage :bos.m2.allocation-cache - (:use :cl - :bknr.utils + (:use :cl :bknr.indices :bknr.datastore - :bknr.user - :bknr.web + :bknr.user :bknr.images :bknr.statistics :bknr.rss

1 0

[bknr-cvs] r2361 - in branches/bos/projects/bos: m2 test
by ksprotte＠common-lisp.net 18 Jan '08

18 Jan '08

Author: ksprotte Date: Fri Jan 18 13:25:24 2008 New Revision: 2361 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/test/allocation-area.lisp Log: all tests pass!! Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Fri Jan 18 13:25:24 2008 @@ -104,6 +104,8 @@ (in top (collect region))))))) ;;; allocation-cache +(defvar *allocation-cache*) + (defconstant +threshold+ 200 "Free regions of size N where (<= 1 N +threshold+) are indexed.") @@ -114,22 +116,23 @@ (defun make-allocation-cache () (make-instance 'allocation-cache)) -(defvar *allocation-cache*) +(defstruct cache-entry + area region) (declaim (inline index-lookup index-pop index-push size-indexed-p)) (defun index-lookup (n) - "Will return the first index region of size N or + "Will return the first index cache-entry of size N or nil if it does not exist." (first (aref (allocation-cache-index *allocation-cache*) (1- n)))) (defun index-pop (n) - "As INDEX-LOOKUP, but will remove the region + "As INDEX-LOOKUP, but will remove the cache-entry from the index." (pop (aref (allocation-cache-index *allocation-cache*) (1- n)))) -(defun index-push (n region) - "Add region (which has to be of size N) to index." - (push region (aref (allocation-cache-index *allocation-cache*) (1- n)))) +(defun index-push (n cache-entry) + "Add cache-entry (which has to be of size N) to index." + (push cache-entry (aref (allocation-cache-index *allocation-cache*) (1- n)))) (defun size-indexed-p (n) "Are regions of size N indexed?" @@ -141,18 +144,27 @@ matching N can be found, simply returns NIL. If REMOVE is T then the returned region is removed from -the cache." +the cache and FREE-M2S of the affected allocation-area +is decremented." (cond ((not (size-indexed-p n)) nil) - (remove (index-pop n)) - (t (index-lookup n)))) + (remove (let ((cache-entry (index-pop n))) + (when cache-entry + (with-slots (area region) + cache-entry + (decf (allocation-area-free-m2s area) n) + region)))) + (t (let ((cache-entry (index-lookup n))) + (when cache-entry + (cache-entry-region cache-entry)))))) (defun add-area (allocation-area) (dolist (region (free-regions allocation-area) allocation-area) (let ((size (length region))) (if (size-indexed-p size) - (index-push size region) + (index-push size (make-cache-entry :area allocation-area + :region region)) (incf (ignored-size *allocation-cache*) size))))) (defun free-regions-count () Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Fri Jan 18 13:25:24 2008 @@ -227,7 +227,8 @@ :bknr.rss :bos.m2 :bos.m2.config - :iterate) + :iterate + :arnesi) (:import-from :bos.m2 bos.m2::point-in-polygon-p) (:export #:find-exact-match #:add-area Modified: branches/bos/projects/bos/test/allocation-area.lisp ============================================================================== --- branches/bos/projects/bos/test/allocation-area.lisp (original) +++ branches/bos/projects/bos/test/allocation-area.lisp Fri Jan 18 13:25:24 2008 @@ -18,11 +18,15 @@ (finishes (make-contract sponsor m2-count)) (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area)))))) -(test allocation-area.one-contract.with-cache +(test allocation-area.one-contract.with-cache.1 (with-fixture empty-store () (let ((area (make-allocation-rectangle 0 0 2 5)) (sponsor (make-sponsor :login "test-sponsor")) (m2-count 10)) + (with-transaction () + (bos.m2::activate-allocation-area area)) + (is (= 1 (bos.m2.allocation-cache:free-regions-count))) + (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area))))))

1 0

[bknr-cvs] r2360 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 18 Jan '08

18 Jan '08

Author: ksprotte Date: Fri Jan 18 12:43:06 2008 New Revision: 2360 Modified: branches/bos/projects/bos/m2/allocation.lisp Log: issue rebuild-cache on de- / activate-allocation-area Modified: branches/bos/projects/bos/m2/allocation.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation.lisp (original) +++ branches/bos/projects/bos/m2/allocation.lisp Fri Jan 18 12:43:06 2008 @@ -184,11 +184,13 @@ (defun activate-allocation-area (area) (warn "activating ~S" area) (setf (slot-value area 'active-p) t) + (bos.m2.allocation-cache:rebuild-cache) area) (defun deactivate-allocation-area (area) (warn "deactivating ~S" area) (setf (slot-value area 'active-p) nil) + (bos.m2.allocation-cache:rebuild-cache) area) (defun map-edges (fn vertices)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs January 2008