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

[bknr-cvs] hans changed trunk/thirdparty/cl-unicode/build/read.lisp
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3670 Author: hans URL: http://bknr.net/trac/changeset/3670 correct typo in special variable name U trunk/thirdparty/cl-unicode/build/read.lisp Modified: trunk/thirdparty/cl-unicode/build/read.lisp =================================================================== --- trunk/thirdparty/cl-unicode/build/read.lisp 2008-07-29 07:32:15 UTC (rev 3669) +++ trunk/thirdparty/cl-unicode/build/read.lisp 2008-07-29 07:35:26 UTC (rev 3670) @@ -275,7 +275,7 @@ data files and building the corresponding Lisp datastructures in memory." (fill-database) - (when *compile-verbose + (when *compile-verbose* (format t "~&;;; Building hash tables") (force-output)) (build-name-mappings)

1 0

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

29 Jul '08

Revision: 3669 Author: hans URL: http://bknr.net/trac/changeset/3669 Print progress diagnostics only when *compile-verbose* is set. U trunk/thirdparty/cl-unicode/build/dump.lisp U trunk/thirdparty/cl-unicode/build/read.lisp U trunk/thirdparty/cl-unicode/util.lisp Modified: trunk/thirdparty/cl-unicode/build/dump.lisp =================================================================== --- trunk/thirdparty/cl-unicode/build/dump.lisp 2008-07-28 19:11:30 UTC (rev 3668) +++ trunk/thirdparty/cl-unicode/build/dump.lisp 2008-07-29 07:32:15 UTC (rev 3669) @@ -106,8 +106,9 @@ location of this source file. Writes a Lisp header to the files unless NO-HEADER-P is true." `(let ((pathname (merge-pathnames ,relative-path *this-file*))) - (format t "~&;;; Writing source file ~A" (file-namestring pathname)) - (force-output) + (when *compile-verbose* + (format t "~&;;; Writing source file ~A" (file-namestring pathname)) + (force-output)) (with-open-file (,stream pathname :direction :output :if-exists :supersede) Modified: trunk/thirdparty/cl-unicode/build/read.lisp =================================================================== --- trunk/thirdparty/cl-unicode/build/read.lisp 2008-07-28 19:11:30 UTC (rev 3668) +++ trunk/thirdparty/cl-unicode/build/read.lisp 2008-07-29 07:32:15 UTC (rev 3669) @@ -43,8 +43,9 @@ (let ((variables (extract-variables bindings)) (types (extract-types bindings))) `(let ((pathname (merge-pathnames ,file-name (merge-pathnames "data/" *this-file*)))) - (format t "~&;;; Parsing Unicode file ~A" (file-namestring pathname)) - (force-output) + (when *compile-verbose* + (format t "~&;;; Parsing Unicode file ~A" (file-namestring pathname)) + (force-output)) (with-open-file (binary-in pathname :element-type 'flex:octet) ;; Unicode data files must be read as UTF-8 (let ((in (flex:make-flexi-stream binary-in :external-format '(:utf-8 :eol-style :lf)))) @@ -274,7 +275,8 @@ data files and building the corresponding Lisp datastructures in memory." (fill-database) - (format t "~&;;; Building hash tables") - (force-output) + (when *compile-verbose + (format t "~&;;; Building hash tables") + (force-output)) (build-name-mappings) (build-case-mapping)) Modified: trunk/thirdparty/cl-unicode/util.lisp =================================================================== --- trunk/thirdparty/cl-unicode/util.lisp 2008-07-28 19:11:30 UTC (rev 3668) +++ trunk/thirdparty/cl-unicode/util.lisp 2008-07-29 07:32:15 UTC (rev 3669) @@ -215,7 +215,9 @@ the *HANGUL-SYLLABLES-TO-CODE-POINTS* hash table. Used for CHARACTER-NAMED." (declare #.*standard-optimize-settings*) - (format t "~&;;; Computing Hangul syllable names") + (when *compile-verbose* + (format t "~&;;; Computing Hangul syllable names") + (force-output)) (loop for code-point from +first-hangul-syllable+ to +last-hangul-syllable+ for name = (compute-hangul-name code-point) do (setf (gethash name *hangul-syllables-to-code-points*) code-point)))

1 0

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

28 Jul '08

