Download
(eval-when-compile (when (< emacs-major-version 21) (require 'cl)))
(require 'thingatpt nil t)
(when (and (require 'thingatpt+ nil t)
(fboundp 'tap-put-thing-at-point-props))
(tap-define-aliases-wo-prefix)
(tap-put-thing-at-point-props))
(defgroup Synonyms nil
"Commands to look up synonyms in a thesaurus."
:prefix "synonyms-"
:group 'convenience :group 'help :group 'apropos :group 'matching
:link `(url-link :tag "Send Bug Report"
,(concat "mailto:" "drew.adams" "@" "oracle" ".com?subject=\
synonyms.el bug: \
&body=Describe bug here, starting with `emacs -q'. \
Don't forget to mention your Emacs and library versions."))
:link '(url-link :tag "Other Libraries by Drew"
"http://www.emacswiki.org/cgi-bin/wiki/DrewsElispLibraries")
:link '(url-link :tag "Download" "http://www.emacswiki.org/cgi-bin/wiki/synonyms.el")
:link '(url-link :tag "Description" "http://www.emacswiki.org/cgi-bin/wiki/Synonyms")
:link '(emacs-commentary-link :tag "Commentary" "synonyms"))
(defface synonyms-heading '((((background dark)) (:foreground "Yellow"))
(t (:foreground "Blue")))
"*Face for different synonym types."
:group 'Synonyms :group 'faces)
(defface synonyms-search-text '((t (:foreground "Red")))
"*Face for the term whose synonyms were sought."
:group 'Synonyms :group 'faces)
(defface synonyms-link '((((background dark)) (:foreground "Yellow" :underline t))
(t (:foreground "Blue" :underline t)))
"*Face for history links."
:group 'Synonyms :group 'faces)
(defface synonyms-mouse-face '((((background dark)) (:background "DarkCyan"))
(t (:background "Cyan")))
"*Mouse face for the term whose synonyms were sought."
:group 'Synonyms :group 'faces)
(defcustom synonyms-append-result-flag nil
"*t means that `synonyms' appends search result to previous results.
No other value, besides t, has this effect.
This can be overridden by using a negative prefix argument,
for example, `M--'. If you use `C-u C-u', then both this and
`synonyms-match-more-flag' are overridden."
:type 'boolean :group 'Synonyms)
(defcustom synonyms-cache-file ""
"*Location to write cache file containing synonyms.
Written to save the list of synonyms used for completion.
This is an absolute (complete-path) location, including the file name."
:type '(file :must-match t) :group 'Synonyms)
(defcustom synonyms-file ""
"*Location of thesaurus file `mthesaur.txt'.
This is an absolute (complete-path) location, including the file name."
:type '(file :must-match t) :group 'Synonyms)
(defcustom synonyms-fill-column 80
"*Synonyms* buffer text is wrapped (filled) to this many columns."
:type 'integer :group 'Synonyms)
(defcustom synonyms-match-more-flag nil
"*t means additional thesaurus entries can be matched by `synonyms'.
No other value, besides t, has this effect.
A value of t means two things:
1) Input can match parts of synonyms, in addition to whole synonyms.
2) All synonyms are shown, even if input matches a thesaurus entry.
This can be overridden by using a positive prefix argument,
for example, `C-u'. If you use `C-u C-u', then both this and
`synonyms-append-result-flag' are overridden."
:type 'boolean :group 'Synonyms)
(defcustom synonyms-mode-hook nil
"*Normal hook run when entering Thesaurus mode."
:type 'hook :group 'Synonyms)
(defcustom synonyms-use-cygwin-flag nil
"*Non-nil means to double backslashes in arguments to `call-process'.
There is apparently a bug in the Emacs (at least versions 20-22) C
code that implements function `call-process' on MS Windows. When
using native Windows Emacs with Cygwin commands, such as `grep', the C
code removes a level of backslashes, so string arguments supplied to
`call-process' need to have twice as many backslashes as they should
need. If you are using Emacs on Windows and Cygwin `grep', then you
probably will want to use a non-nil value for
`synonyms-use-cygwin-flag'."
:type 'boolean :group 'Synonyms)
(defcustom synonyms-dictionary-url "http://dictionary.reference.com/search?q="
"*URL of a Web dictionary lookup. Text to look up is appended to this.
See also `synonyms-dictionaries-url'."
:type 'string :group 'Synonyms)
(defcustom synonyms-dictionary-alternate-url "http://www.onelook.com/?ls=b&w="
"*URL of a Web dictionary lookup. Text to look up is appended to this.
The default value, \"http://www.onelook.com/?ls=b&w=\" lets you use `?'
and `*' as wildcards in the terms you look up. These are not used as
regexp wildcards, however. `?' stands for any single character, and
`*' stands for any sequence of characters. In terms of regexp syntax,
`?' here is equivalent to the regexp `.', and `*' is equivalent to the
regexp `.*'. See http://www.onelook.com/?c=faq#patterns for more
information on the allowed wildcard patterns.
See also `synonyms-dictionary-url'."
:type 'string :group 'Synonyms)
(defvar synonyms-history nil "Minibuffer history list for thesaurus lookup.")
(defvar synonyms-history-forward nil
"Minibuffer history list for thesaurus lookup using `synonyms-history-backward'.")
(defvar synonyms-list-for-obarray nil "List of synonyms to be used for completion")
(defvar synonyms-mode-map nil "Keymap for `synonyms-mode'.")
(unless synonyms-mode-map
(let ((map (make-sparse-keymap "Synonyms")))
(define-key map [(?d) (mouse-2)] 'synonyms-definition-mouse)
(define-key map "d\r" 'synonyms-definition-no-read)
(define-key map "s" 'synonyms)
(define-key map [S-return] 'synonyms)
(define-key map "\r" 'synonyms-no-read)
(define-key map [C-return] 'synonyms-match-more-no-read)
(define-key map [M-return] 'synonyms-append-result-no-read)
(define-key map [C-M-return] 'synonyms-match-more+append-result-no-read)
(define-key map [mouse-2] 'synonyms-mouse)
(define-key map [C-mouse-2] 'undefined)
(define-key map [C-down-mouse-2] 'synonyms-mouse-match-more)
(define-key map [M-mouse-2] 'synonyms-mouse-append-result)
(define-key map [C-M-mouse-2] 'synonyms-mouse-match-more+append-result)
(define-key map "l" 'synonyms-history-backward)
(define-key map "p" 'synonyms-history-backward)
(define-key map "r" 'synonyms-history-forward)
(define-key map "n" 'synonyms-history-forward)
(define-key map [mouse-4] 'synonyms-history-backward)
(define-key map [mouse-5] 'synonyms-history-forward)
(define-key map " " 'scroll-up)
(define-key map "\^?" 'scroll-down)
(define-key map "?" 'describe-mode)
(define-key map "q" 'quit-window)
(define-key map [menu-bar] (make-sparse-keymap))
(define-key map [menu-bar synonyms] (cons "Synonyms" map))
(define-key map [synonyms-help] '("Help" . describe-mode))
(define-key map [synonyms-separator-2] '("--"))
(define-key map [synonyms-next] '("Show Next" . synonyms-history-forward))
(put 'synonyms-history-forward 'menu-enable 'synonyms-history-forward)
(define-key map [synonyms-previous] '("Show Previous" . synonyms-history-backward))
(put 'synonyms-history-backward 'menu-enable '(and synonyms-history (cdr synonyms-history)))
(define-key map [synonyms-separator] '("--"))
(define-key map [synonyms-more-append]
'("Find (Max), Append Results" . synonyms-match-more+append-result))
(define-key map [synonyms-append]
'("Find, Append Results" . synonyms-append-result))
(define-key map [synonyms-more] '("Find (Max)" . synonyms-match-more))
(define-key map [synonyms-synonyms] '("Find" . synonyms))
(setq synonyms-mode-map map)))
(defvar synonyms-obarray (make-vector 103307 0)
"Obarray of synonyms. Used for completion.")
(defvar synonyms-search-text nil "Current text being looked up (matched).")
(define-derived-mode synonyms-mode text-mode "Synonyms"
"Major mode for browsing thesaurus entries (synonyms).
Like Text mode but with these additional key bindings:
\\<synonyms-mode-map>\\[synonyms-mouse], \\[synonyms-no-read], \\[synonyms] - \
Look up synonyms for a word or phrase
\\[synonyms-mouse-match-more], \\[synonyms-match-more] - Like \\[synonyms-no-read], but \
try to match more terms
\\[synonyms-mouse-append-result], \\[synonyms-append-result] - Like \\[synonyms-no-read], but \
add result to previous result
\\[synonyms-mouse-match-more+append-result], \\[synonyms-match-more+append-result] - Like \
\\[synonyms-match-more] and \\[synonyms-append-result] combined
\\[scroll-up] - Scroll down through the buffer of synonyms
\\[scroll-down] - Scroll up through the buffer of synonyms
\\[describe-mode] - Display this help
\\[quit-window] - Quit Synonyms mode
Of the various key bindings that look up synonyms, the most flexible
is \\[synonyms] - it prompts you for the search string to match. This
can be a regular expression (regexp). The other lookup bindings are
for convenience - just click.
In Synonyms mode, Transient Mark mode is enabled.
Options `synonyms-match-more-flag' and `synonyms-append-result-flag'
affect synonym matching and the results. For convenience, \\[synonyms-mouse-match-more],
\\[synonyms-mouse-append-result], and \\[synonyms-mouse-match-more+append-result] \
toggle the effect of those options for the
duration of the command.
Note that even though Synonyms mode is similar to Text mode, buffer
`*Synonyms*' is read-only, by default - use `C-x C-q' to toggle.
Turning on Synonyms mode runs the normal hooks `text-mode-hook' and
`synonyms-mode-hook' (in that order)."
(modify-syntax-entry ?- "w" synonyms-mode-syntax-table)
(modify-syntax-entry ?1 "w" synonyms-mode-syntax-table)
(modify-syntax-entry ?2 "w" synonyms-mode-syntax-table)
(modify-syntax-entry ?3 "w" synonyms-mode-syntax-table)
(modify-syntax-entry ?9 "w" synonyms-mode-syntax-table)
(modify-syntax-entry ?0 "w" synonyms-mode-syntax-table)
(modify-syntax-entry ?$ "w" synonyms-mode-syntax-table)
(buffer-disable-undo)
(setq fill-column synonyms-fill-column)
(set (make-local-variable 'transient-mark-mode) t))
(defun synonyms-ensure-synonyms-read-from-cache ()
"Ensure synonyms are in `synonyms-obarray', from `synonyms-cache-file'.
If this file does not yet exist, then it and the obarray are created.
Creating the obarray for the first time takes 2-3 minutes.
This does nothing if the obarray is already complete."
(interactive)
(unless (intern-soft "synonym" synonyms-obarray)
(setq synonyms-list-for-obarray ()
synonyms-cache-file (expand-file-name synonyms-cache-file))
(if (synonyms-file-readable-p synonyms-cache-file)
(let ((list-buf (find-file-noselect synonyms-cache-file 'nowarn 'raw))
(obarray synonyms-obarray))
(unwind-protect
(setq synonyms-list-for-obarray (read list-buf))
(kill-buffer list-buf)))
(synonyms-make-obarray)
(synonyms-write-synonyms-to-cache))))
(defun synonyms-make-obarray ()
"Fill `synonyms-obarray' with the available synonyms."
(interactive)
(unless (intern-soft "synonym" synonyms-obarray)
(synonyms-define-synonyms-file)
(with-temp-message "Building synonyms list for completion. This will take a few minutes..."
(let ((thesaurus-buf (find-file-noselect synonyms-file 'nowarn 'raw))
synonym)
(unwind-protect
(save-current-buffer
(set-buffer thesaurus-buf)
(goto-char (point-min))
(synonyms-mode)
(while (re-search-forward "\\(\\(\\w\\|[ ]\\)+\\)\\(,\\|$\\)" nil t)
(setq synonym (buffer-substring (match-beginning 1) (match-end 1)))
(intern synonym synonyms-obarray)))
(kill-buffer thesaurus-buf))))))
(defun synonyms-define-synonyms-file ()
"Prompt user to define `synonyms-file', unless it is readable."
(setq synonyms-file (expand-file-name synonyms-file))
(unless (synonyms-file-readable-p synonyms-file)
(while (not (synonyms-file-readable-p synonyms-file))
(setq synonyms-file (read-file-name "Thesaurus file: " nil nil 'confirm "mthesaur.txt")))
(custom-set-variables (list 'synonyms-file
(setq synonyms-file (expand-file-name synonyms-file))
'now))))
(defun synonyms-write-synonyms-to-cache ()
"Write synonyms in `synonyms-obarray' to file `synonyms-cache-file'."
(interactive)
(synonyms-define-cache-file)
(with-temp-message "Writing synonyms cache file..."
(with-temp-file synonyms-cache-file
(mapatoms (lambda (symb) (push symb synonyms-list-for-obarray)) synonyms-obarray)
(prin1 synonyms-list-for-obarray (current-buffer)))))
(defun synonyms-define-cache-file ()
"Prompt user to define `synonyms-cache-file', unless it is writable."
(unless (synonyms-file-writable-p synonyms-cache-file)
(while (not (synonyms-file-writable-p synonyms-cache-file))
(setq synonyms-cache-file
(read-file-name "Cache file: "
(expand-file-name (file-name-directory synonyms-file)) nil nil
(concat (file-name-nondirectory synonyms-file) ".cache"))))
(custom-set-variables (list 'synonyms-cache-file
(setq synonyms-cache-file (expand-file-name synonyms-cache-file))
'now))))
(defun synonyms-file-readable-p (file)
"Return non-nil if FILE (a string) names a readable file."
(and (not (string= "" file)) (file-readable-p file) (not (file-directory-p file))))
(defun synonyms-file-writable-p (file)
"Return non-nil if FILE (a string) names a writable file."
(and (not (string= "" file)) (file-writable-p file) (not (file-directory-p file))))
(defun synonyms (&optional arg regexp)
"Show synonyms that match a regular expression (e.g. a word or phrase).
You are prompted for the regexp. By default, it is the text
of the region, if it is active and `transient-mark-mode' is enabled,
or the nearest word to the cursor, if not.
Option `synonyms-match-more-flag' non-nil means additional thesaurus
entries can be matched. This can be more time-consuming. It means
two things:
1) Input can match parts of synonyms, in addition to whole synonyms.
2) All synonyms are shown, even if input matches a thesaurus entry.
Option `synonyms-append-result-flag' non-nil means to append search
result to previous results.
A prefix argument toggles the meaning of each of those options for the
duration of the command:
If `C-u' or `C-u C-u', then toggle `synonyms-match-more-flag'.
If negative or `C-u C-u', then toggle `synonyms-append-result-flag'.
\(`C-u C-u' thus means toggle both options.)
When called from Lisp, optional second argument REGEXP is the regexp
to match (no prompting)."
(interactive "P")
(synonyms-ensure-synonyms-read-from-cache)
(let* ((num-arg (prefix-numeric-value arg))
(morep (eq synonyms-match-more-flag (atom arg)))
(appendp (eq synonyms-append-result-flag (and (wholenump num-arg)
(/= 16 num-arg))))
(default-search-text (or regexp (synonyms-default-regexp)))
(search-text (or regexp
(let ((case-fold-search t))
(completing-read
"Show synonyms for word or phrase (regexp): "
synonyms-obarray nil nil nil 'synonyms-history
default-search-text)))))
(synonyms-action search-text)))
(defun synonyms-action (search-text)
"Helper function for command `synonyms'.
APPENDP and MOREP are free here."
(setq synonyms-search-text search-text)
(when (string= "" search-text) (error "No text to look up"))
(unless (member search-text synonyms-history) (push search-text synonyms-history))
(setq search-text (replace-regexp-in-string "\\." "[^,]" search-text nil t))
(synonyms-lookup search-text (and (boundp 'appendp) appendp) (and (boundp 'morep) morep)))
(defun synonyms-no-read (arg)
"Same as command `synonyms', but uses the default input text (regexp)."
(interactive "P")
(let* ((num-arg (prefix-numeric-value arg))
(morep (eq synonyms-match-more-flag (atom arg)))
(appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg))))
(search-text (synonyms-default-regexp)))
(setq synonyms-search-text search-text)
(when (string= "" search-text) (error "No text to look up"))
(unless (member search-text synonyms-history) (push search-text synonyms-history))
(setq search-text (replace-regexp-in-string "\\." "[^,]" search-text nil t))
(synonyms-lookup search-text appendp morep)))
(defun synonyms-match-more ()
"Same as using `synonyms' with `synonyms-match-more-flag' = t."
(interactive)
(let ((synonyms-match-more-flag t))
(synonyms)))
(defun synonyms-match-more-no-read (arg)
"Same as using `synonyms' with `synonyms-match-more-flag' = t."
(interactive "P")
(let ((synonyms-match-more-flag t))
(synonyms-no-read arg)))
(defun synonyms-append-result ()
"Same as using `synonyms' with `synonyms-append-result-flag' = t."
(interactive)
(let ((synonyms-append-result-flag t))
(synonyms)))
(defun synonyms-append-result-no-read (arg)
"Same as using `synonyms' with `synonyms-append-result-flag' = t."
(interactive "P")
(let ((synonyms-append-result-flag t))
(synonyms-no-read arg)))
(defun synonyms-match-more+append-result ()
"Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
(interactive)
(let ((synonyms-match-more-flag t)
(synonyms-append-result-flag t))
(synonyms)))
(defun synonyms-match-more+append-result-no-read (arg)
"Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
(interactive "P")
(let ((synonyms-match-more-flag t)
(synonyms-append-result-flag t))
(synonyms-no-read arg)))
(defun synonyms-mouse (event arg)
"Show synonyms that match a regular expression (e.g. a word or phrase).
The regexp to match is the synonym or region clicked with mouse-2. If
the region is active, but a synonym elsewhere is clicked, that synonym
is used, not the selected text.
You can either click a listed synonym, to see its synonyms, or select
one or more words and click the selection, to see matching synonyms.
To quickly select a series of words: double-click mouse-1 to select
the first word, then click mouse-3 to extend the selection to the last
word.
Selection is useful when you want to see synonyms of a similar term.
For example, instead of clicking the listed synonym `bleeding heart', you
might select `heart' and click that.
The prefix argument acts the same as for command `synonyms'.
If you click a history link with mouse-2, previously retrieved search
results are revisited."
(interactive "e\nP")
(set-buffer (window-buffer (posn-window (event-end event))))
(let ((beg (region-beginning))
(end (region-end))
(active mark-active))
(goto-char (posn-point (event-end event)))
(cond ((get-text-property (point) 'back-link) (synonyms-history-backward nil))
((get-text-property (point) 'forward-link) (synonyms-history-forward nil))
(t (if (and active (> (point) beg) (< (point) end))
(goto-char end)
(deactivate-mark))
(synonyms-no-read arg)))))
(defun synonyms-mouse-match-more (event arg)
"Same as `synonyms-mouse' with `synonyms-match-more-flag' = t."
(interactive "e\nP")
(let ((synonyms-match-more-flag t))
(synonyms-mouse event arg)))
(defun synonyms-mouse-append-result (event arg)
"Same as `synonyms-mouse' with `synonyms-append-result-flag' = t."
(interactive "e\nP")
(let ((synonyms-append-result-flag t))
(synonyms-mouse event arg)))
(defun synonyms-mouse-match-more+append-result (event arg)
"Like `synonyms-match-more-flag' = `synonyms-append-result-flag' = t."
(interactive "e\nP")
(let ((synonyms-match-more-flag t)
(synonyms-append-result-flag t))
(synonyms-mouse event arg)))
(defun synonyms-default-regexp ()
"Return the default regexp for `synonym' and `synonyms-mouse'.
If the region is active in `transient-mark-mode', use its text.
Else, if this is *Synonyms* buffer, use the synonym under the cursor.
Else use the word nearest the cursor.
An active region has no effect except in `transient-mark-mode'."
(if (and mark-active transient-mark-mode)
(buffer-substring-no-properties (point) (mark))
(if (eq major-mode 'synonyms-mode)
(let (beg end)
(when (and (not (eobp)) (get-text-property (point) 'mouse-face))
(setq end (point)
beg (1+ (point))))
(when (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face))
(setq end (1- (point))
beg (point)))
(if (null beg)
(synonyms-nearest-word)
(setq beg (previous-single-property-change beg 'mouse-face)
end (or (next-single-property-change end 'mouse-face) (point-max)))
(replace-regexp-in-string
"\\(^ \\| $\\)" ""
(replace-regexp-in-string "[\n]" " " (buffer-substring-no-properties beg end) nil t)
nil t)))
(synonyms-nearest-word))))
(defun synonyms-nearest-word ()
"Word nearest the cursor."
(let ((word (if (fboundp 'word-nearest-point)
(word-nearest-point)
(word-at-point))))
(set-text-properties 0 (length word) nil word)
word))
(defun synonyms-lookup (search-text appendp morep)
"Search the thesaurus for SEARCH-TEXT.
APPEND-P non-nil means to append search result to previous results.
MORE-P non-nil means additional thesaurus entries can be matched."
(save-selected-window
(with-temp-message
(format "Looking up %s synonyms for \"%s\"%s..." (if morep "(max)" "")
(replace-regexp-in-string (regexp-quote "[^,]") "." search-text nil t)
(if appendp " (appending)" ""))
(let ((temp-buf (generate-new-buffer " *Temp*")))
(unwind-protect
(progn
(set-buffer temp-buf)
(buffer-disable-undo)
(erase-buffer)
(let ((entry-p (synonyms-search-entries search-text temp-buf morep)))
(unless (if morep
(or (synonyms-search-synonyms search-text temp-buf t) entry-p)
(or entry-p (synonyms-search-synonyms search-text temp-buf nil)))
(pop synonyms-history)
(error "No synonyms found for `%s'" search-text))
(let ((results-buf (get-buffer-create "*Synonyms*")))
(synonyms-format-synonyms search-text morep)
(synonyms-show-synonyms temp-buf results-buf appendp)
(message nil))))
(kill-buffer temp-buf))))))
(defun synonyms-search-entries (search-text buf morep)
"Search thesaurus entries (headings) for SEARCH-TEXT.
Put result in buffer BUF.
MORE-P non-nil means additional thesaurus entries can be matched."
(call-process "grep" nil buf nil "-i" (synonyms-hack-backslashes-if-cygwin
(if morep
(format "^\\w*%s\\w*," search-text)
(format "^%s," search-text)))
(expand-file-name synonyms-file))
(not (zerop (count-lines (point-min) (point-max)))))
(defun synonyms-search-synonyms (search-text buf morep)
"Search thesaurus body for SEARCH-TEXT.
SEARCH-TEXT is a regexp that can match any part of a thesaurus term.
Put result in buffer BUF.
MORE-P non-nil means additional thesaurus entries can be matched."
(call-process "grep" nil buf nil "-i" (synonyms-hack-backslashes-if-cygwin
(if morep
(format ",\\w*%s\\w*\\(,\\|$\\)" search-text)
(format ",%s\\(,\\|$\\)" search-text)))
(expand-file-name synonyms-file))
(not (zerop (count-lines (point-min) (point-max)))))
(defun synonyms-hack-backslashes-if-cygwin (string)
"Double each backslash in STRING, unless it contains SPC characters.
More precisely, if `synonyms-use-cygwin-flag' is non-nil and this is
Emacs 20 or there are no spaces in STRING, then double any backslashes
in STRING.
This is an ugly hack made necessary because of bugs in Emacs C code."
(when (and synonyms-use-cygwin-flag
(or (= emacs-major-version 20) (not (string-match " " string))))
(setq string (replace-regexp-in-string "[\\]" "\\\\" string nil t)))
string)
(defun synonyms-format-synonyms (search-text morep)
"Format synonyms that match SEARCH-TEXT.
MORE-P non-nil means additional thesaurus entries can be matched."
(goto-char (point-min))
(let ((entries-count (count-lines (point-min) (point-max))))
(if (= entries-count 1)
(synonyms-format-entry search-text t morep)
(synonyms-format-entries search-text entries-count morep))
(synonyms-format-finish search-text morep)))
(defun synonyms-format-entry (search-text single-p morep)
"Format a single thesaurus entry that matches SEARCH-TEXT.
SINGLE-P non-nil means there is only one entry."
(beginning-of-line)
(let ((beg (point))
(orig (if morep
(format "\\w*\\(%s\\)\\w*" synonyms-search-text)
(format "\\(%s\\)" synonyms-search-text)))
(entry-p nil)
term end)
(when single-p (insert "Synonyms for "))
(setq term (point))
(when (looking-at orig) (setq entry-p t))
(unless (search-forward "," nil t) (error "Bad thesaurus file - no commas"))
(setq end (match-beginning 0))
(replace-match ":\n\n" nil t)
(cond (single-p
(add-text-properties beg term '(face synonyms-heading))
(add-text-properties term end (if entry-p
'(face synonyms-search-text
mouse-face synonyms-mouse-face)
'(face synonyms-heading)))
(add-text-properties end (+ 2 end) '(face synonyms-heading)))
(t
(add-text-properties beg (1+ end) '(face synonyms-heading))
(save-excursion
(forward-line -2)
(save-restriction
(narrow-to-region (point) (save-excursion (end-of-line) (backward-char) (point)))
(unless (search-forward ". " nil t)
(error "Badly formatted numeric entry - no period"))
(add-text-properties (point) (point-max) '(mouse-face synonyms-mouse-face))
(when (looking-at orig)
(add-text-properties (match-beginning 1) (match-end 1)
'(face synonyms-search-text)))))))
(forward-line)))
(defun synonyms-format-entries (search-text entries-count morep)
"Format thesaurus entries that have synonyms matching SEARCH TEXT.
ENTRIES-COUNT is the number of entries.
MORE-P non-nil means additional thesaurus entries can be matched."
(let ((countdown entries-count)
(beg (point))
(part1 "Synonyms for ")
(part2 ":\n"))
(insert part1 synonyms-search-text part2)
(add-text-properties beg (setq beg (+ beg (length part1))) '(face synonyms-heading))
(add-text-properties beg (setq beg (+ beg (length synonyms-search-text)))
'(face synonyms-search-text mouse-face synonyms-mouse-face))
(add-text-properties beg (+ beg (length part2)) '(face synonyms-heading))
(while (> countdown 0)
(setq countdown (1- countdown))
(insert (format "\n\%s. " (- entries-count countdown)))
(synonyms-format-entry search-text nil morep))))
(defun synonyms-format-finish (search-text morep)
"Finish formatting synonyms matching SEARCH-TEXT.
MORE-P non-nil means additional thesaurus entries can be matched."
(goto-char (point-min))
(forward-line)
(while (search-forward "," nil t) (replace-match ", " nil t))
(goto-char (point-min))
(let ((case-fold-search t)
(new-search-text (if morep
(format "\\(^\\|, \\)\\w*\\(%s\\)\\w*\\($\\|,\\)" search-text)
(format "\\(^\\|, \\)\\(%s\\)\\($\\|,\\)" search-text)))
(no-numbered-headers-p (not (re-search-forward "^[0-9]+[.]" nil t))))
(goto-char (point-min))
(forward-line)
(while (re-search-forward new-search-text nil t)
(add-text-properties (match-beginning 2) (match-end 2) '(face synonyms-search-text))
(goto-char (match-end 2)))
(synonyms-mode)
(save-excursion
(goto-char (point-min))
(forward-line)
(while (re-search-forward "\\(^\\|, \\)\\(\\(\\w\\|[\\t ]\\)+\\)\\($\\|,\\)" nil t)
(add-text-properties (match-beginning 2) (match-end 2) '(mouse-face synonyms-mouse-face))
(goto-char (match-end 2)))
(fill-region (point-min) (point-max)))
(synonyms-add-history-links)))
(defun synonyms-add-history-links ()
"Add Back and Forward chronological navigation links"
(save-excursion
(unless (re-search-backward "Synonyms for") (error "No \"Synonyms for\" text"))
(end-of-line)
(insert (make-string (- fill-column 16 (point)) ?\ ) "[")
(let ((beg (point))
(Back "Back")
(spacer "] [")
(Forward "Forward"))
(insert Back)
(add-text-properties beg (point)
'(face synonyms-link mouse-face synonyms-mouse-face back-link t
help-echo "mouse-2, RET: Go backward in synonyms search history"))
(insert spacer Forward)
(add-text-properties (+ beg (length Back) (length spacer)) (point)
'(face synonyms-link mouse-face synonyms-mouse-face forward-link t
help-echo "mouse-2, RET: Go forward in synonyms search history"))
(insert "]"))))
(defun synonyms-show-synonyms (temp-buf results-buf appendp)
"Display search results from buffer TEMP-BUF in buffer RESULTS-BUF.
If APPEND-P is non-nil and RESULTS-BUF is not empty, then insert a
separator line between previous search results and the current results."
(set-buffer results-buf)
(setq buffer-read-only nil)
(unless (= (point-min) (point-max))
(if (not appendp)
(erase-buffer)
(goto-char (point-max))
(let ((beg (point)))
(insert "\n" (make-string (1- (window-width)) ?_) "\n\n\n")
(add-text-properties beg (point) '(face synonyms-heading)))))
(let ((start-result (point)))
(insert-buffer temp-buf)
(select-window (display-buffer results-buf))
(goto-char start-result)
(forward-line 2)
(when (looking-at "^[0-9]. ") (goto-char (match-end 0)))
(recenter 2)
(synonyms-mode)
(setq buffer-read-only t)))
(defun synonyms-history-backward (arg)
"Run `synonyms' on a previous argument, moving backward in the history.
A prefix argument has the same meaning as for command `synonyms'."
(interactive "P")
(unless (cdr synonyms-history) (error "Cannot move backward in history"))
(push (pop synonyms-history) synonyms-history-forward)
(let* ((num-arg (prefix-numeric-value arg))
(morep (eq synonyms-match-more-flag (atom arg)))
(appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg)))))
(if (not (get-buffer "*Synonyms*"))
(synonyms-action (car synonyms-history))
(let ((divider (with-current-buffer "*Synonyms*" (re-search-backward "^___" nil t))))
(if (not divider)
(synonyms-action (car synonyms-history))
(set-buffer "*Synonyms*")
(goto-char divider)
(unless (re-search-backward "^Synonyms for \\([^:]+\\):" nil t)
(error "Cannot find previous synonyms page"))
(goto-char (match-beginning 1))
(recenter 0)
(message "%s" (buffer-substring (match-beginning 1) (match-end 1))))))))
(defun synonyms-history-forward (arg)
"Run `synonyms' on a previous argument, moving forward in the history.
A prefix argument has the same meaning as for command `synonyms'."
(interactive "P")
(unless synonyms-history-forward (error "Cannot move forward in history"))
(push (pop synonyms-history-forward) synonyms-history)
(let* ((num-arg (prefix-numeric-value arg))
(morep (eq synonyms-match-more-flag (atom arg)))
(appendp (eq synonyms-append-result-flag (and (wholenump num-arg) (/= 16 num-arg)))))
(if (not (get-buffer "*Synonyms*"))
(synonyms-action (car synonyms-history))
(let ((divider (with-current-buffer "*Synonyms*" (re-search-forward "^___" nil t))))
(if (not divider)
(synonyms-action (car synonyms-history))
(set-buffer "*Synonyms*")
(goto-char divider)
(unless (re-search-forward "^Synonyms for \\([^:]+\\):" nil t)
(error "Cannot find next synonyms page"))
(goto-char (match-beginning 1))
(recenter 0)
(message "%s" (buffer-substring (match-beginning 1) (match-end 1))))))))
(defalias 'dictionary-definition 'synonyms-definition)
(defun synonyms-definition (search-text alternate-p)
"Look up the definition of a word or phrase using online dictionaries.
The dictionary used is `synonyms-dictionary-url'.
With prefix arg, look up the definition in the alternate dictionary,
`synonyms-dictionary-alternate-url'."
(interactive (list (completing-read "Look up definition of word or phrase (regexp): "
synonyms-obarray nil nil nil 'synonyms-history
(synonyms-default-regexp))
current-prefix-arg))
(synonyms-ensure-synonyms-read-from-cache)
(browse-url (concat (if alternate-p synonyms-dictionary-alternate-url synonyms-dictionary-url)
search-text)))
(defun synonyms-definition-no-read (alternate-p)
"Look up the definition of a word or phrase using online dictionaries.
The dictionary used is `synonyms-dictionary-url'.
With prefix arg, look up the definition in the alternate dictionary,
`synonyms-dictionary-alternate-url'."
(interactive "P")
(synonyms-definition (synonyms-default-regexp) alternate-p))
(defun synonyms-definition-mouse (event alternate-p)
"Look up the definition of a word or phrase using online dictionaries.
The dictionary used is `synonyms-dictionary-url'.
With prefix arg, look up the definition in the alternate dictionary,
`synonyms-dictionary-alternate-url'."
(interactive "e\nP")
(set-buffer (window-buffer (posn-window (event-end event))))
(let ((beg (region-beginning))
(end (region-end))
(active mark-active))
(goto-char (posn-point (event-end event)))
(cond ((get-text-property (point) 'back-link) (synonyms-history-backward nil))
((get-text-property (point) 'forward-link) (synonyms-history-forward nil))
(t (if (and active (> (point) beg) (< (point) end))
(goto-char end)
(deactivate-mark))
(synonyms-definition (synonyms-default-regexp) alternate-p)))))
(provide 'synonyms)