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