Skip to content
Snippets Groups Projects
frames.lisp 46.8 KiB
Newer Older
cer's avatar
cer committed
(defvar *pointer-documentation-interval*
	(max (floor (* 1/10 internal-time-units-per-second)) 1))
(defvar *last-pointer-documentation-time* 0)
cer's avatar
cer committed

cer's avatar
cer committed
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
	   ((frame standard-application-frame) presentation input-context window x y stream)
cer's avatar
cer committed
  (frame-manager-display-pointer-documentation
    (frame-manager frame) frame presentation input-context window x y stream))

(defmethod frame-manager-display-pointer-documentation
	   ((framem standard-frame-manager)
	    frame presentation input-context window x y stream)
  (when stream
cer's avatar
cer committed
    ;; The documentation should never say anything if we're not over a presentation
    (when (null presentation) 
cer's avatar
cer committed
      (window-clear stream))
cer's avatar
cer committed
    ;; Cheap test to not do this work too often
    (let ((old-modifier-state *last-pointer-documentation-modifier-state*)
	  (modifier-state (window-modifier-state window))
	  (last-time *last-pointer-documentation-time*)
	  (time (get-internal-real-time)))
      (setq *last-pointer-documentation-modifier-state* modifier-state)
      (when (and (< time (+ last-time *pointer-documentation-interval*))
		 (= modifier-state old-modifier-state))
cer's avatar
cer committed
	(return-from frame-manager-display-pointer-documentation nil))
cer's avatar
cer committed
      (setq *last-pointer-documentation-time* time))
    (when presentation
      (with-output-recording-options (stream :record nil)
	(with-end-of-line-action (stream :allow)
	  (with-end-of-page-action (stream :allow)
	    (window-clear stream)
	    (when (null (frame-document-highlighted-presentation-1
			  frame presentation input-context window x y stream))
	      (setq *last-pointer-documentation-time* 0))
	    (force-output stream)))))))

