Changeset 2755

Show
Ignore:
Timestamp:
03/17/08 15:53:31 (10 months ago)
Author:
ksprotte
Message:

added image-tree-kml-latest-handler; tree-nodes now know their depth

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r2754 r2755  
    321321   (geo-height :initarg :geo-height :reader geo-height)    
    322322   (children :initarg :children :reader children) 
    323    (parent :reader parent))) 
     323   (parent :reader parent) 
     324   (depth :reader depth :initarg :depth))) 
    324325 
    325326(defpersistent-class image-tree (image-tree-node) 
    …… 
    338339 
    339340(defun make-image-tree-node (image &key geo-rect children 
    340                              (class-name 'image-tree-node)) 
     341                             (class-name 'image-tree-node) 
     342                             depth) 
    341343  (destructuring-bind (geo-x geo-y geo-width geo-height) 
    342344      geo-rect 
    …… 
    348350                                         :geo-width ,geo-width 
    349351                                         :geo-height ,geo-height              
    350                                          :children ,children)))) 
     352                                         :children ,children 
     353                                         :depth ,depth)))) 
    351354 
    352355(defun image-tree-node-less (a b) 
    …… 
    357360    (t nil))) 
    358361 
     362;; (defmethod lod-min ((obj image-tree-node)) 
     363;;   (/ (min (store-image-width obj) (store-image-height obj)) 2.0)) 
     364 
     365;; (defmethod lod-min ((obj image-tree)) 
     366;;   900) 
     367 
     368;; (defmethod lod-max ((obj image-tree-node)) 
     369;;   (if (children obj) 
     370;;       (* (store-image-width obj) (store-image-height obj)) 
     371;;       -1)) 
     372 
    359373(defmethod lod-min ((obj image-tree-node)) 
    360   (/ (min (store-image-width obj) (store-image-height obj)) 2.0)) 
    361  
    362 (defmethod lod-min ((obj image-tree)) 
    363   900) 
     374  256) 
    364375 
    365376(defmethod lod-max ((obj image-tree-node)) 
    366   (if (children obj) 
    367       (* (store-image-width obj) (store-image-height obj)) 
    368       -1)) 
     377  -1) 
    369378 
    370379(defun children-sizes (width height &key (divisor 2)) 
    …… 
    380389          (divide-almost-equally height)))) 
    381390 
    382 (defun map-children-rects (function left top width-heights) 
    383   "Calls FUNCTION with (x y width height) for each of the sub-rectangles 
     391(defun map-children-rects (function left top width-heights depth) 
     392  "Calls FUNCTION with (x y width height depth) for each of the sub-rectangles 
    384393specified by the start point LEFT, TOP and WIDTH-HEIGHTS of the sub-rectangles. 
    385394Collects the results into an array of dimensions corresponding to WIDTH-HEIGHTS." 
    …… 
    390399        (let ((safe-top top))           ; pretty ugly, sorry 
    391400          (dolist (h heights) 
    392             (push (funcall function left safe-top w h) results) 
     401            (push (funcall function left safe-top w h depth) results) 
    393402            (incf safe-top h)))         
    394403        (incf left w))))) 
    …… 
    418427                 (and (<= image-width output-images-size) 
    419428                      (<= image-height output-images-size))) 
    420                (%make-image-tree (image-x image-y image-width image-height) 
     429               (%make-image-tree (image-x image-y image-width image-height depth) 
    421430                 (let ((class (pop classes)) 
    422431                       (children (unless (image-small-enough image-width image-height) 
    …… 
    424433                                    (map-children-rects #'%make-image-tree 
    425434                                                        image-x image-y 
    426                                                         (children-sizes image-width image-height)) 
     435                                                        (children-sizes image-width image-height) 
     436                                                        (1+ depth)) 
    427437                                    #'image-tree-node-less)))) 
    428438                   (cl-gd:with-image (image output-images-size output-images-size t) 
    …… 
    441451                                                      (list image-x image-y image-width image-height)) 
    442452                                           :children children 
    443                                            :class-name class))))) 
     453                                           :class-name class 
     454                                           :depth depth))))) 
    444455        (with-image-tree-node-counter 
    445           (%make-image-tree 0 0 source-image-width source-image-height)))))) 
     456          (%make-image-tree 0 0 source-image-width source-image-height 0)))))) 
    446457 
    447458 
    …… 
    481492                                      (format nil "image-tree/~d" (store-object-id (parent object))))) 
    482493         "go to parent")))) 
    483     (:p "lod-min:" (:princ (lod-min object)) "lod-max:" (:princ (lod-max object))) 
     494    (:p "depth: " (:princ (depth object)) "lod-min:" (:princ (lod-min object)) "lod-max:" (:princ (lod-max object))) 
    484495    (:table 
    485496     (dolist (row (group-on (children object) :key #'geo-y :include-key nil)) 
    …… 
    502513        (kml-region rect lod) 
    503514        (kml-overlay (format nil "~a:~a/image/~d" *website-url* *port* (store-object-id obj)) 
    504                      rect 0) 
     515                     rect (depth obj)) 
    505516        (dolist (child (children obj)) 
    506517          (kml-network-link (format nil "~a:~a/image-tree-kml/~d" *website-url* *port* (store-object-id child)) 
    …… 
    508519                                                   (geo-width child) (geo-height child))) 
    509520                            `(:min ,(lod-min child) :max ,(lod-max child)))))))) 
     521 
     522(defclass image-tree-kml-latest-handler (redirect-handler) 
     523  ()) 
     524 
     525(defmethod handle ((page-handler image-tree-kml-latest-handler)) 
     526  (redirect (format nil "~a:~a/image-tree-kml/~d" *website-url* *port* (store-object-id (car (last (class-instances 'image-tree))))))) 
     527 
     528 

  • trunk/projects/bos/web/webserver.lisp

    r2736 r2755  
    201201                                        ("/edit-sponsor" edit-sponsor-handler) 
    202202                                        ("/contract-kml" contract-kml-handler) 
    203                                         ("/image-tree-kml" image-tree-kml-handler) 
     203                                        ("/image-tree-kml-latest" image-tree-kml-latest-handler) 
     204                                        ("/image-tree-kml" image-tree-kml-handler)                                         
    204205                                        ("/image-tree" image-tree-handler)                               
    205206                                        ("/contract-image" contract-image-handler)