src/.emacs.d/load/querty.el

   1 ;------------------------------------------------------------;
   2 ; qwerty.el
   3 ;
   4 ; For people who are used to more efficient keyboard layouts.
   5 ;
   6 ; version 1.1
   7 ;
   8 ; * Now includes `M-x dvorak' to switch to a Dvorak keyboard layout.
   9 ;
  10 ; Written by Neil Jerram <nj104_AT_cus.cam.ac.uk>,
  11 ; Monday 14 December 1992.
  12 ; Copyright (C) 1993 Neil Jerram.
  13
  14 ;;; This program is free software; you can redistribute it and/or modify
  15 ;;; it under the terms of the GNU General Public License as published by
  16 ;;; the Free Software Foundation; either version 1, or (at your option)
  17 ;;; any later version.
  18 ;;;
  19 ;;; This program is distributed in the hope that it will be useful,
  20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;;; GNU General Public License for more details.
  23 ;;;
  24 ;;; The GNU General Public License is available by anonymous ftp from
  25 ;;; prep.ai.mit.edu in pub/gnu/COPYING.  Alternately, you can write to
  26 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
  27 ;;; USA.
  28
  29 ; This trivial piece of Emacs Lisp was inspired by Stephen Jay Gould's
  30 ; essay "The Panda's Thumb of Technology" in his book "Bully for
  31 ; Brontosaurus".  In this essay, he explains how the intrinsically
  32 ; inefficient QWERTY keyboard layout (all the most common keys are in
  33 ; weak finger positions) is a hangover from the days when typists
  34 ; needed to be slowed down so that the (hidden) mechanics of the
  35 ; typewriter didn't get jammed.  Maybe if enough people come to use
  36 ; Emacs and realise the advantages of different keyboard layouts, the
  37 ; days of QWERTY could be numbered.
  38
  39 ; EXAMPLE: French keyboards often have A and Q swapped around
  40 ; (in comparison with English keyboards).  So a French person
  41 ; unused to the English layout (and vice-versa) could re-program
  42 ; his/her keyboard by typing `M-x anti-qwerty RET aq RET qa RET'.
  43
  44 ; I would be very interested to hear about alternative keyboard
  45 ; layouts that anyone may use, preferably with their definitions
  46 ; with respect to the usual QWERTY layout.
  47
  48 ; Public functions
  49
  50 (defun qwerty ()
  51
  52   "Qwerty keyboard layout."
  53
  54   (interactive)
  55   (setq keyboard-translate-table nil)
  56   (message "Default keyboard restored."))
  57
  58 (defun dvorak ()
  59
  60   "Dvorak keyboard layout:
  61 -------------------------------------------------------------------------
  62 | Esc| 1  | 2  | 3  | 4  | 5  | 6  | 7  | 8  | 9  | 0  | [  | ]  |  <-  |
  63 -------------------------------------------------------------------------
  64 | Tab | /  | ,  | .  | p  | y  | f  | g  | c  | r  | l  | ;  | =  |     |
  65 ------------------------------------------------------------------- |   |
  66 | Ctrl | a  | o  | e  | u  | i  | d  | h  | t  | n  | s  | -  |   <-    |
  67 -------------------------------------------------------------------------
  68 | Shift  | '  | q  | j  | k  | x  | b  | m  | w  | v  | z  | Shift |
  69 ---------------------------------------------------------------------
  70 "
  71   (interactive)
  72   (anti-qwerty "/,.pyfgcrl;=aoeuidhtns-'qjkxbmwvz?<>PYFGCRL:+AOEUIDHTNS_QJKXBMWVZ[]{}\""
  73                       "qwertyuiop[]asdfghjkl;'zxcvbnm,./QWERTYUIOP{}ASDFGHJKL:\"XCVBNM<>?-=_+Z"))
  74
  75 (defun anti-qwerty (old new &optional ctrl unsafe)
  76
  77   "Remaps the keyboard according to OLD and NEW strings.  OLD should
  78 include all the keys that the user wants to change, typed in the
  79 default keyboard system (usually qwerty).  NEW is what the user would
  80 like to be typing in order to produce the contents of OLD on the
  81 screen.
  82
  83   The third (optional prefix) argument CTRL, if non-nil, means that
  84 any transformations on letters that occur should be duplicated in the
  85 related control characters: in other words, if `a' becomes `z', then
  86 `C-a' should become `C-z'.
  87
  88   Before implementing any changes the function first checks that the
  89 mapping implied by OLD and NEW is one to one, in other words no two
  90 keyboard keys may map to the same character and a single keyboard key
  91 may not be given two different mappings.  If any such errors are
  92 discovered in the mapping, no changes to the keyboard are made.
  93
  94   As an additional safeguard, this function binds the keystroke `M-\'
  95 to the restoring function `qwerty'.  If the fourth (optional) argument
  96 UNSAFE is non-nil, this binding is suppressed."
  97
  98   (interactive "sQWERTY expression: \nsNew system expression: \nP")
  99   (let ((o-n-map (if (qwerty-translation-safe-p old new)
 100                           0
 101                       (sit-for 1)))
 102         (n-o-map (if (qwerty-translation-safe-p new old)
 103                           0
 104                       (sit-for 1)))
 105         llp)
 106     (if (and (numberp o-n-map)
 107                   (numberp n-o-map))
 108         (progn
 109             (setq llp (and (letters-to-letters-p old new)
 110                             (letters-to-letters-p new old)))
 111               (un-qwerty old new llp ctrl)
 112                 (or unsafe
 113                           (progn (global-set-key "\e\\" 'qwerty)
 114                                       (local-unset-key "\e\\"))
 115                                 t)
 116                   (message
 117                       (concat "Keyboard changed.  "
 118                                  (if unsafe
 119                                             "Type `M-x qwerty' to restore default."
 120                                         "Type `M-\\' or `M-x qwerty' to restore default."))))
 121       (error "! Expressions given are not a one to one mapping"))))
 122
 123 ; Private functions
 124
 125 (defun un-qwerty (old new llp ctrl)
 126   (let* ((the-table (make-string 128 0))
 127           (ml (min (length old)
 128                      (length new)))
 129            (old (substring old 0 ml))
 130             (new (substring new 0 ml))
 131              (i 0)
 132               co cn)
 133     (while (< i ml)
 134       (setq co (aref old i)
 135                 cn (aref new i))
 136       (if (and (< co 128) (< cn 128)); Reject Meta characters.
 137           (if (= (aref the-table cn) 0); No unnecessary repeats.
 138                     (progn
 139                       (if (not llp)
 140                               (aset the-table cn co)
 141                           (aset the-table (upcase cn) (upcase co))
 142                             (aset the-table (downcase cn) (downcase co)))
 143                       (setq co (- (upcase co) 64))
 144                       (if (or (not ctrl) (not llp) (< co 0) (> co 31))
 145                               nil
 146                           (aset the-table (- (upcase cn) 64) co)))))
 147       (setq i (1+ i)))
 148     (setq i 0)
 149     (while (< i 128)
 150       (if (= (aref the-table i) 0)
 151             (aset the-table i i))
 152       (setq i (1+ i)))
 153     (setq keyboard-translate-table the-table)))
 154
 155 (defun qwerty-translation-safe-p (old new)
 156   "Returns nil if the mapping from OLD to NEW is not one to one."
 157   (let* ((mapping-length (min (length old)
 158                                     (length new)))
 159           (old (substring old 0 mapping-length))
 160            (new (substring new 0 mapping-length))
 161             (i 0)
 162              (errors 0)
 163               (case-fold-search nil)
 164                j co cn match)
 165     (while (< i mapping-length)
 166       (setq co (aref old i)
 167                 cn (aref new i)
 168                     j (1+ i))
 169       (while (setq match
 170                       (string-match (regexp-quote (char-to-string co))
 171                                      (substring old j)))
 172         (if (/= cn (aref (substring new j) match))
 173                 (setq errors (1+ errors)))
 174         (setq j (+ j match 1)))
 175       (setq i (1+ i)))
 176     (if (= errors 0)
 177         t
 178       (message "\"%s\" -> \"%s\" : %d %s" old new errors
 179                       (if (> errors 1) "errors" "error"))
 180       nil)))
 181
 182 (defun letters-to-letters-p (old new)
 183   "Returns t if all letters in OLD are mapped to letters in NEW."
 184   (let* ((mapping-length (min (length old)
 185                                     (length new)))
 186           (old (substring old 0 mapping-length))
 187            (new (substring new 0 mapping-length))
 188             (i 0)
 189              (llp t)
 190               (case-fold-search nil)
 191                co cn)
 192     (while (< i mapping-length)
 193       (setq co (upcase (aref old i))
 194                 cn (upcase (aref new i))
 195                     j (1+ i))
 196       (and (>= co ?A)
 197               (<= co ?Z)
 198                  (or (< cn ?A)
 199                             (> cn ?Z))
 200                     (setq llp nil))
 201       (setq i (1+ i)))
 202     llp))
 203
 204 ;------------------------------------------------------------;