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

[bknr-cvs] hans changed trunk/projects/bos/
by BKNR Commits 03 Dec '08

03 Dec '08

Revision: 4110 Author: hans URL: http://bknr.net/trac/changeset/4110 more google maps goodness U trunk/projects/bos/payment-website/static/poi-ms.css 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/simple-sat-map.lisp Modified: trunk/projects/bos/payment-website/static/poi-ms.css =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-03 21:17:12 UTC (rev 4109) +++ trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-03 21:19:43 UTC (rev 4110) @@ -35,7 +35,15 @@ position: absolute; } -#google-map { +#map { +} + +#map.large { + width: 600px; + height: 600px; +} + +#map.small { width: 400px; - height: 300px; -} \ No newline at end of file + height: 150px; +} Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-03 21:17:12 UTC (rev 4109) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-03 21:19:43 UTC (rev 4110) @@ -18,6 +18,10 @@ <div id="bd"> <div id="yui-main"> <div class="yui-b" id="content"> + <div id="map"> + </div> + <div id="content-body"> + </div> </div> </div> <div class="yui-b"> @@ -29,7 +33,6 @@ <select id="poi-selector" size="1"> <option value="overview">Übersicht</option> <option value="sponsors">Sponsoren</option> - <option value="map">Google Map</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-03 21:17:12 UTC (rev 4109) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-03 21:19:43 UTC (rev 4110) @@ -5,6 +5,7 @@ var googleMapKey = "ABQIAAAA5meUSZ1F7u46UjJHEXSlJhQkkdysj0TmG3bX_n9aMEXHvIwNeRQLmdjbjYpAetJRis7naMxi-fqMRQ"; var pois = {}; var sponsors = []; +var mainMap; Date.prototype.renderDate = function() { return this.getDate() + '.' + this.getMonth() + '.' + (this.getYear() > 2000 ? this.getYear() : (1900 + this.getYear())); @@ -86,7 +87,7 @@ $('#media-list *').removeClass('active'); $(e.target).addClass('active'); - $('#content') + $('#content-body') .empty() .append(H2(null, medium.title), mediaHandlers[medium.mediumType].makeViewer(medium), @@ -118,49 +119,16 @@ return path; } -function makeMap(centerX, centerY) { - var rows = []; - - for (var y = -1; y < 3; y++) { - var tiles = []; - for (var x = -1; x < 3; x++) { - tiles.push(IMG({ 'class': 'map-tile', - src: '/overview/' - + (Math.floor(centerX / 90) + x) * 90 - + '/' - + (Math.floor(centerY / 90) + y) * 90, - width: 90, height: 90 })); - } - rows.push(DIV(null, tiles)); - } - - return DIV(null, rows); -} - -function positionMapIcon(img, x, y) { - img.style.left = (x - (Math.floor(x / 90) - 1) * 90) + 'px'; - img.style.top = (y - (Math.floor(y / 90) - 1) * 90) + 'px'; - return img; -} - function loadMainInfo(poi) { - $('#content') + $('#content-body') .empty() .append(H2(null, poi.subtitle), - DIV({ 'class': 'map' }, - makeMap(poi.x, poi.y), - positionMapIcon(IMG({ 'class': 'icon', - src: '/images/' + poi.icon + '.gif', - width: 16, height: 16}), - poi.x - 8, poi.y - 8)), P(null, poi.description)); } -function showPOI(e) { - var poi = pois[(e.target && e.target.value) || e.data]; +function showPOI(poi) { - $('#left-bar') .empty() .append(UL({ id: 'media-list' })); @@ -181,6 +149,8 @@ .bind('click', medium, showMedium)); } }, poi.media); + + mainMap.zoomTo(poi.x, poi.y); } function pointToPath(point, level) { @@ -195,19 +165,20 @@ return path; } -function showGoogleMap() { - var mapDiv = DIV({ id: 'google-map' }); - $('#content') - +function showOverview() { + $('#content-body') .empty() - .append(H2(null, NLS('Google Map')), - mapDiv); + .append(H2(null, NLS('Google Map'))); $('#left-bar') .empty(); - var map = new GMap2(mapDiv); + mainMap.overview(); +} +function Map() { + this.map = new GMap2($('#map')[0]); + var copyright = new GCopyright(1, new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), @@ -215,10 +186,10 @@ "Copyright BOS Deutschland e.V."); var copyrightCollection = new GCopyrightCollection('Map'); copyrightCollection.addCopyright(copyright); - var tileLayers = [new GTileLayer(copyrightCollection, 0, 7)]; - var projection = new GMercatorProjection(7); + var tileLayers = [new GTileLayer(copyrightCollection, 0, 12)]; + var projection = new GMercatorProjection(12); tileLayers[0].getTileUrl = function(point, level) { - if (level < 7) { + if (level < 15) { var path = pointToPath(point, level); log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); return '/simple-map/sl_utm50s-0?path=' + path; @@ -227,22 +198,63 @@ } } var customMap = new GMapType(tileLayers, projection, 'Map', { errorMessage: NLS("Keine Daten in dieser Zoomstufe") }); - map.addMapType(customMap); - map.addControl(new GLargeMapControl()); - map.setCenter(new GLatLng(0, 0), 1, customMap); + this.map.addMapType(customMap); + + this.controls = [ new GLargeMapControl() ]; + + this.addControls = function() { + for (var i in this.controls) { + this.map.addControl(this.controls[i]); + } + } + this.removeControls = function() { + for (var i in this.controls) { + this.map.removeControl(this.controls[i]); + } + } + + this.map.enableContinuousZoom(); + this.map.enableScrollWheelZoom(); + + this.overview = function() { + $('#map').removeClass('small'); + $('#map').addClass('large'); + this.addControls(); + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 2, customMap); + this.map.checkResize(); + } + + this.zoomTo = function (x, y) { + $('#map').removeClass('large'); + $('#map').addClass('small'); + this.removeControls(); + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(x, y), 6), 6); + this.map.checkResize(); + } + + this.overview(); + + function pointToLatLng(x, y) { + return projection.fromPixelToLatLng(new GPoint(x, y), 6); + } + + for (var i in pois) { + var marker = new GMarker(pointToLatLng(pois[i].x, pois[i].y)); + GEvent.addListener(marker, "click", partial(showPOI, pois[i])); + this.map.addOverlay(marker); + } } var pages = { overview: showOverview, - map: showGoogleMap } function selectPage(e) { var value = e.target.value; if (value.match(/^\d+/)) { - showPOI(e); + showPOI(pois[value]); } else if (pages[value]) { pages[value](e); } @@ -251,46 +263,11 @@ function showSponsor(e) { var sponsor = e.data; var contract = sponsor.contracts[0]; - $('#content') + $('#content-body') .empty() - .append(H2(null, sponsor.name), - DIV({ 'class': 'map' }, - makeMap(contract.left, contract.top), - positionMapIcon(IMG({ 'class': 'contract', - src: '/contract-image/' + contract.id, - width: contract.width, height: contract.height}), - contract.left, contract.top)) - ); + .append(H2(null, sponsor.name)); } -function showOverview() { - - $('#poi-selector').val('overview'); - - var elements = []; - elements.push(IMG({ src: '/infosystem/bilder/karte_uebersicht.jpg', width: 360, height: 360 })); - for (var i in pois) { - var poi = pois[i]; - var link = A({ href: '#' }, - IMG({ 'class': 'icon', - src: '/images/' + poi.icon + '.gif', - width: 16, height: 16, - title: poi.title, - style: 'left: ' + (Math.round(poi.x / 30) - 8) + 'px; ' - + 'top: ' + (Math.round(poi.y / 30) - 8) + 'px' })); - $(link).bind('click', poi.id, showPOI); - elements.push(link); - } - - $('#content') - .empty() - .append(H2(null, NLS('Übersicht')), - DIV({ 'class': 'map' }, elements)); - - $('#left-bar') - .empty(); -} - function showSponsors() { $('#left-bar') @@ -320,7 +297,7 @@ var poi_id = document.location.hash.replace(/#/, ""); if (poi_id) { - showPOI({ data: poi_id }); + showPOI(pois[poi_id]); } else { showOverview(); } @@ -339,6 +316,8 @@ } $('#poi-selector').bind('change', null, selectPage); + mainMap = new Map(); + loadJSONDoc('/sponsors-json').addCallback(loadSponsors); } catch (e) { @@ -347,7 +326,7 @@ } function init() { - $('#small-map a').bind('click', showPOI); + $('#small-map a').bind('click', showOverview); loadJSONDoc('/poi-json').addCallback(loadPOIs); } \ No newline at end of file Modified: trunk/projects/bos/web/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp 2008-12-03 21:17:12 UTC (rev 4109) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-03 21:19:43 UTC (rev 4110) @@ -10,6 +10,7 @@ (define-persistent-class tree () ((name :read) + (size :read) (root :read))) (defun tree-with-name (name) @@ -17,6 +18,13 @@ :key #'tree-name :test #'string-equal)) +(defun tree-depth (tree) + (values (- (ceiling (log (tree-size tree) 2)) 8))) + +(defmethod print-object ((tree tree) stream) + (print-store-object (tree stream :type t) + (format stream "name ~S size ~D" (tree-name tree) (tree-size tree)))) + (define-persistent-class node () ((image :read) (children :read :initform nil))) @@ -64,9 +72,41 @@ ()) (defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) - (let ((node (tree-root (tree-with-name (bknr.web:parse-url)))) - (path (or (bknr.web:query-param "path") ""))) - (dotimes (i (length path)) + (let* ((tree (tree-with-name (bknr.web:parse-url))) + (node (tree-root tree)) + (path (or (bknr.web:query-param "path") ""))) + (dotimes (i (min (length path) + (tree-depth tree))) (setf node (nth (parse-integer path :start i :end (1+ i)) (node-children node)))) - (node-image node))) + (when (> (length path) (tree-depth tree)) + (setf (hunchentoot:aux-request-value 'zoom-path) + (subseq path (tree-depth tree)))) + (node-image node))) + +(defun zoom-image (store-image zoom-path) + (let ((source-size (expt 2 (- 8 (length zoom-path)))) + (x 0) + (y 0) + (bit 128)) + (dotimes (i (length zoom-path)) + (let ((path-bits (- (char-code (aref zoom-path i)) #.(char-code #\0)))) + (when (plusp (logand 1 path-bits)) + (incf x bit)) + (when (plusp (logand 2 path-bits)) + (incf y bit)) + (setf bit (/ bit 2)))) + (bknr.images:with-store-image (source-image store-image) + (cl-gd:with-image (zoomed-image 256 256 t) + (cl-gd:copy-image source-image zoomed-image + x y + 0 0 + source-size source-size + :resize t + :dest-width 256 :dest-height 256) + (bknr.images:emit-image-to-browser zoomed-image :png))))) + +(defmethod bknr.web:handle-object ((handler simple-map-handler) image) + (if-let (zoom-path (hunchentoot:aux-request-value 'zoom-path)) + (zoom-image image zoom-path) + (call-next-method))) \ No newline at end of file

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/
by BKNR Commits 03 Dec '08

