cbeta.el

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