Reformatted.
[chise/xemacs-chise.git] / 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     (=big5     
73      "^B-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
74      =ucs@big5
75      "\tBU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
76     (=ks-x1001
77      "^K0-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
78      =ucs@ks
79      "\tKU[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
80     (=jef-china3     
81      "^JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)" 1 16
82      nil
83      nil)
84     )
85   "*List of information about mapping table formats.
86 Elements are of the form
87 \(CCS CODE-REGEXP PAREN-EXP BASE UCS-CCS UCS-REGEXP).
88
89 CCS     is a symbol, which is a name of a target coded-charset.
90
91 CODE-REGEXP is a regular expression to match against
92         the representation of the target coded-charset.
93
94 PAREN-EXP is a number specifies which parenthesized expression
95         in the CODE-REGEXP.
96
97 BASE    base of code in the string specified by CODE-REGEXP and
98         PAREN-EXP.
99
100 UCS-CCS is a symbol, which is a name of a UCS-CCS.
101
102 UCS-REGEXP is a regular expression to match against
103         the representation of the UCS-CCS.")
104
105 ;;;###autoload
106 (defun mapping-table-read-file (filename)
107   "Read mapping table." 
108   (interactive "fMapping table : ")
109   (with-temp-buffer
110     (buffer-disable-undo)
111     (insert-file-contents filename)
112     (goto-char (point-min))
113     (let (rest setting ccs code ucs ucs-pat ucs-ccs ucs-code chr)
114       (while (not (eobp))
115         (setq rest mapping-table-ccs-setting-alist)
116         (catch 'matched
117           (while rest
118             (setq setting (car rest)
119                   ccs (pop setting))
120             (when (looking-at (pop setting))
121               (setq code (string-to-int (match-string (pop setting))
122                                         (pop setting))
123                     ucs-ccs (pop setting)
124                     ucs-pat (car setting))
125               (goto-char (match-end 0))
126               (throw 'matched t))
127             (setq rest (cdr rest)))
128           (setq ccs nil
129                 code nil
130                 ucs-pat nil
131                 ucs-ccs nil))
132         (setq ucs-code
133               (if (and ucs-pat
134                        (looking-at ucs-pat))
135                   (prog1
136                       (string-to-int (match-string 1) 16)
137                     (goto-char (match-end 0)))))
138         (setq ucs
139               (if (looking-at
140                    "[ \t]*U[+-]\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]+\\)")
141                   (string-to-int (match-string 1) 16)))
142         (if (and ucs-ccs ucs (not ucs-code))
143             (setq ucs-code ucs
144                   ucs nil))
145         (when (setq chr (decode-char ccs code))
146           (unless (eq (encode-char chr ccs 'defined-only)
147                       code)
148             (put-char-attribute chr ccs code))
149           (when (and ucs-code
150                      (not
151                       (eq (or
152                            (encode-char chr ucs-ccs 'defined-only)
153                            (cond
154                             ((memq ucs-ccs '(=ucs@jis
155                                              =ucs@jis/1990
156                                              =ucs@jis/2000))
157                              (encode-char chr '=ucs@jis/fw 'defined-only))
158                             ((eq ucs-ccs '=ucs@gb)
159                              (encode-char chr '=ucs@gb/fw 'defined-only))
160                             ;; ((eq ucs-ccs '=ucs@cns)
161                             ;;  (encode-char chr '=ucs@cns/fw 'defined-only))
162                             ;; ((eq ucs-ccs '=ucs@big5)
163                             ;;  nil)
164                             ;; ((eq ucs-ccs '=ucs@ks)
165                             ;;  (encode-char chr '=ucs@ks/fw 'defined-only))
166                             (t
167                              (char-feature chr '=>ucs))))
168                           ucs-code)))
169             (put-char-attribute chr ucs-ccs ucs-code))
170           (when (and ucs
171                      (not (eq (or (encode-char chr '=ucs 'defined-only)
172                                   (and (not (memq ucs-ccs '(=ucs@jis
173                                                             =ucs@jis/1990
174                                                             =ucs@jis/2000
175                                                             =ucs@gb
176                                                             =ucs@cns
177                                                             =ucs@big5
178                                                             =ucs@ks
179                                                             )))
180                                        (char-feature chr '=>ucs)))
181                               ucs)))
182             (if (or ucs-code (null ucs-ccs))
183                 (unless (eq (char-feature chr '=>ucs) ucs)
184                   (put-char-attribute chr '=>ucs ucs))
185               (unless (eq (encode-char chr ucs-ccs 'defined-only)
186                           ucs)
187                 (put-char-attribute chr ucs-ccs ucs)))))
188         (forward-line)))))
189
190 ;;;###autoload
191 (defun ucs-compat-read-file (filename)
192   (interactive "fUCS-compat file : ")
193   (with-temp-buffer
194     (buffer-disable-undo)
195     (insert-file-contents filename)
196     (goto-char (point-min))
197     (let (ucs ucs*)
198       (while (re-search-forward
199               "^ *U[---+]\\([0-9A-F]+\\)\t *U[---+]\\([0-9A-F]+\\)" nil t)
200         (setq ucs (string-to-int (match-string 1) 16)
201               ucs* (string-to-int (match-string 2) 16))
202         (put-char-attribute (decode-char '=ucs ucs) '=>ucs* ucs*)
203         ))))
204
205 ;;;###autoload
206 (defun jp-jouyou-read-file (filename)
207   (interactive "fjp-jouyou file : ")
208   (with-temp-buffer
209     (buffer-disable-undo)
210     (insert-file-contents filename)
211     (goto-char (point-min))
212     (let (char tchars)
213       (while (re-search-forward "^[^\t\n ]+\t\\(.\\)\t*" nil t)
214         (setq char (aref (match-string 1) 0)
215               tchars (buffer-substring (match-end 0)
216                                        (point-at-eol)))
217         (when (> (length tchars) 0)
218           (setq tchars
219                 (mapcar (lambda (c)
220                           (aref c 0))
221                         (split-string tchars " ")))
222           (unless (or (equal (char-feature char '<-simplified@JP/Jouyou)
223                              tchars)
224                       (and (equal (char-feature char '<-simplified)
225                                   tchars)
226                            (memq 'JP/Jouyou
227                                  (char-feature char '<-simplified*sources))))
228             (put-char-attribute char
229                                 '<-simplified@JP/Jouyou
230                                 tchars)))
231         ;; (put-char-attribute
232         ;;  char 'script (adjoin
233         ;;                'JP
234         ;;                (adjoin
235         ;;                 'Jouyou
236         ;;                 (adjoin
237         ;;                  'Ideograph
238         ;;                  (get-char-attribute char 'script)))))
239         ))))
240
241 (provide 'read-maps)
242
243 ;;; read-maps.el ends here