;;; hmouse-drv.el --- Smart Key/Mouse driver functions.

;; Copyright (C) 1989-1995 Free Software Foundation, Inc.
;; Developed with support from Motorola Inc.

;; Author: Bob Weiner, Brown U.
;; Maintainer: Mats Lidell <matsl@contactor.se>
;; Keywords: hypermedia, mouse

;; This file is part of GNU Hyperbole.

;; GNU Hyperbole is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or (at
;; your option) any later version.

;; GNU Hyperbole is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;;;
;;; Other required Elisp libraries
;;;

(require 'hypb)

;;;
;;; Public variables
;;;

(defvar action-key-depress-window nil
  "The last window in which the Action Key was depressed or nil.")
(defvar assist-key-depress-window nil
  "The last window in which the Assist Key was depressed or nil.")
(defvar action-key-release-window nil
  "The last window in which the Action Key was released or nil.")
(defvar assist-key-release-window nil
  "The last window in which the Assist Key was released or nil.")

(defvar action-key-depress-prev-point nil
  "Marker at point prior to last Action Key depress.
Note that this may be a buffer different than where the depress occurs.")
(defvar assist-key-depress-prev-point nil
  "Marker at point prior to last Assist Key depress.
Note that this may be a buffer different than where the depress occurs.")
(defvar action-key-release-prev-point nil
  "Marker at point prior to last Action Key release.
Note that this may be a buffer different than where the release occurs.")
(defvar assist-key-release-prev-point nil
  "Marker at point prior to last Assist Key release.
Note that this may be a buffer different than where the release occurs.")

(defvar action-key-cancelled nil
  "When non-nil, cancels last Action Key depress.")
(defvar assist-key-cancelled nil
  "When non-nil, cancels last Assist Key depress.")

(defvar action-key-help-flag nil
  "When non-nil, forces display of help for next Action Key release.")
(defvar assist-key-help-flag nil
  "When non-nil, forces display of help for next Assist Key release.")

;;;
;;; Hyperbole context-sensitive key driver functions
;;;

(defun action-mouse-key (&rest args)
  "Set point to the current mouse cursor position and execute 'action-key'.
Any ARGS will be passed to 'hmouse-function'."
  (interactive)
  (require 'hsite)
  ;; Make this a no-op if some local mouse key binding overrode the global
  ;; action-key-depress command invocation.
  (if action-key-depressed-flag
      (let ((hkey-alist hmouse-alist))
	(setq action-key-depressed-flag nil)
	(cond (action-key-cancelled
		(setq action-key-cancelled nil
		      assist-key-depressed-flag nil))
	      (assist-key-depressed-flag
		(hmouse-function nil nil args))
	      ((action-mouse-key-help nil args))
	      (t (hmouse-function 'action-key nil args))))))

(defun assist-mouse-key (&rest args)
  "Set point to the current mouse cursor position and execute 'assist-key'.
Any ARGS will be passed to 'hmouse-function'."
  (interactive)
  (require 'hsite)
  ;; Make this a no-op if some local mouse key binding overrode the global
  ;; assist-key-depress command invocation.
  (if assist-key-depressed-flag
      (let ((hkey-alist hmouse-alist))
	(setq assist-key-depressed-flag nil)
	(cond (assist-key-cancelled
		(setq assist-key-cancelled nil
		      action-key-depressed-flag nil))
	      (action-key-depressed-flag
		(hmouse-function nil t args))
	      ((action-mouse-key-help t args))
	      (t (hmouse-function 'assist-key t args))))))

(defun hmouse-function (func assist-flag set-point-arg-list)
  "Executes FUNC for Action Key (Assist Key with ASSIST-FLAG non-nil) and sets point from SET-POINT-ARG-LIST.
FUNC may be nil in which case no function is called.
SET-POINT-ARG-LIST is passed to the call of the command bound to
'hmouse-set-point-command'.  Returns nil if 'hmouse-set-point-command' variable
is not bound to a valid function."
  (if (fboundp hmouse-set-point-command)
      (let ((release-args (hmouse-set-point set-point-arg-list)))
	(if assist-flag
	    (setq assist-key-release-window (selected-window)
		  assist-key-release-args release-args
		  assist-key-release-prev-point (point-marker))
	  (setq action-key-release-window (selected-window)
		action-key-release-args release-args
		action-key-release-prev-point (point-marker)))
	(and (eq major-mode 'br-mode)
	     (setq action-mouse-key-prev-window 
		   (if (br-in-view-window-p)
		       (save-window-excursion
			 (br-next-listing-window)
			 (selected-window))
		     (selected-window))))
	(setq action-mouse-key-prefix-arg current-prefix-arg)
	(if (null func)
	    nil
	  (funcall func)
	  (setq action-mouse-key-prev-window nil
		action-mouse-key-prefix-arg nil))
	t)))

(defun action-mouse-key-help (assist-flag args)
  "If a Smart Key help flag is set and the other Smart Key is not down, shows help.
Takes two args:  ASSIST-FLAG should be non-nil iff command applies to the Assist Key.
ARGS is a list of arguments passed to 'hmouse-function'.
Returns t if help is displayed, nil otherwise."
  (let ((help-shown)
	(other-key-released (not (if assist-flag
				     action-key-depressed-flag
				   assist-key-depressed-flag))))
    (unwind-protect
	(setq help-shown
	      (cond ((and  action-key-help-flag other-key-released)
		     (setq action-key-help-flag nil)
		     (hmouse-function 'hkey-help assist-flag args)
		     t)
		    ((and  assist-key-help-flag other-key-released)
		     (setq assist-key-help-flag nil)
		     (hmouse-function 'assist-key-help assist-flag args)
		     t)))
      (if help-shown
	  ;; Then both Smart Keys have been released. 
	  (progn (setq action-key-cancelled nil
		       assist-key-cancelled nil)
		 t)))))

(defun action-key ()
  "Use one key to perform functions that vary by buffer.
Default function is given by 'action-key-default-function' variable.
Returns t unless 'action-key-default-function' variable is not bound to a valid
function."
  (interactive)
  (require 'hsite)
  (or (hkey-execute nil)
      (if (fboundp action-key-default-function)
	 (progn (funcall action-key-default-function)
		t))))

(defun assist-key ()
  "Use one assist-key to perform functions that vary by buffer.
Default function is given by 'assist-key-default-function' variable.
Returns non-nil unless 'assist-key-default-function' variable is not bound
to a valid function."
  (interactive)
  (require 'hsite)
  (or (hkey-execute t)
      (if (fboundp assist-key-default-function)
	  (progn (funcall assist-key-default-function)
		 t))))

(defun hkey-execute (assist-flag)
  "Evaluate Action Key form (or Assist Key form with ASSIST-FLAG non-nil) for first non-nil predicate from 'hkey-alist'.
Non-nil ASSIST-FLAG means evaluate second form, otherwise evaluate first form.
Returns non-nil iff a non-nil predicate is found."
    (let ((pred-forms hkey-alist)
	  (pred-form) (pred-t))
      (while (and (null pred-t) (setq pred-form (car pred-forms)))
	(if (setq pred-t (eval (car pred-form)))
	    (eval (if assist-flag (cdr (cdr pred-form)) (car (cdr pred-form))))
	  (setq pred-forms (cdr pred-forms))))
      pred-t))

(defun hkey-help (&optional assist-flag)
  "Display help for the Action Key command in current context.
With optional ASSIST-FLAG non-nil, display help for the Assist Key command.
Returns non-nil iff associated help documentation is found."
  (interactive "P")
  (require 'hsite)
  (let ((pred-forms hkey-alist)
	(pred-form) (pred-t) (call) (cmd-sym) (doc))
    (while (and (null pred-t) (setq pred-form (car pred-forms)))
      (or (setq pred-t (eval (car pred-form)))
	  (setq pred-forms (cdr pred-forms))))
    (if pred-t
	(setq call (if assist-flag (cdr (cdr pred-form))
		     (car (cdr pred-form)))
	      cmd-sym (car call))
      (setq cmd-sym
	    (if assist-flag assist-key-default-function action-key-default-function)
	    call cmd-sym))
    (setq hkey-help-msg
	  (if (and cmd-sym (symbolp cmd-sym))
	      (progn
		(setq doc (documentation cmd-sym))
		(let* ((condition (car pred-form))
		       (temp-buffer-show-hook
			 (function
			   (lambda (buf)
			     (set-buffer buf)
			     (setq buffer-read-only t)
			     (if (br-in-browser)
				 (save-excursion
				   (let ((owind (selected-window)))
				     (br-to-view-window)
				     (select-window (previous-window))
				     (display-buffer buf 'other-win)
				     (select-window owind)))
			       (display-buffer buf 'other-win)))))
		       (temp-buffer-show-function temp-buffer-show-hook))
		  (with-output-to-temp-buffer (hypb:help-buf-name "Smart")
		    (princ (format "A click of the %s Key"
				   (if assist-flag "Assist" "Action")))
		    (terpri)
		    (princ "WHEN  ")
		    (princ
		      (or condition
			  "there is no matching context"))
		    (terpri)
		    (princ "CALLS ") (princ call)
		    (if doc (progn (princ " WHICH:") (terpri) (terpri)
				   (princ doc)))
		    (if (memq cmd-sym '(hui:hbut-act hui:hbut-help))
			(progn
			  (princ (format "\n\nBUTTON SPECIFICS:\n\n%s\n"
					 (actype:doc 'hbut:current t)))
			  (hattr:report
			    (nthcdr 2 (hattr:list 'hbut:current)))))
		    (terpri)
		    ))
		"")
	    (message "No %s Key command for current context."
		     (if assist-flag "Assist" "Action"))))
    doc))

(defun assist-key-help ()
  "Display doc associated with Assist Key command in current context.
Returns non-nil iff associated documentation is found."
  (interactive)
  (hkey-help 'assist))

(defun hkey-help-hide ()
  "Restores frame to configuration prior to help buffer display.
Point must be in the help buffer."
  (let ((buf (current-buffer)))
    (if *hkey-wconfig*
	(set-window-configuration *hkey-wconfig*)
      (switch-to-buffer (other-buffer)))
    (if (fboundp 'help-mode-bury)
	(help-mode-bury)
      (bury-buffer buf))
    (setq *hkey-wconfig* nil)))

(defun hkey-help-show (buffer &optional current-window)
  "Saves prior frame configuration if BUFFER displays help.  Displays BUFFER.

Optional second arg CURRENT-WINDOW non-nil forces display of buffer within
the current window.  By default, it is displayed in another window."
  (if (bufferp buffer) (setq buffer (buffer-name buffer)))
  (and (stringp buffer)
       (string-match "Help\\*$" buffer)
       (not (memq t (mapcar (function
			     (lambda (wind)
			       (string-match
				"Help\\*$"
				(buffer-name (window-buffer wind)))))
			    (hypb:window-list 'no-mini))))
       (setq *hkey-wconfig* (current-window-configuration)))
  (let* ((buf (get-buffer-create buffer))
	 (wind (if current-window
		   (progn (switch-to-buffer buf)
			  (selected-window))
		 (display-buffer buf))))
    (setq minibuffer-scroll-window wind)))

(defun hkey-operate (arg)
  "Uses the keyboard to emulate Smart Mouse Key drag actions.
Each invocation alternates between starting a drag and ending it.
Prefix ARG non-nil means emulate Assist Key rather than the Action Key.

Only works when running under a window system, not from a dumb terminal."
  (interactive "P")
  (or hyperb:window-system
      (hypb:error "(hkey-operate): Drag actions require mouse support"))
  (if arg
      (if assist-key-depressed-flag
	  (progn (assist-mouse-key)
		 (message "Assist Key released."))
	(assist-key-depress)
	(message
	  "Assist Key depressed; go to release point and hit {%s %s}."
	  (substitute-command-keys "\\[universal-argument]")
	  (substitute-command-keys "\\[hkey-operate]")
	  ))
    (if action-key-depressed-flag
	(progn (action-mouse-key)
	       (message "Action Key released."))
      (action-key-depress)
      (message "Action Key depressed; go to release point and hit {%s}."
	       (substitute-command-keys "\\[hkey-operate]"))
      )))

(defun hkey-summarize (&optional current-window)
  "Displays smart key operation summary in help buffer.
Optional arg CURRENT-WINDOW non-nil forces display of buffer within
the current window.  By default, it is displayed in another window."
  (let* ((doc-file (hypb:mouse-help-file))
	 (buf-name (hypb:help-buf-name "Smart"))
	 (wind (get-buffer-window buf-name))
	 owind)
    (if (file-readable-p doc-file)
	(progn
	  (if (br-in-browser)
	      (br-to-view-window))
	  (setq owind (selected-window))
	  (unwind-protect
	      (progn
		(if wind
		    (select-window wind)
		  (hkey-help-show buf-name current-window)
		  (select-window (get-buffer-window buf-name)))
		(setq buffer-read-only nil) (erase-buffer)
		(insert-file-contents doc-file)
		(goto-char (point-min))
		(set-buffer-modified-p nil))
	    (select-window owind))))))

;; 
;; Private variables
;; 

(defvar action-key-depress-args nil
  "List of mouse event args from most recent depress of the Action Key.")
(defvar assist-key-depress-args nil
  "List of mouse event args from most recent depress of the Assist Key.")

(defvar action-key-release-args nil
  "List of mouse event args from most recent release of the Action Key.")
(defvar assist-key-release-args nil
  "List of mouse event args from most recent release of the Assist Key.")

(defvar action-mouse-key-prev-window nil
  "Window point was in prior to current invocation of 'action/assist-mouse-key'.")

(defvar action-mouse-key-prefix-arg nil
  "Prefix argument to pass to 'smart-br-cmd-select'.")

(defvar action-key-depressed-flag nil "t while Action Key is depressed.")
(defvar assist-key-depressed-flag nil "t while Assist Key is depressed.")
(defvar hkey-help-msg "" "Holds last Smart Key help message.")
(defvar *hkey-wconfig* nil
  "Screen configuration prior to display of a help buffer.")

;;;
;;; public support functions
;;;

;; "hsite.el" contains documentation for this variable.
(or (boundp 'smart-scroll-proportional) (setq smart-scroll-proportional nil))

;; The smart keys scroll buffers when pressed at the ends of lines.
;; These next two functions do the scrolling and keep point at the end
;; of line to simplify repeated scrolls when using keyboard smart keys.
;;
;; These functions may also be used to test whether the scroll action would
;; be successful, no action is taken if it would fail (because the beginning
;; or end of a buffer is already showing) and nil is returned.
;; t is returned whenever scrolling is performed.

(defun smart-scroll-down ()
  "Scrolls down according to value of smart-scroll-proportional.
If smart-scroll-proportional is nil or if point is on the bottom window line,
scrolls down (backward) a windowful.  Otherwise, tries to bring current line
to bottom of window.  Leaves point at end of line and returns t if scrolled,
nil if not."
  (interactive)
  (let ((rtn t))
    (if smart-scroll-proportional
	;; If selected line is already last in window, then scroll backward
	;; a windowful, otherwise make it last in window.
	(if (>= (point) (save-excursion
			  (goto-char (1- (window-end)))
			  (beginning-of-line) (point)))
	    (if (pos-visible-in-window-p (point-min))
		(setq rtn nil)
	      (scroll-down))
	  (recenter -1))
      (if (pos-visible-in-window-p (point-min))
	  (setq rtn nil)
	(scroll-down)))
    (end-of-line)
    (or rtn (progn (beep) (message "Beginning of buffer")))
    rtn))

(defun smart-scroll-up ()
  "Scrolls up according to value of smart-scroll-proportional.
If smart-scroll-proportional is nil or if point is on the top window line,
scrolls up (forward) a windowful.  Otherwise, tries to bring current line to
top of window.  Leaves point at end of line and returns t if scrolled, nil if
not."
  (interactive)
  (let ((rtn t))
    (if smart-scroll-proportional
	;; If selected line is already first in window, then scroll forward a
	;; windowful, otherwise make it first in window.
	(if (<= (point) (save-excursion
			  (goto-char (window-start))
			  (end-of-line) (point)))
	    (if (pos-visible-in-window-p (point-max))
		(setq rtn nil)
	      (scroll-up))
	  (recenter 0))
      (if (pos-visible-in-window-p (point-max))
	  (setq rtn nil)
	(scroll-up)))
    (end-of-line)
    (or rtn (progn (beep) (message "End of buffer")))
    rtn))

(provide 'hmouse-drv)

;;; hmouse-drv.el ends here