[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
Gilbert Baumann
gbaumann at common-lisp.net
Sun May 8 18:09:12 UTC 2005
Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv10559
Modified Files:
incremental-redisplay.lisp
Log Message:
Incremental redisplay changes, part i: checking for overlap.
Date: Sun May 8 20:09:11 2005
Author: gbaumann
Index: mcclim/incremental-redisplay.lisp
diff -u mcclim/incremental-redisplay.lisp:1.46 mcclim/incremental-redisplay.lisp:1.47
--- mcclim/incremental-redisplay.lisp:1.46 Tue Mar 8 11:46:16 2005
+++ mcclim/incremental-redisplay.lisp Sun May 8 20:09:11 2005
@@ -280,36 +280,33 @@
(defgeneric incremental-redisplay
(stream position erases moves draws erase-overlapping move-overlapping))
-(defmethod incremental-redisplay
- ((stream updating-output-stream-mixin) position
- erases moves draws erase-overlapping move-overlapping)
+(defmethod incremental-redisplay ((stream updating-output-stream-mixin) position
+ erases moves draws erase-overlapping move-overlapping)
(declare (ignore position))
(let ((history (stream-output-history stream)))
(with-output-recording-options (stream :record nil :draw t)
(loop
- for (nil br) in erases
- do (erase-rectangle stream br))
+ for (nil br) in erases
+ do (erase-rectangle stream br))
(loop
- for (nil old-bounding) in moves
- do (erase-rectangle stream old-bounding))
+ for (nil old-bounding) in moves
+ do (erase-rectangle stream old-bounding))
(loop
- for (nil br) in erase-overlapping
- do (erase-rectangle stream br))
+ for (nil br) in erase-overlapping
+ do (erase-rectangle stream br))
(loop
- for (nil old-bounding) in move-overlapping
- do (erase-rectangle stream old-bounding)))
+ for (nil old-bounding) in move-overlapping
+ do (erase-rectangle stream old-bounding)))
(loop
- for (r) in moves
- do (replay r stream))
+ for (r) in moves
+ do (replay r stream))
(loop
- for (r) in draws
- do (replay r stream))
- (loop
- for (r) in erase-overlapping
- do (replay history stream r))
- (loop
- for (r) in move-overlapping
- do (replay history stream r) )))
+ for (r) in draws
+ do (replay r stream))
+ (let ((res +nowhere+))
+ (loop for (r) in erase-overlapping do (setf res (region-union res r)))
+ (loop for (r) in move-overlapping do (setf res (region-union res r)))
+ (replay history stream res)) ))
(defclass updating-stream-state (complete-medium-state)
((cursor-x :accessor cursor-x :initarg :cursor-x :initform 0)
@@ -713,141 +710,113 @@
;;; work in progress
(defvar *existing-output-records* nil)
-;;; Helper functions for managing a hash table of records
+;;;
-(defun get-record-hash (record hash)
- (let ((bucket (gethash (slot-value record 'coordinates) hash)))
- (if (null bucket)
- (values nil nil)
- (let ((rec (find record bucket :test #'output-record-equal)))
- (if rec
- (values rec t)
- (values nil nil))))))
-
-(defun add-record-hash (record hash)
- (push record (gethash (slot-value record 'coordinates) hash nil)))
-
-(defun delete-record-hash (record hash)
- (let ((bucket (gethash (slot-value record 'coordinates) hash)))
- (if bucket
- (multiple-value-bind (new-bucket deleted)
- (delete-1 record bucket :test #'output-record-equal)
- (if deleted
- (progn
- (setf (gethash (slot-value record 'coordinates) hash)
- new-bucket)
- t)
- nil))
- nil)))
+(defmethod output-record-hash (record)
+ (slot-value record 'coordinates))
(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))
- (when (eq (output-record-dirty record) :clean)
- (return-from compute-difference-set (values nil nil nil nil nil)))
- (let* ((draws nil)
- (moves (explicit-moves record))
- (erases nil)
- (erase-overlapping nil)
- (move-overlapping nil)
- (stream (updating-output-stream record))
- (visible-region (pane-viewport-region stream))
- (old-children (if (slot-boundp record 'old-children)
- (old-children record)
- nil))
- (old-bounds (old-bounds record)))
- (unless (or (null visible-region)
- (region-intersects-region-p visible-region record)
- (and old-children
- (region-intersects-region-p visible-region old-bounds)))
- (return-from compute-difference-set (values nil nil nil nil nil)))
- ;; XXX This means that compute-difference-set can't be called repeatedly on
- ;; the same tree; ugh. On the other hand, if we don't clear explicit-moves,
- ;; they can hang around in the tree for later passes and cause trouble.
- (setf (explicit-moves record) nil)
- (let ((existing-output-records (make-hash-table :test 'equalp)))
- ;; Find output records in the new tree that match a record in the old
- ;; tree i.e., already have a valid display on the screen.
- (map-over-child-display
- (if old-children
- #'(lambda (r)
- (add-record-hash r existing-output-records))
- #'(lambda (r) (push (list r r) draws)))
- (sub-record record)
- visible-region)
- (when old-children
- (map-over-child-display
- #'(lambda (r)
- (unless (delete-record-hash r existing-output-records)
- (push (list r (copy-bounding-rectange r)) erases)))
- old-children
- visible-region)
- ;; Any records left in the hash table do not have a counterpart
- ;; visible on the screen and need to be drawn.
- (loop
- for bucket being the hash-values of existing-output-records
- do (loop
- for r in bucket
- do (push (list r r) draws)))))
- (when check-overlapping
- (setf erase-overlapping (nconc erases draws))
- (setf move-overlapping moves)
- (setf erases nil)
- (setf moves nil)
- (setf draws nil))
- ;; Visit this record's updating-output children and merge in the
- ;; difference set. We need to visit all updating-output records, not just
- ;; ones in the visible region, because they might have old records that
- ;; lie in the visible region and that need to be erased.
- (map-over-child-updating-output
- #'(lambda (r)
- (multiple-value-bind (e m d e-o m-o)
- (compute-difference-set r check-overlapping)
- (setf erases (nconc e erases))
- (setf moves (nconc m moves))
- (setf draws (nconc d draws))
- (setf erase-overlapping (nconc e-o erase-overlapping))
- (setf move-overlapping (nconc m-o move-overlapping))))
- (sub-record record)
- nil)
- ;; Look for updating-output children that were not visited. Their
- ;; display records need to be erased.
- (when old-children
- (flet ((erase-obsolete (dr) ;All of them
- (let ((erase-chunk (list dr (copy-bounding-rectange dr))))
- (if check-overlapping
- (push erase-chunk erase-overlapping)
- (push erase-chunk erases)))))
- (declare (dynamic-extent #'erase-obsolete))
- (map-over-child-updating-output
- #'(lambda (r)
- (when (eq (output-record-dirty r) :updating)
- (map-over-obsolete-display #'erase-obsolete
- (sub-record r)
- visible-region)))
- old-children
- visible-region)))
- ;; Traverse all the display records for this updating output node and do
- ;; the notes...
- (flet ((note-got (r)
- (note-output-record-got-sheet r stream))
- (note-lost (r)
- (note-output-record-lost-sheet r stream)))
- (declare (dynamic-extent #'note-got #'note-lost))
- (map-over-child-display #'note-got (sub-record record) nil)
- (when old-children
- (map-over-child-display #'note-lost old-children nil)
- (map-over-child-updating-output
- #'(lambda (r)
- (when (eq (output-record-dirty r) :updating)
- (map-over-obsolete-display #'note-lost
- (sub-record r)
- nil)))
- old-children
- nil)))
- (values erases moves draws erase-overlapping move-overlapping)))
+ ;; (declare (values erases moves draws erase-overlapping move-overlapping))
+ (let (was
+ is
+ (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))))
+ (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 ((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)))
+ ;; 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))))))
+ ;; Now we essentially want 'gone', 'stay', 'come'
+ (let ((gone-overlap nil)
+ (come-overlap nil))
+ (when check-overlapping
+ (setf (values gone gone-overlap)
+ (loop for k in gone
+ if (some (lambda (x) (region-intersects-region-p k x))
+ stay)
+ 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*
+ else collect k into come*
+ finally (return (values come* come-overlap*)))))
+ ;; Hmm, we somehow miss come-overlap ...
+ (values
+ ;; erases
+ (loop for k in gone collect (list k k))
+ ;; moves
+ nil
+ ;; draws
+ (loop for k in come collect (list k k))
+ ;; erase overlapping
+ (append (loop for k in gone-overlap collect (list k k))
+ (loop for k in come-overlap collect (list k k)))
+ ;; move overlapping
+ nil)))))
(defparameter *enable-updating-output* t
"Switch to turn on incremental redisplay")
More information about the Mcclim-cvs
mailing list