code.delx.au - gnu-emacs/blob - lisp/language/tibet-util.el

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