1 ;;; tibet-util.el --- utilities for Tibetan -*- coding: iso-2022-7bit; -*-
3 ;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006
4 ;; Free Software Foundation, Inc.
5 ;; Copyright (C) 1995, 1997, 1998, 2000
6 ;; National Institute of Advanced Industrial Science and Technology (AIST)
7 ;; Registration Number H14PRO021
9 ;; Keywords: multilingual, Tibetan
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 ;; Boston, MA 02110-1301, USA.
28 ;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch>
30 ;; Created: Feb. 17. 1997
33 ;; 1997.03.13 Modification in treatment of text properties;
34 ;; Support for some special signs and punctuations.
35 ;; 1999.10.25 Modification for a new composition way by K.Handa.
41 (defconst tibetan-obsolete-glyphs
42 `(("\e$(7!=\e(B" .
"\e$(8!=\e(B") ; 2 col <-> 1 col
43 ("\e$(7!?\e(B" .
"\e$(8!?\e(B")
44 ("\e$(7!@\e(B" .
"\e$(8!@\e(B")
45 ("\e$(7!A\e(B" .
"\e$(8!A\e(B")
46 ("\e$(7"`\e(B" . "\e$
(8"`\e(B")
47 ("\e$(7!;\e(B" .
"\e$(8!;\e(B")
48 ("\e$(7!D\e(B" .
"\e$(8!D\e(B")
49 ;; Yes these are dirty. But ...
50 ("\e$(7!>\e(B \e$(7!>\e(B" .
,(compose-string "\e$(7!>\e(B \e$(7!>\e(B" 0 3 [?
\e$
(7!>\e(B (Br . Bl
) ?
(Br . Bl
) ?
\e$
(7!>\e(B]))
51 ("\e$(7!4!5!5\e(B" .
,(compose-string
52 "\e$(7#R#S#S#S\e(B" 0 4
53 [?
\e$
(7#R
\e(B (Br . Bl
) ?
\e$
(7#S
\e(B (Br . Bl
) ?
\e$
(7#S
\e(B (Br . Bl
) ?
\e$
(7#S
\e(B]))
54 ("\e$(7!4!5\e(B" .
,(compose-string "\e$(7#R#S#S\e(B" 0 3 [?
\e$
(7#R
\e(B (Br . Bl
) ?
\e$
(7#S
\e(B (Br . Bl
) ?
\e$
(7#S
\e(B]))
55 ("\e$(7!6\e(B" .
,(compose-string "\e$(7#R#S!I\e(B" 0 3 [?
\e$
(7#R
\e(B (Br . Bl
) ?
\e$
(7#S
\e(B (br . tr
) ?
\e$
(7!I
\e(B]))
56 ("\e$(7!4\e(B" .
,(compose-string "\e$(7#R#S\e(B" 0 2 [?
\e$
(7#R
\e(B (Br . Bl
) ?
\e$
(7#S
\e(B]))))
59 (defun tibetan-char-p (ch)
60 "Check if char CH is Tibetan character.
61 Returns non-nil if CH is Tibetan. Otherwise, returns nil."
62 (memq (char-charset ch
) '(tibetan tibetan-1-column
)))
64 ;;; Functions for Tibetan <-> Tibetan-transcription.
67 (defun tibetan-tibetan-to-transcription (str)
68 "Transcribe Tibetan string STR and return the corresponding Roman string."
69 (let (;; Accumulate transcriptions here in reverse order.
75 (let ((idx (string-match tibetan-precomposition-rule-regexp str i
)))
77 ;; Ith character and the followings matches precomposable
82 (cdr (assoc (match-string 0 str
)
83 tibetan-precomposition-rule-alist
))
84 tibetan-precomposed-transcription-alist
)))
85 (setq ch
(substring str i
(1+ i
))
88 (car (or (rassoc ch tibetan-consonant-transcription-alist
)
89 (rassoc ch tibetan-vowel-transcription-alist
)
90 (rassoc ch tibetan-subjoined-transcription-alist
)))))
91 (setq trans
(cons this-trans trans
))))
92 (apply 'concat
(nreverse trans
))))
95 (defun tibetan-transcription-to-tibetan (str)
96 "Convert Tibetan Roman string STR to Tibetan character string.
97 The returned string has no composition information."
98 (let (;; Case is significant.
99 (case-fold-search nil
)
101 ;; Accumulate Tibetan strings here in reverse order.
104 (while (setq i
(string-match tibetan-regexp str idx
))
106 ;; STR contains a pattern that doesn't match Tibetan
107 ;; transcription. Include the pattern as is.
108 (setq t-str-list
(cons (substring str idx i
) t-str-list
)))
109 (setq subtrans
(match-string 0 str
)
111 (let ((t-char (cdr (assoc subtrans
112 tibetan-precomposed-transcription-alist
))))
114 ;; SUBTRANS corresponds to a transcription for
115 ;; precomposable Tibetan sequence.
116 (setq t-char
(car (rassoc t-char
117 tibetan-precomposition-rule-alist
)))
120 (or (assoc subtrans tibetan-consonant-transcription-alist
)
121 (assoc subtrans tibetan-vowel-transcription-alist
)
122 (assoc subtrans tibetan-modifier-transcription-alist
)
123 (assoc subtrans tibetan-subjoined-transcription-alist
)))))
124 (setq t-str-list
(cons t-char t-str-list
))))
125 (if (< idx
(length str
))
126 (setq t-str-list
(cons (substring str idx
) t-str-list
)))
127 (apply 'concat
(nreverse t-str-list
))))
130 ;;; Functions for composing/decomposing Tibetan sequence.
132 ;;; A Tibetan syllable is typically structured as follows:
134 ;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]]
136 ;;; where C's are all vertically stacked, V appears below or above
137 ;;; consonant cluster and M is always put above the C[C+]V combination.
138 ;;; (Sanskrit visarga, though it is a vowel modifier, is considered
139 ;;; to be a punctuation.)
141 ;;; Here are examples of the words "bsgrubs" and "hfauM"
143 ;;; \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
151 ;;; 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
152 ;;; forms when they are used as subjoined consonant. Consonant `r'
153 ;;; takes another special form when used as superjoined in such a case
154 ;;; as "rka", while it does not change its form when conjoined with
155 ;;; subjoined `'', `w' or `y' as in "rwa", "rya".
157 ;; Append a proper composition rule and glyph to COMPONENTS to compose
158 ;; CHAR with a composition that has COMPONENTS.
160 (defun tibetan-add-components (components char
)
161 (let ((last (last components
))
162 (stack-upper '(tc . bc
))
163 (stack-under '(bc . tc
))
165 ;; Special treatment for 'a chung.
166 ;; If 'a follows a consonant, turn it into the subjoined form.
167 ;; * Disabled by Tomabechi 2000/06/09 *
168 ;; Because in Unicode, \e$(7"A\e(B may follow directly a consonant without
169 ;; 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
170 ;;(if (and (= char ?\e$(7"A\e(B)
171 ;; (aref (char-category-set (car last)) ?0))
172 ;; (setq char ?\e$(7"R\e(B)) ;; modified for new font by Tomabechi 1999/12/10
174 ;; Composite vowel signs are decomposed before being added
175 ;; Added by Tomabechi 2000/06/08
176 (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))
179 (cddr (assoc (char-to-string char)
180 tibetan-composite-vowel-alist)))
182 (cadr (assoc (char-to-string char)
183 tibetan-composite-vowel-alist))))
185 ;; Compose upper vowel sign vertically over.
186 ((aref (char-category-set char) ?2)
187 (setq rule stack-upper))
189 ;; Compose lower vowel sign vertically under.
190 ((aref (char-category-set char) ?3)
191 (if (eq char ?\e$(7"Q
\e(B) ;; `\e$(7"Q\e(B' should not visible when composed.
193 (setq rule stack-under
)))
194 ;; Transform ra-mgo (superscribed r) if followed by a subjoined
195 ;; consonant other than w, ', y, r.
196 ((and (= (car last
) ?
\e$
(7"C\e(B)
197 (not (memq char '(?\e$(7#>\e(B ?\e$(7"R
\e(B ?
\e$
(7#B
\e(B ?
\e$
(7#C
\e(B))))
198 (setcar last ?
\e$
(7!"\e(B) ;; modified for newfont by Tomabechi 1999/12/10
199 (setq rule stack-under))
200 ;; Transform initial base consonant if followed by a subjoined
203 (let ((laststr (char-to-string (car last))))
204 (if (and (/= char ?\e$(7"R
\e(B) ;; modified for new font by Tomabechi
205 (string-match "[\e$(7"!\e(B-\e$
(7"="?
"@"D
\e(B-\e$
(7"J"K
\e(B]" laststr))
206 (setcar last (string-to-char
207 (cdr (assoc (char-to-string (car last))
208 tibetan-base-to-subjoined-alist)))))
209 (setq rule stack-under))))
212 (setcdr last (list rule char)))
213 ;; Added by Tomabechi 2000/06/08
215 (nconc last comp-vowel))
219 (defun tibetan-compose-string (str)
220 "Compose Tibetan string STR.
"
222 ;; `\e$(7"A
\e(B' is included in the pattern for subjoined consonants
223 ;; because we treat it specially in tibetan-add-components.
224 ;; (This feature is removed by Tomabechi 2000/06/08)
225 (while (setq idx
(string-match tibetan-composable-pattern str idx
))
229 (if (eq (string-match tibetan-precomposition-rule-regexp str idx
) idx
)
230 (setq idx
(match-end 0)
232 (list (string-to-char
234 (assoc (match-string 0 str
)
235 tibetan-precomposition-rule-alist
)))))
236 (setq components
(list (aref str idx
))
239 (tibetan-add-components components
(aref str idx
))
241 (compose-string str from to components
))))
245 (defun tibetan-compose-region (beg end
)
246 "Compose Tibetan text the region BEG and END."
248 (let (str result chars
)
251 (narrow-to-region beg end
)
252 (goto-char (point-min))
253 ;; `\e$(7"A\e(B' is included in the pattern for subjoined consonants
254 ;; because we treat it specially in tibetan-add-components.
255 ;; (This feature is removed by Tomabechi 2000/06/08)
256 (while (re-search-forward tibetan-composable-pattern nil t
)
257 (let ((from (match-beginning 0))
261 (if (looking-at tibetan-precomposition-rule-regexp
)
264 (list (string-to-char
266 (assoc (match-string 0)
267 tibetan-precomposition-rule-alist
)))))
268 (goto-char (match-end 0)))
269 (setq components
(list (char-after from
)))
271 (while (< (point) to
)
272 (tibetan-add-components components
(following-char))
274 (compose-region from to components
)))))))
276 (defvar tibetan-decompose-precomposition-alist
277 (mapcar (function (lambda (x) (cons (string-to-char (cdr x
)) (car x
))))
278 tibetan-precomposition-rule-alist
))
281 (defun tibetan-decompose-region (from to
)
282 "Decompose Tibetan text in the region FROM and TO.
283 This is different from decompose-region because precomposed Tibetan characters
284 are decomposed into normal Tibetan character sequences."
287 (narrow-to-region from to
)
288 (decompose-region from to
)
291 (let* ((char (following-char))
292 (slot (assq char tibetan-decompose-precomposition-alist
)))
297 (forward-char 1))))))
301 (defun tibetan-decompose-string (str)
302 "Decompose Tibetan string STR.
303 This is different from decompose-string because precomposed Tibetan characters
304 are decomposed into normal Tibetan character sequences."
310 (setq char
(aref str idx
)
311 slot
(assq (aref str idx
) tibetan-decompose-precomposition-alist
)
312 new
(concat new
(if slot
(cdr slot
) (char-to-string char
)))
317 (defun tibetan-composition-function (from to pattern
&optional string
)
319 (tibetan-compose-string string
)
320 (tibetan-compose-region from to
))
324 ;;; This variable is used to avoid repeated decomposition.
326 (setq-default tibetan-decomposed nil
)
329 (defun tibetan-decompose-buffer ()
330 "Decomposes Tibetan characters in the buffer into their components.
331 See also the documentation of the function `tibetan-decompose-region'."
333 (make-local-variable 'tibetan-decomposed
)
334 (cond ((not tibetan-decomposed
)
335 (tibetan-decompose-region (point-min) (point-max))
336 (setq tibetan-decomposed t
))))
339 (defun tibetan-compose-buffer ()
340 "Composes Tibetan character components in the buffer.
341 See also docstring of the function tibetan-compose-region."
343 (make-local-variable 'tibetan-decomposed
)
344 (tibetan-compose-region (point-min) (point-max))
345 (setq tibetan-decomposed nil
))
348 (defun tibetan-post-read-conversion (len)
351 (let ((buffer-modified-p (buffer-modified-p)))
352 (narrow-to-region (point) (+ (point) len
))
353 (tibetan-compose-region (point-min) (point-max))
354 (set-buffer-modified-p buffer-modified-p
)
355 (make-local-variable 'tibetan-decomposed
)
356 (setq tibetan-decomposed nil
)
357 (- (point-max) (point-min))))))
361 (defun tibetan-pre-write-conversion (from to
)
362 (setq tibetan-decomposed-temp tibetan-decomposed
)
363 (let ((old-buf (current-buffer)))
364 (set-buffer (generate-new-buffer " *temp*"))
367 (insert-buffer-substring old-buf from to
))
368 (if (not tibetan-decomposed-temp
)
369 (tibetan-decompose-region (point-min) (point-max)))
370 ;; Should return nil as annotations.
375 ;;; Unicode-related definitions.
378 (defvar tibetan-canonicalize-for-unicode-alist
379 '(("\e$(7"Q
\e(B" . "") ;; remove vowel a
380 ("\e$
(7"T\e(B" .
"\e$(7"R
"S\e(B") ;; decompose vowels whose use is ``discouraged'' in Unicode 3.0
381 ("\e$(7"V
\e(B" . "\e$
(7"R"U
\e(B")
382 ("\e$
(7"W\e(B" .
"\e$(7#C"a
\e(B")
383 ("\e$
(7"X\e(B" .
"\e$(7#C"R
"a\e(B")
384 ("\e$(7"Y
\e(B" . "\e$
(7#D
"a\e(B")
385 ("\e$(7"Z
\e(B" . "\e$
(7#D
"R"a
\e(B")
386 ("\e$
(7"b\e(B" .
"\e$(7"R
"a\e(B"))
387 "Rules for canonicalizing Tibetan vowels for Unicode.")
389 (defvar tibetan-canonicalize-for-unicode-regexp
390 "[\e$(7"Q
"T"V
"W"X
"Y"Z
"b\e(B]"
391 "Regexp for Tibetan vowels to be canonicalized in Unicode.")
393 (defun tibetan-canonicalize-for-unicode-region (from to
)
395 (narrow-to-region from to
)
397 (while (re-search-forward tibetan-canonicalize-for-unicode-regexp nil t
)
399 ;;(from (match-beginning 0))
402 (cdr (assoc (match-string 0)
403 tibetan-canonicalize-for-unicode-alist
))))
405 ;;(delete-region from to)
406 ;;(insert canonical-form)
407 (replace-match canonical-form
)
410 (defvar tibetan-strict-unicode t
411 "*Flag to control Tibetan canonicalizing for Unicode.
413 If non-nil, the vowel a is removed and composite vowels are decomposed
414 before writing buffer in Unicode. See also
415 `tibetan-canonicalize-for-unicode-regexp' and
416 `tibetan-canonicalize-for-unicode-alist'.")
419 (defun tibetan-pre-write-canonicalize-for-unicode (from to
)
420 (let ((old-buf (current-buffer))
421 (strict-unicode tibetan-strict-unicode
))
422 (set-buffer (generate-new-buffer " *temp*"))
425 (insert-buffer-substring old-buf from to
))
427 (tibetan-canonicalize-for-unicode-region (point-min) (point-max)))
428 ;; Should return nil as annotations.
431 (provide 'tibet-util
)
433 ;;; arch-tag: 7a7333e8-1584-446c-b39c-a02b9def265d
434 ;;; tibet-util.el ends here