[bknr-cvs] hans changed trunk/projects/bos/
BKNR Commits
bknr at bknr.net
Mon Dec 1 12:33:59 UTC 2008
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=~{~D~}"
- (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)
More information about the Bknr-cvs
mailing list