Revision: 4104 Author: hans URL: http://bknr.net/trac/changeset/4104
Refactor sat-tree handler. Move to new JSON object serialization API. Experiment with satellite image in JS.
U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/payment-website/static/poi-ms.html U trunk/projects/bos/payment-website/static/poi-ms.js U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/sat-tree.lisp U trunk/projects/bos/web/webserver.lisp
Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/m2/m2.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -698,7 +698,7 @@ left top width height (format-date-time (contract-date contract) :show-time nil))))))
-(defmethod json-encode progn ((contract contract)) +(defmethod json:encode-slots progn ((contract contract)) (destructuring-bind (left top width height) (contract-bounding-box contract) (json:encode-object-elements "timestamp" (format-date-time (contract-date contract) :mail-style t) @@ -708,7 +708,7 @@ "width" width "height" height)))
-(defmethod json-encode progn ((sponsor sponsor)) +(defmethod json:encode-slots progn ((sponsor sponsor)) (json:encode-object-elements "name" (user-full-name sponsor) "country" (or (sponsor-country sponsor) "sponsor-country-unknown") @@ -718,15 +718,13 @@ (json:with-object-element ("contracts") (json:with-array () (dolist (contract (sponsor-paid-contracts sponsor)) - (json:with-object () - (json-encode contract)))))) + (json:encode-object contract)))))
(defun sponsors-as-json (sponsors) "Render the SPONSORS as JSON" (json:with-array () (dolist (sponsor sponsors) - (json:with-object () - (json-encode sponsor))))) + (json:encode-object sponsor))))
(defun delete-directory (pathname) (cl-fad:delete-directory-and-files pathname :if-does-not-exist :ignore))
Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/m2/poi.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -303,55 +303,50 @@ (defmethod json:encode ((object symbol) &optional stream) (json:encode (string-downcase (symbol-name object)) stream))
-(defgeneric json-encode (object) - (:method-combination progn)) - -(defmethod json-encode progn ((object store-object)) +(defmethod json:encode-slots progn ((object store-object)) (json:encode-object-element "id" (store-object-id object)))
-(defmethod json-encode progn ((poi poi)) +(defmethod json:encode-slots progn ((poi poi)) (json:encode-object-elements "name" (poi-name poi) "icon" (poi-icon poi) "x" (poi-center-x poi) - "y" (poi-center-y poi))) + "y" (poi-center-y poi)) + (json:with-object-element ("media") + (json:with-array () + (dolist (medium (poi-media poi)) + (json:encode-object medium)))))
-(defmethod json-encode progn ((blob blob)) +(defmethod json:encode-slots progn ((blob blob)) (json:encode-object-elements "type" (blob-type blob) "timestamp" (format-date-time (blob-timestamp blob) :mail-style t)))
-(defmethod json-encode progn ((image store-image)) +(defmethod json:encode-slots progn ((image store-image)) (json:encode-object-elements "name" (store-image-name image) "width" (store-image-width image) "height" (store-image-height image)))
-(defmethod json-encode progn ((object bos.m2::textual-attributes-mixin)) +(defmethod json:encode-slots progn ((object bos.m2::textual-attributes-mixin)) (dolist (field '(title subtitle description)) (let ((string (slot-string object field *language*))) (unless (equal "" string) (json:encode-object-element field string)))))
-(defmethod json-encode progn ((medium poi-medium)) +(defmethod json:encode-slots progn ((medium poi-medium)) (json:encode-object-element "mediumType" (cl-ppcre:regex-replace "^poi-" (string-downcase (class-name (class-of medium))) "")))
-(defmethod json-encode progn ((movie poi-movie)) +(defmethod json:encode-slots progn ((movie poi-movie)) (json:encode-object-elements "url" (poi-movie-url movie) "timestamp" (format-date-time (poi-medium-creation-time movie) :mail-style t)))
(defun poi-as-json (poi language) (let ((*language* language)) - (json:with-object () - (json-encode poi) - (json:with-object-element ("media") - (json:with-array () - (dolist (medium (poi-media poi)) - (json:with-object () - (json-encode medium)))))))) + (json:encode-object poi)))
(defun pois-as-json (language) (json:with-array ()
Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-01 12:33:59 UTC (rev 4104) @@ -26,7 +26,8 @@ </a> </div> <select id="poi-selector" size="1"> - <option value="overview">Überblick</option> + <option value="overview">Übersicht</option> + <option value="sponsors">Sponsoren</option> </select> <div id="left-bar"> </div>
Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-01 12:33:59 UTC (rev 4104) @@ -13,6 +13,10 @@ return key; // for now }
+function log2(x) { + return Math.log(x) / Math.LN2; +} + var B = createDOMFunc('b', null); var OBJECT = createDOMFunc('object'); var PARAM = createDOMFunc('param'); @@ -89,6 +93,30 @@ P(null, medium.description)); }
+var SAT_MAP_SIZE = 28800; + +function makePath(size, x, y) { + var depth = log2(SAT_MAP_SIZE / size); + var path = ''; + var xPos = 0; + var yPos = 0; + var currentSize = SAT_MAP_SIZE; + for (var i = 0; i < Math.min(depth, 6); i++) { + currentSize /= 2; + var index + = ((x > (xPos + currentSize)) ? 1 : 0) + + ((y > (yPos + currentSize)) ? 2 : 0); + if (index & 1) { + xPos += currentSize; + } + if (index & 2) { + yPos += currentSize; + } + path += index; + } + return path; +} + function makeMap(centerX, centerY) { var rows = [];
@@ -198,6 +226,12 @@ DIV({ 'class': 'map' }, elements));
$('#left-bar') + .empty(); +} + +function showSponsors() { + + $('#left-bar') .empty() .append(H3(NLS("Letzte Sponsoren")), UL({ id: 'sponsor-list' }));
Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -696,4 +696,4 @@ (poi-handle-if-modified-since) (with-json-response () (json:with-object-element ("pois") - (bos.m2:pois-as-json (request-language))))) \ No newline at end of file + (bos.m2:pois-as-json (request-language)))))
Modified: trunk/projects/bos/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/web/sat-tree.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/web/sat-tree.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -3,6 +3,16 @@ (defclass sat-node (node-extension) ((image :accessor image :initarg :image)))
+(defmethod json:encode-slots progn ((sat-node sat-node)) + (json:with-object-element ("satImage") + (json:encode-object (image sat-node))) + (json:with-object-element ("children") + (json:with-array () + (dotimes (i 4) + (json:encode-array-element + (when (child sat-node i) + (store-object-id (image (child sat-node i))))))))) + (defpersistent-class sat-layer () ((name :reader name :initarg :name :index-type unique-index @@ -66,6 +76,16 @@ :type geo-box :documentation "can be different from base-node's geo-box")))
+(defmethod json:encode-slots progn ((sat-image sat-image)) + (json:encode-object-element "path" (path sat-image)) + (json:with-object-element ("geoBox") + (json:with-array () + (json:encode-array-elements + (aref (image-geo-box sat-image) 0) + (aref (image-geo-box sat-image) 1) + (aref (image-geo-box sat-image) 2) + (aref (image-geo-box sat-image) 3))))) + (defmethod print-object ((obj sat-image) stream) (print-unreadable-object (obj stream :type t :identity t) (format stream "~s of layer ~s" (path obj) (name (layer obj))))) @@ -202,50 +222,64 @@
;;; handlers
-(defclass sat-tree-kml-handler (page-handler) +(defclass sat-node-handler (object-handler) ())
-(defmethod handle ((handler sat-tree-kml-handler)) - (with-query-params ((path) (name)) - (let ((path (parse-path path)) - (layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD"))))) - (assert layer nil "Cannnot find layer of name ~s." name) - (let* ((quad-node (find-node-with-path *quad-tree* path)) - (sat-node (find-if (lambda (e) (and (eql (name e) (name layer)) - (typep e 'sat-node))) - (extensions quad-node)))) - (assert sat-node nil "There is no sat-node of name ~s at path ~s." name path) - (let ((sat-image (image sat-node))) - (hunchentoot:handle-if-modified-since (blob-timestamp sat-image)) - (with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml" - :root-element "kml") - (setf (hunchentoot:header-out :last-modified) - (hunchentoot:rfc-1123-date (blob-timestamp sat-image))) - (let ((lod (node-lod sat-node)) - (rect (geo-box-rectangle (geo-box sat-node)))) - (with-element "Document" - (kml-region rect lod) - (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id sat-image)) - (geo-box-rectangle (image-geo-box sat-image)) - :draw-order (compute-draw-order sat-node (local-draw-order layer)) - ;; :absolute 0 - ) - (let ((*print-case* :downcase)) - (dotimes (i 4) - (let ((child (child sat-node i))) - (when child - (kml-network-link (format nil "http://~A/sat-tree-kml?name=~A&path=~%7B~D~%7D" - (website-host) (name layer) (append path (list i))) - :rect (geo-box-rectangle (geo-box child)) - :lod (node-lod child)))))))))))))) +(defmethod object-handler-get-object ((handler sat-node-handler)) + (with-query-params (path name) + (let* ((path (parse-path path)) + (layer (or (find-sat-layer (make-keyword-from-string name)) + (error "Cannnot find layer of name ~s." name))) + (quad-node (find-node-with-path *quad-tree* path)) + (sat-node (find-if (lambda (e) + (and (eql (name e) (name layer)) + (typep e 'sat-node))) + (extensions quad-node)))) + (assert sat-node nil "There is no sat-node of name ~s at path ~s." name path) + sat-node)))
+(defmethod handle-object :before ((handler sat-node-handler) sat-node) + (hunchentoot:handle-if-modified-since (blob-timestamp (image sat-node))) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date (blob-timestamp (image sat-node))))) + +(defclass sat-tree-kml-handler (sat-node-handler) + ()) + +(defmethod handle-object ((handler sat-tree-kml-handler) sat-node) + (with-query-params (path name) + (with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml" + :root-element "kml") + (with-element "Document" + (kml-region (geo-box-rectangle (geo-box sat-node)) (node-lod sat-node)) + (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id (image sat-node))) + (geo-box-rectangle (image-geo-box (image sat-node))) + :draw-order (compute-draw-order sat-node + (local-draw-order (find-sat-layer (make-keyword-from-string name)))) + ;; :absolute 0 + ) + (dotimes (i 4) + (when-let (child (child sat-node i)) + (kml-network-link (format nil "~(http://~A/sat-tree-kml?name=~A&path=~A~A~)" + (website-host) name path i) + :rect (geo-box-rectangle (geo-box child)) + :lod (node-lod child)))))))) + +(defclass sat-tree-json-handler (sat-node-handler) + ()) + +(defmethod handle-object ((handler sat-tree-json-handler) sat-node) + (with-json-response () + (json:with-object-element ("satNode") + (json:encode-object sat-node)))) + (defclass sat-root-kml-handler (page-handler) ())
(defmethod handle ((handler sat-root-kml-handler)) (with-query-params ((name)) (let ((*print-case* :downcase) - (layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD"))))) + (layer (find-sat-layer (make-keyword-from-string name)))) (assert layer nil "Cannnot find layer of name ~s." name) (let ((top-level-nodes (sat-layer-top-level-nodes layer))) (assert top-level-nodes)
Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/web/webserver.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -170,6 +170,7 @@ ("/contract-image" contract-image-handler) ("/contract" contract-handler) ("/sat-tree-kml" sat-tree-kml-handler) + ("/sat-tree-json" sat-tree-json-handler) ("/sat-root-kml" sat-root-kml-handler) ("/look-at-allocation-area" look-at-allocation-area-handler) ("/reports-xml" reports-xml-handler)