home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / packages / webster.el < prev    next >
Encoding:
Text File  |  1992-06-29  |  16.8 KB  |  506 lines
  1. ;; Copyright (C) 1989 Free Software Foundation
  2.  
  3. ;; This file is part of GNU Emacs.
  4.  
  5. ;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  7. ;; accepts responsibility to anyone for the consequences of using it
  8. ;; or for whether it serves any particular purpose or works at all,
  9. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  10. ;; License for full details.
  11.  
  12. ;; Everyone is granted permission to copy, modify and redistribute
  13. ;; GNU Emacs, but only under the conditions described in the
  14. ;; GNU Emacs General Public License.   A copy of this license is
  15. ;; supposed to have been given to you along with GNU Emacs so you
  16. ;; can know your rights and responsibilities.  It should be in a
  17. ;; file named COPYING.  Among other things, the copyright notice
  18. ;; and this notice must be preserved on all copies.
  19. ;;
  20. ;; Author Jason R. Glasgow (glasgow@cs.yale.edu)
  21. ;; Modified from telnet.el by William F. Schelter
  22. ;; But almost entirely different.
  23. ;;
  24. ;; Modified by Dirk Grunwald to maintain an open connection.
  25. ;;
  26. ;; 3/18/89 Ashwin Ram <Ram-Ashwin@yale.edu>
  27. ;; Added webster-mode.
  28. ;; Fixed documentation.
  29. ;;
  30. ;; 3/20/89 Dirk Grunwald <grunwald@flute.cs.uiuc.edu>
  31. ;; Merged Rams changes with new additions: smarter window placement,
  32. ;; correctly handles un-exposed webster windows, minor cleanups.
  33. ;; Also, ``webster-word'', akin to ``spell-word''.
  34. ;;
  35. ;; To use this, you might want to add this line to your .emacs file:
  36. ;;
  37. ;;  (autoload 'webster "webster" "look up a word in Webster's 7th edition" t)
  38. ;;
  39. ;; Then just hit M-x webster to look up a word.
  40. ;;
  41. ;; 3/21/89 Dave Sill <dsill@relay.nswc.navy.mil>
  42. ;; Removed webster-word and webster-define, adding default of current word to 
  43. ;; webster, webster-spell, and webster-endings instead.
  44. ;;
  45. ;; 1/21/91 Jamie Zawinski <jwz@lucid.com>
  46. ;; Added webster-reformat to produce better looking output.  Made it notice
  47. ;; references to other words in the definitions (all upper-case) and do
  48. ;; completion on them in the string read by meta-x webster.
  49. ;;
  50. ;; 9/14/91 Jamie Zawinski <jwz@lucid.com>
  51. ;; Improved the above.
  52. ;;
  53. ;; 4/15/92 Jamie Zawinski <jwz@lucid.com>
  54. ;; Improved formatting some more, and added Lucid GNU Emacs font and mouse
  55. ;; support (mostly cannibalized from webster-ucb.el.)
  56.  
  57. (defvar webster-host "129.79.254.192"
  58.   "The host to use as a webster server.")
  59.  
  60. (defvar webster-port "2627"
  61.   "The port to connect to. Either 103 or 2627")
  62.  
  63. (defvar webster-process nil
  64.   "The current webster process")
  65.  
  66. (defvar webster-process-name "webster"
  67.   "The current webster process")
  68.  
  69. (defvar webster-buffer nil
  70.   "The current webster process")
  71.  
  72. (defvar webster-running nil
  73.   "Used to determine when connection is established")
  74.  
  75. ;;;
  76. ;;; Initial filter for ignoring information until successfully connected
  77. ;;;
  78. (defun webster-initial-filter (proc string)
  79.   (let ((this-buffer (current-buffer)))
  80.     (set-buffer webster-buffer)
  81.     (goto-char (point-max))
  82.     (cond ((not (eq (process-status webster-process) 'run))
  83.        (setq webster-running t)
  84.        (message "Webster died"))
  85.       ((string-match "No such host" string)
  86.        (setq webster-running t)
  87.        (kill-buffer (process-buffer proc))
  88.        (error "No such host."))
  89.       ((string-match "]" string)
  90.        (setq webster-running t)
  91.        (set-process-filter proc 'webster-filter)))
  92.     (set-buffer this-buffer)))
  93.  
  94. (defvar webster-reformat t
  95.   "*Set this to t if you want the webster output to be prettied up, and
  96. for the \\[webster] prompt to do completion across the set of words known
  97. to be in the dictionary (words you've looked up, or which appeared in 
  98. definitions as crossreferences.)")
  99.  
  100. (defun webster-filter (proc string)
  101.   (let ((this-buffer (current-buffer))
  102.     (endp nil))
  103.     (set-buffer webster-buffer)
  104.     (cond ((not (eq (process-status webster-process) 'run))
  105.        (message "Webster died"))
  106.       ((string-match "Connection closed" string)
  107.        (message "Closing webster connection...")
  108.        (kill-process proc)
  109.        (replace-regexp "Process webster killed" "" nil)
  110.        (goto-char 1)
  111.        (message "Closing webster connection...Done."))
  112.       ((string-match "SPELLING 0" string)
  113.        (insert-string "...Word not found in webster\n"))
  114.       ((string-match "SPELLING 1" string)
  115.        (insert-string "...Spelled correctly\n"))
  116.       ((let ((end-def-message (or (string-match "\200" string)
  117.                       (string-match "\0" string))))
  118.          (if end-def-message
  119.          (progn
  120.            (webster-filter
  121.             proc
  122.             (concat (substring string 0 (- end-def-message 1)) "\n\n"))
  123.            (setq endp t)
  124.            (goto-char (point-max))
  125.            t))))
  126.       (t
  127.        (goto-char (point-max))
  128.        (let ((now (point)))
  129.          (insert string)
  130.          (delete-char-in-region now (point) "\^M" " "))
  131.        (if (process-mark proc)
  132.            (set-marker (process-mark proc) (point)))))
  133.     (if endp
  134.     ;; if the webster window is visible, move the last line to the
  135.     ;; bottom of that window
  136.     (let ((webster-window (get-buffer-window webster-buffer))
  137.           (window (selected-window)))
  138.       (if webster-reformat (webster-reformat (process-mark proc)))
  139.       (if webster-window
  140.           (progn
  141.         (select-window webster-window)
  142.         (goto-char (point-max))
  143.         (recenter (1- (window-height webster-window)))
  144.         (select-window window)))))))
  145.  
  146. (defconst webster-completion-table (make-vector 511 0))
  147.  
  148. (defun webster-intern (string)
  149.   (while (string-match "\\." string)
  150.     (setq string (concat (substring string 0 (match-beginning 0))
  151.              (substring string (match-end 0)))))
  152.   (intern (downcase string) webster-completion-table))
  153.  
  154. (defvar webster-fontify (string-match "Lucid" emacs-version)
  155.   "*Set to t to use the Lucid GNU Emacs font-change mechanism.")
  156.  
  157. (cond ((fboundp 'make-face)
  158.        (or (find-face 'webster)
  159.        (face-differs-from-default-p (make-face 'webster))
  160.        (copy-face 'default 'webster))
  161.        (or (find-face 'webster-bold)
  162.        (face-differs-from-default-p (make-face 'webster-bold))
  163.        (copy-face 'bold 'webster-bold))
  164.        (or (find-face 'webster-italic)
  165.        (face-differs-from-default-p (make-face 'webster-italic))
  166.        (copy-face 'italic 'webster-italic))
  167.        (or (find-face 'webster-bold-italic)
  168.        (face-differs-from-default-p (make-face 'webster-bold-italic))
  169.        (copy-face 'bold-italic 'webster-bold-italic))
  170.        (or (find-face 'webster-small)
  171.        (face-differs-from-default-p (make-face 'webster-small))
  172.        (copy-face 'webster-bold 'webster-small))
  173.        ))
  174.  
  175. (defun webster-fontify (start end face &optional highlight)
  176.   (let ((e (make-extent start end (current-buffer))))
  177.     (set-extent-face e face)
  178.     (if highlight (set-extent-attribute e 'highlight))))
  179.  
  180.  
  181. (defun webster-reformat (end)
  182.   "Clean up the output of the webster server, and gather words for the 
  183. completion table."
  184.   (if (not webster-reformat) nil
  185.     (goto-char end)
  186.     (let ((case-fold-search nil))
  187.       (re-search-backward "^[A-Z]+" nil t)
  188.       (if webster-fontify
  189.       (save-excursion
  190.         (previous-line 1)
  191.         (if (looking-at "^DEFINE \\([^ \n]+\\)")
  192.         (webster-fontify (match-beginning 1) (match-end 1)
  193.                  'webster-bold t))))
  194.       (cond
  195.        ((or (looking-at "^DEFINITION [0-9]")
  196.         (looking-at "^SPELLING"))
  197.     (forward-line 1)
  198.     (let ((p (point))
  199.           (indent 2))
  200.       (search-forward "\n\n" nil 0)
  201.       (narrow-to-region p (point))
  202.       (goto-char p)
  203.       (while (search-forward "\n" nil t)
  204.         (delete-char -1)
  205.         (just-one-space))
  206.       (goto-char p)
  207.       (while (not (eobp))
  208.         (if (looking-at " *\n")
  209.         (delete-region (match-beginning 0) (match-end 0)))
  210.         (cond ((looking-at "^[0-9]+ ")
  211.            (if webster-fontify
  212.                (webster-fontify (point) (match-end 0)
  213.                     'webster-bold-italic))
  214.            (goto-char (match-end 0))
  215.            (if (looking-at "[^\n0-9]+ [0-9]")
  216.                (save-excursion
  217.              (goto-char (1- (match-end 0)))
  218.              (insert "\n")))
  219.            (if (looking-at "[a-z]+\\( [a-z]+\\)*[ \n]")
  220.                (webster-intern
  221.             (buffer-substring (point) (1- (match-end 0)))))
  222.            (if webster-fontify
  223.                (webster-fontify (point) (1- (match-end 0))
  224.                     'webster-bold t))
  225.            (goto-char (1- (match-end 0)))
  226.            (if (looking-at " *\n") (forward-line 1)))
  227.           ((looking-at " *[0-9]+\\. ")
  228.            (setq indent 5)
  229.            (delete-horizontal-space)
  230.            (insert (if (= (preceding-char) ?\n) "  " "\n  "))
  231.            (skip-chars-forward "0-9. ")
  232.            (if webster-fontify
  233.                (webster-fontify
  234.             (save-excursion (beginning-of-line) (point))
  235.             (point)
  236.             'webster-bold-italic)))
  237.           ((looking-at " *\\([0-9]+\\): *")
  238.            (let ((n (buffer-substring (match-beginning 1)
  239.                           (match-end 1))))
  240.              (delete-region (match-beginning 0) (match-end 0))
  241.              (insert "\n")
  242.              (indent-to (- 6 (length n)))
  243.              (insert n " : ")
  244.              (setq indent 9)
  245.              (if webster-fontify
  246.              (webster-fontify
  247.               (save-excursion (beginning-of-line) (point))
  248.               (point)
  249.               'webster-bold-italic))))
  250.           ((looking-at " *\\([0-9]+\\)\\([a-z]+\\): *")
  251.            (let ((n (buffer-substring (match-beginning 1)
  252.                           (match-end 1)))
  253.              (m (buffer-substring (match-beginning 2)
  254.                           (match-end 2))))
  255.              (if (not (equal m "a")) (setq n " "))
  256.              (delete-region (match-beginning 0) (match-end 0))
  257.              (insert "\n")
  258.              (indent-to (- 6 (length n)))
  259.              (insert n "  ")
  260.              (insert m " : ")
  261.              (setq indent 12)
  262.              (if webster-fontify
  263.              (webster-fontify
  264.               (save-excursion (beginning-of-line) (point))
  265.               (point)
  266.               'webster-bold-italic))))
  267.           ((looking-at " *\\([0-9]+\\)\\([a-z]+\\)\\([0-9]+\\): *")
  268.            (let ((n (buffer-substring (match-beginning 1)
  269.                           (match-end 1)))
  270.              (m (buffer-substring (match-beginning 2)
  271.                           (match-end 2)))
  272.              (o (buffer-substring (match-beginning 3)
  273.                           (match-end 3))))
  274.              (if (not (equal o "1")) (setq m " "))
  275.              (if (not (equal m "a")) (setq n " "))
  276.              (delete-region (match-beginning 0) (match-end 0))
  277.              (insert "\n")
  278.              (indent-to (- 6 (length n)))
  279.              (insert n "  ")
  280.              (insert m "  ")
  281.              (insert "(" o ") : ")
  282.              (setq indent 17)
  283.              (if webster-fontify
  284.              (webster-fontify
  285.               (save-excursion (beginning-of-line) (point))
  286.               (point)
  287.               'webster-bold-italic))))
  288.           ((looking-at " *\\\\")
  289.            (setq indent 5)
  290.            (setq p (point))
  291.            (goto-char (match-end 0))
  292.            (search-forward "\\")
  293.            (if (> (current-column) fill-column)
  294.                (progn
  295.              (goto-char p)
  296.              (insert "\n")
  297.              (indent-to 18)
  298.              (search-forward "\\")))
  299.            (if webster-fontify
  300.                (webster-fontify p (point) 'webster-italic)))
  301.           ((looking-at " *\\[")
  302.            (setq indent 6)
  303.            (delete-horizontal-space)
  304.            (insert "\n")
  305.            (indent-to 5)
  306.            (forward-char 1))
  307.           ((and (= (preceding-char) ?\])
  308.             (looking-at " *:"))
  309.            (delete-horizontal-space)
  310.            (setq indent 5)
  311.            (insert "\n "))
  312.           ((looking-at " *SYN *")
  313.            (delete-region (point) (match-end 0))
  314.            (insert "\n")
  315.            (delete-horizontal-space)
  316.            (insert "  ")
  317.            (setq indent 6)
  318.            (if (looking-at "syn ")
  319.                (progn
  320.              (if webster-fontify
  321.                  (webster-fontify (point) (+ (point) 3)
  322.                           'webster-bold))
  323.              (goto-char (match-end 0))
  324.              (insert "see "))))
  325.           (t
  326.            (setq p (point))
  327.            (skip-chars-forward " ,:;-")
  328.            (if (or (looking-at
  329.               "\\([A-Z][-A-Z]+[A-Z]\\)\\( [A-Z][-A-Z]*[A-Z]\\)*")
  330.                (looking-at "[a-z][-a-z]*\\(\\.[a-z][-a-z]*\\)+"))
  331.                (let ((s (buffer-substring (point) (match-end 0))))
  332.              (if webster-fontify
  333.                  (webster-fontify (point) (match-end 0)
  334.                           'webster-bold t))
  335.              (while (string-match "\\." s)
  336.                (setq s (concat (substring s 0 (match-beginning 0))
  337.                        (substring s (match-end 0)))))
  338.              (webster-intern s)))
  339.            (skip-chars-forward "^ \\")
  340.            (if (> (current-column) fill-column)
  341.                (progn
  342.              (goto-char p)
  343.              (insert "\n")
  344.              (delete-horizontal-space)
  345.              (indent-to indent)
  346.              (skip-chars-forward " ")
  347.              (skip-chars-forward "^ \\")
  348.              )))
  349.           )))
  350.     (goto-char (point-min))
  351.     (while (looking-at "\n") (delete-char 1))
  352.     (goto-char (point-max))
  353.     (insert "\n\n")
  354.     (widen))))))
  355.  
  356. ;; " \\(\\(slang\\|cap\\|pl\\|aj\\|av\\|n\\|v\\|vt\\|vi\\)\\(,[ \n]+\\)?\\)+\n"
  357.  
  358. ;;;
  359. ;;; delete char1 and char2 if it precedes char1
  360. ;;; used to get rid of <space><return>
  361. (defun delete-char-in-region (start end char1 char2)
  362.   (goto-char start)
  363.   (setq char2 (aref char2 0))
  364.   (while (search-forward char1 end t)
  365.     (delete-char -1)
  366.     (if (= (char-after (- (point) 1)) char2)
  367.     (delete-char -1))))
  368.  
  369. (defun webster (arg)
  370. "Look up a word in the Webster's dictionary.
  371. Open a network login connection to a webster host if necessary.
  372. Communication with host is recorded in a buffer *webster*."
  373.   (interactive (list
  374.         (let ((prompt (concat "Look up word in webster ("
  375.                       (current-word) "): "))
  376.               (completion-ignore-case t))
  377.           (downcase
  378.            (if webster-reformat
  379.                (completing-read prompt webster-completion-table
  380.                     nil nil)
  381.              (read-string prompt))))))
  382.   (if (equal "" arg) (setq arg (current-word)))
  383.   (webster-send-request "DEFINE" arg))
  384.  
  385. (defun webster-endings (arg)
  386. "Look up endings for a word in the Webster's dictionary.
  387. Open a network login connection to a webster host if necessary.
  388. Communication with host is recorded in a buffer *webster*."
  389.   (interactive (list
  390.         (read-string
  391.          (concat
  392.           "Find endings for word in webster (" (current-word) "): "))))
  393.   (if (equal "" arg) (setq arg (current-word)))
  394.   (webster-send-request "ENDINGS" arg))
  395.  
  396. (defun webster-spell (arg)
  397. "Look spelling for a word in the Webster's dictionary.
  398. Open a network login connection to a webster host if necessary.
  399. Communication with host is recorded in a buffer *webster*."
  400.   (interactive (list
  401.         (read-string
  402.          (concat
  403.           "Try to spell word in webster (" (current-word) "): "))))
  404.   (if (equal "" arg) (setq arg (current-word)))
  405.   (webster-send-request "SPELL" arg))
  406.  
  407. (defun webster-send-request (kind word)
  408.   (require 'shell)
  409.   (let
  410.       ((webster-command (concat "open " webster-host " " webster-port "\n")))
  411.     
  412.     (if (or 
  413.      (not webster-buffer)
  414.      (not webster-process)
  415.      (not (eq (process-status webster-process) 'run)))
  416.     (progn
  417.       (message
  418.        (concat "Attempting to connect to server " webster-host "..."))
  419.       (setq webster-buffer
  420.         (if (not (fboundp 'make-shell)) ;emacs19
  421.             (make-comint webster-process-name "telnet")
  422.           (make-shell webster-process-name "telnet")))
  423.       (let
  424.           ((this-buffer (current-buffer)))
  425.         (set-buffer webster-buffer)
  426.         (webster-mode)
  427.         (set-buffer this-buffer))
  428.  
  429.       (setq webster-process (get-process webster-process-name))
  430.       (set-process-filter webster-process 'webster-initial-filter)
  431.       (process-send-string  webster-process webster-command)
  432.       (setq webster-running nil);
  433.       (while (not webster-running)    ; wait for feedback
  434.         (accept-process-output))))    ;
  435.     (display-buffer webster-buffer nil)
  436.     (process-send-string webster-process (concat kind " " word "\n"))))
  437.  
  438. (defun webster-quit ()
  439.    "Close connection and quit webster-mode.  Buffer is not deleted."
  440.    (interactive)
  441.    (message "Closing connection to %s..." webster-host)
  442.    (kill-process webster-process)
  443.    (message "Closing connection to %s...done" webster-host)
  444.    (bury-buffer))
  445.  
  446. (defun webster-mode ()
  447.   "Major mode for interacting with on-line Webster's dictionary.
  448. \\{webster-mode-map}
  449. Use webster-mode-hook for customization."
  450.   (interactive)
  451.   (kill-all-local-variables)
  452.   (setq major-mode 'webster-mode)
  453.   (setq mode-name "Webster")
  454.   (use-local-map webster-mode-map)
  455.   (run-hooks 'webster-mode-hook))
  456.  
  457. (defvar webster-mode-map nil)
  458. (if webster-mode-map
  459.     nil
  460.   (setq webster-mode-map (make-sparse-keymap))
  461.   (define-key webster-mode-map "?" 'describe-mode)
  462.   (define-key webster-mode-map "d" 'webster)
  463.   (define-key webster-mode-map "e" 'webster-endings)
  464.   (define-key webster-mode-map "q" 'webster-quit)
  465.   (define-key webster-mode-map "s" 'webster-spell)
  466.   (if (string-match "Lucid" emacs-version)
  467.       (define-key webster-mode-map 'button2 'webster-xref-word)))
  468.  
  469. ;; Snatched from unix-apropos by Henry Kautz
  470. (defun current-word ()
  471.    "Word cursor is over, as a string."
  472.    (save-excursion
  473.       (let (beg end)
  474.      (re-search-backward "\\w" nil 2)
  475.      (re-search-backward "\\b" nil 2)
  476.      (setq beg (point))
  477.      (re-search-forward "\\w*\\b" nil 2)
  478.      (setq end (point))
  479.      (buffer-substring beg end))))
  480.  
  481. (defun webster-xref-word (event)
  482.   "Define the highlighted word under the mouse.
  483. Words which are known to have definitions are highlighted when the mouse
  484. moves over them.  You may define any word by selecting it with the left
  485. mouse button and then clicking middle."
  486.   (interactive "e")
  487.   (let* ((buffer (window-buffer (event-window event)))
  488.      (extent (extent-at (event-point event) buffer 'highlight))
  489.      text)
  490.     (cond (extent
  491.        (setq text (save-excursion
  492.             (set-buffer buffer)
  493.             (buffer-substring
  494.              (extent-start-position extent)
  495.              (extent-end-position extent)))))
  496.       ((x-selection-owner-p) ; the selection is in this emacs process.
  497.        (setq text (x-get-selection)))
  498.       (t
  499.        (error "click on a highlighted word to define")))
  500.     (while (string-match "\\." text)
  501.       (setq text (concat (substring text 0 (match-beginning 0))
  502.              (substring text (match-end 0)))))
  503.     (message "looking up %s..." (upcase text))
  504.     (goto-char (point-max))
  505.     (webster text)))
  506.