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

[bknr-cvs] hans changed trunk/projects/bos/payment-website/static/
by BKNR Commits 09 Dec '08

09 Dec '08

Revision: 4120 Author: hans URL: http://bknr.net/trac/changeset/4120 Add fake map for easier deployment. A trunk/projects/bos/payment-website/static/fake-map.jpg U trunk/projects/bos/payment-website/static/poi-ms.html U trunk/projects/bos/payment-website/static/poi-ms.js Added: trunk/projects/bos/payment-website/static/fake-map.jpg =================================================================== (Binary files differ) Property changes on: trunk/projects/bos/payment-website/static/fake-map.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-09 05:50:48 UTC (rev 4119) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-09 06:41:00 UTC (rev 4120) @@ -19,6 +19,7 @@ <div id="yui-main"> <div class="yui-b" id="content"> <div id="map"> + <img src="fake-map.jpg" width="600" height="600"/> </div> <div id="content-body"> </div> Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-09 05:50:48 UTC (rev 4119) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-09 06:41:00 UTC (rev 4120) @@ -188,6 +188,25 @@ mainMap.overview(); } +function FakeMap() { + + this.hide = function () { + $('#map').css('display', 'none'); + } + + this.overview = function () { + $('#map').css('display', 'block'); + } + + var index = 0; + for (var i in pois) { + var poi = pois[i]; + var letter = String.fromCharCode("A".charCodeAt(0) + index++); + + poi.mapIcon = "http://www.google.com/mapfiles/marker" + letter + ".png"; + } +} + function Map() { this.map = new GMap2($('#map')[0]); @@ -393,7 +412,7 @@ pois[poi.id] = poi; } - mainMap = new Map(); + mainMap = new FakeMap(); loadJSONDoc('/sponsors-json').addCallback(loadSponsors); }

1 0

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

09 Dec '08

Revision: 4119 Author: hans URL: http://bknr.net/trac/changeset/4119 Fix from Anton Vodonosov to ensure that MD5:MD5SUM-SEQUENCE is always passed a simple string. U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2008-12-08 22:05:57 UTC (rev 4118) +++ trunk/thirdparty/hunchentoot/util.lisp 2008-12-09 05:50:48 UTC (rev 4119) @@ -144,7 +144,7 @@ (defun md5-hex (string) "Calculates the md5 sum of the string STRING and returns it as a hex string." (with-output-to-string (s) - (loop for code across (md5:md5sum-sequence string) + (loop for code across (md5:md5sum-sequence (coerce string 'simple-string)) do (format s "~2,'0x" code)))) (defun escape-for-html (string)

1 0

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

08 Dec '08

