[bknr-cvs] hans changed trunk/projects/bos/m2/

[BKNR Commits]

Revision: 4105
Author: hans
URL: http://bknr.net/trac/changeset/4105

Add simple satellite map quadtree

U   trunk/projects/bos/m2/packages.lisp
A   trunk/projects/bos/m2/simple-sat-map.lisp

Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp	2008-12-01 12:33:59 UTC (rev 4104)
+++ trunk/projects/bos/m2/packages.lisp	2008-12-01 23:37:14 UTC (rev 4105)
@@ -294,3 +294,12 @@
            #: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

Added: trunk/projects/bos/m2/simple-sat-map.lisp
===================================================================
--- trunk/projects/bos/m2/simple-sat-map.lisp	                        (rev 0)
+++ trunk/projects/bos/m2/simple-sat-map.lisp	2008-12-01 23:37:14 UTC (rev 4105)
@@ -0,0 +1,61 @@
+(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 tile-source-size) (* y tile-source-size)
+                                   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))))))
\ No newline at end of file