(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)))
(when (featurep 'xemacs)
(require 'x-compose)
(define-key global-map (kbd "s-c") compose-map)
(setq scroll-command-groups '((jump-scroll-up jump-scroll-down)))
(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)
(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)
(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) . ((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'.")
(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)
(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 (progn
(if (and (symbolp binding) (fboundp binding))
(setq binding (funcall binding nil)))
(setq events (append binding nil))
(setq unread-command-events
(mapcar 'character-to-event (cdr events))))
(setq unread-command-events (cdr events)))
(vector
(append (list symbol)
(delq symbol
(aref (key-sequence-list-description (car events)) 0))))))
(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)
(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))))))
(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)))))
,@(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)) `(("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.)")
(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) (let ((map-to-fiddle (car maplist)))
(mapc (lambda (keybinding) (define-key map-to-fiddle (read-kbd-macro (car keybinding)) (eval (cdr keybinding))))
(cdr maplist))))
gawd-key-bind-alist))
(provide 'gawd-keys)