Changeset 2730
- Timestamp:
- 03/13/08 18:26:13 (10 months ago)
- Files:
-
- trunk/projects/bos/web/image-tree.lisp (modified) (9 diffs)
- trunk/projects/bos/web/webserver.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
trunk/projects/bos/web/image-tree.lisp
r2728 r2730 17 17 (children :initarg :children :reader children))) 18 18 19 (defpersistent-class image-tree (image-tree-node) 20 ()) 21 19 22 (defmethod print-object ((object image-tree-node) stream) 20 23 (print-unreadable-object (object stream :type t) … … 24 27 (store-image-height object)))) 25 28 26 (defun make-image-tree-node (image &key geo-rect children )29 (defun make-image-tree-node (image &key geo-rect children (class-name 'image-tree-node)) 27 30 (destructuring-bind (geo-x geo-y geo-width geo-height) 28 31 geo-rect 29 32 (make-store-image :image image 30 33 :name (image-tree-node-unique-name) 31 :class-name 'image-tree-node34 :class-name class-name 32 35 :initargs `(:geo-x ,geo-x 33 36 :geo-y ,geo-y … … 36 39 :children ,children)))) 37 40 38 (defun children-sizes (width height &key (divisor 2)) 41 (defun image-tree-node-less (a b) 42 (cond 43 ((< (geo-x a) (geo-x b)) t) 44 ((= (geo-x a) (geo-x b)) 45 (< (geo-y a) (geo-y b))) 46 (t nil))) 47 48 (defun children-sizes (width height &key (divisor 3)) 39 49 (flet ((divide-almost-equally (x) 40 50 (multiple-value-bind (quotient remainder) … … 48 58 (divide-almost-equally height)))) 49 59 50 51 60 (defun map-children-rects (function left top width-heights) 52 61 "Calls FUNCTION with (x y width height) for each of the sub-rectangles 53 62 specified by the start point LEFT, TOP and WIDTH-HEIGHTS of the sub-rectangles. 54 Collects the results into a list."63 Collects the results into an array of dimensions corresponding to WIDTH-HEIGHTS." 55 64 (let (results) 56 65 (destructuring-bind (widths heights) … … 60 69 (dolist (h heights) 61 70 (push (funcall function left safe-top w h) results) 62 (incf safe-top h))) 71 (incf safe-top h))) 63 72 (incf left w))))) 64 65 73 66 74 (defun make-image-tree (source-image geo-location &key (output-images-size 256)) … … 69 77 (source-image-height (cl-gd:image-height source-image)) 70 78 (scaler-x (/ source-image-width geo-width)) 71 (scaler-y (/ source-image-height geo-height))) 79 (scaler-y (/ source-image-height geo-height)) 80 (classes '(image-tree . #1=(image-tree-node . #1#)))) 72 81 (labels ((image-point2geo-point (x y) 73 82 (list (+ (/ x scaler-x) geo-x) … … 87 96 (<= image-height output-images-size))) 88 97 (%make-image-tree (image-x image-y image-width image-height) 89 (let ((children (unless (image-small-enough image-width image-height) 90 (map-children-rects #'%make-image-tree 91 image-x image-y 92 (children-sizes image-width image-height))))) 98 (let ((class (pop classes)) 99 (children (unless (image-small-enough image-width image-height) 100 (sort 101 (map-children-rects #'%make-image-tree 102 image-x image-y 103 (children-sizes image-width image-height)) 104 #'image-tree-node-less)))) 93 105 (cl-gd:with-image (image output-images-size output-images-size t) 94 106 (cl-gd:copy-image source-image image … … 102 114 :geo-rect (image-rect2geo-rect 103 115 (list image-x image-y image-width image-height)) 104 :children children))))) 116 :children children 117 :class-name class))))) 105 118 (with-image-tree-node-counter 106 119 (%make-image-tree 0 0 source-image-width source-image-height)))))) … … 116 129 |# 117 130 131 (defclass image-tree-handler (object-handler) 132 () 133 (:default-initargs :object-class 'image-tree-node)) 134 135 136 (defun img-image-tree (object) 137 (html 138 ((:a :href (website-make-path *website* 139 (format nil "image-tree/~d" (store-object-id object)))) 140 ((:img :src (website-make-path *website* 141 (format nil "image/~d" (store-object-id object)))))))) 142 143 (defmethod handle-object ((image-tree-handler image-tree-handler) (object image-tree-node)) 144 (with-bknr-page (:title (prin1-to-string object)) 145 (img-image-tree object) 146 (:table 147 (dolist (row (group-on (children object) :key #'geo-y :include-key nil)) 148 (html (:tr 149 (dolist (child row) 150 (html (:td (img-image-tree child)))))))))) 151 trunk/projects/bos/web/webserver.lisp
r2725 r2730 201 201 ("/edit-sponsor" edit-sponsor-handler) 202 202 ("/contract-kml" contract-kml-handler) 203 ("/image-tree" image-tree-handler) 203 204 ("/contract-image" contract-image-handler) 204 205 ("/contract" contract-handler) 205 ("/reports-xml" reports-xml-handler) 206 ("/reports-xml" reports-xml-handler) 206 207 ("/complete-transfer" complete-transfer-handler) 207 208 ("/edit-news" edit-news-handler)