(defun frame-document-highlighted-presentation-1
       (frame presentation input-context window x y stream)
  (let ((modifier-state (window-modifier-state window)))
cer's avatar
cer committed
    (declare (type fixnum modifier-state))
cer's avatar
cer committed
    (multiple-value-bind (left   left-presentation   left-context
			  middle middle-presentation middle-context
			  right  right-presentation  right-context)
cer's avatar
cer committed
	(find-applicable-translators-for-documentation presentation input-context
						       frame window x y modifier-state)
      (let* ((*print-length* 3)
	     (*print-level* 2)
	     (*print-circle* nil)
	     (*print-array* nil)
	     (*print-readably* nil)
	     (*print-pretty* nil))
cer's avatar
cer committed
	(flet ((document-translator (translator presentation context-type
				     button-name separator)
cer's avatar
cer committed
		 ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
		 (let ((bit #o20)
		       (shift-name '("h-" "s-" "m-" "c-" "sh-")))
cer's avatar
cer committed
		   (declare (type fixnum bit))
cer's avatar
cer committed
		   (repeat 5			;length of shift-name
cer's avatar
cer committed
		     (unless (zerop (logand bit modifier-state))
		       (write-string (car shift-name) stream))
		     (pop shift-name)
		     (setq bit (the fixnum (ash bit -1)))))
		 (write-string button-name stream)
		 (document-presentation-translator translator presentation context-type
						   frame nil window x y
						   :stream stream
						   :documentation-type :pointer)
		 (write-string separator stream)))
	  (declare (dynamic-extent #'document-translator))
cer's avatar
cer committed
	  ;;--- The button names should be hard-wired in.  Consider 1-button
	  ;;--- Macs and 2-button PCs...
cer's avatar
cer committed
	  (when left
cer's avatar
cer committed
	    (let ((button-name (cond ((and (eq left middle)
					   (eq left right))
cer's avatar
cer committed
				      (setq middle nil
					    right nil)
				      "L,M,R: ")
cer's avatar
cer committed
				     ((eq left middle) 
cer's avatar
cer committed
				      (setq middle nil)
				      "L,M: ")
				     (t "L: "))))
cer's avatar
cer committed
	      (document-translator left left-presentation left-context
				   button-name (if (or middle right) "; " "."))))
cer's avatar
cer committed
	  (when middle
cer's avatar
cer committed
	    (let ((button-name (cond ((eq middle right)
cer's avatar
cer committed
				      (setq right nil)
				      "M,R: ")
				     (t "M: "))))
cer's avatar
cer committed
	      (document-translator middle middle-presentation middle-context
				   button-name (if right "; " "."))))
cer's avatar
cer committed
	  (when right
cer's avatar
cer committed
	    (document-translator right right-presentation right-context
				 "R: " "."))
cer's avatar
cer committed
	  ;; Return non-NIL if any pointer documentation was produced
	  (or left middle right))))))

;; This is derived directly from FIND-APPLICABLE-TRANSLATORS
(defun find-applicable-translators-for-documentation
       (presentation input-context frame window x y modifier-state)
  ;; Assume a maximum of three pointer buttons
cer's avatar
cer committed
  (let ((left nil)   (left-presentation nil)   (left-context nil)
	(middle nil) (middle-presentation nil) (middle-context nil)
	(right nil)  (right-presentation nil)  (right-context nil))
    (macrolet ((match (translator presentation context-type button)
		 (let* ((symbol (symbol-name button))
			(button-translator (intern symbol))
			(button-presentation (fintern "~A-~A" symbol 'presentation))
			(button-context (fintern "~A-~A" symbol 'context)))
cer's avatar
cer committed
		   `(when (and (or (null ,button-translator)
				   (> (presentation-translator-priority ,translator)
				      (presentation-translator-priority ,button-translator)))
			       (button-and-modifier-state-matches-gesture-name-p
				 (button-index ,button) modifier-state
				 (presentation-translator-gesture-name ,translator)))
		      (setq ,button-translator ,translator
cer's avatar
cer committed
			    ,button-presentation ,presentation
cer's avatar
cer committed
			    ,button-context ,context-type)))))
      (do ((presentation presentation
			 (parent-presentation-with-shared-box presentation window)))
	  ((null presentation))
	(let ((from-type (presentation-type presentation)))
	  (dolist (context input-context)
	    (let ((context-type (pop context)))	;input-context-type = first
	      (let ((translators (find-presentation-translators 
				   from-type context-type (frame-command-table frame))))
		(when translators
		  (dolist (translator translators)
		    (when (test-presentation-translator translator
							presentation context-type
							frame window x y
							:modifier-state modifier-state)
cer's avatar
cer committed
		      (match translator presentation context-type :left)
		      (match translator presentation context-type :middle)
		      (match translator presentation context-type :right)))))
cer's avatar
cer committed
	      (when (and (or left middle right)
			 *presentation-menu-translator*
			 (test-presentation-translator *presentation-menu-translator*
						       presentation context-type
						       frame window x y
						       :modifier-state modifier-state))
cer's avatar
cer committed
		(match *presentation-menu-translator* presentation context-type :left)
		(match *presentation-menu-translator* presentation context-type :middle)
		(match *presentation-menu-translator* presentation context-type :right)))))))
    (values left   left-presentation   left-context
	    middle middle-presentation middle-context
	    right  right-presentation  right-context)))
cer's avatar
cer committed

cer's avatar
cer committed
;;;;

(defmethod execute-command-in-frame ((frame standard-application-frame) command)
  (distribute-event
   (port frame)
   (make-instance 'presentation-event
cer's avatar
cer committed
		  :frame frame
cer's avatar
cer committed
		  :sheet (frame-top-level-sheet frame)
		  :value command)))

(define-condition synchronous-command-event ()
  ((command :initarg :command :reader synchronous-command-event-command)))

(defmethod read-frame-command :around ((frame standard-application-frame) &key)
  (let* ((command (queue-pop (frame-command-queue frame))))
    (or command 
	(handler-bind ((synchronous-command-event
			#'(lambda (c)
			    (return-from read-frame-command
			      (synchronous-command-event-command c)))))
	  (call-next-method)))))
	

;; Actually this should be treated as a command event

(defclass presentation-event (event)
	  ((value :initarg :value :reader presentation-event-value)
	   (sheet :initarg :sheet :reader event-sheet)
	   (frame :initarg :frame :reader event-frame)
	   (presentation-type :initarg :presentation-type 
			      :reader event-presentation-type)))

(defmethod handle-event (sheet (event presentation-event))
  (process-command-event sheet event))

(defun process-command-event (sheet event)
  (when (and (eq *application-frame* (event-frame event)) *input-buffer-empty*)
    (signal 'synchronous-command-event :command (presentation-event-value event)))
cer's avatar
cer committed
  ;;--- Perhaps if this results directly from a user action then either
  ;;--- we should do it right away, ie. loose the input buffer or beep if
  ;;---  it has to be deffered.
  ;; If you ask me it might be better to beep.
cer's avatar
cer committed
  (queue-frame-command (event-frame event) (presentation-event-value event)))

(defun queue-frame-command (frame command)
  (queue-push (frame-command-queue frame) command))