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