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)