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)) - ,@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)