Mercurial > hg > xemacs-beta
annotate lisp/mule/tibet-util.el @ 5697:40fbceabaafd
menubar-items.el (default-menubar): Reorganize.
Add PROBLEMS to toplevel.
New "More about XEmacs" submenu for NEWS, licensing, etc.
New "Recent History" menu for messages, lossage, etc.
Get rid of ugly and unexpressive ellipses.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Mon, 24 Dec 2012 03:08:33 +0900 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 771 | 1 ;;; tibet-util.el --- utilities for Tibetan -*- coding: iso-2022-7bit; -*- |
| 2 | |
| 3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. | |
| 4 ;; Licensed to the Free Software Foundation. | |
| 5 | |
| 6 ;; Keywords: multilingual, Tibetan | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
10 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
11 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
12 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
13 ;; option) any later version. |
| 771 | 14 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
18 ;; for more details. |
| 771 | 19 |
| 20 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
788
diff
changeset
|
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 771 | 22 |
| 778 | 23 ;;; Synched up with: Emacs 21.1 (language/tibet-util.el). |
| 771 | 24 |
| 25 ;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch> | |
| 26 | |
| 27 ;; Created: Feb. 17. 1997 | |
| 28 | |
| 778 | 29 ;;; History: |
| 771 | 30 ;; 1997.03.13 Modification in treatment of text properties; |
| 31 ;; Support for some special signs and punctuations. | |
| 32 ;; 1999.10.25 Modification for a new composition way by K.Handa. | |
| 33 | |
| 778 | 34 ;;; Commentary: |
| 35 | |
| 771 | 36 ;;; Code: |
| 37 | |
| 38 ;;;###autoload | |
| 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))) | |
| 43 | |
| 44 ;;; Functions for Tibetan <-> Tibetan-transcription. | |
| 45 | |
| 46 ;;;###autoload | |
| 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) | |
| 55 (let ((idx (string-match tibetan-precomposition-rule-regexp str i))) | |
| 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)))) | |
| 73 | |
| 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)))) | |
| 108 | |
| 109 ;;; | |
| 110 ;;; Functions for composing/decomposing Tibetan sequence. | |
| 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 ;;; | |
| 121 ;;; Here are examples of the words "bsgrubs" and "hfauM" | |
| 122 ;;; | |
| 123 ;;; 4$(7"70"714%qx!"U0"G###C"U14"70"714"G0"G1(B 4$(7"Hx!"Rx!"Ur'"_0"H"R"U"_1(B | |
| 124 ;;; | |
| 125 ;;; M | |
| 126 ;;; b s b s h | |
| 127 ;;; g fa | |
| 128 ;;; r u | |
| 129 ;;; u | |
| 130 ;;; | |
| 131 ;;; Consonants `'' ($(7"A(B), `w' ($(7">(B), `y' ($(7"B(B), `r' ($(7"C(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)) | |
| 788 | 144 rule comp-vowel ;tmp |
| 145 ) | |
| 771 | 146 ;; Special treatment for 'a chung. |
| 147 ;; If 'a follows a consonant, turn it into the subjoined form. | |
| 148 ;; * Disabled by Tomabechi 2000/06/09 * | |
| 149 ;; Because in Unicode, $(7"A(B may follow directly a consonant without | |
| 150 ;; any intervening vowel, as in 4$(7"90"914""0"""Q14"A0"A1!;(B=4$(7"90"91(B 4$(7""0""1(B 4$(7"A0"A1(B not 4$(7"90"91(B 4$(7""0""1(B $(7"Q(B 4$(7"A0"A1(B | |
| 151 ;;(if (and (= char ?$(7"A(B) | |
| 788 | 152 ;; (char-in-category-p (car last) ?0)) |
| 771 | 153 ;; (setq char ?$(7"R(B)) ;; modified for new font by Tomabechi 1999/12/10 |
| 154 | |
| 155 ;; Composite vowel signs are decomposed before being added | |
| 156 ;; Added by Tomabechi 2000/06/08 | |
| 157 (if (memq char '(?$(7"T(B ?$(7"V(B ?$(7"W(B ?$(7"X(B ?$(7"Y(B ?$(7"Z(B ?$(7"b(B)) | |
| 158 (setq comp-vowel | |
| 159 (copy-sequence | |
| 160 (cddr (assoc (char-to-string char) | |
| 161 tibetan-composite-vowel-alist))) | |
| 162 char | |
| 163 (cadr (assoc (char-to-string char) | |
| 164 tibetan-composite-vowel-alist)))) | |
| 165 (cond | |
| 166 ;; Compose upper vowel sign vertically over. | |
| 788 | 167 ((char-in-category-p char ?2) |
| 771 | 168 (setq rule stack-upper)) |
| 169 | |
| 170 ;; Compose lower vowel sign vertically under. | |
| 788 | 171 ((char-in-category-p char ?3) |
| 771 | 172 (if (eq char ?$(7"Q(B) ;; `$(7"Q(B' should not visible when composed. |
| 173 (setq rule nil) | |
| 174 (setq rule stack-under))) | |
| 175 ;; Transform ra-mgo (superscribed r) if followed by a subjoined | |
| 176 ;; consonant other than w, ', y, r. | |
| 177 ((and (= (car last) ?$(7"C(B) | |
| 178 (not (memq char '(?$(7#>(B ?$(7"R(B ?$(7#B(B ?$(7#C(B)))) | |
| 179 (setcar last ?$(7!"(B) ;; modified for newfont by Tomabechi 1999/12/10 | |
| 180 (setq rule stack-under)) | |
| 181 ;; Transform initial base consonant if followed by a subjoined | |
| 182 ;; consonant but 'a. | |
| 183 (t | |
| 184 (let ((laststr (char-to-string (car last)))) | |
| 185 (if (and (/= char ?$(7"R(B) ;; modified for new font by Tomabechi | |
| 186 (string-match "[$(7"!(B-$(7"="?"@"D(B-$(7"J"K(B]" laststr)) | |
| 187 (setcar last (string-to-char | |
| 188 (cdr (assoc (char-to-string (car last)) | |
| 189 tibetan-base-to-subjoined-alist))))) | |
| 190 (setq rule stack-under)))) | |
| 191 | |
| 192 (if rule | |
| 193 (setcdr last (list rule char))) | |
| 194 ;; Added by Tomabechi 2000/06/08 | |
| 195 (if comp-vowel | |
| 196 (nconc last comp-vowel)) | |
| 197 )) | |
| 198 | |
| 199 ;;;###autoload | |
| 200 (defun tibetan-compose-string (str) | |
| 201 "Compose Tibetan string STR." | |
| 202 (let ((idx 0)) | |
| 203 ;; `$(7"A(B' is included in the pattern for subjoined consonants | |
| 204 ;; because we treat it specially in tibetan-add-components. | |
| 205 ;; (This feature is removed by Tomabechi 2000/06/08) | |
| 206 (while (setq idx (string-match tibetan-composable-pattern str idx)) | |
| 207 (let ((from idx) | |
| 208 (to (match-end 0)) | |
| 209 components) | |
| 210 (if (eq (string-match tibetan-precomposition-rule-regexp str idx) idx) | |
| 211 (setq idx (match-end 0) | |
| 212 components | |
| 213 (list (string-to-char | |
| 214 (cdr | |
| 215 (assoc (match-string 0 str) | |
| 216 tibetan-precomposition-rule-alist))))) | |
| 217 (setq components (list (aref str idx)) | |
| 218 idx (1+ idx))) | |
| 219 (while (< idx to) | |
| 220 (tibetan-add-components components (aref str idx)) | |
| 221 (setq idx (1+ idx))) | |
| 222 (compose-string str from to components)))) | |
| 223 str) | |
| 224 | |
| 225 ;;;###autoload | |
| 226 (defun tibetan-compose-region (beg end) | |
| 227 "Compose Tibetan text the region BEG and END." | |
| 228 (interactive "r") | |
| 788 | 229 ;(let (str result chars) |
| 771 | 230 (save-excursion |
| 231 (save-restriction | |
| 232 (narrow-to-region beg end) | |
| 233 (goto-char (point-min)) | |
| 234 ;; `$(7"A(B' is included in the pattern for subjoined consonants | |
| 235 ;; because we treat it specially in tibetan-add-components. | |
| 236 ;; (This feature is removed by Tomabechi 2000/06/08) | |
| 237 (while (re-search-forward tibetan-composable-pattern nil t) | |
| 238 (let ((from (match-beginning 0)) | |
| 239 (to (match-end 0)) | |
| 240 components) | |
| 241 (goto-char from) | |
| 242 (if (looking-at tibetan-precomposition-rule-regexp) | |
| 243 (progn | |
| 244 (setq components | |
| 245 (list (string-to-char | |
| 246 (cdr | |
| 247 (assoc (match-string 0) | |
| 248 tibetan-precomposition-rule-alist))))) | |
| 249 (goto-char (match-end 0))) | |
| 250 (setq components (list (char-after from))) | |
| 251 (forward-char 1)) | |
| 252 (while (< (point) to) | |
| 253 (tibetan-add-components components (following-char)) | |
| 254 (forward-char 1)) | |
| 788 | 255 (compose-region from to components))))) |
| 256 ;) | |
| 257 ) | |
| 771 | 258 |
| 259 (defvar tibetan-decompose-precomposition-alist | |
| 260 (mapcar (function (lambda (x) (cons (string-to-char (cdr x)) (car x)))) | |
| 261 tibetan-precomposition-rule-alist)) | |
| 262 | |
| 263 ;;;###autoload | |
| 264 (defun tibetan-decompose-region (from to) | |
| 265 "Decompose Tibetan text in the region FROM and TO. | |
| 266 This is different from decompose-region because precomposed Tibetan characters | |
| 267 are decomposed into normal Tiebtan character sequences." | |
| 268 (interactive "r") | |
| 269 (save-restriction | |
| 270 (narrow-to-region from to) | |
| 271 (decompose-region from to) | |
| 272 (goto-char from) | |
| 273 (while (not (eobp)) | |
| 274 (let* ((char (following-char)) | |
| 275 (slot (assq char tibetan-decompose-precomposition-alist))) | |
| 276 (if slot | |
| 277 (progn | |
| 278 (delete-char 1) | |
| 279 (insert (cdr slot))) | |
| 280 (forward-char 1)))))) | |
| 281 | |
| 282 | |
| 283 ;;;###autoload | |
| 284 (defun tibetan-decompose-string (str) | |
| 285 "Decompose Tibetan string STR. | |
| 286 This is different from decompose-string because precomposed Tibetan characters | |
| 287 are decomposed into normal Tiebtan character sequences." | |
| 288 (let ((new "") | |
| 289 (len (length str)) | |
| 290 (idx 0) | |
| 291 char slot) | |
| 292 (while (< idx len) | |
| 293 (setq char (aref str idx) | |
| 294 slot (assq (aref str idx) tibetan-decompose-precomposition-alist) | |
| 295 new (concat new (if slot (cdr slot) (char-to-string char))) | |
| 296 idx (1+ idx))) | |
| 297 new)) | |
| 298 | |
| 299 ;;;###autoload | |
| 300 (defun tibetan-composition-function (from to pattern &optional string) | |
| 301 (if string | |
| 302 (tibetan-compose-string string) | |
| 303 (tibetan-compose-region from to)) | |
| 304 (- to from)) | |
| 305 | |
| 306 ;;; | |
| 307 ;;; This variable is used to avoid repeated decomposition. | |
| 308 ;;; | |
| 309 (setq-default tibetan-decomposed nil) | |
| 310 | |
| 311 ;;;###autoload | |
| 312 (defun tibetan-decompose-buffer () | |
| 313 "Decomposes Tibetan characters in the buffer into their components. | |
| 314 See also the documentation of the function `tibetan-decompose-region'." | |
| 315 (interactive) | |
| 316 (make-local-variable 'tibetan-decomposed) | |
| 317 (cond ((not tibetan-decomposed) | |
| 318 (tibetan-decompose-region (point-min) (point-max)) | |
| 319 (setq tibetan-decomposed t)))) | |
| 320 | |
| 321 ;;;###autoload | |
| 322 (defun tibetan-compose-buffer () | |
| 323 "Composes Tibetan character components in the buffer. | |
| 324 See also docstring of the function tibetan-compose-region." | |
| 325 (interactive) | |
| 326 (make-local-variable 'tibetan-decomposed) | |
| 327 (tibetan-compose-region (point-min) (point-max)) | |
| 328 (setq tibetan-decomposed nil)) | |
| 329 | |
| 330 ;;;###autoload | |
| 331 (defun tibetan-post-read-conversion (len) | |
| 332 (save-excursion | |
| 333 (save-restriction | |
| 334 (let ((buffer-modified-p (buffer-modified-p))) | |
| 335 (narrow-to-region (point) (+ (point) len)) | |
| 336 (tibetan-compose-region (point-min) (point-max)) | |
| 337 (set-buffer-modified-p buffer-modified-p) | |
| 338 (make-local-variable 'tibetan-decomposed) | |
| 339 (setq tibetan-decomposed nil) | |
| 340 (- (point-max) (point-min)))))) | |
| 341 | |
| 342 | |
| 343 ;;;###autoload | |
| 344 (defun tibetan-pre-write-conversion (from to) | |
| 345 (setq tibetan-decomposed-temp tibetan-decomposed) | |
| 346 (let ((old-buf (current-buffer))) | |
| 347 (set-buffer (generate-new-buffer " *temp*")) | |
| 348 (if (stringp from) | |
| 349 (insert from) | |
| 350 (insert-buffer-substring old-buf from to)) | |
| 351 (if (not tibetan-decomposed-temp) | |
| 352 (tibetan-decompose-region (point-min) (point-max))) | |
| 353 ;; Should return nil as annotations. | |
| 354 nil)) | |
| 355 | |
| 356 (provide 'tibet-util) | |
| 357 | |
| 778 | 358 ;;; tibet-util.el ends here |