home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / cweb28.zip / examples / kspell.el < prev    next >
Lisp/Scheme  |  1992-07-13  |  10KB  |  224 lines
  1. ;; Alternative spelling enterface for Emacs, contributed by Don Knuth
  2. ;; (Uses the wordtest and extex programs, which are
  3. ;;  supplied as examples with the CWEB distribution,
  4. ;;  available by anonymous ftp from labrea.stanford.edu)
  5.  
  6. ;; Based in part on "spell.el" from GNU Emacs; redistributed under
  7. ;; the terms of the GNU General Public License; NO WARRANTY implied.
  8.  
  9. ;; To install this, using the default directories defined below,
  10. ;; install wordtest and extex in /usr/local/bin, then say
  11. ;; "ln /usr/local/bin/extex /usr/local/bin/excweb", then install
  12. ;; a suitable dictionary in /usr/local/lib/dict/words; one such
  13. ;; dictionary can be found in ~ftp/pub/dict/words at labrea.stanford.edu.
  14. ;; Also create an empty file called .words in your home directory.
  15. ;; Finally, add (load-library "kspell") to your .emacs file, or
  16. ;; include such a line in site-init.el if kspell is to be use by everybody.
  17. ;; If you get a message like "Checking spelling of buffer...not correct"
  18. ;; and nothing else, the probable cause is that the wordtest program
  19. ;; could not open /usr/local/lib/dict/words or ~/.words for reading.
  20.  
  21. (provide 'kspell)
  22.  
  23. (defvar wordtest-command "wordtest" ;; maybe "/usr/local/bin/wordtest" better?
  24.   "*Command to run the wordtest program; can include command-line options.")
  25.  
  26. ;; "wordtest [options] [dictionaries] <infile >outfile" outputs all
  27. ;; lines of infile that don't appear in the dictionaries. The options
  28. ;; can define arbitrary character code mappings of 8-bit characters.
  29. ;; The default mapping takes a-z into A-Z, otherwise is ASCII.
  30.  
  31. (defvar wordtest-filter "extex" ;; maybe "/usr/local/bin/extex" is better?
  32.   "*Command to run the filter needed by wordtest.")
  33. (make-variable-buffer-local 'wordtest-filter)
  34.  
  35. ;; The extex filter extracts words from its input and outputs them on
  36. ;; separate lines as required by wordtest. It removes TeX control
  37. ;; sequences except those used to make accents and special characters.
  38. ;; There's a companion filter excweb that also removes C code from CWEBs.
  39. (setq cweb-mode-hook '(lambda () (setq wordtest-filter "excweb")))
  40.  
  41. (defvar wordtest-system-dictionary "/usr/local/lib/dict/words"
  42.   "*Sorted dictionary containing all \"correct\" words,
  43. including all variant forms obtained by prefix and suffix transformations.")
  44. ;; The standard UNIX dictionary /usr/dict/words is NOT satisfactory.
  45.  
  46. (defvar wordtest-personal-dictionary "~/.words"
  47.   "*Default dictionary to supplement the words in the system dictionary.
  48. If nil, no supplementary dictionary will be used.
  49. This dictionary must be in alphabetic order as defined by wordtest.
  50. Inserting any word with the + option to kspell-region will sort the file.")
  51. (make-variable-buffer-local 'wordtest-personal-dictionary)
  52.  
  53. (defun set-personal-dictionary (filename)
  54.   "Defines the supplementary personal dictionary for kspell to use in the
  55. current buffer, overriding the default value of wordtest-personal-dictionary."
  56.   (interactive "FPersonal dictionary file name: ")
  57.   (setq wordtest-personal-dictionary filename))
  58.  
  59. (defun unset-personal-dictionary ()
  60.   "Tells kspell not to use personal spelling dictionary with current buffer."
  61.   (interactive)
  62.   (setq wordtest-personal-dictionary nil))
  63.  
  64. (defun insert-into-personal-dictionary (word)
  65.   "Put WORD into user's dictionary and sort that dictionary."
  66.   (interactive "sword: ")
  67.   (let ((xword (concat word "\n")))
  68.     (if (null wordtest-personal-dictionary)
  69.         (setq wordtest-personal-dictionary
  70.               (read-string "Personal dictionary file name: " "~/.words")))
  71.     (set-buffer (find-file-noselect wordtest-personal-dictionary))
  72.     (goto-char (point-min))
  73.     (insert xword)
  74.     (call-process-region (point-min) (point-max) shell-file-name
  75.                          t t nil "-c" wordtest-command)
  76.     (search-backward xword (point-min) 1) ;; in case the user is watching
  77.     (while (not (bolp)) (search-backward xword (point-min) 1))
  78.     (save-buffer)))
  79.     
  80. (defun kspell-buffer ()
  81.   "Check spelling of every word in the buffer.
  82. For each incorrect word, you are asked for the correct spelling
  83. and then put into a query-replace to fix some or all occurrences.
  84.  
  85. If you do not want to change a word, just give the same word
  86. as its \"incorrect\" spelling; then the query replace is skipped.
  87. Words are given in lowercase, but they will be Capitalized when
  88. replacing Capitalized words, ALL_CAPS when replacing ALL_CAPS words.
  89. If you type ? after a replacement, your correction will first be
  90. looked up in the dictionary, and the query-replace will occur
  91. only if the replacement is found. If you type + after a replacement,
  92. your replacement will be inserted into the current personal dictionary.
  93.  
  94. You can leave the minibuffer to do some other editing and then come
  95. back again to the query-replace loop by typing \\[other-window]."
  96.   (interactive)
  97.   (save-excursion (kspell-region (point-min) (point-max) "buffer")))
  98.  
  99. (defun kspell-word ()
  100.   "Check spelling of the word at or before point.
  101. If it is not correct, ask user for the correct spelling and
  102. query-replace the entire buffer to substitute it as with kspell-buffer."
  103.   (interactive)
  104.   (let (beg end wordtest-filter)
  105.     (save-excursion
  106.      (if (not (looking-at "\\<"))
  107.          (forward-word -1))
  108.      (setq beg (point))
  109.      (forward-word 1)
  110.      (setq end (point))
  111.      (kspell-region beg end (buffer-substring beg end)))))
  112.  
  113. (defun kspell-region (start end &optional description)
  114.   "Like kspell-buffer but checks only words in the current region.
  115. Used in a program, applies from START to END.
  116. DESCRIPTION is an optional string naming the unit being checked:
  117. for example, \"buffer\"."
  118.   (interactive "r")
  119.   (let (correct
  120.         (filter wordtest-filter)
  121.         (buf (get-buffer-create " *kspell*")) ;; hidden by list-buffers
  122.         (dicts wordtest-system-dictionary))
  123.     (if wordtest-personal-dictionary
  124.         (setq dicts (concat dicts " " wordtest-personal-dictionary)))        
  125.     (save-excursion
  126.       (save-excursion
  127.         (set-buffer buf)
  128.         (widen)
  129.         (erase-buffer))
  130.       (message "Checking spelling of %s..." (or description "region"))
  131.       (if (and (null filter)
  132.                (< end (point-max))
  133.                (= ?\n (char-after end)))
  134.           (call-process-region start (1+ end) shell-file-name
  135.                                nil buf nil "-c"
  136.                                (concat wordtest-command " " dicts))
  137.         (let ((oldbuf (current-buffer)))
  138.           (save-excursion
  139.             (set-buffer buf)
  140.             (insert-buffer-substring oldbuf start end)
  141.             (or (bolp) (insert ?\n))
  142.             (if filter
  143.                 (call-process-region (point-min) (point-max) shell-file-name
  144.                                      t t nil "-c" filter))
  145.             (call-process-region (point-min) (point-max) shell-file-name
  146.                                  t t nil "-c"
  147.                                  (concat wordtest-command " " dicts)))))
  148.       (setq correct (save-excursion (set-buffer buf) (= (buffer-size) 0)))
  149.       (message "Checking spelling of %s...%scorrect"
  150.                (or description "region")
  151.                (if correct "" "not "))
  152.       (if correct t
  153.         (let (word newword qtext lastchar
  154.                    (case-fold-search t)
  155.                    (case-replace t))
  156.           (while (save-excursion
  157.                    (set-buffer buf)
  158.                    (> (buffer-size) 0))
  159.             (save-excursion
  160.               (set-buffer buf)
  161.               (goto-char (point-min))
  162.               (setq word (downcase
  163.                           (buffer-substring (point)
  164.                                             (progn (end-of-line) (point)))))
  165.               (forward-char 1) ;; pass the newline
  166.               (delete-region (point-min) (point))
  167.               (setq qtext (concat "\\b" (regexp-quote word) "\\b")))
  168.             (goto-char (point-min))
  169.             (setq lastchar nil)
  170.             (if (re-search-forward qtext nil t)
  171.                 (while (null lastchar)
  172.                   (setq newword
  173.                         (read-string
  174.                          (concat "edit a replacement for `" word "': ")
  175.                          word))
  176.                   (if (null newword) (setq lastchar 0)
  177.                     (setq lastchar (string-to-char (substring newword -1)))
  178.                     (if (memq lastchar '(?? ?+))
  179.                         (setq newword (substring newword 0 -1))))
  180.                   (cond ((= lastchar ??)
  181.                          (cond ((or (string= word newword) (string= "" newword))
  182.                                 (describe-function 'kspell-buffer)
  183.                                 (setq lastchar nil))
  184.                                ((not (kspelt-right newword))
  185.                                 (setq lastchar nil))))
  186.                         ((= lastchar ?+)
  187.                          (save-excursion
  188.                            (insert-into-personal-dictionary newword))))
  189.                   (cond ((string= word newword))
  190.                         ((null lastchar))
  191.                         (t
  192.                          (goto-char (point-min))
  193.                          (if (or (equal word newword) (null lastchar)) t
  194.                            (query-replace-regexp qtext newword))))))))))))
  195.  
  196. (defun kspelt-right (word)
  197.   "T if WORD is in the system dictionary or user's personal dictionary."
  198.   (let ((buf (get-buffer-create " *temp*"))
  199.         (pdict wordtest-personal-dictionary))
  200.     (message "Checking spelling of %s..." word)
  201.     (save-excursion
  202.      (set-buffer buf)
  203.      (widen)
  204.      (erase-buffer)
  205.      (insert word "\n")
  206.      (if pdict
  207.          (call-process-region (point-min) (point-max) shell-file-name
  208.                               t t nil "-c"
  209.                               (concat wordtest-command " "
  210.                                       wordtest-system-dictionary " "
  211.                                       pdict))
  212.        (call-process-region (point-min) (point-max) shell-file-name
  213.                             t t nil "-c"
  214.                             (concat wordtest-command " "
  215.                                     wordtest-system-dictionary)))
  216.      (= 0 (buffer-size)))))
  217.  
  218. (defun kspell-string (string)
  219.   "Check spelling of string supplied as argument."
  220.   (interactive "sSpell string: ")
  221.   (message "%s is %scorrect" string
  222.            (if (kspelt-right string) "" "in")))
  223.  
  224.