;;!emacs
;;
;; FILE:         hmouse-key.el
;; SUMMARY:      System-dependent key bindings for Hyperbole mouse control.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:     3-Sep-91 at 21:40:58
;; LAST-MOD:     10-May-93 at 12:27:42 by Bob Weiner
;;
;; This file is part of Hyperbole.
;; 
;; Copyright (C) 1991, 1993, Brown University, Providence, RI
;; Developed with support from Motorola Inc.
;; 
;; Permission to use, modify and redistribute this software and its
;; documentation for any purpose other than its incorporation into a
;; commercial product is hereby granted without fee.  A distribution fee
;; may be charged with any redistribution.  Any distribution requires
;; that the above copyright notice appear in all copies, that both that
;; copyright notice and this permission notice appear in supporting
;; documentation, and that neither the name of Brown University nor the
;; author's name be used in advertising or publicity pertaining to
;; distribution of the software without specific, written prior permission.
;; 
;; Brown University makes no representations about the suitability of this
;; software for any purpose.  It is provided "as is" without express or
;; implied warranty.
;;
;;
;; DESCRIPTION:  
;;
;;   Supports Epoch, Lucid Emacs, X, Sunview, NeXTstep, and Apollo DM
;;   window systems.
;;
;;   'sm-mouse-setup' globally binds middle and right mouse buttons as
;;   primary and secondary Smart Keys respectively.
;;
;;   'sm-mouse-toggle-bindings' may be bound to a key.  It switches between
;;   Smart Key mouse bindings and previous mouse key bindings any time
;;   after 'sm-mouse-setup' has been called.
;;
;; DESCRIP-END.

;;; ************************************************************************
;;; Public variables
;;; ************************************************************************

