git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/utf-2000/read-maps.el

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