[mcclim-cvs] CVS mcclim/Drei

[thenriksen]

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

Modified Files:
	drei-clim.lisp input-editor.lisp 
Log Message:
Added new and cooler with-input-editor-typeout implementation for Drei.

Still not used for anything inside McCLIM, but I hope to change input
completion to use it instead of menu-choose for some cases. The
biggest problem, I think, is that Goatee doesn't support
with-input-editor-typeout.


--- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp	2008/01/31 12:14:05	1.38
+++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp	2008/01/31 16:50:07	1.39
@@ -389,14 +389,20 @@
 
 (defmethod* (setf output-record-position) ((new-x number) (new-y number)
                                            (record drei-area))
-  (setf (area-position record) (list new-x new-y)))
+  (multiple-value-bind (old-x old-y) (output-record-position record)
+    (setf (area-position record) (list new-x new-y))
+    (dolist (cursor (cursors record))
+      (multiple-value-bind (cursor-x cursor-y) (output-record-position cursor)
+        (setf (output-record-position cursor)
+              (values (+ (- cursor-x old-x) new-x)
+                      (+ (- cursor-y old-y) new-y)))))))
 
 (defmethod output-record-start-cursor-position ((record drei-area))
   (output-record-position record))
 
 (defmethod* (setf output-record-start-cursor-position) ((new-x number) (new-y number)
                                                        (record drei-area))
-  (setf (output-record-position record) (list new-x new-y)))
+  (setf (output-record-position record) (values new-x new-y)))
 
 (defmethod output-record-hit-detection-rectangle* ((record drei-area))
   (bounding-rectangle* record))
--- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp	2008/01/31 11:19:35	1.32
+++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp	2008/01/31 16:50:07	1.33
@@ -46,7 +46,13 @@
                         :initform nil
                         :documentation "After a command has been
 executed, the contents of the Drei area instance shall be
-replaced by the contents of this array, if non-NIL."))
+replaced by the contents of this array, if non-NIL.")
+   (%typeout-record :accessor typeout-record
+                    :initform nil
+                    :documentation "The output record (if any)
+that is the typeout information for this Drei-based
+input-editing-stream. `With-input-editor-typeout' manages this
+output record."))
   (:documentation "An mixin that helps in implementing Drei-based
 input-editing streams. This class should not be directly
 instantiated."))
@@ -763,12 +769,39 @@
   (:documentation "Call `continuation' with a single argument, a
 stream to do input-editor-typeout on."))
 
-(defmethod invoke-with-input-editor-typeout ((stream drei-input-editing-mixin)
+(defmethod invoke-with-input-editor-typeout ((editing-stream drei-input-editing-mixin)
                                              (continuation function) &key erase)
-  (declare (ignore erase))
-  (with-bound-drei-special-variables ((drei-instance stream))
-    (with-minibuffer-stream (minibuffer)
-      (funcall continuation minibuffer))))
+  (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 new-typeout-record encapsulated-stream))))))
 
 (defmacro with-input-editor-typeout ((&optional (stream t) &rest args
                                                 &key erase)
@@ -778,12 +811,12 @@
 to an `extended-output-stream' while `body' is being evaluated."
   (declare (ignore erase))
   (check-type stream symbol)
-  (let ((stream (if (eq stream t) *standard-input* stream)))
-    `(apply #'invoke-with-input-editor-typeout
-            ,stream
-            #'(lambda (,stream)
-                , at body)
-            ,args)))
+  (let ((stream (if (eq stream t) '*standard-output* stream)))
+    `(invoke-with-input-editor-typeout
+      ,stream
+      #'(lambda (,stream)
+          , at body)
+      , at args)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;