home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / 1char.el next >
Encoding:
Text File  |  1993-06-15  |  17.9 KB  |  555 lines
  1. ;; 1char.el -- commands to fix typos in the previous word with minimal typing.
  2. ;; Copyright (C) Bard Bloom, July 1989; revised July 1990.
  3.  
  4. ;; This file is not yet part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21. ;; Changes since 7/89:
  22. ;;
  23. ;; Commands to undo the last 1char command, and redo it in a different place.
  24. ;; Case toggle 1char
  25. ;; Delete from point through 1char.
  26. ;;
  27.  
  28. ;; Summary:
  29. ;; This is a bunch of commands to make minor changes in recently-typed 
  30. ;; text.  It's intended for fast but inaccurate typists, like me.
  31. ;; 
  32. ;; There's nothing you couldn't do by moving back, typing a character
  33. ;; or three, and moving forward --- but it does save a bunch of keystrokes.
  34. ;; Might improve your typing speed by a word or two per day, even.
  35. ;;
  36. ;; I put the commands under c-h because they really want to be on 
  37. ;; two-key commands you can type without moving your fingers from
  38. ;; the keyboard.
  39. ;;
  40. ;; Positions in the previous word are specified by a short sequence of 
  41. ;; characters, called a 1char.
  42. ;; If it's a letter, then it refers to the last occurrance of that letter
  43. ;; in the word:   pepper  
  44. ;;                   ^    p means this p
  45. ;;                    ^   e means this e
  46. ;;
  47. ;; Most other characters behave the same way.  The main exceptions are (now):
  48. ;;
  49. ;;   
  50. ;;   = and c-q: quotes the next character, so that it is taken literally (i.e., acts
  51. ;;        like a letter). This is most useful for digits, -, and =.
  52. ;;   -: negates the number you are about to type. Negative numbers go forwards rather 
  53. ;;        than backwards.  0 is treated as 1, unless 1char guesses that you really 
  54. ;;        wanted -1.  
  55. ;;   digits: Digits ask you for another character.  `1 c' goes to the first 
  56. ;;        previous occurrance of c (just like c itself).  `2 c' goes to the one
  57. ;;        before that, and so on.
  58. ;;
  59. ;;        pepper
  60. ;;           ^   1 p
  61. ;;          ^    2 p
  62. ;;        ^      3 p
  63. ;;
  64. ;; Lots of these commands take a prefix argument telling how many words back
  65. ;; to go.  Furthermore, if the previous word isn't at least 18 (or whatever
  66. ;; value 1char-min-distance has) chars long, you get to work on the previous
  67. ;; 18 (or whatever) characters.
  68. ;;
  69. ;; Commands:
  70. ;;   c-h c-t: transpose the 1char with the previous character  (P)
  71. ;;   c-h c-d: delete the 1char                                 (P)
  72. ;;   c-h c-i: insert a character before the 1char              (P)
  73. ;;   c-h c-a: insert a character after the 1char               (P)
  74. ;;   c-h c-c: change the 1char to another character            (P)
  75. ;;   c-h c-b: break the word before the 1char.  "ofthe" and t  --> "of the"
  76. ;;   c-h c-m: put the cursor on the 1char.                     (P)
  77. ;;   c-h c-u: undo (without moving point)
  78. ;;   c-h c-l: recenter screen so that this paragraph is on top.
  79. ;;   c-h c-j: join the previous two words.
  80. ;;   c-h ~  : toggle the case of the 1char.                    (P)
  81. ;;   c-h c-x: undo
  82. ;;
  83. ;;   c-h c-k c-d: delete text from point to 1char              (P)
  84. ;;   c-h c-k c-k: delete forward from point to 1char           (P)
  85. ;;                (like c-h c-k c-d but the 1char is interpreted negatively)
  86.  
  87. ;; It's easy to get the wrong occurrance of a letter.  There are commands which undo
  88. ;; the last 1char command you typed and redo it one 1char to the left or right.
  89. ;; So, if the buffer had
  90. ;;
  91. ;; eggplant is extremely toxic
  92. ;;                       #
  93. ;; and you wanted to capitalize the e in `extremely' with c-h ~ 2 e, you'd get
  94. ;;
  95. ;; eggplant is extrEmely toxic
  96. ;;                       #
  97. ;;
  98. ;; which is wrong.  You could fix it with c-h c-n, getting
  99. ;;
  100. ;; eggplant is Extremely toxic
  101. ;;                       #
  102.  
  103. ;; The commands marked (P) take a prefix argument telling how many words
  104. ;; back to go.  
  105. ;;
  106. ;; abbreviations:
  107. ;; if the variable 1char-expands-abbrevs is set to true
  108. ;; then all these commands try to expand the word(s) they 
  109. ;; make as abbrevs.  i have a bunch of abbrevs for my common
  110. ;; typos --- `fo' is an abbrev for `of' --- so 
  111. ;; typing `fothe', c-h c-b t will result in `of the' which is 
  112. ;; probably what i intended.
  113.  
  114.  
  115. ;; buggigestions to bard@cs.cornell.edu
  116.  
  117. (require 'cl)
  118.  
  119. (unless (fboundp 'f:l)
  120.   (defmacro f:l (x &rest y)
  121.     "(function (lambda X) Y).  Abbreviation taken from some obscure dialect
  122. of Lisp, but I remembered it seven years after I read the manual, so it
  123. can't be all that obscure, can it?"
  124.     (list 'function
  125.           (append (list 'lambda x ) y))))
  126.  
  127. (unless (fboundp 'point-after)
  128.   (defmacro point-after (&rest commands)
  129.   "returns the value of point after executing the commands.  doesn't move
  130. point.  (expands to (save-excursion commands (point)))."
  131.   (` (save-excursion
  132.        (,@ commands)
  133.        point))))
  134.  
  135. (defun recenter-top-para ()
  136.   "put the top of this paragraph on the top of the screen.  don't move point."
  137.   (interactive)
  138.   (save-excursion
  139.     (backward-paragraph 1)
  140.     (next-line 1)
  141.     (recenter 0)
  142.     ))
  143.  
  144. (defvar 1char-expands-abbrevs t
  145.   "if true, then the various 1char functions expand abbrevs everywhere
  146. appropriate.")
  147. (make-variable-buffer-local '1char-expands-abbrevs)
  148.  
  149.  
  150. (defun join-words (p)
  151.   "join two previous words. expands them as an abbrev if 
  152. 1char-expands-abbrevs is true. "
  153.   (interactive "p")
  154.   (save-excursion
  155.     (backward-word (1- p))
  156.     (backward-word 1)
  157.     (setq 1char-marker (point-marker))
  158.     (setq 1char-undoer (f:l () (goto-char 1char-marker) (insert " ")))
  159.     (setq 1char-last-prefix-arg p)
  160.     (setq 1char-last-called-function (f:l (p oc) (join-words p)))
  161.     (delete-horizontal-space)
  162.     (forward-word 1)
  163.     (if 1char-expands-abbrevs (expand-abbrev))))
  164.  
  165. (defvar 1char-at-end-of-word-internal nil
  166.   "don't change this.  true inside the about-the-previous-word
  167.  macro, intended to be false elsewhere.")
  168.  
  169. (defmacro about-the-previous-word (prefix &rest code)
  170.   (let ((p (gensym)))
  171.     (`
  172.      (let (((, p) (point-marker))
  173.            (1char-at-end-of-word-internal t)
  174.            )
  175.        ;; i don't know why save-excursion screws up
  176.        (save-restriction
  177.          (let ((a (point)))
  178.            (backward-word (prefix-numeric-value (, prefix)))
  179.            ;; We do want the side effects in the following progns:
  180.            (if (> (+ (point) 1char-min-distance) a)
  181.                (narrow-to-region (max (point-min) (- a 1char-min-distance))
  182.                                  (progn (forward-word 1) (point)))
  183.              (narrow-to-region (1- (point))
  184.                                (progn (forward-word 1) (point))))
  185.            (goto-char (point-max))
  186.            (,@ code)
  187.            cond
  188.            (1char-expands-abbrevs
  189.             (goto-char (point-max))
  190.             (expand-abbrev))
  191.            )
  192.          )
  193.        (goto-char (, p))))))
  194.  
  195. (defvar 1char-min-distance 80
  196.   "The `previous word' for 1chars extends at least this many characters back.")
  197.  
  198. ;; a 1char is now:
  199. ;; EXTERNALLY:
  200. ;;    - most chars: the first previous occurrance of that char.
  201. ;;    - digit N: get another char, C; give the N'th previous occurrance of C.
  202. ;;    - digit 0: read a number in the minibuffer
  203. ;;    - c-a (for future work): give a little minibuffer window to pick
  204. ;;      the place to work interactively.
  205. ;; INTERNALLY
  206. ;;    '(prev c n) -- c=char, n=count.  n<0 means go forward
  207.  
  208. (defun 1char-to-char (oc)
  209.   "Converts a 1char OC to a char c.  So, `3N' would convert to `N'."
  210.   (second oc))
  211.  
  212. (defun 1char-read (prompt)
  213.   (message prompt)
  214.   (let ((y "")
  215.         (x (read-char)))
  216.     (when (eq x ?-)
  217.       (setq y "-")
  218.       (setq x (read-char)))
  219.     (while (memq x '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
  220.       (setq y (concat y (char-to-string x)))
  221.       (message "%s -" y)
  222.       (setq x (read-char))
  223.       )
  224.     (cond
  225.      ((string= y "") (setq y 1))
  226.      ((string= y "-") (setq y -1))
  227.      (t (setq y (string-to-int y))))
  228.     (setq 1char-last-1char
  229.           (case x
  230.             (?\C-a 1char-last-1char)
  231.             ((?\C-q ?=)
  232.              (message "%s (c-q):")
  233.              (list 'prev (read-char) y))
  234.             (otherwise
  235.              (list 'prev x y))))
  236.     1char-last-1char))
  237.  
  238.  
  239. (defmacro 1char-excursion (p oc &rest code)
  240.   (let ((v (gensym)))
  241.     (`
  242.      (save-excursion
  243.        (1char-goto-internal p (, oc))
  244.        (,@ code)
  245.        ))))
  246.  
  247. (put '1char-excursion 'lisp-indent-hook 2)
  248.  
  249. (defun 1char-goto-internal (p oc)
  250.   "Go to the position given by the 1char OC.
  251. Takes a prefix arg to tell it how many words back to go."
  252.   (backward-word
  253.    (1- (prefix-numeric-value p)))
  254.   (let ((n 1)
  255.         (c nil)
  256.         )
  257.     (cond
  258.      ((eq (car oc) 'prev)
  259.       (setq c (cadr oc)
  260.             n (caddr oc))))
  261.     (when (= n 0)
  262.       (setq n 1))
  263.     (cond
  264.      ((null c)
  265.       (error "Internal representation of 1char is screwed up."))
  266.      ((and
  267.        (> n 0)
  268.        (search-backward (char-to-string c)
  269.                         (point-min)
  270.                         't
  271.                         n)))
  272.      ((and
  273.        (< n 0)
  274.        (search-forward (char-to-string c)
  275.                        (point-max)
  276.                        't
  277.                        (- n)))
  278.       (goto-char (match-beginning 0))
  279.       )
  280.      (t
  281.       (error "I can't find a %c." c)))))
  282.   
  283.  
  284. (defun 1char-goto (p oc)
  285.   (interactive
  286.    (list current-prefix-arg
  287.          (1char-read "Goto (1char):")))
  288.   (when (featurep 'positions)
  289.     (stack-save-current-pos))
  290.   (setq 1char-last-prefix-arg p
  291.         1char-goto-last-position (point-marker)
  292.         1char-last-1char oc
  293.         1char-undoer
  294.           (f:l () )
  295.         1char-last-called-function
  296.           (f:l (p oc) (goto-char 1char-goto-last-position) (1char-goto p oc)))
  297.   (1char-goto-internal p oc))
  298.  
  299.  
  300. (defun 1char-break-word (p oc)
  301.   "break the previous word just before a 1char-specified position.
  302. see the documentation of 1char-goto for details."
  303.   (interactive
  304.    (list
  305.     current-prefix-arg
  306.     (1char-read "Break before (1char):")))
  307.   (1char-excursion p oc
  308.     (setq 1char-marker (point-marker))
  309.     (insert-before-markers " ")
  310.     (backward-char 1)
  311.     (if 1char-expands-abbrevs (expand-abbrev))
  312.     (1char-maybe-expand-abbrevs)
  313.     )
  314.   (setq 1char-last-prefix-arg p
  315.         1char-last-1char oc
  316.         1char-undoer
  317.            (f:l ()
  318.              (delete-region (1- 1char-marker) 1char-marker ))
  319.         1char-last-called-function
  320.           (function 1char-break-word))
  321.   )
  322.  
  323. (defun 1char-maybe-expand-abbrevs ()
  324.   (when 1char-expands-abbrevs
  325.     (unless (looking-at "\\>") (forward-word 1))
  326.     (expand-abbrev)))
  327.  
  328. (defun 1char-transpose-chars (p oc)
  329.   "transpose the character given by a 1char-specified position 
  330. and the previous character."
  331.   (interactive
  332.    (list
  333.     current-prefix-arg
  334.     (1char-read "Twiddlebefore (1char):")))
  335.   (1char-excursion p oc
  336.     (transpose-chars nil)
  337.     (setq 1char-marker (point-marker))
  338.     (1char-maybe-expand-abbrevs)
  339.     )
  340.   (setq 1char-last-prefix-arg p
  341.         1char-last-1char oc
  342.         1char-undoer
  343.           (f:l ()
  344.             (goto-char (1- 1char-marker))
  345.             (transpose-chars nil))
  346.         1char-last-called-function (function 1char-transpose-chars))
  347.   )
  348.  
  349.  
  350. (defun 1char-change (p from to)
  351.   "change the character given by a 1char to another character."
  352.   (interactive
  353.    (list
  354.     current-prefix-arg
  355.     (1char-read "Change (1char): ")
  356.     (progn (message "To:") (read-char))))
  357.   (1char-excursion p from
  358.     (setq 1char-marker (point-marker))
  359.     (delete-char 1)
  360.     (insert to)
  361.     (1char-maybe-expand-abbrevs))
  362.   (setq 1char-last-prefix-arg p
  363.         1char-change-to to
  364.         1char-last-1char from
  365.         1char-change-from (1char-to-char from)
  366.         1char-undoer
  367.           (f:l ()
  368.             (save-excursion
  369.               (goto-char (1+ 1char-marker))
  370.               (backward-delete-char-untabify 1)
  371.               (insert 1char-change-from)))
  372.         1char-last-called-function
  373.         (f:l (p oc)
  374.              (1char-change p oc 1char-change-to)))
  375.   )
  376.  
  377.  
  378. (defun 1char-delete (p oc)
  379.   "delete the character given by a 1char."
  380.   (interactive
  381.    (list
  382.     current-prefix-arg
  383.     (1char-read "Delete (1char):")))
  384.   (1char-excursion p oc
  385.     (setq 1char-marker (point-marker))
  386.     (delete-char 1)
  387.     (1char-maybe-expand-abbrevs))
  388.   (setq 1char-last-prefix-arg p
  389.         1char-last-1char oc
  390.         1char-deleted-char (1char-to-char oc)
  391.         1char-undoer
  392.           (f:l () (save-excursion (goto-char 1char-marker) (insert 1char-deleted-char)))
  393.         1char-last-called-function (function 1char-delete))
  394.   )
  395.  
  396. (defun 1char-insert-before (p oc new)
  397.   "insert a character just before the 1char c.  new is the new
  398. character.  expands abbrevs according to 1char-expands-abbrevs."
  399.   (interactive
  400.    (list
  401.     current-prefix-arg
  402.     (1char-read "Insert before (1char): ")
  403.     (progn (message "Char:") (read-char))))
  404.   (1char-excursion p oc
  405.     (setq 1char-marker (point-marker))
  406.     (insert new)
  407.     (1char-maybe-expand-abbrevs))
  408.   (setq 1char-last-prefix-arg p
  409.         1char-insert-char new
  410.         1char-last-1char oc
  411.         1char-undoer
  412.           (f:l () (delete-region 1char-marker (1+ 1char-marker)))
  413.         1char-last-called-function
  414.           (f:l (p oc)
  415.                (1char-insert-before p oc 1char-insert-char)))
  416.   )
  417.  
  418. (defun 1char-insert-after (p oc new)
  419.   "insert a character just after the 1char c.  new is the new
  420. character.  expands abbrevs according to 1char-expands-abbrevs."
  421.   (interactive
  422.    (list
  423.     current-prefix-arg
  424.     (1char-read "Insert after (1char): ")
  425.     (progn (message "Char:") (read-char))))
  426.   (1char-excursion p oc
  427.     (forward-char 1)
  428.     (insert new)
  429.     (setq 1char-marker (point-marker))
  430.     (1char-maybe-expand-abbrevs))
  431.   (setq 1char-last-prefix-arg p
  432.         1char-insert-char new
  433.         1char-last-1char oc
  434.         1char-undoer
  435.           (f:l () (delete-region  (1- 1char-marker) 1char-marker))
  436.         1char-last-called-function
  437.           (f:l (p oc)
  438.                (1char-insert-after p oc 1char-insert-char))))
  439.  
  440. (defun 1char-one-further-out (n)
  441.   (interactive "p")
  442.   (1char-undo)
  443.   (funcall 1char-last-called-function 1char-last-prefix-arg
  444.            (1char-+ 1char-last-1char n))
  445.   )
  446.  
  447. (defun 1char-undo ()
  448.   (save-excursion
  449.     (if 1char-undoer
  450.         (funcall 1char-undoer)
  451.       (error "Sorry, maarster, but I don't know how to fix that.")
  452.       )))
  453.  
  454. (defun 1char-one-further-in (n)
  455.   (interactive "p")
  456.   (1char-one-further-out (- n)))
  457.  
  458. (defun 1char-+ (oc n)
  459.   "Return a 1char which is OC but N further out. If the thing comes out having 0 repitition,
  460. then make it (sgn N) -- on the ground that you're probably decrementing or incrementing
  461. and want it to go in some direction."
  462.   (case (car oc)
  463.     (prev (list 'prev (second oc)
  464.                 (let ((sum (+ n (third oc))))
  465.                   (cond
  466.                    ((not (zerop sum))
  467.                     sum)
  468.                    ((not (zerop (signum n)))
  469.                     (signum n))
  470.                    (t 1))
  471.                 )))
  472.     (t    (error "Doom: illegal 1char %s" (2str oc)))))
  473.       
  474. (defun 1char-negate (oc)
  475.   "Returns a 1char which is OC negated. (forward <-> backward)"
  476.   (case (car oc)
  477.     (prev (list 'prev (second oc) (-  (third oc))))
  478.     (t    (error "Doom: illegal 1char %s" (2str oc)))))
  479.  
  480.  
  481. (defun undo-without-moving ()
  482.   "undo one thing without moving point."
  483.   (interactive)
  484.   (let ((p (point-marker)))
  485.     (undo)
  486.     (goto-char p)))
  487.  
  488.  
  489. (defun 1char-delete-through-1char-backwards (p oc)
  490.   (interactive
  491.    (list current-prefix-arg
  492.          (1char-read "Delete backwards through (1char):")))
  493.   (kill-region (point)
  494.                (point-after (1char-goto-internal p oc)
  495.                             )))
  496.  
  497. (defun 1char-delete-through-1char-forwards (p oc)
  498.   (interactive
  499.    (list current-prefix-arg
  500.          (1char-read "Delete forwards through (1char):")))
  501.   (kill-region (point)
  502.                (point-after (1char-goto-internal p
  503.                                                  (1char-negate oc)))))
  504.  
  505.  
  506. (defun 1char-case-twiddle (p oc)
  507.   "Change the case of a character a ways back."
  508.   (interactive
  509.    (list current-prefix-arg
  510.          (1char-read "Case twiddle (1char):")))
  511.   (1char-excursion p oc
  512.      (let* ((c (string-to-char (buffer-substring (point) (1+ (point)))))
  513.             (C (logxor 32 c))
  514.             )
  515.        (setq 1char-case-twiddle-char c
  516.              1char-marker (point-marker))
  517.        (when (or (and (<= c ?Z) (>= c ?A))
  518.                  (and (<= c ?z) (>= c ?a)))
  519.          (delete-char 1)
  520.          (insert C))
  521.        (setq 1char-last-prefix-arg p
  522.              1char-last-1char oc
  523.              1char-undoer
  524.                (f:l ()
  525.                  (goto-char 1char-marker)
  526.                  (delete-char 1)
  527.                  (insert 1char-case-twiddle-char))
  528.              1char-last-called-function
  529.                (function 1char-case-twiddle)))))
  530.                  
  531.      
  532.      
  533. (global-set-key "\C-h\C-j" 'join-words)
  534. (global-set-key "\C-h\C-@" 'undo)
  535. (global-set-key "\C-h\C-u" 'undo-without-moving)
  536. (global-set-key "\C-h\C-l" 'recenter-top-para)
  537. (global-set-key "\C-h\C-t" '1char-transpose-chars)
  538. (global-set-key "\C-h\C-d" '1char-delete)
  539. (global-set-key "\C-h\C-a" '1char-insert-after)
  540. (global-set-key "\C-h\C-i" '1char-insert-before)
  541. (global-set-key "\C-h\C-c" '1char-change)
  542. (global-set-key "\C-h\C-b" '1char-break-word)
  543. (global-set-key "\C-h\C-m" '1char-goto)
  544. (global-set-key "\C-h<" '1char-one-further-out)
  545. (global-set-key "\C-h," '1char-one-further-out)
  546. (global-set-key "\C-h\C-n" '1char-one-further-out)
  547. (global-set-key "\C-h>" '1char-one-further-in)
  548. (global-set-key "\C-h." '1char-one-further-in)
  549. (global-set-key "\C-h\C-p" '1char-one-further-in)
  550. (global-set-key "\C-h\C-k\C-k" '1char-delete-through-1char-forwards)
  551. (global-set-key "\C-h\C-k\C-d" '1char-delete-through-1char-backwards)
  552. (global-set-key "\C-h~" '1char-case-twiddle)
  553.  
  554.  
  555.