cwiki-common.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'char-db-util)
   3
   4 (setq file-name-coding-system 'utf-8-mcs-er)
   5
   6
   7 (concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db")
   8 (concord-assign-genre 'person-name@ruimoku "/usr/local/var/ruimoku/db")
   9
  10 (concord-assign-genre 'journal-volume@ruimoku "/usr/local/var/ruimoku/db")
  11 (concord-assign-genre 'article@ruimoku "/usr/local/var/ruimoku/db")
  12 (concord-assign-genre 'book@ruimoku "/usr/local/var/ruimoku/db")
  13
  14 (concord-assign-genre 'classification@ruimoku "/usr/local/var/ruimoku/db")
  15 (concord-assign-genre 'region@ruimoku "/usr/local/var/ruimoku/db")
  16 (concord-assign-genre 'era@ruimoku "/usr/local/var/ruimoku/db")
  17 (concord-assign-genre 'period@ruimoku "/usr/local/var/ruimoku/db")
  18 (concord-assign-genre 'journal@ruimoku "/usr/local/var/ruimoku/db")
  19
  20 (mount-char-attribute-table 'instance@ruimoku/bibliography/title)
  21 ;; (mount-char-attribute-table 'instance@ruimoku/bibliography/content*note)
  22
  23
  24 (defvar chise-wiki-view-url "view.cgi")
  25 (defvar chise-wiki-edit-url "edit.cgi")
  26
  27 (defvar chise-wiki-bitmap-glyphs-url
  28   "http://www.chise.org/glyphs")
  29
  30 (defvar chise-wiki-glyph-cgi-url
  31   "http://www.chise.org/chisewiki/glyph.cgi")
  32
  33 (defvar chise-wiki-displayed-features nil)
  34
  35 (defun decode-uri-string (string &optional coding-system)
  36   (if (> (length string) 0)
  37       (let ((i 0)
  38             dest)
  39         (setq string
  40               (mapconcat (lambda (char)
  41                            (if (eq char ?+)
  42                                " "
  43                              (char-to-string char)))
  44                          string ""))
  45         (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
  46           (setq dest (concat dest
  47                              (substring string i (match-beginning 0))
  48                              (char-to-string
  49                               (int-char
  50                                (string-to-int (match-string 1 string) 16))))
  51                 i (match-end 0)))
  52         (decode-coding-string
  53          (concat dest (substring string i))
  54          coding-system))))
  55
  56 (defun www-feature-type (feature-name)
  57   (or (char-feature-property feature-name 'type)
  58       (let ((str (symbol-name feature-name)))
  59         (cond
  60          ((string-match "\\*note\\(@[^*]+\\)?$" str)
  61           'stext)
  62          ((string-match "\\*sources\\(@[^*]+\\)?$" str)
  63           'domain-list)
  64          ((string-match "\\*" str)
  65           nil)
  66          ((string-match "^\\(->\\|<-\\)" str)
  67           'relation)
  68          ((string-match "^ideographic-structure\\(@\\|$\\)" str)
  69           'structure)
  70          ))))
  71
  72 (defun www-feature-format (feature-name)
  73   (or (char-feature-property feature-name 'format)
  74       (let (fn parent ret)
  75         (setq fn feature-name)
  76         (while (and (setq parent (char-feature-name-parent fn))
  77                     (null (setq ret
  78                                 (char-feature-property
  79                                  parent 'format))))
  80           (setq fn parent))
  81         ret)
  82       '((name) " : " (value))))
  83
  84 (defun www-feature-value-format (feature-name)
  85   (or (char-feature-property feature-name 'value-format)
  86       (let (fn parent ret)
  87         (setq fn feature-name)
  88         (while (and (setq parent (char-feature-name-parent fn))
  89                     (null (setq ret
  90                                 (char-feature-property
  91                                  parent 'value-format))))
  92           (setq fn parent))
  93         ret)
  94       (let ((type (www-feature-type feature-name)))
  95         (cond ((eq type 'relation)
  96                'space-separated-char-list)
  97               ((eq type 'structure)
  98                'space-separated-ids)
  99               ((eq type 'stext)
 100                'wiki-text)
 101               ))
 102       (if (find-charset feature-name)
 103           (if (and (= (charset-dimension feature-name) 2)
 104                    (= (charset-chars feature-name) 94))
 105               '("0x" (HEX)
 106                 " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
 107             '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))))
 108
 109 (defun char-feature-name-at-domain (feature-name domain)
 110   (if domain
 111       (let ((name (symbol-name feature-name)))
 112         (cond
 113          ((string-match "@[^*]+$" name)
 114           (intern (format "%s/%s" name domain))
 115           )
 116          (t
 117           (intern (format "%s@%s" name domain))
 118           )))
 119     feature-name))
 120
 121 (defun char-feature-name-parent (feature-name)
 122   (let ((name (symbol-name feature-name)))
 123     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 124         (intern (substring name 0 (car (last (match-data) 2)))))))
 125
 126 (defun char-feature-name-domain (feature-name)
 127   (let ((name (symbol-name feature-name)))
 128     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 129         (intern (substring name (1+ (match-beginning 0)))))))
 130
 131 (defun char-feature-name-sans-versions (feature)
 132   (let ((feature-name (symbol-name feature)))
 133     (if (string-match "[@/]\\$rev=latest$" feature-name)
 134         (intern (substring feature-name 0 (match-beginning 0)))
 135       feature)))
 136
 137 (defun est-object-genre (object)
 138   (if (characterp object)
 139       'character
 140     (concord-object-genre object)))
 141
 142 (defun www-get-feature-value (object feature)
 143   (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
 144     (cond
 145      ((characterp object)
 146       (mount-char-attribute-table latest-feature)
 147       (or (char-feature object latest-feature)
 148           (char-feature object feature))
 149       )
 150      (t
 151       (or (condition-case nil
 152               (concord-object-get object latest-feature)
 153             (error nil))
 154           (condition-case nil
 155               (concord-object-get object feature)
 156             (error nil)))
 157       ))))
 158
 159 (defun get-previous-code-point (ccs code)
 160   (let ((chars (charset-chars ccs))
 161         (dim (charset-dimension ccs))
 162         (i 0)
 163         mask byte-min byte-max
 164         bytes dest)
 165     (cond
 166      ((= chars 94)
 167       (setq mask #x7F
 168             byte-min 33
 169             byte-max 126)
 170       )
 171      ((= chars 96)
 172       (setq mask #x7F
 173             byte-min 32
 174             byte-max 127)
 175       )
 176      ((= chars 128)
 177       (setq mask #x7F
 178             byte-min 0
 179             byte-max #xFF)
 180       )
 181      (t ; (= chars 256)
 182       (setq mask #xFF
 183             byte-min 0
 184             byte-max #xFF)
 185       ))
 186     (setq bytes (make-vector dim 0))
 187     (while (< i dim)
 188       (aset bytes i (logand (lsh code (* i -8)) mask))
 189       (setq i (1+ i)))
 190     (setq i 0)
 191     (while (and (< i dim)
 192                 (progn
 193                   (aset bytes i (1- (aref bytes i)))
 194                   (< (aref bytes i) byte-min)))
 195       (aset bytes i byte-max)
 196       (setq i (1+ i)))
 197     (when (< i dim)
 198       (setq dest (aref bytes 0)
 199             i 1)
 200       (while (< i dim)
 201         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 202               i (1+ i)))
 203       dest)))
 204
 205 (defun get-next-code-point (ccs code)
 206   (let ((chars (charset-chars ccs))
 207         (dim (charset-dimension ccs))
 208         (i 0)
 209         mask byte-min byte-max
 210         bytes dest)
 211     (cond
 212      ((= chars 94)
 213       (setq mask #x7F
 214             byte-min 33
 215             byte-max 126)
 216       )
 217      ((= chars 96)
 218       (setq mask #x7F
 219             byte-min 32
 220             byte-max 127)
 221       )
 222      ((= chars 128)
 223       (setq mask #x7F
 224             byte-min 0
 225             byte-max #xFF)
 226       )
 227      (t ; (= chars 256)
 228       (setq mask #xFF
 229             byte-min 0
 230             byte-max #xFF)
 231       ))
 232     (setq bytes (make-vector dim 0))
 233     (while (< i dim)
 234       (aset bytes i (logand (lsh code (* i -8)) mask))
 235       (setq i (1+ i)))
 236     (setq i 0)
 237     (while (and (< i dim)
 238                 (progn
 239                   (aset bytes i (1+ (aref bytes i)))
 240                   (> (aref bytes i) byte-max)))
 241       (aset bytes i byte-min)
 242       (setq i (1+ i)))
 243     (when (< i dim)
 244       (setq dest (aref bytes 0)
 245             i 1)
 246       (while (< i dim)
 247         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 248               i (1+ i)))
 249       dest)))
 250
 251 (defun find-previous-defined-code-point (ccs code)
 252   (let ((i (get-previous-code-point ccs code))
 253         char)
 254     (cond
 255      ((eq ccs '=jis-x0208)
 256       (setq ccs '=jis-x0208@1990))
 257      ((eq ccs '=jis-x0213-1)
 258       (setq ccs '=jis-x0213-1@2004)))
 259     (while (and i
 260                 (>= i 0)
 261                 (null (setq char (decode-char ccs i
 262                                               (unless (eq ccs '=ucs)
 263                                                 'defined-only)))))
 264       (setq i (get-previous-code-point ccs i)))
 265     char))
 266
 267 (defun find-next-defined-code-point (ccs code)
 268   (let ((i (get-next-code-point ccs code))
 269         max char)
 270     (setq max (+ code 1000))
 271     (cond
 272      ((eq ccs '=jis-x0208)
 273       (setq ccs '=jis-x0208@1990))
 274      ((eq ccs '=jis-x0213-1)
 275       (setq ccs '=jis-x0213-1@2004)))
 276     (while (and i
 277                 (<= i max)
 278                 (null (setq char (decode-char ccs i
 279                                               (unless (eq ccs '=ucs)
 280                                                 'defined-only)))))
 281       (setq i (get-next-code-point ccs i)))
 282     char))
 283
 284
 285 ;;; @ URI representation
 286 ;;;
 287
 288 (defun www-uri-decode-feature-name (uri-feature)
 289   (let (feature)
 290     (setq uri-feature (decode-uri-string uri-feature 'utf-8-mcs-er))
 291     (cond
 292      ((string-match "^from\\." uri-feature)
 293       (intern (format "<-%s" (substring uri-feature (match-end 0))))
 294       )
 295      ((string-match "^to\\." uri-feature)
 296       (intern (format "->%s" (substring uri-feature (match-end 0))))
 297       )
 298      ((string-match "^rep\\." uri-feature)
 299       (intern (format "=%s" (substring uri-feature (match-end 0))))
 300       )
 301      ((string-match "^g\\." uri-feature)
 302       (intern (format "=>>%s" (substring uri-feature (match-end 0))))
 303       )
 304      ((string-match "^gi\\." uri-feature)
 305       (intern (format "=>>>%s" (substring uri-feature (match-end 0))))
 306       )
 307      ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
 308       (intern (format "=>>%s%s"
 309                       (make-string (string-to-int
 310                                     (match-string 1 uri-feature))
 311                                    ?>)
 312                       (substring uri-feature (match-end 0))))
 313       )
 314      ((string-match "^o\\." uri-feature)
 315       (intern (format "=+>%s" (substring uri-feature (match-end 0))))
 316       )
 317      ((string-match "^a\\." uri-feature)
 318       (intern (format "=>%s" (substring uri-feature (match-end 0))))
 319       )
 320      ((string-match "^a\\([0-9]+\\)\\." uri-feature)
 321       (intern (format "%s>%s"
 322                       (make-string (string-to-int
 323                                     (match-string 1 uri-feature))
 324                                    ?=)
 325                       (substring uri-feature (match-end 0))))
 326       )
 327      ((and (setq feature (intern (format "=>%s" uri-feature)))
 328            (find-charset feature))
 329       feature)
 330      ((and (setq feature (intern (format "=>>%s" uri-feature)))
 331            (find-charset feature))
 332       feature)
 333      ((and (setq feature (intern (format "=>>>%s" uri-feature)))
 334            (find-charset feature))
 335       feature)
 336      ((and (setq feature (intern (format "=%s" uri-feature)))
 337            (find-charset feature))
 338       feature)
 339      (t (intern uri-feature)))))
 340
 341 (defun www-uri-encode-feature-name (feature-name)
 342   (setq feature-name (symbol-name feature-name))
 343   (cond
 344    ((string-match "^=\\+>\\([^=>]+\\)" feature-name)
 345     (concat "o." (substring feature-name (match-beginning 1)))
 346     )
 347    ((string-match "^=\\([^=>]+\\)" feature-name)
 348     (concat "rep." (substring feature-name (match-beginning 1)))
 349     )
 350    ((string-match "^=>>\\([^=>]+\\)" feature-name)
 351     (concat "g." (substring feature-name (match-beginning 1)))
 352     )
 353    ((string-match "^=>>>\\([^=>]+\\)" feature-name)
 354     (concat "gi." (substring feature-name (match-beginning 1)))
 355     )
 356    ((string-match "^=>>\\(>+\\)" feature-name)
 357     (format "gi%d.%s"
 358             (length (match-string 1 feature-name))
 359             (substring feature-name (match-end 1)))
 360     )
 361    ((string-match "^=>\\([^=>]+\\)" feature-name)
 362     (concat "a." (substring feature-name (match-beginning 1)))
 363     )
 364    ((string-match "^\\(=+\\)>" feature-name)
 365     (format "a%d.%s"
 366             (length (match-string 1 feature-name))
 367             (substring feature-name (match-end 0)))
 368     )
 369    ((string-match "^->" feature-name)
 370     (concat "to." (substring feature-name (match-end 0)))
 371     )
 372    ((string-match "^<-" feature-name)
 373     (concat "from." (substring feature-name (match-end 0)))
 374     )
 375    (t feature-name)))
 376
 377 (defun www-uri-make-feature-name-url (uri-genre uri-feature-name uri-object)
 378   (format "%s?feature=%s&%s=%s"
 379           chise-wiki-view-url uri-feature-name uri-genre uri-object))
 380
 381 (defun www-uri-decode-object (genre char-rep)
 382   (let (ccs cpos)
 383     (cond
 384      ((string-match "\\(%3A\\|:\\)" char-rep)
 385       (setq ccs (substring char-rep 0 (match-beginning 0))
 386             cpos (substring char-rep (match-end 0)))
 387       (setq ccs (www-uri-decode-feature-name ccs))
 388       (cond
 389        ((string-match "^0x" cpos)
 390         (setq cpos
 391               (string-to-number (substring cpos (match-end 0)) 16))
 392         )
 393        (t
 394         (setq cpos (car (read-from-string cpos)))
 395         ))
 396       (if (and (eq genre 'character)
 397                (numberp cpos))
 398           (decode-char ccs cpos)
 399         (concord-decode-object ccs cpos genre))
 400       )
 401      (t
 402       (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
 403       (cond
 404        ((eq genre 'character)
 405         (when (= (length char-rep) 1)
 406           (aref char-rep 0))
 407         )
 408        ((eq genre 'feature)
 409         (concord-decode-object
 410          '=id (www-uri-decode-feature-name char-rep) 'feature)
 411         )
 412        (t
 413         (concord-decode-object
 414          '=id (car (read-from-string char-rep)) genre)
 415         ))))))
 416
 417 (defun www-uri-encode-object (object)
 418   (if (characterp object)
 419       (if (encode-char object '=ucs)
 420           (mapconcat
 421            (lambda (byte)
 422              (format "%%%02X" byte))
 423            (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
 424            "")
 425         (let ((ccs-list '(; =ucs
 426                           =cns11643-1 =cns11643-2 =cns11643-3
 427                           =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
 428                           =gb2312 =gb12345
 429                           =jis-x0208 =jis-x0208@1990
 430                           =jis-x0212
 431                           =cbeta =jef-china3
 432                           =jis-x0213-1@2000 =jis-x0213-1@2004
 433                           =jis-x0208@1983 =jis-x0208@1978
 434                           =zinbun-oracle =>zinbun-oracle
 435                           =daikanwa
 436                           =gt =gt-k
 437                           =>>jis-x0208 =>>jis-x0213-1
 438                           =+>jis-x0208@1978
 439                           =>jis-x0208 =>jis-x0213-1
 440                           =>>gt
 441                           =>ucs@iso =>ucs@unicode
 442                           =>ucs@jis =>ucs@cns =>ucs@ks
 443                           =ruimoku-v6
 444                           =big5
 445                           =big5-cdp))
 446               ccs ret)
 447           (while (and ccs-list
 448                       (setq ccs (pop ccs-list))
 449                       (not (setq ret (encode-char object ccs 'defined-only)))))
 450           (cond (ret
 451                  (format "%s:0x%X"
 452                          (www-uri-encode-feature-name ccs)
 453                          ret))
 454                 ((and (setq ccs (car (split-char object)))
 455                       (setq ret (encode-char object ccs)))
 456                  (format "%s:0x%X"
 457                          (www-uri-encode-feature-name ccs)
 458                          ret))
 459                 (t
 460                  (format "system-char-id:0x%X"
 461                          (encode-char object 'system-char-id))
 462                  ))))
 463     (format "rep.id:%s" (concord-object-id object))))
 464
 465 (defun est-format-object (object)
 466   (if (characterp object)
 467       (char-to-string object)
 468     (format "%s" (concord-object-id object))))
 469
 470 (defun www-uri-make-object-url (object &optional uri-object)
 471   (format "%s?%s=%s"
 472           chise-wiki-view-url
 473           (est-object-genre object)
 474           (or uri-object
 475               (www-uri-encode-object object))))
 476
 477
 478 ;;; @ Feature name presentation
 479 ;;;
 480
 481 (defun www-format-feature-name-default (feature-name)
 482   (mapconcat
 483    #'capitalize
 484    (split-string
 485     (symbol-name feature-name)
 486     "-")
 487    " "))
 488
 489 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
 490   (let ((str (symbol-name feature-name))
 491         base meta)
 492     (cond
 493      ((string-match "\\*[^*]+$" str)
 494       (setq base (substring str 0 (match-beginning 0))
 495             meta (substring str (match-beginning 0)))
 496       (concat (www-format-feature-name* (intern base) lang)
 497               meta))
 498      (t
 499       (www-format-feature-name-default feature-name)
 500       ))))
 501
 502 (defun www-format-feature-name-as-rel-to (feature-name)
 503   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 504
 505 (defun www-format-feature-name-as-rel-from (feature-name)
 506   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 507
 508 (defun www-format-feature-name-as-CCS (feature-name)
 509   (let* ((rest
 510           (split-string
 511            (symbol-name feature-name)
 512            "-"))
 513          (dest (upcase (pop rest))))
 514     (when (string-match "^=+>*" dest)
 515       (setq dest (concat (substring dest 0 (match-end 0))
 516                          " "
 517                          (substring dest (match-end 0)))))
 518     (cond
 519      (rest
 520       (while (cdr rest)
 521         (setq dest (concat dest " " (upcase (pop rest)))))
 522       (if (string-match "^[0-9]+$" (car rest))
 523           (concat dest "-" (car rest))
 524         (concat dest " " (upcase (car rest))))
 525       )
 526      (t dest))))
 527
 528 (defun www-format-feature-name* (feature-name &optional lang)
 529   (let (name fn parent ret)
 530     (cond
 531      ((or (and lang
 532                (char-feature-property
 533                 feature-name
 534                 (intern (format "name@%s" lang))))
 535           (char-feature-property
 536            feature-name 'name)))
 537      ((and (setq name (symbol-name feature-name))
 538            (string-match "\\*" name))
 539       (www-format-feature-name-as-metadata feature-name lang))
 540      (t
 541       (setq fn feature-name)
 542       (while (and (setq parent (char-feature-name-parent fn))
 543                   (null (setq ret
 544                               (or (and lang
 545                                        (char-feature-property
 546                                         parent
 547                                         (intern (format "name@%s" lang))))
 548                                   (char-feature-property
 549                                    parent 'name)))))
 550         (setq fn parent))
 551       (cond
 552        (ret
 553         (concat ret (substring (symbol-name feature-name)
 554                                (length (symbol-name parent)))))
 555        ((find-charset feature-name)
 556         (www-format-feature-name-as-CCS feature-name))
 557        ((string-match "^\\(->\\)" name)
 558         (www-format-feature-name-as-rel-to feature-name))
 559        ((string-match "^\\(<-\\)" name)
 560         (www-format-feature-name-as-rel-from feature-name))
 561        (t
 562         (www-format-feature-name-default feature-name)
 563         ))
 564       ))))
 565
 566 (defun www-format-feature-name (feature-name &optional lang)
 567   (www-format-encode-string
 568    (www-format-feature-name* feature-name lang)))
 569
 570
 571 ;;; @ HTML generator
 572 ;;;
 573
 574 (defvar www-format-char-img-style "vertical-align:bottom;")
 575
 576 (defun www-format-encode-string (string &optional without-tags as-body)
 577   (with-temp-buffer
 578     (insert string)
 579     (let (plane code start end char variants ret rret)
 580       (when as-body
 581         (goto-char (point-min))
 582         (while (search-forward "&" nil t)
 583           (replace-match "&amp;" nil t)))
 584       (goto-char (point-min))
 585       (while (search-forward "<" nil t)
 586         (replace-match "&lt;" nil t))
 587       (goto-char (point-min))
 588       (while (search-forward ">" nil t)
 589         (replace-match "&gt;" nil t))
 590       (if without-tags
 591           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 592         (let ((coded-charset-entity-reference-alist
 593                (list*
 594                 '(=gt                   "GT-" 5 d)
 595                 '(=cns11643-1           "C1-" 4 X)
 596                 '(=cns11643-2           "C2-" 4 X)
 597                 '(=cns11643-3           "C3-" 4 X)
 598                 '(=cns11643-4           "C4-" 4 X)
 599                 '(=cns11643-5           "C5-" 4 X)
 600                 '(=cns11643-6           "C6-" 4 X)
 601                 '(=cns11643-7           "C7-" 4 X)
 602                 '(=gb2312               "G0-" 4 X)
 603                 '(=gb12345              "G1-" 4 X)
 604                 '(=jis-x0208@1990       "J90-" 4 X)
 605                 '(=jis-x0212            "JSP-" 4 X)
 606                 '(=cbeta                "CB" 5 d)
 607                 '(=jis-x0208@1997       "J97-" 4 X)
 608                 '(=jis-x0208@1978       "J78-" 4 X)
 609                 '(=jis-x0208@1983       "J83-" 4 X)
 610                 '(=ruimoku-v6           "RUI6-" 4 X)
 611                 '(=zinbun-oracle        "ZOB-" 4 d)
 612                 '(=jef-china3           "JC3-" 4 X)
 613                 '(=daikanwa             "M-" 5 d)
 614                 coded-charset-entity-reference-alist)))
 615           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 616
 617           (goto-char (point-min))
 618           (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
 619             (setq code (string-to-int (match-string 1)))
 620             (replace-match
 621              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\"
 622 style=\"%s\">"
 623                      code
 624                      chise-wiki-bitmap-glyphs-url
 625                      (/ code 1000) code
 626                      www-format-char-img-style)
 627              t 'literal))
 628
 629           (goto-char (point-min))
 630           (while (re-search-forward "&\\(o-\\)?J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 631             (setq plane (match-string 2)
 632                   code (string-to-int (match-string 3) 16))
 633             (replace-match
 634              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\"
 635 style=\"%s\">"
 636                      plane code
 637                      chise-wiki-bitmap-glyphs-url
 638                      plane
 639                      (- (lsh code -8) 32)
 640                      (- (logand code 255) 32)
 641                      www-format-char-img-style)
 642              t 'literal))
 643
 644           (goto-char (point-min))
 645           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 646             (setq plane (string-to-int (match-string 1))
 647                   code (string-to-int (match-string 2) 16))
 648             (replace-match
 649              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\"
 650 style=\"%s\">"
 651                      plane code
 652                      chise-wiki-bitmap-glyphs-url
 653                      plane
 654                      (- (lsh code -8) 32)
 655                      (- (logand code 255) 32)
 656                      www-format-char-img-style)
 657              t 'literal))
 658
 659           (goto-char (point-min))
 660           (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 661             (setq plane (string-to-int (match-string 1))
 662                   code (string-to-int (match-string 2) 16))
 663             (replace-match
 664              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\"
 665 style=\"%s\">"
 666                      plane code
 667                      chise-wiki-bitmap-glyphs-url
 668                      plane code
 669                      www-format-char-img-style)
 670              t 'literal))
 671
 672           (goto-char (point-min))
 673           (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 674             (setq code (string-to-int (match-string 1) 16))
 675             (replace-match
 676              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 677                      code code)
 678              t 'literal))
 679
 680           (goto-char (point-min))
 681           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
 682             (setq code (string-to-int (match-string 2)))
 683             (replace-match
 684              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\"
 685 style=\"vertical-align:middle\">"
 686                      code
 687                      chise-wiki-bitmap-glyphs-url
 688                      code
 689                      www-format-char-img-style)
 690              t 'literal))
 691
 692           (goto-char (point-min))
 693           (while (re-search-forward "&\\(G-\\|g2-\\)?GT-\\([0-9]+\\);" nil t)
 694             (setq code (string-to-int (match-string 2)))
 695             (replace-match
 696              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\"
 697 style=\"%s\">"
 698                      code
 699                      chise-wiki-glyph-cgi-url
 700                      code
 701                      www-format-char-img-style)
 702              t 'literal))
 703
 704           (goto-char (point-min))
 705           (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
 706             (setq code (string-to-int (match-string 2)))
 707             (replace-match
 708              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\"
 709 style=\"%s\">"
 710                      code
 711                      chise-wiki-glyph-cgi-url
 712                      code
 713                      www-format-char-img-style)
 714              t 'literal))
 715
 716           (goto-char (point-min))
 717           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
 718             (setq code (string-to-int (match-string 1) 16))
 719             (replace-match
 720              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\"
 721 style=\"%s\">"
 722                      code
 723                      chise-wiki-glyph-cgi-url
 724                      code
 725                      www-format-char-img-style)
 726              t 'literal))
 727
 728           (goto-char (point-min))
 729           (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
 730             (setq code (string-to-int (match-string 1) 16))
 731             (replace-match
 732              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\"
 733 style=\"%s\">"
 734                      code
 735                      chise-wiki-glyph-cgi-url
 736                      code
 737                      www-format-char-img-style)
 738              t 'literal))
 739
 740           (goto-char (point-min))
 741           (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
 742             (setq code (string-to-int (match-string 1) 16))
 743             (replace-match
 744              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\"
 745 style=\"vertical-align:middle\">"
 746                      code
 747                      chise-wiki-glyph-cgi-url
 748                      code
 749                      www-format-char-img-style)
 750              t 'literal))
 751
 752           (goto-char (point-min))
 753           (while (re-search-forward "&\\(A-\\)?\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
 754             (setq code (string-to-int (match-string 3) 16))
 755             (replace-match
 756              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\"
 757 style=\"vertical-align:middle\">"
 758                      code
 759                      code
 760                      www-format-char-img-style)
 761              t 'literal))
 762
 763           (goto-char (point-min))
 764           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
 765             (setq code (string-to-int (match-string 1) 16))
 766             (setq start (match-beginning 0)
 767                   end (match-end 0))
 768             (setq char (decode-char 'system-char-id code))
 769             (cond
 770              ((and (setq variants
 771                          (or (www-get-feature-value char '->subsumptive)
 772                              (www-get-feature-value char '->denotational)))
 773                    (progn
 774                      (while (and variants
 775                                  (setq ret (www-format-encode-string
 776                                             (char-to-string (car variants))))
 777                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
 778                        (setq variants (cdr variants)))
 779                      ret))
 780               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
 781                 (goto-char start)
 782                 (delete-region start end)
 783                 (insert ret))
 784               )
 785              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
 786                             (www-get-feature-value char 'ideographic-structure)))
 787               (setq ret
 788                     (mapconcat
 789                      (lambda (ch)
 790                        (if (listp ch)
 791                            (if (characterp (setq rret (find-char ch)))
 792                                (setq ch rret)))
 793                        (if (characterp ch)
 794                            (www-format-encode-string
 795                             (char-to-string ch) without-tags)
 796                          (www-format-encode-string
 797                           (format "%S" ch) without-tags)))
 798                      ret ""))
 799               (when ret
 800                 (goto-char start)
 801                 (delete-region start end)
 802                 (insert ret))
 803               )))
 804           ))
 805       ;; (goto-char (point-min))
 806       ;; (while (search-forward "&GT-" nil t)
 807       ;;   (replace-match "&amp;GT-" t 'literal))
 808       (buffer-string))))
 809
 810 (defun www-html-display-text (text)
 811   (princ
 812    (with-temp-buffer
 813      (insert text)
 814      (goto-char (point-min))
 815      (while (search-forward "<" nil t)
 816        (replace-match "&lt;" nil t))
 817      (goto-char (point-min))
 818      (while (search-forward ">" nil t)
 819        (replace-match "&gt;" nil t))
 820      (goto-char (point-min))
 821      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
 822        (replace-match
 823         (format "<a href=\"%s\">%s</a>"
 824                 (match-string 2)
 825                 (match-string 1))
 826         nil t))
 827      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 828      (goto-char (point-min))
 829      (while (search-forward "&GT-" nil t)
 830        (replace-match "&amp;GT-" nil t))
 831      (buffer-string))))
 832
 833 (defun www-html-display-paragraph (text)
 834   (princ "<p>")
 835   (www-html-display-text text)
 836   (princ "</p>\n"))
 837
 838
 839 ;;; @ for GlyphWiki
 840 ;;;
 841
 842 (defvar coded-charset-GlyphWiki-id-alist
 843   '((=ucs               "u"     4 x nil)
 844     (=ucs@JP            "u"     4 x nil)
 845     (=ucs@jis           "u"     4 x nil)
 846     (=ucs@gb            "u"     4 x "-g")
 847     (=ucs@cns           "u"     4 x "-t")
 848     (=ucs@ks            "u"     4 x "-k")
 849     (=ucs@iso           "u"     4 x "-u")
 850     (=ucs@unicode       "u"     4 x "-us")
 851     (=adobe-japan1-6    "aj1-"  5 d nil)
 852     (=gt                "gt-"   5 d nil)
 853     (=big5-cdp          "cdp-"  4 x nil)
 854     (=cbeta             "cb"    5 d nil)
 855     (=jis-x0208@1978/1pr "j78-" 4 x nil)
 856     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
 857     (=jis-x0208@1978    "j78-"  4 x nil)
 858     (=jis-x0208@1983    "j83-"  4 x nil)
 859     (=jis-x0208@1990    "j90-"  4 x nil)
 860     (=jis-x0212         "jsp-"  4 x nil)
 861     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
 862     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
 863     (=jis-x0213-2       "jx2-"  4 x nil)
 864     (=cns11643-1        "c1-"   4 x nil)
 865     (=cns11643-2        "c2-"   4 x nil)
 866     (=cns11643-3        "c3-"   4 x nil)
 867     (=cns11643-4        "c4-"   4 x nil)
 868     (=cns11643-5        "c5-"   4 x nil)
 869     (=cns11643-6        "c6-"   4 x nil)
 870     (=cns11643-7        "c7-"   4 x nil)
 871     (=daikanwa          "dkw-"  5 d nil)
 872     (=gt-k              "gt-k"  5 d nil)
 873     (=jef-china3        "jc3-"  4 x nil)
 874     (=big5              "b-"    4 x nil)
 875     (=ks-x1001          "k0-"   4 x nil)
 876     ))
 877
 878 (defun char-GlyphWiki-id (char)
 879   (let ((rest coded-charset-GlyphWiki-id-alist)
 880         spec ret code)
 881     (while (and rest
 882                 (setq spec (pop rest))
 883                 (null (setq ret (char-feature char (car spec))))))
 884     (when ret
 885       (or
 886        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
 887             (cond
 888              ((and (or (encode-char char '=jis-x0208@1990)
 889                        (encode-char char '=jis-x0212)
 890                        (encode-char char '=jis-x0213-1))
 891                    (setq code (encode-char char '=ucs@jis)))
 892               (format "u%04x" code)
 893               )
 894              ((and (or (encode-char char '=gb2312)
 895                        (encode-char char '=gb12345))
 896                    (setq code (encode-char char '=ucs@gb)))
 897               (format "u%04x-g" code)
 898               )
 899              ((and (or (encode-char char '=cns11643-1)
 900                        (encode-char char '=cns11643-2)
 901                        (encode-char char '=cns11643-3)
 902                        (encode-char char '=cns11643-4)
 903                        (encode-char char '=cns11643-5)
 904                        (encode-char char '=cns11643-6)
 905                        (encode-char char '=cns11643-7))
 906                    (setq code (encode-char char '=ucs@cns)))
 907               (format "u%04x-t" code)
 908               )
 909              ((and (encode-char char '=ks-x1001)
 910                    (setq code (encode-char char '=ucs@ks)))
 911               (format "u%04x-k" code)
 912               )))
 913        (format (format "%s%%0%d%s%s"
 914                        (nth 1 spec)
 915                        (nth 2 spec)
 916                        (nth 3 spec)
 917                        (or (nth 4 spec) ""))
 918                ret)))))
 919
 920
 921 ;;; @ End.
 922 ;;;
 923
 924 (provide 'cwiki-common)
 925
 926 ;;; cwiki-common.el ends here