(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)))
(defun tibetan-tibetan-to-transcription (str)
"Transcribe Tibetan string STR and return the corresponding Roman string."
(let ( (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)
(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))))
(defun tibetan-transcription-to-tibetan (str)
"Convert Tibetan Roman string STR to Tibetan character string.
The returned string has no composition information."
(let ( (case-fold-search nil)
(idx 0)
(t-str-list nil)
i subtrans)
(while (setq i (string-match tibetan-regexp str idx))
(if (< idx i)
(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
(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))))
(defun tibetan-add-components (components char)
(let ((last (last components))
(stack-upper '(tc . bc))
(stack-under '(bc . tc))
rule comp-vowel tmp)
(if (memq char '(?$(7"T(B ?$(7"V(B ?$(7"W(B ?$(7"X(B ?$(7"Y(B ?$(7"Z(B ?$(7"b(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 ?$(7"Q(B) (setq rule nil)
(setq rule stack-under)))
((and (= (car last) ?$(7"C(B)
(not (memq char '(?$(7#>(B ?$(7"R(B ?$(7#B(B ?$(7#C(B))))
(setcar last ?$(7!"(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 ?$(7"R(B) (string-match "[$(7"!(B-$(7"="?"@"D(B-$(7"J"K(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))
;; `$(7"A(B' is included in the pattern for subjoined consonants
(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)
(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))
(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))
(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 Tiebtan 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))))))
(defun tibetan-decompose-string (str)
"Decompose Tibetan string STR.
This is different from decompose-string because precomposed Tibetan characters
are decomposed into normal Tiebtan 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))
(defun tibetan-composition-function (from to pattern &optional string)
(if string
(tibetan-compose-string string)
(tibetan-compose-region from to))
(- to from))
(setq-default tibetan-decomposed nil)
(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))))
(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))
(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))))))
(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)))
nil))
(provide 'tibet-util)