X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=89e99e564bd1c066e13e62b18c2b38e596f7aec3;hb=69e7f8641ebcf3026cbad95e545c9463223b14ac;hp=5e5c638849d23fcc2fae807866101ca8e7c174c6;hpb=21213a594fe531bcaa1a10ddf46b16e05ef77414;p=chise%2Fxemacs-chise.git diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el index 5e5c638..89e99e5 100644 --- a/lisp/utf-2000/char-db-util.el +++ b/lisp/utf-2000/char-db-util.el @@ -71,6 +71,34 @@ (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A))) v)) +;;;###autoload +(defun char-ref-p (obj) + (and (consp obj) + (keywordp (car obj)))) + +;;;###autoload +(defun char-ref= (cr1 cr2) + (cond ((char-ref-p cr1) + (if (char-ref-p cr2) + (char-spec= (plist-get cr1 :char) + (plist-get cr2 :char)) + (char-spec= (plist-get cr1 :char) cr2))) + (t + (char-spec= cr1 + (if (char-ref-p cr2) + (plist-get cr2 :char) + cr2))))) + +;;;###autoload +(defun char-spec= (cs1 cs2) + (if (characterp cs1) + (if (characterp cs2) + (eq cs1 cs2) + (eq cs1 (find-char cs2))) + (if (characterp cs2) + (eq (find-char cs1) cs2) + (eq (find-char cs1) (find-char cs2))))) + (defun char-attribute-name< (ka kb) (cond ((find-charset ka) @@ -116,45 +144,85 @@ ((symbolp kb) nil))) +(defvar char-db-coded-charset-priority-list + (let ((rest default-coded-charset-priority-list) + dest) + (while rest + (when (symbolp (car rest)) + (cond ((memq (car rest) + '(latin-viscii-lower + latin-viscii-upper + ipa + lao + ethiopic + arabic-digit + arabic-1-column + arabic-2-column))) + ((string-match "^ideograph-gt-pj-" (symbol-name (car rest))) + (unless (memq 'ideograph-gt dest) + (setq dest (cons 'ideograph-gt dest)))) + (t + (setq dest (cons (car rest) dest))))) + (setq rest (cdr rest))) + (sort dest #'char-attribute-name<))) + (defun char-db-insert-char-spec (char &optional readable column) (unless column (setq column (current-column))) - (let (char-spec ret al cal key) + (let (char-spec ret al cal key temp-char) (cond ((characterp char) - (cond ((setq ret (get-char-attribute char 'ucs)) + (cond ((and (setq ret (get-char-attribute char 'ucs)) + (not (and (<= #xE000 ret)(<= ret #xF8FF)))) (setq char-spec (list (cons 'ucs ret))) (if (setq ret (get-char-attribute char 'name)) (setq char-spec (cons (cons 'name ret) char-spec))) ) - ((setq ret (split-char char)) + ((setq ret + (let ((default-coded-charset-priority-list + char-db-coded-charset-priority-list)) + (split-char char))) (setq char-spec (list ret)) (dolist (ccs (delq (car ret) (charset-list))) - (if (and (>= (charset-iso-final-char ccs) ?0) - (setq ret (get-char-attribute char ccs))) + (if (or (and (>= (charset-iso-final-char ccs) ?0) + (setq ret (get-char-attribute char ccs))) + (eq ccs 'ideograph-daikanwa)) (setq char-spec (cons (cons ccs ret) char-spec)))) + (if (null char-spec) + (setq char-spec (split-char char))) (if (setq ret (get-char-attribute char 'name)) (setq char-spec (cons (cons 'name ret) char-spec))) ))) ((consp char) (setq char-spec char) (setq char nil))) - (if (or char - (setq char (condition-case nil - (define-char char-spec) - (error nil)))) - (progn - (setq al nil - cal nil) - (while char-spec - (setq key (car (car char-spec))) - (if (find-charset key) - (setq cal (cons key cal)) - (setq al (cons key al))) - (setq char-spec (cdr char-spec))) - (insert-char-attributes char - readable - (or al 'none) cal)) - (insert (prin1-to-string char-spec))))) + (unless (or char + (condition-case nil + (setq char (find-char char-spec)) + (error nil))) + ;; define temporary character + ;; Current implementation is dirty. + (setq temp-char (define-char (cons '(ideograph-daikanwa . 0) + char-spec))) + (remove-char-attribute temp-char 'ideograph-daikanwa) + (setq char temp-char)) + (setq al nil + cal nil) + (while char-spec + (setq key (car (car char-spec))) + (if (find-charset key) + (setq cal (cons key cal)) + (setq al (cons key al))) + (setq char-spec (cdr char-spec))) + (insert-char-attributes char + readable + (or al 'none) cal) + (when temp-char + ;; undefine temporary character + ;; Current implementation is dirty. + (setq char-spec (char-attribute-alist temp-char)) + (while char-spec + (remove-char-attribute temp-char (car (car char-spec))) + (setq char-spec (cdr char-spec)))))) (defun char-db-insert-alist (alist &optional readable column) (unless column @@ -171,7 +239,7 @@ (cond ((eq name 'char) (insert "(char . ") (if (setq ret (condition-case nil - (define-char value) + (find-char value) (error nil))) (progn (setq al nil @@ -196,7 +264,7 @@ (if (and (consp cell) (consp (car cell)) (setq ret (condition-case nil - (define-char cell) + (find-char cell) (error nil))) ) (progn @@ -241,6 +309,12 @@ (setq value (pop plist)) (cond ((eq name :char) (insert ":char\t") + (cond ((numberp value) + (setq value (decode-char 'ucs value))) + ;; ((consp value) + ;; (setq value (or (find-char value) + ;; value))) + ) (char-db-insert-char-spec value readable) (insert line-breaking)) (t @@ -306,7 +380,7 @@ (when (and (memq 'name attributes) (setq value (get-char-attribute char 'name))) (insert (format - (if (> (length value) 47) + (if (> (+ (current-column) (length value)) 48) "(name . %S)%s" "(name . %S)%s") value line-breaking)) @@ -560,6 +634,24 @@ line-breaking)) (setq attributes (delq '->mojikyo attributes)) ) + (when (and (memq 'hanyu-dazidian-vol attributes) + (setq value (get-char-attribute char 'hanyu-dazidian-vol))) + (insert (format "(hanyu-dazidian-vol . %d)%s" + value line-breaking)) + (setq attributes (delq 'hanyu-dazidian-vol attributes)) + ) + (when (and (memq 'hanyu-dazidian-page attributes) + (setq value (get-char-attribute char 'hanyu-dazidian-page))) + (insert (format "(hanyu-dazidian-page . %d)%s" + value line-breaking)) + (setq attributes (delq 'hanyu-dazidian-page attributes)) + ) + (when (and (memq 'hanyu-dazidian-char attributes) + (setq value (get-char-attribute char 'hanyu-dazidian-char))) + (insert (format "(hanyu-dazidian-char . %d)%s" + value line-breaking)) + (setq attributes (delq 'hanyu-dazidian-char attributes)) + ) (setq rest ccs-attributes) (while (and rest (progn @@ -582,15 +674,19 @@ ((memq name '(->lowercase ->uppercase ->titlecase ->fullwidth <-fullwidth + ->identical ->vulgar-ideograph <-vulgar-ideograph ->ancient-ideograph <-ancient-ideograph ->original-ideograph <-original-ideograph ->simplified-ideograph <-simplified-ideograph + ->wrong-ideograph <-wrong-ideograph ->same-ideograph ->ideographic-variants + ->synonyms ->radical <-radical - ->bopomofo ->ideograph - ->ideographic <-ideographic)) + ->bopomofo <-bopomofo + ->ideographic <-ideographic + ideographic-structure)) (insert (format "(%-18s%s " name line-breaking)) (setq lbs (concat "\n" (make-string (current-column) ?\ )) separator nil) @@ -668,7 +764,7 @@ (if (and (consp cell) (consp (car cell)) (setq ret (condition-case nil - (define-char cell) + (find-char cell) (error nil)))) (progn (setq rest cell @@ -705,7 +801,8 @@ (setq value (get-char-attribute char name))) (insert (format - (cond ((memq name '(ideograph-daikanwa ideograph-gt)) + (cond ((memq name '(ideograph-daikanwa ideograph-gt + ideograph-cbeta)) (if has-long-ccs-name "(%-26s . %05d)\t; %c%s" "(%-18s . %05d)\t; %c%s")) @@ -845,6 +942,9 @@ (condition-case err (progn (insert-char-data-with-variant char 'printable) + (unless (char-attribute-alist char) + (insert (format ";; = %c\n" + (apply #'make-char (split-char char))))) ;; (char-db-update-comment) (set-buffer-modified-p nil) (view-mode the-buf (lambda (buf)