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