[bknr-cvs] hans changed trunk/projects/bos/
BKNR Commits
bknr at bknr.net
Thu Dec 4 15:02:58 UTC 2008
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)))
+
More information about the Bknr-cvs
mailing list