September 2008 - bknr-cvs@common-lisp.net

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/packages.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3794 Author: ksprotte URL: http://bknr.net/trac/changeset/3794 new POI slot: lod-min - the lod minimum used in Google Earth Users can customize this in the CMS. This intends to address the issue: KML/Google Earth: Aus gr?\195?\182?\195?\159erer H?\195?\182he soll das BOS-Icon immer zu sehen sein An arbitrary POI can be chosen or newly created for this purpose - it needn't even be "published-web". U trunk/projects/bos/m2/packages.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-09-04 14:37:34 UTC (rev 3793) +++ trunk/projects/bos/m2/packages.lisp 2008-09-04 17:18:28 UTC (rev 3794) @@ -203,7 +203,7 @@ ;; slot-strings #:slot-string #:set-slot-string-values - + ;; pois #:title #:subtitle #:description ; for slot-string access #:update-textual-attributes @@ -226,6 +226,7 @@ #:poi-area #:poi-icon #:poi-media + #:poi-lod-min #:make-poi #:update-poi #:poi-complete @@ -239,7 +240,7 @@ #:poi-panoramas #:poi-movies #:make-poi-javascript - + ;; news #:news-item #:make-news-item

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3793 Author: ksprotte URL: http://bknr.net/trac/changeset/3793 fixed KML/Google Earth bug. Einblenden der Vertrags-Icons erfolgt zu sp?\195?\164t, werden erst sichtbar, wenn man sehr nah ranfliegt U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-09-04 14:03:38 UTC (rev 3792) +++ trunk/projects/bos/web/contract-tree.lisp 2008-09-04 14:37:34 UTC (rev 3793) @@ -58,31 +58,41 @@ (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t))) (defun contract-placemark-at-node-p (node contract) - "Returns T if CONTRACT is large enough at the LOD of NODE to be displayed -with its center placemark." - (if (not (node-has-children-p node)) - t - (let ((geo-box (geo-box node))) - (destructuring-bind (geo-box-utm-west geo-box-utm-north &rest _) - (geo-utm:lon-lat-to-utm-x-y (geo-box-west geo-box) (geo-box-north geo-box)) - (declare (ignore _)) - (destructuring-bind (geo-box-utm-east geo-box-utm-south &rest _) - (geo-utm:lon-lat-to-utm-x-y (geo-box-east geo-box) (geo-box-south geo-box)) - (declare (ignore _)) - (let* ((output-images-size *contract-tree-images-size*) - (rect (contract-largest-rectangle contract)) - (contract-width (third rect)) - (contract-height (fourth rect)) - (geo-width (- geo-box-utm-east geo-box-utm-west)) - (geo-height (- geo-box-utm-north geo-box-utm-south)) - (contract-pixel-size (min (* contract-width (/ output-images-size geo-width)) - (* contract-height (/ output-images-size geo-height))))) - (if (< (contract-area contract) 4) - nil - (if (< (depth node) 6) - (> contract-pixel-size 15) - (> contract-pixel-size 30))))))))) + "Returns T if CONTRACT is large enough at the LOD of NODE to be +displayed with its center placemark. +This predicate is called by INSERT-CONTRACT. We assume that for +bulk-insertions contracts with larger area are inserted first." + (cond + ((not (node-has-children-p node)) + t) + ;; let's fill nodes to a very low minimum - as noted above, larger + ;; contracts are inserted first + ((and (> (depth node) 3) + (< (length (placemark-contracts node)) 2)) + t) + (t (let ((geo-box (geo-box node))) + (destructuring-bind (geo-box-utm-west geo-box-utm-north &rest _) + (geo-utm:lon-lat-to-utm-x-y (geo-box-west geo-box) (geo-box-north geo-box)) + (declare (ignore _)) + (destructuring-bind (geo-box-utm-east geo-box-utm-south &rest _) + (geo-utm:lon-lat-to-utm-x-y (geo-box-east geo-box) (geo-box-south geo-box)) + (declare (ignore _)) + (let* ((output-images-size *contract-tree-images-size*) + (rect (contract-largest-rectangle contract)) + (contract-width (third rect)) + (contract-height (fourth rect)) + (geo-width (- geo-box-utm-east geo-box-utm-west)) + (geo-height (- geo-box-utm-north geo-box-utm-south)) + (contract-pixel-size (min (* contract-width (/ output-images-size geo-width)) + (* contract-height (/ output-images-size geo-height))))) + (cond + ((< (contract-area contract) 4) + nil) + ((< (depth node) 4) + (> contract-pixel-size 5)) + (t (> contract-pixel-size 10)))))))))) + (defun find-contract-node (node contract) (find-node-if (lambda (node) (member contract (placemark-contracts node))) node)) @@ -353,12 +363,14 @@ ;;; make-contract-tree-from-m2 (defun make-contract-tree-from-m2 () + (when *contract-tree* + (map-nodes #'delete-node-extension *contract-tree*)) (setq *contract-tree* (make-instance 'contract-node ;; we know that MAKE-QUAD-TREE ;; has already been called :base-node *quad-tree* :name '*contract-tree*)) - (dolist (contract (all-contracts)) + (dolist (contract (sort (copy-list (all-contracts)) #'> :key #'contract-area)) (when (contract-published-p contract) (insert-contract *contract-tree* contract))) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree*

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/quad-tree.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3792 Author: ksprotte URL: http://bknr.net/trac/changeset/3792 safer print-object method for node-extension U trunk/projects/bos/web/quad-tree.lisp Modified: trunk/projects/bos/web/quad-tree.lisp =================================================================== --- trunk/projects/bos/web/quad-tree.lisp 2008-09-04 13:39:10 UTC (rev 3791) +++ trunk/projects/bos/web/quad-tree.lisp 2008-09-04 14:03:38 UTC (rev 3792) @@ -177,8 +177,13 @@ (def-extension-reader depth)) (defmethod print-object ((node node-extension) stream) - (print-unreadable-object (node stream :type t :identity t) - (format stream "name: ~s path: ~s" (name node) (node-path node)))) + (handler-case + (let ((name (name node)) + (node-path (node-path node))) + (print-unreadable-object (node stream :type t :identity t) + (format stream "name: ~s path: ~s" name node-path))) + (error () + (print-unreadable-object (node stream :type t :identity t))))) (defmethod delete-node-extension ((node node-extension)) (setf (%extensions (base-node node))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/sponsor-handlers.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3791 Author: ksprotte URL: http://bknr.net/trac/changeset/3791 Create sponsor Language for communication and certificate default: DE U trunk/projects/bos/web/sponsor-handlers.lisp Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-04 13:09:36 UTC (rev 3790) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-04 13:39:10 UTC (rev 3791) @@ -92,7 +92,7 @@ (:tr (:td "Email-Address") (:td (text-field "email" :size 40))) (:tr (:td "Language for communication and certificate") - (:td (language-selector "en"))) + (:td (language-selector "de"))) (:tr (:td "Name for certificate") (:td (text-field "name" :size 20))) (:tr (:td "Postal address for certificate")

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/util.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3790 Author: hans URL: http://bknr.net/trac/changeset/3790 Special case for zero-length string. U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2008-09-04 12:18:43 UTC (rev 3789) +++ trunk/thirdparty/hunchentoot/util.lisp 2008-09-04 13:09:36 UTC (rev 3790) @@ -243,43 +243,45 @@ (defun url-decode (string &optional (external-format *hunchentoot-default-external-format*)) "Decodes a URL-encoded STRING which is assumed to be encoded using the external format EXTERNAL-FORMAT." - (loop - with vector = (make-array (length string) :element-type 'octet :fill-pointer 0) - with i = 0 - with unicode - for char = (aref string i) - do (labels ((decode-hex (length) - (prog1 - (parse-integer string :start i :end (+ i length) :radix 16) - (incf i length))) - (push-integer (integer) - (vector-push integer vector)) - (peek () - (aref string i)) - (advance () - (setf char (peek)) - (incf i))) - (cond - ((char= #\% char) - (advance) - (cond - ((char= #\u (peek)) - (unless unicode - (setf unicode t) - (upgrade-vector vector '(integer 0 65535))) - (advance) - (push-integer (decode-hex 4))) - (t - (push-integer (decode-hex 2))))) - (t - (push-integer (char-code (case char - ((#\+) #\Space) - (otherwise char)))) - (advance)))) - while (< i (length string)) - finally (return (if unicode - (upgrade-vector vector 'character :converter #'code-char) - (octets-to-string vector :external-format external-format))))) + (if (zerop (length string)) + "" + (loop + with vector = (make-array (length string) :element-type 'octet :fill-pointer 0) + with i = 0 + with unicode + for char = (aref string i) + do (labels ((decode-hex (length) + (prog1 + (parse-integer string :start i :end (+ i length) :radix 16) + (incf i length))) + (push-integer (integer) + (vector-push integer vector)) + (peek () + (aref string i)) + (advance () + (setf char (peek)) + (incf i))) + (cond + ((char= #\% char) + (advance) + (cond + ((char= #\u (peek)) + (unless unicode + (setf unicode t) + (upgrade-vector vector '(integer 0 65535))) + (advance) + (push-integer (decode-hex 4))) + (t + (push-integer (decode-hex 2))))) + (t + (push-integer (char-code (case char + ((#\+) #\Space) + (otherwise char)))) + (advance)))) + while (< i (length string)) + finally (return (if unicode + (upgrade-vector vector 'character :converter #'code-char) + (octets-to-string vector :external-format external-format)))))) (defun form-url-encoded-list-to-alist (form-url-encoded-list &optional (external-format *hunchentoot-default-external-format*))

