code.delx.au - gnu-emacs/blob - lisp/language/tibet-util.el

   1 ;;; tibet-util.el --- utilities for Tibetan   -*- coding: iso-2022-7bit; -*-
   2
   3 ;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007
   4 ;;   Free Software Foundation, Inc.
   5 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   6 ;;   2005, 2006, 2007
   7 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
   8 ;;   Registration Number H14PRO021
   9
  10 ;; Keywords: multilingual, Tibetan
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch>
  30
  31 ;; Created: Feb. 17. 1997
  32
  33 ;;; History:
  34 ;; 1997.03.13 Modification in treatment of text properties;
  35 ;;            Support for some special signs and punctuations.
  36 ;; 1999.10.25 Modification for a new composition way by K.Handa.
  37
  38 ;;; Commentary:
  39
  40 ;;; Code:
  41
  42 (defconst tibetan-obsolete-glyphs
  43   `(("\e$(7!=\e(B" . "\e$(7!=\e(B")                 ; 2 col <-> 1 col
  44     ("\e$(7!?\e(B" . "\e$(7!?\e(B")
  45     ("\e$(7!@\e(B" . "\e$(7!@\e(B")
  46     ("\e$(7!A\e(B" . "\e$(7!A\e(B")
  47     ("\e$(7"`\e(B" . "\e$(7"`\e(B")
  48     ("\e$(7!;\e(B" . "\e$(7!;\e(B")
  49     ("\e$(7!D\e(B" . "\e$(7!D\e(B")
  50     ;; Yes these are dirty. But ...
  51     ("\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]))
  52     ("\e$(7!4!5!5\e(B" . ,(compose-string
  53                   "\e$(7#R#S#S#S\e(B" 0 4
  54                   [?\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]))
  55     ("\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]))
  56     ("\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]))
  57     ("\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]))))
  58
  59 ;;;###autoload
  60 (defun tibetan-char-p (ch)
  61   "Check if char CH is Tibetan character.
  62 Returns non-nil if CH is Tibetan. Otherwise, returns nil."
  63   (memq (char-charset ch) '(tibetan tibetan-1-column)))
  64
  65 ;;; Functions for Tibetan <-> Tibetan-transcription.
  66
  67 ;;;###autoload
  68 (defun tibetan-tibetan-to-transcription (str)
  69   "Transcribe Tibetan string STR and return the corresponding Roman string."
  70   (let (;; Accumulate transcriptions here in reverse order.
  71         (trans nil)
  72         (len (length str))
  73         (i 0)
  74         ch this-trans)
  75     (while (< i len)
  76       (let ((idx (string-match tibetan-precomposition-rule-regexp str i)))
  77         (if (eq idx i)
  78             ;; Ith character and the followings matches precomposable
  79             ;; Tibetan sequence.
  80             (setq i (match-end 0)
  81                   this-trans
  82                   (car (rassoc
  83                         (cdr (assoc (match-string 0 str)
  84                                     tibetan-precomposition-rule-alist))
  85                         tibetan-precomposed-transcription-alist)))
  86           (setq ch (substring str i (1+ i))
  87                 i (1+ i)
  88                 this-trans
  89                 (car (or (rassoc ch tibetan-consonant-transcription-alist)
  90                          (rassoc ch tibetan-vowel-transcription-alist)
  91                          (rassoc ch tibetan-subjoined-transcription-alist)))))
  92         (setq trans (cons this-trans trans))))
  93     (apply 'concat (nreverse trans))))
  94
  95 ;;;###autoload
  96 (defun tibetan-transcription-to-tibetan (str)
  97   "Convert Tibetan Roman string STR to Tibetan character string.
  98 The returned string has no composition information."
  99   (let (;; Case is significant.
 100         (case-fold-search nil)
 101         (idx 0)
 102         ;; Accumulate Tibetan strings here in reverse order.
 103         (t-str-list nil)
 104         i subtrans)
 105     (while (setq i (string-match tibetan-regexp str idx))
 106       (if (< idx i)
 107           ;; STR contains a pattern that doesn't match Tibetan
 108           ;; transcription.  Include the pattern as is.
 109           (setq t-str-list (cons (substring str idx i) t-str-list)))
 110       (setq subtrans (match-string 0 str)
 111             idx (match-end 0))
 112       (let ((t-char (cdr (assoc subtrans
 113                                 tibetan-precomposed-transcription-alist))))
 114         (if t-char
 115             ;; SUBTRANS corresponds to a transcription for
 116             ;; precomposable Tibetan sequence.
 117             (setq t-char (car (rassoc t-char
 118                                       tibetan-precomposition-rule-alist)))
 119           (setq t-char
 120                 (cdr
 121                  (or (assoc subtrans tibetan-consonant-transcription-alist)
 122                      (assoc subtrans tibetan-vowel-transcription-alist)
 123                      (assoc subtrans tibetan-modifier-transcription-alist)
 124                      (assoc subtrans tibetan-subjoined-transcription-alist)))))
 125         (setq t-str-list (cons t-char t-str-list))))
 126     (if (< idx (length str))
 127         (setq t-str-list (cons (substring str idx) t-str-list)))
 128     (apply 'concat (nreverse t-str-list))))
 129
 130 ;;;
 131 ;;; Functions for composing/decomposing Tibetan sequence.
 132 ;;;
 133 ;;; A Tibetan syllable is typically structured as follows:
 134 ;;;
 135 ;;;      [Prefix] C [C+] V [M] [Suffix [Post suffix]]
 136 ;;;
 137 ;;; where C's are all vertically stacked, V appears below or above
 138 ;;; consonant cluster and M is always put above the C[C+]V combination.
 139 ;;; (Sanskrit visarga, though it is a vowel modifier, is considered
 140 ;;;  to be a punctuation.)
 141 ;;;
 142 ;;; Here are examples of the words "bsgrubs" and "hfauM"
 143 ;;;
 144 ;;;            \e$(7"7"G###C"U"7"G\e(B            \e$(7"H"R"U"_\e(B
 145 ;;;
 146 ;;;                             M
 147 ;;;             b s b s         h
 148 ;;;               g             fa
 149 ;;;               r             u
 150 ;;;               u
 151 ;;;
 152 ;;; 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
 153 ;;; forms when they are used as subjoined consonant.  Consonant `r'
 154 ;;; takes another special form when used as superjoined in such a case
 155 ;;; as "rka", while it does not change its form when conjoined with
 156 ;;; subjoined `'', `w' or `y' as in "rwa", "rya".
 157
 158 ;; Append a proper composition rule and glyph to COMPONENTS to compose
 159 ;; CHAR with a composition that has COMPONENTS.
 160
 161 (defun tibetan-add-components (components char)
 162   (let ((last (last components))
 163         (stack-upper '(tc . bc))
 164         (stack-under '(bc . tc))
 165         rule comp-vowel tmp)
 166     ;; Special treatment for 'a chung.
 167     ;; If 'a follows a consonant, turn it into the subjoined form.
 168     ;; * Disabled by Tomabechi 2000/06/09 *
 169     ;; Because in Unicode, \e$(7"A\e(B may follow directly a consonant without
 170     ;; any intervening vowel, as in \e$(7"9"""Q"A!;\e(B=\e$(7"9\e(B \e$(7""\e(B \e$(7"A\e(B not \e$(7"9\e(B \e$(7""\e(B \e$(7"Q\e(B \e$(7"A\e(B
 171     ;;(if (and (= char ?\e$(7"A\e(B)
 172     ;;       (aref (char-category-set (car last)) ?0))
 173     ;;  (setq char ?\e$(7"R\e(B)) ;; modified for new font by Tomabechi 1999/12/10
 174
 175     ;; Composite vowel signs are decomposed before being added
 176     ;; Added by Tomabechi 2000/06/08
 177     (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))
 178         (setq comp-vowel
 179               (copy-sequence
 180                (cddr (assoc (char-to-string char)
 181                             tibetan-composite-vowel-alist)))
 182               char
 183               (cadr (assoc (char-to-string char)
 184                            tibetan-composite-vowel-alist))))
 185     (cond
 186      ;; Compose upper vowel sign vertically over.
 187      ((aref (char-category-set char) ?2)
 188       (setq rule stack-upper))
 189
 190      ;; Compose lower vowel sign vertically under.
 191      ((aref (char-category-set char) ?3)
 192       (if (or (eq char ?\e$(7"Q\e(B) ;; `\e$(7"Q\e(B' and `\e$,1FP\e(B' should not visible when composed.
 193               (eq char #xF70))
 194           (setq rule nil)
 195         (setq rule stack-under)))
 196      ;; Transform ra-mgo (superscribed r) if followed by a subjoined
 197      ;; consonant other than w, ', y, r.
 198      ((and (= (car last) ?\e$(7"C\e(B)
 199            (not (memq char '(?\e$(7#>\e(B ?\e$(7"R\e(B ?\e$(7#B\e(B ?\e$(7#C\e(B))))
 200       (setcar last ?\e$(7!"\e(B) ;; modified for newfont by Tomabechi 1999/12/10
 201       (setq rule stack-under))
 202      ;; Transform initial base consonant if followed by a subjoined
 203      ;; consonant but 'a.
 204      (t
 205       (let ((laststr (char-to-string (car last))))
 206         (if (and (/= char ?\e$(7"R\e(B) ;; modified for new font by Tomabechi
 207                  (string-match "[\e$(7"!\e(B-\e$(7"="?"@"D\e(B-\e$(7"J"K\e(B]" laststr))
 208             (setcar last (string-to-char
 209                           (cdr (assoc (char-to-string (car last))
 210                                       tibetan-base-to-subjoined-alist)))))
 211         (setq rule stack-under))))
 212
 213     (if rule
 214         (setcdr last (list rule char)))
 215     ;; Added by Tomabechi 2000/06/08
 216     (if comp-vowel
 217         (nconc last comp-vowel))
 218     ))
 219
 220 ;;;###autoload
 221 (defun tibetan-compose-string (str)
 222   "Compose Tibetan string STR."
 223   (let ((idx 0))
 224     ;; `\e$(7"A\e(B' is included in the pattern for subjoined consonants
 225     ;; because we treat it specially in tibetan-add-components.
 226     ;; (This feature is removed by Tomabechi 2000/06/08)
 227     (while (setq idx (string-match tibetan-composable-pattern str idx))
 228       (let ((from idx)
 229             (to (match-end 0))
 230             components)
 231         (if (eq (string-match tibetan-precomposition-rule-regexp str idx) idx)
 232             (setq idx (match-end 0)
 233                   components
 234                   (list (string-to-char
 235                          (cdr
 236                           (assoc (match-string 0 str)
 237                                  tibetan-precomposition-rule-alist)))))
 238           (setq components (list (aref str idx))
 239                 idx (1+ idx)))
 240         (while (< idx to)
 241           (tibetan-add-components components (aref str idx))
 242           (setq idx (1+ idx)))
 243         (compose-string str from to components))))
 244   str)
 245
 246 ;;;###autoload
 247 (defun tibetan-compose-region (beg end)
 248   "Compose Tibetan text the region BEG and END."
 249   (interactive "r")
 250   (let (str result chars)
 251     (save-excursion
 252       (save-restriction
 253         (narrow-to-region beg end)
 254         (goto-char (point-min))
 255         ;; `\e$(7"A\e(B' is included in the pattern for subjoined consonants
 256         ;; because we treat it specially in tibetan-add-components.
 257         ;; (This feature is removed by Tomabechi 2000/06/08)
 258         (while (re-search-forward tibetan-composable-pattern nil t)
 259           (let ((from (match-beginning 0))
 260                 (to (match-end 0))
 261                 components)
 262             (goto-char from)
 263             (if (looking-at tibetan-precomposition-rule-regexp)
 264                 (progn
 265                   (setq components
 266                         (list (string-to-char
 267                                (cdr
 268                                 (assoc (match-string 0)
 269                                        tibetan-precomposition-rule-alist)))))
 270                   (goto-char (match-end 0)))
 271               (setq components (list (char-after from)))
 272               (forward-char 1))
 273             (while (< (point) to)
 274               (tibetan-add-components components (following-char))
 275               (forward-char 1))
 276             (compose-region from to components)))))))
 277
 278 (defvar tibetan-decompose-precomposition-alist
 279   (mapcar (function (lambda (x) (cons (string-to-char (cdr x)) (car x))))
 280           tibetan-precomposition-rule-alist))
 281
 282 ;;;###autoload
 283 (defun tibetan-decompose-region (from to)
 284   "Decompose Tibetan text in the region FROM and TO.
 285 This is different from decompose-region because precomposed Tibetan characters
 286 are decomposed into normal Tibetan character sequences."
 287   (interactive "r")
 288   (save-restriction
 289     (narrow-to-region from to)
 290     (decompose-region from to)
 291     (goto-char from)
 292     (while (not (eobp))
 293       (let* ((char (following-char))
 294              (slot (assq char tibetan-decompose-precomposition-alist)))
 295         (if slot
 296             (progn
 297               (delete-char 1)
 298               (insert (cdr slot)))
 299           (forward-char 1))))))
 300
 301
 302 ;;;###autoload
 303 (defun tibetan-decompose-string (str)
 304   "Decompose Tibetan string STR.
 305 This is different from decompose-string because precomposed Tibetan characters
 306 are decomposed into normal Tibetan character sequences."
 307   (let ((new "")
 308         (len (length str))
 309         (idx 0)
 310         char slot)
 311     (while (< idx len)
 312       (setq char (aref str idx)
 313             slot (assq (aref str idx) tibetan-decompose-precomposition-alist)
 314             new (concat new (if slot (cdr slot) (char-to-string char)))
 315             idx (1+ idx)))
 316     new))
 317
 318 ;;;###autoload
 319 (defun tibetan-composition-function (pos &optional string)
 320   (setq pos (1- pos))
 321   (if string
 322       ;; Not yet implemented.
 323       nil
 324     (if (>= pos (point-min))
 325         (save-excursion
 326           (goto-char pos)
 327           (if (looking-at tibetan-composable-pattern)
 328               (prog1 (match-end 0)
 329                 (tibetan-compose-region pos (match-end 0))))))))
 330
 331 ;;;
 332 ;;; This variable is used to avoid repeated decomposition.
 333 ;;;
 334 (setq-default tibetan-decomposed nil)
 335
 336 ;;;###autoload
 337 (defun tibetan-decompose-buffer ()
 338   "Decomposes Tibetan characters in the buffer into their components.
 339 See also the documentation of the function `tibetan-decompose-region'."
 340   (interactive)
 341   (make-local-variable 'tibetan-decomposed)
 342   (cond ((not tibetan-decomposed)
 343          (tibetan-decompose-region (point-min) (point-max))
 344          (setq tibetan-decomposed t))))
 345
 346 ;;;###autoload
 347 (defun tibetan-compose-buffer ()
 348   "Composes Tibetan character components in the buffer.
 349 See also docstring of the function tibetan-compose-region."
 350   (interactive)
 351   (make-local-variable 'tibetan-decomposed)
 352   (tibetan-compose-region (point-min) (point-max))
 353   (setq tibetan-decomposed nil))
 354
 355 ;;;###autoload
 356 (defun tibetan-post-read-conversion (len)
 357   (save-excursion
 358     (save-restriction
 359       (let ((buffer-modified-p (buffer-modified-p)))
 360         (narrow-to-region (point) (+ (point) len))
 361         (tibetan-compose-region (point-min) (point-max))
 362         (set-buffer-modified-p buffer-modified-p)
 363         (make-local-variable 'tibetan-decomposed)
 364         (setq tibetan-decomposed nil)
 365         (- (point-max) (point-min))))))
 366
 367
 368 ;;;###autoload
 369 (defun tibetan-pre-write-conversion (from to)
 370   (setq tibetan-decomposed-temp tibetan-decomposed)
 371   (let ((old-buf (current-buffer)))
 372     (set-buffer (generate-new-buffer " *temp*"))
 373     (if (stringp from)
 374         (insert from)
 375       (insert-buffer-substring old-buf from to))
 376     (if (not tibetan-decomposed-temp)
 377         (tibetan-decompose-region (point-min) (point-max)))
 378     ;; Should return nil as annotations.
 379     nil))
 380
 381 \f
 382 ;;;
 383 ;;; Unicode-related definitions.
 384 ;;;
 385
 386 (defvar tibetan-canonicalize-for-unicode-alist
 387   '(("\e$(7"Q\e(B" . "")  ;; remove vowel a
 388     ("\e$(7"T\e(B" . "\e$(7"R"S\e(B") ;; decompose vowels whose use is ``discouraged'' in Unicode 3.0
 389     ("\e$(7"V\e(B" . "\e$(7"R"U\e(B")
 390     ("\e$(7"W\e(B" . "\e$(7#C"a\e(B")
 391     ("\e$(7"X\e(B" . "\e$(7#C"R"a\e(B")
 392     ("\e$(7"Y\e(B" . "\e$(7#D"a\e(B")
 393     ("\e$(7"Z\e(B" . "\e$(7#D"R"a\e(B")
 394     ("\e$(7"b\e(B" . "\e$(7"R"a\e(B"))
 395   "Rules for canonicalizing Tibetan vowels for Unicode.")
 396
 397 (defvar tibetan-canonicalize-for-unicode-regexp
 398   "[\e$(7"Q"T"V"W"X"Y"Z"b\e(B]"
 399   "Regexp for Tibetan vowels to be canonicalized in Unicode.")
 400
 401 (defun tibetan-canonicalize-for-unicode-region (from to)
 402   (save-restriction
 403     (narrow-to-region from to)
 404     (goto-char from)
 405     (while (re-search-forward tibetan-canonicalize-for-unicode-regexp nil t)
 406       (let (
 407             ;;(from (match-beginning 0))
 408             ;;(to (match-end 0))
 409             (canonical-form
 410              (cdr (assoc (match-string 0)
 411                          tibetan-canonicalize-for-unicode-alist))))
 412         ;;(goto-char from)
 413         ;;(delete-region from to)
 414         ;;(insert canonical-form)
 415         (replace-match canonical-form)
 416         ))))
 417
 418 (defvar tibetan-strict-unicode t
 419   "*Flag to control Tibetan canonicalizing for Unicode.
 420
 421 If non-nil, the vowel a is removed and composite vowels are decomposed
 422 before writing buffer in Unicode.  See also
 423 `tibetan-canonicalize-for-unicode-regexp' and
 424 `tibetan-canonicalize-for-unicode-alist'.")
 425
 426 ;;;###autoload
 427 (defun tibetan-pre-write-canonicalize-for-unicode (from to)
 428   (let ((old-buf (current-buffer))
 429         (strict-unicode tibetan-strict-unicode))
 430     (set-buffer (generate-new-buffer " *temp*"))
 431     (if (stringp from)
 432         (insert from)
 433       (insert-buffer-substring old-buf from to))
 434     (if strict-unicode
 435         (tibetan-canonicalize-for-unicode-region (point-min) (point-max)))
 436     ;; Should return nil as annotations.
 437     nil))
 438
 439 (provide 'tibet-util)
 440
 441 ;;; arch-tag: 7a7333e8-1584-446c-b39c-a02b9def265d
 442 ;;; tibet-util.el ends here