cbeta.el

   1 ;;; cbeta.el --- Parser for CBETA Ideographs representation.
   2
   3 ;; Copyright (C) 2001,2002 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: CBETA, IDS, Ideographs, UCS, Unicode
   7
   8 ;; This file is a part of Tomoyo-Tools.
   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 ;; (require 'mojikyo)
  28
  29 (defvar cbeta-replacement-char-alist
  30   (list '(?\u2502 . ?\u4E28)
  31         '(?\u251C . ?\u2E8A)
  32         (cons ?\u2524 (decode-char '=gt-k 00153))
  33         (cons ?\u3026 (decode-char 'japanese-jisx0208 #x5035))
  34         '(?\u3039 . ?\u8279)
  35         '(?\u3106 . ?\u6535)
  36         '(?\u3113 . ?\u37A2)
  37         '(?\u3117 . ?\u5369)
  38         '(?\u3128 . ?\u3405)
  39         '(?\u3120 . ?\u5E7A)
  40         ))
  41
  42 (defun cbeta-parse-element (string simplify)
  43   (let ((chr (aref string 0))
  44         ret)
  45     (cond ((eq chr ?\()
  46            (if (> (length string) 1)
  47                (let* ((ret (cbeta-parse-1 (substring string 1) simplify))
  48                       (str (cdr ret)))
  49                  (if (and str
  50                           (>= (length str) 1)
  51                           (eq (aref str 0) ?\)))
  52                      (cons (car ret)
  53                            (if (> (length str) 1)
  54                                (substring str 1)))))))
  55           ((eq chr ?\))
  56            nil)
  57           (t
  58            (cons (if (setq ret (assq chr cbeta-replacement-char-alist))
  59                      (cdr ret)
  60                    chr)
  61                  (if (> (length string) 1)
  62                      (substring string 1)))))))
  63
  64 (defun cbeta-parse-component (string simplify)
  65   (let ((ret (cbeta-parse-1 string simplify))
  66         rret)
  67     (when ret
  68       (if (and simplify
  69                (listp (car ret))
  70                (setq rret (ideographic-structure-find-char
  71                            (cdr (assq 'ideographic-structure (car ret))))))
  72           (cons rret (cdr ret))
  73         ret))))
  74
  75 (defun cbeta-parse-horizontal (l-chr string simplify)
  76   (let ((ret (cbeta-parse-component string simplify))
  77         rc)
  78     (when ret
  79       (if (and simplify
  80                (listp l-chr)
  81                (setq rc (ideographic-structure-find-char
  82                          (cdr (assq 'ideographic-structure l-chr)))))
  83           (setq l-chr rc))
  84       (cons (list
  85              (list 'ideographic-structure
  86                    ;; '(:cdp-combinator 1 :char #x2FF0)
  87                    ?\u2FF0
  88                    l-chr (car ret)))
  89             (cdr ret)))))
  90
  91 (defun cbeta-parse-vertical (u-chr string simplify)
  92   (let ((ret (cbeta-parse-component string simplify))
  93         rc)
  94     (when ret
  95       (if (and simplify
  96                (listp u-chr)
  97                (setq rc (ideographic-structure-find-char
  98                          (cdr (assq 'ideographic-structure u-chr)))))
  99           (setq u-chr rc))
 100       (cons (list
 101              (list 'ideographic-structure
 102                    ;; '(:cdp-combinator 2 :char #x2FF1)
 103                    ?\u2FF1
 104                    u-chr (car ret)))
 105             (cdr ret)))))
 106
 107 (defun cbeta-parse-other (u-chr string simplify)
 108   (let ((ret (cbeta-parse-component string simplify))
 109         rc)
 110     (when ret
 111       (if (and simplify
 112                (listp u-chr)
 113                (setq rc (ideographic-structure-find-char
 114                          (cdr (assq 'ideographic-structure u-chr)))))
 115           (setq u-chr rc))
 116       (cons (list
 117              (list 'ideographic-structure
 118                    (cond ((memq u-chr '(?\u56D7))
 119                           ?\u2FF4)
 120                          ((memq u-chr '(?\u51E0))
 121                           ?\u2FF5)
 122                          ((memq u-chr '(?\u51F5))
 123                           ?\u2FF6)
 124                          ((memq u-chr '(?\u531A))
 125                           ?\u2FF7)
 126                          ((memq u-chr '(?\u5382 ?\u5C38))
 127                           ?\u2FF8)
 128                          (t
 129                           ?\u2FFB))
 130                    u-chr (car ret)))
 131             (cdr ret)))))
 132
 133 (defun cbeta-substitute-char (s-chr old-chr new-chr)
 134   (let ((structure
 135          (if (characterp s-chr)
 136              (get-char-attribute s-chr 'ideographic-structure)
 137            (cdr (assq 'ideographic-structure s-chr))))
 138         component dest ret)
 139     (catch 'tag
 140       (while structure
 141         (setq component (car structure)
 142               structure (cdr structure))
 143         (cond ((equal component old-chr)
 144                (setq ret (nconc (nreverse dest)
 145                                 (cons new-chr structure)))
 146                (throw 'tag
 147                       (if (cdr (cdr ret))
 148                           (list (cons 'ideographic-structure ret))
 149                         (car (cdr ret)))))
 150               ((setq ret (cbeta-substitute-char component old-chr new-chr))
 151                (setq ret (nconc (nreverse dest)
 152                                 (cons ret structure)))
 153                (throw 'tag
 154                       (if (cdr (cdr ret))
 155                           (list (cons 'ideographic-structure ret))
 156                         (car (cdr ret)))))
 157               (t
 158                (setq dest (cons component dest))))))))
 159
 160 (defun cbeta-delete-char (s-chr d-chr)
 161   (let ((structure
 162          (if (characterp s-chr)
 163              (get-char-attribute s-chr 'ideographic-structure)
 164            (cdr (assq 'ideographic-structure s-chr))))
 165         component dest ret)
 166     (catch 'tag
 167       (while structure
 168         (setq component (car structure)
 169               structure (cdr structure))
 170         (cond ((equal component d-chr)
 171                (setq ret (nconc (nreverse dest) structure))
 172                (throw 'tag
 173                       (if (cdr (cdr ret))
 174                           (list (cons 'ideographic-structure ret))
 175                         (car (cdr ret)))))
 176               ((setq ret (cbeta-delete-char component d-chr))
 177                (setq ret (nconc (nreverse dest)
 178                                 (cons ret structure)))
 179                (throw 'tag
 180                       (if (cdr (cdr ret))
 181                           (list (cons 'ideographic-structure ret))
 182                         (car (cdr ret)))))
 183               (t
 184                (setq dest (cons component dest))))))))
 185
 186 (defun cbeta-parse-substitution (s-chr string simplify)
 187   (let ((ret (cbeta-parse-1 string simplify))
 188         old-chr new-chr str)
 189     (when ret
 190       (setq old-chr (car ret)
 191             str (cdr ret))
 192       (when (and str
 193                  (eq (aref str 0) ?+)
 194                  (>= (length str) 2))
 195         (setq str (substring str 1))
 196         (setq ret (cbeta-parse-1 str simplify))
 197         (when ret
 198           (setq new-chr (car ret)
 199                 str (cdr ret))
 200           (when (setq ret (cbeta-substitute-char s-chr old-chr new-chr))
 201             (cons ret str)))))))
 202
 203 (defun cbeta-parse-elimination (s-chr string simplify)
 204   (let ((ret (cbeta-parse-1 string simplify))
 205         old-chr str)
 206     (when ret
 207       (setq old-chr (car ret)
 208             str (cdr ret))
 209       (when (setq ret (cbeta-delete-char s-chr old-chr))
 210         (cons ret str)))))
 211
 212 (defun cbeta-parse-1 (string simplify)
 213   (let ((ret (cbeta-parse-element string simplify))
 214         c1 str
 215         op)
 216     (when ret
 217       (setq c1 (car ret)
 218             str (cdr ret))
 219       (or (if (and str
 220                    (setq op (aref str 0))
 221                    (> (length str) 1)
 222                    (setq str (substring str 1)))
 223               (cond ((eq op ?*)
 224                      (cbeta-parse-horizontal c1 str simplify))
 225                     ((eq op ?/)
 226                      (cbeta-parse-vertical c1 str simplify))
 227                     ((eq op ?@)
 228                      (cbeta-parse-other c1 str simplify))
 229                     ((eq op ?-)
 230                      (or (cbeta-parse-substitution c1 str simplify)
 231                          (cbeta-parse-elimination c1 str simplify)))))
 232           ret))))
 233
 234
 235 ;;; @ End.
 236 ;;;
 237
 238 (provide 'cbeta)
 239
 240 ;;; cbeta.el ends here