1 0

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

04 Sep '08

Revision: 3789 Author: ksprotte URL: http://bknr.net/trac/changeset/3789 fixed country-stats U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-09-04 10:52:31 UTC (rev 3788) +++ trunk/projects/bos/m2/m2.lisp 2008-09-04 12:18:43 UTC (rev 3789) @@ -624,8 +624,7 @@ (defun add-to-contract-stats (contract) (let* ((area (contract-area contract)) (sponsor (contract-sponsor contract)) - (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor))) - (country (sponsor-country sponsor))) + (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor)))) (with-slots (sold-m2s paying-sponsors country-sponsors last-contracts) *contract-stats* ;; sold-m2s @@ -634,8 +633,9 @@ (when new-sponsor-p (incf paying-sponsors)) ;; country-sponsors - (when country - (let ((country-stat (gethash country country-sponsors))) + (when (sponsor-country sponsor) + (let* ((country (make-keyword-from-string (sponsor-country sponsor))) + (country-stat (gethash country country-sponsors))) (unless country-stat (setq country-stat (setf (gethash country country-sponsors) (make-country-stat)))) (when new-sponsor-p Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 10:52:31 UTC (rev 3788) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 12:18:43 UTC (rev 3789) @@ -286,9 +286,9 @@ (attribute "id" "countryStatsStyle") (with-element "IconStyle" (with-element "Icon" - ;; (with-element "href" (text "http://maps.google.com/mapfiles/kml/pal3/icon23.png")) (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) (do-sponsor-countries (country) + (assert (keywordp country)) (let ((coords (cdr (assoc country *country-coords*)))) (when coords (destructuring-bind (lon lat) @@ -296,7 +296,6 @@ (multiple-value-bind (number-of-paying-sponsors number-of-sold-m2s) (contract-stats-for-country country) (with-element "Placemark" - ;; (with-element "name" (text (format nil "~a ~a" (car country-contracts) (length (cdr country-contracts))))) (with-element "styleUrl" (text "#countryStatsStyle")) (with-element "description" (text (format nil "<p>~A</p><table><tbody><tr><td>~A:</td><td>~D ~A</td></tr>

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/poi-handlers.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3788 Author: ksprotte URL: http://bknr.net/trac/changeset/3788 display the web link of all poi media U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-04 10:40:59 UTC (rev 3787) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-04 10:52:31 UTC (rev 3788) @@ -223,6 +223,9 @@ :br (submit-button "upload" "upload")))) (:tr ((:td :colspan "2" :height "10"))) + (:tr (:td "web link") + (:td (:princ-safe (medium-web-link medium)))) + (:tr ((:td :colspan "2" :height "10"))) ((:form :method "post") (:tr (:td "title") (:td (text-field "title" @@ -244,6 +247,13 @@ (:method ((medium poi-airal)) "Airal") (:method ((medium poi-movie)) "Movie")) +(defgeneric medium-web-link (medium) + (:method ((medium store-image)) + (format nil "http://~A/image/~A" + (website-host) (store-object-id medium))) + (:method ((medium poi-movie)) + (poi-movie-url medium))) + (defgeneric medium-handler-preview (medium &key small) (:method ((medium poi-medium) &key small) (declare (ignore small))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/kml-handlers.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3787 Author: ksprotte URL: http://bknr.net/trac/changeset/3787 clearer interface for kml-upload-handler U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 09:49:18 UTC (rev 3786) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 10:40:59 UTC (rev 3787) @@ -58,9 +58,22 @@ ;; we want this after the processing (:p (:format "last-change: ~A" (format-date-time (store-object-last-change kml-root-data 0))) + " " (cmslink (format nil "/kml-upload?lang=~A&action=download" language) "download current version"))))) - (submit-button "upload" "upload")))))) + (submit-button "upload" "upload")) + (:p "Please note that the " (:b "download current version") + " links above show you the kml files exactly like you + uploaded them. These are not the KML files as seen by the + users.") + (:p "For the actually served kml files some automatic + replacements are being done. You can inspect those by the + following links:") + (:p (dolist (kml-root-data (class-instances 'kml-root-data)) + (let ((language (language kml-root-data))) + (html (cmslink (format nil "/kml-root?lang=~A" language) + (:format "kml ~A" language)) + " ")))))))) (defmethod handle-form ((handler kml-upload-handler) (action (eql :download))) (with-query-params (lang)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3786 Author: ksprotte URL: http://bknr.net/trac/changeset/3786 contract-tree image update daemon: avoid error in delete-file if (blob-pathname old-store-image) of old-store-image does not exist U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-09-04 09:24:47 UTC (rev 3785) +++ trunk/projects/bos/web/contract-tree.lisp 2008-09-04 09:49:18 UTC (rev 3786) @@ -270,7 +270,10 @@ (setf (image node) new-store-image) ;; delete the old one (when old-store-image - (delete-file (blob-pathname old-store-image)) + (if (probe-file (blob-pathname old-store-image)) + (delete-file (blob-pathname old-store-image)) + (warn "Intended to delete ~A of ~A.~%But it already does not exist." + (blob-pathname old-store-image) old-store-image)) (delete-object old-store-image))))))) (defun contract-node-update-image-needed-p (node)

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/util.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3785 Author: hans URL: http://bknr.net/trac/changeset/3785 support non-standard %u notation in URL-DECODE U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2008-09-03 16:50:27 UTC (rev 3784) +++ trunk/thirdparty/hunchentoot/util.lisp 2008-09-04 09:24:47 UTC (rev 3785) @@ -229,32 +229,57 @@ ((#\") (write-string "\\\"" out)) (otherwise (write-char char out))))))) +(defmacro upgrade-vector (vector new-type &key converter (new-length `(array-total-size ,vector))) + `(setf ,vector (loop + with new-vector = (make-array ,new-length + :element-type ,new-type + :fill-pointer (length vector)) + for i from 0 below (length ,vector) + do (setf (aref new-vector i) ,(if converter + `(funcall ,converter (aref ,vector i)) + `(aref ,vector i))) + finally (return new-vector)))) + (defun url-decode (string &optional (external-format *hunchentoot-default-external-format*)) "Decodes a URL-encoded STRING which is assumed to be encoded using the external format EXTERNAL-FORMAT." - (let ((vector (make-array (length string) - :element-type 'octet - :fill-pointer 0))) - (loop with percent-p and buff - for char of-type character across string - for i from 0 - when buff do - (vector-push (parse-integer string - :start (1- i) - :end (1+ i) - :radix 16) - vector) - (setq buff nil) - else when percent-p - do (setq buff t - percent-p nil) - else when (char= char #\%) - do (setq percent-p t) - else do (vector-push (char-code (case char - ((#\+) #\Space) - (otherwise char))) - vector)) - (octets-to-string vector :external-format external-format))) + (loop + with vector = (make-array (length string) :element-type 'octet :fill-pointer 0) + with i = 0 + with unicode + for char = (aref string i) + do (labels ((decode-hex (length) + (prog1 + (parse-integer string :start i :end (+ i length) :radix 16) + (incf i length))) + (push-integer (integer) + (vector-push integer vector)) + (peek () + (aref string i)) + (advance () + (setf char (peek)) + (incf i))) + (cond + ((char= #\% char) + (advance) + (cond + ((char= #\u (peek)) + (unless unicode + (setf unicode t) + (upgrade-vector vector '(integer 0 65535))) + (advance) + (push-integer (decode-hex 4))) + (t + (push-integer (decode-hex 2))))) + (t + (push-integer (char-code (case char + ((#\+) #\Space) + (otherwise char)))) + (advance)))) + while (< i (length string)) + finally (return (if unicode + (upgrade-vector vector 'character :converter #'code-char) + (octets-to-string vector :external-format external-format))))) (defun form-url-encoded-list-to-alist (form-url-encoded-list &optional (external-format *hunchentoot-default-external-format*))

1 0