Revision: 3668 Author: ksprotte URL: http://bknr.net/trac/changeset/3668 project bos does not cause a single compilation warning U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/web/bos.web.asd Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-07-28 19:09:03 UTC (rev 3667) +++ trunk/projects/bos/m2/bos.m2.asd 2008-07-28 19:11:30 UTC (rev 3668) @@ -8,28 +8,24 @@ :cl-pdf :screamer :cl-fad) :components ((:file "packages") (:file "geo-utm" :depends-on ("packages")) - (:file "geometry" :depends-on ("packages" "m2-store")) + (: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 "utils" :depends-on ("packages")) + (:file "news" :depends-on ("packages" "poi")) + (:file "tiled-index" :depends-on ("packages")) + (:file "mail-generator" :depends-on ("packages")) + (:file "make-certificate" :depends-on ("packages")) (:file "initialization-subsystem" :depends-on ("packages")) - (:file "m2-store" :depends-on ("packages" "utils")) - (:file "m2" :depends-on ("initialization-subsystem" - "tiled-index" - "utils" - "make-certificate" - "mail-generator" - "geo-utm" - "geometry")) - (:file "m2-pdf" :depends-on ("m2")) - (:file "contract-expiry" :depends-on ("m2")) - (:file "allocation" :depends-on ("m2")) - (:file "allocation-cache" :depends-on ("packages" "geometry")) - (:file "poi" :depends-on ("utils" "allocation")) - (:file "import" :depends-on ("m2")) - (:file "map" :depends-on ("m2" "allocation" "geometry")) - (:file "export" :depends-on ("m2")) - (:file "cert-daemon" :depends-on ("config")))) + (:file "m2-store" :depends-on ("packages")) + (:file "m2" :depends-on ("config" "geometry" "initialization-subsystem" + "packages" "tiled-index" "utils")) + (:file "m2-pdf" :depends-on ("packages")) + (:file "contract-expiry" :depends-on ("packages")) + (:file "allocation" :depends-on ("geometry" "packages")) + (:file "allocation-cache" :depends-on ("allocation" "initialization-subsystem" + "packages" "utils")) + (:file "poi" :depends-on ("packages")) + (:file "import" :depends-on ("packages")) + (:file "map" :depends-on ("config" "packages" "tiled-index")) + (:file "export" :depends-on ("packages")) + (:file "cert-daemon" :depends-on ("packages")))) Modified: trunk/projects/bos/web/bos.web.asd =================================================================== --- trunk/projects/bos/web/bos.web.asd 2008-07-28 19:09:03 UTC (rev 3667) +++ trunk/projects/bos/web/bos.web.asd 2008-07-28 19:11:30 UTC (rev 3668) @@ -19,49 +19,36 @@ :depends-on (:bknr.web :bknr.modules :bos.m2 :cxml) :components ((:file "packages") - (:file "utf-8" :depends-on ("packages")) - (:file "config" :depends-on ("packages")) - (:file "dictionary" :depends-on ("packages" #+nil "startup")) - (:file "web-macros" :depends-on ("config")) - (:file "web-utils" :depends-on ("web-macros")) - (:file "cms-links" :depends-on ("web-utils")) - (:file "map-handlers" :depends-on ("web-utils")) - (:file "map-browser-handler" :depends-on ("web-utils")) - (:file "poi-handlers" :depends-on ("web-utils" "dictionary")) - (:file "boi-handlers" :depends-on ("web-utils")) - (:file "contract-handlers" :depends-on ("web-utils")) - (:file "contract-image-handler" :depends-on ("web-utils")) - (:file "reports-xml-handler" :depends-on ("boi-handlers")) - (:file "kml-utils" :depends-on ("packages")) + (:file "utf-8" :depends-on ("packages")) + (:file "config" :depends-on ("packages")) + (:file "dictionary" :depends-on ("packages" "startup")) + (:file "web-macros" :depends-on ("packages")) + (:file "web-utils" :depends-on ("packages")) + (:file "cms-links" :depends-on ("packages")) + (:file "map-handlers" :depends-on ("packages" "web-macros")) + (:file "map-browser-handler" :depends-on ("packages" "web-macros")) + (:file "poi-handlers" :depends-on ("dictionary" "packages" "web-macros")) + (:file "boi-handlers" :depends-on ("packages" "web-macros")) + (:file "contract-handlers" :depends-on ("packages" "web-macros")) + (:file "contract-image-handler" :depends-on ("packages")) + (:file "reports-xml-handler" :depends-on ("packages")) + (:file "kml-utils" :depends-on ("packages")) (:file "quad-tree" :depends-on ("packages")) - (:file "contract-tree" :depends-on ("quad-tree")) - (:file "sat-tree" :depends-on ("quad-tree" "contract-tree")) + (:file "contract-tree" :depends-on ("packages" "quad-tree")) + (:file "sat-tree" :depends-on ("packages" "quad-tree")) (:file "countries" :depends-on ("packages")) (:file "website-language" :depends-on ("packages")) - (:file "kml-handlers" :depends-on ("packages" - "website-language" - "web-macros" - "countries" - "dictionary")) - (: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")) - (:file "news-rss" :depends-on ("web-utils")) - (:file "contract-rss" :depends-on ("web-utils")) - (:file "webserver" :depends-on ("news-tags" - "tags" - "website-language" - "map-handlers" - "map-browser-handler" - "poi-handlers" - "boi-handlers" - "contract-handlers" - "sponsor-handlers" - "news-handlers" - "allocation-area-handlers")) - (:file "daily" :depends-on ("config" "webserver")) - (:file "startup" :depends-on ("config" "webserver")))) + (:file "kml-handlers" :depends-on ("dictionary" "kml-utils" "packages" + "web-macros" "countries")) + (:file "sponsor-handlers" :depends-on ("packages" "web-macros")) + (:file "news-handlers" :depends-on ("packages" "web-macros")) + (:file "allocation-area-handlers" :depends-on ("packages" "web-macros")) + (:file "allocation-cache-handlers" :depends-on ("packages" "web-macros")) + (:file "languages-handler" :depends-on ("packages" "web-macros")) + (:file "tags" :depends-on ("packages")) + (:file "news-tags" :depends-on ("packages")) + (:file "news-rss" :depends-on ("packages")) + (:file "contract-rss" :depends-on ("packages")) + (:file "webserver" :depends-on ("packages" "web-macros")) + (:file "daily" :depends-on ("packages")) + (:file "startup" :depends-on ("packages"))))