Revision: 4118 Author: hans URL: http://bknr.net/trac/changeset/4118 Snapshot before designer gets the work. 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-08 15:15:24 UTC (rev 4117) +++ trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-08 22:05:57 UTC (rev 4118) @@ -4,17 +4,29 @@ ul#media-list li { position: relative; + height: 64px; + margin-left: 62px; +} + +ul#media-list li img { + position: absolute; + left: -62px; + top: 2px; +} + +ul#poi-list li { + position: relative; height: 44px; margin-left: 42px; } -ul#media-list li img { +ul#poi-list li img { position: absolute; left: -42px; top: 2px; } -ul#media-list .active { +ul#media-list .active, ul#poi-list .active { background-color: #0f0; } Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-08 15:15:24 UTC (rev 4117) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-08 22:05:57 UTC (rev 4118) @@ -30,10 +30,6 @@ <img src="/infosystem/bilder/uebersichtskarte_klein.gif" width="118" height="62"/> </a> </div> - <select id="poi-selector" size="1"> - <option value="overview">Übersicht</option> - <option value="sponsors">Sponsoren</option> - </select> <div id="left-bar"> </div> </div> Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-08 15:15:24 UTC (rev 4117) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-08 22:05:57 UTC (rev 4118) @@ -28,7 +28,7 @@ var mediaHandlers = { image: { icon: function (medium) { - return IMG({ src: '/image/' + medium.id + '/thumbnail,,40,40', width: 40, height: 40 }) + return IMG({ src: '/image/' + medium.id + '/thumbnail,,60,60', width: 60, height: 60 }) }, makeViewer: function (medium) { return IMG({ src: '/image/' + medium.id, @@ -38,7 +38,7 @@ }, panorama: { icon: function (medium) { - return IMG({ src: '/static/panorama-icon.gif', width: 40, height: 40 }) + return IMG({ src: '/static/panorama-icon.gif', width: 60, height: 60 }) }, makeViewer: function (medium) { return APPLET({ id: 'applet', @@ -52,7 +52,7 @@ }, movie: { icon: function (medium) { - return IMG({ src: '/static/movie-icon.gif', width: 40, height: 40 }) + return IMG({ src: '/static/movie-icon.gif', width: 60, height: 60 }) }, makeViewer: function (medium) { /* can't use DOM objects like below because IE does not grok it @@ -128,6 +128,9 @@ } function showPOI(poi) { + if (poi.data) { + poi = poi.data; + } $('#left-bar') .empty() @@ -140,11 +143,9 @@ map(function (medium) { if (mediaHandlers[medium.mediumType]) { $('#media-list') - .append($(A({ href: '#' }, - LI(null, + .append($(LI(null, + A({ href: '#' }, mediaHandlers[medium.mediumType].icon(medium), - (new Date(medium.timestamp)).renderDate(), - BR(), B(null, medium.title || medium.name)))) .bind('click', medium, showMedium)); } @@ -168,11 +169,22 @@ function showOverview() { $('#content-body') .empty() - .append(H2(null, NLS('Google Map'))); + .append(H2(null, NLS('Übersicht'))); $('#left-bar') - .empty(); + .empty() + .append(UL({ id: 'poi-list' })); + for (var i in pois) { + var poi = pois[i]; + $('#poi-list') + .append($(LI(null, + A({ href: '#' }, + IMG({ src: poi.mapIcon }), + B(poi.title)))) + .bind('click', poi, showPOI)); + } + mainMap.overview(); } @@ -188,7 +200,7 @@ this.layers = {}; this.makeLayer = function (name) { - var tileLayer = new GTileLayer(copyrightCollection, 0, 12); + var tileLayer = new GTileLayer(copyrightCollection, 0, 14); tileLayer.getTileUrl = function(point, level) { if (level < 15) { var path = pointToPath(point, level); @@ -202,7 +214,7 @@ return tileLayer; } - var projection = new GMercatorProjection(12); + var projection = new GMercatorProjection(14); var customMap = new GMapType( [ this.makeLayer('sat-2002'), this.makeLayer('contracts') ], @@ -223,8 +235,8 @@ } } - this.map.enableContinuousZoom(); - this.map.enableScrollWheelZoom(); +// this.map.enableContinuousZoom(); +// this.map.enableScrollWheelZoom(); this.mapClicked = function (overlay, latlng, overlaylatlng) { log('map clicked, overlay: ' + overlay + ' latlng: ' + latlng + ' overlaylatlng: ' + overlaylatlng); @@ -241,7 +253,7 @@ this.show(); $('#map').removeClass('small'); $('#map').addClass('large'); - this.addControls(); +// this.addControls(); this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 3, customMap); this.map.checkResize(); } @@ -272,9 +284,25 @@ return projection.fromPixelToLatLng(new GPoint(x, y), 6); } + var poiBaseIcon = new GIcon(G_DEFAULT_ICON); + + poiBaseIcon.shadow = "http://www.google.com/mapfiles/shadow50.png"; + poiBaseIcon.iconSize = new GSize(20, 34); + poiBaseIcon.shadowSize = new GSize(37, 34); + poiBaseIcon.iconAnchor = new GPoint(9, 34); + poiBaseIcon.infoWindowAnchor = new GPoint(9, 2); + + var index = 0; for (var i in pois) { - var marker = new GMarker(pointToLatLng(pois[i].x, pois[i].y)); - GEvent.addListener(marker, "click", partial(showPOI, pois[i])); + var poi = pois[i]; + var letter = String.fromCharCode("A".charCodeAt(0) + index++); + var letteredIcon = new GIcon(poiBaseIcon); + + poi.mapIcon = + letteredIcon.image = "http://www.google.com/mapfiles/marker" + letter + ".png"; + + var marker = new GMarker(pointToLatLng(poi.x, poi.y), { icon: letteredIcon }); + GEvent.addListener(marker, "click", partial(showPOI, poi)); this.map.addOverlay(marker); } @@ -326,8 +354,8 @@ map(function (sponsor) { $('#sponsor-list') - .append($(A({ href: '#' }, - LI(null, + .append($(LI(null, + A({ href: '#' }, IMG({ src: '/images/flags/' + sponsor.country.toLowerCase() + '.gif'}), (new Date(sponsor.contracts[0].timestamp)).renderDate(), BR(), @@ -363,9 +391,7 @@ for (var i in data.pois) { var poi = data.pois[i]; pois[poi.id] = poi; - $('#poi-selector').append(OPTION({ value: poi.id }, poi.title)); } - $('#poi-selector').bind('change', null, selectPage); mainMap = new Map(); Modified: trunk/projects/bos/web/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp 2008-12-08 15:15:24 UTC (rev 4117) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-08 22:05:57 UTC (rev 4118) @@ -8,9 +8,18 @@ ;; directions. It is then stored in a quad tree, with each node ;; having one image and four children. -(defparameter *levels* 6) -(defparameter *tree-size* 16384) -(defparameter *tile-size* 256) +(defparameter *tree-levels* 12 + "Total number of levels in the tree.") + +(defparameter *tree-size* 16384 + "Width and height of the tree's base image.") + +(defparameter *tile-size* 256 + "Width and height of the tiles in the tree.") + +(defvar *image-levels* (floor (- (log *tree-size* 2) (log *tile-size* 2))) + "Number of levels in the tree with images attached. Below that, images are zoomed.") + (defparameter *tile-pow* (floor (log *tile-size* 2))) (define-persistent-class tree () @@ -35,7 +44,7 @@ ((make-quad (x y level) (apply #'make-instance 'node :x x :y y :level level - (when (< level *levels*) + (when (< level *image-levels*) (let* ((next-level (1+ level)) (next-tile-size (/ *tree-size* (expt 2 next-level)))) (list :children @@ -55,6 +64,7 @@ (y :read) (level :read) (images :read :initform (make-hash-table)) + (contracts :read :initform nil) (children :read :initform nil))) (defun node-pixel-size (node) @@ -86,7 +96,7 @@ (cl-gd:with-image* (256 256 t) (setf (cl-gd:save-alpha-p) t) (let ((transparent (cl-gd:find-color 255 255 255 :alpha 127)) - (factor (expt 2 (- *levels* (node-level node))))) + (factor (expt 2 (- *image-levels* (node-level node))))) (cl-gd:do-rows (y) (cl-gd:do-pixels-in-row (x) (let ((m2 (find-m2 (+ (node-x node) @@ -138,7 +148,7 @@ (bknr.images:make-store-image :image tile :name image-name :if-exists :kill))) - (when (< level *levels*) + (when (< level *image-levels*) (let ((next-tile-source-size (/ tile-source-size 2)) (next-level (1+ level))) (destructuring-bind (one two three four) (node-children node) @@ -167,12 +177,12 @@ (node (tree-root tree)) (path (or (bknr.web:query-param "path") ""))) (dotimes (i (min (length path) - *levels*)) + *image-levels*)) (setf node (nth (parse-integer path :start i :end (1+ i)) (node-children node)))) - (when (> (length path) *levels*) + (when (> (length path) *image-levels*) (setf (hunchentoot:aux-request-value 'zoom-path) - (subseq path *levels*))) + (subseq path *image-levels*))) (or (node-image node layer) (when (find layer (tree-layers tree)) (transparent-image)))))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/misc.lisp
by BKNR Commits 08 Dec '08

