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