03 Dec '08

Revision: 4109 Author: hans URL: http://bknr.net/trac/changeset/4109 add print-store-object macro, fix dependencies U trunk/bknr/datastore/src/bknr.datastore.asd U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/data/package.lisp Modified: trunk/bknr/datastore/src/bknr.datastore.asd =================================================================== --- trunk/bknr/datastore/src/bknr.datastore.asd 2008-12-03 21:16:32 UTC (rev 4108) +++ trunk/bknr/datastore/src/bknr.datastore.asd 2008-12-03 21:17:12 UTC (rev 4109) @@ -22,6 +22,7 @@ :unit-test :bknr.utils :bknr.indices + :yason :trivial-utf-8) :components ((:module "data" :components ((:file "package") Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-12-03 21:16:32 UTC (rev 4108) +++ trunk/bknr/datastore/src/data/object.lisp 2008-12-03 21:17:12 UTC (rev 4109) @@ -282,6 +282,12 @@ ;; running the transaction log. (initialize-transient-instance object)) +(defmacro print-store-object ((object stream &key type) &body body) + ;; variable capture accepted here. + `(print-unreadable-object (,object ,stream :type ,type) + (format stream "ID: ~D " (store-object-id ,object)) + ,@body)) + (defmethod print-object ((object store-object) stream) (print-unreadable-object (object stream :type t) (format stream "ID: ~D" (store-object-id object)))) Modified: trunk/bknr/datastore/src/data/package.lisp =================================================================== --- trunk/bknr/datastore/src/data/package.lisp 2008-12-03 21:16:32 UTC (rev 4108) +++ trunk/bknr/datastore/src/data/package.lisp 2008-12-03 21:17:12 UTC (rev 4109) @@ -56,6 +56,7 @@ #:store-object-id #:store-object-last-change #:store-object-touch + #:print-store-object #:delete-object #:delete-objects

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/handlers.lisp
by BKNR Commits 03 Dec '08

