Mercurial > emacs
annotate lisp/language/tibet-util.el @ 28678:b132db55ef7e
(struct Lisp_Buffer_Cons): Remove.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Fri, 21 Apr 2000 13:00:58 +0000 |
parents | 55576e0788b1 |
children | 60eb71a9f901 |
rev | line source |
---|---|
17315
a3ca5e15c82a
Fix the format of the first line.
Kenichi Handa <handa@m17n.org>
parents:
17301
diff
changeset
|
1 ;;; tibet-util.el --- Support for inputting Tibetan characters |
17301 | 2 |
3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. | |
18377
8b4a66c66dd6
Change copyright notice.
Richard M. Stallman <rms@gnu.org>
parents:
18309
diff
changeset
|
4 ;; Licensed to the Free Software Foundation. |
17301 | 5 |
6 ;; Keywords: multilingual, Tibetan | |
7 | |
8 ;; This file is part of GNU Emacs. | |
9 | |
10 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 ;; it under the terms of the GNU General Public License as published by | |
12 ;; the Free Software Foundation; either version 2, or (at your option) | |
13 ;; any later version. | |
14 | |
15 ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 ;; GNU General Public License for more details. | |
19 | |
20 ;; You should have received a copy of the GNU General Public License | |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 ;; Boston, MA 02111-1307, USA. | |
24 | |
25 ;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch> | |
26 | |
27 ;; Created: Feb. 17. 1997 | |
28 | |
29 ;; History: | |
30 ;; 1997.03.13 Modification in treatment of text properties; | |
31 ;; Support for some special signs and punctuations. | |
26896 | 32 ;; 1999.10.25 Modification for a new composition way by K.Handa. |
17301 | 33 |
34 ;;; Code: | |
35 | |
17993
73869115ae0a
Most of setup-LANGUAGE-environment functions are
Kenichi Handa <handa@m17n.org>
parents:
17776
diff
changeset
|
36 ;;;###autoload |
73869115ae0a
Most of setup-LANGUAGE-environment functions are
Kenichi Handa <handa@m17n.org>
parents:
17776
diff
changeset
|
37 (defun setup-tibetan-environment () |
73869115ae0a
Most of setup-LANGUAGE-environment functions are
Kenichi Handa <handa@m17n.org>
parents:
17776
diff
changeset
|
38 (interactive) |
22987
708271862495
(setup-XXX-environment): Just call set-language-environment. If
Kenichi Handa <handa@m17n.org>
parents:
20738
diff
changeset
|
39 (set-language-environment "Tibetan")) |
17993
73869115ae0a
Most of setup-LANGUAGE-environment functions are
Kenichi Handa <handa@m17n.org>
parents:
17776
diff
changeset
|
40 |
26896 | 41 ;;;###autoload |
42 (defun tibetan-char-p (ch) | |
43 "Check if char CH is Tibetan character. | |
44 Returns non-nil if CH is Tibetan. Otherwise, returns nil." | |
45 (memq (char-charset ch) '(tibetan tibetan-1-column))) | |
46 | |
47 ;;; Functions for Tibetan <-> Tibetan-transcription. | |
17301 | 48 |
49 ;;;###autoload | |
26896 | 50 (defun tibetan-tibetan-to-transcription (str) |
51 "Transcribe Tibetan string STR and return the corresponding Roman string." | |
52 (let (;; Accumulate transcriptions here in reverse order. | |
53 (trans nil) | |
54 (len (length str)) | |
55 (i 0) | |
56 ch this-trans) | |
57 (while (< i len) | |
58 (let ((idx (string-match tibetan-precomposition-rule-alist str i))) | |
59 (if (eq idx i) | |
60 ;; Ith character and the followings matches precomposable | |
61 ;; Tibetan sequence. | |
62 (setq i (match-end 0) | |
63 this-trans | |
64 (car (rassoc | |
65 (cdr (assoc (match-string 0 str) | |
66 tibetan-precomposition-rule-alist)) | |
67 tibetan-precomposed-transcription-alist))) | |
68 (setq ch (substring str i (1+ i)) | |
69 i (1+ i) | |
70 this-trans | |
71 (car (or (rassoc ch tibetan-consonant-transcription-alist) | |
72 (rassoc ch tibetan-vowel-transcription-alist) | |
73 (rassoc ch tibetan-subjoined-transcription-alist))))) | |
74 (setq trans (cons this-trans trans)))) | |
75 (apply 'concat (nreverse trans)))) | |
17301 | 76 |
77 ;;;###autoload | |
26896 | 78 (defun tibetan-transcription-to-tibetan (str) |
79 "Convert Tibetan Roman string STR to Tibetan character string. | |
80 The returned string has no composition information." | |
81 (let (;; Case is significant. | |
17301 | 82 (case-fold-search nil) |
26896 | 83 (idx 0) |
84 ;; Accumulate Tibetan strings here in reverse order. | |
85 (t-str-list nil) | |
86 i subtrans) | |
87 (while (setq i (string-match tibetan-regexp str idx)) | |
88 (if (< idx i) | |
89 ;; STR contains a pattern that doesn't match Tibetan | |
90 ;; transcription. Include the pattern as is. | |
91 (setq t-str-list (cons (substring str idx i) t-str-list))) | |
92 (setq subtrans (match-string 0 str) | |
93 idx (match-end 0)) | |
94 (let ((t-char (cdr (assoc subtrans | |
95 tibetan-precomposed-transcription-alist)))) | |
96 (if t-char | |
97 ;; SUBTRANS corresponds to a transcription for | |
98 ;; precomposable Tibetan sequence. | |
99 (setq t-char (car (rassoc t-char | |
100 tibetan-precomposition-rule-alist))) | |
101 (setq t-char | |
102 (cdr | |
103 (or (assoc subtrans tibetan-consonant-transcription-alist) | |
104 (assoc subtrans tibetan-vowel-transcription-alist) | |
105 (assoc subtrans tibetan-modifier-transcription-alist) | |
106 (assoc subtrans tibetan-subjoined-transcription-alist))))) | |
107 (setq t-str-list (cons t-char t-str-list)))) | |
108 (if (< idx (length str)) | |
109 (setq t-str-list (cons (substring str idx) t-str-list))) | |
110 (apply 'concat (nreverse t-str-list)))) | |
17301 | 111 |
112 ;;; | |
26896 | 113 ;;; Functions for composing/decomposing Tibetan sequence. |
17301 | 114 ;;; |
115 ;;; A Tibetan syllable is typically structured as follows: | |
116 ;;; | |
117 ;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]] | |
118 ;;; | |
119 ;;; where C's are all vertically stacked, V appears below or above | |
120 ;;; consonant cluster and M is always put above the C[C+]V combination. | |
121 ;;; (Sanskrit visarga, though it is a vowel modifier, is considered | |
122 ;;; to be a punctuation.) | |
123 ;;; | |
124 ;;; Here are examples of the words "bsgrubs" and "h'uM" | |
125 ;;; | |
28478 | 126 ;;; 4$(7"70"714%qx!"U0"G###C"U14"70"714"G0"G1(B 4$(7"Hx!#Ax!"Ur'"_0"H"A"U"_1(B |
17301 | 127 ;;; |
128 ;;; M | |
129 ;;; b s b s h | |
130 ;;; g ' | |
131 ;;; r u | |
132 ;;; u | |
133 ;;; | |
26896 | 134 ;;; Consonants `'' ($(7"A(B), `w' ($(7">(B), `y' ($(7"B(B), `r' ($(7"C(B) take special |
135 ;;; forms when they are used as subjoined consonant. Consonant `r' | |
136 ;;; takes another special form when used as superjoined in such a case | |
137 ;;; as "rka", while it does not change its form when conjoined with | |
138 ;;; subjoined `'', `w' or `y' as in "rwa", "rya". | |
139 | |
140 ;; Append a proper composition rule and glyph to COMPONENTS to compose | |
141 ;; CHAR with a composition that has COMPONENTS. | |
17301 | 142 |
26896 | 143 (defun tibetan-add-components (components char) |
144 (let ((last (last components)) | |
145 (stack-upper '(tc . bc)) | |
146 (stack-under '(bc . tc)) | |
147 rule) | |
148 ;; Special treatment for 'a chung. | |
149 ;; If 'a follows a consonant, turn it into the subjoined form. | |
150 (if (and (= char ?$(7"A(B) | |
151 (aref (char-category-set (car last)) ?0)) | |
152 (setq char ?$(7#A(B)) | |
17301 | 153 |
26896 | 154 (cond |
155 ;; Compose upper vowel sign vertically over. | |
156 ((aref (char-category-set char) ?2) | |
157 (setq rule stack-upper)) | |
17301 | 158 |
26896 | 159 ;; Compose lower vowel sign vertically under. |
160 ((aref (char-category-set char) ?3) | |
161 (setq rule stack-under)) | |
17301 | 162 |
26896 | 163 ;; Transform ra-mgo (superscribed r) if followed by a subjoined |
164 ;; consonant other than w, ', y, r. | |
165 ((and (= (car last) ?$(7"C(B) | |
166 (not (memq char '(?$(7#>(B ?$(7#A(B ?$(7#B(B ?$(7#C(B)))) | |
167 (setcar last ?$(7#P(B) | |
168 (setq rule stack-under)) | |
17301 | 169 |
26896 | 170 ;; Transform initial base consonant if followed by a subjoined |
171 ;; consonant but 'a. | |
172 (t | |
173 (let ((laststr (char-to-string (car last)))) | |
174 (if (and (/= char ?$(7#A(B) | |
175 (string-match "[$(7"!(B-$(7"="?"@"D(B-$(7"J(B]" laststr)) | |
176 (setcar last (string-to-char | |
177 (cdr (assoc (char-to-string (car last)) | |
178 tibetan-base-to-subjoined-alist))))) | |
179 (setq rule stack-under)))) | |
17301 | 180 |
26896 | 181 (setcdr last (list rule char)))) |
17301 | 182 |
183 ;;;###autoload | |
184 (defun tibetan-compose-string (str) | |
26896 | 185 "Compose Tibetan string STR." |
186 (let ((idx 0)) | |
187 ;; `$(7"A(B' is included in the pattern for subjoined consonants | |
188 ;; because we treat it specially in tibetan-add-components. | |
189 (while (setq idx (string-match tibetan-composable-pattern str idx)) | |
190 (let ((from idx) | |
191 (to (match-end 0)) | |
192 components) | |
193 (if (eq (string-match tibetan-precomposition-rule-regexp str idx) idx) | |
194 (setq idx (match-end 0) | |
195 components | |
196 (list (string-to-char | |
197 (cdr | |
198 (assoc (match-string 0 str) | |
199 tibetan-precomposition-rule-alist))))) | |
200 (setq components (list (aref str idx)) | |
201 idx (1+ idx))) | |
202 (while (< idx to) | |
203 (tibetan-add-components components (aref str idx)) | |
204 (setq idx (1+ idx))) | |
205 (compose-string str from to components)))) | |
206 str) | |
17301 | 207 |
19553
e63ba5228950
(tibetan-composition): Add autoload cookies.
Kenichi Handa <handa@m17n.org>
parents:
19366
diff
changeset
|
208 ;;;###autoload |
26896 | 209 (defun tibetan-compose-region (beg end) |
210 "Compose Tibetan text the region BEG and END." | |
17301 | 211 (interactive "r") |
26896 | 212 (let (str result chars) |
17301 | 213 (save-excursion |
214 (save-restriction | |
215 (narrow-to-region beg end) | |
216 (goto-char (point-min)) | |
26896 | 217 ;; `$(7"A(B' is included in the pattern for subjoined consonants |
218 ;; because we treat it specially in tibetan-add-components. | |
219 (while (re-search-forward tibetan-composable-pattern nil t) | |
220 (let ((from (match-beginning 0)) | |
221 (to (match-end 0)) | |
222 components) | |
223 (goto-char from) | |
224 (if (looking-at tibetan-precomposition-rule-regexp) | |
225 (progn | |
226 (setq components | |
227 (list (string-to-char | |
228 (cdr | |
229 (assoc (match-string 0) | |
230 tibetan-precomposition-rule-alist))))) | |
231 (goto-char (match-end 0))) | |
232 (setq components (list (char-after from))) | |
233 (forward-char 1)) | |
234 (while (< (point) to) | |
235 (tibetan-add-components components (following-char)) | |
236 (forward-char 1)) | |
237 (compose-region from to components))))))) | |
17301 | 238 |
239 ;;;###autoload | |
26896 | 240 (defalias 'tibetan-decompose-region 'decompose-region) |
241 ;;;###autoload | |
242 (defalias 'tibetan-decompose-string 'decompose-string) | |
243 | |
244 ;;;###autoload | |
245 (defun tibetan-composition-function (from to pattern &optional string) | |
246 (if string | |
247 (tibetan-compose-string string) | |
248 (tibetan-compose-region from to)) | |
249 (- to from)) | |
17301 | 250 |
251 ;;; | |
252 ;;; This variable is used to avoid repeated decomposition. | |
253 ;;; | |
254 (setq-default tibetan-decomposed nil) | |
255 | |
256 ;;;###autoload | |
257 (defun tibetan-decompose-buffer () | |
258 "Decomposes Tibetan characters in the buffer into their components. | |
26896 | 259 See also the documentation of the function `tibetan-decompose-region'." |
17301 | 260 (interactive) |
261 (make-local-variable 'tibetan-decomposed) | |
262 (cond ((not tibetan-decomposed) | |
263 (tibetan-decompose-region (point-min) (point-max)) | |
264 (setq tibetan-decomposed t)))) | |
265 | |
266 ;;;###autoload | |
267 (defun tibetan-compose-buffer () | |
268 "Composes Tibetan character components in the buffer. | |
269 See also docstring of the function tibetan-compose-region." | |
270 (interactive) | |
271 (make-local-variable 'tibetan-decomposed) | |
272 (tibetan-compose-region (point-min) (point-max)) | |
273 (setq tibetan-decomposed nil)) | |
274 | |
275 ;;;###autoload | |
276 (defun tibetan-post-read-conversion (len) | |
277 (save-excursion | |
278 (save-restriction | |
279 (let ((buffer-modified-p (buffer-modified-p))) | |
280 (narrow-to-region (point) (+ (point) len)) | |
281 (tibetan-compose-region (point-min) (point-max)) | |
282 (set-buffer-modified-p buffer-modified-p) | |
20107
4595a463b105
(tibetan-post-read-conversion): Return
Kenichi Handa <handa@m17n.org>
parents:
19553
diff
changeset
|
283 (make-local-variable 'tibetan-decomposed) |
4595a463b105
(tibetan-post-read-conversion): Return
Kenichi Handa <handa@m17n.org>
parents:
19553
diff
changeset
|
284 (setq tibetan-decomposed nil) |
4595a463b105
(tibetan-post-read-conversion): Return
Kenichi Handa <handa@m17n.org>
parents:
19553
diff
changeset
|
285 (- (point-max) (point-min)))))) |
17301 | 286 |
287 | |
288 ;;;###autoload | |
289 (defun tibetan-pre-write-conversion (from to) | |
290 (setq tibetan-decomposed-temp tibetan-decomposed) | |
23522
0f86fe9632e0
(tibetan-pre-write-conversion): Use with-temp-buffer.
Kenichi Handa <handa@m17n.org>
parents:
22987
diff
changeset
|
291 (let ((old-buf (current-buffer))) |
23545
0d25c6f765ab
(tibetan-pre-write-conversion): Cancel previous
Kenichi Handa <handa@m17n.org>
parents:
23522
diff
changeset
|
292 (set-buffer (generate-new-buffer " *temp*")) |
0d25c6f765ab
(tibetan-pre-write-conversion): Cancel previous
Kenichi Handa <handa@m17n.org>
parents:
23522
diff
changeset
|
293 (if (stringp from) |
0d25c6f765ab
(tibetan-pre-write-conversion): Cancel previous
Kenichi Handa <handa@m17n.org>
parents:
23522
diff
changeset
|
294 (insert from) |
0d25c6f765ab
(tibetan-pre-write-conversion): Cancel previous
Kenichi Handa <handa@m17n.org>
parents:
23522
diff
changeset
|
295 (insert-buffer-substring old-buf from to)) |
0d25c6f765ab
(tibetan-pre-write-conversion): Cancel previous
Kenichi Handa <handa@m17n.org>
parents:
23522
diff
changeset
|
296 (if (not tibetan-decomposed-temp) |
0d25c6f765ab
(tibetan-pre-write-conversion): Cancel previous
Kenichi Handa <handa@m17n.org>
parents:
23522
diff
changeset
|
297 (tibetan-decompose-region (point-min) (point-max))) |
17776
ece62fdeeebb
(tibetan-pre-write-conversion): Make it work
Kenichi Handa <handa@m17n.org>
parents:
17315
diff
changeset
|
298 ;; Should return nil as annotations. |
ece62fdeeebb
(tibetan-pre-write-conversion): Make it work
Kenichi Handa <handa@m17n.org>
parents:
17315
diff
changeset
|
299 nil)) |
17301 | 300 |
18309
bd8b521f5218
Provide XXX-util instead of
Kenichi Handa <handa@m17n.org>
parents:
17993
diff
changeset
|
301 (provide 'tibet-util) |
17301 | 302 |
303 ;;; language/tibet-util.el ends here. |