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 setup-tibetan-environment ()
  38   (interactive)
  39   (set-language-environment "Tibetan"))
  40
  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.
  48
  49 ;;;###autoload
  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))))
  76
  77 ;;;###autoload
  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.
  82         (case-fold-search nil)
  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))))
 111
 112 ;;;
 113 ;;; Functions for composing/decomposing Tibetan sequence.
 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 ;;;
 126 ;;;            \e$(7"7"G###C"U"7"G\e(B         \e$(7"H"A"U"_\e(B
 127 ;;;
 128 ;;;                             M
 129 ;;;             b s b s         h
 130 ;;;               g             '
 131 ;;;               r             u
 132 ;;;               u
 133 ;;;
 134 ;;; 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
 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.
 142
 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 ?\e$(7"A\e(B)
 151              (aref (char-category-set (car last)) ?0))
 152         (setq char ?\e$(7#A\e(B))
 153
 154     (cond
 155      ;; Compose upper vowel sign vertically over.
 156      ((aref (char-category-set char) ?2)
 157       (setq rule stack-upper))
 158
 159      ;; Compose lower vowel sign vertically under.
 160      ((aref (char-category-set char) ?3)
 161       (setq rule stack-under))
 162
 163      ;; Transform ra-mgo (superscribed r) if followed by a subjoined
 164      ;; consonant other than w, ', y, r.
 165      ((and (= (car last) ?\e$(7"C\e(B)
 166            (not (memq char '(?\e$(7#>\e(B ?\e$(7#A\e(B ?\e$(7#B\e(B ?\e$(7#C\e(B))))
 167       (setcar last ?\e$(7#P\e(B)
 168       (setq rule stack-under))
 169
 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 ?\e$(7#A\e(B)
 175                  (string-match "[\e$(7"!\e(B-\e$(7"="?"@"D\e(B-\e$(7"J\e(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))))
 180
 181     (setcdr last (list rule char))))
 182
 183 ;;;###autoload
 184 (defun tibetan-compose-string (str)
 185   "Compose Tibetan string STR."
 186   (let ((idx 0))
 187     ;; `\e$(7"A\e(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)
 207
 208 ;;;###autoload
 209 (defun tibetan-compose-region (beg end)
 210   "Compose Tibetan text the region BEG and END."
 211   (interactive "r")
 212   (let (str result chars)
 213     (save-excursion
 214       (save-restriction
 215         (narrow-to-region beg end)
 216         (goto-char (point-min))
 217         ;; `\e$(7"A\e(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)))))))
 238
 239 ;;;###autoload
 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))
 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.
 259 See also the documentation of the function `tibetan-decompose-region'."
 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)
 283         (make-local-variable 'tibetan-decomposed)
 284         (setq tibetan-decomposed nil)
 285         (- (point-max) (point-min))))))
 286
 287
 288 ;;;###autoload
 289 (defun tibetan-pre-write-conversion (from to)
 290   (setq tibetan-decomposed-temp tibetan-decomposed)
 291   (let ((old-buf (current-buffer)))
 292     (set-buffer (generate-new-buffer " *temp*"))
 293     (if (stringp from)
 294         (insert from)
 295       (insert-buffer-substring old-buf from to))
 296     (if (not tibetan-decomposed-temp)
 297         (tibetan-decompose-region (point-min) (point-max)))
 298     ;; Should return nil as annotations.
 299     nil))
 300
 301 (provide 'tibet-util)
 302
 303 ;;; language/tibet-util.el ends here.