- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3500 Author: ksprotte URL: http://bknr.net/trac/changeset/3500 contract-tree small change U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-18 10:53:38 UTC (rev 3499) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-18 11:03:33 UTC (rev 3500) @@ -247,6 +247,7 @@ (cl-gd:find-color r g b :alpha 40)))) (let ((box (geo-box node)) (image-size *contract-tree-images-size*)) + ;; (warn "will update image for ~a" node) (cl-gd:with-image (cl-gd:*default-image* image-size image-size t) (setf (cl-gd:save-alpha-p) t (cl-gd:alpha-blending-p) nil)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/poi-handlers.lisp
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3499 Author: ksprotte URL: http://bknr.net/trac/changeset/3499 added target POI-micro-site to learn-more link U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-18 10:33:20 UTC (rev 3498) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-18 10:53:38 UTC (rev 3499) @@ -528,6 +528,7 @@ (attribute "align" "center") (with-element "a" (attribute "href" (poi-xml-path)) + (attribute "target" "POI-micro-site") (text (dictionary-entry "learn more" language))))) (with-element "tr" (with-element "td"

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3498 Author: ksprotte URL: http://bknr.net/trac/changeset/3498 fixes for contract-tree, especially contract-node-find-corresponding-store-image U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-18 05:03:18 UTC (rev 3497) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-18 10:33:20 UTC (rev 3498) @@ -20,9 +20,17 @@ (defun contract-node-find-corresponding-store-image (node) (let ((store-images (get-keyword-store-images (contract-node-keyword node)))) - (when (< 1 (length store-images)) - (warn "~D store-images for ~S" (length store-images) node)) - (first store-images))) + (if (alexandria:length= 1 store-images) + ;; good, there is only one + (first store-images) + ;; We will just return NIL, if we cannot find one. + ;; If there are too many, we will return the newest one and delete the rest. + (progn + (warn "~D store-images for ~S" (length store-images) node) + (let ((store-images-newest-first + (sort (copy-list store-images) #'> :key #'blob-timestamp))) + (mapc #'delete-object (rest store-images-newest-first)) + (first store-images-newest-first)))))) (defmethod initialize-instance :after ((node contract-node) &key args) (declare (ignore args)) @@ -34,9 +42,8 @@ (defvar *contract-tree* nil) (defparameter *contract-tree-images-size* 128) ; was 256 -;;; XXX soll spaeter von was anderem abhaengen (defmethod leaf-node-p ((node contract-node)) - (= 9 (depth node))) + (= 10 (depth node))) (defun contract-geo-box (contract) (destructuring-bind (x y width height) @@ -296,7 +303,8 @@ (with-query-params (path) (let* ((path (parse-path path)) (node (find-node-with-path *contract-tree* path)) - (image (image node))) + (image (image node))) + (assert image nil "contract-tree node ~{~D~} does not have an image" path) (hunchentoot:handle-if-modified-since (blob-timestamp image)) (with-store-image* (image) (emit-image-to-browser cl-gd:*default-image* :png

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/backend/
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3497 Author: hans URL: http://bknr.net/trac/changeset/3497 add ignored nodelay argument to all backends U trunk/thirdparty/usocket/backend/allegro.lisp U trunk/thirdparty/usocket/backend/armedbear.lisp U trunk/thirdparty/usocket/backend/clisp.lisp U trunk/thirdparty/usocket/backend/cmucl.lisp U trunk/thirdparty/usocket/backend/lispworks.lisp U trunk/thirdparty/usocket/backend/sbcl.lisp U trunk/thirdparty/usocket/backend/scl.lisp Modified: trunk/thirdparty/usocket/backend/allegro.lisp =================================================================== --- trunk/thirdparty/usocket/backend/allegro.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/allegro.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -49,7 +49,8 @@ :text :binary)) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in Allegro CL")) (let ((socket)) Modified: trunk/thirdparty/usocket/backend/armedbear.lisp =================================================================== --- trunk/thirdparty/usocket/backend/armedbear.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/armedbear.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -185,7 +185,8 @@ (typecase condition (error (error 'unknown-error :socket socket :real-error condition)))) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in ABCL")) (let ((usock)) Modified: trunk/thirdparty/usocket/backend/clisp.lisp =================================================================== --- trunk/thirdparty/usocket/backend/clisp.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/clisp.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -55,7 +55,8 @@ (error usock-err :socket socket) (signal usock-err :socket socket))))))) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in CLISP")) (let ((socket) Modified: trunk/thirdparty/usocket/backend/cmucl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/cmucl.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/cmucl.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -50,7 +50,8 @@ :socket socket :condition condition)))) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in CMUCL")) (let* ((socket)) Modified: trunk/thirdparty/usocket/backend/lispworks.lisp =================================================================== --- trunk/thirdparty/usocket/backend/lispworks.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/lispworks.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -73,7 +73,8 @@ (declare (ignore host port err-msg)) (raise-usock-err errno socket condition))))) -(defun socket-connect (host port &key (element-type 'base-char) timeout) +(defun socket-connect (host port &key (element-type 'base-char) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in Lispworks")) (let ((hostname (host-to-hostname host)) Modified: trunk/thirdparty/usocket/backend/sbcl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/sbcl.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/sbcl.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -186,7 +186,8 @@ (signal usock-cond :socket socket)))))) -(defun socket-connect (host port &key (element-type 'character) timeout deadline) +(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay) + (declare (ignore nodelay)) (declare (ignore deadline)) (when timeout (warn "SOCKET-CONNECT timeout not supported in SBCL")) Modified: trunk/thirdparty/usocket/backend/scl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/scl.lisp 2008-07-18 04:47:37 UTC (rev 3496) +++ trunk/thirdparty/usocket/backend/scl.lisp 2008-07-18 05:03:18 UTC (rev 3497) @@ -28,7 +28,8 @@ :socket socket :condition condition)))) -(defun socket-connect (host port &key (element-type 'character) timeout) +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) (when timeout (warn "SOCKET-CONNECT timeout not supported in SCL")) (let* ((socket (with-mapped-conditions ()

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/doc/indices.tex
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3496 Author: hans URL: http://bknr.net/trac/changeset/3496 Correct typo, thanks to Stan Parman (?) for reporting. U trunk/bknr/datastore/doc/indices.tex Modified: trunk/bknr/datastore/doc/indices.tex =================================================================== --- trunk/bknr/datastore/doc/indices.tex 2008-07-17 16:06:40 UTC (rev 3495) +++ trunk/bknr/datastore/doc/indices.tex 2008-07-18 04:47:37 UTC (rev 3496) @@ -148,7 +148,7 @@ \begin{Verbatim}[fontsize=\small,frame=leftline,framerule=0.9mm,rulecolor=\color{gray},framesep=5.1mm,xleftmargin=5mm,fontfamily=cmtt] (make-instance 'gorilla :name "Lucy" :description :aggressive) (make-instance 'gorilla :name "Robert" :description :playful) -(make-instance 'gorilla :name "John" :description :aggressive))) +(make-instance 'gorilla :name "John" :description :aggressive) (all-gorillas) ; => (#<GORILLA "Lucy"> #<GORILLA "Robert"> #<GORILLA "John">)

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/backend/openmcl.lisp
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3495 Author: hans URL: http://bknr.net/trac/changeset/3495 Add :NODELAY argument to SOCKET-CONNECT to disable TCP start-up delays. CCL only. U trunk/thirdparty/usocket/backend/openmcl.lisp Modified: trunk/thirdparty/usocket/backend/openmcl.lisp =================================================================== --- trunk/thirdparty/usocket/backend/openmcl.lisp 2008-07-17 16:00:11 UTC (rev 3494) +++ trunk/thirdparty/usocket/backend/openmcl.lisp 2008-07-17 16:06:40 UTC (rev 3495) @@ -72,13 +72,14 @@ :text :binary)) -(defun socket-connect (host port &key (element-type 'character) timeout deadline) +(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay) (with-mapped-conditions () (let ((mcl-sock (openmcl-socket:make-socket :remote-host (host-to-hostname host) :remote-port port :format (to-format element-type) :deadline deadline + :nodelay nodelay :connect-timeout (and timeout (* timeout internal-time-units-per-second))))) (openmcl-socket:socket-connect mcl-sock)

