[bknr-cvs] hans changed trunk/projects/bos/
BKNR Commits
bknr at bknr.net
Tue Dec 2 22:16:07 UTC 2008
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)
More information about the Bknr-cvs
mailing list