;;; gawd-keys.el --- Startup code that sets keybindings, for the Gordianet.

;;; Copyright (C) 1999--2001 Nix <nix@esperi.demon.co.uk>.

;; Author: Nix <nix@esperi.demon.co.uk>
;; Created: 1999-04-18
;; Keywords: local
;; Version: $Revision: 1.12 $

;; This file is not part of XEmacs.

;;; Commentary:

;; This file's sole purpose is to shrink site-start.el.
;; The keybindings use a good bit of code, so this is definitely in a Good
;; Cause(tm).

;; Much of this file is historical, existing purely to rebind keys on old
;; terminal emulators.

;; To be precise, this does not set any keybindings, merely defines some
;; functions that are useful when bound to keys and defines an alist
;; of useful bindings and a fucntion to apply that alist. The actual
;; call to that function takes place in `default.el' so that the user
;; may override it, set the bindings alist to nothing, that sort of thing.

;;; Code:

;; Define a few useful commands; without exception these just make things
;; interactive that beforehand were not, or that were only accessible via the
;; mouse.

(defun jump-scroll-down ()
"Jump point up (thus, the document down) by six lines.
Like `previous-line' with an argument of 6."
 (interactive "_")
 (previous-line 6))

(defun jump-scroll-up ()
"Jump point down (thus, the document up) by six lines.
Like `next-line' with an argument of 6."
 (interactive "_")
 (next-line 6))

(defun join-line-to-next (&optional arg)
"Join this line to the next one.
Call `delete-indentation' with a prefix argument if none was provided,
and without one if one was provided."
 (interactive "*P")
 (delete-indentation (not arg)))

;; XEmacs-specifics.