03 Dec '08

Revision: 4108 Author: hans URL: http://bknr.net/trac/changeset/4108 adapt to current yason api U trunk/projects/quickhoney/src/handlers.lisp Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-12-02 22:16:07 UTC (rev 4107) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-12-03 21:16:32 UTC (rev 4108) @@ -45,7 +45,7 @@ () (:default-initargs :query-function #'store-image-with-name)) -(defmethod json:encode ((object symbol) stream) +(defmethod json:encode ((object symbol) &optional stream) (json:encode (string-downcase (symbol-name object)) stream)) @@ -598,4 +598,4 @@ (defmethod handle ((handler shutdown-handler)) (hunchentoot:stop-server hunchentoot:*server*) - "Shutting down HTTP server") \ No newline at end of file + "Shutting down HTTP server")

1 0

[bknr-cvs] hans changed trunk/projects/bos/
by BKNR Commits 02 Dec '08

02 Dec '08

Revision: 4107 Author: hans URL: http://bknr.net/trac/changeset/4107 fix compilation problems U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/m2/packages.lisp D trunk/projects/bos/m2/simple-sat-map.lisp U trunk/projects/bos/web/bos.web.asd U trunk/projects/bos/web/packages.lisp A trunk/projects/bos/web/simple-sat-map.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/m2/bos.m2.asd 2008-12-02 22:16:07 UTC (rev 4107) @@ -3,10 +3,18 @@ (in-package :cl-user) (asdf:defsystem :bos.m2 - :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime - :kmrcl :iterate :arnesi - :cl-pdf :cl-pdf-parser :screamer :cl-fad - :yason) + :depends-on (:bknr.datastore + :bknr.modules + :cl-smtp + :cl-mime + :kmrcl + :iterate + :arnesi + :cl-pdf + :cl-pdf-parser + :screamer + :cl-fad + :yason) :components ((:file "packages") (:file "geo-utm" :depends-on ("packages")) (:file "geometry" :depends-on ("packages")) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/m2/packages.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -293,13 +293,4 @@ #:add-area #:count-cache-entries #:pprint-cache - #:allocation-cache-subsystem)) - -(defpackage :simple-sat-map - (:use :cl - :bknr.indices - :bknr.datastore - :alexandria) - (:shadowing-import-from :alexandria #:array-index) - (:nicknames :ssm) - ) \ No newline at end of file + #:allocation-cache-subsystem)) \ No newline at end of file Deleted: trunk/projects/bos/m2/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -1,72 +0,0 @@ -(in-package :ssm) - -;; Simple Sat Map - -;; This satellite map interface works with square tiles of 256 pixels. -;; The original image is extended so that the number of pixels is a -;; power of two. The same dimensions are assumed in x and y -;; directions. It is then stored in a quad tree, with each node -;; having one image and four children. - -(define-persistent-class tree () - ((name :read) - (root :read))) - -(defun tree-with-name (name) - (find name (class-instances 'tree) - :key #'tree-name - :test #'string-equal)) - -(define-persistent-class node () - ((image :read) - (children :read :initform nil))) - -(defun import-image (image-filename &key (tile-size 256)) - (assert (= (log tile-size 2) (round (log tile-size 2))) - () "TILE-SIZE needs to be power of two") - (cl-gd:with-image-from-file (map-image image-filename) - (format t "~&; read image ~A, width ~A height ~A~%" - image-filename (cl-gd:image-width map-image) (cl-gd:image-height map-image)) - (let* ((basename (pathname-name image-filename)) - (pow (ceiling (log (max (cl-gd:image-height map-image) - (cl-gd:image-width map-image)) 2))) - (size (expt 2 pow)) - (levels (floor (- pow (log tile-size 2))))) - (format t "~&; pow ~A size ~A levels ~A~%" pow size levels) - (labels - ((write-quad (x y level) - (format t "; ~A ~A ~A~%" x y level) - (cl-gd:with-image (tile tile-size tile-size t) - (let ((tile-source-size (/ size (expt 2 level)))) - (cl-gd:copy-image map-image tile - x y - 0 0 - tile-source-size tile-source-size - :dest-width tile-size :dest-height tile-size - :resample t :resize t) - (apply #'make-instance 'node - :image (bknr.images:make-store-image :image tile - :name (format nil "~A-~A-~A-~A" - basename level x y)) - (when (< level levels) - (let ((next-tile-source-size (/ tile-source-size 2)) - (next-level (1+ level))) - (list :children - (list (write-quad x y next-level) - (write-quad (+ x next-tile-source-size) y next-level) - (write-quad x (+ y next-tile-source-size) next-level) - (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) - (make-instance 'tree - :name basename - :root (write-quad 0 0 0)))))) - -(defclass simple-map-handler (bknr.images::imageproc-handler) - ()) - -(defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) - (let ((node (tree-root (tree-with-name (bknr.web:parse-url)))) - (path (or (bknr.web:query-param "path") ""))) - (dotimes (i (length path)) - (setf node (nth (parse-integer path :start i :end (1+ i)) - (node-children node)))) - (node-image node))) Modified: trunk/projects/bos/web/bos.web.asd =================================================================== --- trunk/projects/bos/web/bos.web.asd 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/web/bos.web.asd 2008-12-02 22:16:07 UTC (rev 4107) @@ -16,7 +16,10 @@ :description "worldpay test web server" :long-description "" - :depends-on (:bknr.web :bknr.modules :bos.m2 :cxml) + :depends-on (:bknr.web + :bknr.modules + :bos.m2 + :cxml) :components ((:file "packages") (:file "utf-8" :depends-on ("packages")) @@ -25,6 +28,7 @@ (:file "web-macros" :depends-on ("packages")) (:file "web-utils" :depends-on ("packages")) (:file "cms-links" :depends-on ("packages")) + (:file "simple-sat-map" :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")) Modified: trunk/projects/bos/web/packages.lisp =================================================================== --- trunk/projects/bos/web/packages.lisp 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/web/packages.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -25,3 +25,13 @@ (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:shadowing-import-from :alexandria #:array-index) (:export)) + +(defpackage :simple-sat-map + (:use :cl + :bknr.indices + :bknr.datastore + :alexandria) + (:shadowing-import-from :alexandria #:array-index) + (:nicknames :ssm) + (:export #:simple-map-handler + #:import)) \ No newline at end of file Copied: trunk/projects/bos/web/simple-sat-map.lisp (from rev 4106, trunk/projects/bos/m2/simple-sat-map.lisp) =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp (rev 0) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -0,0 +1,72 @@ +(in-package :ssm) + +;; Simple Sat Map + +;; This satellite map interface works with square tiles of 256 pixels. +;; The original image is extended so that the number of pixels is a +;; power of two. The same dimensions are assumed in x and y +;; directions. It is then stored in a quad tree, with each node +;; having one image and four children. + +(define-persistent-class tree () + ((name :read) + (root :read))) + +(defun tree-with-name (name) + (find name (class-instances 'tree) + :key #'tree-name + :test #'string-equal)) + +(define-persistent-class node () + ((image :read) + (children :read :initform nil))) + +(defun import-image (image-filename &key (tile-size 256)) + (assert (= (log tile-size 2) (round (log tile-size 2))) + () "TILE-SIZE needs to be power of two") + (cl-gd:with-image-from-file (map-image image-filename) + (format t "~&; read image ~A, width ~A height ~A~%" + image-filename (cl-gd:image-width map-image) (cl-gd:image-height map-image)) + (let* ((basename (pathname-name image-filename)) + (pow (ceiling (log (max (cl-gd:image-height map-image) + (cl-gd:image-width map-image)) 2))) + (size (expt 2 pow)) + (levels (floor (- pow (log tile-size 2))))) + (format t "~&; pow ~A size ~A levels ~A~%" pow size levels) + (labels + ((write-quad (x y level) + (format t "; ~A ~A ~A~%" x y level) + (cl-gd:with-image (tile tile-size tile-size t) + (let ((tile-source-size (/ size (expt 2 level)))) + (cl-gd:copy-image map-image tile + x y + 0 0 + tile-source-size tile-source-size + :dest-width tile-size :dest-height tile-size + :resample t :resize t) + (apply #'make-instance 'node + :image (bknr.images:make-store-image :image tile + :name (format nil "~A-~A-~A-~A" + basename level x y)) + (when (< level levels) + (let ((next-tile-source-size (/ tile-source-size 2)) + (next-level (1+ level))) + (list :children + (list (write-quad x y next-level) + (write-quad (+ x next-tile-source-size) y next-level) + (write-quad x (+ y next-tile-source-size) next-level) + (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) + (make-instance 'tree + :name basename + :root (write-quad 0 0 0)))))) + +(defclass simple-map-handler (bknr.images::imageproc-handler) + ()) + +(defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) + (let ((node (tree-root (tree-with-name (bknr.web:parse-url)))) + (path (or (bknr.web:query-param "path") ""))) + (dotimes (i (length path)) + (setf node (nth (parse-integer path :start i :end (1+ i)) + (node-children node)))) + (node-image node))) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/web/webserver.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -183,7 +183,7 @@ ("/poi-kml-look-at" poi-kml-look-at-handler) ("/poi-kml" poi-kml-handler) ("/map-browser" map-browser-handler) - ("/simple-map" ssm::simple-map-handler) + ("/simple-map" ssm:simple-map-handler) ("/poi-javascript" poi-javascript-handler) ("/m2-javascript" m2-javascript-handler) ("/poi-json" poi-json-handler)