1 0

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

28 Jul '08

Revision: 3667 Author: ksprotte URL: http://bknr.net/trac/changeset/3667 removed allocation-area-gfx-handler (not needed anymore and causing a warning due to undefined function make-vga-colors) U trunk/projects/bos/web/allocation-area-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/allocation-area-handlers.lisp =================================================================== --- trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-28 18:33:35 UTC (rev 3666) +++ trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-28 19:09:03 UTC (rev 3667) @@ -95,51 +95,6 @@ (with-bos-cms-page (:title "Allocation area has been deactivated") (:h2 "The allocation area has been deactivated"))) -(defclass allocation-area-gfx-handler (editor-only-handler object-handler) - ()) - -(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area) - (cl-gd:with-image* ((allocation-area-width allocation-area) - (allocation-area-height allocation-area) t) - (with-slots (left top width height) allocation-area - (let ((colors (make-vga-colors)) - (vertices (mapcan #'(lambda (point) (list (- (car point) left) - (- (cdr point) top))) - (coerce (allocation-area-vertices allocation-area) 'list)))) - (loop with dest-y = 0 - for y = (+ top dest-y) - for tile-y = (* 90 (floor y 90)) - until (> tile-y (+ top height)) - for copy-height = (cond - ((< tile-y top) - (+ 90 (- tile-y top))) - ((> (+ tile-y 90) (+ top height)) - (- (+ tile-y 90) (+ top height))) - (t - 90)) - for source-y = (if (< tile-y top) (- 90 copy-height) 0) - do (loop with dest-x = 0 - for x = (+ left dest-x) - for tile-x = (* 90 (floor x 90)) - until (> tile-x (+ left width)) - for copy-width = (cond - ((< tile-x left) - (+ 90 (- tile-x left))) - ((> (+ tile-x 90) (+ left width)) - (- (+ tile-x 90) (+ left width))) - (t - 90)) - for source-x = (if (< tile-x left) (- 90 copy-width) 0) - do (cl-gd:copy-image (image-tile-image (get-map-tile x y)) - cl-gd:*default-image* - source-x source-y - dest-x dest-y - copy-width copy-height) - do (incf dest-x copy-width)) - do (incf dest-y copy-height)) - (cl-gd:draw-polygon vertices :color (elt colors 1)) - (emit-image-to-browser cl-gd:*default-image* :png))))) - (defclass create-allocation-area-handler (admin-only-handler form-handler) ()) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-28 18:33:35 UTC (rev 3666) +++ trunk/projects/bos/web/webserver.lisp 2008-07-28 19:09:03 UTC (rev 3667) @@ -184,7 +184,6 @@ ("/m2-javascript" m2-javascript-handler) ("/sponsor-login" sponsor-login-handler) ("/create-allocation-area" create-allocation-area-handler) - ("/allocation-area-gfx" allocation-area-gfx-handler) ("/allocation-area" allocation-area-handler) ("/allocation-cache" allocation-cache-handler) ("/certificate" certificate-handler)

1 0

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

28 Jul '08

Revision: 3666 Author: ksprotte URL: http://bknr.net/trac/changeset/3666 some fixes to bos to avoid compilation warnings U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/web/bos.web.asd U trunk/projects/bos/web/quad-tree.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-28 15:14:31 UTC (rev 3665) +++ trunk/projects/bos/m2/m2.lisp 2008-07-28 18:33:35 UTC (rev 3666) @@ -377,7 +377,7 @@ (dolist (m2 (contract-m2s contract)) (collect (list (m2-x m2) (m2-y m2)))))) -(defun contracts-bounding-box (&optional (contracts (all-contracts))) +(defun contracts-bounding-box (&optional (contracts (class-instances 'contract))) (geometry:with-bounding-box-collect (collect) (dolist (contract contracts) (dolist (m2 (contract-m2s contract)) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-28 15:14:31 UTC (rev 3665) +++ trunk/projects/bos/m2/packages.lisp 2008-07-28 18:33:35 UTC (rev 3666) @@ -140,8 +140,7 @@ #:contract #:make-contract #:contract-p - #:get-contract - #:all-contracts + #:get-contract #:contract-sponsor #:contract-paidp #:contract-download-only Modified: trunk/projects/bos/web/bos.web.asd =================================================================== --- trunk/projects/bos/web/bos.web.asd 2008-07-28 15:14:31 UTC (rev 3665) +++ trunk/projects/bos/web/bos.web.asd 2008-07-28 18:33:35 UTC (rev 3666) @@ -21,7 +21,7 @@ :components ((:file "packages") (:file "utf-8" :depends-on ("packages")) (:file "config" :depends-on ("packages")) - (:file "dictionary" :depends-on ("packages")) + (:file "dictionary" :depends-on ("packages" #+nil "startup")) (:file "web-macros" :depends-on ("config")) (:file "web-utils" :depends-on ("web-macros")) (:file "cms-links" :depends-on ("web-utils")) Modified: trunk/projects/bos/web/quad-tree.lisp =================================================================== --- trunk/projects/bos/web/quad-tree.lisp 2008-07-28 15:14:31 UTC (rev 3665) +++ trunk/projects/bos/web/quad-tree.lisp 2008-07-28 18:33:35 UTC (rev 3666) @@ -359,6 +359,15 @@ :order order) (nreverse nodes))) +(defmethod node-path ((node node-extension)) + (node-path (base-node node))) + +;;; *quad-tree* +(defvar *quad-tree*) + +(defun make-quad-tree () + (setq *quad-tree* (make-instance 'quad-node :geo-box *m2-geo-box*))) + (defmethod node-path ((node quad-node)) (let (prev-n path) (map-nodes (lambda (n) @@ -372,15 +381,6 @@ (geo-box node)))) :order :depth-first))) -(defmethod node-path ((node node-extension)) - (node-path (base-node node))) - -;;; *quad-tree* -(defvar *quad-tree*) - -(defun make-quad-tree () - (setq *quad-tree* (make-instance 'quad-node :geo-box *m2-geo-box*))) - (defun node-lod (node) (if (zerop (depth node)) '(:min 16 :max -1)

