[mcclim-cvs] CVS mcclim/Drei

[thenriksen]

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

Modified Files:
	input-editor.lisp 
Log Message:
Improved the implementation of with-input-editor-typeout yet again.


--- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp	2008/01/31 19:17:56	1.34
+++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp	2008/02/01 00:23:36	1.35
@@ -756,40 +756,68 @@
 ;;; 
 ;;; `With-input-editor-typeout'
 ;;;
+;;; Clears some space above the input-editing stream, moving other
+;;; output records on the sheet down, and prints the output. Nothing
+;;; is displayed until after the with-input-editor-typeout body is
+;;; done.
+
+(defun sheet-move-output-vertically (sheet y delta-y)
+  "Move the output records of `sheet', starting at vertical
+device unit offset `y' or below, down by `delta-y' device units,
+then repaint `sheet'."
+  (unless (zerop delta-y)
+    (with-bounding-rectangle* (sheet-x1 sheet-y1 sheet-x2 sheet-y2) sheet
+      (declare (ignore sheet-x1 sheet-y1))
+      (map-over-output-records-overlapping-region
+       #'(lambda (record)
+           (multiple-value-bind (record-x record-y) (output-record-position record)
+             (when (>= record-y y)
+               (setf (output-record-position record)
+                     (values record-x (+ record-y delta-y))))))
+       (stream-output-history sheet)
+       (make-bounding-rectangle 0 y sheet-x2 sheet-y2))
+      ;; Only repaint within the visible region...
+      (with-bounding-rectangle* (viewport-x1 viewport-y1 viewport-x2 viewport-y2)
+          (or (pane-viewport-region sheet) sheet)
+        (declare (ignore viewport-y1))
+        (repaint-sheet sheet (make-bounding-rectangle viewport-x1 (- y (abs delta-y))
+                                                      viewport-x2 viewport-y2))))))
 
 (defmethod climi::invoke-with-input-editor-typeout ((editing-stream drei-input-editing-mixin)
                                                     (continuation function) &key erase)
+  (declare (ignore erase))
   (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream))
          (new-typeout-record (with-output-to-output-record (encapsulated-stream)
                                (funcall continuation encapsulated-stream)))
          (editor-record (drei-instance editing-stream)))
     (with-accessors ((stream-typeout-record typeout-record)) editing-stream
       (with-sheet-medium (medium encapsulated-stream)
-        (with-bounding-rectangle* (x1 y1 x2 y2) editor-record
-          ;; Clear the input-editor display.
-          (draw-rectangle* medium x1 y1 x2 y2 :ink +background-ink+)
-          (setf (output-record-position new-typeout-record)
-                (output-record-position (or stream-typeout-record editor-record))
-                (output-record-position editor-record)
-                (values x1 (+ y1 (- (bounding-rectangle-height new-typeout-record)
-                                    (if stream-typeout-record
-                                        (bounding-rectangle-height stream-typeout-record)
-                                        0)))))
-          (when erase
-            (with-bounding-rectangle* (x1 y1 x2 y2) new-typeout-record
-              (draw-rectangle* medium x1 y1 x2 y2 :ink +background-ink+)))
-          ;; Reuse the old stream-typeout-record, if any.
-          (cond (stream-typeout-record
-                 ;; Blank the old one.
-                 (with-bounding-rectangle* (x1 y1 x2 y2) stream-typeout-record
-                   (draw-rectangle* medium x1 y1 (1+ x2) y2 :ink +background-ink+))
-                 (clear-output-record stream-typeout-record)
-                 (add-output-record new-typeout-record stream-typeout-record))
-                (t
-                 (stream-add-output-record encapsulated-stream new-typeout-record)
-                 (setf stream-typeout-record new-typeout-record)))
-          ;; Now, let there be light!
-          (replay stream-typeout-record encapsulated-stream))))))
+        (setf (output-record-position new-typeout-record)
+              (values 0 (bounding-rectangle-min-y (or stream-typeout-record editor-record))))
+        ;; Calculate the height difference between the old typeout and the new.
+        (let ((delta-y (- (bounding-rectangle-height new-typeout-record)
+                          (if stream-typeout-record
+                              (bounding-rectangle-height stream-typeout-record)
+                              0))))
+          (multiple-value-bind (typeout-x typeout-y)
+              (output-record-position new-typeout-record)
+            (declare (ignore typeout-x))
+            ;; Clear the old typeout.
+            (when stream-typeout-record
+              (clear-output-record stream-typeout-record))
+            (sheet-move-output-vertically encapsulated-stream typeout-y delta-y)
+            ;; Reuse the old stream-typeout-record, if any.
+            (cond (stream-typeout-record
+                   (add-output-record new-typeout-record stream-typeout-record))
+                  (t
+                   (stream-add-output-record encapsulated-stream new-typeout-record)
+                   (setf stream-typeout-record new-typeout-record)))
+            ;; Now, let there be light!
+            (with-bounding-rectangle* (x1 y1 x2 y2) stream-typeout-record
+              (declare (ignore x2))
+              (repaint-sheet encapsulated-stream
+                             (make-bounding-rectangle
+                              x1 y1 (bounding-rectangle-width encapsulated-stream) y2)))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;