1 0

[bknr-cvs] hans changed trunk/projects/bos/
by BKNR Commits 02 Dec '08

02 Dec '08

Revision: 4106 Author: hans URL: http://bknr.net/trac/changeset/4106 Add satellite map browser using Google Maps. U trunk/projects/bos/m2/simple-sat-map.lisp U trunk/projects/bos/payment-website/static/poi-ms.css 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/map-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/m2/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-02 22:00:36 UTC (rev 4106) @@ -39,7 +39,7 @@ (cl-gd:with-image (tile tile-size tile-size t) (let ((tile-source-size (/ size (expt 2 level)))) (cl-gd:copy-image map-image tile - (* x tile-source-size) (* y tile-source-size) + x y 0 0 tile-source-size tile-source-size :dest-width tile-size :dest-height tile-size @@ -58,4 +58,15 @@ (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) (make-instance 'tree :name basename - :root (write-quad 0 0 0)))))) \ No newline at end of file + :root (write-quad 0 0 0)))))) + +(defclass simple-map-handler (bknr.images::imageproc-handler) + ()) + +(defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) + (let ((node (tree-root (tree-with-name (bknr.web:parse-url)))) + (path (or (bknr.web:query-param "path") ""))) + (dotimes (i (length path)) + (setf node (nth (parse-integer path :start i :end (1+ i)) + (node-children node)))) + (node-image node))) Modified: trunk/projects/bos/payment-website/static/poi-ms.css =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-02 22:00:36 UTC (rev 4106) @@ -34,3 +34,8 @@ .map .icon, .map .contract { position: absolute; } + +#google-map { + width: 400px; + height: 300px; +} \ No newline at end of file Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-02 22:00:36 UTC (rev 4106) @@ -1,4 +1,4 @@ -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd"> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> <title>POI Microsite </title> @@ -7,6 +7,7 @@ <script src="MochiKit/MochiKit.js" type="text/javascript"> </script> <script src="jquery-nightly.js" type="text/javascript"> </script> <script src="poi-ms.js" type="text/javascript"> </script> + <script src="http://maps.google.com/maps?file=api&v=2&key=ABQIAAAA5meUSZ1F7u46Uj…" type="text/javascript"> </script> <meta http-equiv="content-type" content="text/html; charset=utf-8" /> </head> <body> @@ -28,6 +29,7 @@ <select id="poi-selector" size="1"> <option value="overview">Übersicht</option> <option value="sponsors">Sponsoren</option> + <option value="map">Google Map</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 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-02 22:00:36 UTC (rev 4106) @@ -2,6 +2,7 @@ $(document).ready(init); +var googleMapKey = "ABQIAAAA5meUSZ1F7u46UjJHEXSlJhQkkdysj0TmG3bX_n9aMEXHvIwNeRQLmdjbjYpAetJRis7naMxi-fqMRQ"; var pois = {}; var sponsors = []; @@ -163,29 +164,90 @@ $('#left-bar') .empty() .append(UL({ id: 'media-list' })); - if (!poi) { - showOverview(); - } else { - $('#poi-selector').val(poi.id); + $('#poi-selector').val(poi.id); - document.title = poi.title; - $('.yui-b h1').html(poi.title); - loadMainInfo(poi); - map(function (medium) { - if (mediaHandlers[medium.mediumType]) { - $('#media-list') - .append($(A({ href: '#' }, - LI(null, - mediaHandlers[medium.mediumType].icon(medium), - (new Date(medium.timestamp)).renderDate(), - BR(), - B(null, medium.title || medium.name)))) - .bind('click', medium, showMedium)); - } - }, poi.media); + document.title = poi.title; + $('.yui-b h1').html(poi.title); + loadMainInfo(poi); + map(function (medium) { + if (mediaHandlers[medium.mediumType]) { + $('#media-list') + .append($(A({ href: '#' }, + LI(null, + mediaHandlers[medium.mediumType].icon(medium), + (new Date(medium.timestamp)).renderDate(), + BR(), + B(null, medium.title || medium.name)))) + .bind('click', medium, showMedium)); + } + }, poi.media); +} + +function pointToPath(point, level) { + var x = point.x; + var y = point.y; + var path = ''; + for (var i = 0; i < level; i++) { + path = ((x & 1) + ((y & 1) << 1)) + path; + x >>= 1; + y >>= 1; } + return path; } +function showGoogleMap() { + var mapDiv = DIV({ id: 'google-map' }); + $('#content') + + .empty() + .append(H2(null, NLS('Google Map')), + mapDiv); + + $('#left-bar') + .empty(); + + var map = new GMap2(mapDiv); + + var copyright + = new GCopyright(1, + new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), + 3, + "Copyright BOS Deutschland e.V."); + var copyrightCollection = new GCopyrightCollection('Map'); + copyrightCollection.addCopyright(copyright); + var tileLayers = [new GTileLayer(copyrightCollection, 0, 7)]; + var projection = new GMercatorProjection(7); + tileLayers[0].getTileUrl = function(point, level) { + if (level < 7) { + var path = pointToPath(point, level); + log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); + return '/simple-map/sl_utm50s-0?path=' + path; + } else { + return null; + } + } + var customMap = new GMapType(tileLayers, projection, 'Map', { errorMessage: NLS("Keine Daten in dieser Zoomstufe") }); + map.addMapType(customMap); + map.addControl(new GLargeMapControl()); + + map.setCenter(new GLatLng(0, 0), 1, customMap); +} + +var pages = { + overview: showOverview, + map: showGoogleMap +} + +function selectPage(e) { + var value = e.target.value; + + if (value.match(/^\d+/)) { + showPOI(e); + } else if (pages[value]) { + pages[value](e); + } +} + function showSponsor(e) { var sponsor = e.data; var contract = sponsor.contracts[0]; @@ -275,7 +337,7 @@ pois[poi.id] = poi; $('#poi-selector').append(OPTION({ value: poi.id }, poi.title)); } - $('#poi-selector').bind('change', null, showPOI); + $('#poi-selector').bind('change', null, selectPage); loadJSONDoc('/sponsors-json').addCallback(loadSponsors); } Modified: trunk/projects/bos/web/map-handlers.lisp =================================================================== --- trunk/projects/bos/web/map-handlers.lisp 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/web/map-handlers.lisp 2008-12-02 22:00:36 UTC (rev 4106) @@ -4,7 +4,8 @@ (defun map-navigator (x y base-url &key formcheck) (labels ((pfeil-image (name) - (html ((:img :border "0" :width "16" :height "16" :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name))))) + (html ((:img :border "0" :width "16" :height "16" + :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name))))) (td-link-to (x y name &optional (link-format (concatenate 'string base-url "~D/~D"))) (html (:td (if (or (minusp x) (minusp y) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/web/webserver.lisp 2008-12-02 22:00:36 UTC (rev 4106) @@ -183,6 +183,7 @@ ("/poi-kml-look-at" poi-kml-look-at-handler) ("/poi-kml" poi-kml-handler) ("/map-browser" map-browser-handler) + ("/simple-map" ssm::simple-map-handler) ("/poi-javascript" poi-javascript-handler) ("/m2-javascript" m2-javascript-handler) ("/poi-json" poi-json-handler)

