[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp

[Gilbert Baumann]

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv11427

Modified Files:
	incremental-redisplay.lisp 
Log Message:
incremental redisplay changes, part ii: 
If in UPDATING-OUTPUT the cache test passes but the y cursor
coordinate changed, instead of calling the display function again we
just move the record on our own.

Date: Sun May  8 20:15:44 2005
Author: gbaumann

Index: mcclim/incremental-redisplay.lisp
diff -u mcclim/incremental-redisplay.lisp:1.47 mcclim/incremental-redisplay.lisp:1.48
--- mcclim/incremental-redisplay.lisp:1.47	Sun May  8 20:09:11 2005
+++ mcclim/incremental-redisplay.lisp	Sun May  8 20:15:44 2005
@@ -349,10 +349,10 @@
 ;;;programmer forcing all new output.
 
 (defun state-matches-stream-p (state stream)
-  (multiple-value-bind (cx cy)
-      (stream-cursor-position stream)
+  (multiple-value-bind (cx cy) (stream-cursor-position stream)
     (with-sheet-medium (medium stream)
-      (match-output-records state :cursor-x cx :cursor-y cy))))
+      ;; Note: We don't match the y coordinate.
+      (match-output-records state :cursor-x cx))))
 
 (define-protocol-class updating-output-record (output-record))
 
@@ -825,6 +825,17 @@
 
 (defvar *no-unique-id* (cons nil nil))
 
+(defun move-output-record (record dx dy)
+  (multiple-value-bind (sx sy) (output-record-start-cursor-position record)
+    (multiple-value-bind (ex ey) (output-record-end-cursor-position record)
+      (setf (output-record-position record)
+            (values (+ (nth-value 0 (output-record-position record)) dx)
+                    (+ (nth-value 1 (output-record-position record)) dy)))
+      (setf (output-record-start-cursor-position record)
+            (values (+ sx dx) (+ sy dy)))
+      (setf (output-record-end-cursor-position record)
+            (values (+ ex dx) (+ ey dy))))))
+
 (defmethod invoke-updating-output ((stream updating-output-stream-mixin)
 				   continuation
 				   record-type
@@ -864,16 +875,10 @@
 	       (setf (end-graphics-state record)
 		     (medium-graphics-state stream))
 	       (add-to-map parent-cache record  unique-id id-test all-new)))
-	    ((or (setq state-mismatch
-		       (not (state-matches-stream-p (start-graphics-state
-						     record)
-						    stream)))
-		 (not (funcall cache-test
-			       cache-value
-			       (output-record-cache-value record))))
+	    ((or (setq state-mismatch (not (state-matches-stream-p (start-graphics-state record) stream)))
+		 (not (funcall cache-test cache-value (output-record-cache-value record))))
 	     (when *trace-updating-output*
-	       (format *trace-output* "~:[cache test~;stream state~] ~S~%"
-		       state-mismatch record))
+	       (format *trace-output* "~:[cache test~;stream state~] ~S~%" state-mismatch record))
 	     (let ((*current-updating-output* record))
 	       (setf (start-graphics-state record)
 		     (medium-graphics-state stream))
@@ -887,16 +892,29 @@
 	     ;; parent's sequence of records
 	     (when *trace-updating-output*
 	       (format *trace-output* "clean ~S~%" record))
-	     (setf (output-record-dirty record) :clean)
-	     (setf (output-record-parent record) nil)
-	     (map-over-updating-output #'(lambda (r)
-					   (setf (output-record-dirty r)
-						 :clean))
-				       record
-				       nil)
-	     (add-output-record record (stream-current-output-record stream))
-	     (set-medium-graphics-state (end-graphics-state record) stream)
-	     (setf (parent-cache record) parent-cache)))
+             ;;
+             (multiple-value-bind (cx cy) (stream-cursor-position stream)
+               (multiple-value-bind (sx sy) (output-record-start-cursor-position record)
+                 (let ((dx (- cx sx))
+                       (dy (- cy sy)))
+                   (unless (zerop dy)
+                     (move-output-record record dx dy) )
+                   (let ((tag (cond ((= dx dy 0) :clean)
+                                    (t :moved))))
+                     (setf (output-record-dirty record) tag)
+                     (setf (output-record-parent record) nil)
+                     (map-over-updating-output #'(lambda (r)
+                                                   (unless (eq r record)
+                                                     (incf (slot-value (start-graphics-state r) 'cursor-x) dx)
+                                                     (incf (slot-value (start-graphics-state r) 'cursor-y) dy)
+                                                     (incf (slot-value (end-graphics-state r) 'cursor-x) dx)
+                                                     (incf (slot-value (end-graphics-state r) 'cursor-y) dy))
+                                                   (setf (output-record-dirty r) tag))
+                                               record
+                                               nil)
+                     (add-output-record record (stream-current-output-record stream))
+                     (set-medium-graphics-state (end-graphics-state record) stream)
+                     (setf (parent-cache record) parent-cache) )) ))))
       record)))
 
 ;;; The Franz user guide says that updating-output does