1 0

[bknr-cvs] hans changed trunk/thirdparty/drakma/request.lisp
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3494 Author: hans URL: http://bknr.net/trac/changeset/3494 Add :deadline keyword argument, available only on CCL 1.2+ U trunk/thirdparty/drakma/request.lisp Modified: trunk/thirdparty/drakma/request.lisp =================================================================== --- trunk/thirdparty/drakma/request.lisp 2008-07-17 15:18:01 UTC (rev 3493) +++ trunk/thirdparty/drakma/request.lisp 2008-07-17 16:00:11 UTC (rev 3494) @@ -201,7 +201,9 @@ #+:lispworks (connection-timeout 20) #+:lispworks (read-timeout 20) #+(and :lispworks (not :lw-does-not-have-write-timeout)) - (write-timeout 20 write-timeout-provided-p)) + (write-timeout 20 write-timeout-provided-p) + #+openmcl + deadline) "Sends an HTTP request to a web server and returns its reply. URI is where the request is sent to, and it is either a string denoting a uniform resource identifier or a PURI:URI object. The scheme of URI @@ -376,7 +378,14 @@ arguments can also be NIL \(meaning no timeout), and they don't apply if an existing stream is re-used. All timeout keyword arguments are only available for LispWorks, WRITE-TIMEOUT is only available for -LispWorks 5.0 or higher." +LispWorks 5.0 or higher. + +DEADLINE, a time in the future, specifies the time until which the +request should be finished. The DEADLINE is specified in internal +time units (see (GET-INTERNAL-TIME-UNITS) and +INTERNAL-TIME-UNITS-PER-SECOND). If the server fails to respond until +that time, a COMMUNICATION-DEADLINE-EXPIRED condition is signalled. +DEADLINE is available on CCL 1.2 and later." (unless (member protocol '(:http/1.0 :http/1.1) :test #'eq) (error "Don't know how to handle protocol ~S." protocol)) (setq uri (cond ((uri-p uri) (copy-uri uri)) @@ -445,7 +454,17 @@ :errorp t) #-:lispworks (usocket:socket-stream - (usocket:socket-connect host port :element-type 'octet)))) + (usocket:socket-connect host port + :element-type 'octet + #+openmcl #+openmcl + :deadline deadline + :nodelay t)))) + #+openmcl + (when deadline + ;; It is correct to set the deadline here even though it may have been initialized + ;; by SOCKET-CONNECT already: The stream may have been passed in by the user and + ;; the user may want to adjust the deadline for every request. + (setf (ccl:stream-deadline http-stream) deadline)) (when (and use-ssl ;; don't attach SSL to existing streams (not stream))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3493 Author: ksprotte URL: http://bknr.net/trac/changeset/3493 removed obsolete image-tree from bos - step 2 U trunk/projects/bos/web/bos.web.asd D trunk/projects/bos/web/image-tree.lisp A trunk/projects/bos/web/kml-utils.lisp Change set too large, please see URL above

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/
by BKNR Commits 17 Jul '08

17 Jul '08

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)

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3491 Author: hans URL: http://bknr.net/trac/changeset/3491 Add option to ignore objects in a snapshot that are of now-nonexistant classes. U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-17 14:11:47 UTC (rev 3490) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-17 14:48:01 UTC (rev 3491) @@ -353,15 +353,15 @@ (%encode-integer (store-object-id object) stream) (%encode-set-slots slots object stream))) -(defvar *class-rename-hash*) - (defun find-class-with-interactive-renaming (class-name) - (loop until (find-class class-name nil) + (loop until (or (null class-name) + (find-class class-name nil)) do (progn - (format *query-io* "Class ~A not found, enter new class: " class-name) + (format *query-io* "Class ~A not found, enter new class or enter NIL to ignore objects of this class: " class-name) (finish-output *query-io*) (setq class-name (read *query-io*)))) - (setf (gethash class-name *class-rename-hash*) (find-class class-name))) + (and class-name + (find-class class-name))) (defun find-slot-name-with-interactive-rename (class slot-name) (loop until (find slot-name (class-slots class) :key #'slot-definition-name) @@ -406,20 +406,24 @@ (class-name (%decode-symbol stream)) (nslots (%decode-integer stream)) (class (find-class-with-interactive-renaming class-name)) - (slots (find-class-slots-with-interactive-renaming class (loop - repeat nslots - collect (%decode-symbol stream))))) + (slot-names (loop repeat nslots collect (%decode-symbol stream))) + (slots (if class + (find-class-slots-with-interactive-renaming class slot-names) + slot-names))) (setf (gethash id layouts) (cons class slots)))) (defun %read-slots (stream object slots) + "Read the OBJECT from STREAM. The individual slots of the object +are expected in the order of the list SLOTS. If the OBJECT is NIL, +the slots are read from the snapshot and ignored." (declare (optimize (speed 3))) (dolist (slot-name slots) - (if slot-name ; NIL for slots which are not restored because of schema changes + (if slot-name ; NIL for slots which are not restored because of schema changes (restart-case (let ((*current-object-slot* (list object slot-name)) - (*current-slot-relaxed-p* - (store-object-relaxed-object-reference-p object slot-name))) + (*current-slot-relaxed-p* (or (null object) + (store-object-relaxed-object-reference-p object slot-name)))) (let ((value (decode stream))) (when object (let ((bknr.indices::*indices-remove-p* nil)) @@ -437,30 +441,25 @@ (defun snapshot-read-object (stream layouts) (declare (optimize (speed 3))) (with-simple-restart (skip-object "Skip the object.") - (let ((layout-id (%decode-integer stream)) - (object-id (%decode-integer stream))) - #+nil (format t "id: ~A~%" object-id) - (destructuring-bind (class &rest slots) (gethash layout-id layouts) - (declare (ignore slots)) - #+nil (format t "; class: ~A~%" class) - (let ((result (make-instance class :id object-id))) - result))))) + (let* ((layout-id (%decode-integer stream)) + (object-id (%decode-integer stream)) + (class (first (gethash layout-id layouts)))) + ;; If the class is NIL, it was not found in the currently + ;; running Lisp image and objects of this class will be ignored. + (when class + (make-instance class :id object-id))))) (defun snapshot-read-slots (stream layouts) (let* ((layout-id (%decode-integer stream)) (object-id (%decode-integer stream)) (object (store-object-with-id object-id))) (restart-case - (progn - #+nil (format t "read-slots for object ~A, id ~A~%" object object-id) - (unless object - (error "READ-SLOTS form for unexistent object with ID ~A~%" object-id)) - (%read-slots stream object (cdr (gethash layout-id layouts)))) - (skip-object-initialization () - :report "Skip object initialization.") - (delete-object () - :report "Delete the object." - (delete-object object))))) + (%read-slots stream object (cdr (gethash layout-id layouts))) + (skip-object-initialization () + :report "Skip object initialization.") + (delete-object () + :report "Delete the object." + (delete-object object))))) (defmethod encode-object ((object store-object) stream) (if (object-destroyed-p object) @@ -563,7 +562,6 @@ (created-objects 0) (read-slots 0) (error t) - (*class-rename-hash* (make-hash-table)) (*slot-name-map* nil)) (unwind-protect (progn @@ -584,8 +582,8 @@ (format t "unknown char ~A at offset ~A~%" char (file-position s))) (ecase char ((nil) (return)) - (#\O (snapshot-read-object s class-layouts) (incf created-objects)) (#\L (snapshot-read-layout s class-layouts)) + (#\O (snapshot-read-object s class-layouts) (incf created-objects)) (#\S (snapshot-read-slots s class-layouts) (incf read-slots)))))) (map-store-objects #'initialize-transient-instance) (setf error nil))

1 0