1 ;; -*- coding: utf-8-mcs-er -*-
2 (require 'char-db-util)
4 (setq file-name-coding-system 'utf-8-mcs-er)
7 (concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db")
9 (concord-assign-genre 'journal-volume@ruimoku "/usr/local/var/ruimoku/db")
10 (concord-assign-genre 'article@ruimoku "/usr/local/var/ruimoku/db")
11 (concord-assign-genre 'book@ruimoku "/usr/local/var/ruimoku/db")
13 (concord-assign-genre 'classification@ruimoku "/usr/local/var/ruimoku/db")
14 (concord-assign-genre 'region@ruimoku "/usr/local/var/ruimoku/db")
15 (concord-assign-genre 'era@ruimoku "/usr/local/var/ruimoku/db")
16 (concord-assign-genre 'period@ruimoku "/usr/local/var/ruimoku/db")
17 (concord-assign-genre 'journal@ruimoku "/usr/local/var/ruimoku/db")
20 (defvar chise-wiki-view-url "view.cgi")
21 (defvar chise-wiki-edit-url "edit.cgi")
23 (defvar chise-wiki-bitmap-glyphs-url
24 "http://chise.zinbun.kyoto-u.ac.jp/glyphs")
26 (defvar chise-wiki-glyph-cgi-url
27 "http://chise.zinbun.kyoto-u.ac.jp/chisewiki/glyph.cgi")
29 (defvar chise-wiki-displayed-features nil)
31 (defun decode-uri-string (string &optional coding-system)
32 (if (> (length string) 0)
36 (mapconcat (lambda (char)
39 (char-to-string char)))
41 (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
42 (setq dest (concat dest
43 (substring string i (match-beginning 0))
46 (string-to-int (match-string 1 string) 16))))
49 (concat dest (substring string i))
52 (defun www-feature-type (feature-name)
53 (or (char-feature-property feature-name 'type)
54 (let ((str (symbol-name feature-name)))
56 ((string-match "\\*note\\(@[^*]+\\)?$" str)
58 ((string-match "\\*sources\\(@[^*]+\\)?$" str)
60 ((string-match "\\*" str)
62 ((string-match "^\\(->\\|<-\\)" str)
64 ((string-match "^ideographic-structure\\(@\\|$\\)" str)
68 (defun www-feature-format (feature-name)
69 (or (char-feature-property feature-name 'format)
71 (setq fn feature-name)
72 (while (and (setq parent (char-feature-name-parent fn))
74 (char-feature-property
78 '((name) " : " (value))))
80 (defun www-feature-value-format (feature-name)
81 (or (char-feature-property feature-name 'value-format)
83 (setq fn feature-name)
84 (while (and (setq parent (char-feature-name-parent fn))
86 (char-feature-property
87 parent 'value-format))))
90 (let ((type (www-feature-type feature-name)))
91 (cond ((eq type 'relation)
92 'space-separated-char-list)
98 (if (find-charset feature-name)
99 (if (and (= (charset-dimension feature-name) 2)
100 (= (charset-chars feature-name) 94))
102 " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
103 '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))))
105 (defun char-feature-name-at-domain (feature-name domain)
107 (let ((name (symbol-name feature-name)))
109 ((string-match "@[^*]+$" name)
110 (intern (format "%s/%s" name domain))
113 (intern (format "%s@%s" name domain))
117 (defun char-feature-name-parent (feature-name)
118 (let ((name (symbol-name feature-name)))
119 (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
120 (intern (substring name 0 (car (last (match-data) 2)))))))
122 (defun char-feature-name-domain (feature-name)
123 (let ((name (symbol-name feature-name)))
124 (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
125 (intern (substring name (1+ (match-beginning 0)))))))
127 (defun char-feature-name-sans-versions (feature)
128 (let ((feature-name (symbol-name feature)))
129 (if (string-match "[@/]\\$rev=latest$" feature-name)
130 (intern (substring feature-name 0 (match-beginning 0)))
133 (defun est-object-genre (object)
134 (if (characterp object)
136 (concord-object-genre object)))
138 (defun www-get-feature-value (object feature)
139 (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
142 (mount-char-attribute-table latest-feature)
143 (or (char-feature object latest-feature)
144 (char-feature object feature))
147 (or (condition-case nil
148 (concord-object-get object latest-feature)
151 (concord-object-get object feature)
155 (defun get-previous-code-point (ccs code)
156 (let ((chars (charset-chars ccs))
157 (dim (charset-dimension ccs))
159 mask byte-min byte-max
182 (setq bytes (make-vector dim 0))
184 (aset bytes i (logand (lsh code (* i -8)) mask))
187 (while (and (< i dim)
189 (aset bytes i (1- (aref bytes i)))
190 (< (aref bytes i) byte-min)))
191 (aset bytes i byte-max)
194 (setq dest (aref bytes 0)
197 (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
201 (defun get-next-code-point (ccs code)
202 (let ((chars (charset-chars ccs))
203 (dim (charset-dimension ccs))
205 mask byte-min byte-max
228 (setq bytes (make-vector dim 0))
230 (aset bytes i (logand (lsh code (* i -8)) mask))
233 (while (and (< i dim)
235 (aset bytes i (1+ (aref bytes i)))
236 (> (aref bytes i) byte-max)))
237 (aset bytes i byte-min)
240 (setq dest (aref bytes 0)
243 (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
247 (defun find-previous-defined-code-point (ccs code)
248 (let ((i (get-previous-code-point ccs code))
251 ((eq ccs '=jis-x0208)
252 (setq ccs '=jis-x0208@1990))
253 ((eq ccs '=jis-x0213-1)
254 (setq ccs '=jis-x0213-1@2004)))
257 (null (setq char (decode-char ccs i
258 (unless (eq ccs '=ucs)
260 (setq i (get-previous-code-point ccs i)))
263 (defun find-next-defined-code-point (ccs code)
264 (let ((i (get-next-code-point ccs code))
266 (setq max (+ code 1000))
268 ((eq ccs '=jis-x0208)
269 (setq ccs '=jis-x0208@1990))
270 ((eq ccs '=jis-x0213-1)
271 (setq ccs '=jis-x0213-1@2004)))
274 (null (setq char (decode-char ccs i
275 (unless (eq ccs '=ucs)
277 (setq i (get-next-code-point ccs i)))
281 ;;; @ URI representation
284 (defun www-uri-decode-feature-name (uri-feature)
287 ((string-match "^from\\." uri-feature)
288 (intern (format "<-%s" (substring uri-feature (match-end 0))))
290 ((string-match "^to\\." uri-feature)
291 (intern (format "->%s" (substring uri-feature (match-end 0))))
293 ((string-match "^rep\\." uri-feature)
294 (intern (format "=%s" (substring uri-feature (match-end 0))))
296 ((string-match "^g\\." uri-feature)
297 (intern (format "=>>%s" (substring uri-feature (match-end 0))))
299 ((string-match "^gi\\." uri-feature)
300 (intern (format "=>>>%s" (substring uri-feature (match-end 0))))
302 ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
303 (intern (format "=>>%s%s"
304 (make-string (string-to-int
305 (match-string 1 uri-feature))
307 (substring uri-feature (match-end 0))))
309 ((string-match "^a\\." uri-feature)
310 (intern (format "=>%s" (substring uri-feature (match-end 0))))
312 ((string-match "^a\\([0-9]+\\)\\." uri-feature)
313 (intern (format "%s>%s"
314 (make-string (string-to-int
315 (match-string 1 uri-feature))
317 (substring uri-feature (match-end 0))))
319 ((and (setq feature (intern (format "=>%s" uri-feature)))
320 (find-charset feature))
322 ((and (setq feature (intern (format "=>>%s" uri-feature)))
323 (find-charset feature))
325 ((and (setq feature (intern (format "=>>>%s" uri-feature)))
326 (find-charset feature))
328 ((and (setq feature (intern (format "=%s" uri-feature)))
329 (find-charset feature))
331 (t (intern uri-feature)))))
333 (defun www-uri-encode-feature-name (feature-name)
334 (setq feature-name (symbol-name feature-name))
336 ((string-match "^=\\([^=>]+\\)" feature-name)
337 (concat "rep." (substring feature-name (match-beginning 1)))
339 ((string-match "^=>>\\([^=>]+\\)" feature-name)
340 (concat "g." (substring feature-name (match-beginning 1)))
342 ((string-match "^=>>>\\([^=>]+\\)" feature-name)
343 (concat "gi." (substring feature-name (match-beginning 1)))
345 ((string-match "^=>>\\(>+\\)" feature-name)
347 (length (match-string 1 feature-name))
348 (substring feature-name (match-end 1)))
350 ((string-match "^=>\\([^=>]+\\)" feature-name)
351 (concat "a." (substring feature-name (match-beginning 1)))
353 ((string-match "^\\(=+\\)>" feature-name)
355 (length (match-string 1 feature-name))
356 (substring feature-name (match-end 0)))
358 ((string-match "^->" feature-name)
359 (concat "to." (substring feature-name (match-end 0)))
361 ((string-match "^<-" feature-name)
362 (concat "from." (substring feature-name (match-end 0)))
366 (defun www-uri-make-feature-name-url (uri-feature-name uri-char)
367 (format "%s?feature=%s&char=%s"
368 chise-wiki-view-url uri-feature-name uri-char))
370 (defun www-uri-decode-object (genre char-rep)
373 ((string-match "\\(%3A\\|:\\)" char-rep)
374 (setq ccs (substring char-rep 0 (match-beginning 0))
375 cpos (substring char-rep (match-end 0)))
376 (setq ccs (www-uri-decode-feature-name ccs))
378 ((string-match "^0x" cpos)
380 (string-to-number (substring cpos (match-end 0)) 16))
383 (setq cpos (car (read-from-string cpos)))
385 (if (and (eq genre 'character)
387 (decode-char ccs cpos)
388 (concord-decode-object ccs cpos genre))
391 (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
393 ((eq genre 'character)
394 (when (= (length char-rep) 1)
398 (concord-decode-object
399 '=id (www-uri-decode-feature-name char-rep) 'feature)
402 (concord-decode-object
403 '=id (car (read-from-string char-rep)) genre)
406 (defun www-uri-encode-object (object)
407 (if (characterp object)
408 (if (encode-char object '=ucs)
411 (format "%%%02X" byte))
412 (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
414 (let ((ccs-list '(; =ucs
415 =cns11643-1 =cns11643-2 =cns11643-3
416 =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
418 =jis-x0208 =jis-x0208@1990
421 =jis-x0213-1@2000 =jis-x0213-1@2004
422 =jis-x0208@1983 =jis-x0208@1978
423 =zinbun-oracle =>zinbun-oracle
426 =>>jis-x0208 =>>jis-x0213-1
427 =>jis-x0208 =>jis-x0213-1
434 (setq ccs (pop ccs-list))
435 (not (setq ret (encode-char object ccs 'defined-only)))))
438 (www-uri-encode-feature-name ccs)
440 ((and (setq ccs (car (split-char object)))
441 (setq ret (encode-char object ccs)))
443 (www-uri-encode-feature-name ccs)
446 (format "system-char-id:0x%X"
447 (encode-char object 'system-char-id))
449 (format "rep.id:%s" (concord-object-id object))))
451 (defun est-format-object (object)
452 (if (characterp object)
453 (char-to-string object)
454 (format "%s" (concord-object-id object))))
457 ;;; @ Feature name presentation
460 (defun www-format-feature-name-default (feature-name)
464 (symbol-name feature-name)
468 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
469 (let ((str (symbol-name feature-name))
472 ((string-match "\\*[^*]+$" str)
473 (setq base (substring str 0 (match-beginning 0))
474 meta (substring str (match-beginning 0)))
475 (concat (www-format-feature-name* (intern base) lang)
478 (www-format-feature-name-default feature-name)
481 (defun www-format-feature-name-as-rel-to (feature-name)
482 (concat "\u2192" (substring (symbol-name feature-name) 2)))
484 (defun www-format-feature-name-as-rel-from (feature-name)
485 (concat "\u2190" (substring (symbol-name feature-name) 2)))
487 (defun www-format-feature-name-as-CCS (feature-name)
490 (symbol-name feature-name)
492 (dest (upcase (pop rest))))
493 (when (string-match "^=+>*" dest)
494 (setq dest (concat (substring dest 0 (match-end 0))
496 (substring dest (match-end 0)))))
500 (setq dest (concat dest " " (upcase (pop rest)))))
501 (if (string-match "^[0-9]+$" (car rest))
502 (concat dest "-" (car rest))
503 (concat dest " " (upcase (car rest))))
507 (defun www-format-feature-name* (feature-name &optional lang)
508 (let (name fn parent ret)
511 (char-feature-property
513 (intern (format "name@%s" lang))))
514 (char-feature-property
515 feature-name 'name)))
516 ((and (setq name (symbol-name feature-name))
517 (string-match "\\*" name))
518 (www-format-feature-name-as-metadata feature-name lang))
520 (setq fn feature-name)
521 (while (and (setq parent (char-feature-name-parent fn))
524 (char-feature-property
526 (intern (format "name@%s" lang))))
527 (char-feature-property
532 (concat ret (substring (symbol-name feature-name)
533 (length (symbol-name parent)))))
534 ((find-charset feature-name)
535 (www-format-feature-name-as-CCS feature-name))
536 ((string-match "^\\(->\\)" name)
537 (www-format-feature-name-as-rel-to feature-name))
538 ((string-match "^\\(<-\\)" name)
539 (www-format-feature-name-as-rel-from feature-name))
541 (www-format-feature-name-default feature-name)
545 (defun www-format-feature-name (feature-name &optional lang)
546 (www-format-encode-string
547 (www-format-feature-name* feature-name lang)))
550 ;;; @ Feature value presentation
553 (defun www-format-value-as-kuten (value)
555 (- (lsh value -8) 32)
556 (- (logand value 255) 32)))
558 (defun www-format-value-default (value &optional without-tags)
562 (www-format-encode-string
566 (www-format-encode-string (format "%S" value) without-tags)))
568 (defun www-format-value-as-char-list (value &optional without-tags)
573 (www-format-encode-string
574 (format (if (characterp unit)
579 (let (genre-o name-f ret)
581 (if (characterp unit)
582 (format "<a href=\"%s?char=%s\">%s</a>"
584 (www-uri-encode-object unit)
585 (www-format-encode-string (char-to-string unit)))
586 (format "<a href=\"%s?%s=%s\">%s</a>"
588 (concord-object-genre unit)
589 (concord-object-id unit)
592 (www-get-feature-value
596 (concord-decode-object
598 (concord-object-genre unit)
600 (www-get-feature-value
602 'object-representation-format)
604 (www-format-eval-feature-value
605 unit name-f nil nil nil ret
606 'without-tags 'without-edit)
609 (www-format-encode-string
614 (www-format-encode-string (format "%s" value) without-tags)))
616 (defun www-format-value-as-domain-list (value &optional without-tags)
617 (let (name source0 source num dest rest unit start end ddest)
626 (setq unit (pop rest))
628 (setq name (symbol-name unit)))
633 ((string-match "^zob1968=" name)
634 (setq source (intern (substring name 0 (match-end 0)))
635 num (substring name (match-end 0)))
636 (if (string-match "^\\([0-9]+\\)-\\([0-9]+\\)$" num)
637 (setq start (string-to-number
638 (match-string 1 num))
639 end (string-to-number
640 (match-string 2 num)))
641 (setq start (string-to-number num)
644 (if (eq source source0)
646 ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
648 (setq source0 source)
650 " <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/\">%s</a>=<a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
651 (www-format-encode-string "\u4EAC大人\u6587ç ”ç”²\u9AA8")
653 (setq start (1+ start))
654 (while (<= start end)
659 ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
661 (setq start (1+ start)))
665 (if (eq source source0)
667 (setq source0 source)
671 (www-format-encode-string (format "%s" value) without-tags))))
673 (defun www-format-value-as-ids (value &optional without-tags)
678 (www-format-encode-string
679 (format (if (characterp unit)
685 (if (characterp unit)
686 (format "<a href=\"%s?char=%s\">%s</a>"
688 (www-uri-encode-object unit)
689 (www-format-encode-string (char-to-string unit)))
690 (www-format-encode-string (format "%s" unit)))))
691 (ideographic-structure-to-ids value) " ")
692 (www-format-encode-string (format "%s" value) without-tags)))
694 (defun www-format-value-as-S-exp (value &optional without-tags)
695 (www-format-encode-string (format "%S" value) without-tags))
697 (defun www-format-value-as-HEX (value)
700 (www-format-value-as-S-exp value)))
702 (defun www-format-value-as-CCS-default (value)
705 (www-format-value-as-HEX value)
707 (www-format-value-as-S-exp value)))
709 (defun www-format-value-as-CCS-94x94 (value)
711 (format "0x%s [%s] (%d)"
712 (www-format-value-as-HEX value)
713 (www-format-value-as-kuten value)
715 (www-format-value-as-S-exp value)))
717 (defun www-format-value-as-kangxi-radical (value)
718 (if (and (integerp value)
721 (www-format-encode-string
722 (format "%c" (ideographic-radical value)))
723 (www-format-value-as-S-exp value)))
725 (defun www-format-value (object feature-name
726 &optional value format
727 without-tags without-edit)
729 (setq value (www-get-feature-value object feature-name)))
730 (www-format-apply-value object feature-name
731 format nil value nil nil
732 without-tags without-edit)
736 ;;; @ format evaluator
739 (defun www-format-encode-string (string &optional without-tags)
742 (let (plane code start end char variants ret rret)
743 (goto-char (point-min))
744 (while (search-forward "<" nil t)
745 (replace-match "<" nil t))
746 (goto-char (point-min))
747 (while (search-forward ">" nil t)
748 (replace-match ">" nil t))
750 (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
751 (let ((coded-charset-entity-reference-alist
754 '(=cns11643-1 "C1-" 4 X)
755 '(=cns11643-2 "C2-" 4 X)
756 '(=cns11643-3 "C3-" 4 X)
757 '(=cns11643-4 "C4-" 4 X)
758 '(=cns11643-5 "C5-" 4 X)
759 '(=cns11643-6 "C6-" 4 X)
760 '(=cns11643-7 "C7-" 4 X)
762 '(=gb12345 "G1-" 4 X)
763 '(=jis-x0208@1990 "J90-" 4 X)
764 '(=jis-x0212 "JSP-" 4 X)
766 '(=jis-x0208@1997 "J97-" 4 X)
767 '(=jis-x0208@1978 "J78-" 4 X)
768 '(=jis-x0208@1983 "J83-" 4 X)
769 '(=ruimoku-v6 "RUI6-" 4 X)
770 '(=zinbun-oracle "ZOB-" 4 d)
771 '(=jef-china3 "JC3-" 4 X)
772 '(=daikanwa "M-" 5 d)
773 coded-charset-entity-reference-alist)))
774 (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
776 (goto-char (point-min))
777 (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
778 (setq code (string-to-int (match-string 1)))
780 (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\">"
782 chise-wiki-bitmap-glyphs-url
786 (goto-char (point-min))
787 (while (re-search-forward "&J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
788 (setq plane (match-string 1)
789 code (string-to-int (match-string 2) 16))
791 (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\">"
793 chise-wiki-bitmap-glyphs-url
796 (- (logand code 255) 32))
799 (goto-char (point-min))
800 (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
801 (setq plane (string-to-int (match-string 1))
802 code (string-to-int (match-string 2) 16))
804 (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\">"
806 chise-wiki-bitmap-glyphs-url
809 (- (logand code 255) 32))
812 (goto-char (point-min))
813 (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
814 (setq plane (string-to-int (match-string 1))
815 code (string-to-int (match-string 2) 16))
817 (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\">"
819 chise-wiki-bitmap-glyphs-url
823 (goto-char (point-min))
824 (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
825 (setq code (string-to-int (match-string 1) 16))
827 (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
831 (goto-char (point-min))
832 (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
833 (setq code (string-to-int (match-string 2)))
835 (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\">"
837 chise-wiki-bitmap-glyphs-url
841 (goto-char (point-min))
842 (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
843 (setq code (string-to-int (match-string 2)))
845 (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\">"
847 chise-wiki-glyph-cgi-url
851 (goto-char (point-min))
852 (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
853 (setq code (string-to-int (match-string 2)))
855 (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\">"
857 chise-wiki-glyph-cgi-url
861 (goto-char (point-min))
862 (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
863 (setq code (string-to-int (match-string 1) 16))
865 (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\">"
867 chise-wiki-glyph-cgi-url
871 (goto-char (point-min))
872 (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
873 (setq code (string-to-int (match-string 1) 16))
875 (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\">"
877 chise-wiki-glyph-cgi-url
881 (goto-char (point-min))
882 (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
883 (setq code (string-to-int (match-string 1) 16))
885 (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\">"
887 chise-wiki-glyph-cgi-url
891 (goto-char (point-min))
892 (while (re-search-forward "&\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
893 (setq code (string-to-int (match-string 2) 16))
895 (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\">"
900 (goto-char (point-min))
901 (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
902 (setq code (string-to-int (match-string 1) 16))
903 (setq start (match-beginning 0)
905 (setq char (decode-char 'system-char-id code))
908 (or (www-get-feature-value char '->subsumptive)
909 (www-get-feature-value char '->denotational)))
912 (setq ret (www-format-encode-string
913 (char-to-string (car variants))))
914 (string-match "&MCS-\\([0-9A-F]+\\);" ret))
915 (setq variants (cdr variants)))
917 (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
919 (delete-region start end)
922 ((setq ret (or (www-get-feature-value char 'ideographic-combination)
923 (www-get-feature-value char 'ideographic-structure)))
928 (if (characterp (setq rret (find-char ch)))
931 (www-format-encode-string
932 (char-to-string ch) without-tags)
933 (www-format-encode-string
934 (format "%S" ch) without-tags)))
938 (delete-region start end)
942 ;; (goto-char (point-min))
943 ;; (while (search-forward ">-" nil t)
944 ;; (replace-match "&GT-" t 'literal))
947 (defun www-format-props-to-string (props &optional format)
949 (setq format (plist-get props :format)))
951 (plist-get props :flag)
952 ;; (if (plist-get props :zero-padding)
954 (if (plist-get props :len)
956 (let ((ret (plist-get props :len)))
961 ((eq format 'decimal) "d")
962 ((eq format 'hex) "x")
963 ((eq format 'HEX) "X")
964 ((eq format 'S-exp) "S")
967 (defun www-format-apply-value (object feature-name
969 &optional uri-object uri-feature
970 without-tags without-edit)
974 ((memq format '(decimal hex HEX))
976 (format (www-format-props-to-string props format)
978 (www-format-encode-string
982 ((eq format 'wiki-text)
984 (www-xml-format-list value)
985 (www-format-eval-list value object feature-name nil uri-object
986 without-tags without-edit))
989 (www-format-encode-string
990 (format (www-format-props-to-string props format)
994 (www-format-value-as-kuten value))
995 ((eq format 'kangxi-radical)
996 (www-format-value-as-kangxi-radical value))
997 ((eq format 'space-separated-char-list)
998 (www-format-value-as-char-list value without-tags))
999 ((eq format 'space-separated-ids)
1000 (www-format-value-as-ids value without-tags))
1001 ((eq format 'space-separated-domain-list)
1002 (www-format-value-as-domain-list value without-tags))
1003 ((eq format 'string)
1004 (www-format-encode-string (format "%s" value) without-tags)
1007 (www-format-value-default value without-tags)
1010 (if (or without-tags
1012 (eq (plist-get props :mode) 'peek))
1014 (format "%s <a href=\"%s?%s=%s&feature=%s&format=%s\"
1015 ><input type=\"submit\" value=\"edit\" /></a>"
1018 (est-object-genre object)
1019 uri-object uri-feature format))))
1021 (defun www-format-eval-feature-value (object
1023 &optional format lang uri-object value
1024 without-tags without-edit)
1026 (setq value (www-get-feature-value object feature-name)))
1028 (setq format (www-feature-value-format feature-name)))
1031 (www-format-apply-value
1034 uri-object (www-uri-encode-feature-name feature-name)
1035 without-tags without-edit)
1038 (cond ((null (cdr format))
1039 (setq format (car format))
1040 (www-format-apply-value
1042 (car format) (nth 1 format) value
1043 uri-object (www-uri-encode-feature-name feature-name)
1044 without-tags without-edit)
1047 (www-format-eval-list format object feature-name lang uri-object
1048 without-tags without-edit)
1051 (defun www-format-eval-unit (exp object feature-name
1052 &optional lang uri-object value
1053 without-tags without-edit)
1055 (setq value (www-get-feature-value object feature-name)))
1057 (setq uri-object (www-uri-encode-object object)))
1059 ((stringp exp) (www-format-encode-string exp))
1063 ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
1064 S-exp string default))
1065 (let ((fn (plist-get (nth 1 exp) :feature))
1066 domain domain-fn ret)
1069 (setq fn (intern fn)))
1070 (setq domain (char-feature-name-domain feature-name))
1071 (setq domain-fn (char-feature-name-at-domain fn domain))
1072 (if (setq ret (www-get-feature-value object domain-fn))
1073 (setq feature-name domain-fn
1075 (setq feature-name fn
1076 value (www-get-feature-value object fn)))
1077 (push feature-name chise-wiki-displayed-features)
1079 (if (eq (car exp) 'value)
1080 (www-format-eval-feature-value object feature-name
1081 (plist-get (nth 1 exp) :format)
1082 lang uri-object value
1083 without-tags without-edit)
1084 (www-format-apply-value
1086 (car exp) (nth 1 exp) value
1087 uri-object (www-uri-encode-feature-name feature-name)
1088 without-tags without-edit))
1090 ((eq (car exp) 'name)
1091 (let ((fn (plist-get (nth 1 exp) :feature))
1094 (setq domain (char-feature-name-domain feature-name))
1096 (setq fn (intern fn)))
1097 (setq domain-fn (char-feature-name-at-domain fn domain))
1098 (setq feature-name domain-fn)))
1100 (www-format-feature-name feature-name lang)
1101 (format "<a href=\"%s\">%s</a>"
1102 (www-uri-make-feature-name-url
1103 (www-uri-encode-feature-name feature-name)
1105 (www-format-feature-name feature-name lang))
1108 ((eq (car exp) 'name-url)
1109 (let ((fn (plist-get (nth 1 exp) :feature))
1112 (setq domain (char-feature-name-domain feature-name))
1114 (setq fn (intern fn)))
1115 (setq domain-fn (char-feature-name-at-domain fn domain))
1116 (setq feature-name domain-fn)))
1117 (www-uri-make-feature-name-url
1118 (www-uri-encode-feature-name feature-name)
1121 ((eq (car exp) 'domain-name)
1122 (let ((domain (char-feature-name-domain feature-name)))
1124 (format "@%s" domain))))
1125 ((eq (car exp) 'prev-char)
1128 (let ((prev-char (find-previous-defined-code-point
1129 feature-name value)))
1131 (format "\n<a href=\"%s?char=%s\">%s</a>"
1133 (www-uri-encode-object prev-char)
1134 "<input type=\"submit\" value=\"-\" />"
1135 ;; (www-format-encode-string
1136 ;; (char-to-string prev-char))
1140 ((eq (car exp) 'next-char)
1143 (let ((next-char (find-next-defined-code-point
1144 feature-name value)))
1146 (format "<a href=\"%s?char=%s\">%s</a>"
1148 (www-uri-encode-object next-char)
1149 "<input type=\"submit\" value=\"+\" />"
1150 ;; (www-format-encode-string
1151 ;; (char-to-string next-char))
1155 ((eq (car exp) 'link)
1157 (www-format-eval-list (nthcdr 2 exp)
1158 object feature-name lang uri-object
1159 without-tags without-edit)
1164 (www-format-eval-list (plist-get (nth 1 exp) :ref)
1165 object feature-name lang uri-object
1166 'without-tags 'without-edit)
1167 (www-format-eval-list (nthcdr 2 exp)
1168 object feature-name lang uri-object
1169 without-tags without-edit)))
1176 (www-format-eval-list (nthcdr 2 exp) object feature-name
1178 without-tags without-edit)
1181 (defun www-format-eval-list (format-list object feature-name
1182 &optional lang uri-object
1183 without-tags without-edit)
1184 (if (consp format-list)
1187 (www-format-eval-unit exp object feature-name lang uri-object
1188 nil without-tags without-edit))
1190 (www-format-eval-unit format-list object feature-name lang uri-object
1191 nil without-tags without-edit)))
1197 (defun www-xml-format-props (props)
1201 (setq key (pop props)
1204 (setq key (symbol-name key)))
1205 (if (eq (aref key 0) ?:)
1206 (setq key (substring key 1)))
1208 (format "%s %s=\"%s\""
1210 (www-format-encode-string
1211 (format "%s" val) 'without-tags))))
1214 (defun www-xml-format-unit (format-unit)
1215 (let (name props children ret)
1217 ((stringp format-unit)
1218 (mapconcat (lambda (c)
1221 ;; ((eq c ?<) "&lt;")
1222 ;; ((eq c ?>) "&gt;")
1224 (char-to-string c))))
1225 (www-format-encode-string format-unit 'without-tags)
1228 ((consp format-unit)
1229 (setq name (car format-unit)
1230 props (nth 1 format-unit)
1231 children (nthcdr 2 format-unit))
1232 (when (eq name 'link)
1233 (setq ret (plist-get props :ref))
1234 (unless (stringp ret)
1235 (setq props (plist-remprop (copy-list props) :ref))
1237 (cons (list* 'ref nil ret)
1240 (format "<%s%s>%s</%s>"
1243 (www-xml-format-props props)
1245 (www-xml-format-list children)
1248 name (www-xml-format-props props)))
1251 (format "%s" format-unit)))))
1253 (defun www-xml-format-list (format-list)
1254 (if (atom format-list)
1255 (www-xml-format-unit format-list)
1256 (mapconcat #'www-xml-format-unit
1260 ;;; @ HTML generator
1263 (defun www-html-display-text (text)
1267 (goto-char (point-min))
1268 (while (search-forward "<" nil t)
1269 (replace-match "<" nil t))
1270 (goto-char (point-min))
1271 (while (search-forward ">" nil t)
1272 (replace-match ">" nil t))
1273 (goto-char (point-min))
1274 (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
1276 (format "<a href=\"%s\">%s</a>"
1280 (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
1281 (goto-char (point-min))
1282 (while (search-forward ">-" nil t)
1283 (replace-match "&GT-" nil t))
1286 (defun www-html-display-paragraph (text)
1288 (www-html-display-text text)
1295 (defvar coded-charset-GlyphWiki-id-alist
1296 '((=ucs "u" 4 x nil)
1297 (=ucs@JP "u" 4 x nil)
1298 (=ucs@jis "u" 4 x nil)
1299 (=ucs@gb "u" 4 x "-g")
1300 (=ucs@cns "u" 4 x "-t")
1301 (=ucs@ks "u" 4 x "-k")
1302 (=ucs@iso "u" 4 x "-u")
1303 (=ucs@unicode "u" 4 x "-us")
1304 (=adobe-japan1-6 "aj1-" 5 d nil)
1306 (=big5-cdp "cdp-" 4 x nil)
1307 (=cbeta "cb" 5 d nil)
1308 (=jis-x0208@1978/1pr "j78-" 4 x nil)
1309 (=jis-x0208@1978/-4pr "j78-" 4 x nil)
1310 (=jis-x0208@1978 "j78-" 4 x nil)
1311 (=jis-x0208@1983 "j83-" 4 x nil)
1312 (=jis-x0208@1990 "j90-" 4 x nil)
1313 (=jis-x0212 "jsp-" 4 x nil)
1314 (=jis-x0213-1@2000 "jx1-2000-" 4 x nil)
1315 (=jis-x0213-1@2004 "jx1-2004-" 4 x nil)
1316 (=jis-x0213-2 "jx2-" 4 x nil)
1317 (=cns11643-1 "c1-" 4 x nil)
1318 (=cns11643-2 "c2-" 4 x nil)
1319 (=cns11643-3 "c3-" 4 x nil)
1320 (=cns11643-4 "c4-" 4 x nil)
1321 (=cns11643-5 "c5-" 4 x nil)
1322 (=cns11643-6 "c6-" 4 x nil)
1323 (=cns11643-7 "c7-" 4 x nil)
1324 (=daikanwa "dkw-" 5 d nil)
1325 (=gt-k "gt-k" 5 d nil)
1326 (=jef-china3 "jc3-" 4 x nil)
1327 (=big5 "b-" 4 x nil)
1328 (=ks-x1001 "k0-" 4 x nil)
1331 (defun char-GlyphWiki-id (char)
1332 (let ((rest coded-charset-GlyphWiki-id-alist)
1335 (setq spec (pop rest))
1336 (null (setq ret (char-feature char (car spec))))))
1339 (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
1341 ((and (or (encode-char char '=jis-x0208@1990)
1342 (encode-char char '=jis-x0212)
1343 (encode-char char '=jis-x0213-1))
1344 (setq code (encode-char char '=ucs@jis)))
1345 (format "u%04x" code)
1347 ((and (or (encode-char char '=gb2312)
1348 (encode-char char '=gb12345))
1349 (setq code (encode-char char '=ucs@gb)))
1350 (format "u%04x-g" code)
1352 ((and (or (encode-char char '=cns11643-1)
1353 (encode-char char '=cns11643-2)
1354 (encode-char char '=cns11643-3)
1355 (encode-char char '=cns11643-4)
1356 (encode-char char '=cns11643-5)
1357 (encode-char char '=cns11643-6)
1358 (encode-char char '=cns11643-7))
1359 (setq code (encode-char char '=ucs@cns)))
1360 (format "u%04x-t" code)
1362 ((and (encode-char char '=ks-x1001)
1363 (setq code (encode-char char '=ucs@ks)))
1364 (format "u%04x-k" code)
1366 (format (format "%s%%0%d%s%s"
1370 (or (nth 4 spec) ""))
1377 (provide 'cwiki-common)
1379 ;;; cwiki-common.el ends here