[mcclim-cvs] CVS mcclim/Experimental

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/Experimental
In directory clnet:/tmp/cvs-serv28193/Experimental

Modified Files:
	pointer-doc-hack.lisp 
Log Message:
Added some amazing hacks to pointer-documentation-panes for the notion of a "background message".

This is the beginning of extending pointer-documentation-panes into
more generally useful minibuffer-like panes.

For now, this just means that the Listener shows arglists and other
things for Drei commands. It's still a little flickery, though.


--- /project/mcclim/cvsroot/mcclim/Experimental/pointer-doc-hack.lisp	2006/03/29 10:43:44	1.2
+++ /project/mcclim/cvsroot/mcclim/Experimental/pointer-doc-hack.lisp	2008/01/27 22:24:07	1.3
@@ -218,41 +218,52 @@
     (let ((x (device-event-x event))
 	  (y (device-event-y event))
 	  (pstream *pointer-documentation-output*))
-      (loop for (button presentation translator context)
-	    in new-translators
-	    for name = (cadr (assoc button +button-documentation+))
-	    for first-one = t then nil
-	    do (progn
-		 (unless first-one
-		   (stream-increment-cursor-position pstream 12 0)
-		   #+nil(write-string "; " pstream))
-		 (unless (zerop current-modifier)
-		   (print-modifiers pstream current-modifier :short)
-		   (write-string "-" pstream))
+      (if (null new-translators)
+          (when (and (background-message pstream)
+                     (not (record-on-display pstream (background-message pstream))))
+            (cond ((> (get-universal-time)
+                      (+ (background-message-time pstream)
+                         *background-message-minimum-lifetime*))
+                   (setf (background-message pstream) nil))
+                  (t
+                   (setf (output-record-parent (background-message pstream)) nil)
+                   (stream-add-output-record pstream (background-message pstream))
+                   (replay (background-message pstream) pstream))))
+          (loop for (button presentation translator context)
+                in new-translators
+                for name = (cadr (assoc button +button-documentation+))
+                for first-one = t then nil
+                do (progn
+                     (unless first-one
+                       (stream-increment-cursor-position pstream 12 0)
+                       #+nil(write-string "; " pstream))
+                     (unless (zerop current-modifier)
+                       (print-modifiers pstream current-modifier :short)
+                       (write-string "-" pstream))
 
-		 ;; Hefner's pointer-documentation hack.
-		 (setf name (cond 
-			      ((eql button +pointer-left-button+)   *icon-mouse-left*)
-			      ((eql button +pointer-middle-button+) *icon-mouse-middle*)
-			      ((eql button +pointer-right-button+)  *icon-mouse-right*)
-			      (t name)))
-		 (if (not (typep name 'indexed-pattern))  (format pstream "~A: " name)
-		   (multiple-value-bind (x y)  (stream-cursor-position pstream)
-		     (draw-pattern* pstream name x y)
-		     (stream-increment-cursor-position pstream 24 0)))
-		   
-		 (document-presentation-translator translator
-						   presentation
-						   (input-context-type context)
-						   *application-frame*
-						   event
-						   stream
-						   x y
-						   :stream pstream
-						   :documentation-type
-						   :pointer))   )
-	    ;finally nil #+nil (when new-translators
-		;		(write-char #\. pstream)))
+                     ;; Hefner's pointer-documentation hack.
+                     (setf name (cond 
+                                  ((eql button +pointer-left-button+)   *icon-mouse-left*)
+                                  ((eql button +pointer-middle-button+) *icon-mouse-middle*)
+                                  ((eql button +pointer-right-button+)  *icon-mouse-right*)
+                                  (t name)))
+                     (if (not (typep name 'indexed-pattern))  (format pstream "~A: " name)
+                         (multiple-value-bind (x y)  (stream-cursor-position pstream)
+                           (draw-pattern* pstream name x y)
+                           (stream-increment-cursor-position pstream 24 0)))
+           	   
+                     (document-presentation-translator translator
+                                                       presentation
+                                                       (input-context-type context)
+                                                       *application-frame*
+                                                       event
+                                                       stream
+                                                       x y
+                                                       :stream pstream
+                                                       :documentation-type
+                                                       :pointer))   ))
+                                        ;finally nil #+nil (when new-translators
+                                        ;		(write-char #\. pstream)))
       ;; Wasteful to do this after doing
       ;; find-innermost-presentation-context above... look at doing this
       ;; first and then doing the innermost test.