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)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;