(defun setup-tibetan-environment ()
(interactive)
(set-language-environment "Tibetan"))
(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)))
(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))))
(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)))))
(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 "[$(7!1(B-$(7!o"f$(8!
(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 "[$(7!g!e"Q(B-$(7"^"_(B-$(7"l(B]" chstr)))
(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."
(let (l rule)
(if (cmpcharp first)
(setq l (decompose-composite-char first 'list t))
(setq l (list first)))
(if upward
(setq rule (list '(tc . bc)))
(setq rule (list '(bc . tc))))
(setq l (append l rule (list second)))
(apply 'compose-chars l)))
(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)
(if (string-match
"^\\(.+\\)\\($(7"Q(B\\)\\([$(7!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]\\)" t-str)
(setq t-str (concat
(match-string 1 t-str)
(match-string 3 t-str))))
(if (string-match
"^\\(.+\\)\\([$(7!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]\\)\\($(7"Q(B\\)" t-str)
(setq t-str (concat
(match-string 1 t-str)
(match-string 2 t-str))))
(setq result "")
(while (string-match "^\\([$(7"!(B-$(7"J$!(B-$(7%u(B]\\)\\([$(7"!(B-$(7"@"B(B-$(7"J$!(B-$(7%u(B].*\\)" t-str)
(setq result (concat result (match-string 1 t-str)))
(setq t-str (match-string 2 t-str)))
(while
(string-match "^\\(.\\)\\([$(7"A#!(B-$(7#J!I!g!e"Q(B-$(7"^"_(B-$(7"l(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 "$(7"A(B" s-str)
(not (tibetan-complete-char-examin f-ch)))
(setq s-str "$(7#A(B"))
(setq s-ch (string-to-char s-str))
(setq rest (match-string 3 t-str))
(cond ((string-match "\\c2" s-str) (setq composed
(tibetan-vertical-stacking f-ch s-ch t)))
((string-match "\\c3" s-str) (setq composed
(tibetan-vertical-stacking f-ch s-ch nil)))
((and (string-match "$(7"C(B" f-str)
(not (string-match "[$(7#>#A#B#C(B]" s-str)))
(setq f-ch ?$(7#P(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 "[$(7"!(B-$(7"="?"@"D(B-$(7"J(B]" f-str)
(not (string-match "$(7#A(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.
;;;###autoload
(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 "[$(8!D! (setq ch-str
(car (rassoc ch-str tibetan-precomposition-rule-alist))))
((eq (char-charset (string-to-char ch-str)) 'composition)
(setq ch-str (decompose-composite-char (string-to-char ch-str)))
(cond ((string= ch-str "$(7#R#S#S#S(B")
(setq ch-str "$(7!4!5!5(B"))
((string= ch-str "$(7#R#S#S(B")
(setq ch-str "$(7!4!5(B"))
((string= ch-str "$(7#R#S!I(B")
(setq ch-str "$(7!6(B"))
((string= ch-str "$(7#R#S(B")
(setq ch-str "$(7!4(B")))))
(if (string-match "^\\([$(7#!(B-$(7#J(B]\\)\\(.*\\)$" ch-str)
(setq ch-str
(concat (car (rassoc (match-string 1 ch-str)
tibetan-base-to-subjoined-alist))
(match-string 2 ch-str))))
(if (string-match "^\\([$(7$!(B-$(7%u(B]\\)\\(.*\\)$" ch-str)
(setq ch-str
(concat (car (rassoc (match-string 1 ch-str)
tibetan-precomposition-rule-alist))
(match-string 2 ch-str))))
(if (string-match "^$(7#P(B\\(.*\\)$" ch-str)
(setq ch-str (concat "$(7"C(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
"[$(7"!(B-$(7"J$!(B-$(7%u(B]+[$(7#!(B-$(7#J!I!g!e"Q(B-$(7"^"_(B-$(7"l(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)
(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))
(provide 'tibet-util)
;;; language/tibet-util.el ends here.