bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

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

05 Sep '08

Revision: 3800 Author: ksprotte URL: http://bknr.net/trac/changeset/3800 small cosmetic change to KML Upload 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 18:11:22 UTC (rev 3799) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-09-05 08:54:41 UTC (rev 3800) @@ -35,7 +35,7 @@ (dolist (kml-root-data (class-instances 'kml-root-data)) (let ((language (language kml-root-data))) (html (:h2 (:princ language)) - (:p ((:input :type "file" :name language)) + (:p ((:input :type "file" :name language :size 50)) " " (let ((file-upload (request-uploaded-file language))) (when file-upload

1 0

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

04 Sep '08

Revision: 3799 Author: ksprotte URL: http://bknr.net/trac/changeset/3799 some doc for kml-root-dynamic-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 17:42:21 UTC (rev 3798) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 18:11:22 UTC (rev 3799) @@ -181,7 +181,11 @@ (text (sponsor-info-text sponsor)))))))) (defclass kml-root-dynamic-handler (object-handler) - ((timestamp :accessor timestamp :initform (get-universal-time)))) + () + (:documentation "This handler is not actually used anymore, because +the root kml files are uploaded through the CMS. It is still left here +in the codebase, because it was used to generate the initial templates +and might be needed again.")) (defun write-personalized-contract-placemark-kml (contract lang) (with-element "Style" @@ -194,14 +198,12 @@ (write-contract-placemark-kml contract lang)) (defun write-root-kml (handler sponsor) + (declare (ignore handler)) (let ((*print-case* :downcase) (contract (when sponsor (first (sponsor-contracts sponsor))))) - (hunchentoot:handle-if-modified-since (timestamp handler)) ;; only the first contract of SPONSOR will be shown (with-xml-response (:content-type #+nil "text/xml" "application/vnd.google-earth.kml+xml; charset=utf-8" :root-element "kml") - (setf (hunchentoot:header-out :last-modified) - (hunchentoot:rfc-1123-date (timestamp handler))) (with-query-params ((lang "en")) (with-element "Document" (with-element "name" (text "BOS"))

1 0

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

04 Sep '08

Revision: 3798 Author: ksprotte URL: http://bknr.net/trac/changeset/3798 POI and country-stats should not hide their children 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 17:18:35 UTC (rev 3797) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 17:42:21 UTC (rev 3798) @@ -244,10 +244,10 @@ :name (dictionary-entry "POIs" lang) :rect (make-rectangle :x 0 :y 0 :width +width+ :height +width+) :lod '(:min 0 :max -1) - :hide-children t) + :hide-children nil) (kml-network-link (format nil "http://~a/country-stats?lang=~A" (website-host) lang) :name (dictionary-entry "Country-Stats" lang) - :hide-children t)))))) + :hide-children nil)))))) (defmethod handle-object ((handler kml-root-dynamic-handler) (object sponsor)) (write-root-kml handler object))

1 0

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

04 Sep '08