;; Provide key composition in XEmacs. (Emacs has `ucs-insert').

(when (featurep 'xemacs)
  (require 'x-compose)

  ;; Hardwire a keymap in.
  (define-key global-map (kbd "s-c") compose-map)

; If we have a scroll-in-place user here, isolate the jump-scrolling commands in
; their own group.

  (setq scroll-command-groups '((jump-scroll-up jump-scroll-down)))

  ;; XEmacs uses scroll-in-place, which is more primitive than
  ;; Eli and my rewrite in Emacs, so needs explicit definitions of some commands
  ;; that that package provides.

  ;; Scroll-in-place / preserve-screen-position interfere with the next two, so we force it off in them.

  (defun scroll-down-1-stay (&optional other)
    "Shift the screen down by one line, taking point with it if necessary.
If OTHER is non-nil, do it to the `other-window' instead."
    (interactive "_")
    (let ((scroll-in-place nil))
      (if other (scroll-other-window-down 1)
        (scroll-down-command 1))))

  (defun scroll-up-1-stay (&optional other)
    "Shift the screen up by one line, taking point with it if necessary.
If OTHER is non-nil, do it to the `other-window' instead."
    (interactive "_")
    (let ((scroll-in-place nil))
      (if other (scroll-other-window 1)
        (scroll-up-command 1))))

  (defun scroll-modeline-left (n &optional window)
    "Scroll the text of WINDOW's modeline N columns leftwards.
Prefix argument is the number of columns to scroll"
    (interactive "p")
    (let ((window (or window (selected-window))))
      (set-modeline-hscroll window (+ (modeline-hscroll window) n))))

  (defun scroll-modeline-right (n &optional window)
    "Scroll the text of WINDOW's modeline N columns rightwards.
Prefix argument is the number of columns to scroll"
    (interactive "p")
    (let ((window (or window (selected-window))))
      (set-modeline-hscroll window (- (modeline-hscroll window) n))))

  (defun pushpop-window-configuration (unpop)
    "Push or pop the window configuration.
Pop a window off the window-configuration stack; see `pop-window-configuration'.
With prefix argument, push the most recently popped window back onto the stack
again."
    (interactive "P")
    (if unpop (unpop-window-configuration)
      (pop-window-configuration)))
  (put 'pushpop-window-configuration 'disabled t)

  ;; Handling non-ASCII-coded keys and characters
  ;;
  ;; These are quite tricky. You can't transmit a (control up) or similar over a
  ;; VT terminal, just as you can't differentiate C-x from C-X; so you can remap
  ;; control-up and control-down in your terminal emulator to functions that do a
  ;; C-c M-o u and C-c M-o d. These prefix keys should be sufficiently weird as
  ;; not to collide with anyone else's use of the same, while in any case being
  ;; vaguely similar to the M-O {foo} used by VT terminals for their escape codes.
  ;;
  ;; Similarly, shift-up and shift-down have gone to C-c M-o U and C-c M-o D, and
  ;; C-i has gone to C-c M-o i, to differentiate it from TAB. Meta-(shift
  ;; control)-(up down next prior) are also handled here because they are
  ;; disambiguated wrongly otherwise, owing to the binding of M-C-c to
  ;; exit-recursive-edit.
  ;;
  ;; A much larger remapping is the mapping of C-c M-1 [A-Z] to (control [A-Z]),
  ;; and of M-C-c M-1 [A-Z] to (meta control [A-Z]).  (I'd have liked to use C-c
  ;; M-o {foo}, but that collided with the other specialist remappings and/or the
  ;; VT mappings.)
  ;;
  ;; Finally, we put Meta, Alt, Super and Hyper keys on PF1 to PF4.
  
  ;; First, define the extended terminal control prefix keys, and change the
  ;; binding of exit-recursive-edit because it collides with a set of VT100
  ;; bindings that everyone missed :( Specifically, change it to use a capitalised
  ;; control key ;}
  
  ;; This could be implemented in Emacs, but there is very little point: This code
  ;; is largely historical at this point.
  
  (global-set-key (kbd "C-c M-o")
    (define-prefix-command 'vt100-console-function-key-map))
  (global-set-key (kbd "C-c M-1")
    (define-prefix-command 'vt100-capctrl-console-function-key-map))
  (global-set-key (kbd "M-C-c") (define-prefix-command 'vt100-meta-userdefs-key-map))
  (global-set-key (kbd "M-C-c M-o") (define-prefix-command 'vt100-meta-console-function-key-map))
  (global-set-key (kbd "M-C-c M-1") (define-prefix-command 'vt100-meta-ctrl-console-function-key-map))
  (global-set-key (kbd "M-escape [") (define-prefix-command 'vt100-next-prior-map))
  (global-set-key (kbd "M-escape O") (define-prefix-command 'vt100-meta-map))
  (global-set-key (kbd "M-C-C") 'exit-recursive-edit)

  ;; Now, for ASCII-only devices only, bind the relevant Weird Key Sequences(tm)
  ;; to the appropriate *real* key events.  (In one case, the Weird Key
  ;; Sequence(TM) is a perfectly normal VT100 key sequence for PF[1-4], but as we
  ;; have to rebind it in the function-key-map anyway, we may as well do it here.)
  
  ;; We allow other devices, too, because even in X some of these bindings are
  ;; useful; mainly those that allow super and hyper to be bound.
  
  ;; We have a table that does much of the mapping for us, in a similar manner as
  ;; the gawd-key-bind-alist below does the key->command binding, and simply stick
  ;; the contents of this table into the right place later on.
  
  ;; FIXME - The meta-next, meta-prior, meta-up and meta-down mappings here are VT
  ;; terminal specific. (However, what *doesn't* emulate a VT terminal, at least
  ;; in that?)
  
  (defvar key-translation-alist '(((eq (console-type) 'tty) .
                                   ((function-key-map .
                                    (("\C-c\eoU" . [(shift up)])
                                     ("\C-c\eoD" . [(shift down)])
                                     ("\C-c\eou" . [(control up)])
                                     ("\C-c\eod" . [(control down)])
                                     ("\C-c\eop" . [(control prior)])
                                     ("\C-c\eon" . [(control next)])
                                     ("\e\C-c\eoU" . [(meta shift up)])
                                     ("\e\C-c\eoD" . [(meta shift down)])
                                     ("\e\C-c\eou" . [(meta control up)])
                                     ("\e\C-c\eod" . [(meta control down)])
                                     ("\e\C-c\eop" . [(meta control prior)])
                                     ("\e\C-c\eon" . [(meta control next)])
                                     ("\e\e[5~" . [(meta prior)])
                                     ("\e\e[6~" . [(meta next)])
                                     ("\e\eOA" . [(meta up)])
                                     ("\e\eOB" . [(meta down)])
                                     ("\e\eOC" . [(meta right)])
                                     ("\e\eOD" . [(meta left)])
                                     ("\C-c\eoi" . [(control i)])
                                     ("\eOP" . event-apply-meta-modifier)
                                     ("\eOQ" . event-apply-alt-modifier)
                                     ("\eOR" . event-apply-super-modifier)
                                     ("\eOS" . event-apply-hyper-modifier)))))
                                  ((eq (console-type) 'x) . ; X knows these keys' names already.
                                    ((key-translation-map .
                                     (([kp-divide] . event-apply-alt-modifier)
                                      ([kp-multiply] . event-apply-super-modifier)
                                      ([kp-subtract] . event-apply-hyper-modifier))))))
    "Which keys to translate into which non-ASCII-coded events.
An alist mapping a predicate identifying a device to a keymap set,
where a keymap set is an alist mapping a keymap name to (an alist mapping
an identifying input key, in raw XEmacs format, to an internal event
to transform it into). (Not very clear, I fear.)

The entry for TTYs must be first in this list.

The terminal emulator provides the key sequence and it is translated
it to the events via `function-key-map'.")

  ;; In order for all that to work, we need a version of `event-apply-modifier'
  ;; that pays attention to the `key-translation-map', as well as the
  ;; `function-key-map'.

  (defun event-apply-modifier (symbol)
    "Return the next key event, with a modifier flag applied.
SYMBOL is the name of this modifier, as a symbol.
`function-key-map' and `key-translation-map' are scanned for prefix bindings."
    (let (events binding)
      ;; read keystrokes scanning `function-key-map' and `key-translation-map'.
      (while (keymapp
              (setq binding
                    (progn
                      (setq events (append events (list (next-key-event))))
                      (or (lookup-key
                           function-key-map
                           (vconcat events))
                          (lookup-key
                           key-translation-map
                           (vconcat events)))))))
      (if binding                       ; found a binding
          (progn
            ;; allow for several modifiers
            (if (and (symbolp binding) (fboundp binding))
                (setq binding (funcall binding nil)))
            (setq events (append binding nil))
            ;; put remaining keystrokes back into input queue
            (setq unread-command-events
                  (mapcar 'character-to-event (cdr events))))
        (setq unread-command-events (cdr events)))
      ;; add a modifier SYMBOL to the first keystroke or event
      (vector
       (append (list symbol)
               (delq symbol
                     (aref (key-sequence-list-description (car events)) 0))))))

  ;; Go through the capital alphabet and map C-c M-1 {letter} to (control letter),
  ;; and M-C-c M-1 {letter} to (meta control letter).  This is especially tricky
  ;; because some of the keys we try to automatically bind here are subsets of
  ;; others that we try to bind; i.e. [(control c) (meta 1) {letter}] is a subset
  ;; of [(meta control c) (meta 1) {letter}], so we have to be sure to bind the
  ;; latter *first* so it matches first.
  (let ((char-to-set ?A))
    (while (not (> char-to-set ?Z))
      (nconc (assoc function-key-map (car key-translation-alist)) `((,(concat "\e\C-c\e1" (char-to-string char-to-set)) .
                                                                     [(meta control ,char-to-set)])))
      (nconc (assoc function-key-map (car key-translation-alist)) `((,(concat "\C-c\e1" (char-to-string char-to-set)) .
                                                                     [(control ,char-to-set)])))
      (setq char-to-set (int-to-char (1+ char-to-set))))
    nil)

  (defun gawd-setup-console-function-key-map (console)
    "Set up our console shortcut keys.
These provide for things like ctrl-up, ctrl-down &c, if appropriate
bindings are made in the terminal emulator.
It applies the bindings given in `key-translation-alist'."
    (let ((old-console (selected-console)))
      (unwind-protect
          (progn
            (select-console console)
            (mapc #'(lambda (device-mapping)
                      (if (eval (car device-mapping))
                          (mapc #'(lambda (keymap-binding)
                                    (let ((keymap (symbol-value (car keymap-binding))))
                                      (mapc #'(lambda (keypair)
                                                (define-key keymap (car keypair) (cdr keypair)))
                                            (cdr keymap-binding)))) (cdr device-mapping)))) key-translation-alist)
            (select-console old-console))))
    nil)

  ;; Set up the VT special keys for each console, and immediately after we have
  ;; loaded the terminal-specific init file.  (We can't run it now because the
  ;; terminal-specific init file is loaded after even default.el.  Why?
  ;; Beats me.)

  (add-hook 'create-console-hook 'gawd-setup-console-function-key-map)
  (add-hook 'term-setup-hook (function (lambda () (gawd-setup-console-function-key-map (selected-console))))))

;; Define a useful variable to make keymapping a comparative doddle
; TODO: extend this to local keymaps for not-yet-loaded modes

(defvar gawd-key-bind-alist
  `((,(current-global-map)
     ("M-up" . 'jump-scroll-down)
     ("M-down" . 'jump-scroll-up)
     ("S-up" . 'scroll-down-1-stay)
     ("S-down" . 'scroll-up-1-stay)
     ("M-C-next" . 'scroll-other-window)
     ("M-C-prior" . 'scroll-other-window-down)
     ("A-M-down" . 'down-list)
     ("A-M-up" . 'backward-up-list)
     ("A-M-home" . 'beginning-of-defun)
     ("A-M-end" . 'end-of-defun)
     ("A-M-left" . 'backward-sexp)
     ("A-M-right" . 'forward-sexp)
     ("C-x M-b" . 'bury-buffer)
     ("C-x O" . 'backward-other-window)
     ("C-iso-left-tab" . 'backward-other-window)
     ("C-x C-^" . 'shrink-window)
     ("C-c j" . 'join-line-to-next)
     ("C-c y" . 'browse-kill-ring)
     ("C-x M-k" . 'kill-buffer-and-window)
     ("A-x b" . (function (lambda (interactive)
                            (replace-buffer-in-windows (current-buffer)))))
     ; This fixes a documentation bug

     ,@(if (featurep 'xemacs)
           `(("C-x z" . 'vi-dot)
             ("C-x C-n" . 'set-goal-column)
             ("M-S-up" . (function (lambda () (interactive (scroll-down-1-stay t)))))
             ("M-S-down" . (function (lambda () (interactive (scroll-up-1-stay t)))))
             ("C-x C-}" . 'scroll-modeline-left)
             ("C-x C-{" . 'scroll-modeline-right)
             ("C-c p" . 'pushpop-window-configuration)) ; Emacs has winner-mode
         `(("C-h a" . 'apropos-toc)
           ("C-h C-m" 'manual-entry)
           ("M-S-up" . 'scroll-other-window-down-1-stay)
           ("M-S-down" . 'scroll-other-window-up-1-stay)
           ("A-k" 'kill-whole-line))))
    ,@(if (not (featurep 'xemacs))
          (,help-mode-map
           ("S-BS" . 'help-go-back))
"Alist from key definitions to bindings.
Each element is of the form (MODE-MAP (KEY . BINDING) ...), where the
MODE-MAP is the name of a major mode's keymap, the KEY may be any string
acceptable to `kbd', and the BINDING is anything that makes sense as the
DEF argument to `define-key'. (Note that not all these arguments may make
sense for all keymaps.)")

;; This function applies the bindings. Note its use of `read-kbd-macro' rather
;; than `kbd' as `kbd' does not evaluate its arguments, and they must be
;; evaluated in this case. `kbd' simply calls `read-kbd-macro', so no harm
;; is done.

(defun gawd-apply-key-bindings ()
  "Apply the key bindings given in the `gawd-key-bind-alist'.
See the documentation for that variable for more information."
  (mapc (lambda (maplist)                        ; For each map
          (let ((map-to-fiddle (car maplist)))
            (mapc (lambda (keybinding)  ; For each keybinding
                    (define-key map-to-fiddle (read-kbd-macro (car keybinding)) (eval (cdr keybinding))))
                  (cdr maplist))))
        gawd-key-bind-alist))

(provide 'gawd-keys)