08 Dec '08

Revision: 4117 Author: hans URL: http://bknr.net/trac/changeset/4117 Handle wildcarded filenames properly. Requests for files containing wildcard characters will be responded to with a 404 response code instead of an error. U trunk/thirdparty/hunchentoot/misc.lisp Modified: trunk/thirdparty/hunchentoot/misc.lisp =================================================================== --- trunk/thirdparty/hunchentoot/misc.lisp 2008-12-05 13:37:32 UTC (rev 4116) +++ trunk/thirdparty/hunchentoot/misc.lisp 2008-12-08 15:15:24 UTC (rev 4117) @@ -129,8 +129,9 @@ denoted by PATH. Send a content type header corresponding to CONTENT-TYPE or \(if that is NIL) tries to determine the content type via the file's suffix." - (unless (and (fad:file-exists-p path) - (not (fad:directory-exists-p path))) + (when (or (wild-pathname-p path) + (not (fad:file-exists-p path)) + (fad:directory-exists-p path)) ;; does not exist (setf (return-code) +http-not-found+) (throw 'handler-done nil))

1 0

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

05 Dec '08

Revision: 4116 Author: hans URL: http://bknr.net/trac/changeset/4116 placemark for contract U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/payment-website/static/poi-ms.js Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-12-05 12:08:08 UTC (rev 4115) +++ trunk/projects/bos/m2/m2.lisp 2008-12-05 13:37:32 UTC (rev 4116) @@ -700,13 +700,16 @@ (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) - "count" (length (contract-m2s contract)) - "top" top - "left" left - "width" width - "height" height))) + (destructuring-bind (center-x center-y) (contract-center contract) + (json:encode-object-elements + "timestamp" (format-date-time (contract-date contract) :mail-style t) + "count" (length (contract-m2s contract)) + "top" top + "left" left + "width" width + "height" height + "centerX" center-x + "centerY" center-y)))) (defmethod json:encode-slots progn ((sponsor sponsor)) (json:encode-object-elements Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-05 12:08:08 UTC (rev 4115) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-05 13:37:32 UTC (rev 4116) @@ -151,7 +151,6 @@ }, poi.media); mainMap.hide(); -// mainMap.zoomTo(poi.x, poi.y); } function pointToPath(point, level) { @@ -180,26 +179,35 @@ function Map() { this.map = new GMap2($('#map')[0]); - 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, 12)]; - var projection = new GMercatorProjection(12); - tileLayers[0].getTileUrl = function(point, level) { - if (level < 15) { - var path = pointToPath(point, level); - log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); - return '/simple-map/contracts?path=' + path; - } else { - return null; + copyrightCollection.addCopyright(new GCopyright(1, + new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), + 3, + "Copyright BOS Deutschland e.V.")); + + this.layers = {}; + + this.makeLayer = function (name) { + var tileLayer = new GTileLayer(copyrightCollection, 0, 12); + tileLayer.getTileUrl = function(point, level) { + if (level < 15) { + var path = pointToPath(point, level); +// log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); + return '/simple-map/' + name + '?path=' + path; + } else { + return null; + } } + this.layers[name] = tileLayer; + return tileLayer; } - var customMap = new GMapType(tileLayers, projection, 'Map', { errorMessage: NLS("Keine Daten in dieser Zoomstufe") }); + var projection = new GMercatorProjection(12); + var customMap = new GMapType( + [ this.makeLayer('sat-2002'), + this.makeLayer('contracts') ], + projection, 'Map', { errorMessage: NLS("Keine Daten in dieser Zoomstufe") }); + this.map.addMapType(customMap); this.controls = [ new GLargeMapControl() ]; @@ -218,6 +226,17 @@ this.map.enableContinuousZoom(); this.map.enableScrollWheelZoom(); + this.mapClicked = function (overlay, latlng, overlaylatlng) { + log('map clicked, overlay: ' + overlay + ' latlng: ' + latlng + ' overlaylatlng: ' + overlaylatlng); + } + + this.moveEnd = function () { + log('map has moved'); + } + + GEvent.addListener(this.map, "click", bind(this.mapClicked, this)); + GEvent.addListener(this.map, "moveend", bind(this.moveEnd, this)); + this.overview = function () { this.show(); $('#map').removeClass('small'); @@ -227,7 +246,7 @@ this.map.checkResize(); } - this.zoomTo = function (x, y) { + this.poiDetail = function (x, y) { $('#map').removeClass('large'); $('#map').addClass('small'); this.removeControls(); @@ -235,6 +254,10 @@ this.map.checkResize(); } + this.zoomTo = function (x, y, level) { + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(x, y), 6), level); + } + this.hide = function () { $('#map').css('display', 'none'); } @@ -254,10 +277,21 @@ GEvent.addListener(marker, "click", partial(showPOI, pois[i])); this.map.addOverlay(marker); } + + this.setSponsorMarker = function (sponsor) { + var position = pointToLatLng(sponsor.contracts[0].centerX, sponsor.contracts[0].centerY); + if (this.sponsorMarker) { + this.sponsorMarker.setLatLng(position); + } else { + this.sponsorMarker = new GMarker(position); + this.map.addOverlay(this.sponsorMarker); + } + } } var pages = { overview: showOverview, + sponsors: showSponsors } function selectPage(e) { @@ -276,6 +310,11 @@ $('#content-body') .empty() .append(H2(null, sponsor.name)); + + mainMap.zoomTo(contract.left, contract.top, 8); + mainMap.setSponsorMarker(sponsor); + + // Math.max(contract.width, contract.height) } function showSponsors() { @@ -296,6 +335,8 @@ " ", sponsor.contracts[0].count, " m²"))) .bind('click', sponsor, showSponsor)); }, sponsors.slice(0, 10)); + + mainMap.overview(); } function loadSponsors(data) {

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/images/image.lisp
by BKNR Commits 05 Dec '08

