-;;; tibet-util.el --- Support for inputting Tibetan characters
-
-;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
-;; Licensed to the Free Software Foundation.
-
-;; Keywords: multilingual, Tibetan
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch>
-
-;; Created: Feb. 17. 1997
-
-;; History:
-;; 1997.03.13 Modification in treatment of text properties;
-;; Support for some special signs and punctuations.
-
-;;; Code:
-
-;;;###autoload
-(defun setup-tibetan-environment ()
- (interactive)
- (setup-english-environment)
- (setq coding-category-iso-8-2 'tibetan)
-
- (setq-default buffer-file-coding-system 'iso-2022-7)
-
- (setq default-input-method '("Tibetan" . "quail-tibetan-wylie"))
-
- (setq sendmail-coding-system 'iso-2022-7
- rmail-file-coding-system 'iso-2022-7))
-
-;;; This function makes a transcription string for
-;;; re-composing a character.
-
-;;;###autoload
-(defun tibetan-tibetan-to-transcription (ch)
- "Return a transcription string of Tibetan character CH"
- (let ((char ch)
- (l (append tibetan-consonant-transcription-alist
- tibetan-vowel-transcription-alist
- tibetan-precomposed-transcription-alist
- tibetan-subjoined-transcription-alist))
- decomp-l t-char trans str result)
- (if (eq (char-charset char) 'composition)
- (setq decomp-l (decompose-composite-char char 'list nil))
- (setq decomp-l (cons char nil)))
- (setq str "")
- (while decomp-l
- (setq t-char (char-to-string (car decomp-l)))
- (setq trans (car (rassoc t-char l)))
- (setq str (concat str trans))
- (setq decomp-l (cdr decomp-l)))
- (setq result str)))
-
-;;; This function translates transcription string into a string of
-;;; Tibetan characters.
-
-;;;###autoload
-(defun tibetan-transcription-to-tibetan (transcription)
- "Translate Roman transcription into a sequence of Tibetan components."
- (let ((trans transcription)
- (lp tibetan-precomposed-transcription-alist)
- (l (append tibetan-consonant-transcription-alist
- tibetan-vowel-transcription-alist
- tibetan-subjoined-transcription-alist))
- (case-fold-search nil)
- substr t-char p-str t-str result)
- (setq substr "")
- (setq p-str "")
- (setq t-str "")
- (cond ((string-match tibetan-precomposed-regexp trans)
- (setq substr (substring trans (match-beginning 0) (match-end 0)))
- (setq trans (substring trans (match-end 0)))
- (setq t-char (cdr (assoc substr lp)))
- (setq p-str t-char)))
- (while (string-match tibetan-regexp trans)
- (setq substr (substring trans (match-beginning 0) (match-end 0)))
- (setq trans (substring trans 0 (match-beginning 0)))
- (setq t-char
- (cdr (assoc substr l)))
- (setq t-str (concat t-char t-str)))
- (setq result (concat p-str t-str))))
-
-
-;;;
-;;; Functions for composing Tibetan character.
-;;;
-;;; A Tibetan syllable is typically structured as follows:
-;;;
-;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]]
-;;;
-;;; where C's are all vertically stacked, V appears below or above
-;;; consonant cluster and M is always put above the C[C+]V combination.
-;;; (Sanskrit visarga, though it is a vowel modifier, is considered
-;;; to be a punctuation.)
-;;;
-;;; Here are examples of the words "bsgrubs" and "h'uM"
-;;;
-;;; \e$(7"7\e2%q`"U\e1"7"G\e(B \e2\e$(7"H`#A`"U0"_\e1\e(B
-;;;
-;;; M
-;;; b s b s h
-;;; g '
-;;; r u
-;;; u
-;;;
-;;; Consonants ''', 'w', 'y', 'r' take special forms when they are used
-;;; as subjoined consonant. Consonant 'r' takes another special form
-;;; when used as superjoined as in "rka", and so on, while it does not
-;;; change its form when conjoined with subjoined ''', 'w' or 'y'
-;;; as in "rwa", "rya".
-;;;
-;;;
-;;; As a Tibetan input method should avoid using conversion key,
-;;; we use a "Tibetan glyph -> transcription -> Tibetan glyph"
-;;; translation at each key input.
-;;;
-;;; 1st stage - Check the preceding char.
-;;; If the preceding char is Tibetan and composable, then
-;;;
-;;; 2nd stage - Translate the preceding char into transcription
-;;;
-;;; 3rd stage - Concatenate the transcription of preceding char
-;;; and the current input key.
-;;;
-;;; 4th stage - Re-translate the concatenated transcription into
-;;; a sequence of Tibetan letters.
-;;;
-;;; 5th stage - Convert leading consonants into one single precomposed char
-;;; if possible.
-;;;
-;;; 6th stage - Compose the consonants into one composite glyph.
-;;;
-;;; (If the current input is a vowel sign or a vowel modifier,
-;;; then it is composed with preceding char without checking
-;;; except when the preceding char is a punctuation or a digit.)
-;;;
-;;;
-
-;;; This function is used to avoid composition
-;;; between Tibetan and non-Tibetan chars.
-
-;;;###autoload
-(defun tibetan-char-examin (ch)
- "Check if char CH is Tibetan character.
-Returns non-nil if CH is Tibetan. Otherwise, returns nil."
- (let ((chr ch))
- (if (eq (char-charset chr) 'composition)
- (string-match "\\cq+" (decompose-composite-char chr))
- (string-match "\\cq" (char-to-string chr)))))
-
-;;; This is used to avoid composition between digits, signs, punctuations
-;;; and word constituents.
-
-;;;###autoload
-(defun tibetan-composable-examin (ch)
- "Check if Tibetan char CH is composable.
-Returns t if CH is a composable char \(i.e. neither punctuation nor digit)."
- (let ((chr ch)
- chstr)
- (if (eq (char-charset chr) 'composition)
- (setq chstr (decompose-composite-char chr))
- (setq chstr (char-to-string chr)))
- (not (string-match "[\e$(7!1\e(B-\e$(7!o"f\e$(8!;!=!?!@!A!D"`\e(B]" chstr))))
-
-
-;;; This checks if a character to be composed contains already
-;;; one or more vowels / vowel modifiers. If the character contains
-;;; them, then no more consonant should be added.
-
-;;;###autoload
-(defun tibetan-complete-char-examin (ch)
- "Check if composite char CH contains one or more vowel/vowel modifiers.
-Returns non-nil, if CH contains vowel/vowel modifiers."
- (let ((chr ch)
- chstr)
- (if (eq (char-charset chr) 'composition)
- (setq chstr (decompose-composite-char chr))
- (setq chstr (char-to-string chr)))
- (string-match "[\e$(7!g!e"Q\e(B-\e$(7"^"_\e(B-\e$(7"l\e(B]" chstr)))
-
-;;; This function makes a composite character consisting of two characters
-;;; vertically stacked.
-
-;;;###autoload
-(defun tibetan-vertical-stacking (first second upward)
- "Return a vertically stacked composite char consisting of FIRST and SECOND.
-If UPWARD is non-nil, then SECOND is put above FIRST."
- (if upward
- (compose-chars first '(tc . bc) second)
- (compose-chars first '(bc . tc) second)))
-
-;;; This function makes a composite char from a string.
-;;; Note that this function returns a string, not a char.
-
-;;;###autoload
-(defun tibetan-compose-string (str)
- "Compose a sequence of Tibetan character components into a composite character.
-Returns a string containing a composite character."
- (let ((t-str str)
- f-str s-str f-ch s-ch rest composed result)
- ;;Make sure no redundant vowel sign is present.
- (if (string-match
- "^\\(.+\\)\\(\e$(7"Q\e(B\\)\\([\e$(7!I!g!e"Q\e(B-\e$(7"^"_\e(B-\e$(7"l\e(B]\\)" t-str)
- (setq t-str (concat
- (match-string 1 t-str)
- (match-string 3 t-str))))
- (if (string-match
- "^\\(.+\\)\\([\e$(7!I!g!e"Q\e(B-\e$(7"^"_\e(B-\e$(7"l\e(B]\\)\\(\e$(7"Q\e(B\\)" t-str)
- (setq t-str (concat
- (match-string 1 t-str)
- (match-string 2 t-str))))
- ;;Start conversion.
- (setq result "")
- ;; Consecutive base/precomposed consonants are reduced to the last one.
- (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)
- (setq result (concat result (match-string 1 t-str)))
- (setq t-str (match-string 2 t-str)))
- ;; Vowel/vowel modifier, subjoined consonants are added one by one
- ;; to the preceding element.
- (while
- (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)
- (setq f-str (match-string 1 t-str))
- (setq f-ch (string-to-char f-str))
- (setq s-str (match-string 2 t-str))
- ;;Special treatment for 'a chung.
- ;;If 'a follows a consonant, then turned into its subjoined form.
- (if (and (string-match "\e$(7"A\e(B" s-str)
- (not (tibetan-complete-char-examin f-ch)))
- (setq s-str "\e$(7#A\e(B"))
- (setq s-ch (string-to-char s-str))
- (setq rest (match-string 3 t-str))
- (cond ((string-match "\\c2" s-str);; upper vowel sign
- (setq composed
- (tibetan-vertical-stacking f-ch s-ch t)))
- ((string-match "\\c3" s-str);; lower vowel sign
- (setq composed
- (tibetan-vertical-stacking f-ch s-ch nil)))
- ;;Automatic conversion of ra-mgo (superscribed r).
- ;;'r' is converted if followed by a subjoined consonant
- ;;other than w, ', y, r.
- ((and (string-match "\e$(7"C\e(B" f-str)
- (not (string-match "[\e$(7#>#A#B#C\e(B]" s-str)))
- (setq f-ch ?\e$(7#P\e(B)
- (setq composed
- (tibetan-vertical-stacking f-ch s-ch nil)))
- ((not (tibetan-complete-char-examin f-ch))
- ;;Initial base consonant is tranformed, if followed by
- ;;a subjoined consonant, except when it is followed
- ;;by a subscribed 'a.
- (if (and (string-match "[\e$(7"!\e(B-\e$(7"="?"@"D\e(B-\e$(7"J\e(B]" f-str)
- (not (string-match "\e$(7#A\e(B" s-str)))
- (setq f-ch
- (string-to-char
- (cdr (assoc f-str tibetan-base-to-subjoined-alist)))))
- (setq composed
- (tibetan-vertical-stacking f-ch s-ch nil)))
- (t
- (setq composed s-str)
- (setq result (concat result f-str))))
- (setq t-str (concat composed rest)))
- (setq result (concat result t-str))))
-
-;;; quail <-> conversion interface.
-
-(defun tibetan-composition (pc key)
- "Interface to quail input method.
-Takes two arguments: char PC and string KEY, where PC is the preceding
-character to be composed with current input KEY.
-Returns a string which is the result of composition."
- (let (trans cur-ch t-str result)
- ;; Make a tibetan character corresponding to current input key.
- (setq cur-ch (tibetan-transcription-to-tibetan key))
- ;; Check if the preceding character is Tibetan and composable.
- (cond ((and (tibetan-char-examin pc)
- (tibetan-composable-examin pc))
- ;;If Tibetan char corresponding to the current input key exists,
- (cond (cur-ch
- ;; Then,
- ;; Convert the preceding character into transcription,
- ;; and concatenate it with the current input key,
- (setq trans (tibetan-tibetan-to-transcription pc))
- (setq trans (concat trans key))
- ;; Concatenated transcription is converted to
- ;; a sequence of Tibetan characters,
- (setq t-str (tibetan-transcription-to-tibetan trans))
- ;; And it is composed into a composite character.
- (setq result (tibetan-compose-string t-str)))
- ;; Else,
- (t
- ;; Simply concatenate the preceding character and
- ;; the current input key.
- (setq result (char-to-string pc))
- (setq result (concat result key)))))
- ;; If the preceding char is not Tibetan or not composable,
- (t
- ;; pc = 0 means the point is at the beginning of buffer.
- (if (not (eq pc 0))
- (setq result (char-to-string pc)))
- (if cur-ch
- (setq result (concat result cur-ch))
- (setq result (concat result key))))
- )))
-
-
-;;;###autoload
-(defun tibetan-decompose-region (beg end)
- "Decompose Tibetan characters in the region BEG END into their components.
-Components are: base and subjoined consonants, vowel signs, vowel modifiers.
-One column punctuations are converted to their 2 column equivalents."
- (interactive "r")
- (let (ch-str ch-beg ch-end)
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (goto-char (point-min))
- ;; \\cq = Tibetan character
- (while (re-search-forward "\\cq" nil t)
- (setq ch-str (buffer-substring-no-properties
- (match-beginning 0) (match-end 0)))
- ;; Save the points. Maybe, using save-match-data is preferable.
- ;; But in order not to lose the trace(because the body is too long),
- ;; we save the points in variables.
- (setq ch-beg (match-beginning 0))
- (setq ch-end (match-end 0))
- ;; Here starts the decomposition.
- (cond
- ;; 1 column punctuations -> 2 column equivalent
- ((string-match "[\e$(8!D!;!=!?!@!A"`\e(B]" ch-str)
- (setq ch-str
- (car (rassoc ch-str tibetan-precomposition-rule-alist))))
- ;; Decomposition of composite character.
- ((eq (char-charset (string-to-char ch-str)) 'composition)
- ;; Make a string which consists of a sequence of
- ;; components.
- (setq ch-str (decompose-composite-char (string-to-char ch-str)))
- ;; Converts nyi zla into base elements.
- (cond ((string= ch-str "\e$(7#R#S#S#S\e(B")
- (setq ch-str "\e$(7!4!5!5\e(B"))
- ((string= ch-str "\e$(7#R#S#S\e(B")
- (setq ch-str "\e$(7!4!5\e(B"))
- ((string= ch-str "\e$(7#R#S!I\e(B")
- (setq ch-str "\e$(7!6\e(B"))
- ((string= ch-str "\e$(7#R#S\e(B")
- (setq ch-str "\e$(7!4\e(B")))))
- ;; If the sequence of components starts with a subjoined consonants,
- (if (string-match "^\\([\e$(7#!\e(B-\e$(7#J\e(B]\\)\\(.*\\)$" ch-str)
- ;; then the first components is converted to its base form.
- (setq ch-str
- (concat (car (rassoc (match-string 1 ch-str)
- tibetan-base-to-subjoined-alist))
- (match-string 2 ch-str))))
- ;; If the sequence of components starts with a precomposed character,
- (if (string-match "^\\([\e$(7$!\e(B-\e$(7%u\e(B]\\)\\(.*\\)$" ch-str)
- ;; then it is converted into a sequence of components.
- (setq ch-str
- (concat (car (rassoc (match-string 1 ch-str)
- tibetan-precomposition-rule-alist))
- (match-string 2 ch-str))))
- ;; Special treatment for superscribed r.
- (if (string-match "^\e$(7#P\e(B\\(.*\\)$" ch-str)
- (setq ch-str (concat "\e$(7"C\e(B" (match-string 1 ch-str))))
- ;; Finally, the result of decomposition is inserted, and
- ;; the composite character is deleted.
- (insert-and-inherit ch-str)
- (delete-region ch-beg ch-end))))))
-
-;;;###autoload
-(defun tibetan-compose-region (beg end)
- "Make composite chars from Tibetan character components in the region BEG END.
-Two column punctuations are converted to their 1 column equivalents."
- (interactive "r")
- (let (str result)
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (goto-char (point-min))
- ;; First, sequence of components which has a precomposed equivalent
- ;; is converted.
- (while (re-search-forward
- tibetan-precomposition-rule-regexp nil t)
- (setq str (buffer-substring-no-properties
- (match-beginning 0) (match-end 0)))
- (save-match-data
- (insert-and-inherit
- (cdr (assoc str tibetan-precomposition-rule-alist))))
- (delete-region (match-beginning 0) (match-end 0)))
- (goto-char (point-min))
- ;; Then, composable elements are put into a composite character.
- (while (re-search-forward
- "[\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]+"
- nil t)
- (setq str (buffer-substring-no-properties
- (match-beginning 0) (match-end 0)))
- (save-match-data
- (setq result (tibetan-compose-string str))
- (insert-and-inherit result))
- (delete-region (match-beginning 0) (match-end 0)))))))
-
-;;;
-;;; This variable is used to avoid repeated decomposition.
-;;;
-(setq-default tibetan-decomposed nil)
-
-;;;###autoload
-(defun tibetan-decompose-buffer ()
- "Decomposes Tibetan characters in the buffer into their components.
-See also docstring of the function tibetan-decompose-region."
- (interactive)
- (make-local-variable 'tibetan-decomposed)
- (cond ((not tibetan-decomposed)
- (tibetan-decompose-region (point-min) (point-max))
- (setq tibetan-decomposed t))))
-
-;;;###autoload
-(defun tibetan-compose-buffer ()
- "Composes Tibetan character components in the buffer.
-See also docstring of the function tibetan-compose-region."
- (interactive)
- (make-local-variable 'tibetan-decomposed)
- (tibetan-compose-region (point-min) (point-max))
- (setq tibetan-decomposed nil))
-
-;;;###autoload
-(defun tibetan-post-read-conversion (len)
- (save-excursion
- (save-restriction
- (let ((buffer-modified-p (buffer-modified-p)))
- (narrow-to-region (point) (+ (point) len))
- (tibetan-compose-region (point-min) (point-max))
- (set-buffer-modified-p buffer-modified-p)
- (point-max))))
- (make-local-variable 'tibetan-decomposed)
- (setq tibetan-decomposed nil))
-
-
-;;;###autoload
-(defun tibetan-pre-write-conversion (from to)
- (setq tibetan-decomposed-temp tibetan-decomposed)
- (let ((old-buf (current-buffer))
- (work-buf (get-buffer-create " *tibetan-work*")))
- (set-buffer work-buf)
- (erase-buffer)
- (if (stringp from)
- (insert from)
- (insert-buffer-substring old-buf from to))
- (if (not tibetan-decomposed-temp)
- (tibetan-decompose-region (point-min) (point-max)))
- ;; Should return nil as annotations.
- nil))
-
-(provide 'tibet-util)
-
-;;; language/tibet-util.el ends here.
+;;; tibet-util.el --- utilities for Tibetan -*- coding: iso-2022-7bit; -*-
+
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
+
+;; Keywords: multilingual, Tibetan
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch>
+
+;; Created: Feb. 17. 1997
+
+;;; History:
+;; 1997.03.13 Modification in treatment of text properties;
+;; Support for some special signs and punctuations.
+;; 1999.10.25 Modification for a new composition way by K.Handa.
+
+;;; Commentary:
+
+;;; Code:
+
+(defconst tibetan-obsolete-glyphs
+ `(("\e$(7!=\e(B" . "\e$(8!=\e(B") ; 2 col <-> 1 col
+ ("\e$(7!?\e(B" . "\e$(8!?\e(B")
+ ("\e$(7!@\e(B" . "\e$(8!@\e(B")
+ ("\e$(7!A\e(B" . "\e$(8!A\e(B")
+ ("\e$(7"`\e(B" . "\e$(8"`\e(B")
+ ("\e$(7!;\e(B" . "\e$(8!;\e(B")
+ ("\e$(7!D\e(B" . "\e$(8!D\e(B")
+ ;; Yes these are dirty. But ...
+ ("\e$(7!>\e(B \e$(7!>\e(B" . ,(compose-string "\e$(7!>\e(B \e$(7!>\e(B" 0 3 [?\e$(7!>\e(B (Br . Bl) ? (Br . Bl) ?\e$(7!>\e(B]))
+ ("\e$(7!4!5!5\e(B" . ,(compose-string
+ "\e$(7#R#S#S#S\e(B" 0 4
+ [?\e$(7#R\e(B (Br . Bl) ?\e$(7#S\e(B (Br . Bl) ?\e$(7#S\e(B (Br . Bl) ?\e$(7#S\e(B]))
+ ("\e$(7!4!5\e(B" . ,(compose-string "\e$(7#R#S#S\e(B" 0 3 [?\e$(7#R\e(B (Br . Bl) ?\e$(7#S\e(B (Br . Bl) ?\e$(7#S\e(B]))
+ ("\e$(7!6\e(B" . ,(compose-string "\e$(7#R#S!I\e(B" 0 3 [?\e$(7#R\e(B (Br . Bl) ?\e$(7#S\e(B (br . tr) ?\e$(7!I\e(B]))
+ ("\e$(7!4\e(B" . ,(compose-string "\e$(7#R#S\e(B" 0 2 [?\e$(7#R\e(B (Br . Bl) ?\e$(7#S\e(B]))))
+
+;;;###autoload
+(defun tibetan-char-p (ch)
+ "Check if char CH is Tibetan character.
+Returns non-nil if CH is Tibetan. Otherwise, returns nil."
+ (memq (char-charset ch) '(tibetan tibetan-1-column)))
+
+;;; Functions for Tibetan <-> Tibetan-transcription.
+
+;;;###autoload
+(defun tibetan-tibetan-to-transcription (str)
+ "Transcribe Tibetan string STR and return the corresponding Roman string."
+ (let (;; Accumulate transcriptions here in reverse order.
+ (trans nil)
+ (len (length str))
+ (i 0)
+ ch this-trans)
+ (while (< i len)
+ (let ((idx (string-match tibetan-precomposition-rule-regexp str i)))
+ (if (eq idx i)
+ ;; Ith character and the followings matches precomposable
+ ;; Tibetan sequence.
+ (setq i (match-end 0)
+ this-trans
+ (car (rassoc
+ (cdr (assoc (match-string 0 str)
+ tibetan-precomposition-rule-alist))
+ tibetan-precomposed-transcription-alist)))
+ (setq ch (substring str i (1+ i))
+ i (1+ i)
+ this-trans
+ (car (or (rassoc ch tibetan-consonant-transcription-alist)
+ (rassoc ch tibetan-vowel-transcription-alist)
+ (rassoc ch tibetan-subjoined-transcription-alist)))))
+ (setq trans (cons this-trans trans))))
+ (apply 'concat (nreverse trans))))
+
+;;;###autoload
+(defun tibetan-transcription-to-tibetan (str)
+ "Convert Tibetan Roman string STR to Tibetan character string.
+The returned string has no composition information."
+ (let (;; Case is significant.
+ (case-fold-search nil)
+ (idx 0)
+ ;; Accumulate Tibetan strings here in reverse order.
+ (t-str-list nil)
+ i subtrans)
+ (while (setq i (string-match tibetan-regexp str idx))
+ (if (< idx i)
+ ;; STR contains a pattern that doesn't match Tibetan
+ ;; transcription. Include the pattern as is.
+ (setq t-str-list (cons (substring str idx i) t-str-list)))
+ (setq subtrans (match-string 0 str)
+ idx (match-end 0))
+ (let ((t-char (cdr (assoc subtrans
+ tibetan-precomposed-transcription-alist))))
+ (if t-char
+ ;; SUBTRANS corresponds to a transcription for
+ ;; precomposable Tibetan sequence.
+ (setq t-char (car (rassoc t-char
+ tibetan-precomposition-rule-alist)))
+ (setq t-char
+ (cdr
+ (or (assoc subtrans tibetan-consonant-transcription-alist)
+ (assoc subtrans tibetan-vowel-transcription-alist)
+ (assoc subtrans tibetan-modifier-transcription-alist)
+ (assoc subtrans tibetan-subjoined-transcription-alist)))))
+ (setq t-str-list (cons t-char t-str-list))))
+ (if (< idx (length str))
+ (setq t-str-list (cons (substring str idx) t-str-list)))
+ (apply 'concat (nreverse t-str-list))))
+
+;;;
+;;; Functions for composing/decomposing Tibetan sequence.
+;;;
+;;; A Tibetan syllable is typically structured as follows:
+;;;
+;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]]
+;;;
+;;; where C's are all vertically stacked, V appears below or above
+;;; consonant cluster and M is always put above the C[C+]V combination.
+;;; (Sanskrit visarga, though it is a vowel modifier, is considered
+;;; to be a punctuation.)
+;;;
+;;; Here are examples of the words "bsgrubs" and "hfauM"
+;;;
+;;; \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
+;;;
+;;; M
+;;; b s b s h
+;;; g fa
+;;; r u
+;;; u
+;;;
+;;; 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
+;;; forms when they are used as subjoined consonant. Consonant `r'
+;;; takes another special form when used as superjoined in such a case
+;;; as "rka", while it does not change its form when conjoined with
+;;; subjoined `'', `w' or `y' as in "rwa", "rya".
+
+;; Append a proper composition rule and glyph to COMPONENTS to compose
+;; CHAR with a composition that has COMPONENTS.
+
+(defun tibetan-add-components (components char)
+ (let ((last (last components))
+ (stack-upper '(tc . bc))
+ (stack-under '(bc . tc))
+ rule comp-vowel tmp)
+ ;; Special treatment for 'a chung.
+ ;; If 'a follows a consonant, turn it into the subjoined form.
+ ;; * Disabled by Tomabechi 2000/06/09 *
+ ;; Because in Unicode, \e$(7"A\e(B may follow directly a consonant without
+ ;; 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
+ ;;(if (and (= char ?\e$(7"A\e(B)
+ ;; (aref (char-category-set (car last)) ?0))
+ ;; (setq char ?\e$(7"R\e(B)) ;; modified for new font by Tomabechi 1999/12/10
+
+ ;; Composite vowel signs are decomposed before being added
+ ;; Added by Tomabechi 2000/06/08
+ (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))
+ (setq comp-vowel
+ (copy-sequence
+ (cddr (assoc (char-to-string char)
+ tibetan-composite-vowel-alist)))
+ char
+ (cadr (assoc (char-to-string char)
+ tibetan-composite-vowel-alist))))
+ (cond
+ ;; Compose upper vowel sign vertically over.
+ ((aref (char-category-set char) ?2)
+ (setq rule stack-upper))
+
+ ;; Compose lower vowel sign vertically under.
+ ((aref (char-category-set char) ?3)
+ (if (eq char ?\e$(7"Q\e(B) ;; `\e$(7"Q\e(B' should not visible when composed.
+ (setq rule nil)
+ (setq rule stack-under)))
+ ;; Transform ra-mgo (superscribed r) if followed by a subjoined
+ ;; consonant other than w, ', y, r.
+ ((and (= (car last) ?\e$(7"C\e(B)
+ (not (memq char '(?\e$(7#>\e(B ?\e$(7"R\e(B ?\e$(7#B\e(B ?\e$(7#C\e(B))))
+ (setcar last ?\e$(7!"\e(B) ;; modified for newfont by Tomabechi 1999/12/10
+ (setq rule stack-under))
+ ;; Transform initial base consonant if followed by a subjoined
+ ;; consonant but 'a.
+ (t
+ (let ((laststr (char-to-string (car last))))
+ (if (and (/= char ?\e$(7"R\e(B) ;; modified for new font by Tomabechi
+ (string-match "[\e$(7"!\e(B-\e$(7"="?"@"D\e(B-\e$(7"J"K\e(B]" laststr))
+ (setcar last (string-to-char
+ (cdr (assoc (char-to-string (car last))
+ tibetan-base-to-subjoined-alist)))))
+ (setq rule stack-under))))
+
+ (if rule
+ (setcdr last (list rule char)))
+ ;; Added by Tomabechi 2000/06/08
+ (if comp-vowel
+ (nconc last comp-vowel))
+ ))
+
+;;;###autoload
+(defun tibetan-compose-string (str)
+ "Compose Tibetan string STR."
+ (let ((idx 0))
+ ;; `\e$(7"A\e(B' is included in the pattern for subjoined consonants
+ ;; because we treat it specially in tibetan-add-components.
+ ;; (This feature is removed by Tomabechi 2000/06/08)
+ (while (setq idx (string-match tibetan-composable-pattern str idx))
+ (let ((from idx)
+ (to (match-end 0))
+ components)
+ (if (eq (string-match tibetan-precomposition-rule-regexp str idx) idx)
+ (setq idx (match-end 0)
+ components
+ (list (string-to-char
+ (cdr
+ (assoc (match-string 0 str)
+ tibetan-precomposition-rule-alist)))))
+ (setq components (list (aref str idx))
+ idx (1+ idx)))
+ (while (< idx to)
+ (tibetan-add-components components (aref str idx))
+ (setq idx (1+ idx)))
+ (compose-string str from to components))))
+ str)
+
+;;;###autoload
+(defun tibetan-compose-region (beg end)
+ "Compose Tibetan text the region BEG and END."
+ (interactive "r")
+ (let (str result chars)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ ;; `\e$(7"A\e(B' is included in the pattern for subjoined consonants
+ ;; because we treat it specially in tibetan-add-components.
+ ;; (This feature is removed by Tomabechi 2000/06/08)
+ (while (re-search-forward tibetan-composable-pattern nil t)
+ (let ((from (match-beginning 0))
+ (to (match-end 0))
+ components)
+ (goto-char from)
+ (if (looking-at tibetan-precomposition-rule-regexp)
+ (progn
+ (setq components
+ (list (string-to-char
+ (cdr
+ (assoc (match-string 0)
+ tibetan-precomposition-rule-alist)))))
+ (goto-char (match-end 0)))
+ (setq components (list (char-after from)))
+ (forward-char 1))
+ (while (< (point) to)
+ (tibetan-add-components components (following-char))
+ (forward-char 1))
+ (compose-region from to components)))))))
+
+(defvar tibetan-decompose-precomposition-alist
+ (mapcar (function (lambda (x) (cons (string-to-char (cdr x)) (car x))))
+ tibetan-precomposition-rule-alist))
+
+;;;###autoload
+(defun tibetan-decompose-region (from to)
+ "Decompose Tibetan text in the region FROM and TO.
+This is different from decompose-region because precomposed Tibetan characters
+are decomposed into normal Tibetan character sequences."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (decompose-region from to)
+ (goto-char from)
+ (while (not (eobp))
+ (let* ((char (following-char))
+ (slot (assq char tibetan-decompose-precomposition-alist)))
+ (if slot
+ (progn
+ (delete-char 1)
+ (insert (cdr slot)))
+ (forward-char 1))))))
+
+
+;;;###autoload
+(defun tibetan-decompose-string (str)
+ "Decompose Tibetan string STR.
+This is different from decompose-string because precomposed Tibetan characters
+are decomposed into normal Tibetan character sequences."
+ (let ((new "")
+ (len (length str))
+ (idx 0)
+ char slot)
+ (while (< idx len)
+ (setq char (aref str idx)
+ slot (assq (aref str idx) tibetan-decompose-precomposition-alist)
+ new (concat new (if slot (cdr slot) (char-to-string char)))
+ idx (1+ idx)))
+ new))
+
+;;;###autoload
+(defun tibetan-composition-function (from to pattern &optional string)
+ (if string
+ (tibetan-compose-string string)
+ (tibetan-compose-region from to))
+ (- to from))
+
+;;;
+;;; This variable is used to avoid repeated decomposition.
+;;;
+(setq-default tibetan-decomposed nil)
+
+;;;###autoload
+(defun tibetan-decompose-buffer ()
+ "Decomposes Tibetan characters in the buffer into their components.
+See also the documentation of the function `tibetan-decompose-region'."
+ (interactive)
+ (make-local-variable 'tibetan-decomposed)
+ (cond ((not tibetan-decomposed)
+ (tibetan-decompose-region (point-min) (point-max))
+ (setq tibetan-decomposed t))))
+
+;;;###autoload
+(defun tibetan-compose-buffer ()
+ "Composes Tibetan character components in the buffer.
+See also docstring of the function tibetan-compose-region."
+ (interactive)
+ (make-local-variable 'tibetan-decomposed)
+ (tibetan-compose-region (point-min) (point-max))
+ (setq tibetan-decomposed nil))
+
+;;;###autoload
+(defun tibetan-post-read-conversion (len)
+ (save-excursion
+ (save-restriction
+ (let ((buffer-modified-p (buffer-modified-p)))
+ (narrow-to-region (point) (+ (point) len))
+ (tibetan-compose-region (point-min) (point-max))
+ (set-buffer-modified-p buffer-modified-p)
+ (make-local-variable 'tibetan-decomposed)
+ (setq tibetan-decomposed nil)
+ (- (point-max) (point-min))))))
+
+
+;;;###autoload
+(defun tibetan-pre-write-conversion (from to)
+ (setq tibetan-decomposed-temp tibetan-decomposed)
+ (let ((old-buf (current-buffer)))
+ (set-buffer (generate-new-buffer " *temp*"))
+ (if (stringp from)
+ (insert from)
+ (insert-buffer-substring old-buf from to))
+ (if (not tibetan-decomposed-temp)
+ (tibetan-decompose-region (point-min) (point-max)))
+ ;; Should return nil as annotations.
+ nil))
+
+\f
+;;;
+;;; Unicode-related definitions.
+;;;
+
+(defvar tibetan-canonicalize-for-unicode-alist
+ '(("\e$(7"Q\e(B" . "") ;; remove vowel a
+ ("\e$(7"T\e(B" . "\e$(7"R"S\e(B") ;; decompose vowels whose use is ``discouraged'' in Unicode 3.0
+ ("\e$(7"V\e(B" . "\e$(7"R"U\e(B")
+ ("\e$(7"W\e(B" . "\e$(7#C"a\e(B")
+ ("\e$(7"X\e(B" . "\e$(7#C"R"a\e(B")
+ ("\e$(7"Y\e(B" . "\e$(7#D"a\e(B")
+ ("\e$(7"Z\e(B" . "\e$(7#D"R"a\e(B")
+ ("\e$(7"b\e(B" . "\e$(7"R"a\e(B"))
+ "Rules for canonicalizing Tibetan vowels for Unicode.")
+
+(defvar tibetan-canonicalize-for-unicode-regexp
+ "[\e$(7"Q"T"V"W"X"Y"Z"b\e(B]"
+ "Regexp for Tibetan vowels to be canonicalized in Unicode.")
+
+(defun tibetan-canonicalize-for-unicode-region (from to)
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char from)
+ (while (re-search-forward tibetan-canonicalize-for-unicode-regexp nil t)
+ (let (
+ ;;(from (match-beginning 0))
+ ;;(to (match-end 0))
+ (canonical-form
+ (cdr (assoc (match-string 0)
+ tibetan-canonicalize-for-unicode-alist))))
+ ;;(goto-char from)
+ ;;(delete-region from to)
+ ;;(insert canonical-form)
+ (replace-match canonical-form)
+ ))))
+
+(defvar tibetan-strict-unicode t
+ "*Flag to control Tibetan canonicalizing for Unicode.
+
+If non-nil, the vowel a is removed and composite vowels are decomposed
+before writing buffer in Unicode. See also
+`tibetan-canonicalize-for-unicode-regexp' and
+`tibetan-canonicalize-for-unicode-alist'.")
+
+;;;###autoload
+(defun tibetan-pre-write-canonicalize-for-unicode (from to)
+ (let ((old-buf (current-buffer))
+ (strict-unicode tibetan-strict-unicode))
+ (set-buffer (generate-new-buffer " *temp*"))
+ (if (stringp from)
+ (insert from)
+ (insert-buffer-substring old-buf from to))
+ (if strict-unicode
+ (tibetan-canonicalize-for-unicode-region (point-min) (point-max)))
+ ;; Should return nil as annotations.
+ nil))
+
+(provide 'tibet-util)
+
+;;; arch-tag: 7a7333e8-1584-446c-b39c-a02b9def265d
+;;; tibet-util.el ends here
HCoop / bpt / emacs.git / blobdiff