Download
(provide 'pkb)
(defun pkb-concat= (variable &rest txt-to-add)
"Add the text TXT-TO-ADD to the string stored in VARIABLE"
(set variable (apply 'concat (symbol-value variable) txt-to-add))
)
(defmacro pkb-dolist-cons (spec &rest body)
"Loop over a list..
Evaluate BODY with VAR bound to each cons from LIST, in turn.
Then evaluate RESULT to get return value, default nil.
\(fn (VAR LIST [RESULT]) BODY...)"
(declare (indent 1) (debug ((symbolp form &optional form) body)))
`(let ((,(car spec) ,(nth 1 spec)))
(while ,(car spec)
,@body
(setq ,(car spec) (cdr ,(car spec))))
,@(if (cdr (cdr spec))
`((setq ,(car spec) nil) ,@(cdr (cdr spec))))
)
)
(defcustom pkb-include-base-key-list
(let (cur-list mouse-pref-only mouse-event-w-pref mouse-event-w-pref-num)
(setq cur-list
(append cur-list
'(return tab escape backspace delete insert home end prior next
right down left up)))
(dolist (num (number-sequence 1 12))
(add-to-list 'cur-list
(intern (concat "f" (number-to-string num))) t))
(setq cur-list
(append cur-list
'(
lwindow rwindow apps kp-down kp-add kp-begin kp-decimal
kp-delete kp-divide kp-down kp-end kp-enter kp-equal kp-home
kp-insert kp-left kp-multiply kp-next kp-prior kp-right
kp-separator kp-space kp-subtract kp-tab kp-up)))
(dolist (num (number-sequence 1 9) cur-list)
(add-to-list 'cur-list
(intern (concat "kp-" (number-to-string num))) t))
(setq cur-list (append cur-list
(list mouse-wheel-up-event mouse-wheel-down-event)
'(mouse-1 mouse-2 mouse-3 mouse-4)))
cur-list
)
"A list of the non-ascii base-keys that should be included (ascii base-keys will automatically be included).
The order of this list is used by `pkb-compare-base-key' to sort base-keys"
)
(defcustom pkb-include-keyboard-modifier
'(shift control meta alt)
"A list of the keyboard modifiers that should be included.
The order of this list is used by `pkb-compare-base-key' to sort base-keys"
)
(defcustom pkb-include-mouse-modifier
'(click down double drag triple)
"A list of the mouse modifiers that should be included.
The order of this list is used by `pkb-compare-base-key' to sort base-keys"
)
(defun pkb-char-table-eventp (event)
"Return t if EVENT can be stored in a char-table"
(let (event-check)
(fset 'event-check
(lambda (one-event)
(and (integerp one-event)
(>= one-event 0)
(<= one-event (max-char)))))
(if (consp event)
(and (event-check (car event)) (event-check (cdr event)))
(event-check event)))
)
(defun pkb-esc-mapp (key-sequence)
"Return t if the last element of the vector KEY-SEQUENCE is an ESC"
(and (not (equal key-sequence []))
(equal 27 (aref key-sequence (- (length key-sequence) 1))))
)
(defun pkb-include-mk-p (modified-key)
"Return t if MODIFIED-KEY (e.g. C-g) should be included in the output. If a
vector is passed, return t if every element of vector should be included in
the output."
(if (not (vectorp modified-key))
(cond
((eq modified-key t))
((and (consp modified-key))
(<= (car modified-key) 4194303))
((let* ((mods-type (event-modifiers modified-key))
(basic-type (event-basic-type modified-key))
(flag t)
(pkb-include-modifier
(append pkb-include-keyboard-modifier
pkb-include-mouse-modifier)))
(and
(or
(and (integerp basic-type)
(>= basic-type 32)
(<= basic-type 127))
(memq basic-type pkb-include-base-key-list))
(dolist (elem mods-type flag)
(setq flag (and (memq elem
(append pkb-include-keyboard-modifier pkb-include-mouse-modifier))
flag)))))))
(let ((flag t))
(dotimes (i (length modified-key) flag)
(setq flag (and flag (pkb-include-mk-p (aref modified-key i)))))))
)
(defun pkb-compare-key-sequences (ks1 ks2)
"Return non-nil if the key-sequence (given as a vector) KS1 should precede KS2 in a sort.
The key-sequences are compared item by item, using
`pkb-compare-modified-keys'. If KS1 and KS2 start with the same events
except that KS1 is shorter than KS2, then KS1 precedes KS2."
(let ((idx 0))
(catch 'quit
(while t
(if (<= (length ks1) idx)
(throw 'quit t)
(if (<= (length ks2) idx)
(throw 'quit nil)
(if (not (equal (elt ks1 idx) (elt ks2 idx)))
(throw 'quit
(pkb-compare-modified-keys (elt ks1 idx) (elt ks2 idx))))
))
(setq idx (1+ idx)))))
)
(defun pkb-compare-modified-keys (mk1 mk2)
"Return non-nil if the modified key MK1 should precede MK2 in a sort. Char-ranges sort as the first character in the range.
The sorting of mks is dependent on the order of items in the list (reverse (append pkb-include-keyboard-modifier pkb-include-mouse-modifier)). MK1 and MK2 are sequentially checked to see if they have each modifier in the list. If MK2 has a modifier and MK1 does not then MK1 procedes MK2. If MK1 and MK2 have the same modifiers, `pkb-compare-base-key' is used to compare their base-key.
Intended to be used by `pkb-compare-key-sequences'. "
(when (consp mk1) (integerp (car mk1)) (integerp (cdr mk1))
(setq mk1 (car mk1)))
(when (consp mk2) (integerp (car mk2)) (integerp (cdr mk2))
(setq mk2 (car mk2)))
(let (mk1-mod mk2-mod)
(catch 'quit
(setq mk1-mod (event-modifiers mk1))
(setq mk2-mod (event-modifiers mk2))
(dolist (modif (reverse
(append pkb-include-keyboard-modifier pkb-include-mouse-modifier)))
(if (memq modif mk1-mod)
(if (not (memq modif mk2-mod))
(throw 'quit nil))
(if (memq modif mk2-mod)
(throw 'quit t))
))
(pkb-compare-base-keys
(event-basic-type mk1) (event-basic-type mk2))))
)
(defun pkb-compare-modifier-lists (mods1 mods2)
"Return non-nil if the list of modifiers MODS1 should precede MODS2 in a sort, as in `pkb-compare-modified-keys'."
(catch 'quit
(dolist (modif (reverse
(append pkb-include-keyboard-modifier pkb-include-mouse-modifier)))
(if (memq modif mods1)
(if (not (memq modif mods2))
(throw 'quit nil))
(if (memq modif mods2)
(throw 'quit t))
))
nil)
)
(defun pkb-compare-base-keys (bk1 bk2)
"Return non-nil if the base-key BK1 should precede BK2 in a sort.
Integer events precede other events and smaller integers preceded larger. ESC is sorted after any other integer-events. Otherwise, they are ordered according to `pkb-include-base-key-list'.
Intended to be used by `pkb-compare-modified-keys'"
(catch 'quit
(if (integerp bk1)
(if (integerp bk2)
(cond ((equal bk1 ?\e) (throw 'quit nil))
((equal bk2 ?\e) (throw 'quit t))
(t (throw 'quit (< bk1 bk2))))
(throw 'quit t))
(if (integerp bk2)
(throw 'quit nil)))
(let (bk1-pos)
(setq bk1-pos (memq bk1 pkb-include-base-key-list))
(if bk1-pos
(if (memq bk2 bk1-pos)
(throw 'quit t)
(if (memq bk2 pkb-include-base-key-list)
(throw 'quit nil)
(throw 'quit t)))
nil
)
))
)
(defun pkb-accessible-keymaps (keymapi &optional include-list exclude-list)
"Find all keymaps accessible via prefix-keys from KEYMAPI, except as
restricted by INCLUDE-LIST and/or EXCLUDE-LIST. The output will be in the
form (PK PK-OPTIONS . KEYMAP).
In contrast to the command `accessible-keymaps', 1) prefix-keys that are not
input events according `pkb-include-mk-p' will be excluded; 2) the output
will be unsorted; 3) if a pk is stored in the ESC key of the parent keymap,
the `esc-map-fl' key in PK-OPTIONS will be t.
If INCLUDE-LIST is nil, only the prefix-keys it specifies will be
included. The basic syntax for INCLUDE-LIST is a list of the form (PK-1
... PK-n), where each PK-i is a prefix-key. In this case, this function will
return only keymaps accessible via prefix-keys from some PK-i
\(inclusive). This behavior can be adjusted by replacing PK-i with (list
PK-i), which will cause only PK-i exact-matches to be included in the
returned prefix-keys (note that a prefix-key accessible from ELEM may still
be included if it's accessible from a different element of
INCLUDE-LIST). e.g. ([?\C-x] [?\C-h]) means: \"Include all prefix-keys
accessible from either 'C-x' and 'C-h'\", while ( ([?C-x]) [?\C-h] ) means:
\"Include 'C-x' and all prefix-keys accessible from 'C-h'\".
Any prefix-keys beginning with an element of EXCLUDE-LIST will not be
included. Exact-only matches can be included in EXCLUDE-LIST in the same way as in INCLUDE-LIST.
With respect to priority between INCLUDE-LIST and EXCLUDE-LIST, longer
prefix-key vectors take preference over shorter ones and then EXCLUDE-LIST
takes preference over INCLUDE-LIST, except that any exact-match elements in
INCLUDE-LIST will always be added."
(let (access-kms-vrbl pks-included inc-exl-hierarchy inc-pk-exact)
(when (null include-list) (setq include-list (list [])))
(dolist (inc-pk include-list)
(when (listp inc-pk)
(add-to-list 'inc-pk-exact (car inc-pk) nil 'ignore)
(setq include-list (delq inc-pk include-list))))
(let (cur-pks-len cur-pks-list)
(setq include-list
(sort include-list
(lambda (pk1 pk2) (> (length pk1) (length pk2)))))
(when include-list
(setq cur-pks-list (list (list (list (car include-list))))))
(setq cur-pks-len (length (car include-list)))
(dolist (inc-pk (cdr include-list))
(when (/= (length inc-pk) cur-pks-len)
(setq inc-exl-hierarchy (append cur-pks-list inc-exl-hierarchy))
(setq cur-pks-list nil)
(setq cur-pks-len (length inc-pk)))
(let ((cur-branch (list (list inc-pk))))
(dolist (branch inc-exl-hierarchy)
(when (equal (substring (caar branch) 0 cur-pks-len) inc-pk)
(add-to-list 'cur-branch branch t 'ignore)
(setq inc-exl-hierarchy (delq branch inc-exl-hierarchy))))
(add-to-list 'cur-pks-list cur-branch nil 'ignore)))
(setq inc-exl-hierarchy (append cur-pks-list inc-exl-hierarchy)))
(dolist (exc-pk-entry exclude-list)
(let* (cur-branch
(exc-pk (if (listp exc-pk-entry) (car exc-pk-entry) exc-pk-entry))
(exc-pk-len (length exc-pk)))
(catch 'quit
(dolist (root-branch inc-exl-hierarchy)
(when (and (<= (length (caar root-branch)) exc-pk-len)
(equal (caar root-branch)
(substring exc-pk 0 (length (caar root-branch)))))
(setq cur-branch root-branch)
(throw 'quit nil))))
(while cur-branch
(catch 'quit
(dolist (subbranch (cdr cur-branch))
(let ((sub-pk (caar subbranch)))
(when (and (<= (length sub-pk) exc-pk-len)
(equal sub-pk (substring exc-pk 0 (length sub-pk))))
(setq cur-branch subbranch)
(throw 'quit nil))))
(setcdr (last (car cur-branch)) (list exc-pk-entry))
(setq cur-branch nil)))))
(dolist (hier-elt inc-exl-hierarchy)
(dolist (pk-w-keymap (accessible-keymaps keymapi (caar hier-elt)))
(setq pk-w-keymap (cons nil pk-w-keymap))
(setcar pk-w-keymap (cadr pk-w-keymap))
(setcar (cdr pk-w-keymap) nil)
(let ((cur-pk (car pk-w-keymap)))
(when
(and
(not (member cur-pk pks-included))
(pkb-include-mk-p cur-pk)
(let ((cur-pk-len (length cur-pk)) (cur-branch hier-elt)
high-branch)
(while cur-branch
(catch 'quit
(dolist (subbranch (cdr cur-branch))
(let ((sub-pk (caar subbranch)))
(when (and (<= (length sub-pk) cur-pk-len)
(equal sub-pk
(substring cur-pk 0 (length sub-pk))))
(setq cur-branch subbranch)
(throw 'quit nil))))
(setq high-branch cur-branch)
(setq cur-branch nil)))
(catch 'quit
(dolist (exc-pk-entry (cdar high-branch))
(when
(if (listp exc-pk-entry)
(equal cur-pk (car exc-pk-entry))
(and (<= (length exc-pk-entry) cur-pk-len)
(equal exc-pk-entry
(substring cur-pk 0 (length exc-pk-entry))
)))
(throw 'quit nil)))
t)))
(add-to-list 'access-kms-vrbl pk-w-keymap nil 'ignore))
(add-to-list 'pks-included cur-pk nil 'ignore))))
(dolist (pk-to-add inc-pk-exact)
(unless (member pk-to-add pks-included)
(let ((defn (lookup-key keymapi pk-to-add)))
(when (keymapp defn)
(add-to-list 'access-kms-vrbl
(append (list pk-to-add) (cons nil defn))
nil 'ignore)))))
(dolist (pk-w-keymap access-kms-vrbl)
(when (and (>= (length (car pk-w-keymap)) 1)
(member (substring (car pk-w-keymap) -1) '((?\e) (?\M-\e))))
(setcar (cdr pk-w-keymap)
(list
(list (cons 'esc-map-fl t))))))
access-kms-vrbl)
)
(defun pkb-int-fix-m-esc-in-key-sequences (vector-in)
"An internal function used `pkb-accessible-keymaps'."
(if
(catch 'quit (dotimes (i (length vector-in))
(if (equal (aref vector-in i) 134217755)
(throw 'quit t)))
nil)
(let (list-eqv)
(dotimes (i (length vector-in))
(if (equal (aref vector-in i) 134217755)
(setq list-eqv (append list-eqv '(27 27)))
(setq list-eqv (append list-eqv (list (aref vector-in i))))))
(vconcat list-eqv))
vector-in)
)
(defun pkb-list-keys (input-keymap &optional esc-mapf ignore-sic-if-unmod)
"List the modified-keys (mks) in INPUT-KEYMAP.
If ESC-MAPF, ignore events if they can stored in a char-table (intended for
ignoring events in a non-root keymap whose last prefix key is ESC).
Returns (MKS . BINDS-CHAR-TABLE), where MKS, BINDS-CHAR-TABLE are described
in the comments at the top of the .el file. The bindings in BINDS-CHAR-TABLE
are not also in MKS.
If IGNORE-SIC-IF-UNMOD is non-nil, bindings of self-insert-command
will be ignored for unmodified keys.
Note that this function will properly treat keys with a Meta modifier
\(e.g. so that [27 ?b] -> M-b). "
(let (mks events-w-defn-for-ct binds-char-table)
(map-keymap
(lambda (event defn)
(when (and (pkb-include-mk-p event)
(not (equal event 27))
(or (not esc-mapf)
(symbolp event)
(and (integerp event)
(memq 'meta (event-modifiers event))))
(or (not ignore-sic-if-unmod)
(event-modifiers event)
(not (eq defn 'self-insert-command))))
(if (pkb-char-table-eventp event)
(push (cons event defn) events-w-defn-for-ct)
(pkb-int-add-event event))))
input-keymap)
(setq binds-char-table (make-char-table 'keymap))
(dolist (event-w-defn events-w-defn-for-ct)
(set-char-table-range binds-char-table
(car event-w-defn) (cdr event-w-defn)))
(map-char-table
(lambda (event defn)
(set-char-table-range binds-char-table event (list nil defn)))
binds-char-table)
(let ((esc-defn (lookup-key input-keymap [27])))
(when esc-defn
(when (pkb-include-mk-p 27)
(set-char-table-range binds-char-table 27 (list nil esc-defn)))
(when (keymapp esc-defn)
(map-keymap
(lambda (event defn)
(if (not (consp event))
(when (and (integerp event)
(not (memq 'meta (event-modifiers event))))
(let ((meta-event
(event-convert-list (list 'meta event))))
(when (pkb-include-mk-p meta-event)
(pkb-int-add-event meta-event))))
(when (> (- (cdr event) (car event)) 128)
(error (concat "In pkb-list-keys - trying to add a"
" very large char-range in the ESC map: %s")
event))
(dolist (int-event
(number-sequence (car event) (cdr event)))
(let ((meta-event
(event-convert-list (list 'meta int-event))))
(when (pkb-include-mk-p meta-event)
(pkb-int-add-event meta-event))))))
esc-defn))))
(cons mks binds-char-table))
)
(defun pkb-int-add-event (event &optional key-defn)
"An internal function used by `pkb-list-keys'
Note: This function uses global variables MKS, INPUT-KEYMAP."
(unless (assoc event mks)
(unless key-defn
(setq key-defn (lookup-key input-keymap (vector event))))
(add-to-list 'mks (list event nil key-defn)))
)
(defun pkb-int-find-event-defn (key-list event)
"Search for the definition of EVENT in KEY-LIST (i.e. a cons cell
\(MKS . BINDS-CHAR-TABLE) ), returning (MK-OPTIONS BIND . BIND-OPTIONS) or
nil (if no binding for EVENT).
EVENT should be a single event, not a char-range."
(when (consp event)
(error "event %s should be not be a char-range" event))
(if (pkb-char-table-eventp event)
(char-table-range (cdr key-list) event)
(cdr (assoc event (car key-list))))
)
(defun pkb-categorize-key-list
(key-list max-mks-for-simple max-bks-for-compact
&optional translate-events-list)
"(Destructively) convert KEY-LIST into a format appropriate for output.
The format for KEY-LIST is the same as the output from
`pkb-list-keys', i.e. (MKS . BINDS-CHAR-TABLE).
If MAX-BKS-FOR-COMPACT < 0, this function will never return format (3)
\(i.e. it will behave as if MAX-BKS-FOR-COMPACT = infinity).
The output will be a list in one the following formats, covering the
different ways of printing differently sized keymap:
1) ('simple . MKS), if the number of mks < MAX-MKS-FOR-SIMPLE. MKS now
includes all events in BINDS-CHAR-TABLE;
2) ('compact . BKS-W-BINDS), if the number of bks <
MAX-BKS-FOR-COMPACT. BKS-W-BINDS has all events, including those
previously in BINDS-CHAR-TABLE.
3) ('full BKS-W-BINDS . BINDS-CHAR-TABLE), otherwise. An event from
BINDS-CHAR-TABLE whose basic-type was originally in MKS will now be
only in BKS-W-BINDS (events whose basic-type was not originally in
MKS will still only be in BINDS-CHAR-TABLE).
4) nil, if KEY-LIST has no binds.
TRANSLATE-EVENTS-LIST is passed to `pkb-transl-events', `pkb-transl-simp'"
(let* ((mks (car key-list)) (binds-char-table (cdr key-list))
(mks-tally (length mks)) tent-mks)
(catch 'outer-quit
(catch 'quit
(when (> mks-tally max-mks-for-simple)
(throw 'quit nil))
(map-char-table
(lambda (event defn)
(setq mks-tally (1+ mks-tally))
(when (> mks-tally max-mks-for-simple)
(throw 'quit nil))
(add-to-list 'tent-mks (append (list (copy-tree event)) defn)))
binds-char-table)
(if tent-mks
(setcdr (last tent-mks) mks)
(setq tent-mks mks))
(setq tent-mks
(pkb-transl-simp tent-mks max-mks-for-simple
translate-events-list))
(unless (listp tent-mks)
(throw 'quit nil))
(if (equal (length tent-mks) 0)
(throw 'outer-quit nil)
(throw 'outer-quit (cons 'simple tent-mks))))
(let (bks-w-binds (bks-tally 0) tent-bks-w-binds)
(dolist (mk-w-bind mks)
(let* ((event (car mk-w-bind))
(bind-w-opt (nthcdr 2 mk-w-bind))
(mods (event-modifiers event))
(basic-type (event-basic-type event))
(one-bk-w-binds (assoc basic-type bks-w-binds)))
(if one-bk-w-binds
(setcdr (last one-bk-w-binds) (list (cons mods bind-w-opt)))
(setq one-bk-w-binds (list basic-type nil (cons mods bind-w-opt)))
(when (integerp basic-type)
(setq mods-to-check
(cond
((and (>= basic-type 97) (<= basic-type 122))
'(nil control shift))
((or (= basic-type 64)
(and (>= basic-type 91) (<= basic-type 95)))
'(nil control))
((and (>= basic-type 0) (<= basic-type (max-char)))
'(nil))
(t nil)))
(dolist (one-mod mods-to-check)
(let ((mod-event
(if (null mods-to-check)
basic-type
(event-convert-list (list one-mod basic-type)))))
(when (char-table-range binds-char-table mod-event)
(setcdr (last one-bk-w-binds)
(list
(append
(list (when one-mod (list one-mod)))
(cdr
(char-table-range binds-char-table mod-event)))))
(set-char-table-range binds-char-table mod-event nil)))))
(add-to-list 'bks-w-binds one-bk-w-binds)
(setq bks-tally (1+ bks-tally)))))
(setq bks-tally (+ bks-tally
(pkb-transl-events 'bks-w-binds binds-char-table
translate-events-list)))
(catch 'quit
(when (and (> bks-tally max-bks-for-compact) (>= max-bks-for-compact 0))
(throw 'quit nil))
(map-char-table
(lambda (event defn)
(setq defn (cdr defn))
(let (asscn)
(cond
((consp event)
(add-to-list 'tent-bks-w-binds
(list (copy-tree event) nil
(cons nil defn)))
(setq bks-tally (1+ bks-tally)))
((and (>= event 64) (<= event 122) (/= event 96)
(setq asscn (assoc (event-basic-type event) tent-bks-w-binds)))
(setcdr (last asscn)
(list (cons (event-modifiers event) defn))))
(t
(add-to-list 'tent-bks-w-binds
(list (event-basic-type event) nil
(cons (event-modifiers event) defn)))
(setq bks-tally (1+ bks-tally)))))
(when (and (> bks-tally max-bks-for-compact)
(>= max-bks-for-compact 0))
(throw 'quit nil)))
binds-char-table)
(if bks-w-binds
(progn
(setcdr (last tent-bks-w-binds) bks-w-binds)
(setq bks-w-binds tent-bks-w-binds))
(setq bks-w-binds tent-bks-w-binds))
(throw 'outer-quit (cons 'compact bks-w-binds)))
(append (list 'full) (cons bks-w-binds binds-char-table)))))
)
(defun pkb-transl-events
(bks-w-binds-symb binds-char-table
&optional translate-events-list do-not-keep-esc-in-lbr do-not-transl-lbr-to-esc)
"Translate events (i.e. move or copy bindings) in BKS-W-BINDS-SYMB (passed
as a symbol) and BINDS-CHAR-TABLE, both of which may be altered. The returned value is the net change in the length of BKS-W-BINDS-SYMB.
Unless DO-NOT-TRANSL-LBR-TO-ESC is non-nil, this function will copy events
of C-[ = 27 to 'escape, since that is how they are interpreted. If
DO-NOT-KEEP-ESC-IN-LBR is non-nil, such events will be moved instead of
copied (the latter option is ignored if the former option is non-nil).
TRANSLATE-EVENTS-LIST allows certain events to be copied to other events
\(e.g. delete, M-delete is usually translated to C-d, M-DEL, respectively,
so it makes sense to copy the bindings). It is a list of elements (EVENT
COPY-LIST DELETE-ORIG-FL). EVENT is the event to translate and COPY-LIST is
a list of the events to copy the binding to. If DELETE-ORIG-FL is non-nil
then the original event is deleted."
(let ((change-in-bks-length 0))
(unless do-not-transl-lbr-to-esc
(let ((escape-bk-w-binds (list 'escape nil))
(lbrack-bk-w-binds (assoc ?\[ (symbol-value bks-w-binds-symb))))
(when lbrack-bk-w-binds
(dolist (mods-type-w-bind (nthcdr 2 lbrack-bk-w-binds))
(when (memq 'control (car mods-type-w-bind))
(add-to-list
'escape-bk-w-binds
(cons
(event-modifiers
(event-convert-list
(append (delq 'control (car mods-type-w-bind))
(list 'escape))))
(cdr mods-type-w-bind))
t)
(when do-not-keep-esc-in-lbr
(delq mods-type-w-bind lbrack-bk-w-binds))))
(when (<= (length lbrack-bk-w-binds) 2)
(set bks-w-binds-symb (delq lbrack-bk-w-binds
(symbol-value bks-w-binds-symb)))
(setq change-in-bks-length (1- change-in-bks-length))))
(when (char-table-range binds-char-table 27)
(setcdr (last escape-bk-w-binds)
(list
(cons nil (cdr (char-table-range binds-char-table 27)))))
(when do-not-keep-esc-in-lbr
(set-char-table-range binds-char-table 27 nil)))
(when (> (length escape-bk-w-binds) 2)
(add-to-list bks-w-binds-symb escape-bk-w-binds)
(setq change-in-bks-length (1+ change-in-bks-length)))))
(dolist (translate-event translate-events-list)
(let* ((event (car translate-event))
(mods (event-modifiers event))
(basic-type (event-basic-type event))
defn asscn mods-type-w-bind)
(when (and (pkb-char-table-eventp event)
(char-table-range binds-char-table event))
(setq defn (cdr (char-table-range binds-char-table event)))
(when (nth 2 translate-event)
(set-char-table-range binds-char-table event nil)))
(unless defn
(setq asscn (assoc basic-type (symbol-value bks-w-binds-symb)))
(setq mods-type-w-bind (assoc mods (nthcdr 2 asscn)))
(when mods-type-w-bind
(setq defn (cdr mods-type-w-bind))
(when (nth 2 translate-event)
(if (<= (length asscn) 3)
(progn
(set bks-w-binds-symb
(delq asscn (symbol-value bks-w-binds-symb)))
(setq change-in-bks-length (1- change-in-bks-length)))
(delq mods-type-w-bind asscn)))))
(when defn
(dolist (target-event (nth 1 translate-event))
(setq mods (event-modifiers target-event))
(setq basic-type (event-basic-type target-event))
(setq asscn (assoc basic-type (symbol-value bks-w-binds-symb)))
(if asscn
(if (assoc mods (nthcdr 2 asscn))
(error
"Attempt to translate to event %s, which has a definition"
target-event)
(setcdr (last asscn) (list (cons mods defn))))
(if (pkb-char-table-eventp target-event)
(if (char-table-range binds-char-table target-event)
(error (concat "Attempt to translate to event %s, "
"which already has a definition")
target-event)
(set-char-table-range binds-char-table target-event defn))
(add-to-list bks-w-binds-symb
(list basic-type nil (cons mods defn)))
(setq change-in-bks-length (1+ change-in-bks-length))))))))
change-in-bks-length)
)
(defun pkb-transl-simp
(mks max-mks-for-simple
&optional translate-events-list do-not-keep-esc-in-lbr
do-not-transl-lbr-to-esc)
"Translate events (i.e. move or copy bindings) in MKS, as long as the
resulting number of mks is less than MAX-MKS-FOR-SIMPLE. In the latter case, an updated mks list is returned (and MKS may be altered); otherwise, 0 is returned.
The optional arguments are as in `pkb-transl-events'"
(let (tent-mks tent-dels (mks-tally (length mks)))
(catch 'quit
(dolist (mk-w-bind mks)
(let* ((mods-type (event-modifiers (car mk-w-bind)))
(basic-type (event-basic-type (car mk-w-bind))))
(unless do-not-transl-lbr-to-esc
(when (and (equal basic-type ?\[) (memq 'control mods-type))
(if do-not-keep-esc-in-lbr
(add-to-list 'tent-dels mk-w-bind)
(setq mks-tally (1+ mks-tally)))
(add-to-list
'tent-mks
(append (list (event-convert-list
(append (delq 'control mods-type) '(escape)))
nil)
(nthcdr 2 mk-w-bind)))))
(let ((asscn (assoc (car mk-w-bind) translate-events-list)))
(when asscn
(when (nth 2 asscn)
(add-to-list 'tent-dels mk-w-bind)
(setq mks-tally (1- mks-tally)))
(dolist (target-mk (nth 1 asscn))
(setq mks-tally (1+ mks-tally))
(add-to-list 'tent-mks
(append (list target-mk nil)
(nthcdr 2 mk-w-bind))))))
(when (> mks-tally max-mks-for-simple)
(throw 'quit 0))))
(dolist (mk-to-del tent-dels)
(setq mks (delq mk-to-del mks)))
(if tent-mks
(setcdr (last tent-mks) mks)
(setq tent-mks mks))
tent-mks))
)
(defun pkb-split-full-to-groups
(key-list key-groups &optional percent-for-full-gr)
"Split a full prefix-key, as given by KEY-LIST, into groups given by
KEY-GROUPS. Note that KEY-LIST will be modified.
Unless overridden by a group-specific setting, a group is given as a full-gr
\(i.e. printed with all base-keys, even those without bindings) if at least
PERCENT-FOR-FULL-GR percent of base-keys in the group have
bindings. PERCENT-FOR-FULL-GR defaults to 70%.
The format for KEY-LIST is the same as the cdr of the output from
`pkb-categorize-key-list' for a full keymap, i.e. a cons of the form
\(BKS-W-BINDS . BINDS-CHAR-TABLE). Note that the elements of KEY-LIST may be
modified by this command.
KEY-GROUPS is a list of the key-groups for a full keymap. A key-group is a
list of the form
( (group-name &optional NUM-FOR-FULL-GR OPTIONS)
BKS-IN-ONE-BLOCK-1 ... BKS-IN-ONE-BLOCK-k),
where BKS-IN-ONE-BLOCK-i is a list of the form (BK-1 ... BK-n), i.e. a list
of the bks expected for ONE-BLOCK-i. NUM-FOR-FULL-GR gives the number of
base-keys that need to be defined for the group to be printed as a full-gr;
NUM-FOR-FULL-GR can be omitted, whereby PERCENT-FOR-FULL-GR is used
instead. OPTIONS is intended for additional group-specific options to be
specified.
The output will be
\(BKS-W-BINDS-USED REMAINING-BKS-W-BINDS . GROUPS).
BKS-W-BINDS-USED is a list of all the BKS-W-BINDS in the groups, each one
contained exactly once (so that they can converted for
output). REMAINING-BKS-W-BINDS will hold all bindings not listed in
GROUPS. Note that the BKS-W-BINDS in REMAINING-BKS-W-BINDS are not also in
BKS-W-BINDS-USED.
GROUPS is a list of ONE-GROUP's, each of which is in one of two formats:
1) ('full-gr (GROUP-NAME OPTIONS) . BLOCKS-PRELIM).
2) ('compact-gr (GROUP-NAME OPTIONS) . BKS-W-BINDS)."
(let* (groups
(bks-w-binds (car key-list))
(binds-char-table (cdr key-list))
new-one-bk-w-binds-from-chars
(remaining-from-bks-w-binds (copy-sequence bks-w-binds))
bks-w-no-binds)
(unless percent-for-full-gr (setq percent-for-full-gr 0.7))
(dolist (one-key-group key-groups)
(let (blocks-prelim bks-w-binds-for-compact-gr
(bks-total-tally 0) (bks-included-tally 0)
num-for-full-gr bks-w-no-binds-tent)
(dolist (bks-in-one-block (cdr one-key-group))
(let (one-block-prelim)
(dolist (bk bks-in-one-block)
(let (one-bk-w-binds)
(cond
((setq one-bk-w-binds (assoc bk bks-w-binds))
(setq remaining-from-bks-w-binds
(delq one-bk-w-binds remaining-from-bks-w-binds)))
((setq one-bk-w-binds (or (assoc bk new-one-bk-w-binds-from-chars)
(assoc bk bks-w-no-binds)
(assoc bk bks-w-no-binds-tent)))
nil)
(t
(setq one-bk-w-binds (list bk nil))
(when (pkb-char-table-eventp bk)
(when (or (consp bk) (event-modifiers bk))
(error "Key group base keys must be a single base key"
" (i.e. not a char-range and not a modified-key)"))
(when (char-table-range binds-char-table bk)
(add-to-list 'one-bk-w-binds
(append '(nil)
(cdr
(char-table-range binds-char-table bk)))
t 'ignore)
(set-char-table-range binds-char-table bk nil))
(when (or (equal bk 64)
(and (>= bk 91) (<= bk 122) (/= bk 96)))
(let ((control-bk (event-convert-list (list 'control bk))))
(when (char-table-range binds-char-table control-bk)
(add-to-list 'one-bk-w-binds
(append '((control))
(cdr
(char-table-range binds-char-table control-bk)))
t 'ignore)
(set-char-table-range binds-char-table control-bk nil)))
(when (and (integerp bk) (>= bk 97) (<= bk 122))
(let ((shift-bk (- bk 32)))
(when (char-table-range binds-char-table shift-bk)
(add-to-list 'one-bk-w-binds
(append '((shift))
(cdr
(char-table-range binds-char-table shift-bk)))
t 'ignore)
(set-char-table-range binds-char-table shift-bk nil))))))
(if (nth 2 one-bk-w-binds)
(add-to-list 'new-one-bk-w-binds-from-chars one-bk-w-binds)
(add-to-list 'bks-w-no-binds-tent one-bk-w-binds))))
(add-to-list 'one-block-prelim one-bk-w-binds t 'ignore)
(when (nth 2 one-bk-w-binds)
(setq bks-included-tally (1+ bks-included-tally))
(add-to-list 'bks-w-binds-for-compact-gr one-bk-w-binds t 'ignore))
(setq bks-total-tally (1+ bks-total-tally))))
(add-to-list 'blocks-prelim one-block-prelim t 'ignore)))
(setq num-for-full-gr
(cond ((nth 1 (car one-key-group)))
(t (fceiling (* percent-for-full-gr bks-total-tally)))))
(let* ((key-group-header (car one-key-group))
(new-group-header (cons (car key-group-header)
(nthcdr 2 key-group-header))))
(cond
((>= bks-included-tally num-for-full-gr)
(dolist (one-bk-w-no-binds bks-w-no-binds-tent)
(add-to-list 'bks-w-no-binds one-bk-w-no-binds nil 'eq))
(add-to-list 'groups
(append (list 'full-gr new-group-header) blocks-prelim)
t 'ignore))
((> bks-included-tally 0)
(add-to-list 'groups
(append (list 'compact-gr new-group-header)
bks-w-binds-for-compact-gr)
t 'ignore))))))
(dolist (unused-entry remaining-from-bks-w-binds)
(setq bks-w-binds (delq unused-entry bks-w-binds)))
(setq bks-w-binds
(append bks-w-binds new-one-bk-w-binds-from-chars bks-w-no-binds))
(map-char-table
(lambda (event defn)
(if (consp event)
(add-to-list 'remaining-from-bks-w-binds
(list (copy-tree event) (car defn)
(cons nil (cdr defn)))
t 'ignore)
(let* ((mods-type (event-modifiers event))
(basic-type (event-basic-type event))
(one-bk-w-binds (assoc basic-type remaining-from-bks-w-binds)))
(if one-bk-w-binds
(add-to-list 'one-bk-w-binds (cons mods-type (cdr defn))
t 'ignore)
(add-to-list 'remaining-from-bks-w-binds
(list basic-type nil (cons mods-type (cdr defn)))
t 'ignore)))))
binds-char-table)
(append (list bks-w-binds remaining-from-bks-w-binds) groups))
)
(defun pkb-sort-pks-list (pks-list &optional combine-simple-fl)
"Destructively sort a PKS-LIST; also, if COMBINE-SIMPLE-FL, combine
consecutive simple sections.
A PKS-LIST is a list whose elements are given by the output of `pkb-key-list-to-output' and are one of three types (see definition of that function for more information):
1) (pk 'compact bks-w-binds)
2) (pk 'full bks-w-binds binds-char-table)
3) (pk 'simple mks).
If COMBINE-SIMPLE-FL, the sorted list that this command returns has the same
format except that elements of type 3 are replaced with:
3') (pks-simple-list 'simple-mixed mks) - a list of prefix-keys
PKS-SIMPLE-LIST and the list of modified-keys MKS for those prefix-keys."
(setq pks-list
(sort pks-list
(lambda (pk-for-output1 pk-for-output2)
(pkb-compare-key-sequences
(car pk-for-output1) (car pk-for-output2)))))
(when combine-simple-fl
(let (consec-simp (prev-cons nil) (cur-cons pks-list) cons-to-rep-list)
(when (eq (nth 1 (car pks-list)) 'simple)
(setq consec-simp (list (car cur-cons)))
(while (eq (nth 1 (car (setq cur-cons (cdr cur-cons)))) 'simple)
(add-to-list 'consec-simp (car cur-cons) t))
(setq pks-list (cons consec-simp cur-cons))
(setq cons-to-rep-list (list pks-list))
(setq prev-cons cur-cons)
(setq consec-simp nil))
(while cur-cons
(if (eq (nth 1 (car cur-cons)) 'simple)
(if consec-simp
(add-to-list 'consec-simp (car cur-cons) t)
(setq consec-simp (list (car cur-cons))))
(when consec-simp
(setcdr prev-cons (cons consec-simp cur-cons))
(add-to-list 'cons-to-rep-list (cdr prev-cons) t)
(setq consec-simp nil))
(setq prev-cons cur-cons))
(setq cur-cons (cdr cur-cons)))
(when consec-simp
(setcdr prev-cons (cons consec-simp nil))
(add-to-list 'cons-to-rep-list (cdr prev-cons) t))
(dolist (cons-to-rep cons-to-rep-list)
(let (simp-pks simp-kss)
(dolist (simp-entry (car cons-to-rep))
(add-to-list 'simp-pks (car simp-entry) t)
(dolist (one-mk (nth 2 simp-entry))
(add-to-list 'simp-kss
(cons
(vconcat (car simp-entry) (list (car one-mk)))
(cdr one-mk)) t)))
(setcar cons-to-rep (list simp-pks 'simple-mixed simp-kss))))))
pks-list
)
(defun pkb-bks-w-binds-to-blocks-prelim (bks-w-binds max-bks-per-row)
"Split the bks in BKS-W-BINDS into rows (of ONE-BLOCK-PRELIM) with
MAX-BKS-PER-ROW bks per row. This converts BKS-W-BINDS (possibly for a
compact prefix-key) into BLOCKS-PRELIM (i.e. the input format for
`pkb-process-blocks').
BKS-W-BINDS is a list of ONE-BK-W-BINDS, as explained in
`pkb-categorize-key-list'; the format for BLOCKS-PRELIM is a list of
ONE-BLOCK-PRELIM's, each of which is a list of ONE-BK-W-BINDS."
(let (blocks-prelim (count 0))
(dolist (one-bk-w-binds bks-w-binds)
(if (= 0 (mod count max-bks-per-row))
(add-to-list 'blocks-prelim (list one-bk-w-binds) t 'ignore)
(setcdr (last (car (last blocks-prelim))) (list one-bk-w-binds)))
(setq count (1+ count)))
blocks-prelim)
)
(defun pkb-process-blocks (blocks-prelim)
"Process BLOCKS-PRELIM into BLOCKS, ideal for printing tables.
See comments in header of this .el for descriptions of BLOCKS-PRELIM
and BLOCKS."
(let (blocks)
(dolist (one-block-prelim blocks-prelim)
(let (block-mods one-block)
(dolist (one-bk-w-binds one-block-prelim)
(dolist (mods-type-w-bind (nthcdr 2 one-bk-w-binds))
(unless (member (car mods-type-w-bind) block-mods)
(add-to-list 'block-mods (car mods-type-w-bind)))))
(setq block-mods (sort block-mods 'pkb-compare-modifier-lists))
(setq one-block (list (list 'bks)))
(dolist (mod block-mods)
(add-to-list 'one-block (list mod) t 'ignore))
(dolist (one-bk-w-binds one-block-prelim)
(let (
mods-type-w-bind)
(dolist (one-row one-block)
(if (eq (car one-row) 'bks)
(setcdr (last one-row) (list (cons (nth 0 one-bk-w-binds)
(nth 1 one-bk-w-binds))))
(setq mods-type-w-bind
(assoc (car one-row) (nthcdr 2 one-bk-w-binds)))
(setcdr (last one-row) (list (cdr mods-type-w-bind)))
))))
(add-to-list 'blocks one-block t 'ignore)))
blocks)
)
(defun pkb-update-options (options-list string-or-option-key)
"Return an updated options list after adding STRING-OR-OPTION-KEY to OPTIONS-LIST.
If STRING-OR-OPTION-KEY is a string, it is treated as the output string of
the object (equivalent to passing (outp-str . OUTPUT-STRING)); if it is a
cons cell, the cons is added to the options list. This function
appropriately deals with whether or not any options are already set; setting
a string overwrites a previous string."
(let (asscn)
(when (and (consp string-or-option-key)
(eq (car string-or-option-key) 'outp-str))
(setq string-or-option-key (cdr string-or-option-key)))
(if (and (stringp string-or-option-key)
(or (stringp options-list) (null options-list)))
(setq options-list string-or-option-key)
(when (stringp options-list)
(setq options-list (list (cons 'outp-str options-list))))
(when (stringp string-or-option-key)
(setq string-or-option-key (cons 'outp-str string-or-option-key)))
(setq asscn (assq (car string-or-option-key) options-list))
(if asscn
(setcdr asscn (cdr string-or-option-key))
(add-to-list 'options-list string-or-option-key))
options-list))
)
(defun pkb-key-sequence-location (key-sequence)
"Specify where the definition for KEY-SEQUENCE would be stored in a tree of
keymaps. Return (KEYMAP . EVENT), where KEYMAP is the keymap that would
contain the definition and EVENT is where in that keymap the definition
would be stored."
(let* ((last-idx (- (length key-sequence) 1))
(last-event (aref key-sequence last-idx))
(last-event-mods (event-modifiers last-event))
(but-last (substring key-sequence 0 -1))
last-event-no-meta)
(if (and (memq 'meta last-event-mods)
(pkb-char-table-eventp
(setq last-event-no-meta
(event-convert-list
(append (delq 'meta last-event-mods)
(list (event-basic-type last-event)))))))
(cons (vconcat but-last [27]) last-event-no-meta)
(cons but-last last-event))))