1 0

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

01 Dec '08

Revision: 4105 Author: hans URL: http://bknr.net/trac/changeset/4105 Add simple satellite map quadtree U trunk/projects/bos/m2/packages.lisp A trunk/projects/bos/m2/simple-sat-map.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-12-01 12:33:59 UTC (rev 4104) +++ trunk/projects/bos/m2/packages.lisp 2008-12-01 23:37:14 UTC (rev 4105) @@ -294,3 +294,12 @@ #:count-cache-entries #:pprint-cache #:allocation-cache-subsystem)) + +(defpackage :simple-sat-map + (:use :cl + :bknr.indices + :bknr.datastore + :alexandria) + (:shadowing-import-from :alexandria #:array-index) + (:nicknames :ssm) + ) \ No newline at end of file Added: trunk/projects/bos/m2/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/m2/simple-sat-map.lisp (rev 0) +++ trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-01 23:37:14 UTC (rev 4105) @@ -0,0 +1,61 @@ +(in-package :ssm) + +;; Simple Sat Map + +;; This satellite map interface works with square tiles of 256 pixels. +;; The original image is extended so that the number of pixels is a +;; power of two. The same dimensions are assumed in x and y +;; directions. It is then stored in a quad tree, with each node +;; having one image and four children. + +(define-persistent-class tree () + ((name :read) + (root :read))) + +(defun tree-with-name (name) + (find name (class-instances 'tree) + :key #'tree-name + :test #'string-equal)) + +(define-persistent-class node () + ((image :read) + (children :read :initform nil))) + +(defun import-image (image-filename &key (tile-size 256)) + (assert (= (log tile-size 2) (round (log tile-size 2))) + () "TILE-SIZE needs to be power of two") + (cl-gd:with-image-from-file (map-image image-filename) + (format t "~&; read image ~A, width ~A height ~A~%" + image-filename (cl-gd:image-width map-image) (cl-gd:image-height map-image)) + (let* ((basename (pathname-name image-filename)) + (pow (ceiling (log (max (cl-gd:image-height map-image) + (cl-gd:image-width map-image)) 2))) + (size (expt 2 pow)) + (levels (floor (- pow (log tile-size 2))))) + (format t "~&; pow ~A size ~A levels ~A~%" pow size levels) + (labels + ((write-quad (x y level) + (format t "; ~A ~A ~A~%" x y level) + (cl-gd:with-image (tile tile-size tile-size t) + (let ((tile-source-size (/ size (expt 2 level)))) + (cl-gd:copy-image map-image tile + (* x tile-source-size) (* y tile-source-size) + 0 0 + tile-source-size tile-source-size + :dest-width tile-size :dest-height tile-size + :resample t :resize t) + (apply #'make-instance 'node + :image (bknr.images:make-store-image :image tile + :name (format nil "~A-~A-~A-~A" + basename level x y)) + (when (< level levels) + (let ((next-tile-source-size (/ tile-source-size 2)) + (next-level (1+ level))) + (list :children + (list (write-quad x y next-level) + (write-quad (+ x next-tile-source-size) y next-level) + (write-quad x (+ y next-tile-source-size) next-level) + (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) + (make-instance 'tree + :name basename + :root (write-quad 0 0 0)))))) \ No newline at end of file

