cwiki-common.el

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