05 Dec '08

Revision: 4115 Author: hans URL: http://bknr.net/trac/changeset/4115 Only try to delete old blob file if it exists. U trunk/bknr/web/src/images/image.lisp Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-12-05 11:27:44 UTC (rev 4114) +++ trunk/bknr/web/src/images/image.lisp 2008-12-05 12:08:08 UTC (rev 4115) @@ -77,7 +77,8 @@ (:supersede (delete-object existing-image)) (:kill - (delete-file (blob-pathname existing-image)) + (when (probe-file (blob-pathname existing-image)) + (delete-file (blob-pathname existing-image))) (delete-object existing-image)))) (let ((store-image (apply #'make-instance class-name

1 0

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

05 Dec '08

Revision: 4114 Author: hans URL: http://bknr.net/trac/changeset/4114 Contract rendering works now. 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.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-05 09:49:44 UTC (rev 4113) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-05 11:27:44 UTC (rev 4114) @@ -193,7 +193,7 @@ if (level < 15) { var path = pointToPath(point, level); log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); - return '/simple-map/sat-2002?path=' + path; + return '/simple-map/contracts?path=' + path; } else { return null; } @@ -223,7 +223,7 @@ $('#map').removeClass('small'); $('#map').addClass('large'); this.addControls(); - this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 2, customMap); + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 3, customMap); this.map.checkResize(); } Modified: trunk/projects/bos/web/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp 2008-12-05 09:49:44 UTC (rev 4113) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-05 11:27:44 UTC (rev 4114) @@ -8,9 +8,19 @@ ;; directions. It is then stored in a quad tree, with each node ;; having one image and four children. +(defparameter *levels* 6) +(defparameter *tree-size* 16384) +(defparameter *tile-size* 256) +(defparameter *tile-pow* (floor (log *tile-size* 2))) + (define-persistent-class tree () - ((root :read))) + ((root :read) + (layers :read :initform nil))) +(defmethod print-object ((tree tree) stream) + (print-store-object (tree stream :type t) + (format stream "LAYERS: ~S" (tree-layers tree)))) + (defmethod destroy-object :before ((tree tree)) (labels ((descend (node) @@ -20,43 +30,91 @@ (delete-object node))) (descend (tree-root tree)))) -(defparameter *levels* 6) -(defparameter *tree-size* 16384) -(defparameter *tile-size* 256) - (defun make-tree () (labels - ((make-quad (level) + ((make-quad (x y level) (apply #'make-instance 'node + :x x :y y :level level (when (< level *levels*) - (let ((next-level (1+ level))) + (let* ((next-level (1+ level)) + (next-tile-size (/ *tree-size* (expt 2 next-level)))) (list :children - (list (make-quad next-level) - (make-quad next-level) - (make-quad next-level) - (make-quad next-level)))))))) + (list (make-quad x y next-level) + (make-quad (+ x next-tile-size) y next-level) + (make-quad x (+ y next-tile-size) next-level) + (make-quad (+ x next-tile-size) (+ y next-tile-size) next-level)))))))) (make-instance 'tree - :root (make-quad 0)))) + :root (make-quad 0 0 0)))) (defun get-tree () (or (first (class-instances 'tree)) (make-tree))) (define-persistent-class node () - ((images :read :initform (make-hash-table :test #'equal)) + ((x :read) + (y :read) + (level :read) + (images :read :initform (make-hash-table)) (children :read :initform nil))) +(defun node-pixel-size (node) + (/ *tree-size* (expt 2 (node-level node)) 256)) + +(defun node-size (node) + (/ *tree-size* (expt 2 (node-level node)))) + +(defmethod print-object ((node node) stream) + (print-store-object (node stream :type t) + (format stream "X: ~A Y: ~A LEVEL: ~A IMAGES: ~A CHILDREN: ~:[NO~;YES~]" + (node-x node) (node-y node) (node-level node) + (loop for layer being the hash-keys of (node-images node) + collect layer) + (node-children node)))) + (defmethod destroy-object :before ((node node)) (loop for image being the hash-values of (node-images node) do (unless (object-destroyed-p image) (delete-object image)))) -(defun node-image (node layer-name) - (gethash layer-name (node-images node))) +(defun find-m2 (x y) + (when (and (< x bos.m2.config:+width+) + (< y bos.m2.config:+width+)) + (bos.m2:get-m2 x y))) +(defun generate-contract-image (node) + (cl-gd:with-image* (256 256 t) + (setf (cl-gd:save-alpha-p) t) + (let ((transparent (cl-gd:find-color 255 255 255 :alpha 127)) + (factor (expt 2 (- *levels* (node-level node))))) + (cl-gd:do-rows (y) + (cl-gd:do-pixels-in-row (x) + (let ((m2 (find-m2 (+ (node-x node) + (* x factor)) + (+ (node-y node) + (* y factor))))) + (setf (cl-gd:raw-pixel) + (if (and m2 (bos.m2:m2-contract m2)) + (apply #'cl-gd:find-color (bos.m2:contract-color (bos.m2:m2-contract m2))) + transparent)))))) + (with-transaction (:generate-contract-image) + (setf (node-image node :contracts) + (bknr.images:make-store-image :name (format nil "contracts-~A-~A-~A" + (node-level node) + (node-x node) + (node-y node)) + :if-exists :kill))))) + +(defgeneric node-image (node layer-name) + (:method (node layer-name) + (gethash (find-keyword layer-name) (node-images node))) + (:method (node (layer-name (eql :contracts))) + (or (call-next-method) + (generate-contract-image node)))) + (defun (setf node-image) (new-image node layer-name) - (setf (gethash layer-name (node-images node)) new-image)) + (pushnew layer-name (slot-value (get-tree) 'layers)) + (setf (gethash (find-keyword layer-name) (node-images node)) new-image)) (defun import-image (image-filename layer-name) (cl-gd:with-image-from-file (map-image image-filename) @@ -75,11 +133,11 @@ tile-source-size tile-source-size :dest-width *tile-size* :dest-height *tile-size* :resample t :resize t) - (when-let (old-image (bknr.images:store-image-with-name image-name)) - (delete-object old-image)) - (setf (node-image node layer-name) - (bknr.images:make-store-image :image tile - :name image-name)) + (with-transaction (:make-tile) + (setf (node-image node layer-name) + (bknr.images:make-store-image :image tile + :name image-name + :if-exists :kill))) (when (< level *levels*) (let ((next-tile-source-size (/ tile-source-size 2)) (next-level (1+ level))) @@ -100,8 +158,11 @@ (defclass simple-map-handler (bknr.images::imageproc-handler) ()) +(defun find-keyword (name) + (find-symbol (string-upcase (string name)) :keyword)) + (defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) - (let* ((layer (bknr.web:parse-url)) + (let* ((layer (find-keyword (bknr.web:parse-url))) (tree (get-tree)) (node (tree-root tree)) (path (or (bknr.web:query-param "path") ""))) @@ -113,7 +174,8 @@ (setf (hunchentoot:aux-request-value 'zoom-path) (subseq path *levels*))) (or (node-image node layer) - (transparent-image)))) + (when (find layer (tree-layers tree)) + (transparent-image))))) (defun zoom-image (store-image zoom-path) (let ((source-size (floor (expt 2 (- (log *tile-size* 2) (length zoom-path))))) @@ -128,17 +190,47 @@ (incf y bit)) (setf bit (/ bit 2)))) (bknr.images:with-store-image (source-image store-image) - (cl-gd:with-image (zoomed-image *tile-size* *tile-size* t) - (cl-gd:copy-image source-image zoomed-image + (cl-gd:with-image* (*tile-size* *tile-size* t) + (setf (cl-gd:save-alpha-p) t) + (cl-gd:fill-image 0 0 :color (cl-gd:find-color 255 255 255 :alpha 127)) + (cl-gd:copy-image source-image cl-gd:*default-image* x y 0 0 source-size source-size :resize t :dest-width *tile-size* :dest-height *tile-size*) - (bknr.images:emit-image-to-browser zoomed-image :png))))) + (bknr.images:emit-image-to-browser cl-gd:*default-image* :png))))) (defmethod bknr.web:handle-object ((handler simple-map-handler) (image bknr.images:store-image)) (if-let (zoom-path (hunchentoot:aux-request-value 'zoom-path)) (zoom-image image zoom-path) (call-next-method))) +(defun contracts-changed (tree contract &key type) + (declare (ignore type tree)) + (destructuring-bind (width height) (cddr (bos.m2:contract-bounding-box contract)) + (let ((contract-size (max width height))) + (labels + ((recur (node) + (when (>= contract-size (node-pixel-size node)) + ;; contract is likely to be visible at this resolution, remove tile images so that they are regenerated + (when-let (image (gethash :contracts (node-images node))) + (format t "; contract image of ~A deleted~%" node) + (delete-file (blob-pathname image)) + (delete-object image) + (setf (node-image node :contracts) nil))) + (dolist (child (node-children node)) + (when (geometry:rectangle-intersects-p (bos.m2:contract-bounding-box contract) + (list (node-x child) (node-y child) + (node-size child) (node-size child))) + (recur child))))) + (recur (tree-root (get-tree))))))) + +(defun init-simple-sat-map () + (geometry:register-rect-subscriber geometry:*rect-publisher* + 'tree + (list 0 0 bos.m2.config:+width+ bos.m2.config:+width+) + 'contracts-changed)) + +(bos.m2:register-transient-init-function 'init-simple-sat-map + 'geometry:make-rect-publisher) \ No newline at end of file

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/images/image.lisp
by BKNR Commits 05 Dec '08

