update.
[chise/est.git] / cwiki-common.el
1 ;; -*- coding: utf-8-mcs-er -*-
2 (require 'char-db-util)
3 (require 'chiset-common)
4 ;; (require 'concord-images)
5
6 (setq file-name-coding-system 'utf-8-mcs-er)
7
8 (concord-assign-genre 'code-point "/usr/local/var/chise-ipld/db")
9 (concord-assign-genre 'coded-character "/usr/local/var/chise-ipld/db")
10 (concord-assign-genre 'glyph "/usr/local/var/chise-ipld/db")
11
12 (concord-assign-genre 'image-resource "/usr/local/var/photo/db")
13 (concord-assign-genre 'glyph-image "/usr/local/var/photo/db")
14
15 (concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db")
16 (concord-assign-genre 'person-name@ruimoku "/usr/local/var/ruimoku/db")
17
18 (concord-assign-genre 'journal-volume@ruimoku "/usr/local/var/ruimoku/db")
19 (concord-assign-genre 'article@ruimoku "/usr/local/var/ruimoku/db")
20 (concord-assign-genre 'book@ruimoku "/usr/local/var/ruimoku/db")
21
22 (concord-assign-genre 'classification@ruimoku "/usr/local/var/ruimoku/db")
23 (concord-assign-genre 'region@ruimoku "/usr/local/var/ruimoku/db")
24 (concord-assign-genre 'era@ruimoku "/usr/local/var/ruimoku/db")
25 (concord-assign-genre 'period@ruimoku "/usr/local/var/ruimoku/db")
26 (concord-assign-genre 'journal@ruimoku "/usr/local/var/ruimoku/db")
27 (concord-assign-genre 'journal-name@ruimoku "/usr/local/var/ruimoku/db")
28 (concord-assign-genre 'publisher@ruimoku "/usr/local/var/ruimoku/db")
29 (concord-assign-genre 'publisher-name@ruimoku "/usr/local/var/ruimoku/db")
30
31 (mount-char-attribute-table '*instance@ruimoku/bibliography/title)
32 ;; (mount-char-attribute-table '*instance@ruimoku/bibliography/content*note)
33
34 (concord-assign-genre 'entry@zh-classical "/usr/local/var/kanbun/db")
35 ;; (concord-assign-genre 'morpheme-entry@zh-classical "/usr/local/var/kanbun/db")
36 (concord-assign-genre 'word-class@zh-classical "/usr/local/var/kanbun/db")
37 (concord-assign-genre 'morpheme@zh-classical "/usr/local/var/kanbun/db")
38 (concord-assign-genre 'sentence@zh-classical "/usr/local/var/kanbun/db")
39 ;; (concord-assign-genre 'sentence-entry@zh-classical "/usr/local/var/kanbun/db")
40
41 (mount-char-attribute-table '*instance@morpheme-entry/zh-classical)
42
43 (concord-assign-genre 'ud@zh-classical "/usr/local/var/kanbun/db")
44
45
46 (concord-assign-genre 'hng-card "/usr/local/var/hng-card/db")
47
48 (mount-char-attribute-table '->HNG)
49 (mount-char-attribute-table '<-HNG)
50 (mount-char-attribute-table '->HNG@CN/manuscript)
51 (mount-char-attribute-table '<-HNG@CN/manuscript)
52 (mount-char-attribute-table '->HNG@CN/printed)
53 (mount-char-attribute-table '<-HNG@CN/printed)
54 (mount-char-attribute-table '->HNG@JP/manuscript)
55 (mount-char-attribute-table '<-HNG@JP/manuscript)
56 (mount-char-attribute-table '->HNG@JP/printed)
57 (mount-char-attribute-table '<-HNG@JP/printed)
58 (mount-char-attribute-table '->HNG@KR)
59 (mount-char-attribute-table '<-HNG@KR)
60 (mount-char-attribute-table '->HNG@MISC)
61 (mount-char-attribute-table '<-HNG@MISC)
62
63
64 (defvar est-hide-cgi-mode nil)
65 (defvar est-view-url-prefix "..")
66 (defvar chise-wiki-view-url "view.cgi")
67 (defvar chise-wiki-edit-url "edit.cgi")
68
69 (defvar chise-wiki-bitmap-glyphs-url
70   "http://www.chise.org/glyphs")
71
72 (defvar chise-wiki-hng-bitmap-glyphs-url
73   "http://hng.chise.org/glyphs/HNG")
74
75 (defvar chise-wiki-daijiten-bitmap-glyphs-url
76   "http://hng.chise.org/glyphs/daijiten")
77
78 (defvar chise-wiki-glyph-cgi-url
79   "http://www.chise.org/chisewiki/glyph.cgi")
80
81 (defvar chise-wiki-displayed-features nil)
82
83 (defvar est-coded-charset-priority-list
84   '(; =ucs
85     =cns11643-1 =cns11643-2 =cns11643-3
86     =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
87     =gb2312 =gb12345
88     =jis-x0208 =jis-x0208@1990
89     =jis-x0213-2
90     =jis-x0212
91     =adobe-japan1
92     =cbeta =jef-china3
93     =jis-x0213-1@2000 =jis-x0213-1@2004
94     =jis-x0208@1983 =jis-x0208@1978
95     =zinbun-oracle =>zinbun-oracle
96     =daikanwa
97     =gt =gt-k
98     =>>>adobe-japan1
99     =>>>jis-x0208 =>>>jis-x0213-1 =>>>jis-x0213-2
100     =>>jis-x0208 =>>jis-x0213-1 =>>jis-x0213-2
101     =>>adobe-japan1
102     =+>jis-x0208 =+>jis-x0213-1 =+>jis-x0213-2
103     =+>jis-x0208@1978
104     =+>adobe-japan1
105     =>jis-x0208 =>jis-x0213-1
106     =>>gt
107     =>ucs@iso =>ucs@unicode
108     =>ucs@jis =>ucs@cns =>ucs@ks
109     =+>ucs@iso =+>ucs@unicode
110     =>>ucs@iso =>>ucs@unicode
111     =>>ucs@jis =>>ucs@cns =>>ucs@ks
112     =>>>ucs@iso =>>>ucs@unicode
113     =>>>ucs@jis =>>>ucs@cns =>>>ucs@ks
114     ===ucs@iso
115     =ruimoku-v6
116     =big5
117     =big5-cdp
118     =>cbeta
119     =mj
120     ==mj
121     ===mj
122     =ucs-itaiji-001
123     =ucs-itaiji-002
124     =ucs-itaiji-003
125     =ucs-itaiji-004
126     =ucs-itaiji-005
127     =ucs-itaiji-006
128     =ucs-itaiji-007
129     =ucs-itaiji-008
130     =ucs-itaiji-009
131     =ucs-itaiji-010
132     =ucs-itaiji-011
133     =ucs-itaiji-084
134     =ucs-var-001
135     =ucs-var-002
136     =ucs-var-003
137     =ucs-var-004
138     =ucs@unicode
139     ==ucs@unicode
140     ===ucs@unicode
141     ==>daijiten
142     ==>ucs@bucs
143     ===daikanwa/+p
144     ===gt
145     =>ucs@iwds-1
146     =>ucs@component
147     =>ucs-itaiji-001
148     =>ucs-itaiji-002
149     =>ucs-itaiji-003
150     =>ucs-itaiji-004
151     =>ucs-itaiji-005
152     =>ucs-itaiji-006
153     =>ucs-itaiji-007
154     ===adobe-japan1
155     ===cns11643-1 ===cns11643-2 ===cns11643-3
156     ===cns11643-4 ===cns11643-5 ===cns11643-6 ===cns11643-7
157     ))
158
159 (defun decode-uri-string (string &optional coding-system)
160   (if (> (length string) 0)
161       (let ((i 0)
162             dest)
163         (setq string
164               (mapconcat (lambda (char)
165                            (if (eq char ?+)
166                                " "
167                              (char-to-string char)))
168                          string ""))
169         (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
170           (setq dest (concat dest
171                              (substring string i (match-beginning 0))
172                              (char-to-string
173                               (int-char
174                                (string-to-int (match-string 1 string) 16))))
175                 i (match-end 0)))
176         (decode-coding-string
177          (concat dest (substring string i))
178          coding-system))))
179
180 (defun www-feature-type (feature-name)
181   (or (char-feature-property feature-name 'type)
182       (let ((str (symbol-name feature-name)))
183         (cond
184          ((string-match "\\*note\\(@[^*]+\\)?$" str)
185           'stext)
186          ((string-match "\\*sources\\(@[^*]+\\)?$" str)
187           'domain-list)
188          ((string-match "\\*" str)
189           nil)
190          ((string-match "^\\(->\\|<-\\)" str)
191           'relation)
192          ((string-match "^ideographic-structure\\(@\\|$\\)" str)
193           'structure)
194          ))))
195
196 (defun www-feature-format (feature-name)
197   (or (char-feature-property feature-name 'presentation-format)
198       (char-feature-property feature-name 'format)
199       (let (fn parent ret)
200         (setq fn feature-name)
201         (while (and (setq parent (char-feature-name-parent fn))
202                     (null (setq ret
203                                 (char-feature-property
204                                  parent 'format))))
205           (setq fn parent))
206         ret)
207       '((name) " : " (value))))
208
209 (defun www-feature-value-format (feature-name)
210   (or (char-feature-property feature-name 'value-presentation-format)
211       (char-feature-property feature-name 'value-format)
212       (let (fn parent ret)
213         (setq fn feature-name)
214         (while (and (setq parent (char-feature-name-parent fn))
215                     (null (setq ret
216                                 (or (char-feature-property
217                                      parent 'value-presentation-format)
218                                     (char-feature-property
219                                      parent 'value-format)))))
220           (setq fn parent))
221         ret)
222       (let ((type (www-feature-type feature-name)))
223         (cond ((eq type 'relation)
224                'space-separated)
225               ((eq type 'structure)
226                'space-separated-ids)
227               ((eq type 'stext)
228                'wiki-text)
229               ))
230       (if (find-charset feature-name)
231           (if (and (= (charset-dimension feature-name) 2)
232                    (= (charset-chars feature-name) 94))
233               '("0x" (HEX)
234                 " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
235             '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))
236       'space-separated))
237
238 (defun char-feature-name-at-domain (feature-name domain)
239   (if domain
240       (let ((name (symbol-name feature-name)))
241         (cond
242          ((string-match "@[^*]+$" name)
243           (intern (format "%s/%s" name domain))
244           )
245          (t
246           (intern (format "%s@%s" name domain))
247           )))
248     feature-name))
249
250 (defun char-feature-name-parent (feature-name)
251   (let ((name (symbol-name feature-name)))
252     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
253         (intern (substring name 0 (car (last (match-data) 2)))))))
254
255 (defun char-feature-name-domain (feature-name)
256   (let ((name (symbol-name feature-name)))
257     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
258         (intern (substring name (1+ (match-beginning 0)))))))
259
260 (defun char-feature-name-sans-versions (feature)
261   (let ((feature-name (symbol-name feature)))
262     (if (string-match "[@/]\\$rev=latest$" feature-name)
263         (intern (substring feature-name 0 (match-beginning 0)))
264       feature)))
265
266 (defun est-object-genre (object)
267   (if (characterp object)
268       'character
269     (concord-object-genre object)))
270
271 (defun www-get-feature-value (object feature)
272   (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
273     (cond
274      ((characterp object)
275       (mount-char-attribute-table latest-feature)
276       (or (char-feature object latest-feature)
277           (char-feature object feature))
278       )
279      (t
280       (or (condition-case nil
281               (concord-object-get object latest-feature)
282             (error nil))
283           (condition-case nil
284               (concord-object-get object feature)
285             (error nil)))
286       ))))
287
288 (defun get-previous-code-point (ccs code)
289   (let ((chars (charset-chars ccs))
290         (dim (charset-dimension ccs))
291         (i 0)
292         mask byte-min byte-max
293         bytes dest)
294     (cond
295      ((= chars 94)
296       (setq mask #x7F
297             byte-min 33
298             byte-max 126)
299       )
300      ((= chars 96)
301       (setq mask #x7F
302             byte-min 32
303             byte-max 127)
304       )
305      ((= chars 128)
306       (setq mask #x7F
307             byte-min 0
308             byte-max #xFF)
309       )
310      (t ; (= chars 256)
311       (setq mask #xFF
312             byte-min 0
313             byte-max #xFF)
314       ))
315     (setq bytes (make-vector dim 0))
316     (while (< i dim)
317       (aset bytes i (logand (lsh code (* i -8)) mask))
318       (setq i (1+ i)))
319     (setq i 0)
320     (while (and (< i dim)
321                 (progn
322                   (aset bytes i (1- (aref bytes i)))
323                   (< (aref bytes i) byte-min)))
324       (aset bytes i byte-max)
325       (setq i (1+ i)))
326     (when (< i dim)
327       (setq dest (aref bytes 0)
328             i 1)
329       (while (< i dim)
330         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
331               i (1+ i)))
332       dest)))
333
334 (defun get-next-code-point (ccs code)
335   (let ((chars (charset-chars ccs))
336         (dim (charset-dimension ccs))
337         (i 0)
338         mask byte-min byte-max
339         bytes dest)
340     (cond
341      ((= chars 94)
342       (setq mask #x7F
343             byte-min 33
344             byte-max 126)
345       )
346      ((= chars 96)
347       (setq mask #x7F
348             byte-min 32
349             byte-max 127)
350       )
351      ((= chars 128)
352       (setq mask #x7F
353             byte-min 0
354             byte-max #xFF)
355       )
356      (t ; (= chars 256)
357       (setq mask #xFF
358             byte-min 0
359             byte-max #xFF)
360       ))
361     (setq bytes (make-vector dim 0))
362     (while (< i dim)
363       (aset bytes i (logand (lsh code (* i -8)) mask))
364       (setq i (1+ i)))
365     (setq i 0)
366     (while (and (< i dim)
367                 (progn
368                   (aset bytes i (1+ (aref bytes i)))
369                   (> (aref bytes i) byte-max)))
370       (aset bytes i byte-min)
371       (setq i (1+ i)))
372     (when (< i dim)
373       (setq dest (aref bytes 0)
374             i 1)
375       (while (< i dim)
376         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
377               i (1+ i)))
378       dest)))
379
380 (defun find-previous-defined-code-point (ccs code)
381   (let ((i (get-previous-code-point ccs code))
382         char)
383     (cond
384      ((eq ccs '=jis-x0208)
385       (setq ccs '=jis-x0208@1990))
386      ((eq ccs '=jis-x0213-1)
387       (setq ccs '=jis-x0213-1@2004)))
388     (while (and i
389                 (>= i 0)
390                 (null (setq char (decode-char ccs i
391                                               (unless (eq ccs '=ucs)
392                                                 'defined-only)))))
393       (setq i (get-previous-code-point ccs i)))
394     char))
395
396 (defun find-next-defined-code-point (ccs code)
397   (let ((i (get-next-code-point ccs code))
398         max char)
399     (setq max (+ code 1000))
400     (cond
401      ((eq ccs '=jis-x0208)
402       (setq ccs '=jis-x0208@1990))
403      ((eq ccs '=jis-x0213-1)
404       (setq ccs '=jis-x0213-1@2004)))
405     (while (and i
406                 (<= i max)
407                 (null (setq char (decode-char ccs i
408                                               (unless (eq ccs '=ucs)
409                                                 'defined-only)))))
410       (setq i (get-next-code-point ccs i)))
411     char))
412
413
414 ;;; @ URI representation
415 ;;;
416
417 ;; (defun est-uri-decode-feature-name-body (uri-feature)
418 ;;   (let ((len (length uri-feature))
419 ;;         (i 0)
420 ;;         ch dest)
421 ;;     (while (< i len)
422 ;;       (setq dest
423 ;;             (concat
424 ;;              dest
425 ;;              (if (eq (aref uri-feature i) ?\.)
426 ;;                  (if (and (< (+ i 2) len)
427 ;;                           (eq (aref uri-feature (+ i 2)) ?\.))
428 ;;                      (prog1
429 ;;                          (cond
430 ;;                           ((eq (setq ch (aref uri-feature (1+ i))) ?\.)
431 ;;                            "/")
432 ;;                           ((eq ch ?-)
433 ;;                            "*")
434 ;;                           ((eq ch ?_)
435 ;;                            "+")
436 ;;                           (t
437 ;;                            (substring uri-feature i (+ i 3))
438 ;;                            ))
439 ;;                        (setq i (+ i 3)))
440 ;;                    (setq i (1+ i))
441 ;;                    ".")
442 ;;                (prog1
443 ;;                    (char-to-string (aref uri-feature i))
444 ;;                  (setq i (1+ i)))))))
445 ;;     dest))
446
447 ;; (defun est-uri-encode-feature-name-body (feature)
448 ;;   (mapconcat (lambda (c)
449 ;;                (cond ((eq c ?*)
450 ;;                       ".-.")
451 ;;                      ((eq c ?/)
452 ;;                       "...")
453 ;;                      ((eq c ?+)
454 ;;                       "._.")
455 ;;                      (t (char-to-string c))))
456 ;;              feature ""))
457
458 (defun www-uri-decode-feature-name (uri-feature)
459   (let (feature)
460     (setq uri-feature (decode-uri-string uri-feature 'utf-8-mcs-er))
461     (cond
462      ((string-match "^from\\." uri-feature)
463       (intern (format "<-%s"
464                       (est-uri-decode-feature-name-body
465                        (substring uri-feature (match-end 0)))))
466       )
467      ((string-match "^to\\." uri-feature)
468       (intern (format "->%s"
469                       (est-uri-decode-feature-name-body
470                        (substring uri-feature (match-end 0)))))
471       )
472      ((string-match "^rep\\." uri-feature)
473       (intern (format "=%s"
474                       (est-uri-decode-feature-name-body
475                        (substring uri-feature (match-end 0)))))
476       )
477      ((string-match "^rep[2i]\\." uri-feature)
478       (intern (format "===%s"
479                       (est-uri-decode-feature-name-body
480                        (substring uri-feature (match-end 0)))))
481       )
482      ((string-match "^g\\." uri-feature)
483       (intern (format "=>>%s"
484                       (est-uri-decode-feature-name-body
485                        (substring uri-feature (match-end 0)))))
486       )
487      ((string-match "^g[i2]\\." uri-feature)
488       (intern (format "==%s"
489                       (est-uri-decode-feature-name-body
490                        (substring uri-feature (match-end 0)))))
491       )
492      ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
493       (intern (format "=>>%s%s"
494                       (make-string (string-to-int
495                                     (match-string 1 uri-feature))
496                                    ?>)
497                       (est-uri-decode-feature-name-body
498                        (substring uri-feature (match-end 0)))))
499       )
500      ((string-match "^o\\." uri-feature)
501       (intern (format "=+>%s"
502                       (est-uri-decode-feature-name-body
503                        (substring uri-feature (match-end 0)))))
504       )
505      ((string-match "^a\\." uri-feature)
506       (intern (format "=>%s"
507                       (est-uri-decode-feature-name-body
508                        (substring uri-feature (match-end 0)))))
509       )
510      ((string-match "^a\\([0-9]+\\)\\." uri-feature)
511       (intern (format "%s>%s"
512                       (make-string (string-to-int
513                                     (match-string 1 uri-feature))
514                                    ?=)
515                       (est-uri-decode-feature-name-body
516                        (substring uri-feature (match-end 0)))))
517       )
518      ((and (setq uri-feature (est-uri-decode-feature-name-body uri-feature))
519            (setq feature (intern (format "=>%s" uri-feature)))
520            (find-charset feature))
521       feature)
522      ((and (setq feature (intern (format "=>>%s" uri-feature)))
523            (find-charset feature))
524       feature)
525      ((and (setq feature (intern (format "=>>>%s" uri-feature)))
526            (find-charset feature))
527       feature)
528      ((and (setq feature (intern (format "=%s" uri-feature)))
529            (find-charset feature))
530       feature)
531      (t (intern uri-feature)))))
532
533 (defun www-uri-encode-feature-name (feature-name)
534   (setq feature-name (symbol-name feature-name))
535   (cond
536    ((string-match "^=\\+>\\([^=>]+\\)" feature-name)
537     (concat "o."
538             (est-uri-encode-feature-name-body
539              (substring feature-name (match-beginning 1))))
540     )
541    ((string-match "^=\\([^=>]+\\)" feature-name)
542     (concat "rep."
543             (est-uri-encode-feature-name-body
544              (substring feature-name (match-beginning 1))))
545     )
546    ((string-match "^==\\([^=>]+\\)" feature-name)
547     (concat "g2."
548             (est-uri-encode-feature-name-body
549              (substring feature-name (match-beginning 1))))
550     )
551    ((string-match "^===\\([^=>]+\\)" feature-name)
552     (concat "repi."
553             (est-uri-encode-feature-name-body
554              (substring feature-name (match-beginning 1))))
555     )
556    ((string-match "^=>>\\([^=>]+\\)" feature-name)
557     (concat "g."
558             (est-uri-encode-feature-name-body
559              (substring feature-name (match-beginning 1))))
560     )
561    ((string-match "^=>>>\\([^=>]+\\)" feature-name)
562     (concat "gi."
563             (est-uri-encode-feature-name-body
564              (substring feature-name (match-beginning 1))))
565     )
566    ((string-match "^=>>\\(>+\\)" feature-name)
567     (format "gi%d.%s"
568             (length (match-string 1 feature-name))
569             (est-uri-encode-feature-name-body
570              (substring feature-name (match-end 1))))
571     )
572    ((string-match "^=>\\([^=>]+\\)" feature-name)
573     (concat "a."
574             (est-uri-encode-feature-name-body
575              (substring feature-name (match-beginning 1))))
576     )
577    ((string-match "^\\(=+\\)>" feature-name)
578     (format "a%d.%s"
579             (length (match-string 1 feature-name))
580             (est-uri-encode-feature-name-body
581              (substring feature-name (match-end 0))))
582     )
583    ((string-match "^->" feature-name)
584     (concat "to."
585             (est-uri-encode-feature-name-body
586              (substring feature-name (match-end 0))))
587     )
588    ((string-match "^<-" feature-name)
589     (concat "from."
590             (est-uri-encode-feature-name-body
591              (substring feature-name (match-end 0))))
592     )
593    (t (est-uri-encode-feature-name-body feature-name))))
594
595 (defun www-uri-make-feature-name-url (uri-genre uri-feature-name uri-object)
596   (if est-hide-cgi-mode
597       (format "../feature/%s&%s/%s"
598               uri-feature-name uri-genre uri-object)
599     (format "%s?feature=%s&%s=%s"
600             chise-wiki-view-url uri-feature-name uri-genre uri-object)))
601
602 (defun www-uri-decode-object (genre char-rep)
603   (let (ccs cpos)
604     (cond
605      ((string-match (if est-hide-cgi-mode
606                         "\\(%3D\\|=\\|%3A\\|:\\)"
607                       "\\(%3A\\|:\\)") char-rep)
608       (setq ccs (substring char-rep 0 (match-beginning 0))
609             cpos (substring char-rep (match-end 0)))
610       (setq ccs (www-uri-decode-feature-name ccs))
611       (setq cpos (est-uri-decode-feature-name-body cpos))
612       (cond
613        ((string-match "^0x" cpos)
614         (setq cpos
615               (string-to-number (substring cpos (match-end 0)) 16))
616         )
617        (t
618         (setq cpos (car (read-from-string
619                          (decode-uri-string
620                           cpos file-name-coding-system))))
621         ))
622       (if (and (eq genre 'character)
623                (numberp cpos))
624           (decode-char ccs cpos)
625         (concord-decode-object ccs cpos genre))
626       )
627      (t
628       (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
629       (cond
630        ((eq genre 'character)
631         (when (= (length char-rep) 1)
632           (aref char-rep 0))
633         )
634        ((eq genre 'feature)
635         (concord-decode-object
636          '=id (www-uri-decode-feature-name char-rep) 'feature)
637         )
638        (t
639         (concord-decode-object
640          '=id (car (read-from-string char-rep)) genre)
641         ))))))
642
643 (defun www-uri-encode-object (object)
644   (if (characterp object)
645       (if (encode-char object '=ucs)
646           (mapconcat
647            (lambda (byte)
648              (format "%%%02X" byte))
649            (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
650            "")
651         (let ((ccs-list est-coded-charset-priority-list)
652               ccs ret)
653           (while (and ccs-list
654                       (setq ccs (pop ccs-list))
655                       (not (setq ret (encode-char object ccs 'defined-only)))))
656           (cond (ret
657                  (format (if est-hide-cgi-mode
658                              "%s=0x%X"
659                            "%s:0x%X")
660                          (www-uri-encode-feature-name ccs)
661                          ret))
662                 ((and (setq ccs (car (split-char object)))
663                       (setq ret (encode-char object ccs)))
664                  (format (if est-hide-cgi-mode
665                              "%s=0x%X"
666                            "%s:0x%X")
667                          (www-uri-encode-feature-name ccs)
668                          ret))
669                 (t
670                  (format (if est-hide-cgi-mode
671                              "system-char-id=0x%X"
672                            "system-char-id:0x%X")
673                          (encode-char object 'system-char-id))
674                  ))))
675     (format (if est-hide-cgi-mode
676                 "rep.id=%s"
677               "rep.id:%s")
678             (est-uri-encode-feature-name-body
679              (format "%s" (concord-object-id object))))))
680
681 (defun est-format-object (object &optional readable)
682   (if (characterp object)
683       (char-to-string object)
684     (let ((ret (or (if readable
685                        (or (concord-object-get object 'name)
686                            (concord-object-get object '=name)
687                            (concord-object-get object 'title)))
688                    (concord-object-id object))))
689       (format "%s" ret))))
690
691 (defun www-uri-make-object-url (object &optional uri-object)
692   (if est-hide-cgi-mode
693       (format "%s/%s/%s"
694               est-view-url-prefix
695               (est-object-genre object)
696               (or uri-object
697                   (www-uri-encode-object object)))
698     (format "%s?%s=%s"
699             chise-wiki-view-url
700             (est-object-genre object)
701             (or uri-object
702                 (www-uri-encode-object object)))))
703
704
705 ;;; @ Feature name presentation
706 ;;;
707
708 (defun www-format-feature-name-default (feature-name)
709   (mapconcat
710    #'capitalize
711    (split-string
712     (symbol-name feature-name)
713     "-")
714    " "))
715
716 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
717   (let ((str (symbol-name feature-name))
718         base meta)
719     (cond
720      ((string-match "\\*[^*]+$" str)
721       (setq base (substring str 0 (match-beginning 0))
722             meta (substring str (match-beginning 0)))
723       (concat (www-format-feature-name* (intern base) lang)
724               meta))
725      (t
726       (www-format-feature-name-default feature-name)
727       ))))
728
729 (defun www-format-feature-name-as-rel-to (feature-name)
730   (concat "\u2192" (substring (symbol-name feature-name) 2)))
731
732 (defun www-format-feature-name-as-rel-from (feature-name)
733   (concat "\u2190" (substring (symbol-name feature-name) 2)))
734
735 (defun www-format-feature-name-as-CCS (feature-name)
736   (let* ((rest
737           (split-string
738            (symbol-name feature-name)
739            "-"))
740          (dest (upcase (pop rest))))
741     (when (string-match "^=+>*" dest)
742       (setq dest (concat (substring dest 0 (match-end 0))
743                          " "
744                          (substring dest (match-end 0)))))
745     (cond
746      (rest
747       (while (cdr rest)
748         (setq dest (concat dest " " (upcase (pop rest)))))
749       (if (string-match "^[0-9]+$" (car rest))
750           (concat dest "-" (car rest))
751         (concat dest " " (upcase (car rest))))
752       )
753      (t dest))))
754
755 (defun www-format-feature-name* (feature-name &optional lang)
756   (let (name fn parent ret)
757     (cond
758      ((or (and lang
759                (char-feature-property
760                 feature-name
761                 (intern (format "name@%s" lang))))
762           (char-feature-property
763            feature-name 'name)))
764      ((and (setq name (symbol-name feature-name))
765            (string-match "\\*" name))
766       (www-format-feature-name-as-metadata feature-name lang))
767      (t
768       (setq fn feature-name)
769       (while (and (setq parent (char-feature-name-parent fn))
770                   (null (setq ret
771                               (or (and lang
772                                        (char-feature-property
773                                         parent
774                                         (intern (format "name@%s" lang))))
775                                   (char-feature-property
776                                    parent 'name)))))
777         (setq fn parent))
778       (cond
779        (ret
780         (concat ret (substring (symbol-name feature-name)
781                                (length (symbol-name parent)))))
782        ((find-charset feature-name)
783         (www-format-feature-name-as-CCS feature-name))
784        ((string-match "^\\(->\\)" name)
785         (www-format-feature-name-as-rel-to feature-name))
786        ((string-match "^\\(<-\\)" name)
787         (www-format-feature-name-as-rel-from feature-name))
788        (t
789         (www-format-feature-name-default feature-name)
790         ))
791       ))))
792
793 (defun www-format-feature-name (feature-name &optional lang)
794   (www-format-encode-string
795    (www-format-feature-name* feature-name lang)))
796
797
798 ;;; @ HTML generator
799 ;;;
800
801 (defvar www-format-char-img-style "vertical-align:bottom;")
802
803 (defun www-format-encode-string (string &optional without-tags as-body)
804   (with-temp-buffer
805     (insert string)
806     (let (plane code subcode start end char variants ret rret)
807       (when as-body
808         (goto-char (point-min))
809         (while (search-forward "&" nil t)
810           (replace-match "&amp;" nil t)))
811       (goto-char (point-min))
812       (while (search-forward "<" nil t)
813         (replace-match "&lt;" nil t))
814       (goto-char (point-min))
815       (while (search-forward ">" nil t)
816         (replace-match "&gt;" nil t))
817       (if without-tags
818           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
819         (let ((coded-charset-entity-reference-alist
820                (list*
821                 '(=gt                   "GT-" 5 d)
822                 '(=mj                    "MJ" 6 d)
823                 '(=hanyo-denshi/ja   "HD-JA-" 4 X)
824                 '(=hanyo-denshi/jb   "HD-JB-" 4 X)
825                 '(=hanyo-denshi/jc   "HD-JC-" 4 X)
826                 '(=hanyo-denshi/jd   "HD-JD-" 4 X)
827                 '(=hanyo-denshi/ft   "HD-FT-" 4 X)
828                 '(=hanyo-denshi/ia   "HD-IA-" 4 X)
829                 '(=hanyo-denshi/ib   "HD-IB-" 4 X)
830                 '(=hanyo-denshi/hg   "HD-HG-" 4 X)
831                 '(=hanyo-denshi/ip   "HD-IP-" 4 X)
832                 '(=hanyo-denshi/jt   "HD-JT-" 4 X)
833                 '(=hanyo-denshi/ks   "HD-KS-" 6 d)
834                 '(=>>hanyo-denshi/ja "G-HD-JA-" 4 X)
835                 '(=>>hanyo-denshi/jb "G-HD-JB-" 4 X)
836                 '(=>>hanyo-denshi/jc "G-HD-JC-" 4 X)
837                 '(=>>hanyo-denshi/jd "G-HD-JD-" 4 X)
838                 '(=>>hanyo-denshi/ft "G-HD-FT-" 4 X)
839                 '(=>>hanyo-denshi/ia "G-HD-IA-" 4 X)
840                 '(=>>hanyo-denshi/ib "G-HD-IB-" 4 X)
841                 '(=>>hanyo-denshi/hg "G-HD-HG-" 4 X)
842                 '(=>>hanyo-denshi/ip "G-HD-IP-" 4 X)
843                 '(=>>hanyo-denshi/jt "G-HD-JT-" 4 X)
844                 '(=>>hanyo-denshi/ks "G-HD-KS-" 6 d)
845                 '(==mj                  "g2-MJ" 6 d)
846                 '(==hanyo-denshi/ja "g2-HD-JA-" 4 X)
847                 '(==hanyo-denshi/jb "g2-HD-JB-" 4 X)
848                 '(==hanyo-denshi/jc "g2-HD-JC-" 4 X)
849                 '(==hanyo-denshi/jd "g2-HD-JD-" 4 X)
850                 '(==hanyo-denshi/ft "g2-HD-FT-" 4 X)
851                 '(==hanyo-denshi/ia "g2-HD-IA-" 4 X)
852                 '(==hanyo-denshi/ib "g2-HD-IB-" 4 X)
853                 '(==hanyo-denshi/hg "g2-HD-HG-" 4 X)
854                 '(==hanyo-denshi/ip "g2-HD-IP-" 4 X)
855                 '(==hanyo-denshi/jt "g2-HD-JT-" 4 X)
856                 '(==hanyo-denshi/ks "g2-HD-KS-" 6 d)
857                 '(==daijiten          "g2-DJT-" 5 d)
858                 '(=cns11643-1           "C1-" 4 X)
859                 '(=cns11643-2           "C2-" 4 X)
860                 '(=cns11643-3           "C3-" 4 X)
861                 '(=cns11643-4           "C4-" 4 X)
862                 '(=cns11643-5           "C5-" 4 X)
863                 '(=cns11643-6           "C6-" 4 X)
864                 '(=cns11643-7           "C7-" 4 X)
865                 '(=adobe-japan1-6       "AJ1-" 5 d)
866                 '(=big5-cdp             "CDP-" 4 X)
867                 '(=>big5-cdp          "A-CDP-" 4 X)
868                 '(=gb2312               "G0-" 4 X)
869                 '(=gb12345              "G1-" 4 X)
870                 '(=jis-x0208@1990       "J90-" 4 X)
871                 '(=jis-x0212            "JSP-" 4 X)
872                 '(=cbeta                "CB" 5 d)
873                 '(=jis-x0208@1997       "J97-" 4 X)
874                 '(=jis-x0208@1978       "J78-" 4 X)
875                 '(=jis-x0208@1983       "J83-" 4 X)
876                 '(=ruimoku-v6           "RUI6-" 4 X)
877                 '(=zinbun-oracle        "ZOB-" 4 d)
878                 '(=daijiten             "DJT-" 5 d)
879                 '(=jef-china3           "JC3-" 4 X)
880                 '(=ucs@unicode          "UU+" 4 X)
881                 '(=ucs@JP/hanazono  "hanaJU+" 4 X)
882                 '(==cns11643-1        "R-C1-" 4 X)
883                 '(==cns11643-2        "R-C2-" 4 X)
884                 '(==cns11643-3        "R-C3-" 4 X)
885                 '(==cns11643-4        "R-C4-" 4 X)
886                 '(==cns11643-5        "R-C5-" 4 X)
887                 '(==cns11643-6        "R-C6-" 4 X)
888                 '(==cns11643-7        "R-C7-" 4 X)
889                 '(=hanziku-1         "HZK01-" 4 X)
890                 '(=hanziku-2         "HZK02-" 4 X)
891                 '(=hanziku-3         "HZK03-" 4 X)
892                 '(=hanziku-4         "HZK04-" 4 X)
893                 '(=hanziku-5         "HZK05-" 4 X)
894                 '(=hanziku-6         "HZK06-" 4 X)
895                 '(=hanziku-7         "HZK07-" 4 X)
896                 '(=hanziku-8         "HZK08-" 4 X)
897                 '(=hanziku-9         "HZK09-" 4 X)
898                 '(=hanziku-10        "HZK10-" 4 X)
899                 '(=hanziku-11        "HZK11-" 4 X)
900                 '(=hanziku-12        "HZK12-" 4 X)
901                 '(==>daijiten       "A2-DJT-" 5 d)
902                 '(==cbeta               "CB" 5 d)
903                 '(=big5                  "B-" 4 X)
904                 '(=daikanwa              "M-" 5 d)
905                 coded-charset-entity-reference-alist)))
906           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
907
908           (goto-char (point-min))
909           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?CB\\([0-9]+\\);" nil t)
910             (setq code (string-to-int (match-string 2)))
911             (replace-match
912              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\"
913 style=\"%s\">"
914                      code
915                      chise-wiki-bitmap-glyphs-url
916                      (/ code 1000) code
917                      www-format-char-img-style)
918              t 'literal))
919
920           (goto-char (point-min))
921           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
922             (setq plane (match-string 2)
923                   code (string-to-int (match-string 3) 16))
924             (replace-match
925              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\"
926 style=\"%s\">"
927                      plane code
928                      chise-wiki-bitmap-glyphs-url
929                      plane
930                      (- (lsh code -8) 32)
931                      (- (logand code 255) 32)
932                      www-format-char-img-style)
933              t 'literal))
934
935           (goto-char (point-min))
936           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J0-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
937             (setq code (string-to-int (match-string 2) 16))
938             (replace-match
939              (format "<img alt=\"J0-%04X\" src=\"%s/JIS-90/%02d-%02d.gif\"
940 style=\"%s\">"
941                      code
942                      chise-wiki-bitmap-glyphs-url
943                      (- (lsh code -8) 32)
944                      (- (logand code 255) 32)
945                      www-format-char-img-style)
946              t 'literal))
947
948           (goto-char (point-min))
949           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-\\(JA\\|JB\\|JC\\|JD\\|FT\\|IA\\|IB\\|HG\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
950             (setq plane (match-string 2)
951                   code (string-to-int (match-string 3) 16))
952             (replace-match
953              (format "<img alt=\"HD-%s-%04X\" src=\"%s/IVD/HanyoDenshi/%s%02d%02d.png\"
954 style=\"%s\">"
955                      plane code
956                      chise-wiki-bitmap-glyphs-url
957                      plane
958                      (- (lsh code -8) 32)
959                      (- (logand code 255) 32)
960                      www-format-char-img-style)
961              t 'literal))
962
963           (goto-char (point-min))
964           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-\\(IP\\|JT\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
965             (setq plane (match-string 2)
966                   code (string-to-int (match-string 3) 16))
967             (replace-match
968              (format "<img alt=\"HD-%s-%04X\" src=\"%s/IVD/HanyoDenshi/%s%04X.png\"
969 style=\"%s\">"
970                      plane code
971                      chise-wiki-bitmap-glyphs-url
972                      plane code
973                      www-format-char-img-style)
974              t 'literal))
975
976           (goto-char (point-min))
977           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-KS-\\([0-9]+\\);" nil t)
978             (setq code (string-to-int (match-string 2)))
979             (replace-match
980              (format "<img alt=\"HD-KS%06d\" src=\"%s/IVD/HanyoDenshi/KS%06d.png\"
981 style=\"vertical-align:middle\">"
982                      code
983                      chise-wiki-bitmap-glyphs-url
984                      code
985                      www-format-char-img-style)
986              t 'literal))
987
988           (goto-char (point-min))
989           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
990             (setq plane (string-to-int (match-string 1))
991                   code (string-to-int (match-string 2) 16))
992             (replace-match
993              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\"
994 style=\"%s\">"
995                      plane code
996                      chise-wiki-bitmap-glyphs-url
997                      plane
998                      (- (lsh code -8) 32)
999                      (- (logand code 255) 32)
1000                      www-format-char-img-style)
1001              t 'literal))
1002
1003           (goto-char (point-min))
1004           (while (re-search-forward "&\\(R-\\)?C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
1005             (setq plane (string-to-int (match-string 2))
1006                   code (string-to-int (match-string 3) 16))
1007             (replace-match
1008              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\"
1009 style=\"%s\">"
1010                      plane code
1011                      chise-wiki-bitmap-glyphs-url
1012                      plane code
1013                      www-format-char-img-style)
1014              t 'literal))
1015
1016           (goto-char (point-min))
1017           (while (re-search-forward "&\\(R-\\)?JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
1018             (setq code (string-to-int (match-string 2) 16))
1019             (replace-match
1020              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
1021                      code code)
1022              t 'literal))
1023
1024           (goto-char (point-min))
1025           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
1026             (setq code (string-to-int (match-string 2)))
1027             (replace-match
1028              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\"
1029 style=\"vertical-align:middle\">"
1030                      code
1031                      chise-wiki-bitmap-glyphs-url
1032                      code
1033                      www-format-char-img-style)
1034              t 'literal))
1035
1036           (goto-char (point-min))
1037           (while (re-search-forward "&\\(A2-\\|g2-\\|R-\\)?DJT-\\([0-9]+\\);" nil t)
1038             (setq code (string-to-int (match-string 2)))
1039             (replace-match
1040              (format "<img alt=\"DJT-%05d\" src=\"%s/%05d.png\"
1041 style=\"vertical-align:middle; width: auto; max-height: 60px\">"
1042                      code
1043                      chise-wiki-daijiten-bitmap-glyphs-url
1044                      code
1045                      www-format-char-img-style)
1046              t 'literal))
1047
1048           (goto-char (point-min))
1049           (while (re-search-forward "&SW-JIGUGE\\([45]?\\)-\\([0-9]+\\);" nil t)
1050             (setq subcode (match-string 1)
1051                   code (string-to-int (match-string 2)))
1052             (setq plane
1053                   (if (string= subcode "")
1054                       "5"
1055                     subcode))
1056             (replace-match
1057              (format "<div class=\"tooltip\"><img alt=\"SW-JIGUGE%s-%05d\" src=\"%s/ShuoWen/Jiguge%s/%05d.png\"
1058 style=\"vertical-align:middle; width: auto; max-height: 80px\"><span
1059 class=\"tooltiptext\">%s</span></div>"
1060                      plane code
1061                      chise-wiki-bitmap-glyphs-url
1062                      plane code
1063                      (charset-description
1064                       (if (string= subcode "")
1065                           '=shuowen-jiguge
1066                         (intern (format "===shuowen-jiguge%s" subcode)))))
1067              t 'literal))
1068
1069           (goto-char (point-min))
1070           (while (re-search-forward "&HNG\\([0-9]+\\)-\\([0-9][0-9][0-9][0-9]\\)\\([0-9]\\);" nil t)
1071             (setq plane (match-string 1)
1072                   code (string-to-int (match-string 2))
1073                   subcode (string-to-int (match-string 3)))
1074             (setq subcode
1075                   (if (eq subcode 0)
1076                       ""
1077                     (char-to-string (decode-char 'ascii (+ 96 subcode)))))
1078             (replace-match
1079              (format
1080               "<div class=\"tooltip\"><img alt=\"HNG%s-%04d%s\" src=\"%s/%s/%04d%s.png\" style=\"
1081 vertical-align:middle; width: auto; max-height: 60px\"><span
1082 class=\"tooltiptext\">%s</span></div>"
1083               plane code subcode
1084               chise-wiki-hng-bitmap-glyphs-url
1085               plane code subcode
1086               (charset-description
1087                (car (find (format "HNG%s-" plane)
1088                           coded-charset-entity-reference-alist
1089                           :test (lambda (key cell)
1090                                   (string= key (nth 1 cell))))))
1091               )
1092              t 'literal))
1093
1094           (goto-char (point-min))
1095           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?AJ1-\\([0-9]+\\);" nil t)
1096             (setq code (string-to-int (match-string 2)))
1097             (replace-match
1098              (format "<img alt=\"AJ1-%05d\" src=\"%s/IVD/AdobeJapan1/CID+%d.png\"
1099 style=\"vertical-align:middle\">"
1100                      code
1101                      chise-wiki-bitmap-glyphs-url
1102                      code
1103                      www-format-char-img-style)
1104              t 'literal))
1105
1106           (goto-char (point-min))
1107           (while (re-search-forward "&\\(A-\\|o-\\|G-\\|g2-\\|R-\\)?MJ\\([0-9]+\\);" nil t)
1108             (setq code (string-to-int (match-string 2)))
1109             (replace-match
1110              (format "<img alt=\"MJ%06d\" src=\"http://mojikiban.ipa.go.jp/MJ%06d.png\"
1111 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1112                      code
1113                      code
1114                      www-format-char-img-style)
1115              t 'literal))
1116
1117           (goto-char (point-min))
1118           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\)?IU[+-]\\([0-9A-F]+\\);" nil t)
1119             (setq code (string-to-int (match-string 2) 16))
1120             (replace-match
1121              (format "<img alt=\"u%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1122 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1123                      code
1124                      code
1125                      www-format-char-img-style)
1126              t 'literal))
1127
1128           (goto-char (point-min))
1129           (while (re-search-forward "&A-\\(comp\\|cgn\\)U[+-]\\([0-9A-F]+\\);" nil t)
1130             (setq code (string-to-int (match-string 2) 16))
1131             (replace-match
1132              (format "<img alt=\"u%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1133 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1134                      code
1135                      code
1136                      www-format-char-img-style)
1137              t 'literal))
1138
1139           (goto-char (point-min))
1140           (while (re-search-forward
1141                   "&\\(A-\\|g2-\\)?U-i\\([0-9]+\\)\\+\\([0-9A-F]+\\);"
1142                   nil t)
1143             (setq plane (string-to-int (match-string 2))
1144                   code (string-to-int (match-string 3) 16))
1145             (replace-match
1146              (format "<img alt=\"u%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/u%04x-itaiji-%03d.100px.png\"
1147 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1148                      code
1149                      plane
1150                      code
1151                      plane
1152                      www-format-char-img-style)
1153              t 'literal))
1154
1155           (goto-char (point-min))
1156           (while (re-search-forward "&A-IWDSU\\+\\([0-9A-F]+\\);" nil t)
1157             (setq code (string-to-int (match-string 1) 16))
1158             (replace-match
1159              (format "<img alt=\"A-IWDSU+%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1160 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1161                      code
1162                      code
1163                      www-format-char-img-style)
1164              t 'literal))
1165
1166           (goto-char (point-min))
1167           (while (re-search-forward
1168                   "&\\(A-\\)?CDP-i\\([0-9]+\\)-\\([0-9A-F]+\\);"
1169                   nil t)
1170             (setq plane (string-to-int (match-string 2))
1171                   code (string-to-int (match-string 3) 16))
1172             (replace-match
1173              (format "<img alt=\"cdp-%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/cdp-%04x-itaiji-%03d.100px.png\"
1174 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1175                      code
1176                      plane
1177                      code
1178                      plane
1179                      www-format-char-img-style)
1180              t 'literal))
1181
1182           (goto-char (point-min))
1183           (while (re-search-forward "&\\(g2-\\)?U-v\\([0-9]+\\)\\+\\([0-9A-F]+\\);" nil t)
1184             (setq plane (string-to-int (match-string 2))
1185                   code (string-to-int (match-string 3) 16))
1186             (replace-match
1187              (format "<img alt=\"u%04x-var-%03d\" src=\"http://glyphwiki.org/glyph/u%04x-var-%03d.100px.png\"
1188 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1189                      code
1190                      plane
1191                      code
1192                      plane
1193                      www-format-char-img-style)
1194              t 'literal))
1195
1196           (goto-char (point-min))
1197           (while (re-search-forward "&\\(A-\\|G-\\|R-\\|g2-\\)?GT-\\([0-9]+\\);" nil t)
1198             (setq code (string-to-int (match-string 2)))
1199             (replace-match
1200              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\"
1201 style=\"%s\">"
1202                      code
1203                      chise-wiki-glyph-cgi-url
1204                      code
1205                      www-format-char-img-style)
1206              t 'literal))
1207
1208           (goto-char (point-min))
1209           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\)?GT-K\\([0-9]+\\);" nil t)
1210             (setq code (string-to-int (match-string 2)))
1211             (replace-match
1212              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\"
1213 style=\"%s\">"
1214                      code
1215                      chise-wiki-glyph-cgi-url
1216                      code
1217                      www-format-char-img-style)
1218              t 'literal))
1219
1220           (goto-char (point-min))
1221           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
1222             (setq code (string-to-int (match-string 1) 16))
1223             (replace-match
1224              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\"
1225 style=\"%s\">"
1226                      code
1227                      chise-wiki-glyph-cgi-url
1228                      code
1229                      www-format-char-img-style)
1230              t 'literal))
1231
1232           (goto-char (point-min))
1233           (while (re-search-forward
1234                   "&\\(A-\\|G-\\|g2-\\|R-\\)?CDP-\\([0-9A-F]+\\);" nil t)
1235             (setq code (string-to-int (match-string 2) 16))
1236             (replace-match
1237              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\"
1238 style=\"%s\">"
1239                      code
1240                      chise-wiki-glyph-cgi-url
1241                      code
1242                      www-format-char-img-style)
1243              t 'literal))
1244
1245           (goto-char (point-min))
1246           (while (re-search-forward
1247                   "&\\(I-\\)?HZK\\(0[1-9]\\|1[0-2]\\)-\\([0-9A-F]+\\);" nil t)
1248             (setq plane (match-string 2)
1249                   code (string-to-int (match-string 3) 16))
1250             (replace-match
1251              (format "<img alt=\"HZK%s-%04X\" src=\"%s?char=HZK%s-%04X\"
1252 style=\"%s\">"
1253                      plane
1254                      code
1255                      chise-wiki-glyph-cgi-url
1256                      plane
1257                      code
1258                      www-format-char-img-style)
1259              t 'literal))
1260
1261           (goto-char (point-min))
1262           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?RUI6-\\([0-9A-F]+\\);" nil t)
1263             (setq code (string-to-int (match-string 2) 16))
1264             (replace-match
1265              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\"
1266 style=\"vertical-align:middle\">"
1267                      code
1268                      chise-wiki-glyph-cgi-url
1269                      code
1270                      www-format-char-img-style)
1271              t 'literal))
1272
1273           (goto-char (point-min))
1274           (while (re-search-forward "&hanaJU\\+\\([0-9A-F]+\\);" nil t)
1275             (setq code (string-to-int (match-string 1) 16))
1276             (replace-match
1277              (format "<img alt=\"hanaJU+%04X\" src=\"%s?char=hana-JU+%04X\"
1278 style=\"vertical-align:middle\">"
1279                      code
1280                      chise-wiki-glyph-cgi-url
1281                      code
1282                      www-format-char-img-style)
1283              t 'literal))
1284
1285           (goto-char (point-min))
1286           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
1287             (setq code (string-to-int (match-string 3) 16))
1288             (replace-match
1289              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\"
1290 style=\"vertical-align:middle\">"
1291                      code
1292                      code
1293                      www-format-char-img-style)
1294              t 'literal))
1295
1296           (goto-char (point-min))
1297           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
1298             (setq code (string-to-int (match-string 1) 16))
1299             (setq start (match-beginning 0)
1300                   end (match-end 0))
1301             (setq char (decode-char 'system-char-id code))
1302             (cond
1303              ((and (setq variants
1304                          (or (www-get-feature-value char '->subsumptive)
1305                              (www-get-feature-value char '->denotational)))
1306                    (progn
1307                      (if (characterp variants)
1308                          (setq variants (list variants)))
1309                      (while (and variants
1310                                  (setq ret (www-format-encode-string
1311                                             (char-to-string (car variants))))
1312                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
1313                        (setq variants (cdr variants)))
1314                      ret))
1315               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
1316                 (goto-char start)
1317                 (delete-region start end)
1318                 (insert ret))
1319               )
1320              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
1321                             (www-get-feature-value char 'ideographic-structure)))
1322               (setq ret
1323                     (mapconcat
1324                      (lambda (ch)
1325                        (if (listp ch)
1326                            (if (characterp (setq rret (find-char ch)))
1327                                (setq ch rret)))
1328                        (if (characterp ch)
1329                            (www-format-encode-string
1330                             (char-to-string ch) without-tags)
1331                          (www-format-encode-string
1332                           (format "%S" ch) without-tags)))
1333                      ret ""))
1334               (when ret
1335                 (goto-char start)
1336                 (delete-region start end)
1337                 (insert ret))
1338               )))
1339           ))
1340       ;; (goto-char (point-min))
1341       ;; (while (search-forward "&GT-" nil t)
1342       ;;   (replace-match "&amp;GT-" t 'literal))
1343       (buffer-string))))
1344
1345 (defun www-html-display-text (text)
1346   (princ
1347    (with-temp-buffer
1348      (insert text)
1349      (goto-char (point-min))
1350      (while (search-forward "<" nil t)
1351        (replace-match "&lt;" nil t))
1352      (goto-char (point-min))
1353      (while (search-forward ">" nil t)
1354        (replace-match "&gt;" nil t))
1355      (goto-char (point-min))
1356      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
1357        (replace-match
1358         (format "<a href=\"%s\">%s</a>"
1359                 (match-string 2)
1360                 (match-string 1))
1361         nil t))
1362      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
1363      (goto-char (point-min))
1364      (while (search-forward "&GT-" nil t)
1365        (replace-match "&amp;GT-" nil t))
1366      (buffer-string))))
1367
1368 (defun www-html-display-paragraph (text)
1369   (princ "<p>")
1370   (www-html-display-text text)
1371   (princ "</p>\n"))
1372
1373
1374 ;;; @ for GlyphWiki
1375 ;;;
1376
1377 (defvar coded-charset-GlyphWiki-id-alist
1378   '((===adobe-japan1-0  "aj1-"  5 d nil)
1379     (===adobe-japan1-1  "aj1-"  5 d nil)
1380     (===adobe-japan1-2  "aj1-"  5 d nil)
1381     (===adobe-japan1-3  "aj1-"  5 d nil)
1382     (===adobe-japan1-4  "aj1-"  5 d nil)
1383     (===adobe-japan1-5  "aj1-"  5 d nil)
1384     (===adobe-japan1-6  "aj1-"  5 d nil)
1385     (===ucs@jis         "u"     4 x nil)
1386     (===daikanwa        "dkw-"  5 d nil)
1387     (===ucs@ks          "u"     4 x "-k")
1388     (==ucs-itaiji-005   "u"     4 x "-itaiji-005")
1389     (=ucs-var-001       "u"     4 x "-var-001")
1390     (=ucs-var-002       "u"     4 x "-var-002")
1391     (=ucs-var-003       "u"     4 x "-var-003")
1392     (=ucs-var-004       "u"     4 x "-var-004")
1393     (=ucs-itaiji-001    "u"     4 x "-itaiji-001")
1394     (=ucs-itaiji-002    "u"     4 x "-itaiji-002")
1395     (=ucs-itaiji-003    "u"     4 x "-itaiji-003")
1396     (=ucs-itaiji-084    "u"     4 x "-itaiji-084")
1397     (=>ucs-itaiji-001   "u"     4 x "-itaiji-001")
1398     (=>ucs-itaiji-006   "u"     4 x "-itaiji-006")
1399     (==adobe-japan1-0   "aj1-"  5 d nil)
1400     (==adobe-japan1-1   "aj1-"  5 d nil)
1401     (==adobe-japan1-2   "aj1-"  5 d nil)
1402     (==adobe-japan1-3   "aj1-"  5 d nil)
1403     (==adobe-japan1-4   "aj1-"  5 d nil)
1404     (==adobe-japan1-5   "aj1-"  5 d nil)
1405     (==adobe-japan1-6   "aj1-"  5 d nil)
1406     (==ucs@jis          "u"     4 x nil)
1407     (==ucs@iso          "u"     4 x nil)
1408     (==ucs@cns          "u"     4 x "-t")
1409     (==ucs@unicode      "u"     4 x "-us")
1410     (==daikanwa         "dkw-"  5 d nil)
1411     (==ucs@ks           "u"     4 x "-k")
1412     (==jis-x0208@1978   "j78-"  4 x nil)
1413     (==jis-x0208        "j90-"  4 x nil)
1414     (==jis-x0208@1990   "j90-"  4 x nil)
1415     (==jis-x0208@1983   "j83-"  4 x nil)
1416     (==cbeta           "cbeta-" 5 d nil)
1417     (=>>hanyo-denshi/ks "koseki-" 6 d nil)
1418     (=>>jis-x0208@1978  "j78-"  4 x nil)
1419     (=>>big5-cdp        "cdp-"  4 x nil)
1420     (=>>adobe-japan1-0  "aj1-"  5 d nil)
1421     (=>>adobe-japan1-1  "aj1-"  5 d nil)
1422     (=>>adobe-japan1-2  "aj1-"  5 d nil)
1423     (=>>adobe-japan1-3  "aj1-"  5 d nil)
1424     (=>>adobe-japan1-4  "aj1-"  5 d nil)
1425     (=>>adobe-japan1-5  "aj1-"  5 d nil)
1426     (=>>adobe-japan1-6  "aj1-"  5 d nil)
1427     (=>>jis-x0208       "j90-"  4 x nil)
1428     (=>>jis-x0208@1990  "j90-"  4 x nil)
1429     (=>>jis-x0208@1983  "j83-"  4 x nil)
1430     (=>>daikanwa        "dkw-"  5 d nil)
1431     (=adobe-japan1-0    "aj1-"  5 d nil)
1432     (=adobe-japan1-1    "aj1-"  5 d nil)
1433     (=adobe-japan1-2    "aj1-"  5 d nil)
1434     (=adobe-japan1-3    "aj1-"  5 d nil)
1435     (=adobe-japan1-4    "aj1-"  5 d nil)
1436     (=adobe-japan1-5    "aj1-"  5 d nil)
1437     (=adobe-japan1-6    "aj1-"  5 d nil)
1438     (=decomposition@cid)
1439     (=decomposition@hanyo-denshi)
1440     (=hanyo-denshi/ks   "koseki-" 6 d nil)
1441     (=koseki            "koseki-" 6 d nil)
1442     (=ucs@jis           "u"     4 x nil)
1443     (=ucs@cns           "u"     4 x "-t")
1444     (=ucs@ks            "u"     4 x "-k")
1445     (=ucs@JP            "u"     4 x nil)
1446     (=ucs@gb            "u"     4 x "-g")
1447     (=ucs@iso           "u"     4 x "-u")
1448     (=ucs@unicode       "u"     4 x "-us")
1449     (=big5-cdp          "cdp-"  4 x nil)
1450     (=>big5-cdp         "cdp-"  4 x nil)
1451     (=cbeta            "cbeta-" 5 d nil)
1452     (=big5-cdp-var-3    "cdp-"  4 x "-var-3")
1453     (=big5-cdp-var-5    "cdp-"  4 x "-var-5")
1454     (=big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001")
1455     (=big5-cdp-itaiji-002 "cdp-" 4 x "-itaiji-002")
1456     (=>big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001")
1457     (=jef-china3        "jc3-"  4 x nil)
1458     (=jis-x0212         "jsp-"  4 x nil)
1459     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
1460     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
1461     (=jis-x0213-2       "jx2-"  4 x nil)
1462     (=gt-k              "gt-k"  5 d nil)
1463     (=jis-x0208@1978/1pr "j78-" 4 x nil)
1464     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
1465     (=jis-x0208@1978    "j78-"  4 x nil)
1466     (=+>jis-x0208@1978  "j78-"  4 x nil)
1467     (=+>jis-x0208       "j90-"  4 x nil)
1468     (=+>jis-x0208@1990  "j90-"  4 x nil)
1469     (=+>jis-x0208@1983  "j83-"  4 x nil)
1470     (=ucs               "u"     4 x nil)
1471     (=big5              "b-"    4 x nil)
1472     (=daikanwa          "dkw-"  5 d nil)
1473     (=gt                "gt-"   5 d nil)
1474     (=ruimoku-v6        "rui6-" 4 x nil)
1475     (=>ruimoku-v6       "rui6-" 4 x nil)
1476     (=ks-x1001          "k0-"   4 x nil)
1477     (=cns11643-1        "c1-"   4 x nil)
1478     (=cns11643-2        "c2-"   4 x nil)
1479     (=cns11643-3        "c3-"   4 x nil)
1480     (=cns11643-4        "c4-"   4 x nil)
1481     (=cns11643-5        "c5-"   4 x nil)
1482     (=cns11643-6        "c6-"   4 x nil)
1483     (=cns11643-7        "c7-"   4 x nil)
1484     (=jis-x0208         "j90-"  4 x nil)
1485     (=jis-x0208@1990    "j90-"  4 x nil)
1486     (=jis-x0208@1983    "j83-"  4 x nil)
1487     ))
1488
1489 (defun char-GlyphWiki-id (char)
1490   (let ((rest coded-charset-GlyphWiki-id-alist)
1491         spec ret code)
1492     (while (and rest
1493                 (setq spec (pop rest))
1494                 (null (setq ret (get-char-attribute char (car spec))))))
1495     (when ret
1496       (or
1497        (and (listp ret)
1498             (mapconcat #'char-GlyphWiki-id ret "-"))
1499        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
1500             (cond
1501              ((and (or (encode-char char '=jis-x0208@1990)
1502                        (encode-char char '=jis-x0212)
1503                        (encode-char char '=jis-x0213-1)
1504                        (encode-char char '=jis-x0213-2))
1505                    (setq code (encode-char char '=ucs@jis)))
1506               (format "u%04x" code)
1507               )
1508              ((and (or (encode-char char '=gb2312)
1509                        (encode-char char '=gb12345))
1510                    (setq code (encode-char char '=ucs@gb)))
1511               (format "u%04x-g" code)
1512               )
1513              ((and (or (encode-char char '=cns11643-1)
1514                        (encode-char char '=cns11643-2)
1515                        (encode-char char '=cns11643-3)
1516                        (encode-char char '=cns11643-4)
1517                        (encode-char char '=cns11643-5)
1518                        (encode-char char '=cns11643-6)
1519                        (encode-char char '=cns11643-7))
1520                    (setq code (encode-char char '=ucs@cns)))
1521               (format "u%04x-t" code)
1522               )
1523              ((and (encode-char char '=ks-x1001)
1524                    (setq code (encode-char char '=ucs@ks)))
1525               (format "u%04x-k" code)
1526               )))
1527        (format (format "%s%%0%d%s%s"
1528                        (nth 1 spec)
1529                        (nth 2 spec)
1530                        (nth 3 spec)
1531                        (or (nth 4 spec) ""))
1532                ret)))))
1533
1534
1535 ;;; @ End.
1536 ;;;
1537
1538 (provide 'cwiki-common)
1539
1540 ;;; cwiki-common.el ends here