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
  33 ;;; Code:
  34
  35 ;;;###autoload
  36 (defun setup-tibetan-environment ()
  37   (interactive)
  38   (setup-english-environment)
  39   (setq coding-category-iso-8-2 'tibetan)
  40
  41   (setq-default buffer-file-coding-system 'iso-2022-7bit)
  42
  43   (setq default-input-method  "tibetan-wylie"))
  44
  45 ;;; This function makes a transcription string for
  46 ;;; re-composing a character.
  47
  48 ;;;###autoload
  49 (defun tibetan-tibetan-to-transcription (ch)
  50   "Return a transcription string of Tibetan character CH"
  51   (let ((char ch)
  52         (l (append tibetan-consonant-transcription-alist
  53                    tibetan-vowel-transcription-alist
  54                    tibetan-precomposed-transcription-alist
  55                    tibetan-subjoined-transcription-alist))
  56         decomp-l t-char trans str result)
  57     (if (eq (char-charset char) 'composition)
  58         (setq decomp-l (decompose-composite-char char 'list nil))
  59       (setq decomp-l (cons char nil)))
  60     (setq str "")
  61     (while decomp-l
  62       (setq t-char (char-to-string (car decomp-l)))
  63       (setq trans (car (rassoc t-char l)))
  64       (setq str (concat str trans))
  65       (setq decomp-l (cdr decomp-l)))
  66     (setq result str)))
  67
  68 ;;; This function translates transcription string into a string of
  69 ;;; Tibetan characters.
  70
  71 ;;;###autoload
  72 (defun tibetan-transcription-to-tibetan (transcription)
  73   "Translate Roman transcription into a sequence of Tibetan components."
  74   (let ((trans transcription)
  75         (lp tibetan-precomposed-transcription-alist)
  76         (l (append tibetan-consonant-transcription-alist
  77                    tibetan-vowel-transcription-alist
  78                    tibetan-subjoined-transcription-alist))
  79         (case-fold-search nil)
  80         substr t-char p-str t-str result)
  81     (setq substr "")
  82     (setq p-str "")
  83     (setq t-str "")
  84     (cond ((string-match tibetan-precomposed-regexp trans)
  85            (setq substr (substring trans (match-beginning 0) (match-end 0)))
  86            (setq trans (substring trans (match-end 0)))
  87            (setq t-char (cdr (assoc substr lp)))
  88            (setq p-str t-char)))
  89     (while (string-match tibetan-regexp trans)
  90       (setq substr (substring trans (match-beginning 0) (match-end 0)))
  91       (setq trans (substring trans 0 (match-beginning 0)))
  92       (setq t-char
  93             (cdr (assoc substr l)))
  94       (setq t-str (concat t-char t-str)))
  95     (setq result (concat p-str t-str))))
  96
  97
  98 ;;;
  99 ;;; Functions for composing Tibetan character.
 100 ;;;
 101 ;;; A Tibetan syllable is typically structured as follows:
 102 ;;;
 103 ;;;      [Prefix] C [C+] V [M] [Suffix [Post suffix]]
 104 ;;;
 105 ;;; where C's are all vertically stacked, V appears below or above
 106 ;;; consonant cluster and M is always put above the C[C+]V combination.
 107 ;;; (Sanskrit visarga, though it is a vowel modifier, is considered
 108 ;;;  to be a punctuation.)
 109 ;;;
 110 ;;; Here are examples of the words "bsgrubs" and "h'uM"
 111 ;;;
 112 ;;;            \e$(7"7\e2%q`"U\e1"7"G\e(B         \e2\e$(7"H`#A`"U0"_\e1\e(B
 113 ;;;
 114 ;;;                             M
 115 ;;;             b s b s         h
 116 ;;;               g             '
 117 ;;;               r             u
 118 ;;;               u
 119 ;;;
 120 ;;; Consonants ''', 'w', 'y', 'r' take special forms when they are used
 121 ;;; as subjoined consonant. Consonant 'r' takes another special form
 122 ;;; when used as superjoined as in "rka", and so on, while it does not
 123 ;;; change its form when conjoined with subjoined ''', 'w' or 'y'
 124 ;;; as in "rwa", "rya".
 125 ;;;
 126 ;;;
 127 ;;; As a Tibetan input method should avoid using conversion key,
 128 ;;; we use a "Tibetan glyph -> transcription -> Tibetan glyph"
 129 ;;; translation at each key input.
 130 ;;;
 131 ;;; 1st stage -  Check the preceding char.
 132 ;;;              If the preceding char is Tibetan and composable, then
 133 ;;;
 134 ;;; 2nd stage -  Translate the preceding char into transcription
 135 ;;;
 136 ;;; 3rd stage -  Concatenate the transcription of preceding char
 137 ;;;              and the current input key.
 138 ;;;
 139 ;;; 4th stage -  Re-translate the concatenated transcription into
 140 ;;;              a sequence of Tibetan letters.
 141 ;;;
 142 ;;; 5th stage -  Convert leading consonants into one single precomposed char
 143 ;;;              if possible.
 144 ;;;
 145 ;;; 6th stage -  Compose the consonants into one composite glyph.
 146 ;;;
 147 ;;; (If the current input is a vowel sign or a vowel modifier,
 148 ;;;  then it is composed with preceding char without checking
 149 ;;;  except when the preceding char is a punctuation or a digit.)
 150 ;;;
 151 ;;;
 152
 153 ;;; This function is used to avoid composition
 154 ;;;      between Tibetan and non-Tibetan chars.
 155
 156 ;;;###autoload
 157 (defun tibetan-char-examin (ch)
 158   "Check if char CH is Tibetan character.
 159 Returns non-nil if CH is Tibetan. Otherwise, returns nil."
 160   (let ((chr ch))
 161     (if (eq (char-charset chr) 'composition)
 162         (string-match "\\cq+" (decompose-composite-char chr))
 163       (string-match "\\cq" (char-to-string chr)))))
 164
 165 ;;; This is used to avoid composition between digits, signs, punctuations
 166 ;;; and word constituents.
 167
 168 ;;;###autoload
 169 (defun tibetan-composable-examin (ch)
 170   "Check if Tibetan char CH is composable.
 171 Returns t if CH is a composable char \(i.e. neither punctuation nor digit)."
 172   (let ((chr ch)
 173         chstr)
 174     (if (eq (char-charset chr) 'composition)
 175         (setq chstr (decompose-composite-char chr))
 176       (setq chstr (char-to-string chr)))
 177     (not (string-match "[\e$(7!1\e(B-\e$(7!o"f\e$(8!;!=!?!@!A!D"`\e(B]" chstr))))
 178
 179
 180 ;;; This checks if a character to be composed contains already
 181 ;;; one or more vowels / vowel modifiers. If the character contains
 182 ;;; them, then no more consonant should be added.
 183
 184 ;;;###autoload
 185 (defun tibetan-complete-char-examin (ch)
 186   "Check if composite char CH contains one or more vowel/vowel modifiers.
 187 Returns non-nil, if CH contains vowel/vowel modifiers."
 188   (let ((chr ch)
 189         chstr)
 190     (if (eq (char-charset chr) 'composition)
 191         (setq chstr (decompose-composite-char chr))
 192       (setq chstr (char-to-string chr)))
 193     (string-match "[\e$(7!g!e"Q\e(B-\e$(7"^"_\e(B-\e$(7"l\e(B]" chstr)))
 194
 195 ;;; This function makes a composite character consisting of two characters
 196 ;;; vertically stacked.
 197
 198 ;;;###autoload
 199 (defun tibetan-vertical-stacking (first second upward)
 200   "Return a vertically stacked composite char consisting of FIRST and SECOND.
 201 If UPWARD is non-nil, then SECOND is put above FIRST."
 202   (if upward
 203       (compose-chars first '(tc . bc) second)
 204     (compose-chars first '(bc . tc) second)))
 205
 206 ;;; This function makes a composite char from a string.
 207 ;;; Note that this function returns a string, not a char.
 208
 209 ;;;###autoload
 210 (defun tibetan-compose-string (str)
 211   "Compose a sequence of Tibetan character components into a composite character.
 212 Returns a string containing a composite character."
 213   (let ((t-str str)
 214         f-str s-str f-ch s-ch rest composed result)
 215     ;;Make sure no redundant vowel sign is present.
 216     (if (string-match
 217          "^\\(.+\\)\\(\e$(7"Q\e(B\\)\\([\e$(7!I!g!e"Q\e(B-\e$(7"^"_\e(B-\e$(7"l\e(B]\\)" t-str)
 218         (setq t-str (concat
 219                      (match-string 1 t-str)
 220                      (match-string 3 t-str))))
 221     (if (string-match
 222          "^\\(.+\\)\\([\e$(7!I!g!e"Q\e(B-\e$(7"^"_\e(B-\e$(7"l\e(B]\\)\\(\e$(7"Q\e(B\\)" t-str)
 223         (setq t-str (concat
 224                      (match-string 1 t-str)
 225                      (match-string 2 t-str))))
 226     ;;Start conversion.
 227     (setq result "")
 228     ;; Consecutive base/precomposed consonants are reduced to the last one.
 229     (while (string-match "^\\([\e$(7"!\e(B-\e$(7"J$!\e(B-\e$(7%u\e(B]\\)\\([\e$(7"!\e(B-\e$(7"@"B\e(B-\e$(7"J$!\e(B-\e$(7%u\e(B].*\\)" t-str)
 230       (setq result (concat result (match-string 1 t-str)))
 231       (setq t-str (match-string 2 t-str)))
 232     ;; Vowel/vowel modifier, subjoined consonants are added one by one
 233     ;; to the preceding element.
 234     (while
 235         (string-match "^\\(.\\)\\([\e$(7"A#!\e(B-\e$(7#J!I!g!e"Q\e(B-\e$(7"^"_\e(B-\e$(7"l\e(B]\\)\\(.*\\)" t-str)
 236       (setq f-str (match-string 1 t-str))
 237       (setq f-ch (string-to-char f-str))
 238       (setq s-str (match-string 2 t-str))
 239       ;;Special treatment for 'a chung.
 240       ;;If 'a follows a consonant, then turned into its subjoined form.
 241       (if (and (string-match "\e$(7"A\e(B" s-str)
 242                (not (tibetan-complete-char-examin f-ch)))
 243           (setq s-str "\e$(7#A\e(B"))
 244       (setq s-ch (string-to-char s-str))
 245       (setq rest (match-string 3 t-str))
 246       (cond ((string-match "\\c2" s-str);; upper vowel sign
 247              (setq composed
 248                    (tibetan-vertical-stacking f-ch s-ch t)))
 249             ((string-match "\\c3" s-str);; lower vowel sign
 250              (setq composed
 251                    (tibetan-vertical-stacking f-ch s-ch nil)))
 252             ;;Automatic conversion of ra-mgo (superscribed r).
 253             ;;'r' is converted if followed by a subjoined consonant
 254             ;;other than w, ', y, r.
 255             ((and (string-match "\e$(7"C\e(B" f-str)
 256                   (not (string-match "[\e$(7#>#A#B#C\e(B]" s-str)))
 257              (setq f-ch ?\e$(7#P\e(B)
 258              (setq composed
 259                    (tibetan-vertical-stacking f-ch s-ch nil)))
 260             ((not (tibetan-complete-char-examin f-ch))
 261              ;;Initial base consonant is tranformed, if followed by
 262              ;;a subjoined consonant, except when it is followed
 263              ;;by a subscribed 'a.
 264              (if (and (string-match "[\e$(7"!\e(B-\e$(7"="?"@"D\e(B-\e$(7"J\e(B]" f-str)
 265                       (not (string-match "\e$(7#A\e(B" s-str)))
 266                  (setq f-ch
 267                        (string-to-char
 268                         (cdr (assoc f-str tibetan-base-to-subjoined-alist)))))
 269              (setq composed
 270                    (tibetan-vertical-stacking f-ch s-ch nil)))
 271             (t
 272              (setq composed s-str)
 273              (setq result (concat result f-str))))
 274       (setq t-str (concat composed rest)))
 275     (setq result (concat result t-str))))
 276
 277 ;;; quail <-> conversion interface.
 278
 279 ;;;###autoload
 280 (defun tibetan-composition (pc key)
 281   "Interface to quail input method.
 282 Takes two arguments: char PC and string KEY, where PC is the preceding
 283 character to be composed with current input KEY.
 284 Returns a string which is the result of composition."
 285   (let (trans cur-ch t-str result)
 286     ;; Make a tibetan character corresponding to current input key.
 287     (setq cur-ch (tibetan-transcription-to-tibetan key))
 288     ;; Check if the preceding character is Tibetan and composable.
 289     (cond ((and (tibetan-char-examin pc)
 290                 (tibetan-composable-examin pc))
 291            ;;If Tibetan char corresponding to the current input key exists,
 292            (cond (cur-ch
 293                   ;; Then,
 294                   ;; Convert the preceding character into transcription,
 295                   ;; and concatenate it with the current input key,
 296                   (setq trans (tibetan-tibetan-to-transcription pc))
 297                   (setq trans (concat trans key))
 298                   ;; Concatenated transcription is converted to
 299                   ;; a sequence of Tibetan characters,
 300                   (setq t-str (tibetan-transcription-to-tibetan trans))
 301                   ;; And it is composed into a composite character.
 302                   (setq result (tibetan-compose-string t-str)))
 303                  ;; Else,
 304                  (t
 305                   ;; Simply concatenate the preceding character and
 306                   ;; the current input key.
 307                   (setq result (char-to-string pc))
 308                   (setq result (concat result key)))))
 309           ;; If the preceding char is not Tibetan or not composable,
 310           (t
 311            ;; pc = 0 means the point is at the beginning of buffer.
 312            (if (not (eq pc 0))
 313                (setq result (char-to-string pc)))
 314            (if cur-ch
 315                (setq result (concat result cur-ch))
 316              (setq result (concat result key))))
 317           )))
 318
 319
 320 ;;;###autoload
 321 (defun tibetan-decompose-region (beg end)
 322   "Decompose Tibetan characters in the region BEG END into their components.
 323 Components are: base and subjoined consonants, vowel signs, vowel modifiers.
 324 One column punctuations are converted to their 2 column equivalents."
 325   (interactive "r")
 326   (let (ch-str ch-beg ch-end)
 327     (save-excursion
 328       (save-restriction
 329         (narrow-to-region beg end)
 330         (goto-char (point-min))
 331         ;; \\cq = Tibetan character
 332         (while (re-search-forward "\\cq" nil t)
 333           (setq ch-str (buffer-substring-no-properties
 334                         (match-beginning 0) (match-end 0)))
 335           ;; Save the points. Maybe, using save-match-data is preferable.
 336           ;; But in order not to lose the trace(because the body is too long),
 337           ;; we save the points in variables.
 338           (setq ch-beg (match-beginning 0))
 339           (setq ch-end (match-end 0))
 340           ;; Here starts the decomposition.
 341           (cond
 342            ;; 1 column punctuations -> 2 column equivalent
 343            ((string-match "[\e$(8!D!;!=!?!@!A"`\e(B]" ch-str)
 344             (setq ch-str
 345                   (car (rassoc ch-str tibetan-precomposition-rule-alist))))
 346            ;; Decomposition of composite character.
 347            ((eq (char-charset (string-to-char ch-str)) 'composition)
 348             ;; Make a string which consists of a sequence of
 349             ;; components.
 350             (setq ch-str (decompose-composite-char (string-to-char ch-str)))
 351             ;; Converts nyi zla into base elements.
 352             (cond ((string= ch-str "\e$(7#R#S#S#S\e(B")
 353                    (setq ch-str "\e$(7!4!5!5\e(B"))
 354                   ((string= ch-str "\e$(7#R#S#S\e(B")
 355                    (setq ch-str "\e$(7!4!5\e(B"))
 356                   ((string= ch-str "\e$(7#R#S!I\e(B")
 357                    (setq ch-str "\e$(7!6\e(B"))
 358                   ((string= ch-str "\e$(7#R#S\e(B")
 359                    (setq ch-str "\e$(7!4\e(B")))))
 360           ;; If the sequence of components starts with a subjoined consonants,
 361           (if (string-match "^\\([\e$(7#!\e(B-\e$(7#J\e(B]\\)\\(.*\\)$" ch-str)
 362               ;; then the first components is converted to its base form.
 363               (setq ch-str
 364                     (concat (car (rassoc (match-string 1 ch-str)
 365                                          tibetan-base-to-subjoined-alist))
 366                             (match-string 2 ch-str))))
 367           ;; If the sequence of components starts with a precomposed character,
 368           (if (string-match "^\\([\e$(7$!\e(B-\e$(7%u\e(B]\\)\\(.*\\)$" ch-str)
 369               ;; then it is converted into a sequence of components.
 370               (setq ch-str
 371                     (concat (car (rassoc (match-string 1 ch-str)
 372                                          tibetan-precomposition-rule-alist))
 373                             (match-string 2 ch-str))))
 374           ;; Special treatment for superscribed r.
 375           (if (string-match "^\e$(7#P\e(B\\(.*\\)$" ch-str)
 376               (setq ch-str (concat "\e$(7"C\e(B" (match-string 1 ch-str))))
 377           ;; Finally, the result of decomposition is inserted, and
 378           ;; the composite character is deleted.
 379           (insert-and-inherit ch-str)
 380           (delete-region ch-beg ch-end))))))
 381
 382 ;;;###autoload
 383 (defun tibetan-compose-region (beg end)
 384   "Make composite chars from Tibetan character components in the region BEG END.
 385 Two column punctuations are converted to their 1 column equivalents."
 386   (interactive "r")
 387   (let (str result)
 388     (save-excursion
 389       (save-restriction
 390         (narrow-to-region beg end)
 391         (goto-char (point-min))
 392         ;; First, sequence of components which has a precomposed equivalent
 393         ;; is converted.
 394         (while (re-search-forward
 395                 tibetan-precomposition-rule-regexp nil t)
 396           (setq str (buffer-substring-no-properties
 397                      (match-beginning 0) (match-end 0)))
 398           (save-match-data
 399             (insert-and-inherit
 400              (cdr (assoc str tibetan-precomposition-rule-alist))))
 401           (delete-region (match-beginning 0) (match-end 0)))
 402         (goto-char (point-min))
 403         ;; Then, composable elements are put into a composite character.
 404         (while (re-search-forward
 405                 "[\e$(7"!\e(B-\e$(7"J$!\e(B-\e$(7%u\e(B]+[\e$(7#!\e(B-\e$(7#J!I!g!e"Q\e(B-\e$(7"^"_\e(B-\e$(7"l\e(B]+"
 406                 nil t)
 407           (setq str (buffer-substring-no-properties
 408                      (match-beginning 0) (match-end 0)))
 409           (save-match-data
 410             (setq result (tibetan-compose-string str))
 411             (insert-and-inherit result))
 412           (delete-region (match-beginning 0) (match-end 0)))))))
 413
 414 ;;;
 415 ;;; This variable is used to avoid repeated decomposition.
 416 ;;;
 417 (setq-default tibetan-decomposed nil)
 418
 419 ;;;###autoload
 420 (defun tibetan-decompose-buffer ()
 421   "Decomposes Tibetan characters in the buffer into their components.
 422 See also docstring of the function tibetan-decompose-region."
 423   (interactive)
 424   (make-local-variable 'tibetan-decomposed)
 425   (cond ((not tibetan-decomposed)
 426          (tibetan-decompose-region (point-min) (point-max))
 427          (setq tibetan-decomposed t))))
 428
 429 ;;;###autoload
 430 (defun tibetan-compose-buffer ()
 431   "Composes Tibetan character components in the buffer.
 432 See also docstring of the function tibetan-compose-region."
 433   (interactive)
 434   (make-local-variable 'tibetan-decomposed)
 435   (tibetan-compose-region (point-min) (point-max))
 436   (setq tibetan-decomposed nil))
 437
 438 ;;;###autoload
 439 (defun tibetan-post-read-conversion (len)
 440   (save-excursion
 441     (save-restriction
 442       (let ((buffer-modified-p (buffer-modified-p)))
 443         (narrow-to-region (point) (+ (point) len))
 444         (tibetan-compose-region (point-min) (point-max))
 445         (set-buffer-modified-p buffer-modified-p)
 446         (point-max))))
 447   (make-local-variable 'tibetan-decomposed)
 448   (setq tibetan-decomposed nil))
 449
 450
 451 ;;;###autoload
 452 (defun tibetan-pre-write-conversion (from to)
 453   (setq tibetan-decomposed-temp tibetan-decomposed)
 454   (let ((old-buf (current-buffer))
 455         (work-buf (get-buffer-create " *tibetan-work*")))
 456     (set-buffer work-buf)
 457     (erase-buffer)
 458     (if (stringp from)
 459         (insert from)
 460       (insert-buffer-substring old-buf from to))
 461     (if (not tibetan-decomposed-temp)
 462         (tibetan-decompose-region (point-min) (point-max)))
 463     ;; Should return nil as annotations.
 464     nil))
 465
 466 (provide 'tibet-util)
 467
 468 ;;; language/tibet-util.el ends here.