1 0

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

28 Jul '08

Revision: 3665 Author: ksprotte URL: http://bknr.net/trac/changeset/3665 fixed poi-javascript generation for changed poi-movie format U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-28 14:44:00 UTC (rev 3664) +++ trunk/projects/bos/m2/poi.lisp 2008-07-28 15:14:31 UTC (rev 3665) @@ -176,7 +176,7 @@ (when (poi-panoramas poi) (format t "poi.panoramas = [ ~{~D~^, ~} ];~%" (mapcar #'store-object-id (poi-panoramas poi)))) (when (poi-movies poi) - (format t "poi.movies = [ ~{~S~^, ~} ];~%" (poi-movies poi))) + (format t "poi.movies = [ ~{~S~^, ~} ];~%" (mapcar #'poi-movie-url (poi-movies poi)))) (loop for slot-name in '(title subtitle description) for javascript-name in '("imageueberschrift" "imageuntertitel" "imagetext") for slot-values = (mapcar (lambda (image)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/pa
by BKNR Commits 28 Jul '08

28 Jul '08

Revision: 3664 Author: hans URL: http://bknr.net/trac/changeset/3664 Further testing with PayPal EC API U trunk/projects/quickhoney/src/packages.lisp U trunk/projects/quickhoney/src/paypal-test.lisp U trunk/projects/quickhoney/src/paypal.lisp Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-07-28 14:39:46 UTC (rev 3663) +++ trunk/projects/quickhoney/src/packages.lisp 2008-07-28 14:44:00 UTC (rev 3664) @@ -56,7 +56,11 @@ (defpackage :paypal (:use :cl) (:export #:request - #:make-express-checkout-url)) + #:make-express-checkout-url + #:paypal-error + #:request-error + #:http-request-error + #:response-error)) (defpackage :paypal-test (:use :cl)) \ No newline at end of file Modified: trunk/projects/quickhoney/src/paypal-test.lisp =================================================================== --- trunk/projects/quickhoney/src/paypal-test.lisp 2008-07-28 14:39:46 UTC (rev 3663) +++ trunk/projects/quickhoney/src/paypal-test.lisp 2008-07-28 14:44:00 UTC (rev 3664) @@ -1,5 +1,4 @@ (in-package :paypal-test) - (defgeneric dispatch-request (request-type request) (:documentation "dispatch incoming http request")) @@ -18,14 +17,25 @@ (define-handler :checkout (request) (tbnl:redirect (paypal:make-express-checkout-url 10 :eur - :returnurl (format nil "http://~A:~A/return-paypal" response-host response-port) - :cancelurl (format nil "http://~A:~A/cancel-paypal" response-host response-port)))) + (format nil "http://~A:~A/return-paypal" *response-host* *response-port*) + (format nil "http://~A:~A/cancel-paypal" *response-host* *response-port*)))) (define-handler :stop (request) (throw 'stop-server nil)) (define-handler :return-paypal (request) - "Returned from paypal") + (with-output-to-string (*standard-output*) + (let* ((token (tbnl:get-parameter "token")) + (response (paypal:request "GetExpressCheckoutDetails" :token token)) + (payerid (getf response :payerid)) + (amt (getf response :amt)) + (currencycode (getf response :currencycode))) + (print (paypal:request "DoExpressCheckoutPayment" + :token token + :payerid payerid + :amt amt + :currencycode currencycode + :paymentaction "Sale"))))) (define-handler :cancel-paypal (request) "Cancelled") Modified: trunk/projects/quickhoney/src/paypal.lisp =================================================================== --- trunk/projects/quickhoney/src/paypal.lisp 2008-07-28 14:39:46 UTC (rev 3663) +++ trunk/projects/quickhoney/src/paypal.lisp 2008-07-28 14:44:00 UTC (rev 3664) @@ -2,20 +2,27 @@ (defparameter *paypal-url* "https://api-3t.sandbox.paypal.com/nvp" "NVP URL of the Paypal server") -(defparameter *paypal-user* "sdk-three_api1.sdk.com" +(defparameter *paypal-user* "hans.huebner_api1.gmail.com" "Username to use to authenticate at the Paypal server") -(defparameter *paypal-password* "QFZCWN5HZM8VBG7Q" +(defparameter *paypal-password* "62QFQPLEMM6P3M25" "Password to use to authenticate at the Paypal server") -(defparameter *paypal-signature* "A-IzJhZZjhg29XQ2qnhapuwxIDzyAZQ92FRP5dqBzVesOkzbdUONzmOU" +(defparameter *paypal-signature* "AFcWxV21C7fd0v3bYYYRCpSSRl31Ac-RAs1SuG20a1IoPMJ0WKbx0fdG" "Signature to use to authenticate at the Paypal server") -(define-condition request-error (error) +(define-condition paypal-error (error) + ()) + +(define-condition request-error (paypal-error) ((response :initarg :response))) -(define-condition http-request-error (error) +(define-condition http-request-error (paypal-error) ((http-status :initarg :http-status) (response-string :initarg :response-string))) +(define-condition response-error (paypal-error) + ((response :initarg :response) + (invalid-parameter :initarg :invalid-parameter))) + (defun decode-response (response) "Decode a paypal response string, which is URL encoded and follow list encoding rules. Returns the parameters as a plist." @@ -28,9 +35,9 @@ (index (parse-integer (aref registers 1))) (previous-value (gethash parameter hash))) (unless (= (length previous-value) index) - (error "unexpected list value ~A in Paypal response ~S" parameter-string response)) - (setf (gethash parameter hash) (append previous-value (list (hunchentoot:url-decode value))))) - (setf (gethash (intern parameter-string :keyword) hash) (hunchentoot:url-decode value)))))) + (error 'response-error :invalid-parameter parameter-string :response response)) + (setf (gethash parameter hash) (append previous-value (list (hunchentoot:url-decode value :utf-8))))) + (setf (gethash (intern parameter-string :keyword) hash) (hunchentoot:url-decode value :utf-8)))))) (loop for key being the hash-keys of hash collect key collect (gethash key hash)))) @@ -49,7 +56,9 @@ (cons "SIGNATURE" *paypal-signature*)) (loop for (param value) on args by #'cddr collect (cons (symbol-name param) - (if (stringp value) value (princ-to-string value)))))) + (if (stringp value) + value + (princ-to-string value)))))) (unless (= 200 http-status) (error 'http-request-error :http-status http-status :response-string response-string)) (let ((response (decode-response response-string)))

