Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19078

Modified Files: incremental-redisplay.lisp Log Message: Improve constant factors on compute-difference-set.

* now does more things in only one iteration over: * is, is-table, come, stay * was, was-table. * big-O improvements left as an exercise to the reader or evaluator.

--- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/03/10 21:58:13 1.54 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:40:48 1.55 @@ -748,75 +748,79 @@

(defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) - offset-x offset-y - old-offset-x old-offset-y) + offset-x offset-y + old-offset-x old-offset-y) (declare (ignore offset-x offset-y old-offset-x old-offset-y)) ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is + stay + come (everywhere (or +everywhere+ - (pane-viewport-region (updating-output-stream record))))) - ;; Collect what was there - (labels ((gather-was (record) - (cond ((displayed-output-record-p record) - (push record was)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) - (push record was)) - ((eq :moved (output-record-dirty record)) - (push (slot-value record 'old-bounds) was)) - (t - (map-over-output-records-overlapping-region #'gather-was - (old-children record) - everywhere)))) + (pane-viewport-region (updating-output-stream record)))) + (was-table (make-hash-table :test #'equalp)) + (is-table (make-hash-table :test #'equalp))) + + (labels ((collect-1-was (record) + (push record was) + (push record (gethash (output-record-hash record) was-table))) + (collect-1-is (record) + (push record is) + (push record (gethash (output-record-hash record) is-table)) + ;; come = is \ was + ;; stay = is ^ was + (cond ((updating-output-record-p record) + (if (eq :clean (output-record-dirty record)) + (push record stay) + (push record come))) (t - (map-over-output-records-overlapping-region #'gather-was record everywhere)) ))) - (gather-was record)) - ;; Collect what still is there - (labels ((gather-is (record) - (cond ((displayed-output-record-p record) - (push record is)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) - (push record is)) - ((eq :moved (output-record-dirty record)) - (push record is)) - (t - (map-over-output-records-overlapping-region #'gather-is - (sub-record record) - everywhere)))) - (t - (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) - (gather-is record)) + (let ((q (gethash (output-record-hash record) was-table))) + (if (some #'(lambda (x) (output-record-equal record x)) q) + (push record stay) + (push record come))))))) + ;; Collect what was there + (labels ((gather-was (record) + (cond ((displayed-output-record-p record) + (collect-1-was record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (collect-1-was record)) + ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds))) + (t + (map-over-output-records-overlapping-region #'gather-was + (old-children record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-was record everywhere))))) + (gather-was record)) + ;; Collect what still is there + (labels ((gather-is (record) + (cond ((displayed-output-record-p record) + (collect-1-is record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (collect-1-is record)) + ((eq :moved (output-record-dirty record)) + (collect-1-is record)) + (t + (map-over-output-records-overlapping-region #'gather-is + (sub-record record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) + (gather-is record))) ;; - (let ((was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp)) - gone - stay - come) - (loop for w in was do (push w (gethash (output-record-hash w) was-table))) - (loop for i in is do (push i (gethash (output-record-hash i) is-table))) + (let (gone) ;; gone = was \ is (loop for w in was do - (cond ((updating-output-record-p w) - (unless (eq :clean (output-record-dirty w)) - (push (old-children w) gone))) - (t - (let ((q (gethash (output-record-hash w) is-table))) - (unless (some #'(lambda (x) (output-record-equal w x)) q) - (push w gone)))))) - ;; come = is \ was - ;; stay = is ^ was - (loop for i in is do - (cond ((updating-output-record-p i) - (if (eq :clean (output-record-dirty i)) - (push i stay) - (push i come))) - (t - (let ((q (gethash (output-record-hash i) was-table))) - (if (some #'(lambda (x) (output-record-equal i x)) q) - (push i stay) - (push i come)))))) + (cond ((updating-output-record-p w) + (unless (eq :clean (output-record-dirty w)) + (push (old-children w) gone))) + (t + (let ((q (gethash (output-record-hash w) is-table))) + (unless (some #'(lambda (x) (output-record-equal w x)) q) + (push w gone)))))) ;; Now we essentially want 'gone', 'stay', 'come' (let ((gone-overlap nil) (come-overlap nil)) @@ -825,14 +829,14 @@ (loop for k in gone if (some (lambda (x) (region-intersects-region-p k x)) stay) - collect k into gone-overlap* + collect k into gone-overlap* else collect k into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come if (some (lambda (x) (region-intersects-region-p k x)) stay) - collect k into come-overlap* + collect k into come-overlap* else collect k into come* finally (return (values come* come-overlap*))))) ;; Hmm, we somehow miss come-overlap ...