(require 'ids-find)
(defun decode-url-string (string &optional coding-system)
(if (> (length string) 0)
(let ((i 0)
dest)
(while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
(setq dest (concat dest
(substring string i (match-beginning 0))
(char-to-string
(int-char
(string-to-int (match-string 1 string) 16))))
i (match-end 0)))
(decode-coding-string
(concat dest (substring string i))
coding-system))))
(defconst www-ids-find-version "0.24.2")
(defvar www-ids-find-ideographic-products-file-name
(expand-file-name "ideographic-products"
(expand-file-name
"feature"
(expand-file-name
"character"
chise-system-db-directory))))
(defvar www-ids-find-chise-link-map-url-prefix
"http://kamichi.jp/chise_linkmap/map.cgi?code=")
(defvar www-ids-find-tang-chars-file-name
"~tomo/projects/chise/ids/www/tang-chars.udd")
(defun www-ids-find-format-char (c &optional code-desc)
(let ((str (encode-coding-string (format "%c" c) 'utf-8-er))
plane code)
(princ
(with-temp-buffer
(cond
((string-match "&CB\\([0-9]+\\);" str)
(setq code (string-to-int (match-string 1 str)))
(insert "\n"
code (/ code 1000) code))
(when code-desc
(insert (format "CB%05d" code)))
)
((string-match "&JC3-\\([0-9A-F]+\\);" str)
(setq code (string-to-int (match-string 1 str) 16))
(insert "
\n"
code code))
(when code-desc
(insert (format "JC3-%04X" code)))
)
((string-match "&J\\(78\\|83\\|90\\|SP\\)-\\([0-9A-F]+\\);" str)
(setq plane (match-string 1 str)
code (string-to-int (match-string 2 str) 16))
(insert "
\n"
plane code plane
(- (lsh code -8) 32)
(- (logand code 255) 32)))
(when code-desc
(insert (format "J%s-%04X" plane code)))
)
((string-match "&G\\([01]\\)-\\([0-9A-F]+\\);" str)
(setq plane (string-to-int (match-string 1 str))
code (string-to-int (match-string 2 str) 16))
(insert "
\n"
plane code plane
(- (lsh code -8) 32)
(- (logand code 255) 32)))
(when code-desc
(insert (format "G%d-%04X" plane code)))
)
((string-match "&C\\([1-7]\\)-\\([0-9A-F]+\\);" str)
(setq plane (string-to-int (match-string 1 str))
code (string-to-int (match-string 2 str) 16))
(insert "
\n"
plane code plane code))
(when code-desc
(insert (format "C%d-%04X" plane code)))
)
((string-match "&ZOB-\\([0-9]+\\);" str)
(setq code (string-to-int (match-string 1 str)))
(insert "
\n"
code code))
(when code-desc
(insert (format "ZOB-%04d" code)))
)
(t
(insert "")
(insert str)
(insert "")
))
(goto-char (point-min))
(while (search-forward "&" nil t)
(replace-match "&" t 'literal))
(buffer-string)))))
(defun www-ids-find-format-line (c is)
(let (ucs len i ids)
(www-ids-find-format-char c 'code-desc)
(princ
(or (if (setq ucs (or (char-ucs c)
(encode-char c 'ucs)))
(format
" %s"
ucs
(cond ((<= ucs #xFFFF)
(format "U+%04X" ucs))
((<= ucs #x10FFFF)
(format "U-%08X" ucs))))
" ")))
(when ucs
(princ
(format " (link map)"
www-ids-find-chise-link-map-url-prefix ucs)))
(princ " ")
(when is
(setq ids (ideographic-structure-to-ids is))
(setq i 0
len (length ids))
(while (< i len)
(www-ids-find-format-char (aref ids i))
(setq i (1+ i))))
(when (and ucs
(with-current-buffer
(find-file-noselect
www-ids-find-tang-chars-file-name)
(goto-char (point-min))
(re-search-forward (format "^%d$" ucs) nil t)))
(princ
(format " "
(mapconcat
(lambda (c)
(format "%%%02X" (char-int c)))
(encode-coding-string (char-to-string c)
'utf-8-jp)
"")))
(princ (encode-coding-string "⇒[唐代拓本]" 'utf-8-jp-er)))
(princ "
\n")))
(defun www-ids-insert-chars-including-components (components
&optional ignored-chars)
(let ((products (copy-list (ideographic-products-find components)))
is as bs len ignore-children)
(setq len (length products))
(dolist (c (cond
((> len 8192)
(setq ignore-children t)
products)
((> len 4096)
(sort products
(lambda (a b)
(< (char-int a)(char-int b))))
)
((> len 512)
(sort products
(lambda (a b)
(if (setq as (char-total-strokes a))
(if (setq bs (char-total-strokes b))
(if (= as bs)
(< (char-int a)(char-int b))
(< as bs))
t)
(< (char-int a)(char-int b)))))
)
(t
(sort products
(lambda (a b)
(if (setq as (char-total-strokes a))
(if (setq bs (char-total-strokes b))
(if (= as bs)
(ideograph-char< a b)
(< as bs))
t)
(ideograph-char< a b))))
)))
(unless (memq c ignored-chars)
(setq is (char-feature c 'ideographic-structure))
(princ "
Version ") (princ www-ids-find-version) (princ (format-time-string " (Last-modified: %Y-%m-%d %H:%M:%S)" (nth 5 (file-attributes www-ids-find-ideographic-products-file-name)))) (princ "
") (unless (file-newer-than-file-p www-ids-find-ideographic-products-file-name (locate-file (car command-line-args) exec-path)) (princ (encode-coding-string "
現在、システムの更新作業中です。しばらくお待ちください。
指定した部品を全て含む漢字の一覧を表示します。
CHISE で用いられる実態参照形式(例:&M-00256;)で部品を指定する事もできます。" 'utf-8-jp-er)) (princ (encode-coding-string "
\[Links\]
Copyright (C) 2005, 2006, 2007, 2008, 2009 MORIOKA Tomohiko") (princ (format "
Powered by XEmacs CHISE %s." xemacs-chise-version)) (princ " ")))