rulex

1
;;; rulex.el --- editing rulex dictionaries
2

3
;; Copyright (C) 2003 by Dmitri V. Paduchikh
4

5
;; Author: Dmitry Paduchikh <paduch@imm.uran.ru>
6
;; Keywords: tools, wp
7

8
;; This file is free software; you can redistribute it and/or modify
9
;; it under the terms of the GNU General Public License as published by
10
;; the Free Software Foundation; either version 2, or (at your option)
11
;; any later version.
12

13
;; This file is distributed in the hope that it will be useful,
14
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
;; GNU General Public License for more details.
17

18
;; You should have received a copy of the GNU General Public License
19
;; along with GNU Emacs; see the file COPYING.  If not, write to
20
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21
;; Boston, MA 02111-1307, USA.
22

23
;;; Commentary:
24

25
;;
26

27
;;; Code:
28

29
(require 'cl)
30
(require 'emacspeak-sounds)
31
(require 'emacspeak-speak)
32

33
;;;; rulex-mode
34

35
(define-derived-mode rlex-mode nil "Russian-Lex"
36
  "Major mode for editing Russian pronunciation dictionaries.
37
\\{rlex-mode-map}"
38
  (activate-input-method default-input-method))
39

40
(define-key rlex-mode-map (kbd "M-e") 'rlex-edit-prod)
41

42
;;;; Word combinations
43

44
(defvar rlex-prod-map (make-sparse-keymap))
45

46
(define-key rlex-prod-map (kbd "C-c C-s") 'rlex-insert-prod)
47
(define-key rlex-prod-map (kbd "C-c C-c") 'rlex-insert-prod/quit)
48

49
(defvar rlex-prod-buffer nil
50
  "Buffer where to insert words afterwards.")
51

52
(defun rlex-edit-prod (arg)
53
  "Switch to the buffer for editing word productions.
54
Create one if it doesn't already exist.
55

56
Copy word at the point into the buffer for editing. When interactive
57
prefix ARG is given leave the buffer contents unchanged.
58

59
When done press \\<rlex-prod-map>\\[rlex-insert-prod/quit] or \
60
\\[rlex-insert-prod] to insert resulting words."
61
  (interactive "*P")
62
  (let ((w (word-at-point))
63
	(buf (current-buffer)))
64
    (switch-to-buffer (get-buffer-create "*Word Prod*"))
65
    (unless arg
66
      (erase-buffer)
67
      (and w (insert w))
68
      (goto-char (point-min))
69
      (set-buffer-modified-p nil))
70
    (make-local-variable 'rlex-prod-buffer)
71
    (setq rlex-prod-buffer buf))
72
  (use-local-map rlex-prod-map)
73
  (activate-input-method default-input-method)
74
  (emacspeak-speak-mode-line))
75

76
(defun rlex-combine-prod (prod)
77
  (if (null prod)
78
      (list "")
79
    (let ((res '())
80
	  (strings (rlex-combine-prod (cdr prod))))
81
      (dolist (s (car prod) res)
82
	(if (string= s ".") (setq s ""))
83
	(setq res
84
	      (nconc
85
	       (mapcar (lambda (ss) (concat s ss)) strings)
86
	       res))))))
87

88
(defun rlex-canonical-word (w)
89
  (if (zerop (length w)) w
90
    (when (find ?* w)
91
      (setq w (apply #'concat (split-string w "[+=]")))
92
      (setq w (nsubstitute ?+ ?* w)))
93
    (let* ((lastp (memq (aref w (1- (length w)))
94
			'(?+ ?=)))
95
	   (parts (split-string w "[+=]"))
96
	   (tail (last parts)))
97
      (setcar tail
98
	      (cond (lastp (concat (car tail) "+"))
99
		    ((> (length parts) 1)
100
		     (concat "+" (car tail)))
101
		    (t (car tail))))
102
      (setq w (apply #'concat parts)))
103
    (let* ((pos (position ?+ w))
104
	   (char (and pos (> pos 0) (aref w (1- pos)))))
105
      (when pos				; stressed word
106
	(setq w (nsubstitute ?\xe55 ?\xe71 w))
107
	(setq w (nsubstitute ?\xe35 ?\xe21 w))
108
	(when char (aset w (1- pos) char))))
109
    w))
110

111
(defun rlex-demangle-word (w)
112
  (setq w (apply #'concat (split-string w "[*+=]")))
113
  (setq w (nsubstitute ?\xe55 ?\xe71 w))
114
  (setq w (nsubstitute ?\xe35 ?\xe21 w))
115
  w)
116

117

118
(defun rlex-parse-prod ()
119
  (sort
120
   (mapcar
121
    (lambda (w)
122
      (cons (rlex-demangle-word w)
123
	      (rlex-canonical-word w)))
124
    (rlex-combine-prod
125
     (mapcar (lambda (s)
126
	       (delete-duplicates (split-string s)
127
				  :test #'string=))
128
	     (split-string (buffer-string) "|"))))
129
   (lambda (x y) (string< (car x) (car y)))))
130

131

132
(defun rlex-insert-prod ()
133
  (interactive)
134
  (unless (buffer-live-p rlex-prod-buffer)
135
    (error "No buffer to insert words"))
136
  (let ((words (rlex-parse-prod)))
137
    (with-current-buffer rlex-prod-buffer
138
      (beginning-of-line)
139
      (push-mark (point) t t)
140
      (dolist (ww words)
141
	(unless (string= (car ww) "")
142
	  (insert (car ww) " " (cdr ww) "\n")))
143
      (when (interactive-p)
144
	(emacspeak-auditory-icon 'yank-object)
145
	(save-excursion
146
	  (goto-char (mark))
147
	  (emacspeak-speak-line))))))
148

149
(defun rlex-insert-prod/quit ()
150
  (interactive)
151
  (rlex-insert-prod)
152
  (bury-buffer)
153
  (when (interactive-p)
154
    (emacspeak-auditory-icon 'close-object)
155
    (emacspeak-speak-mode-line)))
156

157

158
(provide 'rulex)
159
;;; rulex.el ends here
160