1 0

[bknr-cvs] hans changed trunk/projects/bos/
by BKNR Commits 01 Dec '08

01 Dec '08

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)

1 0

[bknr-cvs] hans changed trunk/libraries/yason/
by BKNR Commits 01 Dec '08

01 Dec '08

Revision: 4103 Author: hans URL: http://bknr.net/trac/changeset/4103 Add methods to serialize objects and slots, moved here from application code. U trunk/libraries/yason/encode.lisp U trunk/libraries/yason/package.lisp Modified: trunk/libraries/yason/encode.lisp =================================================================== --- trunk/libraries/yason/encode.lisp 2008-11-30 10:29:40 UTC (rev 4102) +++ trunk/libraries/yason/encode.lisp 2008-12-01 12:23:46 UTC (rev 4103) @@ -47,6 +47,14 @@ (encode (float object) stream) object) +(defmethod encode ((object double-float) &optional (stream *standard-output*)) + (encode (coerce object 'single-float) stream) + object) + +(defmethod encode ((object float) &optional (stream *standard-output*)) + (princ object stream) + object) + (defmethod encode ((object integer) &optional (stream *standard-output*)) (princ object stream)) @@ -212,3 +220,19 @@ (progn ,@body) (setf (car (stack *json-output*)) #\,)))) +(defgeneric encode-slots (object) + (:method-combination progn) + (:documentation + "Generic function to encode objects. Every class in a hierarchy + implements a method for ENCODE-OBJECT that serializes its slots. + It is a PROGN generic function so that for a given instance, all + slots are serialized by invoking the ENCODE-OBJECT method for all + classes that it inherits from.")) + +(defgeneric encode-object (object) + (:documentation + "Encode OBJECT, presumably a CLOS object as a JSON object, invoking + the ENCODE-SLOTS method as appropriate.") + (:method (object) + (with-object () + (json:encode-slots object)))) \ No newline at end of file Modified: trunk/libraries/yason/package.lisp =================================================================== --- trunk/libraries/yason/package.lisp 2008-11-30 10:29:40 UTC (rev 4102) +++ trunk/libraries/yason/package.lisp 2008-12-01 12:23:46 UTC (rev 4103) @@ -23,6 +23,8 @@ ;; Basic encoder interface #:encode + #:encode-slots + #:encode-object ;; Streaming encoder interface #:with-output

1 0