0
|
1 ;;; -*- Mode:Emacs-Lisp -*-
|
|
2
|
|
3 ;;; Synched up with: Not in FSF.
|
|
4
|
|
5 ;;; Yet Another Webster Protocol.
|
|
6 ;;; This one is for talking to the kind of Webster server of which
|
|
7 ;;; pasteur.Berkeley.EDU port 1964 is an instance (the "edjames" protocol).
|
|
8 ;;;
|
|
9 ;;; The interface and much of the process-handling code in this file were
|
|
10 ;;; lifted from the Webster client by Jason Glasgow that talks to the kind
|
|
11 ;;; of Webster server of which mintaka.lcs.mit.edu port 103 is an instance.
|
|
12 ;;;
|
|
13 ;;; 13 nov 90 Jamie Zawinski <jwz@lucid.com> created
|
|
14 ;;; 14 sep 91 Jamie Zawinski <jwz@lucid.com> hacked on some more
|
|
15 ;;; 19 feb 91 Jamie Zawinski <jwz@lucid.com> added Lucid Emacs font support
|
|
16 ;;; 15 apr 92 Jamie Zawinski <jwz@lucid.com> added mouse support
|
|
17 ;;; 29 aug 92 Jamie Zawinski <jwz@lucid.com> added 8-bit output
|
|
18 ;;; 6 nov 92 Jamie Zawinski <jwz@lucid.com> hack hack
|
|
19 ;;; 31 dec 92 Jamie Zawinski <jwz@lucid.com> made it guess the root word
|
|
20 ;;; 17 mar 93 Jamie Zawinski <jwz@lucid.com> more hacking, more gnashing
|
|
21 ;;; 31 jul 93 Jamie Zawinski <jwz@lucid.com> variable height fonts in 19.8
|
|
22
|
|
23 ;; TODO:
|
|
24 ;;
|
|
25 ;; vinculum has a "3 character overbar" code. Really need to figure out
|
|
26 ;; some way to hack overbars... Background pixmap? Need to know line
|
|
27 ;; height in pixels to do that.
|
|
28 ;;
|
|
29 ;; I don't event know what half of these special characters are supposed
|
|
30 ;; to look like. Like the "s," in the Turkish root of "chouse"...
|
|
31 ;;
|
|
32 ;; We could fake some of these chars (like upside-down-e) by including bitmaps
|
|
33 ;; in this file, and using extent-begin-glpyhs. Except that right now glyphs
|
|
34 ;; have to come from files, not from '(w h "string") form, so that'll have to
|
|
35 ;; be fixed first. We could also just create an X font...
|
|
36 ;;
|
|
37 ;; note that googol says "10100" instead of "10(\bI100)\bI
|
|
38
|
|
39 (defvar webster-host "westerhost" "*The host with the webster server")
|
|
40 (defvar webster-port "webster" "*The port on which the webster server listens")
|
|
41
|
|
42 (defvar webster-running nil "Used to determine when connection is established")
|
|
43 (defvar webster-state "closed" "for the modeline")
|
|
44 (defvar webster-process nil "The current webster process")
|
|
45 (defvar webster-process-name "webster" "The current webster process")
|
|
46 (defvar webster-buffer nil "The current webster process")
|
|
47
|
|
48 (defvar webster-start-mark nil)
|
|
49
|
|
50 (defvar webster-fontify (string-match "XEmacs" emacs-version)
|
|
51 "*Set to t to use the XEmacs/Lucid Emacs font-change mechanism.")
|
|
52
|
|
53 (defvar webster-iso8859/1 (string-match "XEmacs" emacs-version)
|
|
54 "*Set to t to print certain special characters using ISO-8859/1 codes.")
|
|
55
|
|
56 (defconst webster-completion-table (make-vector 511 0))
|
|
57
|
|
58 (cond ((fboundp 'make-face)
|
|
59 (or (find-face 'webster)
|
|
60 (face-differs-from-default-p (make-face 'webster))
|
|
61 (copy-face 'default 'webster))
|
|
62 (or (find-face 'webster-bold)
|
|
63 (face-differs-from-default-p (make-face 'webster-bold))
|
|
64 (progn
|
|
65 (copy-face 'webster 'webster-bold)
|
|
66 (make-face-bold 'webster-bold)))
|
|
67 (or (find-face 'webster-italic)
|
|
68 (face-differs-from-default-p (make-face 'webster-italic))
|
|
69 (progn
|
|
70 (copy-face 'webster 'webster-italic)
|
|
71 (make-face-italic 'webster-italic)))
|
|
72 (or (find-face 'webster-bold-italic)
|
|
73 (face-differs-from-default-p (make-face 'webster-bold-italic))
|
|
74 (progn
|
|
75 (copy-face 'webster 'webster-bold-italic)
|
|
76 (make-face-bold-italic 'webster-bold-italic)))
|
|
77 (or (find-face 'webster-underline)
|
|
78 (face-differs-from-default-p (make-face 'webster-underline))
|
|
79 (progn
|
|
80 (copy-face 'webster 'webster-underline)
|
|
81 (set-face-underline-p 'webster-underline t)))
|
|
82 (or (find-face 'webster-small)
|
|
83 (face-differs-from-default-p (make-face 'webster-small))
|
|
84 (progn
|
|
85 (copy-face 'webster-bold 'webster-small)
|
|
86 (and (fboundp 'make-face-smaller) ; XEmacs 19.8+
|
|
87 (make-face-smaller 'webster-small))))
|
|
88 (or (find-face 'webster-subscript)
|
|
89 (face-differs-from-default-p (make-face 'webster-subscript))
|
|
90 (progn
|
|
91 (copy-face 'webster-italic 'webster-subscript)
|
|
92 (if (fboundp 'make-face-smaller) ; XEmacs 19.8+
|
|
93 (and (make-face-smaller 'webster-subscript)
|
|
94 (make-face-smaller 'webster-subscript))
|
|
95 (set-face-underline-p 'webster-subscript t))))
|
|
96 (or (find-face 'webster-superscript)
|
|
97 (face-differs-from-default-p (make-face 'webster-superscript))
|
|
98 ;; #### need some way to raise baseline...
|
|
99 (copy-face 'webster-subscript 'webster-superscript))
|
|
100 ))
|
|
101
|
|
102 (defun webster-fontify (start end face &optional highlight)
|
|
103 (let ((os start)
|
|
104 (count 0)
|
|
105 e)
|
|
106 (save-excursion
|
|
107 (goto-char start)
|
|
108 ;; this mess is so we don't fontify the spaces between the words, so that
|
|
109 ;; when the lines are wrapped, the stuff at the beginning of the line
|
|
110 ;; doesn't go in the font of the split word. Kludge kludge.
|
|
111 (while (prog1
|
|
112 (/= (point) end)
|
|
113 (skip-chars-forward " \t")
|
|
114 (setq start (point))
|
|
115 (re-search-forward "[ \t]" (1+ end) 'go)
|
|
116 (forward-char -1))
|
|
117 (setq e (make-extent start (point) (current-buffer)))
|
|
118 (set-extent-face e face)
|
|
119 (setq count (1+ count))))
|
|
120 (if highlight
|
|
121 (set-extent-property
|
|
122 ;; use the same extent if we didn't have to split it.
|
|
123 (if (= count 1) e (make-extent os end (current-buffer)))
|
|
124 'highlight t))
|
|
125 ))
|
|
126
|
|
127 (defconst webster-umlauts
|
|
128 '((?A . ?\304) (?E . ?\313) (?I . ?\317) (?O . ?\326) (?U . ?\334)
|
|
129 (?a . ?\344) (?e . ?\353) (?i . ?\357) (?o . ?\366) (?u . ?\374)
|
|
130 (?y . ?\377)))
|
|
131
|
|
132 (defconst webster-graves
|
|
133 '((?A . ?\300) (?E . ?\310) (?I . ?\314) (?O . ?\322) (?U . ?\331)
|
|
134 (?a . ?\340) (?e . ?\350) (?i . ?\354) (?o . ?\362) (?u . ?\371)))
|
|
135
|
|
136 (defconst webster-acutes
|
|
137 '((?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332)
|
|
138 (?Y . ?\335) (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363)
|
|
139 (?u . ?\372) (?y . ?\375)))
|
|
140
|
|
141 ;;;
|
|
142 ;;; Initial filter for ignoring information until successfully connected
|
|
143 ;;;
|
|
144 (defun webster-initial-filter (proc string)
|
|
145 (let ((this-buffer (current-buffer)))
|
|
146 ;; don't use save-excursion so that point moves in webster-buffer
|
|
147 (set-buffer webster-buffer)
|
|
148 (goto-char (point-max))
|
|
149 (setq webster-state "closed")
|
|
150 (cond ((not (eq (process-status webster-process) 'run))
|
|
151 (setq webster-running t)
|
|
152 (message "Webster died"))
|
|
153 ((string-match "No such host" string)
|
|
154 (setq webster-running t)
|
|
155 (kill-buffer (process-buffer proc))
|
|
156 (error "No such host."))
|
|
157 ((string-match "]" string)
|
|
158 (setq webster-running t)
|
|
159 (setq webster-state "opening")
|
|
160 (set-process-filter proc 'webster-filter)))
|
|
161 (set-buffer this-buffer)))
|
|
162
|
|
163
|
|
164 (defun webster-filter (proc string)
|
|
165 (let ((this-buffer (current-buffer))
|
|
166 (endp nil))
|
|
167 (set-buffer webster-buffer)
|
|
168 (widen)
|
|
169 (goto-char (point-max))
|
|
170 (cond ((not (eq (process-status webster-process) 'run))
|
|
171 (setq webster-state (format "%s" (process-status webster-process)))
|
|
172 (set-marker webster-start-mark (point-max))
|
|
173 (message "Webster died"))
|
|
174 ((string-match "Connection closed" string)
|
|
175 (message "Closing webster connection...")
|
|
176 (kill-process proc)
|
|
177 (setq webster-state "closed")
|
|
178 (replace-regexp "Process webster killed" "" nil)
|
|
179 (set-marker webster-start-mark (point-max))
|
|
180 (message "Closing webster connection...Done."))
|
|
181 ((let ((end-def-message (string-match "\n\\.\r?\n" string)))
|
|
182 (if end-def-message
|
|
183 (progn
|
|
184 (webster-filter
|
|
185 proc
|
|
186 (concat (substring string 0 (- end-def-message 1)) "\n\n"))
|
|
187 (setq endp t)
|
|
188 (setq webster-state "ready")
|
|
189 t))))
|
|
190 (t
|
|
191 (setq webster-state "working")
|
|
192 (if (string-match "^[45][0-9][0-9]" string)
|
|
193 (setq webster-state "ready"
|
|
194 endp t))
|
|
195 (widen)
|
|
196 (let ((now (point)))
|
|
197 (goto-char (point-max))
|
|
198 (insert string)
|
|
199 (save-excursion
|
|
200 (goto-char now)
|
|
201 (while (search-forward "\r" nil t)
|
|
202 (delete-char -1))))
|
|
203 (if (process-mark proc)
|
|
204 (set-marker (process-mark proc) (point)))
|
|
205 (narrow-to-region (point-min) webster-start-mark)
|
|
206 ))
|
|
207 (if endp
|
|
208 ;; if the *webster* window is visible, move the last line to the
|
|
209 ;; bottom of that window
|
|
210 (let ((webster-window (get-buffer-window webster-buffer))
|
|
211 (window (selected-window))
|
|
212 error p)
|
|
213 (set-buffer webster-buffer)
|
|
214 (widen)
|
|
215 (goto-char (point-min))
|
|
216 (narrow-to-region webster-start-mark (point-max))
|
|
217 (let ((buffer-undo-list t))
|
|
218 (if (looking-at "WORD \"\\([^\"\n]*\\)\"\\(\n403 [^\n]+\\)\n")
|
|
219 (progn
|
|
220 (downcase-word 1)
|
|
221 (setq error
|
|
222 (buffer-substring (match-beginning 1) (match-end 1)))
|
|
223 (goto-char (match-beginning 2))
|
|
224 (delete-region (match-beginning 2) (match-end 2))
|
|
225 (insert " not found")
|
|
226 (setq error (webster-guess-root error))
|
|
227 (if error
|
|
228 (insert "; trying \"" error "\"...")
|
|
229 (insert "."))
|
|
230 )
|
|
231 (webster-convert)))
|
|
232 (widen)
|
|
233 (setq p (marker-position webster-start-mark))
|
|
234 (goto-char (point-max))
|
|
235 (or (bobp)
|
|
236 (save-excursion (forward-line -1) (looking-at "-"))
|
|
237 (insert "\n--------------------\n"))
|
|
238 (set-marker webster-start-mark (point-max))
|
|
239 (goto-char p)
|
|
240 (if webster-window
|
|
241 (progn
|
|
242 (select-window webster-window)
|
|
243 (goto-char p)
|
|
244 (recenter 3)
|
|
245 (select-window window)))
|
|
246 (if error (webster error))))))
|
|
247
|
|
248 (defun webster-guess-root (word)
|
|
249 (let ((case-fold-search t))
|
|
250 (cond ((null word) nil)
|
|
251 ((string-match "[ \t\n]" word)
|
|
252 nil)
|
|
253 ((string-match "[^aeiou]ing\\'" word)
|
|
254 (concat (substring word 0 (+ 1 (match-beginning 0))) "e"))
|
|
255 ((string-match "[a-z]ing\\'" word)
|
|
256 (substring word 0 (+ 1 (match-beginning 0))))
|
|
257 ((string-match "ies\\'" word)
|
|
258 (concat (substring word 0 (match-beginning 0)) "y"))
|
|
259 ((string-match "ied\\'" word)
|
|
260 (concat (substring word 0 (match-beginning 0)) "y"))
|
|
261 ((and (string-match "[^aeiouy][^aeiouy]ed\\'" word)
|
|
262 (= (aref word (match-beginning 0))
|
|
263 (aref word (1+ (match-beginning 0)))))
|
|
264 (substring word 0 (+ 1 (match-beginning 0))))
|
|
265 ((string-match "[a-z]ed\\'" word)
|
|
266 (substring word 0 (+ 2 (match-beginning 0))))
|
|
267 ((string-match "[aeiouy]lly\\'" word)
|
|
268 (substring word 0 (+ 2 (match-beginning 0))))
|
|
269 ((string-match "[^l]ly\\'" word)
|
|
270 (substring word 0 (+ 1 (match-beginning 0))))
|
|
271 ; ((string-match "es\\'" word)
|
|
272 ; (substring word 0 (match-beginning 0)))
|
|
273 ; ((string-match "[^e]s\\'" word)
|
|
274 ; (substring word 0 (+ 1 (match-beginning 0))))
|
|
275 ((string-match "s\\'" word)
|
|
276 (substring word 0 (match-beginning 0)))
|
|
277 ((string-match "...ed\\'" word)
|
|
278 (substring word (1- (match-end 0))))
|
|
279 (t nil))))
|
|
280
|
|
281
|
|
282 ;;;###don't autoload
|
|
283 (defun webster (arg)
|
|
284 "Look up a word in the Webster's dictionary.
|
|
285 Open a network login connection to a webster host if necessary.
|
|
286 Communication with host is recorded in a buffer *webster*."
|
|
287 (interactive (list
|
|
288 (let ((prompt (concat "Look up word in webster ("
|
|
289 (current-word) "): "))
|
|
290 (completion-ignore-case t))
|
|
291 (downcase
|
|
292 (completing-read prompt webster-completion-table
|
|
293 nil nil)))))
|
|
294 (if (equal "" arg) (setq arg (current-word)))
|
|
295 (message "looking up %s..." (upcase arg))
|
|
296 (webster-send-request "WORD" (prin1-to-string arg)))
|
|
297
|
|
298 ;;;###don't autoload
|
|
299 (defun webster-endings (arg)
|
|
300 "Look up endings for a word in the Webster's dictionary.
|
|
301 Open a network login connection to a webster host if necessary.
|
|
302 Communication with host is recorded in a buffer *webster*."
|
|
303 (interactive (list
|
|
304 (read-string
|
|
305 (concat
|
|
306 "Find endings for word in webster (" (current-word) "): "))))
|
|
307 (if (equal "" arg) (setq arg (current-word)))
|
|
308 (webster-send-request "PREFIX" arg)
|
|
309 (webster-send-request "LIST" ""))
|
|
310
|
|
311 ;;;###don't autoload
|
|
312 (defun webster-spell (arg)
|
|
313 "Look spelling for a word in the Webster's dictionary.
|
|
314 Open a network login connection to a webster host if necessary.
|
|
315 Communication with host is recorded in a buffer *webster*."
|
|
316 (interactive (list
|
|
317 (read-string
|
|
318 (concat
|
|
319 "Try to spell word in webster (" (current-word) "): "))))
|
|
320 (if (equal "" arg) (setq arg (current-word)))
|
|
321 (webster-send-request "EXACT" arg)
|
|
322 (webster-send-request "LIST" arg))
|
|
323
|
|
324
|
|
325 (defun webster-send-request (kind word)
|
|
326 (require 'shell)
|
|
327 (let ((webster-command (concat "open " webster-host " " webster-port "\n")))
|
|
328 (if (or (not webster-buffer)
|
|
329 (not (buffer-name webster-buffer))
|
|
330 (not webster-process)
|
|
331 (not (eq (process-status webster-process) 'run)))
|
|
332 (progn
|
|
333 (message
|
|
334 (concat "Attempting to connect to server " webster-host "..."))
|
|
335 (setq webster-buffer
|
|
336 (if (not (fboundp 'make-shell)) ;emacs19
|
|
337 (make-comint webster-process-name "telnet")
|
|
338 (make-shell webster-process-name "telnet")))
|
|
339 (set-buffer webster-buffer)
|
|
340 (webster-mode)
|
|
341 (setq webster-process (get-process webster-process-name))
|
|
342 (process-kill-without-query webster-process)
|
|
343 (set-process-filter webster-process 'webster-initial-filter)
|
|
344 (process-send-string webster-process webster-command)
|
|
345 (setq webster-running nil)
|
|
346 (while (not webster-running) ; wait for feedback
|
|
347 (accept-process-output webster-process))
|
|
348 (message
|
|
349 (concat "Attempting to connect to server " webster-host
|
|
350 "... Connected."))
|
|
351 ))
|
|
352 (display-buffer webster-buffer nil)
|
|
353 (process-send-string webster-process (concat kind " " word "\n"))))
|
|
354
|
|
355 (defun webster-quit ()
|
|
356 "Close connection and quit webster-mode. Buffer is not deleted."
|
|
357 (interactive)
|
|
358 (message "Closing connection to %s..." webster-host)
|
|
359 (kill-process webster-process)
|
|
360 (message "Closing connection to %s...done" webster-host)
|
|
361 (setq webster-state "closed")
|
|
362 (if (eq (current-buffer) webster-buffer)
|
|
363 (bury-buffer)))
|
|
364
|
|
365
|
|
366 (defun webster-xref-data (event &optional selection-only)
|
|
367 (let* ((buffer (event-buffer event))
|
|
368 (extent (if buffer (extent-at (event-point event) buffer 'highlight)))
|
|
369 text)
|
|
370 (cond ((and extent (not selection-only))
|
|
371 (setq text (save-excursion
|
|
372 (set-buffer buffer)
|
|
373 (buffer-substring
|
|
374 (extent-start-position extent)
|
|
375 (extent-end-position extent)))))
|
|
376 ((x-selection-owner-p) ; the selection is in this emacs process.
|
|
377 (setq text (x-get-selection))
|
|
378 (if (string-match "[\n\r]" text)
|
|
379 (setq text nil))))
|
|
380 (if (null text)
|
|
381 nil
|
|
382 (while (string-match "\\." text)
|
|
383 (setq text (concat (substring text 0 (match-beginning 0))
|
|
384 (substring text (match-end 0)))))
|
|
385 (webster-unISO text)
|
|
386 text)))
|
|
387
|
|
388 (defun webster-xref-word (event)
|
|
389 "Define the highlighted word under the mouse.
|
|
390 Words which are known to have definitions are highlighted when the mouse
|
|
391 moves over them. You may define any word by selecting it with the left
|
|
392 mouse button and then clicking middle."
|
|
393 (interactive "e")
|
|
394 (webster (or (webster-xref-data event)
|
|
395 (error "click on a highlighted word to define"))))
|
|
396
|
|
397 (defvar webster-menu
|
|
398 '("Webster"
|
|
399 ["Define Word..." webster t]
|
|
400 ["List Words Beginning With..." webster-endings t]
|
|
401 ["Check Spelling Of..." webster-spell t]
|
|
402 "----"
|
|
403 ["Quit Webster" webster-quit t]
|
|
404 ))
|
|
405
|
|
406 (defun webster-menu (event)
|
|
407 (interactive "e")
|
|
408 (let ((text1 (webster-xref-data event nil))
|
|
409 (text2 (webster-xref-data event t)))
|
|
410 (if (equal text1 text2) (setq text2 nil))
|
|
411 (let ((popup-menu-titles t))
|
|
412 (popup-menu
|
|
413 (nconc (list (car webster-menu))
|
|
414 (if text1 (list (vector (format "Define %s" (upcase text1))
|
|
415 (list 'webster text1) t)))
|
|
416 (if text2 (list (vector (format "Define %s" (upcase text2))
|
|
417 (list 'webster text2) t)))
|
|
418 (cdr webster-menu))))))
|
|
419
|
|
420
|
|
421 (defvar webster-mode-map nil)
|
|
422 (if webster-mode-map
|
|
423 nil
|
|
424 (setq webster-mode-map (make-sparse-keymap))
|
|
425 (define-key webster-mode-map "?" 'describe-mode)
|
|
426 (define-key webster-mode-map "d" 'webster)
|
|
427 (define-key webster-mode-map "e" 'webster-endings)
|
|
428 (define-key webster-mode-map "q" 'webster-quit)
|
|
429 (define-key webster-mode-map "s" 'webster-spell)
|
|
430 (cond ((string-match "XEmacs" emacs-version)
|
|
431 (define-key webster-mode-map 'button2 'webster-xref-word)
|
|
432 (define-key webster-mode-map 'button3 'webster-menu)))
|
|
433 )
|
|
434
|
|
435 (defun webster-mode ()
|
|
436 "Major mode for interacting with on-line Webster's dictionary.
|
|
437 \\{webster-mode-map}
|
|
438 Use webster-mode-hook for customization."
|
|
439 (interactive)
|
|
440 (kill-all-local-variables)
|
|
441 (setq major-mode 'webster-mode)
|
|
442 (setq mode-name "Webster")
|
|
443 (use-local-map webster-mode-map)
|
|
444 (setq mode-line-process '(" " webster-state))
|
|
445 (make-local-variable 'kill-buffer-hook)
|
|
446 (if (not (string= (buffer-name (current-buffer)) "*webster*"))
|
|
447 (setq kill-buffer-hook '(lambda ()
|
|
448 (if (get-buffer "*webster*")
|
|
449 (kill-buffer "*webster*")))))
|
|
450 (set (make-local-variable 'webster-start-mark)
|
|
451 (set-marker (make-marker) (point-max)))
|
|
452 (set (make-local-variable 'page-delimiter) "^-")
|
|
453 (if webster-iso8859/1 (setq ctl-arrow 'iso-8859/1))
|
|
454 (run-hooks 'webster-mode-hook))
|
|
455
|
|
456 ;; now in simple.el
|
|
457 ;(defun current-word ()
|
|
458 ; "Word cursor is over, as a string."
|
|
459 ; (save-excursion
|
|
460 ; (let (beg end)
|
|
461 ; (re-search-backward "\\w" nil 2)
|
|
462 ; (re-search-backward "\\b" nil 2)
|
|
463 ; (setq beg (point))
|
|
464 ; (re-search-forward "\\w*\\b" nil 2)
|
|
465 ; (setq end (point))
|
|
466 ; (buffer-substring beg end))))
|
|
467
|
|
468 (defun webster-intern (string)
|
|
469 (intern (webster-strip-crud (webster-unISO (downcase string)))
|
|
470 webster-completion-table))
|
|
471
|
|
472 (defun webster-unISO (text)
|
|
473 ;; turn the ISO chars into the closest ASCII equiv (how they are indexed)
|
|
474 (while (string-match "\347" text) (aset text (match-beginning 0) ?c))
|
|
475 (while (string-match "\307" text) (aset text (match-beginning 0) ?C))
|
|
476 (while (string-match "\335" text) (aset text (match-beginning 0) ?Y))
|
|
477 (while (string-match "[\375\377]" text) (aset text (match-beginning 0) ?y))
|
|
478 (while (string-match "[\300-\305]" text) (aset text (match-beginning 0) ?A))
|
|
479 (while (string-match "[\310-\313]" text) (aset text (match-beginning 0) ?E))
|
|
480 (while (string-match "[\314-\317]" text) (aset text (match-beginning 0) ?I))
|
|
481 (while (string-match "[\322-\326]" text) (aset text (match-beginning 0) ?O))
|
|
482 (while (string-match "[\331-\334]" text) (aset text (match-beginning 0) ?U))
|
|
483 (while (string-match "[\340-\345]" text) (aset text (match-beginning 0) ?a))
|
|
484 (while (string-match "[\350-\353]" text) (aset text (match-beginning 0) ?e))
|
|
485 (while (string-match "[\354-\357]" text) (aset text (match-beginning 0) ?i))
|
|
486 (while (string-match "[\362-\366]" text) (aset text (match-beginning 0) ?o))
|
|
487 (while (string-match "[\371-\374]" text) (aset text (match-beginning 0) ?u))
|
|
488 text)
|
|
489
|
|
490 (defun webster-strip-crud (text)
|
|
491 (while (string-match ".\b" text)
|
|
492 (setq text (concat (substring text 0 (match-beginning 0))
|
|
493 (substring text (match-end 0)))))
|
|
494 text)
|
|
495
|
|
496
|
|
497 (defun webster-textify-region (start end &optional nointern)
|
|
498 (save-excursion
|
|
499 (goto-char (1- end))
|
|
500 (if (looking-at "[^\n]\n") (setq end (1+ end)))
|
|
501 (save-restriction
|
|
502 (let ((case-fold-search nil))
|
|
503 (narrow-to-region start end)
|
|
504 ;; translate silly "special character" codes into something we can use.
|
|
505 ;; we need to do this before nuking the recursive backspace codes.
|
|
506 ;;
|
|
507 ;; Note that mostly these are used as modifiers, like "h(\bQsub-dot)\bQ"
|
|
508 ;; meaning h with a dot under it. We don't handle any of that...
|
|
509 ;;
|
|
510 (goto-char (point-min))
|
|
511 (while (re-search-forward "(\bQ[-a-z0-9*$ ]+)\bQ" nil t)
|
|
512 (goto-char (match-beginning 0))
|
|
513 (let ((s (point))
|
|
514 (e (match-end 0)))
|
|
515 (forward-char 3)
|
|
516 (if (cond
|
|
517 ((looking-at "circumflex") (insert ?^) t)
|
|
518 ((looking-at "brace") (insert ?\{) t)
|
|
519 ((looking-at "tilda") (insert ?\~) t)
|
|
520 ((looking-at "prime") (insert ?\') t)
|
|
521 ((looking-at "accent grave") (insert ?\`) t)
|
|
522 ((looking-at "accent acute") (insert ?\264) t)
|
|
523 ((looking-at "sub-diaeresis") (insert ?\250) t)
|
|
524 ((looking-at "macron") (insert ?\257) t)
|
|
525 ((looking-at "a-e") (insert ?\346) t)
|
|
526 ((looking-at "curly-N") (insert ?\361) t)
|
|
527 ((looking-at "sub-macron") (insert ?\367) t)
|
|
528 ((looking-at "slash-o") (insert ?\370) t)
|
|
529 ((looking-at "cidilla") (insert ?\371) t)
|
|
530 ((looking-at "sup-circle") (insert ?\372) t)
|
|
531 ((looking-at "macron-tilda") (insert ?\373) t)
|
|
532 ((looking-at "hachek") (insert ?\374) t)
|
|
533 ((looking-at "sub-breve") (insert ?\375) t)
|
|
534 ((looking-at "breve") (insert ?\376) t)
|
|
535 ((looking-at "sub-dot") (insert ?\377) t)
|
|
536 ((looking-at "double-bar-\\$") (insert ?$) t)
|
|
537 ;; talk about your special-purpose characters...
|
|
538 ((looking-at "10\\*10\\*100")
|
|
539 (delete-region s e)
|
|
540 (insert "10^10^100")
|
|
541 nil)
|
|
542 ((looking-at "plus squareroot -1")
|
|
543 (delete-region s e)
|
|
544 (insert "sqrt(-1)")
|
|
545 nil)
|
|
546 ;; We don't handle these yet:
|
|
547 ;; aleph ayin beth breve c-bar check daleth double-arrows
|
|
548 ;; double-half-arrows double-hyphen edh fermata-up fermata-down
|
|
549 ;; fist flat-sign g-sub-macron gimel hachek he heth kaph lamed
|
|
550 ;; mem natural-sign nun parallel pe presa prime qoph radical
|
|
551 ;; radical-sign resh sadhe samekh shin sin slur-down spade
|
|
552 ;; stacked-commas tau teth thorn triple-bond waw yod yogh
|
|
553 ;; zayin "* * *" sadhe(final) "3 character overbar"
|
|
554 (t nil))
|
|
555 (progn
|
|
556 (delete-region s (+ s 3))
|
|
557 (delete-region (+ s 1) (- e 2))))))
|
|
558
|
|
559 ;; nuke silly recursive backspace codes
|
|
560 (goto-char (point-min))
|
|
561 (while (search-forward "|\bB" nil t)
|
|
562 (goto-char (point-min))
|
|
563 (save-excursion
|
|
564 (while (search-forward "|\bB" nil t)
|
|
565 (delete-char -3)
|
|
566 (insert "\b"))))
|
|
567 ;; convert @ to ~
|
|
568 (goto-char (point-min))
|
|
569 (while (search-forward "@" nil t)
|
|
570 (delete-char -1) (insert "~")
|
|
571 (if webster-fontify
|
|
572 (webster-fontify (- (point) 1) (point) 'webster-bold-italic)))
|
|
573 ;; now convert lots of other magic codes...
|
|
574 (goto-char (point-min))
|
|
575 (while (search-forward "\b" nil t)
|
|
576 (delete-char -1)
|
|
577 (forward-char -1)
|
|
578 (cond
|
|
579
|
|
580 ((looking-at "([MXYAIJ]")
|
|
581 ;; start smallcaps/italic/bold/super/sub/subitalic
|
|
582 (looking-at "([MXYAIJ]\\([^\)]*\\))")
|
|
583 (let ((start (match-beginning 1))
|
|
584 (end (match-end 1)))
|
|
585 (and (not nointern) (looking-at "(M")
|
|
586 (webster-intern (buffer-substring start end)))
|
|
587 (if webster-fontify
|
|
588 (let ((c (char-after (1- start))))
|
|
589 (webster-fontify start end
|
|
590 (cond ((= ?M c) 'webster-small)
|
|
591 ((= ?X c) 'webster-italic)
|
|
592 ((= ?Y c) 'webster-bold)
|
|
593 ((= ?A c) 'webster-superscript)
|
|
594 ((= ?I c) 'webster-subscript)
|
|
595 ((= ?J c) 'webster-subscript)
|
|
596 )
|
|
597 (= ?M c))))))
|
|
598
|
|
599 ;; #### dubious
|
|
600 ((looking-at "([BGR]") ; start greek/APL/symbol
|
|
601 (and webster-fontify
|
|
602 (looking-at "(\\(.\\)[^\)]*)\^H\\1")
|
|
603 (let ((c (char-after (1- (match-beginning 1)))))
|
|
604 (webster-fontify
|
|
605 (match-beginning 0) (match-end 0) 'webster-small))))
|
|
606
|
|
607 ((looking-at ")[ABGIJMRXY]") ; end font-shift
|
|
608 nil)
|
|
609
|
|
610 ((looking-at "<(\\|(<")
|
|
611 (insert (if webster-iso8859/1 ?\253 "<<"))
|
|
612 (if webster-fontify
|
|
613 (let ((p (point))
|
|
614 (e (and (save-excursion (search-forward ")\b>" nil t))
|
|
615 (match-beginning 0))))
|
|
616 (if e
|
|
617 (webster-fontify p e 'webster-italic)))))
|
|
618
|
|
619 ((looking-at ")>\\|>)")
|
|
620 (insert (if webster-iso8859/1 ?\273 ">>")))
|
|
621
|
|
622 ;; #### dubious
|
|
623 ((looking-at "[a-z\346][-._]") ; lineover,dotover/under,over/underbar
|
|
624 (insert (following-char))
|
|
625 (if webster-fontify
|
|
626 (webster-fontify (- (point) 1) (point) 'webster-underline)))
|
|
627
|
|
628 ((looking-at "[a-zA-Z]:") ; umlaut
|
|
629 (let (c)
|
|
630 (if (and webster-iso8859/1
|
|
631 (setq c (cdr (assq (following-char) webster-umlauts))))
|
|
632 (insert c)
|
|
633 (insert (following-char))
|
|
634 (insert (if webster-iso8859/1 ?\250 ?:)))))
|
|
635
|
|
636 ((looking-at "[\"~][a-zA-Z]") ; umlaut
|
|
637 (let (c)
|
|
638 (delete-char 1)
|
|
639 (if (and webster-iso8859/1
|
|
640 (setq c (cdr (assq (following-char) webster-umlauts))))
|
|
641 (insert c)
|
|
642 (insert (following-char))
|
|
643 (insert (if webster-iso8859/1 ?\250 ?:)))
|
|
644 (insert " ")
|
|
645 (forward-char -1)))
|
|
646
|
|
647 ((looking-at "[a-zA-Z]\)") ; grave
|
|
648 (let (c)
|
|
649 (if (and webster-iso8859/1
|
|
650 (setq c (cdr (assq (following-char) webster-graves))))
|
|
651 (insert c)
|
|
652 (insert (following-char))
|
|
653 (insert "`"))))
|
|
654
|
|
655 ((looking-at ">[a-zA-Z]") ; grave
|
|
656 (let (c)
|
|
657 (delete-char 1)
|
|
658 (if (and webster-iso8859/1
|
|
659 (setq c (cdr (assq (following-char) webster-graves))))
|
|
660 (insert c)
|
|
661 (insert (following-char))
|
|
662 (insert "`"))
|
|
663 (insert " ")
|
|
664 (forward-char -1)))
|
|
665
|
|
666 ((looking-at "[a-zES]\(") ; acute
|
|
667 (let (c)
|
|
668 (if (and webster-iso8859/1
|
|
669 (setq c (cdr (assq (following-char) webster-acutes))))
|
|
670 (insert c)
|
|
671 (insert (following-char))
|
|
672 (insert (if webster-iso8859/1 ?\264 ?\')))))
|
|
673
|
|
674 ((looking-at "<[a-zA-Z]") ; acute
|
|
675 (let (c)
|
|
676 (delete-char 1)
|
|
677 (if (and webster-iso8859/1
|
|
678 (setq c (cdr (assq (following-char) webster-acutes))))
|
|
679 (insert c)
|
|
680 (insert (following-char))
|
|
681 (insert (if webster-iso8859/1 ?\264 ?\')))
|
|
682 (insert " ")
|
|
683 (forward-char -1)))
|
|
684
|
|
685 ((looking-at ";[Cc]") ; ccedilla
|
|
686 (delete-char 1)
|
|
687 (if webster-iso8859/1
|
|
688 (progn
|
|
689 (insert (if (= (following-char) ?C) ?\307 ?\347))
|
|
690 (insert ? ) (forward-char -1))
|
|
691 (forward-char 1)
|
|
692 (insert ?\,)))
|
|
693
|
|
694 ((looking-at "|S") ; section
|
|
695 (insert (if webster-iso8859/1 ?\247 "SS")))
|
|
696
|
|
697 ((looking-at "|q") ; paragraph
|
|
698 (insert (if webster-iso8859/1 ?\266 "PP")))
|
|
699
|
|
700 ((looking-at "*o") ; centerdot
|
|
701 (insert (if webster-iso8859/1 ?\267 ?\*)))
|
|
702
|
|
703 ((looking-at "+=") ; plusminus
|
|
704 (insert (if webster-iso8859/1 ?\261 "+/-")))
|
|
705
|
|
706 ((looking-at "-:") ; division
|
|
707 (insert (if webster-iso8859/1 ?\367 "+/-")))
|
|
708
|
|
709 ((looking-at "-[xX]") ; multiplication
|
|
710 (insert (if webster-iso8859/1 ?\327 "+/-")))
|
|
711
|
|
712 ((looking-at "-m") (insert "--"))
|
|
713 ((looking-at "-n") (insert "-"))
|
|
714 ((looking-at "-/") (insert "\\"))
|
|
715 ((looking-at ")|") (insert ?\[))
|
|
716 ((looking-at "|)") (insert ?\]))
|
|
717 ((looking-at "-3") (insert "..."))
|
|
718 ((looking-at "=\\\\") (insert "$"))
|
|
719
|
|
720 ((looking-at "'o") ; degree
|
|
721 (insert (if webster-iso8859/1 ?\260 ?\*)))
|
|
722
|
|
723 ((or (looking-at "nj") ; nj symbol
|
|
724 (looking-at "|-") ; dagger
|
|
725 (looking-at "|=") ; doubledagger
|
|
726 (looking-at "|o") ; lowerphi
|
|
727 (looking-at "'b") ; stroke
|
|
728 )
|
|
729 (if webster-fontify
|
|
730 (webster-fontify (point) (+ (point) 2) 'webster-bold))
|
|
731 (insert " ")
|
|
732 (forward-char -2))
|
|
733
|
|
734 ((looking-at "[cC]\371") ; (\bQcidilla)\bQ
|
|
735 (if webster-iso8859/1
|
|
736 (insert (if (= (following-char) ?C) ?\307 ?\347))
|
|
737 (forward-char 1)
|
|
738 (insert ?\,)))
|
|
739
|
|
740 ; ((or (looking-at "[a-zA-Z]\250") ; (\bQsub-diaeresis)\bQ
|
|
741 ; (looking-at "[a-zA-Z]\346") ; (\bQa-e)\bQ
|
|
742 ; (looking-at "[a-zA-Z]\361") ; (\bQcurly-N)\bQ
|
|
743 ; (looking-at "[a-zA-Z]\367") ; (\bQsub-macron)\bQ
|
|
744 ; (looking-at "[a-zA-Z]\370") ; (\bQslash-o)\bQ
|
|
745 ; (looking-at "[a-zA-Z]\371") ; (\bQcidilla)\bQ
|
|
746 ; (looking-at "[a-zA-Z]\372") ; (\bQsup-circle)\bQ
|
|
747 ; (looking-at "[a-zA-Z]\373") ; (\bQmacron-tilda)\bQ
|
|
748 ; (looking-at "[a-zA-Z]\374") ; (\bQhachek)\bQ
|
|
749 ; (looking-at "[a-zA-Z]\375") ; (\bQsub-breve)\bQ
|
|
750 ; (looking-at "[a-zA-Z]\376") ; (\bQbreve)\bQ
|
|
751 ; (looking-at "[a-zA-Z]\377") ; (\bQsub-dot)\bQ
|
|
752 ; )
|
|
753 ; (forward-char 1) (insert " ") (forward-char -1)
|
|
754 ; (webster-fontify (1- (point)) (point) 'webster-underline))
|
|
755
|
|
756 ((looking-at "/[a-zA-Z]") ; greek
|
|
757 (forward-char 1)
|
|
758 (insert " <")
|
|
759 (forward-char 1)
|
|
760 (insert ?\>)
|
|
761 (forward-char -5))
|
|
762
|
|
763 ;; overstrike
|
|
764 ((looking-at (format "[%c][%c]" (following-char) (following-char)))
|
|
765 (insert (following-char))
|
|
766 (if webster-fontify
|
|
767 (webster-fontify (- (point) 1) (point) 'webster-bold)))
|
|
768
|
|
769 (t ; ## debug
|
|
770 (insert (following-char))
|
|
771 (insert "\b")
|
|
772 (insert (buffer-substring (+ 1 (point)) (+ 2 (point))))
|
|
773 ))
|
|
774 (delete-char 2))
|
|
775
|
|
776 (goto-char (point-min))
|
|
777 (setq start (point)
|
|
778 end (point-max))
|
|
779 (widen)
|
|
780 (beginning-of-line)
|
|
781 (narrow-to-region (point) end)
|
|
782 (goto-char start)
|
|
783 ;; (fill-region-as-paragraph (point-min) (point-max))
|
|
784 (while (not (eobp))
|
|
785 (setq start (point))
|
|
786 (skip-chars-forward "^ \n\t")
|
|
787 (if (>= (current-column) fill-column)
|
|
788 (progn
|
|
789 (goto-char start)
|
|
790 (delete-horizontal-space)
|
|
791 (insert "\n" (or fill-prefix "")))
|
|
792 (skip-chars-forward " \n\t")))
|
|
793 ))))
|
|
794
|
|
795
|
|
796 (defun webster-pos (start end)
|
|
797 (save-excursion
|
|
798 (goto-char start)
|
|
799 (cond ((and (= start (1- end)) (looking-at "n")) "noun")
|
|
800 ((or (not webster-fontify) (/= start (- end 2)))
|
|
801 (buffer-substring start end))
|
|
802 ((looking-at "ac") "adjective combinational form")
|
|
803 ((looking-at "aj") "adjective")
|
|
804 ((looking-at "as") "adjective suffix")
|
|
805 ((looking-at "av") "adverb")
|
|
806 ((looking-at "ca") "adjective combinational form")
|
|
807 ((looking-at "cf") "combinational form")
|
|
808 ((looking-at "cj") "conjunction")
|
|
809 ((looking-at "da") "definite article")
|
|
810 ((looking-at "ia") "indefinite article")
|
|
811 ((looking-at "ij") "interjection")
|
|
812 ((looking-at "is") "interjection suffix")
|
|
813 ((looking-at "js") "adjective suffix")
|
|
814 ((looking-at "nc") "noun combinational form")
|
|
815 ((looking-at "np") "noun plural suffix")
|
|
816 ((looking-at "ns") "noun suffix")
|
|
817 ((looking-at "pf") "prefix")
|
|
818 ((looking-at "pn") "pronoun")
|
|
819 ((looking-at "pp") "preposition")
|
|
820 ((looking-at "sf") "verb suffix")
|
|
821 ((looking-at "tm") "trademark")
|
|
822 ((looking-at "va") "verbal auxilliary")
|
|
823 ((looking-at "vb") "verb")
|
|
824 ((looking-at "vc") "verb combinational form")
|
|
825 ((looking-at "vi") "verb intransitive")
|
|
826 ((looking-at "vm") "verb impersonal")
|
|
827 ((looking-at "vp") "verb imperfect")
|
|
828 ((looking-at "vs") "verb suffix")
|
|
829 ((looking-at "vt") "verb transitive")
|
|
830 (t (buffer-substring start end)))))
|
|
831
|
|
832
|
|
833 (defun webster-convert ()
|
|
834 (goto-char (point-min))
|
|
835 ;; nuke the continuation lines
|
|
836 (save-excursion
|
|
837 (while (re-search-forward "^C:" nil t)
|
|
838 (forward-char -2)
|
|
839 (while (looking-at "^C:")
|
|
840 (forward-line 1))
|
|
841 (forward-line -1)
|
|
842 (while (looking-at "^C:")
|
|
843 (forward-char -1)
|
|
844 (let ((n (- (point) (save-excursion (beginning-of-line) (point)))))
|
|
845 (delete-char 3)
|
|
846 ;; What a stupid format! (example: "fat")
|
|
847 (if (= n 79) (insert " "))
|
|
848 (beginning-of-line)))))
|
|
849 (goto-char (point-min))
|
|
850 (let ((last-type nil)
|
|
851 (this-type nil)
|
|
852 (last-part nil))
|
|
853 (while (not (eobp))
|
|
854 (setq this-type (following-char))
|
|
855 (cond
|
|
856 ((looking-at "^WORD ")
|
|
857 (let ((p (point)))
|
|
858 (end-of-line)
|
|
859 (delete-region p (point))))
|
|
860
|
|
861 ((looking-at "^21[12] ") ; reply to a LIST command; one line.
|
|
862 (delete-char 4))
|
|
863 ((looking-at "^220 ") ; reply to a LIST command; intern the results.
|
|
864 (let ((p (point)))
|
|
865 (if (eq (preceding-char) ?\n) (setq p (1- p)))
|
|
866 (end-of-line)
|
|
867 (delete-region p (point)))
|
|
868 (insert "\n")
|
|
869 (while (not (or (eobp) (looking-at "\n\n")))
|
|
870 (forward-line 1)
|
|
871 (insert " ")
|
|
872 (let (s e)
|
|
873 (while (looking-at "[^\n;]+;")
|
|
874 (webster-intern (buffer-substring (setq s (match-beginning 0))
|
|
875 (setq e (1- (match-end 0)))))
|
|
876 (goto-char (match-end 0))
|
|
877 (insert " ")
|
|
878 (if webster-fontify
|
|
879 (webster-fontify s e 'webster-bold t)))
|
|
880 (if (looking-at "\n")
|
|
881 nil
|
|
882 (webster-intern
|
|
883 (buffer-substring (setq s (point))
|
|
884 (progn (end-of-line) (setq e (point)))))
|
|
885 (if webster-fontify
|
|
886 (webster-fontify s e 'webster-bold t)))
|
|
887 )))
|
|
888
|
|
889 ((looking-at "^\n")
|
|
890 (delete-char 1))
|
|
891
|
|
892 ((looking-at "^\\(200\\|221\\|PREFIX\\|LIST\\|EXACT\\)[- ]")
|
|
893 ;; just toss these.
|
|
894 (let ((p (point)))
|
|
895 (if (eq (preceding-char) ?\n) (setq p (1- p)))
|
|
896 (end-of-line)
|
|
897 (delete-region p (point))))
|
|
898
|
|
899 ((looking-at "^F:")
|
|
900 ;; First record: F:entname;homono;prefsuf;dots;accents;pos;posjoin;pos2
|
|
901 (delete-char 2)
|
|
902 (search-forward ";")
|
|
903 (let ((p (1- (point)))
|
|
904 homonym prefix dots pos posj pos2)
|
|
905 (if (looking-at "[0-9]+")
|
|
906 (setq homonym (buffer-substring (point) (match-end 0))))
|
|
907 (search-forward ";")
|
|
908 (if (looking-at "[^;]+")
|
|
909 (setq prefix (buffer-substring (point) (match-end 0))))
|
|
910 (search-forward ";")
|
|
911 (if (looking-at "[0-9]+")
|
|
912 (setq dots (append (buffer-substring (point) (match-end 0))
|
|
913 nil)))
|
|
914 (search-forward ";")
|
|
915 ;; ignore accents
|
|
916 (search-forward ";")
|
|
917 (if (looking-at "[a-z]+")
|
|
918 (setq pos (webster-pos (point) (match-end 0))))
|
|
919 (search-forward ";")
|
|
920 (if (looking-at "[a-z]+")
|
|
921 (setq posj (webster-pos (point) (match-end 0))))
|
|
922 (if (looking-at "[a-z]+")
|
|
923 (setq pos2 (webster-pos (point) (match-end 0))))
|
|
924 (end-of-line)
|
|
925 (delete-region p (point))
|
|
926 (beginning-of-line)
|
|
927 (insert " ")
|
|
928 (let ((e (save-excursion (end-of-line) (point))))
|
|
929 (webster-intern (buffer-substring (point) e))
|
|
930 (if webster-fontify
|
|
931 (webster-fontify (point) e 'webster-bold t)))
|
|
932 (beginning-of-line)
|
|
933 (if (not homonym)
|
|
934 (insert " ")
|
|
935 (let ((p (point)))
|
|
936 (insert homonym)
|
|
937 (if webster-fontify
|
|
938 (webster-fontify p (point) 'webster-bold-italic))))
|
|
939 (forward-char 1)
|
|
940 (while dots
|
|
941 (forward-char (- (car dots) ?0))
|
|
942 (insert ".")
|
|
943 (setq dots (cdr dots)))
|
|
944 (end-of-line)
|
|
945 (let ((p (point)))
|
|
946 (if pos (insert " " pos))
|
|
947 (if posj (insert " " posj))
|
|
948 (if pos2 (insert " " pos2))
|
|
949 (if (and webster-fontify (or pos posj pos2))
|
|
950 (webster-fontify p (point) 'webster-italic)))
|
|
951 (insert " ")
|
|
952 ;; prefix/suffix is "p" or "s"; I don't know what it's for.
|
|
953 (setq last-part pos)))
|
|
954
|
|
955 ((looking-at "^P:")
|
|
956 ;; Pronunciation: P:text
|
|
957 (delete-char 2) (delete-char -1)
|
|
958 (insert " \\")
|
|
959 (let ((p (point))
|
|
960 (fill-prefix " "))
|
|
961 (end-of-line)
|
|
962 (insert " ")
|
|
963 (if webster-fontify
|
|
964 (progn
|
|
965 (webster-fontify (1- p) (1- (point)) 'webster-italic)
|
|
966 (forward-char -1)))
|
|
967 (webster-textify-region p (point))
|
|
968 (insert "\\")))
|
|
969
|
|
970 ((looking-at "E:")
|
|
971 ;; Etymology: E:text
|
|
972 (delete-char 2) (insert " [")
|
|
973 (let ((fill-prefix " "))
|
|
974 (webster-textify-region (point) (progn (end-of-line) (point))))
|
|
975 (insert "]"))
|
|
976
|
|
977 ((looking-at "S:")
|
|
978 ;; Synonym: S:text
|
|
979 (delete-char 2) (insert " ")
|
|
980 (let ((fill-prefix " "))
|
|
981 (webster-textify-region (point) (progn (end-of-line) (point)))))
|
|
982
|
|
983 ((looking-at "X:")
|
|
984 ;; Cross Reference: X:word;wrdsuper;wrdsubs;type;word2
|
|
985 (setq last-part nil)
|
|
986 (let (p word super sub type word2)
|
|
987 (delete-char 2)
|
|
988 (setq p (point))
|
|
989 (if (looking-at "[^;]+")
|
|
990 (setq word (upcase (buffer-substring (point) (match-end 0)))))
|
|
991 (search-forward ";")
|
|
992 (if (looking-at "[^;]+")
|
|
993 (setq super (buffer-substring (point) (match-end 0))))
|
|
994 (search-forward ";")
|
|
995 (if (looking-at "[^;]+")
|
|
996 (setq sub (buffer-substring (point) (match-end 0))))
|
|
997 (search-forward ";")
|
|
998 (if (looking-at "[0-9]+")
|
|
999 (setq type (string-to-int
|
|
1000 (buffer-substring (point) (match-end 0)))))
|
|
1001 (search-forward ";")
|
|
1002 (if (looking-at "[^;]+")
|
|
1003 (setq word2 (upcase (buffer-substring (point) (match-end 0)))))
|
|
1004 (delete-region p (point))
|
|
1005 (insert " ")
|
|
1006 (cond ((eq type 0) (insert "see (\bM" word ")\bM"))
|
|
1007 ((eq type 1) (insert "see (\bM" word ")\bM table"))
|
|
1008 ((eq type 2) (insert "### ILLEGAL XREF CODE 2"))
|
|
1009 ((eq type 3) (insert "see (\bM" word2 ")\bM at (\bM" word
|
|
1010 ")\bM table"))
|
|
1011 ((eq type 4) (insert "compare (\bM" word ")\bM"))
|
|
1012 ((eq type 5) (insert "compare (\bM" word ")\bM table"))
|
|
1013 ((eq type 6) (insert "called also (\bM" word ")\bM"))
|
|
1014 ((eq type 7) (insert "### ILLEGAL XREF CODE 7"))
|
|
1015 ((eq type 8) (insert "(\bYsyn)\bY see in addition (\bM" word
|
|
1016 ")\bM"))
|
|
1017 ((eq type 9) (insert "(\bYsyn)\bY see (\bM" word ")\bM"))
|
|
1018 (t (insert "#### ILLEGAL XREF CODE " (or type "nil"))))
|
|
1019 (let ((fill-prefix " "))
|
|
1020 (webster-textify-region p (point)))))
|
|
1021
|
|
1022 ((looking-at "D:")
|
|
1023 ;; Definition: D:snsnumber;snsletter;snssubno;pos;text
|
|
1024 (let (p n sub1 sub2 part)
|
|
1025 (setq p (point))
|
|
1026 (forward-char 2)
|
|
1027 (if (looking-at "[0-9]+")
|
|
1028 (setq n (buffer-substring (point) (match-end 0))))
|
|
1029 (search-forward ";")
|
|
1030 (if (looking-at "[a-z]+")
|
|
1031 (setq sub1 (buffer-substring (point) (match-end 0))))
|
|
1032 (search-forward ";")
|
|
1033 (if (looking-at "[0-9]+")
|
|
1034 (setq sub2 (buffer-substring (point) (match-end 0))))
|
|
1035 (search-forward ";")
|
|
1036 (if (looking-at "[a-z]+")
|
|
1037 (setq part (webster-pos (point) (match-end 0))))
|
|
1038 (search-forward ";")
|
|
1039 (delete-region p (point))
|
|
1040 (if (and sub2 (not (equal sub2 "1")))
|
|
1041 (setq sub1 " "))
|
|
1042 (if (and sub1 (not (equal sub1 "a")))
|
|
1043 (setq n " "))
|
|
1044 ;; If a Definition appears after a Label, don't print numbers
|
|
1045 ;; as the label has done that already.
|
|
1046 (if (eq last-type ?L)
|
|
1047 (setq n (and n " ") sub1 (and sub1 " ") sub2 (and sub2 " ")))
|
|
1048 (if (and part (not (equal part last-part)))
|
|
1049 (let ((p (point)))
|
|
1050 (insert " " part "\n")
|
|
1051 (if webster-fontify
|
|
1052 (webster-fontify p (1- (point)) 'webster-italic))
|
|
1053 (setq last-part part)))
|
|
1054 (indent-to (- 6 (length n)))
|
|
1055 (setq p (point))
|
|
1056 (if (and n (not (equal n "0")))
|
|
1057 (insert n " "))
|
|
1058 (if sub1 (insert " " sub1 " "))
|
|
1059 (if sub2 (insert " (" sub2 ") "))
|
|
1060 (insert ": ")
|
|
1061 (if webster-fontify
|
|
1062 (webster-fontify p (point) 'webster-bold-italic))
|
|
1063 (setq p (point))
|
|
1064 (end-of-line)
|
|
1065 (let ((fill-prefix (make-string (if sub2 17 (if sub1 12 9)) ? )))
|
|
1066 (webster-textify-region p (point)))))
|
|
1067
|
|
1068 ((looking-at "R:")
|
|
1069 ;; Run-on: R:name;dots;accents;pos1;posjoin;pos2
|
|
1070 (delete-char 2)
|
|
1071 (insert " ")
|
|
1072 (search-forward ";") (delete-char -1)
|
|
1073 (let ((beg (save-excursion (beginning-of-line) (+ (point) 2))))
|
|
1074 (webster-intern (buffer-substring beg (point)))
|
|
1075 (if webster-fontify
|
|
1076 (webster-fontify beg (point) 'webster-bold t)))
|
|
1077 (if (looking-at "[0-9]+")
|
|
1078 (let* ((dots (append (buffer-substring (point) (match-end 0))
|
|
1079 nil)))
|
|
1080 (delete-region (point) (match-end 0))
|
|
1081 (beginning-of-line)
|
|
1082 (forward-char 2)
|
|
1083 (while dots
|
|
1084 (forward-char (- (car dots) ?0))
|
|
1085 (insert ".")
|
|
1086 (setq dots (cdr dots)))))
|
|
1087 (search-forward ";") (delete-char -1)
|
|
1088 ;; throw away the accents
|
|
1089 (let ((p (point)))
|
|
1090 (search-forward ";")
|
|
1091 (delete-region p (point)))
|
|
1092 (insert " ")
|
|
1093 (if (looking-at "[a-z][a-z]?;")
|
|
1094 (let* ((start (point))
|
|
1095 (end (1- (match-end 0)))
|
|
1096 (pos (webster-pos start end)))
|
|
1097 (delete-region start end)
|
|
1098 (insert pos)
|
|
1099 (if webster-fontify
|
|
1100 (webster-fontify start (point) 'webster-italic))))
|
|
1101 (cond ((search-forward ";" nil t) (delete-char -1) (insert " ")))
|
|
1102 (cond ((search-forward ";" nil t) (delete-char -1) (insert " "))))
|
|
1103
|
|
1104 ((looking-at "L:")
|
|
1105 ;; Label: L:snsnumber;snsletter;snssubno;text
|
|
1106 (let (p n sub1 sub2)
|
|
1107 (setq p (point))
|
|
1108 (forward-char 2)
|
|
1109 (if (looking-at "[0-9]+")
|
|
1110 (setq n (buffer-substring (point) (match-end 0))))
|
|
1111 (search-forward ";")
|
|
1112 (if (looking-at "[a-z]+")
|
|
1113 (setq sub1 (buffer-substring (point) (match-end 0))))
|
|
1114 (search-forward ";")
|
|
1115 (if (looking-at "[0-9]+")
|
|
1116 (setq sub2 (buffer-substring (point) (match-end 0))))
|
|
1117 (search-forward ";")
|
|
1118 (delete-region p (point))
|
|
1119 (if (and sub2 (not (equal sub2 "1")))
|
|
1120 (setq sub1 " "))
|
|
1121 (if (and sub1 (not (equal sub1 "a")))
|
|
1122 (setq n " "))
|
|
1123 (indent-to (- 6 (length n)))
|
|
1124 (setq p (point))
|
|
1125 (if (not (equal n "0"))
|
|
1126 (insert (or n " ") " "))
|
|
1127 (if sub1 (insert " " sub1))
|
|
1128 (if sub2 (insert " (" sub2 ")"))
|
|
1129 (insert " ")
|
|
1130 (if webster-fontify
|
|
1131 (webster-fontify p (point) 'webster-bold-italic))
|
|
1132 (setq p (point))
|
|
1133 (end-of-line)
|
|
1134 (let ((fill-prefix (make-string (if sub2 17 (if sub1 12 9)) ? )))
|
|
1135 (webster-textify-region p (point)))))
|
|
1136
|
|
1137 ((looking-at "V:")
|
|
1138 ;; Variant: V:name;dots;accents;level1()level2
|
|
1139 (delete-char 2)
|
|
1140 (let ((p (point))
|
|
1141 beg)
|
|
1142 (search-forward ";") (delete-char -1)
|
|
1143 (webster-intern (buffer-substring
|
|
1144 (save-excursion (beginning-of-line)
|
|
1145 (setq beg (point)))
|
|
1146 (point)))
|
|
1147 (if webster-fontify
|
|
1148 (webster-fontify beg (point) 'webster-bold t))
|
|
1149 (if (looking-at "[0-9]+")
|
|
1150 (let* ((dots (append (buffer-substring (point) (match-end 0))
|
|
1151 nil)))
|
|
1152 (delete-region (point) (match-end 0))
|
|
1153 (beginning-of-line)
|
|
1154 (while dots
|
|
1155 (forward-char (- (car dots) ?0))
|
|
1156 (insert ".")
|
|
1157 (setq dots (cdr dots)))))
|
|
1158 (search-forward ";") ; skip accents
|
|
1159 (delete-region (1- (point))
|
|
1160 (save-excursion (end-of-line) (point)))
|
|
1161 (let ((fill-prefix " "))
|
|
1162 (webster-textify-region p (point) t)))
|
|
1163 (save-excursion
|
|
1164 (beginning-of-line)
|
|
1165 (cond ((eq last-type ?F) (delete-char -1))
|
|
1166 ((eq last-type ?V) (delete-char -1) (insert "; "))
|
|
1167 (t (insert " ")))))
|
|
1168
|
|
1169 ((looking-at ".\n")
|
|
1170 (delete-char 1))
|
|
1171 ((looking-at "22[0-9] ")
|
|
1172 (delete-region (point) (save-excursion (end-of-line) (point))))
|
|
1173 ((looking-at "\n")
|
|
1174 nil)
|
|
1175 (t
|
|
1176 (insert "* ")))
|
|
1177 (setq last-type this-type)
|
|
1178 (forward-line 1)
|
|
1179 (while (save-excursion
|
|
1180 (and (not (bobp))
|
|
1181 (progn (forward-line -1) (looking-at "\n"))))
|
|
1182 (delete-char -1))
|
|
1183 ))
|
|
1184 (goto-char (point-min))
|
|
1185 (cond ((search-forward "\^H" nil t)
|
|
1186 (goto-char (point-min))
|
|
1187 (insert
|
|
1188 "\n****\tThis definition contains unrecognized font-change codes."
|
|
1189 "\n****\tPlease tell jwz.\n\n")
|
|
1190 (goto-char (point-min))))
|
|
1191
|
|
1192 ;; lay down the default font; don't put it over the spaces and tabs on
|
|
1193 ;; the beginning of the line so that those space as if it was a fixed
|
|
1194 ;; width font. There must be a better way than
|
|
1195 (if webster-fontify
|
|
1196 (save-excursion
|
|
1197 (let (e)
|
|
1198 (goto-char (point-min))
|
|
1199 (while (not (eobp))
|
|
1200 (skip-chars-forward " \t")
|
|
1201 ;; avoid extent overlaps; should be able to use extent priorities
|
|
1202 ;; to obviate this, but it's late.
|
|
1203 (while (setq e (extent-at (point)))
|
|
1204 (goto-char (1+ (extent-end-position e))))
|
|
1205 (setq e (make-extent (point) (progn (forward-line 1) (point))))
|
|
1206 (set-extent-face e 'webster)))))
|
|
1207 )
|
|
1208
|
|
1209
|
|
1210 ;; Codes:
|
|
1211 ;;
|
|
1212 ;; (A start superscript catalan
|
|
1213 ;; (B start unknown mixed number
|
|
1214 ;; (G start greek alpha
|
|
1215 ;; (I start subscript alcohol
|
|
1216 ;; (J start subitalic mixed number
|
|
1217 ;; (M start small mitten
|
|
1218 ;; (Q start special mitzvah
|
|
1219 ;; (R start APL mixed
|
|
1220 ;; (X start italic everywhere...
|
|
1221 ;; (Y start bold everywhere...
|
|
1222 ;; )A end superscript catalan
|
|
1223 ;; )B end unknown mixed number
|
|
1224 ;; )G end greek alpha
|
|
1225 ;; )I end subscript alcohol
|
|
1226 ;; )J end subitalic mixed number
|
|
1227 ;; )M end small mitten
|
|
1228 ;; )Q end special mitzvah
|
|
1229 ;; )R end APL mixed
|
|
1230 ;; )X end italic everywhere...
|
|
1231 ;; )Y end bold everywhere...
|
|
1232 ;; "a a-umlaut acetoacetic acid
|
|
1233 ;; "e e-umlaut agio
|
|
1234 ;; "i i-umlaut alcaic
|
|
1235 ;; "o o-umlaut ale
|
|
1236 ;; "u u-umlaut alpenglow
|
|
1237 ;; a: a-umlaut aardvark
|
|
1238 ;; n: n-umlaut pogy
|
|
1239 ;; o: o-umlaut coccyx
|
|
1240 ;; s: s-umlaut centrifugation
|
|
1241 ;; u: u-umlaut accouter
|
|
1242 ;; w: w-umlaut bourgeois
|
|
1243 ;; I: I-umlaut natural
|
|
1244 ;; ~a a-umlaut alcove
|
|
1245 ;; ~e e-umlaut Boxer
|
|
1246 ;; ~i i-umlaut Cistercian
|
|
1247 ;; ~o o-umlaut alcove
|
|
1248 ;; ~u u-umlaut Boxer
|
|
1249 ;; ~E E-umlaut arris
|
|
1250 ;; ~O O-umlaut prix fixe
|
|
1251 ;; >e e-grave arriere-pensee
|
|
1252 ;; >a a-grave pompano
|
|
1253 ;; >u u-grave coca
|
|
1254 ;; >E E-grave
|
|
1255 ;; u) u-grave
|
|
1256 ;; o) o-grave
|
|
1257 ;; i) i-grave
|
|
1258 ;; s) s-grave
|
|
1259 ;; ;C C-cedilla compendia
|
|
1260 ;; ;c c-cedilla babassu
|
|
1261 ;; <E E-acute
|
|
1262 ;; <a a-acute
|
|
1263 ;; <e e-acute
|
|
1264 ;; S( S-acute
|
|
1265 ;; c( c-acute
|
|
1266 ;; i( i-acute
|
|
1267 ;; o( o-acute
|
|
1268 ;; r( r-acute
|
|
1269 ;; s( s-acute
|
|
1270 ;; y( y-acute
|
|
1271 ;; )> guillemotright everywhere...
|
|
1272 ;; <( guillemotleft everywhere...
|
|
1273 ;; (< guillemotleft (?) come
|
|
1274 ;; -m longdash pi
|
|
1275 ;; n_ nj babbling
|
|
1276 ;; 'o degree
|
|
1277 ;; |) ]
|
|
1278 ;; |- dagger
|
|
1279 ;; |= doubledagger
|
|
1280 ;; |S section
|
|
1281 ;; |o lower-phi
|
|
1282 ;; |q paragraph paragraph
|
|
1283 ;; =\ "$"
|
|
1284 ;; (< "<"
|
|
1285 ;; (| "["
|
|
1286 ;; 'b stroke
|
|
1287 ;; *o centerdot
|
|
1288 ;; += plusminus
|
|
1289 ;; -/ \
|
|
1290 ;; -3 "..."
|
|
1291 ;; -: division
|
|
1292 ;; -X multiplication
|
|
1293 ;; -n "-"
|
|
1294 ;; -x multiplication
|
|
1295 ;; '' ' overstrike
|
|
1296 ;; :: : overstrike
|
|
1297 ;; ;; ; overstrike
|
|
1298 ;; MM M overstrike
|
|
1299 ;; a- a-lineover
|
|
1300 ;; e- e-lineover
|
|
1301 ;; i- i-lineover
|
|
1302 ;; o- o-lineover
|
|
1303 ;; u- u-lineover
|
|
1304 ;; y- y-lineover
|
|
1305 ;; A- A-lineover
|
|
1306 ;; E- E-lineover
|
|
1307 ;; I- I-lineover
|
|
1308 ;; O- O-lineover
|
|
1309 ;; U- U-lineover
|
|
1310 ;; Q- Q-lineover2
|
|
1311 ;; a. a-dotover
|
|
1312 ;; e. e-dotover
|
|
1313 ;; m. m-dotover
|
|
1314 ;; n. n-dotover
|
|
1315 ;; o. o-dotover
|
|
1316 ;; r. r-dotover
|
|
1317 ;; u. u-dotover
|
|
1318 ;; e_ e-lineunder
|
|
1319 ;; h_ h-lineunder
|
|
1320 ;; k_ k-lineunder
|
|
1321 ;; r- r-lineunder
|
|
1322 ;; r_ r-lineunder
|
|
1323 ;; t_ t-lineunder
|
|
1324 ;; u_ u-lineunder
|
|
1325 ;; k- k-dotunder
|
|
1326
|
|
1327 ;; t(\bQsub-dot)\bQ t-dotunder
|
|
1328 ;; s(\bQsub-dot)\bQ s-dotunder
|
|
1329 ;; h(\bQsub-dot)\bQ h-dotunder aceldama
|
|
1330 ;; n(\bQsub-dot)\bQ n-dotunder
|
|
1331 ;; r(\bQsub-dot)\bQ r-dotunder
|
|
1332 ;; d(\bQsub-dot)\bQ d-dotunder
|
|
1333 ;; z(\bQsub-dot)\bQ z-dotunder
|
|
1334 ;; l(\bQsub-dot)\bQ l-dotunder
|
|
1335 ;; S(\bQsub-dot)\bQ S-dotunder
|
|
1336 ;; H(\bQsub-dot)\bQ H-dotunder
|
|
1337 ;; o(\bQsub-dot)\bQ o-dotunder
|
|
1338 ;; a(\bQsub-dot)\bQ a-dotunder
|
|
1339 ;; e(\bQbreve)\bQ e-breve
|
|
1340 ;; u(\bQbreve)\bQ u-breve
|
|
1341 ;; i(\bQbreve)\bQ i-breve
|
|
1342 ;; a(\bQbreve)\bQ a-breve
|
|
1343 ;; A(\bQbreve)\bQ A-breve
|
|
1344 ;; s(\bQbreve)\bQ s-breve
|
|
1345 ;; n(\bQbreve)\bQ n-breve
|
|
1346 ;; E(\bQbreve)\bQ E-breve
|
|
1347 ;; y(\bQbreve)\bQ y-breve
|
|
1348 ;; o(\bQbreve)\bQ o-breve
|
|
1349 ;; h(\bQsub-breve)\bQ h-breve
|
|
1350 ;; e(\bQhachek)\bQ e-hachek
|
|
1351 ;; s(\bQhachek)\bQ s-hachek
|
|
1352 ;; z(\bQhachek)\bQ z-hachek
|
|
1353 ;; c(\bQhachek)\bQ c-hachek
|
|
1354 ;; j(\bQhachek)\bQ j-hachek
|
|
1355 ;; i(\bQhachek)\bQ i-hachek
|
|
1356 ;; u(\bQhachek)\bQ u-hachek
|
|
1357 ;; g(\bQhachek)\bQ g-hachek
|
|
1358 ;; r(\bQhachek)\bQ r-hachek
|
|
1359 ;; a(\bQhachek)\bQ a-hachek
|
|
1360 ;; C(\bQhachek)\bQ C-hachek
|
|
1361 ;; a(\bQmacron-tilda)\bQ a-macrontilda
|
|
1362 ;; i(\bQmacron-tilda)\bQ i-macrontilda
|
|
1363 ;; e(\bQmacron-tilda)\bQ e-macrontilda
|
|
1364 ;; a(\bQsup-circle)\bQ a-circleover
|
|
1365 ;; A(\bQsup-circle)\bQ A-circleover
|
|
1366 ;; e(\bQcidilla)\bQ e-cedilla
|
|
1367 ;; o(\bQcidilla)\bQ o-cedilla
|
|
1368 ;; a(\bQcidilla)\bQ a-cedilla
|
|
1369 ;; z(\bQsub-diaeresis)\bQ z-umlautunder
|
|
1370 ;; r(\bQsub-diaeresis)\bQ r-umlautunder
|
|
1371 ;; t(\bQsub-macron)\bQ t-lineunder
|
|
1372 ;; B(\bQ3 character overbar)\bQ B-lineover3
|
|
1373
|
|
1374 ;; (\bQa-e)\bQ- ae-overbar (?) herring
|
|
1375
|
|
1376 ;; "U unknown
|
|
1377 ;; '- unknown
|
|
1378 ;; 'a unknown
|
|
1379 ;; (j unknown
|
|
1380 ;; )o unknown
|
|
1381 ;; - unknown
|
|
1382 ;; -0 unknown
|
|
1383 ;; -> unknown
|
|
1384 ;; -M unknown
|
|
1385 ;; -N unknown
|
|
1386 ;; -O unknown
|
|
1387 ;; -s unknown
|
|
1388 ;; ;( unknown
|
|
1389 ;; <' unknown
|
|
1390 ;; <A unknown
|
|
1391 ;; =S unknown
|
|
1392 ;; >' unknown
|
|
1393 ;; B unknown
|
|
1394 ;; G< unknown
|
|
1395 ;; G> unknown
|
|
1396 ;; I' unknown
|
|
1397 ;; O' unknown
|
|
1398 ;; S unknown
|
|
1399 ;; c| unknown
|
|
1400 ;; e@ unknown
|
|
1401 ;; eg unknown
|
|
1402 ;; en unknown
|
|
1403 ;; er unknown
|
|
1404 ;; et unknown
|
|
1405 ;; i" unknown
|
|
1406 ;; l- unknown
|
|
1407 ;; m- unknown
|
|
1408 ;; n, unknown
|
|
1409 ;; nB unknown
|
|
1410 ;; o@ unknown
|
|
1411 ;; os unknown
|
|
1412 ;; ot unknown
|
|
1413 ;; s, unknown chouse
|
|
1414 ;; u@ unknown
|
|
1415 ;; | unknown
|
|
1416
|
|
1417 ;; /a unknown alpha
|
|
1418 ;; /b unknown
|
|
1419 ;; /c unknown
|
|
1420 ;; /d unknown
|
|
1421 ;; /e unknown
|
|
1422 ;; /g unknown
|
|
1423 ;; /h unknown
|
|
1424 ;; /i unknown
|
|
1425 ;; /k unknown
|
|
1426 ;; /l unknown
|
|
1427 ;; /m unknown
|
|
1428 ;; /n unknown
|
|
1429 ;; /p unknown
|
|
1430 ;; /r unknown
|
|
1431 ;; /s unknown
|
|
1432 ;; /t unknown
|
|
1433 ;; /u unknown
|
|
1434 ;; /v unknown
|
|
1435 ;; /w unknown
|
|
1436 ;; /x unknown
|
|
1437 ;; /z unknown
|
|
1438
|
|
1439 ;; /C unknown
|
|
1440 ;; /D unknown
|
|
1441 ;; /F unknown
|
|
1442 ;; /G unknown
|
|
1443 ;; /I unknown
|
|
1444 ;; /L unknown
|
|
1445 ;; /N unknown
|
|
1446 ;; /O unknown
|
|
1447 ;; /P unknown
|
|
1448 ;; /S unknown
|
|
1449 ;; /U unknown
|
|
1450 ;; /V unknown
|
|
1451 ;; /W unknown
|
|
1452 ;; /X unknown
|