[mcclim-cvs] CVS mcclim
thenriksen
thenriksen at common-lisp.net
Fri Feb 1 20:28:46 UTC 2008
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv19045
Modified Files:
commands.lisp input-editing-drei.lisp
input-editing-goatee.lisp input-editing.lisp
Log Message:
Implemented generic input-editor typeout, provided we can get an
output record for the input editor.
Theoretically, the nice typeout implementation should now also work
for Goatee, though I seem to have broken it at some other point.
--- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/29 22:27:11 1.75
+++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/02/01 20:28:46 1.76
@@ -1225,7 +1225,7 @@
;;; In order for this to work, the input-editing-stream must implement
;;; a method for the nonstandard function
-;;; `input-editing-stream-bounding-rectangle'.
+;;; `input-editing-stream-output-record'.
(defun command-line-read-remaining-arguments-for-partial-command
(command-table stream partial-command start-position)
(declare (ignore start-position))
@@ -1233,8 +1233,7 @@
*command-parser-table*))))
(if (encapsulating-stream-p stream)
(let ((interactor (encapsulating-stream-stream stream)))
- (multiple-value-bind (x1 y1 x2 y2)
- (input-editing-stream-bounding-rectangle stream)
+ (with-bounding-rectangle (x1 y1 x2 y2) (input-editing-stream-output-record stream)
(declare (ignore y1 x2))
;; Start the dialog below the editor area
(letf (((stream-cursor-position interactor) (values x1 y2)))
--- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/31 19:17:57 1.11
+++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/02/01 20:28:46 1.12
@@ -31,6 +31,7 @@
(defclass standard-input-editing-stream (drei:drei-input-editing-mixin
empty-input-mixin
+ standard-input-editing-mixin
input-editing-stream
standard-encapsulating-stream)
((scan-pointer :accessor stream-scan-pointer :initform 0)
@@ -119,7 +120,7 @@
((stream-drawing-p real-stream)
(replay record real-stream) ))
(setf (stream-cursor-position real-stream)
- (values 0 (nth-value 3 (input-editing-stream-bounding-rectangle stream))))))
+ (values 0 (bounding-rectangle-max-y (input-editing-stream-output-record stream))))))
;; XXX: We are supposed to implement input editing for all
;; "interactive streams", but that's not really reasonable. We only
@@ -152,8 +153,8 @@
(setf (rescan-queued stream) nil)
(immediate-rescan stream)))
-(defmethod input-editing-stream-bounding-rectangle ((stream standard-input-editing-stream))
- (bounding-rectangle* (view (drei:drei-instance stream))))
+(defmethod input-editing-stream-output-record ((stream standard-input-editing-stream))
+ (drei:drei-instance stream))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
--- /project/mcclim/cvsroot/mcclim/input-editing-goatee.lisp 2008/01/30 15:58:14 1.2
+++ /project/mcclim/cvsroot/mcclim/input-editing-goatee.lisp 2008/02/01 20:28:46 1.3
@@ -27,6 +27,7 @@
(defclass goatee-input-editing-stream (empty-input-mixin
goatee:goatee-input-editing-mixin
+ standard-input-editing-mixin
input-editing-stream
standard-encapsulating-stream)
((buffer :reader stream-input-buffer
@@ -149,5 +150,5 @@
(setf (rescan-queued stream) nil)
(immediate-rescan stream)))
-(defmethod input-editing-stream-bounding-rectangle ((stream goatee-input-editing-stream))
- (bounding-rectangle* (area stream)))
\ No newline at end of file
+(defmethod input-editing-stream-output-record ((stream goatee-input-editing-stream))
+ (area stream))
--- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/01 12:01:10 1.65
+++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/01 20:28:46 1.66
@@ -57,6 +57,16 @@
(:method (stream)
(cl:interactive-stream-p stream))))
+(defclass standard-input-editing-mixin ()
+ ((%typeout-record :accessor typeout-record
+ :initform nil
+ :documentation "The output record (if any)
+that is the typeout information for this
+input-editing-stream. `With-input-editor-typeout' manages this
+output record."))
+ (:documentation "A mixin implementing some useful standard
+behavior for input-editing streams."))
+
;;; These helper functions take the arguments of ACCEPT so that they
;;; can be used directly by ACCEPT.
@@ -167,6 +177,93 @@
do (return t)
finally (return nil)))
+(defmacro with-input-editor-typeout ((&optional (stream t) &rest args
+ &key erase)
+ &body body)
+ "Clear space above the input-editing stream `stream' and
+evaluate `body', capturing output done to `stream'. Place will be
+obtained above the input-editing area and the output put
+there. Nothing will be displayed until `body' finishes. `Stream'
+is not evaluated and must be a symbol. If T (the default),
+`*standard-input*' will be used. `Stream' will be bound to an
+`extended-output-stream' while `body' is being evaluated."
+ (declare (ignore erase))
+ (check-type stream symbol)
+ (let ((stream (if (eq stream t) '*standard-output* stream)))
+ `(invoke-with-input-editor-typeout
+ ,stream
+ #'(lambda (,stream)
+ , at body)
+ , at args)))
+
+(defgeneric invoke-with-input-editor-typeout (stream continuation &key erase)
+ (:documentation "Call `continuation' with a single argument, a
+stream to do input-editor-typeout on."))
+
+(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 (bounding-rectangle-height record)) 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 invoke-with-input-editor-typeout ((editing-stream standard-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 (input-editing-stream-output-record editing-stream)))
+ (with-accessors ((stream-typeout-record typeout-record)) editing-stream
+ (with-sheet-medium (medium 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)))))))))
+
+(defun clear-typeout (&optional (stream t))
+ "Blank out the input-editor typeout displayed on `stream',
+defaulting to T for `*standard-output*'."
+ (with-input-editor-typeout (stream :erase t)
+ (declare (ignore stream))))
+
(defmacro with-input-editing ((&optional (stream t)
&rest args
&key input-sensitizer (initial-contents "")
@@ -219,27 +316,6 @@
(stream-scan-pointer ,stream-var))))
, at body)))
-(defmacro with-input-editor-typeout ((&optional (stream t) &rest args
- &key erase)
- &body body)
- "`Stream' is not evaluated and must be a symbol. If T (the
-default), `*standard-input*' will be used. `Stream' will be bound
-to an `extended-output-stream' while `body' is being evaluated."
- (declare (ignore erase))
- (check-type stream symbol)
- (let ((stream (if (eq stream t) '*standard-output* stream)))
- `(invoke-with-input-editor-typeout
- ,stream
- #'(lambda (,stream)
- , at body)
- , at args)))
-
-(defun clear-typeout (&optional (stream t))
- "Blank out the input-editor typeout displayed on `stream',
-defaulting to T for `*standard-output*'."
- (with-input-editor-typeout (stream :erase t)
- (declare (ignore stream))))
-
(defun input-editing-rescan-loop (editing-stream continuation)
(let ((start-scan-pointer (stream-scan-pointer editing-stream)))
(loop (block rescan
@@ -301,14 +377,11 @@
(with-activation-gestures (*standard-activation-gestures*)
(call-next-method)))
-(defgeneric invoke-with-input-editor-typeout (stream continuation &key erase)
- (:documentation "Call `continuation' with a single argument, a
-stream to do input-editor-typeout on."))
-
-(defgeneric input-editing-stream-bounding-rectangle (stream)
- (:documentation "Return the bounding rectangle of `stream' as
-four values. This function does not appear in the spec but is
-used by the command processing code for layout."))
+(defgeneric input-editing-stream-output-record (stream)
+ (:documentation "Return the output record showing the display of the
+input-editing stream `stream' values. This function does not
+appear in the spec but is used by the command processing code for
+layout and to implement a general with-input-editor-typeout."))
(defmethod input-editor-format ((stream t) format-string &rest format-args)
(unless (and (typep stream '#.*string-input-stream-class*)
More information about the Mcclim-cvs
mailing list