Add `=decomposition@hanyo-denshi' for representative (detailed)
[chise/xemacs-chise.git.1] / lisp / utf-2000 / read-maps.el
1 ;;; read-maps.el --- Read mapping-tables.
2
3 ;; Copyright (C) 2002,2003,2004,2005,2006,2008,2012 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