1 0

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

28 Jul '08

Revision: 3663 Author: hans URL: http://bknr.net/trac/changeset/3663 Remove stripe related code and definitions. U trunk/projects/bos/m2/bos.dtd U trunk/projects/bos/m2/export.lisp U trunk/projects/bos/m2/import.lisp Modified: trunk/projects/bos/m2/bos.dtd =================================================================== --- trunk/projects/bos/m2/bos.dtd 2008-07-28 14:37:24 UTC (rev 3662) +++ trunk/projects/bos/m2/bos.dtd 2008-07-28 14:39:46 UTC (rev 3663) @@ -72,7 +72,7 @@ ! Zustand der Vergabe werden anhand von internen (x,y) Koordinaten gefuehrt. --> <!ELEMENT allocation-areas (allocation-area*)> -<!ELEMENT allocation-area (polygon,stripes?)> +<!ELEMENT allocation-area (polygon)> <!ATTLIST allocation-area active (yes|no) #REQUIRED y CDATA #REQUIRED @@ -104,14 +104,3 @@ x CDATA #REQUIRED y CDATA #REQUIRED > - - -<!ELEMENT stripes (stripe*)> -<!ELEMENT stripe (rectangle,seen?)> -<!ATTLIST stripe - x CDATA #REQUIRED - y CDATA #REQUIRED - > -<!ELEMENT seen (point*)> Modified: trunk/projects/bos/m2/export.lisp =================================================================== --- trunk/projects/bos/m2/export.lisp 2008-07-28 14:37:24 UTC (rev 3662) +++ trunk/projects/bos/m2/export.lisp 2008-07-28 14:39:46 UTC (rev 3663) @@ -29,15 +29,6 @@ (defun area< (a b) (< (store-object-id a) (store-object-id b))) -(defun stripe< (a b) - (let ((ha (stripe-height a)) - (hb (stripe-height b))) - (or (< ha hb) - (and (eql ha hb) - (or (< (stripe-top a) (stripe-top b)) - (and (eql (stripe-top a) (stripe-top b)) - (< (stripe-left a) (stripe-left b)))))))) - (defun export-m2 (m2) (with-element "m2" (attribute "utm-x" (write-to-string (m2-utm-x m2))) @@ -73,19 +64,8 @@ (attribute "width" (write-to-string width)) (attribute "height" (write-to-string height)))) -(defun export-stripe (stripe) - (with-slots (left top width height x y seen) stripe - (with-element "stripe" - (attribute "x" (write-to-string x)) - (attribute "y" (write-to-string y)) - (export-rectangle left top width height) - (when seen - (with-element "seen" - (dolist (m2 seen) - (export-point (m2-x m2) (m2-y m2)))))))) - (defun export-area (area) - (with-slots (left top width height active-p y vertices stripes) area + (with-slots (left top width height active-p y vertices) area (with-element "allocation-area" (attribute "active" (if active-p "yes" "no")) (attribute "y" (write-to-string y)) @@ -93,9 +73,7 @@ (map nil (lambda (vertex) (export-point (car vertex) (cdr vertex))) - vertices)) - (with-element "stripes" - (map-sorted #'export-stripe #'stripe< stripes))))) + vertices))))) (defun export-sponsor (sponsor) (with-element "sponsor" Modified: trunk/projects/bos/m2/import.lisp =================================================================== --- trunk/projects/bos/m2/import.lisp 2008-07-28 14:37:24 UTC (rev 3662) +++ trunk/projects/bos/m2/import.lisp 2008-07-28 14:39:46 UTC (rev 3663) @@ -8,10 +8,7 @@ (area-active-p :accessor importer-area-active-p) (area-y :accessor importer-area-y) (area-vertices :accessor importer-area-vertices) - (area :accessor importer-area) - (stripe :accessor importer-stripe) - (stripe-x :accessor importer-stripe-x) - (stripe-y :accessor importer-stripe-y))) + (area :accessor importer-area))) (defun import-database (pathname) (cxml:parse-file pathname (cxml:make-recoder (make-instance 'importer)))) @@ -79,43 +76,9 @@ (setf (importer-area handler) nil) (setf (importer-area-vertices handler) nil)) ((string= qname "point") - (if (importer-area handler) - (let ((stripe (importer-stripe handler))) - (change-slot-values - stripe - 'seen - (append (stripe-seen stripe) - (list - (ensure-m2 (parse-integer (getattribute "x" attrs)) - (parse-integer (getattribute "y" attrs))))))) - (push (cons (parse-integer (getattribute "x" attrs)) - (parse-integer (getattribute "y" attrs))) - (importer-area-vertices handler)))) - ((string= qname "stripes") - (let* ((*preallocate-stripes* nil) - (a (make-allocation-area - (coerce (reverse (importer-area-vertices handler)) 'vector)))) - (change-slot-values - a - 'y (importer-area-y handler) - 'active-p (importer-area-active-p handler)) - (setf (importer-area handler) a))) - ((string= qname "stripe") - (setf (importer-stripe-x handler) - (parse-integer (getattribute "x" attrs))) - (setf (importer-stripe-y handler) - (parse-integer (getattribute "y" attrs)))) - ((string= qname "rectangle") - (setf (importer-stripe handler) - (make-stripe (importer-area handler) - (parse-integer (getattribute "left" attrs)) - (parse-integer (getattribute "top" attrs)) - (parse-integer (getattribute "width" attrs)) - (parse-integer (getattribute "height" attrs)))) - (change-slot-values - (importer-stripe handler) - 'x (importer-stripe-x handler) - 'y (importer-stripe-y handler))))) + (push (cons (parse-integer (getattribute "x" attrs)) + (parse-integer (getattribute "y" attrs))) + (importer-area-vertices handler))))) (defmethod sax:end-element ((handler importer) namespace-uri local-name qname) (declare (ignore namespace-uri local-name))

