Commit | Line | Data |
---|---|---|
348f797a | 1 | ;;; tibet-util.el --- utilities for Tibetan -*- coding: iso-2022-7bit; -*- |
80d75b56 | 2 | |
80d75b56 | 3 | ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. |
fa526c4a | 4 | ;; Licensed to the Free Software Foundation. |
80d75b56 KH |
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 | ||
e8af40ee | 29 | ;;; History: |
80d75b56 KH |
30 | ;; 1997.03.13 Modification in treatment of text properties; |
31 | ;; Support for some special signs and punctuations. | |
3bdf8898 | 32 | ;; 1999.10.25 Modification for a new composition way by K.Handa. |
80d75b56 | 33 | |
e8af40ee PJ |
34 | ;;; Commentary: |
35 | ||
80d75b56 KH |
36 | ;;; Code: |
37 | ||
80d75b56 | 38 | ;;;###autoload |
3bdf8898 KH |
39 | (defun tibetan-char-p (ch) |
40 | "Check if char CH is Tibetan character. | |
41 | Returns non-nil if CH is Tibetan. Otherwise, returns nil." | |
42 | (memq (char-charset ch) '(tibetan tibetan-1-column))) | |
80d75b56 | 43 | |
3bdf8898 | 44 | ;;; Functions for Tibetan <-> Tibetan-transcription. |
80d75b56 KH |
45 | |
46 | ;;;###autoload | |
3bdf8898 KH |
47 | (defun tibetan-tibetan-to-transcription (str) |
48 | "Transcribe Tibetan string STR and return the corresponding Roman string." | |
49 | (let (;; Accumulate transcriptions here in reverse order. | |
50 | (trans nil) | |
51 | (len (length str)) | |
52 | (i 0) | |
53 | ch this-trans) | |
54 | (while (< i len) | |
ff69c4ee | 55 | (let ((idx (string-match tibetan-precomposition-rule-regexp str i))) |
3bdf8898 KH |
56 | (if (eq idx i) |
57 | ;; Ith character and the followings matches precomposable | |
58 | ;; Tibetan sequence. | |
59 | (setq i (match-end 0) | |
60 | this-trans | |
61 | (car (rassoc | |
62 | (cdr (assoc (match-string 0 str) | |
63 | tibetan-precomposition-rule-alist)) | |
64 | tibetan-precomposed-transcription-alist))) | |
65 | (setq ch (substring str i (1+ i)) | |
66 | i (1+ i) | |
67 | this-trans | |
68 | (car (or (rassoc ch tibetan-consonant-transcription-alist) | |
69 | (rassoc ch tibetan-vowel-transcription-alist) | |
70 | (rassoc ch tibetan-subjoined-transcription-alist))))) | |
71 | (setq trans (cons this-trans trans)))) | |
72 | (apply 'concat (nreverse trans)))) | |
80d75b56 | 73 | |
3bdf8898 KH |
74 | ;;;###autoload |
75 | (defun tibetan-transcription-to-tibetan (str) | |
76 | "Convert Tibetan Roman string STR to Tibetan character string. | |
77 | The returned string has no composition information." | |
78 | (let (;; Case is significant. | |
79 | (case-fold-search nil) | |
80 | (idx 0) | |
81 | ;; Accumulate Tibetan strings here in reverse order. | |
82 | (t-str-list nil) | |
83 | i subtrans) | |
84 | (while (setq i (string-match tibetan-regexp str idx)) | |
85 | (if (< idx i) | |
86 | ;; STR contains a pattern that doesn't match Tibetan | |
87 | ;; transcription. Include the pattern as is. | |
88 | (setq t-str-list (cons (substring str idx i) t-str-list))) | |
89 | (setq subtrans (match-string 0 str) | |
90 | idx (match-end 0)) | |
91 | (let ((t-char (cdr (assoc subtrans | |
92 | tibetan-precomposed-transcription-alist)))) | |
93 | (if t-char | |
94 | ;; SUBTRANS corresponds to a transcription for | |
95 | ;; precomposable Tibetan sequence. | |
96 | (setq t-char (car (rassoc t-char | |
97 | tibetan-precomposition-rule-alist))) | |
98 | (setq t-char | |
99 | (cdr | |
100 | (or (assoc subtrans tibetan-consonant-transcription-alist) | |
101 | (assoc subtrans tibetan-vowel-transcription-alist) | |
102 | (assoc subtrans tibetan-modifier-transcription-alist) | |
103 | (assoc subtrans tibetan-subjoined-transcription-alist))))) | |
104 | (setq t-str-list (cons t-char t-str-list)))) | |
105 | (if (< idx (length str)) | |
106 | (setq t-str-list (cons (substring str idx) t-str-list))) | |
107 | (apply 'concat (nreverse t-str-list)))) | |
80d75b56 KH |
108 | |
109 | ;;; | |
3bdf8898 | 110 | ;;; Functions for composing/decomposing Tibetan sequence. |
80d75b56 KH |
111 | ;;; |
112 | ;;; A Tibetan syllable is typically structured as follows: | |
113 | ;;; | |
114 | ;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]] | |
115 | ;;; | |
116 | ;;; where C's are all vertically stacked, V appears below or above | |
117 | ;;; consonant cluster and M is always put above the C[C+]V combination. | |
118 | ;;; (Sanskrit visarga, though it is a vowel modifier, is considered | |
119 | ;;; to be a punctuation.) | |
120 | ;;; | |
ff69c4ee | 121 | ;;; Here are examples of the words "bsgrubs" and "hfauM" |
80d75b56 | 122 | ;;; |
ff69c4ee | 123 | ;;; \e4\e$(7"7\e0"7\e1\e4%qx!"U\e0"G###C"U\e1\e4"7\e0"7\e1\e4"G\e0"G\e1\e(B \e4\e$(7"Hx!"Rx!"Ur'"_\e0"H"R"U"_\e1\e(B |
80d75b56 KH |
124 | ;;; |
125 | ;;; M | |
126 | ;;; b s b s h | |
ff69c4ee | 127 | ;;; g fa |
80d75b56 KH |
128 | ;;; r u |
129 | ;;; u | |
130 | ;;; | |
3bdf8898 KH |
131 | ;;; Consonants `'' (\e$(7"A\e(B), `w' (\e$(7">\e(B), `y' (\e$(7"B\e(B), `r' (\e$(7"C\e(B) take special |
132 | ;;; forms when they are used as subjoined consonant. Consonant `r' | |
133 | ;;; takes another special form when used as superjoined in such a case | |
134 | ;;; as "rka", while it does not change its form when conjoined with | |
135 | ;;; subjoined `'', `w' or `y' as in "rwa", "rya". | |
136 | ||
137 | ;; Append a proper composition rule and glyph to COMPONENTS to compose | |
138 | ;; CHAR with a composition that has COMPONENTS. | |
139 | ||
140 | (defun tibetan-add-components (components char) | |
141 | (let ((last (last components)) | |
142 | (stack-upper '(tc . bc)) | |
143 | (stack-under '(bc . tc)) | |
7258f9ca | 144 | rule comp-vowel tmp) |
3bdf8898 KH |
145 | ;; Special treatment for 'a chung. |
146 | ;; If 'a follows a consonant, turn it into the subjoined form. | |
7258f9ca KH |
147 | ;; * Disabled by Tomabechi 2000/06/09 * |
148 | ;; Because in Unicode, \e$(7"A\e(B may follow directly a consonant without | |
149 | ;; any intervening vowel, as in \e4\e$(7"9\e0"9\e1\e4""\e0"""Q\e1\e4"A\e0"A\e1!;\e(B=\e4\e$(7"9\e0"9\e1\e(B \e4\e$(7""\e0""\e1\e(B \e4\e$(7"A\e0"A\e1\e(B not \e4\e$(7"9\e0"9\e1\e(B \e4\e$(7""\e0""\e1\e(B \e$(7"Q\e(B \e4\e$(7"A\e0"A\e1\e(B | |
150 | ;;(if (and (= char ?\e$(7"A\e(B) | |
151 | ;; (aref (char-category-set (car last)) ?0)) | |
152 | ;; (setq char ?\e$(7"R\e(B)) ;; modified for new font by Tomabechi 1999/12/10 | |
153 | ||
154 | ;; Composite vowel signs are decomposed before being added | |
155 | ;; Added by Tomabechi 2000/06/08 | |
156 | (if (memq char '(?\e$(7"T\e(B ?\e$(7"V\e(B ?\e$(7"W\e(B ?\e$(7"X\e(B ?\e$(7"Y\e(B ?\e$(7"Z\e(B ?\e$(7"b\e(B)) | |
157 | (setq comp-vowel | |
ff69c4ee KH |
158 | (copy-sequence |
159 | (cddr (assoc (char-to-string char) | |
160 | tibetan-composite-vowel-alist))) | |
7258f9ca KH |
161 | char |
162 | (cadr (assoc (char-to-string char) | |
163 | tibetan-composite-vowel-alist)))) | |
3bdf8898 KH |
164 | (cond |
165 | ;; Compose upper vowel sign vertically over. | |
166 | ((aref (char-category-set char) ?2) | |
167 | (setq rule stack-upper)) | |
168 | ||
169 | ;; Compose lower vowel sign vertically under. | |
170 | ((aref (char-category-set char) ?3) | |
6b12c749 KH |
171 | (if (eq char ?\e$(7"Q\e(B) ;; `\e$(7"Q\e(B' should not visible when composed. |
172 | (setq rule nil) | |
173 | (setq rule stack-under))) | |
3bdf8898 KH |
174 | ;; Transform ra-mgo (superscribed r) if followed by a subjoined |
175 | ;; consonant other than w, ', y, r. | |
176 | ((and (= (car last) ?\e$(7"C\e(B) | |
6b12c749 KH |
177 | (not (memq char '(?\e$(7#>\e(B ?\e$(7"R\e(B ?\e$(7#B\e(B ?\e$(7#C\e(B)))) |
178 | (setcar last ?\e$(7!"\e(B) ;; modified for newfont by Tomabechi 1999/12/10 | |
3bdf8898 | 179 | (setq rule stack-under)) |
3bdf8898 KH |
180 | ;; Transform initial base consonant if followed by a subjoined |
181 | ;; consonant but 'a. | |
182 | (t | |
183 | (let ((laststr (char-to-string (car last)))) | |
6b12c749 KH |
184 | (if (and (/= char ?\e$(7"R\e(B) ;; modified for new font by Tomabechi |
185 | (string-match "[\e$(7"!\e(B-\e$(7"="?"@"D\e(B-\e$(7"J"K\e(B]" laststr)) | |
3bdf8898 KH |
186 | (setcar last (string-to-char |
187 | (cdr (assoc (char-to-string (car last)) | |
188 | tibetan-base-to-subjoined-alist))))) | |
189 | (setq rule stack-under)))) | |
190 | ||
6b12c749 | 191 | (if rule |
7258f9ca KH |
192 | (setcdr last (list rule char))) |
193 | ;; Added by Tomabechi 2000/06/08 | |
194 | (if comp-vowel | |
195 | (nconc last comp-vowel)) | |
196 | )) | |
80d75b56 KH |
197 | |
198 | ;;;###autoload | |
199 | (defun tibetan-compose-string (str) | |
3bdf8898 KH |
200 | "Compose Tibetan string STR." |
201 | (let ((idx 0)) | |
202 | ;; `\e$(7"A\e(B' is included in the pattern for subjoined consonants | |
203 | ;; because we treat it specially in tibetan-add-components. | |
7258f9ca | 204 | ;; (This feature is removed by Tomabechi 2000/06/08) |
3bdf8898 KH |
205 | (while (setq idx (string-match tibetan-composable-pattern str idx)) |
206 | (let ((from idx) | |
207 | (to (match-end 0)) | |
208 | components) | |
209 | (if (eq (string-match tibetan-precomposition-rule-regexp str idx) idx) | |
210 | (setq idx (match-end 0) | |
211 | components | |
212 | (list (string-to-char | |
213 | (cdr | |
214 | (assoc (match-string 0 str) | |
215 | tibetan-precomposition-rule-alist))))) | |
216 | (setq components (list (aref str idx)) | |
217 | idx (1+ idx))) | |
218 | (while (< idx to) | |
219 | (tibetan-add-components components (aref str idx)) | |
220 | (setq idx (1+ idx))) | |
221 | (compose-string str from to components)))) | |
222 | str) | |
80d75b56 KH |
223 | |
224 | ;;;###autoload | |
3bdf8898 KH |
225 | (defun tibetan-compose-region (beg end) |
226 | "Compose Tibetan text the region BEG and END." | |
80d75b56 | 227 | (interactive "r") |
3bdf8898 | 228 | (let (str result chars) |
80d75b56 KH |
229 | (save-excursion |
230 | (save-restriction | |
231 | (narrow-to-region beg end) | |
232 | (goto-char (point-min)) | |
3bdf8898 KH |
233 | ;; `\e$(7"A\e(B' is included in the pattern for subjoined consonants |
234 | ;; because we treat it specially in tibetan-add-components. | |
7258f9ca | 235 | ;; (This feature is removed by Tomabechi 2000/06/08) |
3bdf8898 KH |
236 | (while (re-search-forward tibetan-composable-pattern nil t) |
237 | (let ((from (match-beginning 0)) | |
238 | (to (match-end 0)) | |
239 | components) | |
240 | (goto-char from) | |
241 | (if (looking-at tibetan-precomposition-rule-regexp) | |
242 | (progn | |
243 | (setq components | |
244 | (list (string-to-char | |
245 | (cdr | |
246 | (assoc (match-string 0) | |
247 | tibetan-precomposition-rule-alist))))) | |
248 | (goto-char (match-end 0))) | |
249 | (setq components (list (char-after from))) | |
250 | (forward-char 1)) | |
251 | (while (< (point) to) | |
252 | (tibetan-add-components components (following-char)) | |
253 | (forward-char 1)) | |
254 | (compose-region from to components))))))) | |
80d75b56 | 255 | |
6b12c749 KH |
256 | (defvar tibetan-decompose-precomposition-alist |
257 | (mapcar (function (lambda (x) (cons (string-to-char (cdr x)) (car x)))) | |
258 | tibetan-precomposition-rule-alist)) | |
259 | ||
80d75b56 | 260 | ;;;###autoload |
6b12c749 KH |
261 | (defun tibetan-decompose-region (from to) |
262 | "Decompose Tibetan text in the region FROM and TO. | |
263 | This is different from decompose-region because precomposed Tibetan characters | |
264 | are decomposed into normal Tiebtan character sequences." | |
265 | (interactive "r") | |
266 | (save-restriction | |
267 | (narrow-to-region from to) | |
268 | (decompose-region from to) | |
269 | (goto-char from) | |
270 | (while (not (eobp)) | |
271 | (let* ((char (following-char)) | |
272 | (slot (assq char tibetan-decompose-precomposition-alist))) | |
273 | (if slot | |
274 | (progn | |
275 | (delete-char 1) | |
276 | (insert (cdr slot))) | |
277 | (forward-char 1)))))) | |
278 | ||
279 | ||
3bdf8898 | 280 | ;;;###autoload |
6b12c749 KH |
281 | (defun tibetan-decompose-string (str) |
282 | "Decompose Tibetan string STR. | |
283 | This is different from decompose-string because precomposed Tibetan characters | |
284 | are decomposed into normal Tiebtan character sequences." | |
285 | (let ((new "") | |
286 | (len (length str)) | |
287 | (idx 0) | |
288 | char slot) | |
289 | (while (< idx len) | |
290 | (setq char (aref str idx) | |
291 | slot (assq (aref str idx) tibetan-decompose-precomposition-alist) | |
292 | new (concat new (if slot (cdr slot) (char-to-string char))) | |
293 | idx (1+ idx))) | |
294 | new)) | |
3bdf8898 KH |
295 | |
296 | ;;;###autoload | |
297 | (defun tibetan-composition-function (from to pattern &optional string) | |
298 | (if string | |
299 | (tibetan-compose-string string) | |
300 | (tibetan-compose-region from to)) | |
301 | (- to from)) | |
80d75b56 KH |
302 | |
303 | ;;; | |
304 | ;;; This variable is used to avoid repeated decomposition. | |
305 | ;;; | |
306 | (setq-default tibetan-decomposed nil) | |
307 | ||
308 | ;;;###autoload | |
309 | (defun tibetan-decompose-buffer () | |
310 | "Decomposes Tibetan characters in the buffer into their components. | |
3bdf8898 | 311 | See also the documentation of the function `tibetan-decompose-region'." |
80d75b56 KH |
312 | (interactive) |
313 | (make-local-variable 'tibetan-decomposed) | |
314 | (cond ((not tibetan-decomposed) | |
315 | (tibetan-decompose-region (point-min) (point-max)) | |
316 | (setq tibetan-decomposed t)))) | |
317 | ||
318 | ;;;###autoload | |
319 | (defun tibetan-compose-buffer () | |
320 | "Composes Tibetan character components in the buffer. | |
321 | See also docstring of the function tibetan-compose-region." | |
322 | (interactive) | |
323 | (make-local-variable 'tibetan-decomposed) | |
324 | (tibetan-compose-region (point-min) (point-max)) | |
325 | (setq tibetan-decomposed nil)) | |
326 | ||
327 | ;;;###autoload | |
328 | (defun tibetan-post-read-conversion (len) | |
329 | (save-excursion | |
330 | (save-restriction | |
331 | (let ((buffer-modified-p (buffer-modified-p))) | |
332 | (narrow-to-region (point) (+ (point) len)) | |
333 | (tibetan-compose-region (point-min) (point-max)) | |
334 | (set-buffer-modified-p buffer-modified-p) | |
73b4b264 KH |
335 | (make-local-variable 'tibetan-decomposed) |
336 | (setq tibetan-decomposed nil) | |
337 | (- (point-max) (point-min)))))) | |
80d75b56 KH |
338 | |
339 | ||
340 | ;;;###autoload | |
341 | (defun tibetan-pre-write-conversion (from to) | |
342 | (setq tibetan-decomposed-temp tibetan-decomposed) | |
7273226d | 343 | (let ((old-buf (current-buffer))) |
76d12415 KH |
344 | (set-buffer (generate-new-buffer " *temp*")) |
345 | (if (stringp from) | |
346 | (insert from) | |
347 | (insert-buffer-substring old-buf from to)) | |
348 | (if (not tibetan-decomposed-temp) | |
349 | (tibetan-decompose-region (point-min) (point-max))) | |
5d0ae729 KH |
350 | ;; Should return nil as annotations. |
351 | nil)) | |
80d75b56 | 352 | |
650e8505 | 353 | (provide 'tibet-util) |
80d75b56 | 354 | |
e8af40ee | 355 | ;;; tibet-util.el ends here |