Changeset 3439

Show
Ignore:
Timestamp:
07/15/08 12:03:24 (6 months ago)
Author:
ksprotte
Message:

fixed contract-node timestamp behaviour

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

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r3438 r3439  
    44(defclass contract-node (node-extension) 
    55  ((name :allocation :class :initform 'contract-node) 
    6    (timestamp :accessor timestamp) 
     6   (timestamp :accessor timestamp :initform 0) ; timestamp initially "very old" 
    77   (placemark-contracts :initform nil :accessor placemark-contracts) 
    88   (image :initform nil :accessor image) 
    …… 
    1313  (setf (timestamp node) (get-universal-time))) 
    1414 
     15(defun contract-node-timestamp-updater (contract) 
     16  (lambda (node) (setf (timestamp node) 
     17                       (max (timestamp node) (contract-date contract))))) 
     18 
    1519(defun contract-node-find-corresponding-store-image (node)   
    16   (first (get-keyword-store-images (contract-node-keyword node)))) 
     20  (let ((store-images (get-keyword-store-images (contract-node-keyword node)))) 
     21    (when (< 1 (length store-images)) 
     22      (warn "~D store-images for ~S" (length store-images) node)) 
     23    (first store-images))) 
    1724 
    1825(defmethod initialize-instance :after ((node contract-node) &key args) 
    1926  (declare (ignore args)) 
    2027  (let ((image (contract-node-find-corresponding-store-image node))) 
    21     (if (and image (probe-file (blob-pathname image))) 
    22         (setf (image node) image 
    23               (timestamp node) (blob-timestamp image)) 
    24         (contract-node-set-timestamp-now node)))) 
     28    (when (and image (probe-file (blob-pathname image))) 
     29      (setf (image node) image 
     30            (timestamp node) (blob-timestamp image))))) 
    2531 
    2632(defvar *contract-tree* nil) 
    …… 
    7985  (let ((geo-box (contract-geo-box contract)) 
    8086        (geo-center (contract-geo-center contract))) 
    81     (ensure-intersecting-children contract-tree geo-box #'contract-node-set-timestamp-now) 
    82     (let ((placemark-node (find-node-if (lambda (node) (contract-placemark-at-node-p node contract)) 
    83                                         contract-tree 
    84                                         :prune-test (lambda (node) 
    85                                                       (not (geo-point-in-box-p (geo-box node) geo-center)))))) 
     87    (ensure-intersecting-children contract-tree geo-box 
     88                                  (contract-node-timestamp-updater contract)) 
     89    (let ((placemark-node (find-node-if 
     90                           (lambda (node) (contract-placemark-at-node-p node contract)) 
     91                           contract-tree 
     92                           :prune-test (lambda (node) 
     93                                         (not (geo-point-in-box-p (geo-box node) geo-center)))))) 
    8694      (assert placemark-node) 
    8795      (push contract (placemark-contracts placemark-node))))) 
    …… 
    290298    (when (contract-published-p contract) 
    291299      (insert-contract *contract-tree* contract))) 
    292   (format t "~&rendering contract-tree images if needed...") 
     300  (format t "~&rendering contract-tree images if needed...") (force-output) 
    293301  (map-nodes #'contract-node-update-image-if-needed *contract-tree*) 
    294   (format t "done.~%")  
     302  (format t "done.~%") (force-output)  
    295303  (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* 
    296304                                     (list 0 0 +width+ +width+)