1 0

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

28 Jul '08

Revision: 3662 Author: ksprotte URL: http://bknr.net/trac/changeset/3662 corrected method definition order in poi.lisp U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-28 14:31:11 UTC (rev 3661) +++ trunk/projects/bos/m2/poi.lisp 2008-07-28 14:37:24 UTC (rev 3662) @@ -73,15 +73,6 @@ ((poi :read) (url :update :initform nil))) -(defmethod poi-movies :before ((poi poi)) - "Lazily update the db schema. Method can be removed later." - (macrolet ((movie (tail) `(car ,tail))) - (mapl (lambda (tail) - (when (stringp (movie tail)) - (setf (movie tail) - (make-object 'poi-movie :poi poi :url (movie tail))))) - (slot-value poi 'movies)))) - ;;; poi (define-persistent-class poi () ((name :read :index-type string-unique-index @@ -98,6 +89,15 @@ (movies :update :initform nil) (published :update :initform nil))) +(defmethod poi-movies :before ((poi poi)) + "Lazily update the db schema. Method can be removed later." + (macrolet ((movie (tail) `(car ,tail))) + (mapl (lambda (tail) + (when (stringp (movie tail)) + (setf (movie tail) + (make-object 'poi-movie :poi poi :url (movie tail))))) + (slot-value poi 'movies)))) + (deftransaction make-poi (language name &key title description area) (let ((poi (make-object 'poi :name name :area area))) (setf (slot-string poi 'title language) title)

1 0

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

28 Jul '08

