lisp/utf-2000/read-maps.el

   1 ;;; read-maps.el --- Read mapping-tables.
   2
   3 ;; Copyright (C) 2002,2003,2004,2005,2006,2008 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: mapping table, character, CCS, multiscript, multilingual
   7
   8 ;; This file is part of XEmacs CHISE.
   9
  10 ;; XEmacs CHISE is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; XEmacs CHISE 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 GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs CHISE; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (defvar mapping-table-ccs-setting-alist
  28   '((=jis-x0208@1990
  29      "^J90-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  30      =ucs@jis/1990
  31      "\tJU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  32     (=jis-x0212
  33      "^JSP-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  34      =ucs@jis/1990
  35      "\tJU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  36     (=jis-x0213-1-2000
  37      "^JX1-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  38      =ucs@jis/2000
  39      "\tJU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  40     (=jis-x0213-2-2000
  41      "^JX2-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  42      =ucs@jis/2000
  43      "\tJU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  44     (=gb2312
  45      "^G0-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  46      =ucs@gb
  47      "\tGU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  48     (=cns11643-1
  49      "^C1-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  50      =ucs@cns
  51      "\tCU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  52     (=cns11643-2
  53      "^C2-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  54      =ucs@cns
  55      "\tCU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  56     (=cns11643-3
  57      "^C3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  58      =ucs@cns
  59      "\tCU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  60     (=cns11643-4
  61      "^C4-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  62      =ucs@cns
  63      "\tCU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  64     (=cns11643-5
  65      "^C5-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  66      =ucs@cns
  67      "\tCU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  68     (=cns11643-6
  69      "^C6-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  70      =ucs@cns
  71      "\tCU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  72     (=cns11643-7
  73      "^C7-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  74      =ucs@cns
  75      "\tCU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  76     (=big5
  77      "^B-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  78      =ucs@big5
  79      "\tBU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  80     (=ks-x1001
  81      "^K0-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  82      =ucs@ks
  83      "\tKU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
  84     (=jef-china3
  85      "^JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
  86      nil
  87      nil)
  88     )
  89   "*List of information about mapping table formats.
  90 Elements are of the form
  91 \(CCS CODE-REGEXP PAREN-EXP BASE UCS-CCS UCS-REGEXP).
  92
  93 CCS     is a symbol, which is a name of a target coded-charset.
  94
  95 CODE-REGEXP is a regular expression to match against
  96         the representation of the target coded-charset.
  97
  98 PAREN-EXP is a number specifies which parenthesized expression
  99         in the CODE-REGEXP.
 100
 101 BASE    base of code in the string specified by CODE-REGEXP and
 102         PAREN-EXP.
 103
 104 UCS-CCS is a symbol, which is a name of a UCS-CCS.
 105
 106 UCS-REGEXP is a regular expression to match against
 107         the representation of the UCS-CCS.")
 108
 109 ;;;###autoload
 110 (defun mapping-table-read-file (filename)
 111   "Read mapping table."
 112   (interactive "fMapping table : ")
 113   (with-temp-buffer
 114     (buffer-disable-undo)
 115     (insert-file-contents filename)
 116     (goto-char (point-min))
 117     (let (rest setting ccs code ucs ucs-pat ucs-ccs ucs-code chr)
 118       (while (not (eobp))
 119         (setq rest mapping-table-ccs-setting-alist)
 120         (catch 'matched
 121           (while rest
 122             (setq setting (car rest)
 123                   ccs (pop setting))
 124             (when (looking-at (pop setting))
 125               (setq code (string-to-int (match-string (pop setting))
 126                                         (pop setting))
 127                     ucs-ccs (pop setting)
 128                     ucs-pat (car setting))
 129               (goto-char (match-end 0))
 130               (throw 'matched t))
 131             (setq rest (cdr rest)))
 132           (setq ccs nil
 133                 code nil
 134                 ucs-pat nil
 135                 ucs-ccs nil))
 136         (setq ucs-code
 137               (if (and ucs-pat
 138                        (looking-at ucs-pat))
 139                   (prog1
 140                       (string-to-int (match-string 1) 16)
 141                     (goto-char (match-end 0)))))
 142         (setq ucs
 143               (if (looking-at
 144                    "[ \t]*U[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
 145                   (string-to-int (match-string 1) 16)))
 146         (if (and ucs-ccs ucs (not ucs-code))
 147             (setq ucs-code ucs
 148                   ucs nil))
 149         (when (setq chr (decode-char ccs code))
 150           (unless (eq (encode-char chr ccs 'defined-only)
 151                       code)
 152             (put-char-attribute chr ccs code))
 153           (when (and ucs-code
 154                      (not
 155                       (eq (or
 156                            (encode-char chr ucs-ccs 'defined-only)
 157                            (cond
 158                             ((memq ucs-ccs '(=ucs@jis
 159                                              =ucs@jis/1990
 160                                              =ucs@jis/2000))
 161                              (encode-char chr '=ucs@jis/fw 'defined-only))
 162                             ((eq ucs-ccs '=ucs@gb)
 163                              (encode-char chr '=ucs@gb/fw 'defined-only))
 164                             ;; ((eq ucs-ccs '=ucs@cns)
 165                             ;;  (encode-char chr '=ucs@cns/fw 'defined-only))
 166                             ;; ((eq ucs-ccs '=ucs@big5)
 167                             ;;  nil)
 168                             ;; ((eq ucs-ccs '=ucs@ks)
 169                             ;;  (encode-char chr '=ucs@ks/fw 'defined-only))
 170                             (t
 171                              (char-feature chr '=>ucs))))
 172                           ucs-code)))
 173             (put-char-attribute chr ucs-ccs ucs-code))
 174           (when (and ucs
 175                      (not (eq (or (encode-char chr '=ucs 'defined-only)
 176                                   (and (not (memq ucs-ccs '(=ucs@jis
 177                                                             =ucs@jis/1990
 178                                                             =ucs@jis/2000
 179                                                             =ucs@gb
 180                                                             =ucs@cns
 181                                                             =ucs@big5
 182                                                             =ucs@ks
 183                                                             )))
 184                                        (char-feature chr '=>ucs)))
 185                               ucs)))
 186             (if (or ucs-code (null ucs-ccs))
 187                 (unless (eq (char-feature chr '=>ucs) ucs)
 188                   (put-char-attribute chr '=>ucs ucs))
 189               (unless (eq (encode-char chr ucs-ccs 'defined-only)
 190                           ucs)
 191                 (put-char-attribute chr ucs-ccs ucs)))))
 192         (forward-line)))))
 193
 194 ;;;###autoload
 195 (defun ucs-compat-read-file (filename)
 196   (interactive "fUCS-compat file : ")
 197   (with-temp-buffer
 198     (buffer-disable-undo)
 199     (insert-file-contents filename)
 200     (goto-char (point-min))
 201     (let (ucs ucs*)
 202       (while (re-search-forward
 203               "^ *U[---+]\\([0-9A-F]+\\)\t *U[---+]\\([0-9A-F]+\\)" nil t)
 204         (setq ucs (string-to-int (match-string 1) 16)
 205               ucs* (string-to-int (match-string 2) 16))
 206         (put-char-attribute (decode-char '=ucs ucs) '=>ucs* ucs*)
 207         ))))
 208
 209 ;;;###autoload
 210 (defun jp-jouyou-read-file (filename)
 211   (interactive "fjp-jouyou file : ")
 212   (with-temp-buffer
 213     (buffer-disable-undo)
 214     (insert-file-contents filename)
 215     (goto-char (point-min))
 216     (let (char tchars)
 217       (while (re-search-forward "^[^\t\n ]+\t\\(.\\)\t*" nil t)
 218         (setq char (aref (match-string 1) 0)
 219               tchars (buffer-substring (match-end 0)
 220                                        (point-at-eol)))
 221         (when (> (length tchars) 0)
 222           (setq tchars
 223                 (mapcar (lambda (c)
 224                           (aref c 0))
 225                         (split-string tchars " ")))
 226           (unless (or (equal (char-feature char '<-simplified@JP/Jouyou)
 227                              tchars)
 228                       (and (equal (char-feature char '<-simplified)
 229                                   tchars)
 230                            (memq 'JP/Jouyou
 231                                  (char-feature char '<-simplified*sources))))
 232             (put-char-attribute char
 233                                 '<-simplified@JP/Jouyou
 234                                 tchars)))
 235         ;; (put-char-attribute
 236         ;;  char 'script (adjoin
 237         ;;                'JP
 238         ;;                (adjoin
 239         ;;                 'Jouyou
 240         ;;                 (adjoin
 241         ;;                  'Ideograph
 242         ;;                  (get-char-attribute char 'script)))))
 243         ))))
 244
 245 (provide 'read-maps)
 246
 247 ;;; read-maps.el ends here