;;; -*- Mode:Common-Lisp; Package:ZWEI; Fonts:(COURIER HL12B HL12I); Base:10; patch-file: t -*-
;; **********************************************************************
;; 
;;  This code was written by Garr Lystad, AiLab, DSEG, Texas Inst.
;; 
;; First Version 2-12-88, though some of the code was around much earlier.
;; 
;; 
;; Revisions, heaven forbid:
;; 
;;   2-16-88 Fixed a typo in the transpose-sexp stuff
;;           Added the enhancements to incremental-search
;;           Added documentation at top of file. gsl.
;;   2-17-88 Added the bp-storage command on hyper-p,
;;           added refresh-as-needed.
;;           added cmds on S-M-middle, & S-M-RIGHT.
;;           added some documentation.  gsl
;;   3-4-88  Added Tom Eckberg's mouse bits fix
;;           Fixed the close parens command and moved it to S-C-right.
;;           Fixed Install Mouse Command w arg to take C-x keys
;;           Added a Transpose Regions command on M-Sh-right
;;           Added a command to clear the Transpose Regions bps M-Sh-right-2
;;           Added a copy stored region command to S-middle
;;           Added a replace with stored region command to S-left - use like query replace
;;           Modified the com-store-pt command to store a region,
;;              though the previous 2 commands store one if one is marked.
;;           Added Kill Region command
;;           Moved a few commands around, mostly ones I don't use much. gsl.
;;   3-23-88 Added com-mouse-call-system-menu to c-right. gsl.
;;   3-28-88 Added zwei:*external-use-window* to com-MOUSE-CALL-SYSTEM-MENU. gsl.
;;   3-31-88 Added indentation commands & put on S-C-left & S-C-left-2
;;   4-4-88  Fixed the indentation commands to work from the keyboard too.
;;           Made indentation commands convert tabs to spaces.
;;           Made apropos find mouse commands: KEY-FOR-COMMAND.  gsl.
;;   4-21-88 Made a fix to insert-interval so that if it is aborted it will 
;;           not make a mess out of the buffer.  This was a problem if copying
;;           a multi-line sexp to a point within that sexp.  Fixed copy-sexp
;;           command to query user and do it correctly if desired. gsl.
;;   5-12-88 Created com-mouse-indent-new-line so that cr-tab would be inserted
;;           if and where a point had been saved. gsl.
;;   5-12-88 Fixed install-mouse-command so that keyboard macros with point moved
;;           to mouse work reasonably well.  The cursor doesn't return to its
;;           previous position, but this is unavoidable since the macro is only
;;           primed by the command.  The macro actually begins after the command
;;           finishs and would return the cursor to its original position.  gsl.
;;   5-20-88 Fixed refresh-as-needed so mini buffer inserts are visible. gsl.
;;   7-13-88 Fixed refresh-as-needed to get rid of typeout window.
;;           Fixed test in cur-pt to string-search in uppercase and changed window
;;           in first cond clause, final and clause, to test different window for selection.
;;   8-2-88  Removed the ` from  `(,command) at bottom of install-mouse-command. gsl.
;;            
;; 
;; 
;; **********************************************************************

;;The following commands are added below to the mouse

;; Char insertion
;;      Insert return & tab (indent)  -- M-mouse-left
;;      Insert #\'                    -- M-mouse-middle
;;      Insert #\space                -- M-mouse-right
;;      Insert #\(                    -- M-C-mouse-left
;;      Insert #\-                    -- M-C-mouse-middle
;;      Insert #\)                    -- M-C-mouse-right
;;
;; cursor movement
;;      Backward sexp                 -- M-C-sh-mouse-right-2
;;      Forward  sexp                 -- M-C-sh-mouse-right
;;
;; Copy code
;;      Mark & Copy region to point   -- C-sh-Mouse-left
;;      Copy sexp with mouse to point -- C-sh-Mouse-middle
;;      Copy sexp + space to point    -- C-sh-Mouse-right
;;      Store region if any and
;;        insert stored region at mouse
;;        and move point to mouse     -- S-Mouse-middle
;;
;; Move code
;;      Move sexp, insert return      -- S-C-Mouse-middle
;;      Move region                   -- S-M-Mouse-left
;;      Move sexp                     -- S-M-Mouse-middle
;;      Move sexp, insert space       -- S-M-Mouse-right & S-Mouse-right
;;
;; Replace code
;;      Store region if any and
;;        insert stored region at mouse
;;        and delete following sexp
;;        and move point to mouse        -- S-Mouse-left
;;
;; Transpose code
;;      Transpose lines of point & mouse -- M-sh-Mouse-left
;;      Transpose sexp point & mouse     -- M-sh-Mouse-middle
;;      Transpose regions                -- M-sh-Mouse-right (four times)
;;      Abort Transpose regioins         -- M-sh-Mouse-right-double
;;
;; Kill code
;;      Kill sexp                        -- M-C-sh-mouse-middle
;;      Kill region                      -- M-C-Sh-mouse-left
;; 
;; Misc.
;;      Ballance parens at point for 
;;         sexp beginning at mouse       -- S-C-Mouse-right
;;      Save a lines column number       -- S-C-Mouse-left-2
;;      Move the char moused to the
;;         saved column, add blanks
;;         to move rt. kill to move
;;         left.                         -- S-C-Mouse-left
;;
;; Incremental-search is enhanced for mouse input:
;;   C-sh-mouse-middle will insert an sexp into the search.
;;   C-sh-mouse-left will insert the region marked while mouse is held down.
;;
;;  Store-pt is added (Hyper-p).  It saves a copy of point for 2 minutes  so
;;   that the mouse  commands defined  below will  use that  location rather
;;   than that of the cursor.  For the first 30 sec after the saved location
;;   expires you get a message  the first time you  try to use it,  then you
;;   are back to  using the  cursor location.   Actually this  command is  a
;;   toggle with no arg.  An arg of 1 always saves the current location  and
;;   an arg of  0 always  throws away  any location  saved.  If a minibuffer
;;   position is saved but the minibuffer is deselected while the associated
;;   pane is selected  then the  saved position  is thrown  away.  Note that
;;   when a position in one editor instance  is saved (be it editor pane  or
;;   either minibuffer), text can be moved  in and out from anywhere  in the
;;   buffer, minibuffer, other buffer, or  from another editor instance  for
;;   the two minutes.  Note that NOT all commands which use the space  below
;;   the editor pane are using a minibuffer.  Those that don't, cannot  have
;;   their positions  saved,  and  the  mouse  commands  don't  work in them
;;   (except that additions have been made to incremental-search).

;;  Com-install-mouse-command is installed on C-m.  It installs a command on
;;   a mouse key with the option to move point to the mouse position  during
;;   the execution of the command.  Commands are specified by entering  them
;;   as you would for M-C-X or M-x if Com-install-mouse-command has no  arg.
;;   With an  argument  the  command  is  specified  by  a key.  The command
;;   install-mouse-command is provided for login-init-files, etc.