;; Emacs version variables duplicated here from "hsite.el" in case this is
;; used as part of smart key package without loading Hyperbole.
;;
(defvar hyperb:epoch-p
  (if (boundp 'epoch::version)
      (if (string< epoch::version "Epoch 4") "V3" "V4"))
  "Simplified Epoch version string, e.g. \"V4\", else nil.")

(defvar hyperb:lemacs-p
  (let ((case-fold-search t))
    (if (string-match "Lucid" emacs-version)
	emacs-version))
  "Lucid Emacs version string.")

(defvar hyperb:emacs19-p
  (let ((case-fold-search t))
    (if (string-match "^19\\." emacs-version)
	emacs-version))
  "GNU Emacs 19 version string.")

(defun sm-window-sys-term ()
  "Returns the first part of the term-type if running under a window system, else nil.
Where a part in the term-type is delimited by a '-' or  an '_'."
  (let ((term (cond ((eq window-system 'x)
		     (cond (hyperb:emacs19-p "emacs19")
			   (hyperb:lemacs-p  "lemacs")
			   (hyperb:epoch-p   "epoch")
			   (t                "xterm")))
		    ((or (featurep 'eterm-fns) (equal (getenv "TERM") "eterm"))
		     "next")
		    ((or window-system 
			 (featurep 'mouse)     (featurep 'x-mouse)
			 (featurep 'sun-mouse) (featurep 'apollo))
		     (getenv "TERM")))))
    (and term
	 (substring term 0 (string-match "[-_]" term)))))

(defvar hyperb:window-system (sm-window-sys-term)
  "String name for window system or term type under which Emacs was run.")

(eval (cdr (assoc hyperb:window-system
		  '(("emacs19" . (require 'mouse))       ; GNU Emacs V19
		    ("lemacs"  . (require 'x-mouse))     ; Lucid Emacs
		    ("xterm"   . (require 'x-mouse))     ; X
		    ("epoch"   . (require 'mouse))       ; UofI Epoch
		    ("next"    . (require 'eterm-fns))   ; NeXTstep
		    ("sun"     . (require 'sun-fns))     ; SunView
		    ("apollo"  . (require 'apollo))      ; Display Manager
		    ))))

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

(defun sm-mouse-get-bindings ()
  "Returns list of bindings for mouse keys prior to their use as Smart Keys."
  (eval
    (cdr (assoc
	   hyperb:window-system
	   '(("emacs19" .
	      (mapcar (function
			(lambda (key) (cons key (lookup-key global-map key))))
		      '([down-mouse-2] [mouse-2] [down-mouse-3] [mouse-3]
			[mode-line down-mouse-2] [mode-line mouse-2]
			[mode-line down-mouse-3] [mode-line mouse-3])))
	     ("lemacs" .
	      (mapcar (function
			(lambda (key) (cons key (lookup-key global-map key))))
		      '(button2 button2up button3 button3up)))
	     ("xterm" .
	      (mapcar (function
			(lambda (key) (cons key (lookup-key mouse-map key))))
		      (list x-button-middle x-button-middle-up
			    x-button-right  x-button-right-up)))
	     ("epoch" .
	      (mapcar (function
			(lambda (key) (cons key (aref mouse::global-map key))))
		      (list (mouse::index mouse-middle mouse-down)
			    (mouse::index mouse-middle mouse-up)
			    (mouse::index mouse-right mouse-down)
			    (mouse::index mouse-right mouse-up)
			    ;; Modeline mouse map
			    (mouse::index mouse-mode-middle mouse-down)
			    (mouse::index mouse-mode-middle mouse-up)
			    (mouse::index mouse-mode-right mouse-down)
			    (mouse::index mouse-mode-right mouse-up)
			    )))
	     ("next" .
	      (mapcar (function
			(lambda (key)
			  (cons key (mousemap-get
				      (mouse-list-to-mouse-code key)
				      current-global-mousemap))))
		      (apply 'nconc
			     (mapcar (function
				       (lambda (region)
					 (mapcar (function
						   (lambda (key)
						     (cons region key)))
						 '((left) (up left) (shift left)
						   (right) (up right)
						   ))))
				     '(text scrollbar modeline minibuffer)))
		      ))
	     ;; SunView
	     ("sun" .
	      (mapcar (function
			(lambda (key)
			  (setq key (mouse-list-to-mouse-code key))
			  (cons key (mousemap-get
				      key current-global-mousemap))))
		      (apply 'nconc
			     (mapcar (function
				       (lambda (region)
					 (mapcar (function
						   (lambda (key)
						     (cons region key)))
						 '((middle) (up middle)
						   (right) (up right)
						   ))))
				     '(text scrollbar modeline minibuffer)))
		      ))
	     ("apollo" .
	      (mapcar (function
			(lambda (key-str) (apollo-mouse-key-and-binding
					    key-str)))
		      '("M2D" "M2U" "M3D" "M3U")))
	     )))))

(defun sm-mouse-set-bindings (key-binding-list)
  "Sets mouse keys used as Smart Keys to bindings in KEY-BINDING-LIST.
KEY-BINDING-LIST is the value returned by 'sm-mouse-get-bindings' prior to
Smart Key setup."
  (cond
    ;;
    ;; GNU Emacs 19 or Lucid Emacs
    ((or (equal hyperb:window-system "emacs19")
	 (equal hyperb:window-system "lemacs"))
     (mapcar
       (function
	 (lambda (key-and-binding)
	  (global-set-key (car key-and-binding) (cdr key-and-binding))))
       key-binding-list))
    ;;
    ;; X
    ((equal hyperb:window-system "xterm")
     (mapcar
       (function
	 (lambda (key-and-binding)
	   (define-key mouse-map (car key-and-binding) (cdr key-and-binding))))
       key-binding-list))
    ;;
    ;; Epoch
    ((equal hyperb:window-system "epoch")
     (mapcar
       (function
	 (lambda (key-and-binding)
	  (aset mouse::global-map (car key-and-binding)
		(cdr key-and-binding))))
       key-binding-list))
    ;;
    ;; SunView or NeXT
    ((or (equal hyperb:window-system "next")
	 (equal hyperb:window-system "sun"))
     (mapcar
       (function
	 (lambda (key-and-binding)
	   (global-set-mouse (car key-and-binding) (cdr key-and-binding))))
       key-binding-list))
    ;;
    ;; Apollo Display Manager
    ((equal hyperb:window-system "apollo")
      (if (string< emacs-version "18.58")
	  (mapcar
	    (function
	      (lambda (key-and-binding)
		(global-set-key (car key-and-binding) (cdr key-and-binding))))
	    key-binding-list)
	(mapcar
	  (function
	    (lambda (key-and-binding)
	      (define-key 'apollo-prefix (car key-and-binding)
		(cdr key-and-binding)))) 
	  key-binding-list))
      )
    ))

(defun sm-mouse-setup ()
  "Binds mouse keys for use as Smart Keys."
  (interactive)
  (or sm-mouse-bindings-p
      (setq sm-mouse-previous-bindings (sm-mouse-get-bindings)))
  ;; Ensure Gillespie's Info mouse support is off since
  ;; Hyperbole handles that.
  (setq Info-mouse-support nil)
  ;;
  (cond ;; GNU Emacs 19
        ((equal hyperb:window-system "emacs19")
	 (setq mouse-set-point-command 'mouse-set-point)
	 (global-set-key [down-mouse-2]           'sm-depress-emacs19)
	 (global-set-key [mouse-2]                'smart-key-mouse-emacs19)
	 (global-set-key [down-mouse-3]           'sm-depress-meta-emacs19)
	 (global-set-key [mouse-3]                'smart-key-mouse-meta-emacs19)
	 (global-set-key [mode-line down-mouse-2] 'sm-depress-emacs19)
	 (global-set-key [mode-line mouse-2]      'smart-key-mouse-emacs19)
	 (global-set-key [mode-line down-mouse-3] 'sm-depress-meta-emacs19)
	 (global-set-key [mode-line mouse-3]      'smart-key-mouse-meta-emacs19))
	;;
	;; Lucid Emacs
	((equal hyperb:window-system "lemacs")
	 (setq mouse-set-point-command 'sm-lemacs-move-point)
	 (global-set-key 'button2     'sm-depress)
	 (global-set-key 'button2up   'smart-key-mouse)
	 (global-set-key 'button3     'sm-depress-meta)
	 (global-set-key 'button3up   'smart-key-mouse-meta))
	;;
	;; X
	((equal hyperb:window-system "xterm")
	 (setq mouse-set-point-command 'x-mouse-set-point)
	 (define-key mouse-map x-button-middle 'sm-depress)
	 (define-key mouse-map x-button-middle-up 'smart-key-mouse)
	 (define-key mouse-map x-button-right 'sm-depress-meta)
	 (define-key mouse-map x-button-right-up 'smart-key-mouse-meta)
	 ;; Use these instead of the above for a true META-BUTTON binding.
	 ;; (define-key mouse-map x-button-m-middle 'sm-depress-meta)
	 ;; (define-key mouse-map x-button-m-middle-up 'smart-key-mouse-meta)
	 )
	;;
	;; Epoch
	((equal hyperb:window-system "epoch")
	 (setq mouse-set-point-command 'mouse::set-point)
	 (global-set-mouse mouse-middle mouse-down  'sm-depress)
	 (global-set-mouse mouse-middle mouse-up    'smart-key-mouse)
	 (global-set-mouse mouse-right  mouse-down  'sm-depress-meta)
	 (global-set-mouse mouse-right  mouse-up    'smart-key-mouse-meta)
	 ;; Modeline mouse map
	 (global-set-mouse mouse-mode-middle mouse-down  'sm-depress)
	 (global-set-mouse mouse-mode-middle mouse-up    'smart-key-mouse)
	 (global-set-mouse mouse-mode-right  mouse-down  'sm-depress-meta)
	 (global-set-mouse mouse-mode-right  mouse-up    'smart-key-mouse-meta)
	 )
	;;
	;; NeXT
	((equal hyperb:window-system "next")
	 (setq mouse-set-point-command 'sm-eterm-move-point)
	 ;; Use shift-left button to set point.
	 ;; Use left button instead of non-existent middle as Smart Key.
	 (mapcar
	  (function
	   (lambda (region)
	     (global-set-mouse (cons region '(shift left)) 'mouse-move-point)
	     (global-set-mouse (cons region '(left))       'sm-depress)
	     (global-set-mouse (cons region '(up left))    'smart-key-mouse)
	     (global-set-mouse (cons region '(right))      'sm-depress-meta)
	     (global-set-mouse (cons region '(up right))   'smart-key-mouse-meta)
	     ;; Use these instead of the above for a true META-BUTTON binding.
	     ;; (global-set-mouse (cons region '(meta    right)) 'sm-depress-meta)
	     ;; (global-set-mouse (cons region '(meta up right)) 'smart-key-mouse-meta)
	     ))
	  '(text scrollbar modeline minibuffer))
	 )
	;;
	;; SunView
	((equal hyperb:window-system "sun")
	 (setq mouse-set-point-command 'sm-eterm-move-point)
	 (mapcar
	  (function
	   (lambda (region)
	     (global-set-mouse (cons region '(middle))     'sm-depress)
	     (global-set-mouse (cons region '(up middle))  'smart-key-mouse)
	     (global-set-mouse (cons region '(right))      'sm-depress-meta)
	     (global-set-mouse (cons region '(up right))   'smart-key-mouse-meta)
	     ;; Use these instead of the above for a true META-BUTTON binding.
	     ;; (global-set-mouse (cons region '(meta    middle)) 'sm-depress-meta)
	     ;; (global-set-mouse (cons region '(meta up middle)) 'smart-key-mouse-meta)
	     ))
	  '(text scrollbar modeline minibuffer))
	 )
	;;
	;; Apollo DM
	((equal hyperb:window-system "apollo")
	 (setq mouse-set-point-command 'apollo-mouse-move-point)
	 (bind-apollo-mouse-button "M2D" 'sm-depress)
	 (bind-apollo-mouse-button "M2U" 'smart-key-mouse)
	 (bind-apollo-mouse-button "M3D" 'sm-depress-meta)
	 (bind-apollo-mouse-button "M3U" 'smart-key-mouse-meta)
	 ;; Use these instead of the above for a true META-BUTTON binding.
	 ;; (bind-apollo-mouse-button "M2U" 'smart-key-mouse
	 ;;  'smart-key-mouse-meta)
	 ;; (bind-apollo-mouse-button "M2D" 'sm-depress 'sm-depress-meta)
	 ))
  (setq sm-mouse-bindings (sm-mouse-get-bindings)
	sm-mouse-bindings-p t))

(defun sm-mouse-toggle-bindings ()
  "Toggles between Smart Key mouse settings and their prior bindings."
  (interactive)
  (let ((key-binding-list (if sm-mouse-bindings-p
			      sm-mouse-previous-bindings
			    sm-mouse-bindings))
	(other-list-var (if sm-mouse-bindings-p
			    'sm-mouse-bindings
			  'sm-mouse-previous-bindings)))
    (if key-binding-list
	(progn
	  (set other-list-var (sm-mouse-get-bindings))
	  (sm-mouse-set-bindings key-binding-list)
	  (message "%s mouse bindings in use."
		   (if (setq sm-mouse-bindings-p (not sm-mouse-bindings-p))
		       "Smart Key" "Personal")))
      (error "(sm-mouse-toggle-bindings): Null %s." other-list-var))))

;;; ************************************************************************
;;; Private functions
;;; ************************************************************************

(if (fboundp 'bind-apollo-mouse-button)
    (progn
      (if (string< emacs-version "18.58")
	  (defun apollo-mouse-key-and-binding (mouse-button)
	    "Returns binding for an Apollo MOUSE-BUTTON (a string) or nil if none."
	    (interactive "sMouse Button: ")
	    (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
	      (if (null numeric-code)
		  (error "(hmouse-key): %s is not a valid Apollo mouse key name."
			 mouse-button))
	      (if (stringp numeric-code)
		  (setq numeric-code
			(cdr (assoc numeric-code *apollo-mouse-buttons*))))
	      (let ((key-sequence (concat "\M-*" (char-to-string numeric-code))))
		(cons key-sequence (global-key-binding key-sequence)))))
	(defun apollo-mouse-key-and-binding (mouse-button)
	  "Returns binding for an Apollo MOUSE-BUTTON (a string) or nil if none."
	  (interactive "sMouse Button: ")
	  (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
	    (if (null numeric-code)
		(error "(hmouse-key): %s is not a valid Apollo mouse key name."
		       mouse-button))
	    (if (stringp numeric-code)
		(setq numeric-code
		      (cdr (assoc numeric-code *apollo-mouse-buttons*))))
	    (let ((key-sequence (char-to-string numeric-code)))
	      (cons key-sequence (lookup-key 'apollo-prefix key-sequence)))))
	)
      (defun apollo-mouse-move-point (&optional no-mark)
	"Used so that pressing the left mouse button, moving the cursor, and
releasing the left mouse button leaves the mark set to the initial position
and the point set to the final position.  Useful for easily marking regions
of text.  If the left mouse button is pressed and released at the same place,
the mark is left at the original position of the character cursor.

Returns (x y) screen coordinates of point in columns and lines."
	(interactive)
	(let* ((opoint (point))
	       (owindow (selected-window))
	       (x (- (read-char) 8))
	       (y (- (read-char) 8))
	       (edges (window-edges))
	       (window nil))
	  (while (and (not (eq window (selected-window)))
		      (or (<  y (nth 1 edges))
			  (>= y (nth 3 edges))
			  (<  x (nth 0 edges))
			  (>= x (nth 2 edges))))
	    (setq window (next-window window))
	    (setq edges (window-edges window)))
	  (if (and window (not (eq window (selected-window))))
	      (progn
		(if (and (not *apollo-mouse-move-point-allow-minibuffer-exit*)
			 (eq (selected-window) (minibuffer-window)))
		    (error "Cannot use mouse to leave minibuffer!"))
		(if (eq window (minibuffer-window))
		    (error "Cannot use mouse to enter minibuffer!"))))
	  (if window (select-window window))
	  (move-to-window-line (- y (nth 1 edges)))
	  (let* ((width-1 (1- (window-width window)))
		 (wraps (/ (current-column) width-1))
		 (prompt-length (if (eq (selected-window) (minibuffer-window))
				    (minibuffer-prompt-length)
				  0)))
	    (move-to-column (+ (- x (nth 0 edges) prompt-length)
			       (* wraps width-1))))
	  (if no-mark
	      (progn (setq window (selected-window))
		     (if (eq owindow window)
			 (if (equal opoint (point))
			     (pop-mark))
		       (select-window owindow)
		       (pop-mark)
		       (select-window window)))
	    (set-mark-command nil))
	  ;; Return (x y) coords of point in column and screen line numbers.
	  (list x y)))
      ))

(defun sm-depress (&rest args)
  (interactive)
  (setq smart-key-depress-prev-point (point-marker)
	*smart-key-depressed* t
	*smart-key-depress-args* (smart-key-mouse-set-point args)
	smart-key-depress-window (selected-window)
	*smart-key-release-args* nil
	smart-key-release-window nil
	smart-key-release-prev-point nil)
  (if *smart-key-meta-depressed*
      (or *smart-key-help-p*
	  (setq *smart-key-meta-help-p* t)))
  )

(defun sm-depress-meta (&rest args)
  (interactive)
  (setq smart-key-meta-depress-prev-point (point-marker)
	*smart-key-meta-depressed* t
	*smart-key-meta-depress-args* (smart-key-mouse-set-point args)
	smart-key-meta-depress-window (selected-window)
	*smart-key-meta-release-args* nil
	smart-key-meta-release-window nil
	smart-key-meta-release-prev-point nil)
  (if *smart-key-depressed*
      (or *smart-key-meta-help-p*
	  (setq *smart-key-help-p* t)))
  )

(defun sm-depress-emacs19 (event)
  (interactive "e")
  (sm-depress event))

(defun sm-depress-meta-emacs19 (event)
  (interactive "e")
  (sm-depress-meta event))

(defun smart-key-mouse-emacs19 (event)
  "Set point to the current mouse cursor position and execute 'smart-key'.
EVENT will be passed to 'smart-key-mouse-func'."
  (interactive "e")
  (smart-key-mouse (sm-release-args-emacs19 event)))

(defun smart-key-mouse-meta-emacs19 (event)
  "Set point to the current mouse cursor position and execute 'smart-key'.
EVENT will be passed to 'smart-key-mouse-func'."
  (interactive "e")
  (smart-key-mouse-meta (sm-release-args-emacs19 event)))

(defun sm-release-args-emacs19 (event)
  (if (= (length event) 3)
      ;; Remove depress coordinates and send only release coordinates.
      (list (car event) (nth 2 event))
    event))

(defun sm-lemacs-move-point ()
  (condition-case ()
      (mouse-set-point current-mouse-event)
    ;; Catch "not in a window" errors, e.g. on modeline
    (error nil)))

(defun sm-eterm-move-point (arg-list)
  (apply 'mouse-move-point arg-list))

;;; ************************************************************************
;;; Private variables
;;; ************************************************************************

(defvar sm-mouse-bindings nil
  "List of (key . binding) pairs for Smart Mouse Keys.")

(defvar sm-mouse-bindings-p nil
  "True if Smart Key mouse bindings are in use, else nil.")

(defvar sm-mouse-previous-bindings nil
  "List of previous (key . binding) pairs for mouse keys used as Smart Keys.")

(provide 'hmouse-key)