05 Dec '08

Revision: 4113 Author: hans URL: http://bknr.net/trac/changeset/4113 Add new :IF-EXISTS keyword argument to MAKE-STORE-IMAGE that can be set to control whether an existing image of the same name should be overwritten. U trunk/bknr/web/src/images/image.lisp Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-12-04 15:02:57 UTC (rev 4112) +++ trunk/bknr/web/src/images/image.lisp 2008-12-05 09:49:44 UTC (rev 4113) @@ -65,12 +65,20 @@ name (type :png) directory keywords + (if-exists :error) (class-name 'store-image) initargs) (unless (scan #?r"\D" name) (error "invalid image name ~A, needs to contain at least one non-digit character" name)) - (when (store-image-with-name name) - (error "can't make image with name ~A, an image with this name already exists in the datastore" name)) + (when-let (existing-image (store-image-with-name name)) + (ecase if-exists + (:error + (error "can't make image with name ~A, an image with this name already exists in the datastore" name)) + (:supersede + (delete-object existing-image)) + (:kill + (delete-file (blob-pathname existing-image)) + (delete-object existing-image)))) (let ((store-image (apply #'make-instance class-name :name name

1 0

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

04 Dec '08

Revision: 4112 Author: hans URL: http://bknr.net/trac/changeset/4112 Support multiple layers in simple map tree. Hide map when displaying POI 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.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-03 22:48:32 UTC (rev 4111) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-04 15:02:57 UTC (rev 4112) @@ -150,7 +150,8 @@ } }, poi.media); - mainMap.zoomTo(poi.x, poi.y); + mainMap.hide(); +// mainMap.zoomTo(poi.x, poi.y); } function pointToPath(point, level) { @@ -192,7 +193,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; + return '/simple-map/sat-2002?path=' + path; } else { return null; } @@ -217,7 +218,8 @@ this.map.enableContinuousZoom(); this.map.enableScrollWheelZoom(); - this.overview = function() { + this.overview = function () { + this.show(); $('#map').removeClass('small'); $('#map').addClass('large'); this.addControls(); @@ -233,6 +235,14 @@ this.map.checkResize(); } + this.hide = function () { + $('#map').css('display', 'none'); + } + + this.show = function () { + $('#map').css('display', 'block'); + } + this.overview(); function pointToLatLng(x, y) { Modified: trunk/projects/bos/web/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp 2008-12-03 22:48:32 UTC (rev 4111) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-04 15:02:57 UTC (rev 4112) @@ -9,83 +9,114 @@ ;; having one image and four children. (define-persistent-class tree () - ((name :read) - (size :read) - (root :read))) + ((root :read))) -(defun tree-with-name (name) - (find name (class-instances 'tree) - :key #'tree-name - :test #'string-equal)) +(defmethod destroy-object :before ((tree tree)) + (labels + ((descend (node) + (when (node-children node) + (dolist (child (node-children node)) + (descend child))) + (delete-object node))) + (descend (tree-root tree)))) -(defun tree-depth (tree) - (values (- (ceiling (log (tree-size tree) 2)) 8))) +(defparameter *levels* 6) +(defparameter *tree-size* 16384) +(defparameter *tile-size* 256) -(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)))) +(defun make-tree () + (labels + ((make-quad (level) + (apply #'make-instance 'node + (when (< level *levels*) + (let ((next-level (1+ level))) + (list :children + (list (make-quad next-level) + (make-quad next-level) + (make-quad next-level) + (make-quad next-level)))))))) + (make-instance 'tree + :root (make-quad 0)))) +(defun get-tree () + (or (first (class-instances 'tree)) + (make-tree))) + (define-persistent-class node () - ((image :read) + ((images :read :initform (make-hash-table :test #'equal)) (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") +(defmethod destroy-object :before ((node node)) + (loop + for image being the hash-values of (node-images node) + do (unless (object-destroyed-p image) + (delete-object image)))) + +(defun node-image (node layer-name) + (gethash layer-name (node-images node))) + +(defun (setf node-image) (new-image node layer-name) + (setf (gethash layer-name (node-images node)) new-image)) + +(defun import-image (image-filename layer-name) (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) + (let* ((basename (pathname-name image-filename))) (labels - ((write-quad (x y level) + ((make-image (node 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:with-image (tile *tile-size* *tile-size* t) + (let ((tile-source-size (/ *tree-size* (expt 2 level))) + (image-name (format nil "~A-~A-~A-~A" basename level x y))) (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 + :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)))))) + (when-let (old-image (bknr.images:store-image-with-name image-name)) + (delete-object old-image)) + (setf (node-image node layer-name) + (bknr.images:make-store-image :image tile + :name image-name)) + (when (< level *levels*) + (let ((next-tile-source-size (/ tile-source-size 2)) + (next-level (1+ level))) + (destructuring-bind (one two three four) (node-children node) + (make-image one x y next-level) + (make-image two (+ x next-tile-source-size) y next-level) + (make-image three x (+ y next-tile-source-size) next-level) + (make-image four (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))) + (make-image (tree-root (get-tree)) 0 0 0))))) +(defun transparent-image () + (or (bknr.images:store-image-with-name "transparent") + (cl-gd:with-image* (*tile-size* *tile-size* nil) + (setf (cl-gd:transparent-color) + (cl-gd:allocate-color 0 0 0 :alpha 127)) + (bknr.images:make-store-image :name "transparent" :type :gif)))) + (defclass simple-map-handler (bknr.images::imageproc-handler) ()) (defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) - (let* ((tree (tree-with-name (bknr.web:parse-url))) + (let* ((layer (bknr.web:parse-url)) + (tree (get-tree)) (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)))) - (when (> (length path) (tree-depth tree)) - (setf (hunchentoot:aux-request-value 'zoom-path) - (subseq path (tree-depth tree)))) - (node-image node))) + (dotimes (i (min (length path) + *levels*)) + (setf node (nth (parse-integer path :start i :end (1+ i)) + (node-children node)))) + (when (> (length path) *levels*) + (setf (hunchentoot:aux-request-value 'zoom-path) + (subseq path *levels*))) + (or (node-image node layer) + (transparent-image)))) (defun zoom-image (store-image zoom-path) - (let ((source-size (expt 2 (- 8 (length zoom-path)))) + (let ((source-size (floor (expt 2 (- (log *tile-size* 2) (length zoom-path))))) (x 0) (y 0) (bit 128)) @@ -97,16 +128,17 @@ (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:with-image (zoomed-image *tile-size* *tile-size* 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) + :dest-width *tile-size* :dest-height *tile-size*) (bknr.images:emit-image-to-browser zoomed-image :png))))) -(defmethod bknr.web:handle-object ((handler simple-map-handler) image) +(defmethod bknr.web:handle-object ((handler simple-map-handler) (image bknr.images:store-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 + (call-next-method))) +

1 0

[bknr-cvs] hans changed trunk/libraries/ccl-profiler/
by BKNR Commits 03 Dec '08

03 Dec '08

Revision: 4111 Author: hans URL: http://bknr.net/trac/changeset/4111 This lives in the CCL svn D trunk/libraries/ccl-profiler/

1 0