[bknr-cvs] ksprotte changed trunk/projects/bos/web/
BKNR Commits
bknr at bknr.net
Thu Jul 17 15:17:01 UTC 2008
Revision: 3492
Author: ksprotte
URL: http://bknr.net/trac/changeset/3492
removed obsolete image-tree from bos - step 1
U trunk/projects/bos/web/image-tree.lisp
U trunk/projects/bos/web/kml-handlers.lisp
U trunk/projects/bos/web/webserver.lisp
Modified: trunk/projects/bos/web/image-tree.lisp
===================================================================
--- trunk/projects/bos/web/image-tree.lisp 2008-07-17 14:48:01 UTC (rev 3491)
+++ trunk/projects/bos/web/image-tree.lisp 2008-07-17 15:17:01 UTC (rev 3492)
@@ -312,371 +312,3 @@
;; end kml utils
-(defvar *image-tree-node-counter*)
-
-(defmacro with-image-tree-node-counter (&body body)
- "Allows to call IMAGE-TREE-NODE-UNIQUE-NAME in BODY."
- `(let ((*image-tree-node-counter* -1))
- , at body))
-
-(defun image-tree-node-unique-name ()
- "Generates a unique name for an image-tree-node."
- (format nil "image-tree-~a-~a-~a" (get-universal-time) (random 10000) (incf *image-tree-node-counter*)))
-
-(defpersistent-class image-tree-node (store-image)
- ((geo-x :initarg :geo-x :reader geo-x)
- (geo-y :initarg :geo-y :reader geo-y)
- (geo-width :initarg :geo-width :reader geo-width)
- (geo-height :initarg :geo-height :reader geo-height)
- (children :initarg :children :reader children)
- (parent :reader parent)
- (depth :accessor depth :initarg :depth))
- (:documentation "Derived from STORE-IMAGE, IMAGE-TREE-NODE is an
-image itself, which has additional information, like its
-geo-location. It also knows about its position in the tree; being at a
-certain DEPTH and pointing to its PARENT and its CHILDREN."))
-
-(defpersistent-class image-tree (image-tree-node)
- ((parent :initform nil))
- (:documentation "IMAGE-TREE is the root node of IMAGE-TREE-NODEs."))
-
-(defmethod print-object ((object image-tree-node) stream)
- (print-unreadable-object (object stream :type t)
- (format stream "ID: ~A (~A x ~A)"
- (store-object-id object)
- (store-image-width object)
- (store-image-height object))))
-
-(defmethod initialize-persistent-instance :after ((obj image-tree-node))
- ;; initialize the parent slot
- (dolist (child (children obj))
- (setf (slot-value child 'parent) obj)))
-
-(defmethod geo-location ((obj image-tree-node))
- (list (geo-x obj) (geo-y obj) (geo-width obj) (geo-height obj)))
-
-(defun make-image-tree-node (image &key geo-rect children
- (class-name 'image-tree-node)
- depth)
- (destructuring-bind (geo-x geo-y geo-width geo-height)
- geo-rect
- (make-store-image :image image
- :name (image-tree-node-unique-name)
- :class-name class-name
- :initargs `(:geo-x ,geo-x
- :geo-y ,geo-y
- :geo-width ,geo-width
- :geo-height ,geo-height
- :children ,children
- :depth ,depth))))
-
-(defun image-tree-node-less (a b)
- "Allows to give IMAGE-TREE-NODEs a canonical order according to
-their geo-locations."
- (cond
- ((< (geo-x a) (geo-x b)) t)
- ((= (geo-x a) (geo-x b))
- (< (geo-y a) (geo-y b)))
- (t nil)))
-
-;; (defmethod lod-min ((obj image-tree-node))
-;; (/ (min (store-image-width obj) (store-image-height obj)) 2.0))
-
-;; (defmethod lod-min ((obj image-tree))
-;; 900)
-
-;; (defmethod lod-max ((obj image-tree-node))
-;; (if (children obj)
-;; (* (store-image-width obj) (store-image-height obj))
-;; -1))
-
-(defmethod lod-min ((obj image-tree-node))
- "Initially intended to customize LOD-MIN according to the node's
-context. It seems that a constant default value is sufficient here."
- 256)
-
-(defmethod lod-min ((obj image-tree))
- 16)
-
-(defmethod lod-max ((obj image-tree-node))
- "See LOD-MIN."
- -1)
-
-(defun children-sizes (width height &key (divisor 2))
- "Splits a rectangle of integer size WIDTH x HEIGHT into almost equal
-parts that have again integer size. If the initial rectangle does not
-have an extreme aspect ratio, the number of the resulting rectangles
-will be (sqr divisor)."
- ;; extreme aspect ratios are not implemented yet
- (flet ((divide-almost-equally (x)
- (multiple-value-bind (quotient remainder)
- (floor x divisor)
- (loop for i from 0 below divisor
- if (zerop i)
- collect (+ quotient remainder)
- else
- collect quotient))))
- (list (divide-almost-equally width)
- (divide-almost-equally height))))
-
-(defun map-children-rects (function left top width-heights depth)
- "Calls FUNCTION with (x y width height depth) for each of the
-sub-rectangles specified by the start point LEFT, TOP and
-WIDTH-HEIGHTS of the sub-rectangles. Collects the results into an
-array of dimensions corresponding to WIDTH-HEIGHTS."
- (let (results)
- (destructuring-bind (widths heights)
- width-heights
- (dolist (w widths (nreverse results))
- (let ((safe-top top)) ; pretty ugly, sorry
- (dolist (h heights)
- (push (funcall function left safe-top w h depth) results)
- (incf safe-top h)))
- (incf left w)))))
-
-(defun make-image-tree (source-image geo-location &key
- (output-images-size 256))
- "Constructs an image-tree with the given SOURCE-IMAGE. The root
-IMAGE-TREE-NODE will be at GEO-LOCATION. All images will be scaled to
-OUTPUT-IMAGES-SIZE."
- (destructuring-bind (geo-x geo-y geo-width geo-height) geo-location
- (let* ((source-image-width (cl-gd:image-width source-image))
- (source-image-height (cl-gd:image-height source-image))
- (scaler-x (/ source-image-width geo-width))
- (scaler-y (/ source-image-height geo-height))
- (classes '(image-tree . #1=(image-tree-node . #1#))))
- (labels ((image-point2geo-point (x y)
- (list (+ (/ x scaler-x) geo-x)
- (+ (/ y scaler-y) geo-y)))
- (image-rect2geo-rect (rect)
- (destructuring-bind (x y width height)
- rect
- (let ((x2 (+ x width))
- (y2 (+ y height)))
- (destructuring-bind (geo-x geo-y)
- (image-point2geo-point x y)
- (destructuring-bind (geo-x2 geo-y2)
- (image-point2geo-point x2 y2)
- (list geo-x geo-y (- geo-x2 geo-x) (- geo-y2 geo-y)))))))
- (image-small-enough (image-width image-height)
- (and (<= image-width output-images-size)
- (<= image-height output-images-size)))
- (%make-image-tree (image-x image-y image-width image-height depth)
- (let ((class (pop classes))
- (children (unless (image-small-enough image-width image-height)
- (sort
- (map-children-rects #'%make-image-tree
- image-x image-y
- (children-sizes image-width image-height)
- (1+ depth))
- #'image-tree-node-less))))
- (cl-gd:with-image (image output-images-size output-images-size t)
- (cl-gd:copy-image source-image image
- image-x image-y 0 0
- image-width image-height
- :resample t
- :resize t
- :dest-width output-images-size
- :dest-height output-images-size)
- #+nil
- (cl-gd:with-default-color ((cl-gd:allocate-color 255 0 0 :image image))
- ;; (cl-gd:draw-string 10 10 (format nil "~D,~D (~D x ~D)" image-x image-y image-width image-height)
- ;; :font :medium :image image)
- (cl-gd:draw-rectangle (list 10 10 (- output-images-size 10) (- output-images-size 10))
- :image image))
- (make-image-tree-node image
- :geo-rect (image-rect2geo-rect
- (list image-x image-y image-width image-height))
- :children children
- :class-name class
- :depth depth)))))
- (with-image-tree-node-counter
- (%make-image-tree 0 0 source-image-width source-image-height 0))))))
-
-(defun matrix-from-list (list &key (x-key #'first) (y-key #'second))
- "Converts a flat LIST to a matrix, by using X-KEY and Y-KEY to
-associate a position to each element of LIST. "
- (let* ((matrix (mapcar #'cdr (sort (group-on (sort (copy-list list) #'< :key x-key) :key y-key) #'< :key #'first)))
- (width (length (first matrix))))
- (assert (every #'(lambda (row) (= width (length row))) matrix)
- nil "Cant make a proper matrix from list, cause its rows wont have the same length.")
- matrix))
-
-(defun setp (list &key (test #'eql) (key #'identity))
- "Checks if LIST is a set (using TEST and KEY)."
- (= (length list)
- (length (remove-duplicates list :test test :key key))))
-
-(defun every-eql-first-p (list &key (test #'eql) (key #'identity))
- "Checks if LIST only contains elements that are eql to its first
-element using TEST and KEY)."
- (let ((first-key (funcall key (first list))))
- (every #'(lambda (elt) (funcall test first-key (funcall key elt))) (cdr list))))
-
-(deftransaction combine-image-trees (image-trees)
- "Creates a new image-tree object that contains IMAGE-TREES as
-children. All necessary adoptions for the new structure are
-performed."
- (labels ((reduce-min (&rest args)
- (apply #'reduce #'min args))
- (reduce-max (&rest args)
- (apply #'reduce #'max args))
- (normalize-depths (node &optional (depth 0))
- (setf (depth node) depth)
- (mapc #'(lambda (child) (normalize-depths child (1+ depth))) (children node))
- node))
- (assert (setp image-trees :key #'(lambda (tree) (list (geo-x tree) (geo-y tree))) :test #'equal)
- nil "The given image-trees have at least one duplicate with respect to their left-top position.")
- (assert (every-eql-first-p image-trees :key #'(lambda (tree) (list (store-image-width tree)
- (store-image-height tree)))
- :test #'equal)
- nil "The given image-trees must have the same width and height.")
- (let* ((geo-x (reduce-min image-trees :key #'geo-x))
- (geo-y (reduce-min image-trees :key #'geo-y))
- (geo-x-max (reduce-max image-trees :key #'(lambda (tree) (+ (geo-x tree) (geo-width tree)))))
- (geo-y-max (reduce-max image-trees :key #'(lambda (tree) (+ (geo-y tree) (geo-height tree)))))
- (first-image-tree (first image-trees))
- (children-matrix (matrix-from-list image-trees :x-key #'geo-x :y-key #'geo-y))
- (children-matrix-width (length (first children-matrix)))
- (children-matrix-height (length children-matrix)))
- (cl-gd:with-image (image (store-image-width first-image-tree)
- (store-image-height first-image-tree)
- t)
- ;; copy images
- (flet ((scaler-x (x) (round (/ x children-matrix-width)))
- (scaler-y (y) (round (/ y children-matrix-height))))
- (loop with dest-y = 0
- for row in children-matrix
- do (loop with dest-x = 0
- for tree in row
- do (with-store-image (source-image tree)
- (cl-gd:copy-image source-image image
- 0 0 (scaler-x dest-x) (scaler-y dest-y)
- (store-image-width tree) (store-image-height tree)
- :resample t
- :resize t
- :dest-width (scaler-x (store-image-width first-image-tree))
- :dest-height (scaler-y (store-image-height first-image-tree))))
- do (incf dest-x (store-image-width tree)))
- do (incf dest-y (store-image-height (first row)))))
- (normalize-depths
- (with-image-tree-node-counter
- (make-image-tree-node image :geo-rect (list geo-x geo-y (- geo-x-max geo-x) (- geo-y-max geo-y))
- :children (mapcar (alexandria:rcurry #'persistent-change-class 'image-tree-node)
- image-trees)
- :class-name 'image-tree)))))))
-
-
-;; (cl-gd:with-image-from-file (image "/tmp/115606" :jpeg)
-;; (make-image-tree image nil))
-
-;; (cl-gd:with-image-from-file (image "/tmp/115606" :jpeg)
-;; (make-image-tree image '(0 0 10 10)))
-
-(defclass image-tree-handler (object-handler)
- ()
- (:default-initargs :object-class 'image-tree-node)
- (:documentation "A simple html inspector for image-trees. Mainly
- used for debugging."))
-
-
-(defun img-image-tree (object)
- (html
- ((:a :href (format nil "http://~a/image-tree/~d" (website-host) (store-object-id object)))
- ((:img :src (format nil "http://~a/image/~d" (website-host) (store-object-id object)))))))
-
-(defmethod handle-object ((image-tree-handler image-tree-handler) (object image-tree-node))
- (with-bknr-page (:title (prin1-to-string object))
- #+nil(:pre
- (:princ
- (arnesi:escape-as-html
- (with-output-to-string (*standard-output*)
- (describe object)))))
- (img-image-tree object)
- (when (parent object)
- (html
- (:p
- ((:a :href (format nil "http://~a/image-tree/~d" (website-host) (store-object-id (parent object))))
- "go to parent"))))
- (:p "depth: " (:princ (depth object)) "lod-min:" (:princ (lod-min object)) "lod-max:" (:princ (lod-max object)))
- (:table
- (dolist (row (group-on (children object) :key #'geo-y :include-key nil))
- (html (:tr
- (dolist (child row)
- (html (:td (img-image-tree child))))))))))
-
-
-(defclass image-tree-kml-handler (object-handler)
- ()
- (:default-initargs :object-class 'image-tree-node)
- (:documentation "Generates a kml representation of the queried
-image-tree-node. If the node has children, corresponding network
-links are created."))
-
-(defmethod handle-object ((handler image-tree-kml-handler) (obj image-tree-node))
- (hunchentoot:handle-if-modified-since (blob-timestamp obj))
- (with-xml-response (:content-type "text/xml; charset=utf-8" #+nil"application/vnd.google-earth.kml+xml"
- :root-element "kml")
- (setf (hunchentoot:header-out :last-modified)
- (hunchentoot:rfc-1123-date (blob-timestamp obj)))
- (let ((lod `(:min ,(lod-min obj) :max ,(lod-max obj)))
- (rect (make-rectangle2 (list (geo-x obj) (geo-y obj) (geo-width obj) (geo-height obj)))))
- (with-element "Document"
- (kml-region rect lod)
- (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id obj))
- rect
- :draw-order (depth obj)
- ;; :absolute 0
- )
- (dolist (child (children obj))
- (kml-network-link (format nil "http://~a/image-tree-kml/~d" (website-host) (store-object-id child))
- :rect (make-rectangle2 (list (geo-x child) (geo-y child)
- (geo-width child) (geo-height child)))
- :lod `(:min ,(lod-min child) :max ,(lod-max child))))))))
-
-(defclass image-tree-kml-latest-handler (page-handler)
- ()
- (:documentation "A convenience handler that redirects to the
- IMAGE-TREE-KML-HANDLER of the latest created image-tree."))
-
-(defmethod handle ((page-handler image-tree-kml-latest-handler))
- (redirect (format nil "http://~a/image-tree-kml/~d" (website-host) (store-object-id (car (last (class-instances 'image-tree)))))))
-
-;;;;
-(defun image-tree-import-satellitenbild ()
- "A simple importer for our standard image."
- (labels ((2x2-indices (left top)
- `((,left ,top)(,(1+ left) ,top)(,left ,(1+ top))(,(1+ left) ,(1+ top))))
- (aref-indices (array indices)
- (mapcar #'(lambda (index-pair) (destructuring-bind (x y) index-pair (aref array x y))) indices)))
- (let ((array (make-array (list 4 4))))
- (loop with *default-pathname-defaults* = (merge-pathnames #p"tiles-2700/" (user-homedir-pathname))
- for name in '("sl_utm50s_01.png"
- "sl_utm50s_02.png"
- "sl_utm50s_03.png"
- "sl_utm50s_04.png"
- "sl_utm50s_05.png"
- "sl_utm50s_06.png"
- "sl_utm50s_07.png"
- "sl_utm50s_08.png"
- "sl_utm50s_09.png"
- "sl_utm50s_10.png"
- "sl_utm50s_11.png"
- "sl_utm50s_12.png"
- "sl_utm50s_13.png"
- "sl_utm50s_14.png"
- "sl_utm50s_15.png"
- "sl_utm50s_16.png")
- for i upfrom 0
- for x = (mod i 4)
- for y = (floor i 4)
- do (print (list 'importing x y))
- do (setf (aref array x y)
- (cl-gd:with-image-from-file (image (merge-pathnames name))
- (make-image-tree image (list (* (mod i 4) 2700) (* (floor i 4) 2700)
- 2700 2700)))))
- (combine-image-trees
- (list (combine-image-trees (aref-indices array (2x2-indices 0 0)))
- (combine-image-trees (aref-indices array (2x2-indices 0 2)))
- (combine-image-trees (aref-indices array (2x2-indices 2 0)))
- (combine-image-trees (aref-indices array (2x2-indices 2 2))))))))
Modified: trunk/projects/bos/web/kml-handlers.lisp
===================================================================
--- trunk/projects/bos/web/kml-handlers.lisp 2008-07-17 14:48:01 UTC (rev 3491)
+++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-17 15:17:01 UTC (rev 3492)
@@ -52,9 +52,6 @@
(when (sponsor-info-text sponsor)
(text (sponsor-info-text sponsor))))))))
-(defun image-tree-root-id ()
- (store-object-id (first (class-instances 'image-tree))))
-
(defclass kml-root-handler (object-handler)
((timestamp :accessor timestamp :initform (get-universal-time))))
@@ -85,14 +82,7 @@
(with-element "altitude" (text "0"))
(with-element "range" (text "1134.262777389377"))
(with-element "tilt" (text "0"))
- (with-element "heading" (text "1.391362238653075")))
- (let ((image-tree (find-store-object (image-tree-root-id))))
- (assert (and image-tree (typep image-tree 'image-tree)) nil
- "(find-store-object (image-tree-root-id)) gives ~s" image-tree)
- (kml-network-link (format nil "http://~a/image-tree-kml/~d" (website-host) (image-tree-root-id))
- :rect (make-rectangle2 (geo-location image-tree))
- :lod `(:min ,(lod-min image-tree) :max ,(lod-max image-tree))
- :name "old-image-tree"))
+ (with-element "heading" (text "1.391362238653075")))
(dolist (sat-layer (class-instances 'sat-layer))
(kml-network-link (format nil "http://~a/sat-root-kml?name=~A" (website-host) (name sat-layer))
:rect (geo-box-rectangle *m2-geo-box*)
Modified: trunk/projects/bos/web/webserver.lisp
===================================================================
--- trunk/projects/bos/web/webserver.lisp 2008-07-17 14:48:01 UTC (rev 3491)
+++ trunk/projects/bos/web/webserver.lisp 2008-07-17 15:17:01 UTC (rev 3492)
@@ -199,10 +199,7 @@
:handler-definitions `(("/edit-poi" edit-poi-handler)
("/edit-poi-image" edit-poi-image-handler)
("/edit-sponsor" edit-sponsor-handler)
- ("/kml-root" kml-root-handler)
- ("/image-tree-kml-latest" image-tree-kml-latest-handler)
- ("/image-tree-kml" image-tree-kml-handler)
- ("/image-tree" image-tree-handler)
+ ("/kml-root" kml-root-handler)
("/country-stats" country-stats-handler)
("/contract-tree-kml" contract-tree-kml-handler)
("/contract-tree-image" contract-tree-image-handler)
More information about the Bknr-cvs
mailing list