From 9cbb5c35e40f0025fca1ef185ea1fd4771e41567 Mon Sep 17 00:00:00 2001 From: tomo Date: Fri, 12 Nov 1999 17:16:24 +0000 Subject: [PATCH] New file. --- lisp/utf-2000/auto-autoloads.el | 10 ++ lisp/utf-2000/char-db-util.el | 299 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 309 insertions(+) create mode 100644 lisp/utf-2000/auto-autoloads.el create mode 100644 lisp/utf-2000/char-db-util.el diff --git a/lisp/utf-2000/auto-autoloads.el b/lisp/utf-2000/auto-autoloads.el new file mode 100644 index 0000000..8459827 --- /dev/null +++ b/lisp/utf-2000/auto-autoloads.el @@ -0,0 +1,10 @@ +;;; DO NOT MODIFY THIS FILE +(if (featurep 'utf-2000-autoloads) (error "Already loaded")) + +;;;### (autoloads (what-char-definition) "char-db-util" "utf-2000/char-db-util.el") + +(autoload 'what-char-definition "char-db-util" nil t nil) + +;;;*** + +(provide 'utf-2000-autoloads) diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el new file mode 100644 index 0000000..dc740d2 --- /dev/null +++ b/lisp/utf-2000/char-db-util.el @@ -0,0 +1,299 @@ +;;; char-db-util.el --- Character Database utility + +;; Copyright (C) 1998, 1999 MORIOKA Tomohiko. + +;; Author: MORIOKA Tomohiko +;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE. + +;; This file is part of UTF-2000. + +;; UTF-2000 is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; UTF-2000 is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Code: + +(require 'alist) + +(defconst unidata-normative-category-alist + '(("Lu" letter uppercase) + ("Ll" letter lowercase) + ("Lt" letter titlecase) + ("Mn" mark non-spacing) + ("Mc" mark spacing-combining) + ("Me" mark enclosing) + ("Nd" number decimal-digit) + ("Nl" number letter) + ("No" number other) + ("Zs" separator space) + ("Zl" separator line) + ("Zp" separator paragraph) + ("Cc" other control) + ("Cf" other format) + ("Cs" other surrogate) + ("Co" other private-use) + ("Cn" other not-assigned))) + +(defconst unidata-informative-category-alist + '(("Lm" letter modifier) + ("Lo" letter other) + ("Pc" punctuation connector) + ("Pd" punctuation dash) + ("Ps" punctuation open) + ("Pe" punctuation close) + ("Pi" punctuation initial-quote) + ("Pf" punctuation final-quote) + ("Po" punctuation other) + ("Sm" symbol math) + ("Sc" symbol currency) + ("Sk" symbol modifier) + ("So" symbol other) + )) + +(defun insert-char-data (char) + (let ((data (char-attribute-alist char)) + cell ret name has-long-ccs-name rest) + (when data + (save-restriction + (narrow-to-region (point)(point)) + (insert "(define-char + '(") + (when (setq cell (assq 'name data)) + (setq cell (cdr cell)) + (insert (format + (if (> (length cell) 47) + "(name . %S) + " + "(name\t\t. %S) + ") + cell)) + (setq data (del-alist 'name data)) + ) + (when (setq cell (assq 'name data)) + (setq cell (cdr cell)) + (insert (format + (if (> (length cell) 47) + "(name . %S) + " + "(name\t\t. %S) + ") + cell)) + (setq data (del-alist 'name data)) + ) + (when (setq cell (assq 'ucs data)) + (setq cell (cdr cell)) + (insert (format "(ucs\t\t. #x%04X) + " + cell)) + (setq data (del-alist 'ucs data)) + ) + (when (setq cell (assq '->ucs data)) + (setq cell (cdr cell)) + (insert (format "(->ucs\t\t. #x%04X) + " + cell)) + (setq data (del-alist '->ucs data)) + ) + (when (setq cell (assq 'general-category data)) + (setq ret (cdr cell)) + (insert (format + "(general-category\t%s) ; %s + " + (mapconcat (lambda (cell) + (format "%S" cell)) + ret " ") + (cond ((rassoc (cdr cell) + unidata-normative-category-alist) + "Normative Category") + ((rassoc (cdr cell) + unidata-informative-category-alist) + "Informative Category") + (t + "Unknown Category")))) + (setq data (del-alist 'general-category data)) + ) + (when (setq cell (assq 'bidi-category data)) + (setq cell (cdr cell)) + (insert (format "(bidi-category\t. %S) + " + cell)) + (setq data (del-alist 'bidi-category data)) + ) + (when (setq cell (assq 'mirrored data)) + (setq cell (cdr cell)) + (insert (format "(mirrored\t\t. %S) + " + cell)) + (setq data (del-alist 'mirrored data)) + ) + (when (setq cell (assq 'decimal-digit-value data)) + (setq cell (cdr cell)) + (insert (format "(decimal-digit-value . %S) + " + cell)) + (setq data (del-alist 'decimal-digit-value data)) + (when (setq cell (assq 'digit-value data)) + (setq cell (cdr cell)) + (insert (format "(digit-value\t . %S) + " + cell)) + (setq data (del-alist 'digit-value data)) + ) + (when (setq cell (assq 'numeric-value data)) + (setq cell (cdr cell)) + (insert (format "(numeric-value\t . %S) + " + cell)) + (setq data (del-alist 'numeric-value data)) + ) + ) + (setq data (sort data + (lambda (a b) + (let ((ka (car a)) + (kb (car b))) + (cond ((find-charset ka) + (cond ((find-charset kb) + (cond ((= (charset-dimension ka) + (charset-dimension kb)) + (< (charset-final ka) + (charset-final kb))) + (t + (< (charset-dimension ka) + (charset-dimension kb)) + ))) + (t))) + ((find-charset kb) + t) + ((symbolp ka) + (cond ((symbolp kb) + (string< (symbol-name ka) + (symbol-name kb))) + (t))) + ((symbolp kb) + nil)))))) + (setq rest data) + (while (and rest + (progn + (setq cell (car rest)) + (if (setq ret (find-charset (car cell))) + (if (>= (length (symbol-name (charset-name ret))) 19) + (progn + (setq has-long-ccs-name t) + nil) + t) + t))) + (setq rest (cdr rest))) + (while data + (setq cell (car data)) + (cond ((setq ret (find-charset (car cell))) + (insert (format (if has-long-ccs-name + "(%-26s %s) + " + "(%-18s %s) + " + ) + (charset-name ret) + (mapconcat (lambda (b) + (format "#x%02X" b) + ) + (cdr cell) " ")))) + ((string-match "^->" (symbol-name (car cell))) + (insert + (format "(%-18s %s) + " + (car cell) + (mapconcat (lambda (code) + (cond ((symbolp code) + (symbol-name code)) + ((integerp code) + (format "#x%04X" code)) + (t + (format "\n %S" code)))) + (cdr cell) " ")))) + ((consp (cdr cell)) + (insert (format "%S + " + cell))) + (t + (insert (format "(%-18s . %S) + " + (car cell)(cdr cell))) + )) + (setq data (cdr data))) + (insert "))\n") + (goto-char (point-min)) + (while (re-search-forward "[ \t]+$" nil t) + (replace-match "")) + (goto-char (point-max)) + (tabify (point-min)(point-max)) + )))) + +(defun insert-char-range-data (min max) + (let ((code min)) + (while (<= code max) + (insert-char-data (int-char code)) + (setq code (1+ code)) + ))) + +(defun write-char-range-data-to-file (min max file) + (with-temp-buffer + (insert-char-range-data min max) + (write-region (point-min)(point-max) file))) + +(defun char-db-update-comment () + (interactive) + (save-excursion + (goto-char (point-min)) + (let (cdef table) + (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t) + (goto-char (match-beginning 1)) + (setq cdef (read (current-buffer))) + (when (find-charset (car cdef)) + (goto-char (match-end 0)) + (if (setq table (charset-mapping-table (car cdef))) + (set-charset-mapping-table (car cdef) nil)) + (delete-region (point) (point-at-eol)) + (insert (format "\t; %c" (apply #'make-char cdef))) + (if table + (set-charset-mapping-table (car cdef) table)) + ))))) + +;;;###autoload +(defun what-char-definition (char) + (interactive (list (char-after))) + (let ((buf (get-buffer-create "*Character Description*")) + (the-buf (current-buffer)) + (win-conf (current-window-configuration))) + (pop-to-buffer buf) + (make-local-variable 'what-character-original-window-configuration) + (setq what-character-original-window-configuration win-conf) + (setq buffer-read-only nil) + (erase-buffer) + (condition-case err + (progn + (insert-char-data char) + (set-buffer-modified-p nil) + (view-mode the-buf (lambda (buf) + (set-window-configuration + what-character-original-window-configuration) + )) + (goto-char (point-min))) + (error (progn + (set-window-configuration + what-character-original-window-configuration) + (signal (car err) (cdr err))))))) + +(provide 'char-db-util) + +;;; char-db-util.el ends here -- 1.7.10.4