a1d275b58c21361deb28a9a3881bf3b715c49fba
[chise/uptex-chise.git] / elisp / chise-tex.el
1 ;;; chise-tex.el --- Coding-system based chise2otf like tool
2
3 ;; Copyright (C) 2004,2005,2006,2007,2008,2009 MORIOKA Tomohiko
4
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: OTF package, pTeX, CHISE, Multiscript, Multilingual
7
8 ;; This file is a part of Omega/CHISE.
9
10 ;; This program 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 ;; This program is distributed in the hope that it will be useful, but
16 ;; 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 this program; 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 chise-tex-coded-charset-expression-alist
28   '((=ucs-bmp@gb        "UCSgb"         4 X)
29     (=ucs-bmp@jis       "UCSjis"        4 X)
30     (=ucs-bmp@ks        "UCSks"         4 X)
31     (=gt-pj-1           "GTpjA"         4 X)
32     (=gt-pj-2           "GTpjB"         4 X)
33     (=gt-pj-3           "GTpjC"         4 X)
34     (=gt-pj-4           "GTpjD"         4 X)
35     (=gt-pj-5           "GTpjE"         4 X)
36     (=gt-pj-6           "GTpjF"         4 X)
37     (=gt-pj-7           "GTpjG"         4 X)
38     (=gt-pj-8           "GTpjH"         4 X)
39     (=gt-pj-9           "GTpjI"         4 X)
40     (=gt-pj-10          "GTpjJ"         4 X)
41     (=gt-pj-11          "GTpjK"         4 X)
42     (=ruimoku-v6        "Ruimoku"       4 X)
43     (=hanziku-1         "HanzikuA"      4 X)
44     (=hanziku-2         "HanzikuB"      4 X)
45     (=hanziku-3         "HanzikuC"      4 X)
46     (=hanziku-4         "HanzikuD"      4 X)
47     (=hanziku-5         "HanzikuE"      4 X)
48     (=hanziku-6         "HanzikuF"      4 X)
49     (=hanziku-7         "HanzikuG"      4 X)
50     (=hanziku-8         "HanzikuH"      4 X)
51     (=hanziku-9         "HanzikuI"      4 X)
52     (=hanziku-10        "HanzikuJ"      4 X)
53     (=hanziku-11        "HanzikuK"      4 X)
54     (=hanziku-12        "HanzikuL"      4 X)
55     (=ucs-bmp@cns       "UCScns"        4 X)
56     (thai-tis620        "ThaiTIS"       2 X)
57     ))
58
59 (defvar chise-tex-accent-macro-alist
60   '((?\u0300 . "`") ; <COMBINING GRAVE ACCENT>
61     (?\u0301 . "'") ; <COMBINING ACUTE ACCENT>
62     (?\u0302 . "^") ; <COMBINING CIRCUMFLEX ACCENT>
63     (?\u0303 . "~") ; <COMBINING TILDE>
64     (?\u0304 . "=") ; <COMBINING MACRON>
65     (?\u0306 . "u") ; <COMBINING BREVE>
66     (?\u0307 . ".") ; <COMBINING DOT ABOVE>
67     (?\u0308 . "\"") ; <COMBINING DIAERESIS>
68     (?\u0309 . "Hook")
69     (?\u030B . "H") ; <COMBINING DOUBLE ACUTE ACCENT>
70     (?\u030C . "v") ; <COMBINING CARON>
71     (?\u0323 . "d") ; <COMBINING DOT BELOW>
72     (?\u0327 . "c") ; <COMBINING CEDILLA>
73     (?\u0328 . "k") ; <COMBINING OGONEK>
74     (?\u032E . "ubreve")
75     (?\u0331 . "umacron")
76     ))
77
78 (defun chise-tex-encode-region-for-gb (start end)
79   (interactive "r")
80   (save-excursion
81     (save-restriction
82       (narrow-to-region start end)
83       (goto-char start)
84       (let (chr ret rest spec)
85         (while (and (skip-chars-forward "\x00-\xFF")
86                     (not (eobp)))
87           (setq chr (char-after))
88           (cond ((memq chr '(?\e$(O#@\e(B))
89                  (delete-char)
90                  (insert (format "\\UCSjis{%04X}"
91                                  (encode-char chr '=ucs@jis)))
92                  )
93                 ((and (setq ret (encode-char chr '=jis-x0208-1983))
94                       (< ret #x3021))
95                  (forward-char))
96                 ;; ((setq ret (encode-char chr '=jis-x0208-1990))
97                 ;;  (delete-char)
98                 ;;  (insert (decode-char '=jis-x0208-1983 ret)))
99                 ((and (encode-char chr '=ks-x1001)
100                       (setq ret (or (encode-char chr '=ucs@ks)
101                                     (char-ucs chr))))
102                  (delete-char)
103                  ;; (if (eq (char-before) ?\e$B!T\e(B)
104                  ;;     (insert " "))
105                  (insert (format "\\UCSks{%04X}" ret)))
106                 ((catch 'tag
107                    (setq rest chise-tex-coded-charset-expression-alist)
108                    (while (setq spec (car rest))
109                      (if (setq ret (encode-char chr (car spec)))
110                          (throw 'tag ret))
111                      (setq rest (cdr rest))))
112                  (delete-char)
113                  ;; (if (eq (char-before) ?\e$B!T\e(B)
114                  ;;     (insert " "))
115                  (insert (format (format "\\%s{%%0%d%s}"
116                                          (nth 1 spec)
117                                          (nth 2 spec)
118                                          (nth 3 spec))
119                                  ret)))
120                 (t
121                  (forward-char))))))))
122
123 (defun chise-tex-encode-ucs-char-at-point (&optional chr)
124   (unless chr
125     (setq chr (char-after)))
126   (let (ret rest spec)
127     (cond
128      ((and (encode-char chr '=ks-x1001)
129            (setq ret (or (encode-char chr '=ucs@ks)
130                          (char-ucs chr))))
131       (delete-char)
132       ;; (if (eq (char-before) ?\e$B!T\e(B)
133       ;;     (insert " "))
134       (insert (format "\\UCSks{%04X}" ret))
135       t)
136      ((setq ret (encode-char chr '=ucs-hangul))
137       (delete-char)
138       ;; (if (eq (char-before) ?\e$B!T\e(B)
139       ;;     (insert " "))
140       (insert (format "\\UCSks{%04X}" ret))
141       t)
142      ((eq chr ?\u00B2)
143       (delete-char)
144       (insert "$^2$")
145       t)
146      ((eq chr ?\u00B3)
147       (delete-char)
148       (insert "$^3$")
149       t)
150      ((eq chr ?\u00F8)
151       (delete-char)
152       (insert "\\o{}")
153       t)
154      ((eq chr ?\u0111)
155       (delete-char)
156       (insert "{\\usefont{T1}{pxr}{m}{n}\\dj}")
157       t)
158      ((eq chr ?\u0142)
159       (delete-char)
160       (insert "\\l{}")
161       t)
162      ((eq chr ?\u014B)
163       (delete-char)
164       (insert "{\\usefont{T1}{pxr}{m}{n}\\ng}")
165       t)
166      ((eq chr ?\u0250)
167       (delete-char)
168       (insert "\\textturna{}")
169       t)
170      ((eq chr ?\u0254)
171       (delete-char)
172       (insert "\\textopeno{}")
173       t)
174      ((eq chr ?\u0264)
175       (delete-char)
176       (insert "\\textramshorns{}")
177       t)
178      ((eq chr ?\u026F)
179       (delete-char)
180       (insert "\\textturnm{}")
181       t)
182      ((eq chr ?\u0282)
183       (delete-char)
184       (insert "{\\usefont{T1}{pxr}{m}{n}\\k{s}}")
185       t)
186      ((eq chr ?\u0294)
187       (delete-char)
188       ;; (insert "\\UCSjis{0294}")
189       (insert "\\textglotstop{}")
190       t)
191      ((eq chr ?\u2022)
192       (delete-char)
193       (insert "\\textbullet{}")
194       t)
195      ((eq chr ?\u2080)
196       (delete-char)
197       (insert "$_0$")
198       t)
199      ((eq chr ?\u2081)
200       (delete-char)
201       (insert "$_1$")
202       t)
203      ((eq chr ?\u2082)
204       (delete-char)
205       (insert "$_2$")
206       t)
207      ((eq chr ?\u2083)
208       (delete-char)
209       (insert "$_3$")
210       t)
211      ((eq chr ?\u2084)
212       (delete-char)
213       (insert "$_4$")
214       t)
215      ((eq chr ?\u2085)
216       (delete-char)
217       (insert "$_5$")
218       t)
219      ((eq chr ?\u2086)
220       (delete-char)
221       (insert "$_6$")
222       t)
223      ((eq chr ?\u2087)
224       (delete-char)
225       (insert "$_7$")
226       t)
227      ((eq chr ?\u2088)
228       (delete-char)
229       (insert "$_8$")
230       t)
231      ((eq chr ?\u2089)
232       (delete-char)
233       (insert "$_9$")
234       t)
235      ((eq chr ?\u208A)
236       (delete-char)
237       (insert "$_+$")
238       t)
239      ((eq chr ?\u208B)
240       (delete-char)
241       (insert "$_-$")
242       t)
243      ((eq chr ?\u208C)
244       (delete-char)
245       (insert "$_=$")
246       t)
247      ((eq chr ?\u208D)
248       (delete-char)
249       (insert "$_($")
250       t)
251      ((eq chr ?\u208E)
252       (delete-char)
253       (insert "$_)$")
254       t)
255      ((eq chr ?\u2637)
256       (delete-char)
257       (insert "\\UCSgb{2637}")
258       t)
259      ((eq (encode-char chr '=ucs@jis) #x8DBC)
260       (delete-char)
261       (insert "\\GTpjG{4933}")
262       t)
263      ((and (encode-char chr '=ucs@jp)
264            (setq ret (char-representative-of-domain chr 'gb))
265            (setq ret (encode-char ret '=ucs@gb))
266            (<= ret #xFFFF))
267       (delete-char)
268       ;; (if (eq (char-before) ?\e$B!T\e(B)
269       ;;     (insert " "))
270       (insert (format "\\UCSgb{%04X}" ret))
271       t)
272      ((catch 'tag
273         (setq rest chise-tex-coded-charset-expression-alist)
274         (while (setq spec (car rest))
275           (if (setq ret (encode-char chr (car spec)))
276               (throw 'tag ret))
277           (setq rest (cdr rest))))
278       (delete-char)
279       ;; (if (eq (char-before) ?\e$B!T\e(B)
280       ;;     (insert " "))
281       (insert (format (format "\\%s{%%0%d%s}"
282                               (nth 1 spec)
283                               (nth 2 spec)
284                               (nth 3 spec))
285                       ret))
286       t)
287      )))
288
289 (defun chise-tex-encode-region-for-jis (start end)
290   (interactive "r")
291   (save-excursion
292     (save-restriction
293       (narrow-to-region start end)
294       (goto-char start)
295       (let (chr ret
296                 ;; rest spec
297                 modifier base modifier-1)
298         (while (and (skip-chars-forward "\x00-\x7F")
299                     (not (eobp)))
300           (setq chr (char-after))
301           (cond ((encode-char chr '=jis-x0208-1983)
302                  (forward-char))
303                 ;; ((setq ret (encode-char chr '=jis-x0208-1990))
304                 ;;  (delete-char)
305                 ;;  (insert (decode-char '=jis-x0208-1983 ret)))
306                 ((and (not (eq (char-ucs chr) #x0439))
307                       (not (eq (char-ucs chr) #x0451))
308                       (setq ret (char-feature chr '=decomposition))
309                       (setq modifier (assq (nth 1 ret)
310                                            '((?\u0300 . "`")
311                                              (?\u0301 . "'")
312                                              (?\u0302 . "^")
313                                              (?\u0303 . "~")
314                                              (?\u0304 . "=")
315                                              (?\u0306 . "u")
316                                              (?\u0307 . ".")
317                                              (?\u0308 . "\"")
318                                              (?\u0309 . "Hook")
319                                              (?\u030C . "v")
320                                              (?\u0323 . "d")
321                                              (?\u0327 . "c")
322                                              ))))
323                  (delete-char)
324                  (setq base (car ret))
325                  (if (and (setq ret (char-feature base '=decomposition))
326                           (setq modifier-1
327                                 (assq (car modifier)
328                                       (cdr
329                                        (assq (nth 1 ret)
330                                              '((?\u0302
331                                                 (?\u0300 . "CircGrave")
332                                                 (?\u0301 . "CircAcute")
333                                                 (?\u0303 . "CircTilde")
334                                                 (?\u0309 . "CircHook")
335                                                 )
336                                                (?\u031B
337                                                 (?\u0301 . "HornAcute")
338                                                 )
339                                                (?\u0323
340                                                 (?\u0302 . "Circudot")
341                                                 )))))))
342                      (insert (format "\\%s{%c}" (cdr modifier-1) (car ret)))
343                    (insert (format "\\%s{%c}" (cdr modifier) base))))
344                 ((and (or (encode-char chr '=jis-x0213-1-2000)
345                           (encode-char chr '=jis-x0213-2-2000))
346                       (setq ret (or (encode-char chr '=ucs@jis/2000)
347                                     (encode-char chr '=ucs@jis/fw)))
348                       (<= ret #xFFFF))
349                  (delete-char)
350                  ;; (if (eq (char-before) ?\e$B!T\e(B)
351                  ;;     (insert " "))
352                  (insert (format "\\UCSjis{%04X}" ret)))
353                 ((chise-tex-encode-ucs-char-at-point chr))
354                 (t
355                  (forward-char))))))))
356
357 (defun chise-tex-encode-region-for-utf-8-jis (start end)
358   (interactive "r")
359   (save-excursion
360     (save-restriction
361       (narrow-to-region start end)
362       (goto-char start)
363       (let ((font-encoding 'T1)
364             chr ret
365             ;; rest spec
366             modifier base modifier-1 pos)
367         (while (and (skip-chars-forward "\x00-\x7F")
368                     (not (eobp)))
369           (setq chr (char-after))
370           (cond
371            ((and (setq ret (encode-char chr '=ucs))
372                  (and (<= #x0400 ret)(<= ret #x04F9)))
373             (if (eq font-encoding 'T2A)
374                 (forward-char)
375               (setq pos (point))
376               ;; (unless (and (prog1
377               ;;                  (search-backward
378               ;;                   "\\fontencoding{T2A}\\selectfont{}" nil t)
379               ;;                (goto-char pos))
380               ;;              (eq pos (match-end 0)))
381               ;;   (insert "\\fontencoding{T2A}\\selectfont{}")
382               ;;   )
383               (if (search-backward "\\CyrillicScript{"
384                                    (- pos (eval-when-compile
385                                             (length "\\CyrillicScript{")))
386                                    t)
387                   (search-forward "}" nil t)
388                 (insert "\\CyrillicScript{")
389                 (forward-char)
390                 (skip-chars-forward "---\u0400-\u04F9 ")
391                 (insert "}"))
392               ;; (setq font-encoding 'T2A)
393               )
394             )
395            ((and (setq ret (encode-char chr '=ucs))
396                  (and (<= #x0374 ret)(<= ret #x03F3)))
397             (if (eq font-encoding 'LGR)
398                 (forward-char)
399               (setq pos (point))
400               ;; (unless (and (prog1
401               ;;                  (search-backward
402               ;;                   "\\fontencoding{LGR}\\selectfont{}" nil t)
403               ;;                (goto-char pos))
404               ;;              (eq pos (match-end 0)))
405               ;;   (insert "\\fontencoding{LGR}\\selectfont{}")
406               ;;   )
407               (if (search-backward "\\GreekScript{"
408                                    (- pos (eval-when-compile
409                                             (length "\\GreekScript{")))
410                                    t)
411                   (search-forward "}" nil t)
412                 (insert "\\GreekScript{")
413                 (forward-char)
414                 (skip-chars-forward "\u0374-\u03F3 ")
415                 (insert "}"))
416               ;; (setq font-encoding 'LGR)
417               )
418             ;; (unless (eq font-encoding 'T1)
419             ;;   (unless (looking-at
420             ;;            "\\\\fontencoding{T1}\\\\selectfont{}")
421             ;;     (insert "\\fontencoding{T1}\\selectfont{}")
422             ;;     )
423             ;;   (setq font-encoding 'T1))
424             )
425            (t
426             (unless (eq font-encoding 'T1)
427               (setq pos (point))
428               (unless (and (prog1
429                                (search-backward
430                                 "\\fontencoding{T1}\\selectfont{}" nil t)
431                              (goto-char pos))
432                            (eq pos (match-end 0)))
433                 (insert "\\fontencoding{T1}\\selectfont{}")
434                 )
435               (setq font-encoding 'T1))
436             (cond ((eq (char-ucs chr) #x00D7)
437                    (delete-char)
438                    (insert "\\UCSjis{00D7}"))
439                   ((encode-char chr '=jis-x0208-1983)
440                    (forward-char))
441                   ((and (setq ret (char-ucs chr))
442                         (or (eq ret #x00C5)
443                             (eq ret #x00E5)
444                             (eq ret #x1E2B)
445                             ))
446                    (forward-char))
447                   ;; ((setq ret (encode-char chr '=jis-x0208-1990))
448                   ;;  (delete-char)
449                   ;;  (insert (decode-char '=jis-x0208-1983 ret)))
450                   ((eq (char-ucs chr) #x012B)
451                    (delete-char)
452                    (insert "\\={\\i}")
453                    )
454                   ((setq ret (encode-char chr 'thai-tis620))
455                    (delete-char)
456                    (insert (format "\\ThaiTIS{%X}" (logior ret #x80)))
457                    )
458                   ((and (not (eq (char-ucs chr) #x0439))
459                         (not (eq (char-ucs chr) #x0451))
460                         (setq ret (char-feature chr '=decomposition))
461                         (setq modifier (assq (nth 1 ret)
462                                              chise-tex-accent-macro-alist)))
463                    (delete-char)
464                    (setq base (car ret))
465                    (if (and (setq ret (char-feature base '=decomposition))
466                             (setq modifier-1
467                                   (assq (car modifier)
468                                         (cdr
469                                          (assq (nth 1 ret)
470                                                '((?\u0302
471                                                   (?\u0300 . "\\CircGrave{%c}")
472                                                   (?\u0301 . "\\'{\\^%c}")
473                                                   (?\u0303 . "\\~{\\^%c}")
474                                                   (?\u0309 . "\\CircHook{%c}")
475                                                   )
476                                                  (?\u031B
477                                                   (?\u0301 . "\\HornAcute{%c}")
478                                                   (?\u0303 . "\\HornTilde{%c}")
479                                                   )
480                                                  (?\u0323
481                                                   (?\u0302 . "\\Circudot{%c}")
482                                                   )))))))
483                        (insert (format (cdr modifier-1) (car ret)))
484                      (insert (format "\\%s{%c}" (cdr modifier) base))))
485                   ((and (or (encode-char chr '=jis-x0213-1-2000)
486                             (encode-char chr '=jis-x0213-2-2000))
487                         (setq ret (or (encode-char chr '=ucs@jis/2000)
488                                       (encode-char chr '=ucs@jis/fw)))
489                         (<= ret #xFFFF))
490                    ;; (delete-char)
491                    ;; (if (eq (char-before) ?\e$B!T\e(B)
492                    ;;     (insert " "))
493                    ;; (insert (format "\\UCSjis{%04X}" ret))
494                    (forward-char))
495                   ((chise-tex-encode-ucs-char-at-point chr))
496                   (t
497                    (forward-char))))))))))
498
499 (defun chise-tex-decode-region (start end)
500   (interactive "r")
501   (save-excursion
502     (save-restriction
503       (narrow-to-region start end)
504       (goto-char start)
505       (let (macro code ret me rest spec)
506         (while (search-forward "\\={\\i}" nil t)
507           (replace-match "\e.D\eNo" t t))
508         (goto-char start)
509         (while (re-search-forward "\\\\\\(.\\){\\(.\\)}" nil t)
510           (when (and
511                  (setq macro
512                        (assq
513                         (aref (match-string 1) 0)
514                         '((?\` . ?\u0300) ; <COMBINING GRAVE ACCENT>
515                           (?\' . ?\u0301) ; <COMBINING ACUTE ACCENT>
516                           (?^  . ?\u0302) ; <COMBINING CIRCUMFLEX ACCENT>
517                           (?~  . ?\u0303) ; <COMBINING TILDE>
518                           (?=  . ?\u0304) ; <COMBINING MACRON>
519                           (?u  . ?\u0306) ; <COMBINING BREVE>
520                           (?\. . ?\u0307) ; <COMBINING DOT ABOVE>
521                           (?\" . ?\u0308) ; <COMBINING DIAERESIS>
522                           (?v  . ?\u030C) ; <COMBINING CARON>
523                           (?d  . ?\u0323) ; <COMBINING DOT BELOW>
524                           (?c  . ?\u0327) ; <COMBINING CEDILLA>
525                           )))
526                  (setq ret
527                        (cdr (assq (cdr macro)
528                                   (char-feature (aref (match-string 2) 0)
529                                                 'composition)))))
530             (delete-region (match-beginning 0)(match-end 0))
531             (insert ret)))
532         (goto-char start)
533         (while (re-search-forward "\\\\\\([a-zA-Z0-9]+\\){\\([0-9A-Fa-f]+\\)}"
534                                   nil t)
535           (setq macro (match-string 1)
536                 code (match-string 2)
537                 me (match-end 0))
538           (if (and (catch 'tag
539                      (setq rest chise-tex-coded-charset-expression-alist)
540                      (while (setq spec (car rest))
541                        (if (string= (nth 1 spec) macro)
542                            (throw 'tag spec))
543                        (setq rest (cdr rest))))
544                    (setq ret (decode-char (car spec)
545                                           (string-to-int
546                                            code
547                                            (if (eq (nth 3 spec) 'X)
548                                                16)))))
549               (progn
550                 (delete-region (match-beginning 0)(match-end 0))
551                 (insert ret))
552             (goto-char me)))))))
553
554 (make-coding-system
555  'iso-2022-jp-tex-gb 'iso2022
556  "ISO-2022-JP with TeX representation for GB fonts."
557  '(charset-g0 ascii
558    short t
559    seven t
560    ;; input-charset-conversion ((latin-jisx0201 ascii)
561    ;;                        (japanese-jisx0208-1978 japanese-jisx0208))
562    pre-write-conversion chise-tex-encode-region-for-gb
563    post-read-conversion chise-tex-decode-region
564    mnemonic "pTeX(GB)/7bit"
565    ))
566
567 (make-coding-system
568  'iso-2022-jp-tex-jis 'iso2022
569  "ISO-2022-JP with TeX representation for JIS fonts."
570  '(charset-g0 ascii
571    short t
572    seven t
573    ccs-priority-list (ascii
574                       =jis-x0208@1983 =jis-x0208@1978
575                       latin-jisx0201)
576    ;; output-charset-conversion ((=jis-x0208@1990 =jis-x0208@1983))
577    pre-write-conversion chise-tex-encode-region-for-jis
578    post-read-conversion chise-tex-decode-region
579    mnemonic "pTeX(JIS)/7bit"
580    ))
581
582 (make-coding-system
583  'utf-8-jp-tex 'utf-8
584  "Coding-system of UTF-8 for common glyphs used in Japan."
585  '(pre-write-conversion chise-tex-encode-region-for-utf-8-jis
586    post-read-conversion chise-tex-decode-region
587    charset-g0 =ucs@jp
588    charset-g1 =>ucs-jis
589    charset-g2 =>ucs
590    mnemonic "upTeX(JP)/UTF8"))
591
592
593 ;;; @ End.
594 ;;;
595
596 (provide 'chise-tex)
597
598 ;;; chise-tex.el ends here