Revision: 3797 Author: ksprotte URL: http://bknr.net/trac/changeset/3797 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/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-04 17:18:33 UTC (rev 3796) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-04 17:18:35 UTC (rev 3797) @@ -74,7 +74,9 @@ (:td (:princ-safe (poi-name poi)))) (:tr (:td "published") (:td (checkbox-field "published-web" "published-web" :checked (poi-published-web poi)) " " - (checkbox-field "published-earth" "published-earth" :checked (poi-published-earth poi)))) + (checkbox-field "published-earth" "published-earth" :checked (poi-published-earth poi)) + " with lod-min " + (text-field "lod-min" :size 5 :value (poi-lod-min poi)))) (:tr (:td "title") (:td (text-field "title" :value (slot-string poi 'title language)))) @@ -89,7 +91,8 @@ (:tr (:td "location") (:td (flet ((format-chosen-url () (encode-urlencoded - (format nil "~A?action=save&language=~A&~:[~;published-web=on~]&~:[~;published-earth=on~]" + (format nil "~A?action=save&language=~A&~ + ~:[~;published-web=on~]&~:[~;published-earth=on~]" (hunchentoot:script-name*) language (poi-published-web poi) @@ -177,7 +180,8 @@ title subtitle description language (x nil integer) (y nil integer) - icon) + icon + (lod-min nil integer)) (unless language (setq language (request-language))) (update-textual-attributes poi language :title title @@ -187,7 +191,8 @@ :published-web published-web :published-earth published-earth :area (when (and x y) (list x y)) - :icon icon) + :icon icon + :lod-min lod-min) (with-bos-cms-page (:title "POI has been updated") (html (:h2 "Your changes have been saved") "You may " (cmslink (format nil "~A?language=~A" (edit-object-url poi) language) @@ -250,7 +255,7 @@ (defgeneric medium-web-link (medium) (:method ((medium store-image)) (format nil "http://~A/image/~A" - (website-host) (store-object-id medium))) + (website-host) (store-object-id medium))) (:method ((medium poi-movie)) (poi-movie-url medium))) @@ -582,6 +587,7 @@ (with-element "Placemark" (with-element "name" (text (or (slot-string poi 'title language nil) (slot-string poi 'title "en")))) + (kml-region (make-rectangle2 (list 0 0 +width+ +width+)) `(:min ,(poi-lod-min poi) :max -1)) (with-element "styleUrl" (text "#poiPlacemarkIcon")) (with-element "description" (cdata (poi-description-google-earth poi language))) @@ -625,5 +631,4 @@ (with-element "scale" (text "0.8")) (with-element "Icon" (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) - (kml-region (make-rectangle2 (list 0 0 +width+ +width+)) '(:min 600 :max -1)) (mapc #'(lambda (poi) (write-poi-kml poi lang)) relevant-pois))))))))

1 0

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

04 Sep '08

Revision: 3796 Author: ksprotte URL: http://bknr.net/trac/changeset/3796 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/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-09-04 17:18:31 UTC (rev 3795) +++ trunk/projects/bos/web/contract-tree.lisp 2008-09-04 17:18:33 UTC (rev 3796) @@ -370,7 +370,7 @@ ;; has already been called :base-node *quad-tree* :name '*contract-tree*)) - (dolist (contract (sort (copy-list (all-contracts)) #'> :key #'contract-area)) + (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/m2/poi.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3795 Author: ksprotte URL: http://bknr.net/trac/changeset/3795 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/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-09-04 17:18:28 UTC (rev 3794) +++ trunk/projects/bos/m2/poi.lisp 2008-09-04 17:18:31 UTC (rev 3795) @@ -107,7 +107,10 @@ :documentation "name des icons") (media :accessor poi-media :initarg :media :initform nil - :documentation "liste aller poi-medien, wie poi-image, poi-airal ..."))) + :documentation "liste aller poi-medien, wie poi-image, poi-airal ...") + (lod-min + :accessor poi-lod-min :initarg :poi-lod-min :initform 600 + :documentation "the lod minimum used in Google Earth"))) (defmethod convert-slot-value-while-restoring ((object poi) (slot-name (eql 'published)) @@ -124,7 +127,7 @@ (defmethod destroy-object :before ((poi poi)) (mapc #'delete-object (poi-media poi))) -(deftransaction update-poi (poi &key published-web published-earth icon area) +(deftransaction update-poi (poi &key published-web published-earth icon area lod-min) (check-type published-web boolean) (check-type published-earth boolean) (check-type area list) @@ -134,6 +137,8 @@ (setf (poi-icon poi) icon)) (when area (setf (poi-area poi) area)) + (when lod-min + (setf (poi-lod-min poi) (abs lod-min))) poi) (defmethod poi-complete ((poi poi) language) @@ -231,7 +236,7 @@ (format t "poi.panoramas = [ ~{~D~^, ~} ];~%" (mapcar #'store-object-id (poi-panoramas poi)))) (when (poi-movies poi) (format t "poi.movies = [ ~{~S~^, ~} ];~%" - (mapcar #'(lambda (movie) + (mapcar #'(lambda (movie) (assert (stringp (poi-movie-url movie)) nil "POI-MOVIE-URL of ~S is ~S, but should be a string" movie (poi-movie-url movie))

1 0

[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

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs