[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp

[BKNR Commits]

Revision: 3439
Author: ksprotte
URL: http://bknr.net/trac/changeset/3439

fixed contract-node timestamp behaviour

the main problem was that (timestamp node) has to be computed by
(max (timestamp node) (contract-date contract))

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-15 07:45:57 UTC (rev 3438)
+++ trunk/projects/bos/web/contract-tree.lisp	2008-07-15 10:03:24 UTC (rev 3439)
@@ -3,7 +3,7 @@
 ;;; contract-node
 (defclass contract-node (node-extension)
   ((name :allocation :class :initform 'contract-node)
-   (timestamp :accessor timestamp)
+   (timestamp :accessor timestamp :initform 0) ; timestamp initially "very old"
    (placemark-contracts :initform nil :accessor placemark-contracts)
    (image :initform nil :accessor image)
    (kml-req-count :initform 0 :accessor kml-req-count)
@@ -12,16 +12,22 @@
 (defun contract-node-set-timestamp-now (node)
   (setf (timestamp node) (get-universal-time)))
 
+(defun contract-node-timestamp-updater (contract)
+  (lambda (node) (setf (timestamp node)
+		       (max (timestamp node) (contract-date contract)))))
+
 (defun contract-node-find-corresponding-store-image (node)  
-  (first (get-keyword-store-images (contract-node-keyword 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)))
 
 (defmethod initialize-instance :after ((node contract-node) &key args)
   (declare (ignore args))
   (let ((image (contract-node-find-corresponding-store-image node)))
-    (if (and image (probe-file (blob-pathname image)))
-        (setf (image node) image
-              (timestamp node) (blob-timestamp image))
-        (contract-node-set-timestamp-now node))))
+    (when (and image (probe-file (blob-pathname image)))
+      (setf (image node) image
+	    (timestamp node) (blob-timestamp image)))))
 
 (defvar *contract-tree* nil)
 (defparameter *contract-tree-images-size* 128) ; was 256
@@ -78,11 +84,13 @@
 (defun insert-contract (contract-tree contract)
   (let ((geo-box (contract-geo-box contract))
         (geo-center (contract-geo-center contract)))
-    (ensure-intersecting-children contract-tree geo-box #'contract-node-set-timestamp-now)
-    (let ((placemark-node (find-node-if (lambda (node) (contract-placemark-at-node-p node contract))
-                                        contract-tree
-                                        :prune-test (lambda (node)
-                                                      (not (geo-point-in-box-p (geo-box node) geo-center))))))
+    (ensure-intersecting-children contract-tree geo-box
+				  (contract-node-timestamp-updater contract))
+    (let ((placemark-node (find-node-if
+			   (lambda (node) (contract-placemark-at-node-p node contract))
+			   contract-tree
+			   :prune-test (lambda (node)
+					 (not (geo-point-in-box-p (geo-box node) geo-center))))))
       (assert placemark-node)
       (push contract (placemark-contracts placemark-node)))))
 
@@ -289,9 +297,9 @@
   (dolist (contract (class-instances 'contract))
     (when (contract-published-p contract)
       (insert-contract *contract-tree* contract)))
-  (format t "~&rendering contract-tree images if needed...")
+  (format t "~&rendering contract-tree images if needed...") (force-output)
   (map-nodes #'contract-node-update-image-if-needed *contract-tree*)
-  (format t "done.~%")  
+  (format t "done.~%") (force-output)  
   (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree*
                                      (list 0 0 +width+ +width+)
                                      #'contract-tree-changed))