Changeset 3492

Timestamp:

07/17/08 17:17:01 (4 months ago)

Author:

ksprotte

Message:

removed obsolete image-tree from bos - step 1

Files:

• trunk/projects/bos/web/image-tree.lisp (modified) (1 diff)
• trunk/projects/bos/web/kml-handlers.lisp (modified) (2 diffs)
• trunk/projects/bos/web/webserver.lisp (modified) (1 diff)

trunk/projects/bos/web/image-tree.lisp

@@ -313 +313 @@
-;; 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))))))))

trunk/projects/bos/web/kml-handlers.lisp

@@ -53 +53 @@
-            (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))))
@@ -86 +83 @@
-            (with-element "range" (text "1134.262777389377"))
-            (with-element "tilt" (text "0"))
-
-
-
-
-
-
-
-
+
-          (dolist (sat-layer (class-instances 'sat-layer))
-            (kml-network-link (format nil "http://~a/sat-root-kml?name=~A" (website-host) (name sat-layer))

trunk/projects/bos/web/webserver.lisp

@@ -200 +200 @@
-                                        ("/edit-poi-image" edit-poi-image-handler)
-                                        ("/edit-sponsor" edit-sponsor-handler)
-
-
-
-
+
-                                        ("/country-stats" country-stats-handler)
-                                        ("/contract-tree-kml" contract-tree-kml-handler)