Revision: 3661 Author: hans URL: http://bknr.net/trac/changeset/3661 Remove old graphics generation files that are no longer useful. D trunk/projects/bos/m2/bitmap.lisp U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/m2/packages.lisp Deleted: trunk/projects/bos/m2/bitmap.lisp =================================================================== --- trunk/projects/bos/m2/bitmap.lisp 2008-07-28 14:20:06 UTC (rev 3660) +++ trunk/projects/bos/m2/bitmap.lisp 2008-07-28 14:31:11 UTC (rev 3661) @@ -1,200 +0,0 @@ -;;; Anleitung: -;;; * (write-allocation-bitmaps ...) -;;; $ mogrify -format gif test-*.png # pkg_add -r ImageMagick -;;; $ whirlgif -o test.gif test-???.gif # pkg_add -r whirlgif -;;; Heraus kommt ein animated gif aller Contracts in Erzeugungsreihenfolge, -;;; die im angegebenen Rechteck sichtbar sind (siehe Argumente zu W-A-B). - -(in-package :bos.m2) - -(defun make-vga-colors (&optional (image cl-gd:*default-image*)) - (cl-gd:with-default-image (image) - (let ((colors (make-array 16))) - (setf (elt colors 01) (cl-gd:find-color #xff #xff #xff :resolve t)) - (setf (elt colors 02) (cl-gd:find-color #xff #x00 #x00 :resolve t)) - (setf (elt colors 03) (cl-gd:find-color #x00 #xff #x00 :resolve t)) - (setf (elt colors 04) (cl-gd:find-color #x00 #x00 #xff :resolve t)) - (setf (elt colors 05) (cl-gd:find-color #x00 #xff #xff :resolve t)) - (setf (elt colors 06) (cl-gd:find-color #xff #x00 #xff :resolve t)) - (setf (elt colors 07) (cl-gd:find-color #xff #xff #x00 :resolve t)) - (setf (elt colors 08) (cl-gd:find-color #x80 #x80 #x80 :resolve t)) - (setf (elt colors 09) (cl-gd:find-color #xc0 #xc0 #xc0 :resolve t)) - (setf (elt colors 10) (cl-gd:find-color #x80 #x00 #x00 :resolve t)) - (setf (elt colors 11) (cl-gd:find-color #x00 #x80 #x00 :resolve t)) - (setf (elt colors 12) (cl-gd:find-color #x00 #x00 #x80 :resolve t)) - (setf (elt colors 13) (cl-gd:find-color #x00 #x80 #x80 :resolve t)) - (setf (elt colors 14) (cl-gd:find-color #x80 #x00 #x80 :resolve t)) - (setf (elt colors 15) (cl-gd:find-color #x80 #x80 #x00 :resolve t)) - colors))) - -(defvar *bitmap* nil) - -(defun make-allocation-bitmap (left top width height) - (let ((image (cl-gd:create-image width height))) - (cl-gd:with-default-image (image) - (let ((colors (make-vga-colors image))) - (cl-gd:draw-rectangle* 0 0 (1- width) (1- height) - :filled t - :color (elt colors 0)) - (setf *bitmap* - (list image left top width height colors (make-hash-table))))))) - -(defun free-allocation-bitmap () - (cl-gd:destroy-image (car *bitmap*)) - (setf *bitmap* nil) - nil) - -(defun all-contracts () - (store-objects-with-class 'contract)) - -(defun draw-contracts (image left top width height colors contracts &optional seen) - (cl-gd:with-default-image (image) - ;; We manipulate pixels in a temporary array which is copied to the GD image as - ;; a whole for performance reasons. The FFI is way too slow to manipulate individual pixels. - (let ((work-array (make-array (list width height) :element-type 'fixnum))) - (cl-gd:do-rows (y) - (cl-gd:do-pixels-in-row (x) - (setf (aref work-array x y) (cl-gd:raw-pixel)))) - (flet ((set-pixel (x y color) - (decf x left) - (decf y top) - (when (and (<= 0 x (1- width)) (<= 0 y (1- height))) - (setf (aref work-array x y) color))) - (get-pixel (x y) - (decf x left) - (decf y top) - (if (and (<= 0 x (1- width)) (<= 0 y (1- height))) - (aref work-array x y) - nil))) - (loop for contract in contracts - do (when (or (not seen) - (not (gethash contract seen))) - (when seen (setf (gethash contract seen) t)) - (let ((free (copy-seq (cdr (coerce colors 'list))))) - (dolist (m2 (contract-m2s contract)) - (flet ((doit (x y) - (let ((c (get-pixel x y))) - (when c - (setf free (delete c free)))))) - (doit (+ (m2-x m2) 0) (+ (m2-y m2) -1)) - (doit (+ (m2-x m2) -1) (+ (m2-y m2) 0)) - (doit (+ (m2-x m2) +1) (+ (m2-y m2) 0)) - (doit (+ (m2-x m2) 0) (+ (m2-y m2) +1)))) - (let ((color (or (car free) - (elt colors (1+ (random 15)))))) - (dolist (m2 (contract-m2s contract)) - (set-pixel (m2-x m2) (m2-y m2) color))))))) - (cl-gd:do-rows (y) - (cl-gd:do-pixels-in-row (x) - (setf (cl-gd:raw-pixel) (aref work-array x y))))))) - -(defun write-allocation-bitmap (filename &optional ncontracts) - (destructuring-bind (image left top width height colors seen) *bitmap* - (let ((contracts (sort (copy-list (all-contracts)) #'< :key #'store-object-id))) - (draw-contracts image left top width height colors (subseq contracts 0 ncontracts) seen) - (when (probe-file filename) - (delete-file filename)) - (cl-gd:write-image-to-file filename :image image :type :png)) - filename)) - -(defun draw-stripes () - (destructuring-bind (image left top width height colors seen) *bitmap* - (declare (ignore left top width height seen)) - (cl-gd:with-default-image (image) - (dolist (stripe (store-stripes)) - (with-slots (left top width height) stripe - (cl-gd:draw-rectangle* left top (1- (+ left width)) (1- (+ top height)) - :color (elt colors 1))))))) - -(defun write-allocation-bitmaps - (&key (step 100) left top width height draw-stripes - (directory "/home/david/animate/")) - (when *bitmap* - (free-allocation-bitmap)) - (unless (and left top width height) - ;; automatisch den kleinesten ausschnitt waehlen, der alle allocation - ;; areas enthaelt, falls nicht anders vorgegeben. - (let ((points '())) - (dolist (area (all-allocation-areas)) - (with-slots (left top width height) area - (push (cons left top) points) - (push (cons (+ left width) (+ top height)) points))) - (multiple-value-setq (left top width height) - (compute-bounding-box points)))) - (make-allocation-bitmap left top width height) - (when draw-stripes - (draw-stripes)) - (if step - (loop for i from 0 to (ceiling (length (all-contracts)) step) - do - (let ((filename - (merge-pathnames (format nil "test-~3,'0D.png" i) - directory))) - (print filename) - (force-output) - (write-allocation-bitmap filename (* i step)))) - (write-allocation-bitmap - (merge-pathnames "test.png" directory)))) - -(defvar *initial-random-state* (make-random-state)) - -(defun test-allocation - (&key (initial-random-state *initial-random-state*) - (limit nil)) - (let ((*random-state* (make-random-state initial-random-state))) - (when *bitmap* - (free-allocation-bitmap)) - (make-allocation-bitmap 0 0 400 400) - (let ((u (or (find-user 123) - (make-sponsor :profile-id 123 - :first-name "Otto" - :last-name "Mustermann" - :email-address "otto.mustermann(a)t-online.de")))) - (flet ((make-one-contract () - (let* ((limit 0.0001) - (n (max 1 (round (/ 0.5 (+ (random (- 1.0 limit)) limit)))))) - - (format t " ~D" n) - (force-output) - (make-contract u n)))) - (if limit - (dotimes (x limit) - (make-one-contract)) - (loop - (make-one-contract))))))) - -#+(or) -(progn - (reinit :delete t :directory "home:tmp/mytest-datastore/") - (let ((p #((66 . 0) (134 . 0) - (200 . 66) (200 . 134) - (134 . 200) (66 . 200) - (0 . 134) (0 . 66))) - (q #((200 . 180) (400 . 0) (400 . 200))) - (r (map 'vector - (lambda (x) - (cons (+ (* (car x) 40) 20) - (+ (* (cdr x) 40) 200))) - #((0 . 0) (1 . 0) (1 . 3) (2 . 4) (3 . 3) (3 . 0) (4 . 0) - (4 . 4) (2 . 5) (0 . 4)))) - (s #((400 . 0) (600 . 0) (600 . 200) (400 . 200)))) - (bknr.datastore::without-sync () - (make-allocation-area p) - (make-allocation-area q) - (make-allocation-area r) - (make-allocation-area s))) - (bknr.datastore::without-sync () - (time - (with-simple-restart (ok "ok") - (test-allocation :limit nil))))) - -#+(or) -(bknr.datastore::without-sync () - (make-allocation-area - #((66 . 0) (134 . 0) - (200 . 66) (200 . 134) - (134 . 200) (66 . 200) - (0 . 134) (0 . 66)))) - -#+(or) -(bos.m2::make-allocation-area #((0 . 0) (200 . 0) (200 . 200) (0 . 200))) Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-07-28 14:20:06 UTC (rev 3660) +++ trunk/projects/bos/m2/bos.m2.asd 2008-07-28 14:31:11 UTC (rev 3661) @@ -1,34 +1,35 @@ - (in-package :cl-user) +;; -*- Lisp -*- - (asdf:defsystem :bos.m2 - :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime - :kmrcl :iterate :arnesi - :cl-pdf :screamer :cl-fad) - :components ((:file "packages") - (:file "geo-utm" :depends-on ("packages")) - (:file "geometry" :depends-on ("packages" "m2-store")) - (: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 "initialization-subsystem" :depends-on ("packages")) - (:file "m2-store" :depends-on ("packages" "utils")) - (:file "m2" :depends-on ("initialization-subsystem" - "tiled-index" - "utils" - "make-certificate" - "mail-generator" - "geo-utm" - "geometry")) - (:file "m2-pdf" :depends-on ("m2")) - (:file "contract-expiry" :depends-on ("m2")) - (:file "allocation" :depends-on ("m2")) - (: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" "geometry")) - (:file "export" :depends-on ("m2")) - (:file "cert-daemon" :depends-on ("config")))) +(in-package :cl-user) + +(asdf:defsystem :bos.m2 + :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime + :kmrcl :iterate :arnesi + :cl-pdf :screamer :cl-fad) + :components ((:file "packages") + (:file "geo-utm" :depends-on ("packages")) + (:file "geometry" :depends-on ("packages" "m2-store")) + (: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 "initialization-subsystem" :depends-on ("packages")) + (:file "m2-store" :depends-on ("packages" "utils")) + (:file "m2" :depends-on ("initialization-subsystem" + "tiled-index" + "utils" + "make-certificate" + "mail-generator" + "geo-utm" + "geometry")) + (:file "m2-pdf" :depends-on ("m2")) + (:file "contract-expiry" :depends-on ("m2")) + (:file "allocation" :depends-on ("m2")) + (:file "allocation-cache" :depends-on ("packages" "geometry")) + (:file "poi" :depends-on ("utils" "allocation")) + (:file "import" :depends-on ("m2")) + (:file "map" :depends-on ("m2" "allocation" "geometry")) + (:file "export" :depends-on ("m2")) + (:file "cert-daemon" :depends-on ("config")))) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-28 14:20:06 UTC (rev 3660) +++ trunk/projects/bos/m2/packages.lisp 2008-07-28 14:31:11 UTC (rev 3661) @@ -200,10 +200,6 @@ #:allocation-area-percent-used #:left #:top #:width #:height #:active-p - ;; bitmap routines for drawing of allocation areas - #:make-vga-colors - #:draw-contracts - ;; pois #:*current-language* #:slot-string

1 0