;;indices are #clicks -1, mouse-button, meta-control-bits.
(let ((array (make-array '(3 3 16))))
  (setf (aref array 0 0 0) 'com-mouse-mark-region)           ;;LEFT
  (setf (aref array 0 0 1) 'com-mouse-move-region)           ;;C-LEFT
  (setf (aref array 0 0 2) 'com-mouse-indent-new-line)       ;;M-LEFT
  (setf (aref array 0 0 3) 'com-mouse-left-paren)            ;;M-C-LEFT
  (setf (aref array 0 0 4) 'com-Mouse-Replace-With-Stored-Interval) ;;S-LEFT
  (setf (aref array 0 0 5) 'com-mouse-indent-to-saved-index) ;;S-C-LEFT
  (setf (aref array 0 0 6) 'COM-MOUSE-move-region-2)         ;;S-M-LEFT
  (setf (aref array 0 1 0) 'com-mouse-mark-thing)            ;;MIDDLE
  (setf (aref array 0 1 1) 'com-mouse-kill-yank)             ;;C-MIDDLE
  (setf (aref array 0 1 2) 'COM-MOUSE-QUOTE)                 ;;M-MIDDLE
  (setf (aref array 0 1 3) 'com-mouse-DASH)                  ;;M-C-MIDDLE
  (setf (aref array 0 1 4) 'com-Mouse-Copy-Stored-Interval)  ;;S-C-MIDDLE
  (setf (aref array 0 1 5) 'COM-MOUSE-move-sexp-lf)          ;;S-C-MIDDLE
  (setf (aref array 0 1 6) 'COM-MOUSE-move-sexp)             ;;S-M-MIDDLE
  (setf (aref array 0 2 1) 'com-MOUSE-CALL-SYSTEM-MENU)      ;;C-RIGHT
  (setf (aref array 0 2 2) 'com-mouse-space)                 ;;M-RIGHT
  (setf (aref array 0 2 3) 'com-mouse-right-paren)           ;;M-C-RIGHT
  (setf (aref array 0 2 4) 'COM-MOUSE-move-sexp-sp)          ;;S-RIGHT
  (setf (aref array 0 2 5) 'com-mouse-close-sexp)            ;;S-C-RIGHT
  (setf (aref array 0 2 6) 'COM-MOUSE-move-sexp-sp)          ;;S-M-RIGHT
  (setf (aref array 1 0 0) 'com-mouse-move-region)           ;;LEFT-2
  (setf (aref array 1 0 1) 'com-mouse-copy-REGION)           ;;C-LEFT-2
  (setf (aref array 1 0 2) 'com-mouse-transpose-LINES)       ;;M-LEFT-2
  (setf (aref array 1 0 3) 'com-mouse-kill-region)           ;;M-C-LEFT-2 
  (setf (aref array 1 1 0) 'com-mouse-kill-yank)             ;;MIDDLE-2
  (setf (aref array 1 1 1) 'com-mouse-copy-sexp)             ;;C-MIDDLE-2
  (setf (aref array 1 1 2) 'com-mouse-transpose-SEXP)        ;;M-MIDDLE-2
  (setf (aref array 1 1 3) 'com-kill-sexp)                   ;;M-C-MIDDLE-2 
  (setf (aref array 1 0 5) 'com-mouse-save-index)            ;;S-C-LEFT-2
  (setf (aref array 1 2 1) 'com-mouse-copy-sexp&SP)          ;;C-RIGHT-2
  (setf (aref array 1 2 2) 'com-mouse-transpose-regions)     ;;M-RIGHT-2
  (setf (aref array 1 2 3) 'com-forward-sexp)                ;;M-C-RIGHT-2 
  (setf (aref array 2 2 3) 'com-backward-sexp)               ;;M-C-RIGHT-3 (M-C-sh-right-2)
  (setf (aref array 2 2 2) 'com-clean-mouse-transpose-regions-bps) ;;M-RIGHT-3 (M-sh-right-2) 
  (setf (comtab-mouse-array *standard-comtab*) array) )

;;______________________________________________________________________
(defstruct (mouse-toys-bp-data :type :list)
  (valid nil)
  (window nil)
  (bp nil)
  (interval nil)
  (indent-index 0)
  (time (time)) )

(defvar *one-minute* 3600. "60ths of a second in a minute.")

(defvar *last-mouse-point-expires* (* 2 *one-minute*)
  "Time in 60th of second that *last-mouse-point-and-time* remains valid")

(defvar *last-mouse-point-and-time* (make-mouse-toys-bp-data) "saves a bp and time of storage
for the mouse toys functions.")

(defun mouse-insert-window ()
  (if (send tv:selected-window :operation-handled-p :editor-closure)
      tv:selected-window
    *window*))

(defun cur-pt ()
  "Returns the point, (point) is the default, for the mouse commands below."
  (cond ((and (mouse-toys-bp-data-VALID *last-mouse-point-and-time*)
	      (lisp::search "MINI" (string-upcase
				     (send (mouse-toys-bp-data-WINDOW *last-mouse-point-and-time*) :name)))
	      (not (send (mouse-toys-bp-data-WINDOW *last-mouse-point-and-time*)
			 :self-or-substitute-selected-p) )
	      (send (mouse-insert-window) :self-or-substitute-selected-p) )
	 ;;We were using a mini-buffer, but now we are finished and using its superior pane.
	 (symeval-in-closure (send (mouse-insert-window) :editor-closure) '*point*) )
	((mouse-toys-bp-data-VALID *last-mouse-point-and-time*)
	 ;;Presumably we are doing transfer from one buffer or mini to another, use the stored bp if valid.
	 (cond ((> (time-difference (time) (mouse-toys-bp-data-TIME *last-mouse-point-and-time*))
		   (+ *last-mouse-point-expires* (/ *one-minute* 2)) )
		(setf (mouse-toys-bp-data-VALID *last-mouse-point-and-time*) nil)
		(symeval-in-closure (send (mouse-insert-window) :editor-closure) '*point*) )
	       ((> (time-difference (time) (mouse-toys-bp-data-TIME *last-mouse-point-and-time*))
		   *last-mouse-point-expires*)
		(progn (tv:beep :flash)
		       (format t "LAST MOUSE POINT expired.")
		       (process-sleep 150.)
		       (setf (mouse-toys-bp-data-VALID *last-mouse-point-and-time*) nil)
		       (throw 'ZWEI-COMMAND-LOOP nil) )) 
	       (:otherwise
		(let ((bp (mouse-toys-bp-data-BP *last-mouse-point-and-time*)))
		  (if (> (bp-index bp) (line-length (bp-line bp)))
		      (setf (bp-index bp) (line-length (bp-line bp))) )
		  bp))))
	(:otherwise ;;can't figure out what we are doing, return point of most relevant buffer or mini.
	 (symeval-in-closure (send (mouse-insert-window) :editor-closure) '*point*) )))

(defcom com-store-pt "This toggles storage of the current cursor position for *last-mouse-point-expires*
60ths of a second, for use in the mouse toys functions in place of point.
With arg of 1 always stores, with arg of 0 turns off storage and point is used.
With a numeric arg of 4 or more, no change is made.
ADDITIONALLY: if a region is marked, it is stored for Mouse Copy Stored Interval and
Mouse Replace With Stored Interval." (km)
  (if (< *numeric-arg* 4)
      (if (OR (and *numeric-arg-p* (= 1 *numeric-arg*))
	      (and (not *numeric-arg-p*)
		   (not (mouse-toys-bp-data-VALID *last-mouse-point-and-time*) )))
	  (let ((window (mouse-insert-window)))
	    (format *query-io* "STORING current CURSOR position of ~a for mouse inserts for next ~d minutes."
		    (send window :name)
		    (quotient *last-mouse-point-expires* *one-minute*) )
	    (setf (mouse-toys-bp-data-VALID *last-mouse-point-and-time*) t
		  (mouse-toys-bp-data-TIME *last-mouse-point-and-time*) (time)
		  (mouse-toys-bp-data-BP *last-mouse-point-and-time*)
		  (copy-bp (symeval-in-closure (send window :editor-closure) '*point*))
		  (mouse-toys-bp-data-WINDOW *last-mouse-point-and-time*) window) )
	(progn
	  (send *query-io* :clear-screen)
	  (format *query-io* "Mouse inserts will be done AT POINT")
	  (setf (mouse-toys-bp-data-VALID *last-mouse-point-and-time*) nil) )))
  ;ÏÏ1;Also if there is a region marked, store a copy of it.ÏÏ*
  (if (WINDOW-MARK-P *WINDOW*)
      (progn
	(setf (mouse-toys-bp-data-INTERVAL *last-mouse-point-and-time*)
	      (copy-interval (mark) (point)) )
	(format *query-io* "~&Region has been stored.") ))
  dis-none)


(defun refresh-as-needed (insert-bp &optional (mouse-window-too t)(redisplay-degree dis-text))
  (if (and mouse-window-too (neq tv::mouse-window tv::selected-window))
      (send tv::mouse-window :send-if-handles :refresh) )
  (cond ((and (bp-= (mouse-toys-bp-data-BP *last-mouse-point-and-time*)
		 insert-bp)
	   (not (send (mouse-toys-bp-data-WINDOW *last-mouse-point-and-time*)
		      :self-or-substitute-selected-p)))
	 (send (mouse-toys-bp-data-WINDOW *last-mouse-point-and-time*) :send-if-handles :refresh))
	(:otherwise
	 (when (typep tv:selected-window 'editor-typeout-window)
	   (send *window* :refresh) )
	 (must-redisplay tv:selected-window redisplay-degree (bp-line insert-bp) (bp-index insert-bp)) )))


(defcom com-install-mouse-command "Puts the command specified on a mouse key you click to specify.
With a numeric arg copies command from a keyboard key you specify." (KM)
  (let ((command (if *numeric-arg-P*
		     (progn
		       (CLEAR-PROMPTS)
		       (ADD-PROMPT "Key: ")
		       (ALWAYS-DISPLAY-PROMPTS)
		       (loop as key = (INPUT-WITH-PROMPTS *STANDARD-INPUT* :any-TYI)
			     when (and (listp key)(eq (car key) :mouse-button))
			       do (setq key (second key))
			     with comtab = *comtab*
			     as cmd = (command-lookup key comtab)
			     do (format t "cmd=~s~%" cmd)
			     do (cond ((typep cmd 'closure)
				       (setq comtab
					     (symeval-in-closure cmd 'comtab)) )
				      (t (if (eq cmd 'com-ordinarily-self-insert)
					     (setq *LAST-COMMAND-CHAR* key) )
					 (return cmd) ))
			     when (not (typep cmd 'closure))
			       do (CLEAR-PROMPTS) (ADD-PROMPT "Invalid key.  Key: ")))
		   (cdr (COMPLETING-READ-FROM-MINI-BUFFER
			  "Install which command on mouse?"
			  *COMMAND-ALIST*
			  NIL
			  NIL
			  "You are typing the name of a command to install on the mouse."))))
	(mouse-key (progn
		     (CLEAR-PROMPTS)
		     (ADD-PROMPT "Mouse Key: ")
		     (ALWAYS-DISPLAY-PROMPTS)
		     (loop as key = (INPUT-WITH-PROMPTS *STANDARD-INPUT* :any-TYI)
			   when (and (listp key)(eq (car key) :mouse-button))
			   do (setq key (second key))
			   when (char-bit key :mouse) do (return key)
			   do (CLEAR-PROMPTS)
			   (ADD-PROMPT
			     "Press any combination of Ctrl, Meta, Super, & Hyper, and a Mouse Key: ")
			   (tv:beep) )))
	(point-to-mouse (y-or-n-p "Move the point to mouse for the command?")) )
    ;;if it is a character insert then build such a command.
    (if (and *numeric-arg-p* (eq command 'com-ordinarily-self-insert))
	(let ((name (intern (string-append "Insert-" *LAST-COMMAND-CHAR*) :zwei)))
	  (command-define name (format nil "~a with point at mouse." command) '(KM))
	  (compile name `(lambda () (char-insert ,(IN-CURRENT-FONT *LAST-COMMAND-CHAR*))))
	  (setq command name) ))
    (install-mouse-command command mouse-key point-to-mouse)
    (format *query-io* "~&~a installed on ~c" command mouse-key) )
  dis-none)

(defmacro with-point-at-mouse (&body body)
  `(let ((old-point (copy-bp (point)))
	 (old-mark (copy-bp (mark)))
	 (OLD-MARKED (WINDOW-MARK-P *WINDOW*)) )
     (unwind-protect
	 (progn
	   (setf (WINDOW-MARK-P *WINDOW*) nil)
	   (move-bp (point) (mouse-bp *window*))
	   ,@body)
       (move-bp (point) old-point)
       (move-bp (mark) old-mark)
       (setf (WINDOW-MARK-P *WINDOW*) OLD-MARKED) )))

(defun install-mouse-command (command mouse-key &optional wrap-with-point-at-mouse)
  "Install command on mouse-key.  If wrap-with-point-at-mouse then point is moved to mouse for
  duration of command."
  (check-arg command (rassoc command *command-alist*) "an editor command")
  (check-arg mouse-key (CHAR-BIT mouse-key :MOUSE) "a mouse key, optionally with Meta-Ctrl-type bits.")
  (setf (AREF (COMTAB-MOUSE-ARRAY *standard-comtab*)
	      (MIN (SI:CHAR-MOUSE-CLICKS mouse-key)
		   (1- (array-dimension (comtab-mouse-array *standard-comtab*) 0)) );;gsl
	      (SI:CHAR-MOUSE-BUTTON mouse-key)
	      (TV:CHAR-CMSH-BITS mouse-key) );;(boundp-in-closure
	(if wrap-with-point-at-mouse
	    (let ((name (gensym)))
	      (command-define name (format nil "~a with point at mouse." command) '(KM))
	      (if (and (closurep command) ;;if a kbd macro.
		       (boundp-in-closure command 'MOVE-TO-MOUSE-P))
		  (progn
		    (setf (symeval-in-closure command 'MOVE-TO-MOUSE-P) t)
		    (compile name `(lambda ()
				     (MOVE-BP (POINT) (MOUSE-BP *WINDOW* *MOUSE-X* *MOUSE-Y*))
				     (funcall ',command)
				     dis-none)) )
		(compile name `(lambda ()
				 (with-point-at-mouse (,command)) ))))
	  command)))

(setf (comtab-extended-commands *standard-comtab*)
      (append (make-command-alist (set-difference
				    '(com-store-pt com-install-mouse-command)
				    (comtab-extended-commands *standard-comtab* )
				    :test #'(lambda (cmd pair)(eq cmd (cdr pair))) ))
	      (comtab-extended-commands *standard-comtab* ) ))

(defvar  zwei:*external-use-window* nil "This is for the printer process to know what we want.")

(defcom com-MOUSE-CALL-SYSTEM-MENU "This brings up the system menu." (km)
  (setq zwei:*external-use-window* *window*)
  (tv:MOUSE-CALL-SYSTEM-MENU)
  dis-none)

(command-store 'com-store-pt #\hyper-p *standard-comtab*)
(command-store 'com-install-mouse-command #\C-m *standard-comtab*)
;;______________________________________________________________________
;;Char insert
(defun char-insert (char)
  (LET* ((POINT (CUR-PT))
	 (LINE (BP-LINE POINT))
	 (INDEX (BP-INDEX POINT)) )
    (INSERT-MOVING POINT CHAR)
    (SETQ *CURRENT-COMMAND-TYPE* 'SELF-INSERT)
    (refresh-as-needed point nil dis-line)
    (VALUES DIS-LINE LINE INDEX) ))

(defcom com-mouse-space "This inserts a space at point." (km)
  (char-insert #\space) )

(defcom com-mouse-left-paren "This insert a left paren. at point." (km)
  (char-insert #\() )

(defcom com-mouse-right-paren "This inserts a right paren. at point." (km)
  (char-insert #\)) )

(defcom com-mouse-DASH "This inserts a dash at point." (km)
  (char-insert #\-) )

(defcom com-mouse-QUOTE "This inserts a ' at point." (km)
  (char-insert #\') )

(defcom com-mouse-indent-new-line "Insert a Return and the proper indentation on the new line." ()
  (let ((old-pt (point)) )
    (unwind-protect
	(progn
	  (setf (point) (cur-pt))
	  (let* ((node (line-node (bp-line (point))))
		 (*interval* (if (typep node 'zmacs-buffer) node (send node :superior))) )
	    (com-indent-new-line) )) ;;problem here if at end of buffer. gsl.  -- will fix later.
      (setf (point) old-pt) )))

;;______________________________________________________________________
;; Sexp copy

(defcom com-mouse-copy-SEXP "This copies a moused sexp to point." (KM)
  (let ((bp-1 (copy-bp (MOUSE-BP *WINDOW*)))
	(bp-2 (copy-bp (point)))
	(insert-bp (CUR-PT)) )
    (FUNCALL (CASE (GET *MAJOR-MODE* 'EDITING-TYPE)
	       (:LISP 'LISP-MARK-THING)
	       (:TEXT 'TEXT-MARK-THING)
	       (OTHERWISE 'DEFAULT-MARK-THING))
	     bp-1 bp-2 (bp-ch-char bp-1) (BP-LINE BP-1) (BP-INDEX BP-1))
    (setq bp-1 (forward-over '(#\space #\tab) bp-1)
	  bp-2 (backward-over '(#\space #\tab) bp-2))
    (when (and (neq (bp-line bp-1) (bp-line bp-2))
	       (bp-< bp-1 insert-bp)
	       (bp-< insert-bp bp-2) )
      (unless (y-or-n-p "The region contains the insert point.  Are you sure you want that?")
	(return-from com-mouse-copy-SEXP dis-none) ))
    (move-bp insert-bp (insert-interval insert-bp (copy-interval bp-1 bp-2)))
    (refresh-as-needed insert-bp nil) )
  (if (typep tv:selected-window 'zmacs-window-pane)
      (must-redisplay tv:selected-window dis-text) )
  dis-none)

(defcom com-mouse-copy-SEXP&SP "This copies a moused sexp to point and inserts a space after it." (KM)
  (com-mouse-copy-SEXP)
  (com-mouse-space)
  dis-none)

;;______________________________________________________________________
;; Move Sexp

(defcom com-mouse-move-SEXP "This moves sexp at mouse to point" (KM)
  (mouse-move-sexp-internal nil) )

(defcom com-mouse-move-SEXP-sp "This moves sexp at mouse to point and inserts a space." (KM)
  (mouse-move-sexp-internal :space) )

(defcom com-mouse-move-SEXP-lf "This moves sexp at mouse to point and indents on new line." (KM)
  (mouse-move-sexp-internal :lf) )

(defun mouse-move-sexp-internal (option)
  (let ((BP-POINT (cur-pt))
	(bp-mouse (mouse-bp *window*))
	(bp-2 (copy-bp (cur-pt)))
	(function (CASE (GET *MAJOR-MODE* 'EDITING-TYPE)
		    (:LISP 'LISP-MARK-THING)
		    (:TEXT 'TEXT-MARK-THING)
		    (:OTHERWISE 'DEFAULT-MARK-THING)))
	(X) (Y) (CHAR) (LINE) (CHAR-POS))
    ;;make a copy of the interval at the mouse
    (MULTIPLE-VALUE-SETQ (CHAR X Y LINE CHAR-POS)
      (MOUSE-CHAR *WINDOW* NIL *MOUSE-X* *MOUSE-Y*))	;Figure out where mouse is
    (FUNCALL function bp-mouse bp-2 CHAR LINE CHAR-POS)
    (setq bp-mouse (forward-over '(#\space) bp-mouse)
	  bp-2 (backward-over '(#\space) bp-2))
    (let ((mouse-interval (copy-interval bp-mouse bp-2))) ;;not in order if picking up a line from end.
      (cond ((bp-< BP-POINT bp-mouse)
	     (delete-interval BP-MOUSE bp-2)
	     (MOVE-bp BP-POINT (insert-interval BP-POINT mouse-interval)) )
	    ((bp-< bp-2 BP-POINT)
	     (MOVE-bp BP-POINT (insert-interval BP-POINT mouse-interval))
	     (delete-interval BP-MOUSE bp-2) )
	    (:otherwise ;;The operation is the identity on the buffer, do nothing.
	     )))
    (refresh-as-needed BP-POINT nil) )
   ;;Now do extra space or lf
  (case option
    (:lf (com-indent-new-line))
    (:space (com-mouse-space))
    )    
  (if (typep tv:selected-window 'zmacs-window-pane)
      (must-redisplay tv:selected-window dis-text) )
  dis-none)


;;______________________________________________________________________
;; Region copy and move

(DEFCOM com-mouse-copy-REGION "Jump point and mark to where the mouse is.
Then as the mouse is moved with the button held down point follows the mouse.
When the mouse is released the region marked is copied to where
point originally was.  Point moves to after the insertion." (KM)
  (mouse-region) )

(DEFCOM com-mouse-move-REGION-2 "Jump point and mark to where the mouse is.
Then as the mouse is moved with the button held down point follows the mouse.
When the mouse is released the region marked is deleted and appears where
point originally was.  Point moves to after the insertion." (KM)
  (mouse-region :move) )

(defun mark-region-with-mouse (POINT MARK BP-mouse)
  "This sets point and mark according to where it is moved with a key held."
  (MOVE-BP MARK BP-MOUSE)
  (SETF (WINDOW-MARK-P *WINDOW*) T)
  (DO ((LAST-X *MOUSE-X*)
       (LAST-Y *MOUSE-Y*))
      (NIL)
    (MOVE-BP POINT BP-mouse) 
    (MUST-REDISPLAY *WINDOW* DIS-BPS)
    (REDISPLAY *WINDOW* :POINT)
    (OR (WAIT-FOR-MOUSE LAST-X LAST-Y)
	(RETURN NIL))
    (MULTIPLE-VALUE-SETQ (LAST-X LAST-Y) (MOUSE-POSITION))
    (SETQ BP-mouse (MOUSE-BP *WINDOW* LAST-X LAST-Y))))
  
(defun mouse-region (&optional movep)
  "See com-mouse-copy-REGION & com-mouse-move-REGION-2."
  (LET ((OLD-MARKED (WINDOW-MARK-P *WINDOW*))
	(OLD-POINT (copy-bp (point)))
	(OLD-MARK (COPY-BP (MARK)))
	(insert-bp (CUR-PT))
	(POINT (point))
	(MARK (MARK))
	(BP-mouse (MOUSE-BP *WINDOW* *MOUSE-X* *MOUSE-Y*)))
    ;;move point and mark to get the region to be copied.
    (mark-region-with-mouse POINT MARK BP-mouse)
    ;;insert the region from mark to point at old-point.
    (if (bp-< mark point) (swap-bps mark point)) ;;put in order
    (let ((mouse-interval (copy-interval point mark t)))
      (move-bp bp-mouse point)  ;;save interval start
      (move-bp point old-point) ;;restore point
      (move-bp old-point mark)  ;;bp-mouse to old-point is the marked region, in-order.
      (IF OLD-MARKED            ;;restore mark or unmarked state
	  (MOVE-BP MARK OLD-MARK)
	(SETF (WINDOW-MARK-P *WINDOW*) NIL) )
      (cond ((bp-< insert-bp bp-mouse)
	     (and movep (delete-interval BP-MOUSE old-point t))
	     (MOVE-bp INSERT-BP (insert-interval INSERT-BP mouse-interval)) )
	    ((not (bp-< INSERT-BP old-point));;this handles differing buffers too.
	     (MOVE-bp INSERT-BP (insert-interval INSERT-BP mouse-interval))
	     (and movep (delete-interval BP-MOUSE old-point t)) )
	    (movep) ;;The operation is the identity on the buffer, do nothing.
	    (:otherwise  ;do the copy
	      (MOVE-bp INSERT-BP (insert-interval INSERT-BP mouse-interval)) )))
    (refresh-as-needed insert-bp nil)
    (if (typep tv:selected-window 'zmacs-window-pane)
      (must-redisplay tv:selected-window dis-text) )
    (flush-bp OLD-MARK) (flush-bp old-point))
  DIS-NONE) 

;;______________________________________________________________________
;; Transpositions

(DEFUN swap-intervals (bp-begin1 bp-end1 bp-begin2 bp-end2)
  "bp-begin1 < bp-begin2"
  (if (bp-< bp-begin2 bp-end1)
      (barf "Sorry, your intervals cannot be swapped.")
    (let ((int-1 (copy-interval bp-begin1 bp-end1))
	  (int-2 (copy-interval bp-begin2 bp-end2)) )
      (delete-interval bp-begin2 bp-end2)
      (insert-interval bp-begin2 int-1)
      (delete-interval bp-begin1 bp-end1)
      (insert-interval bp-begin1 int-2) )))


(defcom com-mouse-transpose-SEXP "This is to transpose items at mouse and point" (KM)
  (let ((BP-POINT (copy-bp (cur-pt)))
	(bp-mouse (copy-bp (mouse-bp *window*))) ;;save the mouse position relative to text.
	(bp-m (copy-bp (cur-pt)))
	(bp-p (copy-bp (cur-pt)))
	(function (CASE (GET *MAJOR-MODE* 'EDITING-TYPE)
		    (:LISP 'LISP-MARK-THING)
		    (:TEXT 'TEXT-MARK-THING)
		    (OTHERWISE 'DEFAULT-MARK-THING)))
	(X) (Y) (CHAR) (LINE) (CHAR-POS))

    ;;get mouse sexp bps
    (MULTIPLE-VALUE-SETQ (CHAR X Y LINE CHAR-POS)
      (MOUSE-CHAR *WINDOW* NIL *MOUSE-X* *MOUSE-Y*))	;Figure out where mouse is
    (FUNCALL function bp-mouse bp-m CHAR LINE CHAR-POS)
    (move-bp bp-mouse (forward-over '(#\space) bp-mouse))
    (move-bp bp-m (backward-over '(#\space) bp-m))

    ;;get point sexp bps
    (setq line (bp-line BP-POINT) char-pos (bp-index BP-POINT) char (aref line char-pos))
    (FUNCALL function BP-POINT bp-p CHAR LINE CHAR-POS)
    (move-bp BP-POINT (forward-over '(#\space) BP-POINT))
    (move-bp bp-p (backward-over '(#\space) bp-p))

    (if (bp-< bp-point bp-mouse)
	(swap-intervals bp-point bp-p bp-mouse bp-m)
      (swap-intervals bp-mouse bp-m bp-point bp-p) )
    (refresh-as-needed BP-POINT nil)
    (flush-bp BP-POINT) (flush-bp BP-mouse) (flush-bp BP-m) (flush-bp BP-p))
    
  (if (typep tv:selected-window 'zmacs-window-pane)
      (must-redisplay tv:selected-window dis-text) )
  dis-none)

(defcom com-mouse-transpose-LINES "This is  to transpose LINES at mouse and point" (KM)
  (let ((current-bp (cur-pt)))
    (let ((bp-point-begin (make-bp :bp-line (bp-line current-bp) :bp-index 0))
	  (bp-point-end   (make-bp :bp-line (bp-line current-bp)
				   :bp-index (line-length (bp-line current-bp))))
	  (bp-mouse-begin nil)
	  (bp-mouse-end   nil))
      
      ;;MOVE STUFF AT MOUSE TO POINT
      (MULTIPLE-VALUE-bind (IGNORE IGNORE IGNORE LINE)
	  (MOUSE-CHAR *WINDOW* NIL *MOUSE-X* *MOUSE-Y*)	   ;Figure out where mouse is
	(setq bp-mouse-begin (make-bp :bp-line line :bp-index 0)
	      bp-mouse-end   (make-bp :bp-line line :bp-index (line-length line)) )
	(if (bp-< bp-point-begin bp-mouse-begin)
	    (swap-intervals bp-point-begin bp-point-end   bp-mouse-begin bp-mouse-end)
	    (swap-intervals  bp-mouse-begin bp-mouse-end bp-point-begin bp-point-end) )))
    (refresh-as-needed current-bp)
    (if (typep tv:selected-window 'zmacs-window-pane)
      (must-redisplay tv:selected-window dis-text) ))
  dis-none)

(DEFSTRUCT (mtr-bps (:MAKE-ARRAY (:LENGTH 4 :type :art-q-list))
			(:CONC-NAME NIL)
			(:CALLABLE-CONSTRUCTORS NIL)
			(:ALTERANT ALTER-mtr-bps)
			(:PREDICATE NIL)
			(:COPIER NIL)
			(:TYPE :ARRAY-LEADER))
  (mtr-bps-fill-pointer 0)		;Current fill index for a new bp 
  (mtr-bps-time 0)			;Time last bp entered
  )
;(setq user:qq (make-mtr-bps :mtr-bps-time (time)))

(defvar *mouse-transpose-regions-bps*
  (make-mtr-bps :mtr-bps-time (time))
  "A collection of buffer positions.  If *mouse-transpose-regions-bp-accumulation-time* 
   elapses since the last bp was pushed, then we start over loading bps.  If we have
   three bps and com-mouse-transpose-regions is called again, then the
   two intervals so defined are swapped.")


(defvariable *mouse-transpose-regions-bp-accumulation-time* 3600 :fixnum
  "If *mouse-transpose-regions-bp-accumulation-time* elapses since the last bp was
   pushed on *mouse-transpose-regions-bp-list*, then we start over pushing bps.")

(defcom com-clean-mouse-transpose-regions-bps
	"Cleans out the saved bps for command Mouse Transpose Regions." (KM)
  (loop for i from 0 below (mtr-bps-fill-pointer *mouse-transpose-regions-bps*)
	do (flush-bp (aref *mouse-transpose-regions-bps* i)) )
  (setf (mtr-bps-fill-pointer *mouse-transpose-regions-bps*) 0)
  dis-none)

(defcom com-mouse-transpose-regions
	"Exchange 2 regions delimited by 4 mouse clicks, which are automatically sorted." (KM)
  (cond ((= (mtr-bps-fill-pointer *mouse-transpose-regions-bps*) 0)
	 (setf (mtr-bps-time *mouse-transpose-regions-bps*) (time))
	 (vector-push (copy-bp (mouse-bp *window*) :normal);;copy-bp used here for auto-updates of bps
		      *mouse-transpose-regions-bps*))
	((> (time-difference (time) (mtr-bps-time *mouse-transpose-regions-bps*))
	    (+ *mouse-transpose-regions-bp-accumulation-time* (/ *one-minute* 2)) )
	 (setf (mtr-bps-time *mouse-transpose-regions-bps*) (time)
	       (mtr-bps-fill-pointer *mouse-transpose-regions-bps*) 1
	       (aref *mouse-transpose-regions-bps*) (mouse-bp *window*)) )
	((> (time-difference (time) (mtr-bps-time *mouse-transpose-regions-bps*))
	    *mouse-transpose-regions-bp-accumulation-time*)
		(progn (tv:beep :flash)
		       (format t "LAST MOUSE POINT expired.")
		       (process-sleep 150.)
		       (setf (mouse-toys-bp-data-VALID *last-mouse-point-and-time*) nil)
		       (throw 'ZWEI-COMMAND-LOOP nil) )) 
	(:otherwise
	 (vector-push (copy-bp (mouse-bp *window*) :normal);;copy-bp used here for auto-updates of bps
		      *mouse-transpose-regions-bps*)
	 (if (= (mtr-bps-fill-pointer *mouse-transpose-regions-bps*) 4)
	     (progn
	       (mouse-transpose-region)
	       (loop for i from 0 to 3 do (flush-bp (aref *mouse-transpose-regions-bps* i)))
	       (setf (mtr-bps-fill-pointer *mouse-transpose-regions-bps*) 0) ))))
  (if (typep tv:selected-window 'zmacs-window-pane)
      (must-redisplay tv:selected-window dis-text) )
  dis-none)

(defun mouse-transpose-region ()
  "Takes the positions of *mouse-transpose-regions-bps* and makes regions from them and swaps them."
  (LET ((LIST (g-l-p *mouse-transpose-regions-bps*)))
    (SETQ LIST (SORT LIST #'(LAMBDA (BP1 BP2)
			      (AND (EQ (BP-TOP-LEVEL-NODE BP1)
				       (BP-TOP-LEVEL-NODE BP2))
				   (BP-< BP1 BP2)))))
      (let ((BP1 (FIRST LIST))
	    (BP2 (SECOND LIST))
	    (BP3 (THIRD LIST))
	    (BP4 (FOURTH LIST)) )
	(OR (AND (EQ (BP-TOP-LEVEL-NODE BP1) (BP-TOP-LEVEL-NODE BP2))
		 (EQ (BP-TOP-LEVEL-NODE BP3) (BP-TOP-LEVEL-NODE BP4)))
	    (progn
	      (setf (mtr-bps-fill-pointer *mouse-transpose-regions-bps*) 0)
	      (BARF "Regions are not both within single buffers") ))
	(swap-intervals BP1 BP2 BP3 BP4) )))

;;______________________________________________________________________
;; Stored interval commands

(defcom com-Mouse-Copy-Stored-Interval "Stores the currently marked region, if any,
replacing that stored by com-store-pt, or uses the interval stored by com-store-pt.
That interval is inserted at the mouse."
	()
  (mouse-insert-stored-interval nil)
  dis-text)

(defcom com-Mouse-Replace-With-Stored-Interval "Stores the currently marked region,
if any, replacing that stored by com-store-pt, or uses the interval stored by com-
store-pt. That interval is inserted at the mouse and the following sexp is deleted."
	()
  (mouse-insert-stored-interval t)
  dis-text)

(defun mouse-insert-stored-interval (delete-following-sexp-p)
  "See documentation in com-Mouse-Copy-Stored-Interval and
   com-Mouse-Replace-With-Stored-Interval"
  (if (WINDOW-MARK-P *WINDOW*)
      (setf (mouse-toys-bp-data-INTERVAL *last-mouse-point-and-time*)
	    (copy-interval (mark) (point))
	    (WINDOW-MARK-P *WINDOW*)
	    NIL) )
  (if (null (mouse-toys-bp-data-INTERVAL *last-mouse-point-and-time*))
      (format t "~&There is no stored interval to insert.~%")
    (let ((mouse-bp (mouse-bp *window*))
	  (after-in-bp
	    (insert-interval (mouse-bp *window*)
			     (mouse-toys-bp-data-INTERVAL *last-mouse-point-and-time*) )))
      (move-bp (point) mouse-bp)
      (if delete-following-sexp-p
	  (LET* ((OTHER-END (OR (FORWARD-SEXP after-in-bp 1) (BARF)))
		 (SAME-LINE-P (EQ (BP-LINE mouse-bp) (BP-LINE OTHER-END))))
	    (KILL-INTERVAL-ARG after-in-bp OTHER-END 1)
	    (SETQ *CURRENT-COMMAND-TYPE* 'KILL)
	    (COND ((AND SAME-LINE-P
			(= (BP-INDEX after-in-bp) (LINE-LENGTH (BP-LINE after-in-bp))))
		   (VALUES DIS-LINE (BP-LINE after-in-bp) (BP-INDEX after-in-bp)))
		  (T
		   DIS-TEXT)))
	(if (EQ (BP-LINE mouse-bp) (BP-LINE after-in-bp))
	    DIS-LINE
	  DIS-TEXT)))))
;;______________________________________________________________________
;; Kill command

(defcom com-mouse-kill-region
	"A region is marked by holding down the mouse key.
         When it is released the region is killed." ()
  (mark-region-with-mouse (point) (MARK)  (mouse-BP *WINDOW*))
  (com-kill-region) )

;;______________________________________________________________________
;; Closing Parens command

(defcom com-mouse-close-sexp "This closes off the sexp whose opening paren is moused, on the line of point."
	(KM)
  (let ((bp (bp-find-nearest '(#\() (mouse-bp *window*) )))
    (if bp
	(move-bp (point) (close-sexp bp (copy-bp (point))))
      (barf "You didn't click near enough a (.") ))
  dis-text)

(defun bp-find-nearest (char-list bp &optional fixup)
  "Returns a bp to the character nearest bp which is in char-list.
   If there is no success fixup means return a copy of bp, else nil
   is returned."
  (DO ((f-LINE (BP-LINE BP))
       (b-LINE (BP-LINE BP))
       (f-INDEX (BP-INDEX BP) )
       (b-INDEX (BP-INDEX BP) )
       (f-line-length (LINE-LENGTH (BP-LINE BP)) (LINE-LENGTH f-LINE))
       (LAST-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
       (first-LINE (BP-LINE (INTERVAL-first-BP *INTERVAL*)))
       (LAST-INDEX (BP-INDEX (INTERVAL-LAST-BP *INTERVAL*)))
       (FIRST-INDEX (BP-INDEX (INTERVAL-FIRST-BP *INTERVAL*)))
       failure)
      ((cond ((member (aref f-line f-index) char-list :test #'char=)
	      (return-from bp-find-nearest (create-bp f-line f-index)) )
	     ((member (aref b-line b-index) char-list :test #'char=)
	      (return-from bp-find-nearest (create-bp b-line b-index)) )
	     ((eq failure :total)
	      (if fixup
		  (copy-bp bp)
		(return-from bp-find-nearest nil) ))))
    (incf f-INDEX)
    (decf b-INDEX)
    (cond ((and (eq f-line last-line)
		(= f-index last-index) )
	   (if (eq failure :backward)
	       (setq failure :total)
	     (setq failure :forward) )
	   (decf f-index) )
	  ((>= f-index f-line-length)
	   (setq f-line (LINE-NEXT f-LINE)
		 f-line-length (LINE-LENGTH f-line)
		 f-index 0)))
    (cond ((and (eq b-line first-line)
		(= b-index (1- FIRST-INDEX)) )
	   (if (eq failure :forward)
	       (setq failure :total)
	     (setq failure :backward) )
	   (incf b-index) )
	  ((= b-index -1)
	   (setq b-line (LINE-previous b-LINE)
		 b-index (1- (LINE-LENGTH b-LINE)) )))))


(defun close-sexp (opening-bp point)
  ;;insert the right number of )s
  (move-bp point (backward-over '(#\) #\space #\return #\tab ) point))
  (let ((start-bp (or opening-bp (forward-defun point -1 t))))
    (loop for n from 0 to 1000
	  as trial-bp = (FORWARD-SEXP point -1 t n start-bp nil)
	  when (bp-= trial-bp start-bp)
	  do (progn
	       (dotimes (i n) (insert-moving point #\) ))
	       (return :wow) )
	  when (bp-< trial-bp start-bp)
	  do (progn
	       (dotimes (i n) (insert-moving point #\) ))
	       (return :wee) ))
    ;;insert the space after closing off this line's last sexp
    (let ((line-first-bp (make-bp :bp-line (bp-line point) :bp-index 0))
	  (line-last-bp (make-bp :bp-line (bp-line point) :bp-index (line-length (bp-line point)))) )
      (delete-interval point line-last-bp t)
      (move-bp line-last-bp (make-bp :bp-line (bp-line point) :bp-index (line-length (bp-line point))))
      (loop do (forward-over *whitespace-chars* line-first-bp)
	    when (bp-= line-last-bp line-first-bp) do (return nil)
	    when (char= (bp-char line-first-bp) #\) )
	      do (progn (insert-moving line-first-bp #\space ) (return nil))
	    as for-bp = (FORWARD-SEXP line-first-bp 1 t 0 line-last-bp nil t)
	    do (if for-bp (move-bp line-first-bp for-bp) (return nil)) )))
  (make-bp :bp-line (bp-line point) :bp-index (line-length (bp-line point))) )

;;Unused but couldn't throw it away. gsl.
(defun forward-to (char-list bp &optional (times 1) fixup)
  "Return a bp just after the TIMES-th occurance of a character in CHAR-LIST from bp.
   If times is negative go backwards.  If fixup is non-nil return a bp to the beginning
   (or end) of the buffer if that is encountered, else return nil."
  (let ((bp-out (copy-bp bp)))
    (if (minusp times)
	(dotimes (i (abs times))
	  (loop until (null bp-out)
		until (member (bp-ch-char bp-out) char-list)
		until (bp-= bp-out (interval-first-bp *interval*))
		do (move-bp bp-out (forward-char bp-out -1 fixup)) ))
      (dotimes (i (abs times))
	(loop until (null bp-out)
	      until (member (bp-ch-char bp-out) char-list)
	      until (bp-= bp-out (interval-last-bp *interval*))
	      do (move-bp bp-out (forward-char bp-out 1 fixup)) )))
    bp-out))

;;______________________________________________________________________
;; Indentation commands

;;Turns tabs to spaces
(defcom com-mouse-save-index
	"Saves the line index of the mouse for com-mouse-indent-to-saved-index"
	(km)
  (let ((bp (copy-bp (mouse-bp *window*) :normal)))
    (let ((line (bp-line bp)))
      (UNTABIFY-INTERVAL (make-temp-bp :bp-line line :bp-index 0)
			 (make-temp-bp :bp-line line :bp-index (line-length line))
			 T))
    (setf (mouse-toys-bp-data-indent-index *last-mouse-point-and-time*)
	  (bp-index bp) )
    (move-bp (point) bp)
    (flush-bp bp) )
  dis-bps)

(defcom com-mouse-indent-to-saved-index
	"Indents char moused to index saved by com-mouse-save-index" ()
  (indent-to-saved-index (mouse-bp *window*))
  dis-text)

(defcom com-indent-to-saved-index
	"Indents char at point to index saved by com-mouse-save-index" ()
  (indent-to-saved-index (point))
  dis-text)
	
(defun indent-to-saved-index (bp)
  "Turns tabs to spaces and indents to saved index in *last-mouse-point-and-time*"
  (setf (WINDOW-MARK-P *WINDOW*) nil)
  (let ((line (bp-line bp)))
    (UNTABIFY-INTERVAL (make-temp-bp :bp-line line :bp-index 0)
		       (make-temp-bp :bp-line line :bp-index (line-length line))
		       T))
  (cond ((> (mouse-toys-bp-data-indent-index *last-mouse-point-and-time*)
	    (bp-index bp))
	 (move-bp (point) bp) ;;make dis-line redisplay the correct line
	 (insert bp (make-string (- (mouse-toys-bp-data-indent-index *last-mouse-point-and-time*)
				    (bp-index bp)) :initial-element #\space)))
	((= (mouse-toys-bp-data-indent-index *last-mouse-point-and-time*)
	    (bp-index bp)) )
	(:otherwise
	 (move-bp (point) (bp-line bp)
		  (mouse-toys-bp-data-indent-index *last-mouse-point-and-time*))
	 (kill-interval (point) bp t) )))

(setf (comtab-extended-commands *standard-comtab*)
      (union (make-command-alist '(com-indent-to-saved-index))
	      (comtab-extended-commands *standard-comtab* ) ))

(command-store 'com-indent-to-saved-index #\c-i *standard-comtab*)

;;***************************** FIXES ************************************

(DEFUN COMMAND-LOOKUP (CHAR COMTAB &OPTIONAL NO-INDIRECTION-P)
  "Return the command in COMTAB has for character CHAR.
NO-INDIRECTION-P means do not follow indirections stored
in elements of COMTAB; return the list instead of looking
at the character the list specifies.
The second value is the comtab the command was found in.
This will be COMTAB or a comtab that COMTAB indirects to."
  (DECLARE (VALUES COMMAND COMTAB))
  (DO ((CTB COMTAB)
       (CH CHAR)
       (KEYBOARD-ARRAY)
       (COMMAND))
      (NIL)
    (SETQ KEYBOARD-ARRAY (COMTAB-KEYBOARD-ARRAY CTB)
	  COMMAND (COND ((NOT (ARRAYP KEYBOARD-ARRAY))
			 (CDR (ASSOC CH KEYBOARD-ARRAY :TEST #'EQ)))
			((CHAR-BIT CH :MOUSE)
			 (AREF (COMTAB-MOUSE-ARRAY CTB)
			       (MIN (SI:CHAR-MOUSE-CLICKS CH)
				    (1- (array-dimension (comtab-mouse-array ctb) 0)) );;gsl
			       (SI:CHAR-MOUSE-BUTTON CH)
			       (TV:CHAR-CMSH-BITS CH) ))
			(T (AREF KEYBOARD-ARRAY
				 (CHAR-CODE CH)
				 (CHAR-BITS CH) ))))
    (IF (OR (NOT (CONSP COMMAND)) NO-INDIRECTION-P)
	(AND (OR COMMAND (NULL (SETQ CTB (COMTAB-INDIRECT-TO CTB))))
	     (RETURN (VALUES COMMAND CTB)))
	(SETQ CTB COMTAB
	      CH (MAKE-CHAR (SECOND COMMAND) (FIRST COMMAND)) ))))

(DEFUN INSERT-INTERVAL (AT-BP FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  "Insert a copy of an interval into text at AT-BP.
Either pass the interval to insert as the second argument,
or pass a pair of BPs that delimit the interval.
AT-BP is left pointing before the inserted text unless it is of type :MOVES.
The value is a BP pointing after the inserted text."
  (AND (NOT *BATCH-UNDO-SAVE*)
       *UNDO-SAVE-SMALL-CHANGES*
       (UNDO-SAVE-NEW-SMALL-CHANGE AT-BP AT-BP))
  (MUNG-BP-INTERVAL AT-BP)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((AT-LINE (BP-LINE AT-BP))
	(AT-INDEX (BP-INDEX AT-BP))
	(FROM-LINE (BP-LINE FROM-BP))
	(FROM-INDEX (BP-INDEX FROM-BP))
	(TO-LINE (BP-LINE TO-BP))
	(TO-INDEX (BP-INDEX TO-BP)))
    (IF (EQ FROM-LINE TO-LINE)
	;; Insert within AT-LINE.
	(INSERT-WITHIN-LINE AT-LINE AT-INDEX FROM-LINE FROM-INDEX TO-INDEX)
	(LET ((AT-LINE-LENGTH (LINE-LENGTH AT-LINE))
	      (FROM-LINE-LENGTH (LINE-LENGTH FROM-LINE))
	      (ARRAY-TYPE (IF (OR (EQ (ARRAY-TYPE TO-LINE) 'ART-FAT-STRING)
				  (EQ (ARRAY-TYPE FROM-LINE) 'ART-FAT-STRING))
			      'ART-FAT-STRING
			      (ARRAY-TYPE AT-LINE)))
	      FIRST-LINE
	      LAST-LINE)
	  (COND ((AND (ZEROP TO-INDEX)
		      (ZEROP AT-INDEX)
		      (not (eq to-line at-line)) ) ;;this is needed to prevent circular line links. gsl 2-11-88
		 ;;Inserting stuff ending with CR at front of line
		 ;;implies we can just shove down the old line
		 (SETQ LAST-LINE AT-LINE)
		 ;; But then we can't use it as the first line.
		 (SETQ FIRST-LINE (CREATE-LINE ARRAY-TYPE
					       (- FROM-LINE-LENGTH FROM-INDEX)
					       (BP-NODE AT-BP)))
		 (SETF (LINE-PREVIOUS FIRST-LINE) (LINE-PREVIOUS AT-LINE))
		 (AND (LINE-PREVIOUS AT-LINE)
		      (SETF (LINE-NEXT (LINE-PREVIOUS AT-LINE)) FIRST-LINE))
		 (COPY-ARRAY-PORTION FROM-LINE FROM-INDEX FROM-LINE-LENGTH
				     FIRST-LINE 0 (- FROM-LINE-LENGTH FROM-INDEX))
		 (SETF (LINE-PLIST FIRST-LINE) (LINE-PLIST FROM-LINE))
		 ;; Transfer bps from the front of AT-LINE to FIRST-LINE.
		 (DOLIST (BP (LINE-BP-LIST AT-LINE))
		   (AND (ZEROP (BP-INDEX BP))
			(EQ (BP-STATUS BP) :NORMAL)
			(MOVE-BP BP FIRST-LINE 0))))
		(T
		 ;; Otherwise, keep the beginning of the line we are inserting in,
		 ;; and make a new line for the tail end of the string.
		 (SETQ FIRST-LINE AT-LINE)
		 (SETQ LAST-LINE (CREATE-LINE ARRAY-TYPE
					      (+ TO-INDEX (- AT-LINE-LENGTH AT-INDEX))
					      (BP-NODE AT-BP)))
		 ;; Copy the first part of TO-LINE into the LAST-LINE.
		 (COPY-ARRAY-PORTION TO-LINE 0 TO-INDEX
				     LAST-LINE 0 TO-INDEX)
		 ;; Figure out whether AT-LINE is being changed at all.
		 (OR (AND (ZEROP FROM-LINE-LENGTH)
			  (= AT-INDEX (LINE-LENGTH AT-LINE)))
		     (MUNG-LINE AT-LINE))
		 ;; Copy the second part of AT-LINE to LAST-LINE.
		 (COPY-ARRAY-PORTION AT-LINE AT-INDEX AT-LINE-LENGTH
				     LAST-LINE TO-INDEX (+ (- AT-LINE-LENGTH AT-INDEX) TO-INDEX))
		 ;; Copy FROM-LINE into AT-LINE.
		 (SET-LINE-LENGTH AT-LINE (+ AT-INDEX (- FROM-LINE-LENGTH FROM-INDEX)))
		 (DO ((FF FROM-INDEX (1+ FF))
		      (AT AT-INDEX (1+ AT))
		      (|16B-P| (EQ (ARRAY-TYPE AT-LINE) 'ART-FAT-STRING))
		      (CH))
		     ((>= FF FROM-LINE-LENGTH))
		   (COND ((NOT (OR (< (CHAR-INT (SETQ CH (AREF FROM-LINE FF))) 400)
				   |16B-P|))
			  (SET-LINE-ARRAY-TYPE AT-LINE 'ART-FAT-STRING)
			  (SETQ |16B-P| T)))
		   (SETF (AREF AT-LINE AT) CH))
		 ;; Relocate buffer pointers.
		 (DOLIST (BP (LINE-BP-LIST AT-LINE))
		   (LET ((I (BP-INDEX BP)))
		     (COND ((OR (> I AT-INDEX)
				(AND (= I AT-INDEX)
				     (EQ (BP-STATUS BP) :MOVES)))
			    (MOVE-BP BP LAST-LINE (+ (- I AT-INDEX) TO-INDEX))))))))
	  (let ((THE-LINE-BEYOND (LINE-NEXT AT-LINE))
		(PREV-LINE first-line)
		(THIS-LINE FIRST-LINE))
	    (unwind-protect ;;insure line links' integrity. gsl.
		(DO ((NODE (BP-NODE AT-BP))
		     (ORIGINAL-LINE (LINE-NEXT FROM-LINE) (LINE-NEXT ORIGINAL-LINE)))
		    ((EQ ORIGINAL-LINE TO-LINE))
		  (SETQ PREV-LINE THIS-LINE
			THIS-LINE (COPY-LINE ORIGINAL-LINE NODE))
		  (without-interrupts ;;insure line links' integrity. gsl.
		    (SETF (LINE-NEXT PREV-LINE) THIS-LINE)
		    (SETF (LINE-PREVIOUS THIS-LINE) PREV-LINE) ))
	      (without-interrupts ;;insure line links' integrity. gsl.
		(AND THE-LINE-BEYOND
		     (SETF (LINE-PREVIOUS THE-LINE-BEYOND) LAST-LINE))
		(SETF (LINE-NEXT LAST-LINE) THE-LINE-BEYOND)
		(SETF (LINE-NEXT this-LINE) LAST-LINE)
		(SETF (LINE-PREVIOUS LAST-LINE) this-LINE) )))
	  (CREATE-BP LAST-LINE TO-INDEX)))))

;;fix char bits for keys
;;; Changed this function to set the shifting component of the mouse
;;; button before we do any double-click analysis.
TV:
(DEFUN MOUSE-CHARACTER-BUTTON-ENCODE (BD
			    &AUX BUTTON MASK CH TIME
                            (NEW-BUTTONS MOUSE-LAST-BUTTONS)
                            (NEW-TIME MOUSE-LAST-BUTTONS-TIME))
  "Look at mouse button transitions and detect double clicks.
BD is a mask of buttons that went down on the initial transition;
it presumably came from MOUSE-INPUT.
The value is NIL if no button is pushed (BD is 0),
or 2000 + 8 N + B, where B is the bit number in the button word,
and N is one less than the number of clicks.
   Accepts a character or fixnum.  Returns a character."
  (SETQ CH
	(COND
	  ((>= (SETQ BUTTON (1- (HAULONG BD))) 0)  ; Pick a button that was just pushed
	   (SETQ MASK (LSH 1 BUTTON)
		 CH   (CODE-MOUSE-CHAR BUTTON)
		 TIME MOUSE-LAST-BUTTONS-TIME)
           ;; Change starts here ------------------- Courtesy of Tom Eckberg
	   ;; Set non-incrementing bucky-bits
	   (DOLIST (SHIFT '(:HYPER :SUPER :META :CONTROL))
	     (WHEN (AND (KEY-STATE SHIFT)
			(NOT (MEMBER SHIFT *MOUSE-INCREMENTING-KEYSTATES*)))
	       (SETF (CHAR-BIT CH SHIFT) 1)))
           ;; Change ends here------------------------------ Thanks Tom, gsl.
	   ;; Each incrementing key that is held down
	   ;; counts as an extra click in the number of clicks.
	   (DOLIST (KEY *MOUSE-INCREMENTING-KEYSTATES*)
	     (WHEN (KEY-STATE KEY)
               (SETF (CHAR-MOUSE-CLICKS CH) (INCF (CHAR-MOUSE-CLICKS CH)))))
	   (PROG1
	     (LOOP NAMED MOUSE-CHARACTER-BUTTON-ENCODE	;Do forever (until guy's finger wears out)
		   UNLESS MOUSE-DOUBLE-CLICK-TIME
		   RETURN CH
		   DOING
		   ;; Ignore any clicking during the bounce delay
		   (LOOP DOING (MULTIPLE-VALUE-SETQ (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
			 UNTIL (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-BOUNCE-TIME)
			 FINALLY (SETQ TIME NEW-TIME))
		   ;; Look for button to be lifted, or for double-click timeout
		   (LOOP WHILE (LOGTEST MASK NEW-BUTTONS)
			 DO (MULTIPLE-VALUE-SETQ (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
			 WHEN (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-DOUBLE-CLICK-TIME)
			 ;; Timed-out with button still down
			 DO (RETURN-FROM MOUSE-CHARACTER-BUTTON-ENCODE ch)
			 FINALLY (SETQ TIME NEW-TIME))
		   ;; Button was lifted, do another bounce delay
		   (LOOP DOING (MULTIPLE-VALUE-SETQ (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
			 UNTIL (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-BOUNCE-TIME)
			 FINALLY (SETQ TIME NEW-TIME))
		   ;; Now watch for button to be pushed again
		   (LOOP UNTIL (LOGTEST MASK NEW-BUTTONS)
			 DO (MULTIPLE-VALUE-SETQ (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
			 WHEN (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-DOUBLE-CLICK-TIME)
			 ;; Timed-out with button still up
			 DO (RETURN-FROM MOUSE-CHARACTER-BUTTON-ENCODE CH)
			 FINALLY (PROGN
                                   ;; Count multiplicity of clicks.
                                   (SETF (CHAR-MOUSE-CLICKS CH) (INCF (CHAR-MOUSE-CLICKS CH)))
                                   (SETQ TIME NEW-TIME)))
		   ;; Continue scanning (for triple click)
		   )
	     (SETQ MOUSE-LAST-BUTTONS      NEW-BUTTONS
		   MOUSE-LAST-BUTTONS-TIME NEW-TIME)))))
  (IF (INTEGERP CH) (INT-CHAR CH) CH))

W:
(defmethod (scroll-bar-mixin :mouse-buttons) (bd x y)
  "Redefine :mouse-buttons to map mouse-click R2 to the scroll-bar when scroll-bar is active."
  (let ((buttons (mouse-character-button-encode bd)))
    (if (or (and (= buttons #\mouse-r)
		 (key-state :control)
		 (not (key-state :meta))
		 (not (key-state :super))
		 (not scroll-bar-active-state))
	    (and (= buttons #\mouse-r-2)
		 (not (or (key-state :control)
			  (key-state :meta) ));; make sure it is a single key.
		 (not scroll-bar-active-state) )) 
        (mouse-call-system-menu)
      (send self :mouse-click buttons x y))))

(setq tv:*MOUSE-INCREMENTING-KEYSTATES* '(:shift :right-hyper))

;;************************************************************************
;; Finally some mouse enhancements to incremental search.
;; C-mouse-middle will insert an sexp into the search.
;; C-mouse-left will insert the region marked while mouse is held down.
;; mouse-right will insert a text-mode word

(DEFUN INCREMENTAL-SEARCH (REVERSE-P &AUX (ORIG-PT (COPY-BP (point))))
  (SYS:WITH-SUGGESTIONS-MENUS-FOR ZWEI:INCREMENTAL-SEARCH
    (SELECT-WINDOW *WINDOW*)
    (FORMAT *QUERY-IO* "~&")			;Necessary if in the mini-buffer
    (UNWIND-PROTECT
	(TYPEIN-LINE-ACTIVATE
	  (PROG (CHAR				; The current command.
		 XCHAR				; Upcase version of character
		 MUST-REDIS			; T => The echo-area must be completely redisplayed.
		 (P 0)				; The stack pointer into *IS-BP*, etc. for input and rubout
		 (P1 0)				; The pointer for which search we are doing.
						; Can never exceed P.
		 SUPPRESSED-REDISPLAY		; T if the last input char was read before
						;  redisplay had a chance to finish.
						;  A  G read that way acts like a failing search quit.
		 BP1				; Aux BP used for actual search¥¥g.
		 NEW-BP
		 TIME-OUT			; Set by SEARCH when it times out so we can check input.
		 INPUT-DONE			; An ESCAPE or control char has been seen.
						; Do not look for input any more; just search, then exit.
		 )
		;; Clear out the search string.
		(STORE-ARRAY-LEADER 0 *IS-STRING* 0) 
		;; Initialize the stacks.
		(SETF (AREF *IS-STATUS* 0) T)	
		(SETF (AREF *IS-REVERSE-P* 0) REVERSE-P)
		(SETF (AREF *IS-OPERATION* 0) :NORMAL)
		(SETF (AREF *IS-POINTER* 0) 0)
		(SETF (AREF *IS-BP* 0) (COPY-BP (point)))
		;; Initially we must redisplay.
		(SETQ MUST-REDIS T)		
		(GO CHECK-FOR-INPUT)
		;; Come here if there is input, or nothing to do until there is input.
	     INPUT
		(SETQ SUPPRESSED-REDISPLAY NIL)
		(AND (WINDOW-READY-P *WINDOW*)	;In case of minibuffer,
		     (REDISPLAY *WINDOW* :POINT))	;redisplay point position while waiting.
		(IF (= (WINDOW-REDISPLAY-DEGREE *WINDOW*) DIS-NONE)
		    (REDISPLAY-MODE-LINE)	;Update indication of more above or below.
		    (SETQ SUPPRESSED-REDISPLAY T))
		(IF SUPPRESSED-REDISPLAY
		    (SETQ CHAR (READ-ANY-WITHOUT-SCROLLING))          
		    ;; If must wait for input, make the window's 
		    ;; blinker blink even though not selected.
		    (UNWIND-PROTECT
			(PROGN
			  (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-VISIBILITY :BLINK)
			  (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-DESELECTED-VISIBILITY :BLINK)
			  (SETQ CHAR (READ-ANY-WITHOUT-SCROLLING)))    
		      (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-VISIBILITY
			    (IF (EQ *WINDOW* W:SELECTED-WINDOW)
				:BLINK
				(W:SHEET-EXPOSED-P *WINDOW*)))
		      (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-DESELECTED-VISIBILITY :ON)))
		 ;;This NEXT clause for mouse insertion of string for which to search. gsl.
		(WHEN (CONSP CHAR)
		  (IF (eq (car char) :mouse-button)
		      (COND ((MEMBER (second char) '(#\c-mouse-m-2 #\c-mouse-m)
				     :TEST #'CHAR=)
			     ;;We WANT TO MARK AN SEXP AND LOOK FOR IT
			     (let ((bp-1 (copy-bp (MOUSE-BP *WINDOW*)))
				   (bp-2 (copy-bp (point)))
				   (*mouse-x* (- (fourth char)
						 (TV:SHEET-INSIDE-LEFT (WINDOW-SHEET (third char)))))
				   (*mouse-y* (- (fifth char)
						 (TV:SHEET-INSIDE-top (WINDOW-SHEET (third char))))))
			       (FUNCALL (case (GET *MAJOR-MODE* 'EDITING-TYPE)
					  ((:LISP :TEXT) 'LISP-MARK-THING)
					  (OTHERWISE 'DEFAULT-MARK-THING))
					bp-1 bp-2 (AREF (BP-LINE BP-1) (BP-INDEX BP-1))
					(BP-LINE BP-1) (BP-INDEX BP-1))
			       (let ((st (string-interval (forward-over *whitespace-chars* bp-1)
							  (backward-over *whitespace-chars* bp-2) t t))
				     IDX)
				 (dotimes (n (1- (length st)))
				   (setq char (aref st n))
				   (OR MUST-REDIS (FORMAT *QUERY-IO* "~C" CHAR))
				   (PUSH-ISEARCH-STATUS)
				   (setq idx (AREF *IS-POINTER* P))
				   (AND (>= IDX (ARRAY-LENGTH *IS-STRING*))
					(ADJUST-ARRAY *IS-STRING* (+ IDX 100)))
				   (setf (Aref *IS-STRING* IDX) CHAR)
				   (setf (Aref *IS-POINTER* P) (1+ IDX) )
				   (setf (Aref *IS-OPERATION* P) ':NORMAL) )
				 (setq char (aref st (1- (length st)))) )))
			    ((AND (MEMBER (second char) '(#\c-mouse-l #\c-mouse-l-2 ) :TEST #'CHAR=)
				  (LOGTEST 1 (W:MOUSE-BUTTONS T)) )
			     ;;We WANT TO MARK A REGION AND LOOK FOR IT
			     (LET ((OLD-MARKED (WINDOW-MARK-P *WINDOW*))
				   (OLD-POINT (COPY-BP (POINT)))
				   (OLD-MARK (COPY-BP (MARK)))
				   (*MOUSE-X* (- (FOURTH CHAR) (W:SHEET-INSIDE-LEFT (WINDOW-SHEET (THIRD CHAR)))))
				   (*MOUSE-Y* (- (FIFTH CHAR) (W:SHEET-INSIDE-TOP (WINDOW-SHEET (THIRD CHAR)))))
				   (POINT (POINT))
				   (MARK (MARK))
				   BP)
			       (SETQ BP (MOUSE-BP *WINDOW* *MOUSE-X* *MOUSE-Y*))
			       ;;move point and mark to get the region to be copied.
			       (MOVE-BP MARK BP)
			       (SETF (WINDOW-MARK-P *WINDOW*) T)
			       (DO ((LAST-X *MOUSE-X*)
				    (LAST-Y *MOUSE-Y*))
				   (NIL)
				 (MOVE-BP POINT BP) 
				 (MUST-REDISPLAY *WINDOW* DIS-BPS)
				 (REDISPLAY *WINDOW* :POINT)
				 (OR (WAIT-FOR-MOUSE LAST-X LAST-Y)
				     (RETURN NIL))
				 (MULTIPLE-VALUE-SETQ (LAST-X LAST-Y) (MOUSE-POSITION))
				 (SETQ BP (MOUSE-BP *WINDOW* LAST-X LAST-Y)))
			       ;;insert the region from mark to point FOR SEARCH
			       (let ((st (string-interval MARK POINT NIL))
				     IDX)
				 (dotimes (n (1- (length st)))
				   (setq char (aref st n))
				   (OR MUST-REDIS (FORMAT *QUERY-IO* "~C" CHAR))
				   (PUSH-ISEARCH-STATUS)
				   (setq idx (AREF *IS-POINTER* P))
				   (AND (>= IDX (ARRAY-LENGTH *IS-STRING*))
					(ADJUST-ARRAY *IS-STRING* (+ IDX 100)))
				   (setf (Aref *IS-STRING* IDX) CHAR)
				   (setf (Aref *IS-POINTER* P) (1+ IDX) )
				   (setf (Aref *IS-OPERATION* P) ':NORMAL) )
				 ;;restore old state
				 (move-bp (POINT) OLD-POINT)
				 (IF OLD-MARKED
				     (MOVE-BP MARK OLD-MARK)
				   (SETF (WINDOW-MARK-P *WINDOW*) NIL) )
				 (IF (ZEROP (LENGTH ST))
				     (PROGN
				       (FUNCALL *STANDARD-INPUT* ':UNTYI CHAR) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT))
				   (setq char (aref st (1- (length st)))) ))))
			    (:OTHERWISE
			     (FUNCALL *STANDARD-INPUT* ':UNTYI CHAR)
			     (SETQ INPUT-DONE T)
			     (GO CHECK-FOR-INPUT) ))
		    (SETQ INPUT-DONE T) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT) ))
		(SETQ XCHAR (CHAR-UPCASE CHAR))
		(COND ((NOT (OR (PLUSP (TV:CHAR-CMSH-BITS CHAR))
				(CHAR-BIT CHAR :MOUSE)
				(MEMBER CHAR '(#\ESCAPE #\END #\RUBOUT #\HELP #\ABORT #\CLEAR-INPUT)
					:TEST #'EQ)))
		       (GO NORMAL))
		      ;; Added Meta-S and Meta-R for mail, 9-18-86 (rpm from wjb).
		      ((MEMBER XCHAR '(#\c-S #\c-R #\m-S #\m-R) :TEST #'EQ)
		       (PUSH-ISEARCH-STATUS)
		       (SETF (AREF *IS-OPERATION* P) :REPEAT)
		       ;; Added Meta-R for mail, 9-18-86 (rpm from wjb). 
		       (LET ((NEW-REVERSE-P (or (CHAR= XCHAR #\c-R) (CHAR= XCHAR #\m-R))))
			 ;; In reverse mode, just go to forward.
			 (COND ((NEQ (AREF *IS-REVERSE-P* P) NEW-REVERSE-P)
				(SETF (AREF *IS-REVERSE-P* P) NEW-REVERSE-P)
				(SETQ MUST-REDIS T)
				(SETF (AREF *IS-OPERATION* P) :REVERSE))
			       ((ZEROP (AREF *IS-POINTER* P))
				(LET ((STRING (STRING (OR (CAAR *SEARCH-RING*) (BARF)))))
				  (COPY-ARRAY-CONTENTS STRING *IS-STRING*)
				  (SETF (AREF *IS-POINTER* P) (ARRAY-ACTIVE-LENGTH STRING)))
				(SETQ MUST-REDIS T))))
		       (GO CHECK-FOR-INPUT))
		      ((CHAR= XCHAR #\c-Q)
		       (LET ((NEW-CH (READ-CHAR)))
			 (SETQ CHAR (IF (CHAR-BIT NEW-CH :CONTROL)
					(INT-CHAR (LOGAND 37 (CHAR-CODE NEW-CH)))
					(MAKE-CHAR NEW-CH))))
		       (GO NORMAL))
		      ((CHAR= CHAR #\HELP)
		       (PRINT-DOC :FULL *CURRENT-COMMAND*)
		       (SEND *STANDARD-INPUT* :UNREAD-ANY (SEND *STANDARD-INPUT* :READ-ANY))
		       (GO INPUT))
		      ((OR (CHAR= XCHAR #\c-G) (CHAR= CHAR #\ABORT))
		       (BEEP)
		       (COND ((AND (OR SUPPRESSED-REDISPLAY (NEQ (AREF *IS-STATUS* P) T))
				   (PLUSP P))
			      ;;  G in other than a successful search
			      ;; rubs out until it becomes successful.
			      (SETQ P (DO ((P (1- P) (1- P)))
					  ((EQ (AREF *IS-STATUS* P) T) P)))
			      (SETQ P1 (MIN P P1)
				    MUST-REDIS T)
			      (GO CHECK-FOR-INPUT))
			     (T
			      (MOVE-TO-BP (AREF *IS-BP* 0))
			      (SEND *QUERY-IO* :MAKE-COMPLETE)
			      (RETURN))))
		      ((OR (CHAR= CHAR #\ESCAPE) (CHAR= CHAR #\END))
		       (AND (ZEROP P)
			    ;; Call string search, and make self-doc print the right thing there.
			    (LET ((*CURRENT-COMMAND* 'COM-STRING-SEARCH-INTERNAL))
			      (RETURN (COM-STRING-SEARCH-INTERNAL REVERSE-P NIL NIL NIL))))
		       (SETQ INPUT-DONE T)
		       (GO CHECK-FOR-INPUT))
		      ((OR (CHAR= CHAR #\RUBOUT) (CHAR= CHAR #\CLEAR-INPUT))
		       ;; Clear-input rubs out all the way.  Set P to 1 and let it be decremented.
		       (IF (CHAR= CHAR #\CLEAR-INPUT)
			   (SETQ P 1))
		       (COND ((<= P 0)		; If he over-rubbed out,
			      (BEEP)		; that is an error.
			      (GO CHECK-FOR-INPUT))
			     (T
			      ;; Rubout pops all of these PDLs.
			      (SETQ P (1- P))
			      (SETQ P1 (MIN P P1))
			      (SETQ MUST-REDIS T)
			      (GO CHECK-FOR-INPUT))))
		      (T
		       (UNREAD-CHAR CHAR)
		       (SETQ INPUT-DONE T)
		       (GO CHECK-FOR-INPUT)))
		(FERROR NIL "A clause fell through.")
		;; Normal chars to be searched for come here.
	     NORMAL
		(OR MUST-REDIS (FORMAT *QUERY-IO* "~C" CHAR))
		(PUSH-ISEARCH-STATUS)
		(LET ((IDX (AREF *IS-POINTER* P)))
		  (AND (>= IDX (ARRAY-TOTAL-SIZE *IS-STRING*))
		       (ADJUST-ARRAY *IS-STRING* (+ IDX 100)))
		  (SETF (AREF *IS-STRING* IDX) CHAR)
		  (SETF (AREF *IS-POINTER* P) (1+ IDX)))
		(SETF (AREF *IS-OPERATION* P) :NORMAL)
		;; Come here after possibly processing input to update the search tables
		;; to search for a while.  First, if necessary and not suppressed
		;; update the search string displayed in the echo area.
	     CHECK-FOR-INPUT
		;; If there is input available, go read it.
		;; Otherwise, do work if there is work to be done.
		(AND (NOT INPUT-DONE)
		     (LISTEN)
		     (GO INPUT))
		;; Now do some work for a while, then go back to CHECK-FOR-INPUT.
		(COND (MUST-REDIS
		       (SETQ MUST-REDIS NIL)
		       (FORMAT *QUERY-IO* "~&~:|")
		       (OR (AREF *IS-STATUS* P1) (FORMAT *QUERY-IO* "Failing "))
		       (AND (AREF *IS-REVERSE-P* P) (FORMAT *QUERY-IO* "Reverse "))
		       (FORMAT *QUERY-IO* "I-Search: ")
		       (STORE-ARRAY-LEADER (AREF *IS-POINTER* P) *IS-STRING* 0)
		       (FORMAT *QUERY-IO* "~A" *IS-STRING*)))
		;; Now see what sort of state the actual search is in, and what work there is to do.
		;; P1 points at the level of the table on which we are actually working.
		(SETF BP1 (AREF *IS-BP* P1))
		;; Display point at the end of the last search level which has succeeded.
		(DO ((P0 P1 (1- P0)))
		    ((EQ (AREF *IS-STATUS* P0) T)
		     (MOVE-TO-BP (AREF *IS-BP* P0))))
		(MUST-REDISPLAY *WINDOW* DIS-BPS)
		(COND ((EQ (AREF *IS-STATUS* P1) :GO)
		       (STORE-ARRAY-LEADER (AREF *IS-POINTER* P1) *IS-STRING* 0)
		       ;; If the level we were working on is still not finished,
		       ;; search at most 100 more lines.  If we find it or the end of the buffer
		       ;; before then, this level is determined and we can work on the next.
		       ;; Otherwise, we remain in the :GO state and do 100 more lines next time.
		       (MULTIPLE-VALUE-SETQ (NEW-BP TIME-OUT)
			 ;; Removed dependence on mail, 9-18-86 (rpm from wjb).
			 (FUNCALL (OR (GET (SEND *INTERVAL* :MAJOR-MODE) 'MAJOR-MODE-INCREMENTAL-SEARCH-FUNCTION)
				      #'SEARCH)
				  BP1
				  *IS-STRING*
				  (AREF *IS-REVERSE-P* P1)
				  NIL
				  100))
		       ;; What happened?
		       (COND (TIME-OUT
			      ;; Nothing determined.  NEW-BP has where we stopped.
			      (MOVE-BP BP1 NEW-BP)
			      (DBP BP1))	;Avoids missing occurrences if string starts with CR.
			     ((NULL NEW-BP)
			      ;; This search was determined to be a failure.
			      (OR (AND (MEMBER :MACRO-ERROR (SEND *STANDARD-INPUT* :WHICH-OPERATIONS)
					       :TEST #'EQ)
				       (SEND *STANDARD-INPUT* :MACRO-ERROR))
				  (BEEP))
			      (SETF (AREF *IS-STATUS* P1) NIL)
			      (MOVE-BP BP1 (AREF *IS-BP* (1- P1)))
			      (MOVE-TO-BP BP1)	
			      (SETQ MUST-REDIS T))
			     (T
			      ;; This search level has succeeded.
			      (SETF (AREF *IS-STATUS* P1) T)
			      (MOVE-TO-BP NEW-BP)	
			      (MOVE-BP BP1 NEW-BP))))
		      ((/= P P1)
		       ;; This level is finished, but there are more pending levels typed ahead.
		       (SETQ P1 (1+ P1))
		       (SETF (AREF *IS-BP* P1) (SETQ BP1 (COPY-BP BP1)))
		       (STORE-ARRAY-LEADER (AREF *IS-POINTER* P1) *IS-STRING* 0)
		       (COND ((NULL (AREF *IS-STATUS* (1- P1)))
			      (COND ((NEQ (AREF *IS-OPERATION* P1) :REVERSE)
				     ;; A failing search remains so unless we reverse direction.
				     (SETF (AREF *IS-STATUS* P1) ()))
				    (T
				     ;; If we reverse direction, change prompt line.
				     (SETQ MUST-REDIS T))))
			     ((EQ (AREF *IS-OPERATION* P1) :NORMAL)
			      ;; Normal char to be searched for comes next.
			      ;; We must adjust the bp at which we start to search
			      ;; so as to allow the user to extend the string already found.
			      (MOVE-BP BP1 (FORWARD-CHAR BP1
							 (COND ((AREF *IS-REVERSE-P* P1)
								(COND ((= (ARRAY-ACTIVE-LENGTH *IS-STRING*) 1)
								       0)
								      (T
								       (ARRAY-ACTIVE-LENGTH *IS-STRING*))))
							       (T
								(- 1 (ARRAY-ACTIVE-LENGTH *IS-STRING*))))
							 T)))))
		      ;; If there is nothing left to do, and terminator seen, exit.
		      (INPUT-DONE
		       (SEARCH-RING-PUSH
			 ;; Entries on the search ring should have a leader
			 (STRING-NCONC (MAKE-ARRAY (ARRAY-ACTIVE-LENGTH *IS-STRING*)
						   :ELEMENT-TYPE 'STRING-CHAR
						   :LEADER-LIST '(0))
				       *IS-STRING*)
			 'SEARCH)
		       (FORMAT *QUERY-IO* "~C" #\ESCAPE)
		       (MAYBE-PUSH-POINT ORIG-PT)
		       (SELECT-WINDOW *WINDOW*)
		       (RETURN))
		      ;; Nothing to do and no terminator, wait for input.
		      (T
		       (GO INPUT)))
		(GO CHECK-FOR-INPUT))
	  (SETQ ORIG-PT NIL))
      (PROGN
	(IF ORIG-PT (MOVE-TO-BP ORIG-PT))
	(MUST-REDISPLAY *WINDOW* DIS-BPS)
	(SEND *MODE-LINE-WINDOW* :DONE-WITH-MODE-LINE-WINDOW)))
    DIS-BPS))



(DEFUN KEY-FOR-COMMAND (COMMAND &OPTIONAL (COMTAB *COMTAB*)
			STARTING-CHAR STARTING-COMTAB SUGGESTED-CHAR
			NO-INDIRECTION-P &AUX TEM)  ;;from patch 94.165 ddd/gsl.
  "Return a string describing the character to invoke COMMAND in COMTAB.
Returns NIL if there is no way.
The second value is the comtab that COMMAND was actually found in;
this is COMTAB or one of the comtabs it indirects to.
STARTING-CHAR and STARTING-COMTAB say where, in the sequence
to be searched for COMTAB, to start looking.  This is so you
can use the character and comtab values to resume the search. 
You can use the SUGGESTED-CHAR to save time
by suggesting the place where the command standardly goes."
  (DECLARE (VALUES STRING CHARACTER COMTAB))
  (OR STARTING-CHAR (SETQ STARTING-CHAR (INT-CHAR 0)))
  (OR STARTING-COMTAB (SETQ STARTING-COMTAB COMTAB))
  (BLOCK FOUND
    (BLOCK NIL
      (IF SUGGESTED-CHAR
	(MULTIPLE-VALUE-BIND (COMMAND1 COMTAB1)
	  (COMMAND-LOOKUP SUGGESTED-CHAR COMTAB)
	  (IF (EQ COMMAND1 COMMAND)
	    (RETURN (VALUES (FORMAT () "~@:C" SUGGESTED-CHAR) SUGGESTED-CHAR COMTAB1)))))
      (DO ((CTB STARTING-COMTAB (IF NO-INDIRECTION-P NIL (COMTAB-INDIRECT-TO CTB)))
	   (STARTING-CHAR STARTING-CHAR (INT-CHAR 0))
	   KEYBOARD-ARRAY
	   LENGTH)
	  ((NULL CTB))
	(SETQ KEYBOARD-ARRAY (COMTAB-KEYBOARD-ARRAY CTB))
	(when (not (CHAR-BIT STARTING-CHAR :MOUSE))
	  (IF (NOT (ARRAYP KEYBOARD-ARRAY))
	      (DOLIST (ELT KEYBOARD-ARRAY)
		(COND ((CHAR< (CAR ELT) STARTING-CHAR))	   ;Don't ever notice chars before the starting char.
		      ((AND (EQ (CDR ELT) COMMAND)
			    (IN-THIS-COMTAB-P COMTAB (CAR ELT) CTB))
		       (RETURN-FROM FOUND
			 (FORMAT () "~@:C" (CAR ELT))
			 (CAR ELT)
			 CTB))
		      ((AND (EQ (CDR ELT) 'COM-DOCUMENTATION)
			    (IN-THIS-COMTAB-P COMTAB (CAR ELT) CTB)
			    (SETQ TEM (RASSOC COMMAND *COM-DOCUMENTATION-ALIST* :TEST #'EQ)))
		       (RETURN-FROM FOUND
			 (FORMAT () "~:@C ~:@C" (CAR ELT) (CAR TEM))
			 (CAR ELT)
			 CTB))
		      ((AND (TYPEP (CDR ELT) 'CLOSURE)	   ;Redundant but should speed things up.
			    (PREFIX-COMMAND-P (CDR ELT))
			    (SETQ TEM (KEY-FOR-COMMAND COMMAND (GET-PREFIX-COMMAND-COMTAB (CDR ELT))))
			    (IN-THIS-COMTAB-P COMTAB (CAR ELT) CTB))
		       (RETURN-FROM FOUND
			 (FORMAT () "~:@C ~A" (CAR ELT) TEM)
			 (CAR ELT)
			 CTB))))
	    (PROGN
	      (SETQ LENGTH (ARRAY-DIMENSION KEYBOARD-ARRAY 0))
	      (DO ((BITS (TV:CHAR-CMSH-BITS STARTING-CHAR) (1+ BITS))
		   (INCREMENT (ARRAY-DIMENSION KEYBOARD-ARRAY 1)))
		  ((= BITS 16.))
		(DO ((CH (IF (= BITS (TV:CHAR-CMSH-BITS STARTING-CHAR))
			     (CHAR-CODE STARTING-CHAR)
			   0)
			 (+ 1 CH))
		     (OFFSET (IF (= BITS (TV:CHAR-CMSH-BITS STARTING-CHAR))
				 (* INCREMENT (CHAR-CODE STARTING-CHAR))
			       0)
			     (+ OFFSET INCREMENT))
		     (PTR (LOCF (AREF KEYBOARD-ARRAY 0 BITS))))
		    ((= CH LENGTH))
		  (LET ((THIS-COM (SYS:%P-CONTENTS-OFFSET PTR OFFSET)))	   ;Faster than AREF on 2-dim array!
		    (COND ((AND (EQ THIS-COM COMMAND)
				(IN-THIS-COMTAB-P COMTAB (CODE-CHAR CH BITS) CTB))
			   (RETURN-FROM FOUND (FORMAT () "~@:C" (CODE-CHAR CH BITS))
					(CODE-CHAR CH BITS)
					CTB))
			  ((AND (EQ THIS-COM 'COM-DOCUMENTATION)
				(IN-THIS-COMTAB-P COMTAB (CODE-CHAR CH BITS) CTB)
				(SETQ TEM (RASSOC COMMAND *COM-DOCUMENTATION-ALIST* :TEST #'EQ)))
			   (RETURN-FROM FOUND
			     (FORMAT () "~:@C ~:@C" (CODE-CHAR CH BITS) (CAR TEM))
			     (CODE-CHAR CH BITS)
			     CTB))
			  ((AND (TYPEP THIS-COM 'CLOSURE)  ;Redundant but should speed things up.
				(PREFIX-COMMAND-P THIS-COM)
				(SETQ TEM (KEY-FOR-COMMAND COMMAND (GET-PREFIX-COMMAND-COMTAB THIS-COM)))
				(IN-THIS-COMTAB-P COMTAB (CODE-CHAR CH BITS) CTB))
			   (RETURN-FROM FOUND
			     (FORMAT () "~:@C ~A" (CODE-CHAR CH BITS) TEM)
			     (CODE-CHAR CH BITS)
			     CTB)))))))))
	(let ((char (MOUSE-KEY-FOR-COMMAND COMMAND CTB STARTING-CHAR)))
	  (if char (return-from found (format nil "~@:C" char)
				char  ctb))) ))))

(defun MOUSE-KEY-FOR-COMMAND (COMMAND CTB STARTING-CHAR)
  (let ((array (comtab-mouse-array ctb))
	(start-clicks (if STARTING-CHAR (CHAR-MOUSE-CLICKS STARTING-CHAR) 0))
	(start-button (if STARTING-CHAR (CHAR-MOUSE-BUTTON STARTING-CHAR) 0))
	(start-bits   (if STARTING-CHAR (tv:CHAR-CMSH-BITS STARTING-CHAR) 0)) )
    (when array
      (loop for clicks from start-clicks below (array-dimension array 0)
	    do (loop for button from start-button below (array-dimension array 1)
		     do (loop for bits from start-bits below (array-dimension array 2)
			      when (eq (aref array clicks button bits)
				       command)
			      do (return-from MOUSE-KEY-FOR-COMMAND
				   (dpb 1 #.sys::%%kbd-mouse
					(dpb clicks sys:%%kbd-mouse-n-clicks
					     (dpb button sys:%%kbd-mouse-button 
						  (code-char 0 bits) ))))))))))

;;________________________________________________________________________ END

