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     (cond
 291      ((string-match "^from\\." uri-feature)
 292       (intern (format "<-%s" (substring uri-feature (match-end 0))))
 293       )
 294      ((string-match "^to\\." uri-feature)
 295       (intern (format "->%s" (substring uri-feature (match-end 0))))
 296       )
 297      ((string-match "^rep\\." uri-feature)
 298       (intern (format "=%s" (substring uri-feature (match-end 0))))
 299       )
 300      ((string-match "^g\\." uri-feature)
 301       (intern (format "=>>%s" (substring uri-feature (match-end 0))))
 302       )
 303      ((string-match "^gi\\." uri-feature)
 304       (intern (format "=>>>%s" (substring uri-feature (match-end 0))))
 305       )
 306      ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
 307       (intern (format "=>>%s%s"
 308                       (make-string (string-to-int
 309                                     (match-string 1 uri-feature))
 310                                    ?>)
 311                       (substring uri-feature (match-end 0))))
 312       )
 313      ((string-match "^o\\." uri-feature)
 314       (intern (format "=+>%s" (substring uri-feature (match-end 0))))
 315       )
 316      ((string-match "^a\\." uri-feature)
 317       (intern (format "=>%s" (substring uri-feature (match-end 0))))
 318       )
 319      ((string-match "^a\\([0-9]+\\)\\." uri-feature)
 320       (intern (format "%s>%s"
 321                       (make-string (string-to-int
 322                                     (match-string 1 uri-feature))
 323                                    ?=)
 324                       (substring uri-feature (match-end 0))))
 325       )
 326      ((and (setq feature (intern (format "=>%s" uri-feature)))
 327            (find-charset feature))
 328       feature)
 329      ((and (setq feature (intern (format "=>>%s" uri-feature)))
 330            (find-charset feature))
 331       feature)
 332      ((and (setq feature (intern (format "=>>>%s" uri-feature)))
 333            (find-charset feature))
 334       feature)
 335      ((and (setq feature (intern (format "=%s" uri-feature)))
 336            (find-charset feature))
 337       feature)
 338      (t (intern uri-feature)))))
 339
 340 (defun www-uri-encode-feature-name (feature-name)
 341   (setq feature-name (symbol-name feature-name))
 342   (cond
 343    ((string-match "^=\\+>\\([^=>]+\\)" feature-name)
 344     (concat "o." (substring feature-name (match-beginning 1)))
 345     )
 346    ((string-match "^=\\([^=>]+\\)" feature-name)
 347     (concat "rep." (substring feature-name (match-beginning 1)))
 348     )
 349    ((string-match "^=>>\\([^=>]+\\)" feature-name)
 350     (concat "g." (substring feature-name (match-beginning 1)))
 351     )
 352    ((string-match "^=>>>\\([^=>]+\\)" feature-name)
 353     (concat "gi." (substring feature-name (match-beginning 1)))
 354     )
 355    ((string-match "^=>>\\(>+\\)" feature-name)
 356     (format "gi%d.%s"
 357             (length (match-string 1 feature-name))
 358             (substring feature-name (match-end 1)))
 359     )
 360    ((string-match "^=>\\([^=>]+\\)" feature-name)
 361     (concat "a." (substring feature-name (match-beginning 1)))
 362     )
 363    ((string-match "^\\(=+\\)>" feature-name)
 364     (format "a%d.%s"
 365             (length (match-string 1 feature-name))
 366             (substring feature-name (match-end 0)))
 367     )
 368    ((string-match "^->" feature-name)
 369     (concat "to." (substring feature-name (match-end 0)))
 370     )
 371    ((string-match "^<-" feature-name)
 372     (concat "from." (substring feature-name (match-end 0)))
 373     )
 374    (t feature-name)))
 375
 376 (defun www-uri-make-feature-name-url (uri-genre uri-feature-name uri-object)
 377   (format "%s?feature=%s&%s=%s"
 378           chise-wiki-view-url uri-feature-name uri-genre uri-object))
 379
 380 (defun www-uri-decode-object (genre char-rep)
 381   (let (ccs cpos)
 382     (cond
 383      ((string-match "\\(%3A\\|:\\)" char-rep)
 384       (setq ccs (substring char-rep 0 (match-beginning 0))
 385             cpos (substring char-rep (match-end 0)))
 386       (setq ccs (www-uri-decode-feature-name ccs))
 387       (cond
 388        ((string-match "^0x" cpos)
 389         (setq cpos
 390               (string-to-number (substring cpos (match-end 0)) 16))
 391         )
 392        (t
 393         (setq cpos (car (read-from-string cpos)))
 394         ))
 395       (if (and (eq genre 'character)
 396                (numberp cpos))
 397           (decode-char ccs cpos)
 398         (concord-decode-object ccs cpos genre))
 399       )
 400      (t
 401       (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
 402       (cond
 403        ((eq genre 'character)
 404         (when (= (length char-rep) 1)
 405           (aref char-rep 0))
 406         )
 407        ((eq genre 'feature)
 408         (concord-decode-object
 409          '=id (www-uri-decode-feature-name char-rep) 'feature)
 410         )
 411        (t
 412         (concord-decode-object
 413          '=id (car (read-from-string char-rep)) genre)
 414         ))))))
 415
 416 (defun www-uri-encode-object (object)
 417   (if (characterp object)
 418       (if (encode-char object '=ucs)
 419           (mapconcat
 420            (lambda (byte)
 421              (format "%%%02X" byte))
 422            (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
 423            "")
 424         (let ((ccs-list '(; =ucs
 425                           =cns11643-1 =cns11643-2 =cns11643-3
 426                           =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
 427                           =gb2312 =gb12345
 428                           =jis-x0208 =jis-x0208@1990
 429                           =jis-x0212
 430                           =cbeta =jef-china3
 431                           =jis-x0213-1@2000 =jis-x0213-1@2004
 432                           =jis-x0208@1983 =jis-x0208@1978
 433                           =zinbun-oracle =>zinbun-oracle
 434                           =daikanwa
 435                           =gt =gt-k
 436                           =>>jis-x0208 =>>jis-x0213-1
 437                           =+>jis-x0208@1978
 438                           =>jis-x0208 =>jis-x0213-1
 439                           =>>gt
 440                           =>ucs@iso =>ucs@unicode
 441                           =>ucs@jis =>ucs@cns =>ucs@ks
 442                           =ruimoku-v6
 443                           =big5
 444                           =big5-cdp))
 445               ccs ret)
 446           (while (and ccs-list
 447                       (setq ccs (pop ccs-list))
 448                       (not (setq ret (encode-char object ccs 'defined-only)))))
 449           (cond (ret
 450                  (format "%s:0x%X"
 451                          (www-uri-encode-feature-name ccs)
 452                          ret))
 453                 ((and (setq ccs (car (split-char object)))
 454                       (setq ret (encode-char object ccs)))
 455                  (format "%s:0x%X"
 456                          (www-uri-encode-feature-name ccs)
 457                          ret))
 458                 (t
 459                  (format "system-char-id:0x%X"
 460                          (encode-char object 'system-char-id))
 461                  ))))
 462     (format "rep.id:%s" (concord-object-id object))))
 463
 464 (defun est-format-object (object)
 465   (if (characterp object)
 466       (char-to-string object)
 467     (format "%s" (concord-object-id object))))
 468
 469 (defun www-uri-make-object-url (object &optional uri-object)
 470   (format "%s?%s=%s"
 471           chise-wiki-view-url
 472           (est-object-genre object)
 473           (or uri-object
 474               (www-uri-encode-object object))))
 475
 476
 477 ;;; @ Feature name presentation
 478 ;;;
 479
 480 (defun www-format-feature-name-default (feature-name)
 481   (mapconcat
 482    #'capitalize
 483    (split-string
 484     (symbol-name feature-name)
 485     "-")
 486    " "))
 487
 488 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
 489   (let ((str (symbol-name feature-name))
 490         base meta)
 491     (cond
 492      ((string-match "\\*[^*]+$" str)
 493       (setq base (substring str 0 (match-beginning 0))
 494             meta (substring str (match-beginning 0)))
 495       (concat (www-format-feature-name* (intern base) lang)
 496               meta))
 497      (t
 498       (www-format-feature-name-default feature-name)
 499       ))))
 500
 501 (defun www-format-feature-name-as-rel-to (feature-name)
 502   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 503
 504 (defun www-format-feature-name-as-rel-from (feature-name)
 505   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 506
 507 (defun www-format-feature-name-as-CCS (feature-name)
 508   (let* ((rest
 509           (split-string
 510            (symbol-name feature-name)
 511            "-"))
 512          (dest (upcase (pop rest))))
 513     (when (string-match "^=+>*" dest)
 514       (setq dest (concat (substring dest 0 (match-end 0))
 515                          " "
 516                          (substring dest (match-end 0)))))
 517     (cond
 518      (rest
 519       (while (cdr rest)
 520         (setq dest (concat dest " " (upcase (pop rest)))))
 521       (if (string-match "^[0-9]+$" (car rest))
 522           (concat dest "-" (car rest))
 523         (concat dest " " (upcase (car rest))))
 524       )
 525      (t dest))))
 526
 527 (defun www-format-feature-name* (feature-name &optional lang)
 528   (let (name fn parent ret)
 529     (cond
 530      ((or (and lang
 531                (char-feature-property
 532                 feature-name
 533                 (intern (format "name@%s" lang))))
 534           (char-feature-property
 535            feature-name 'name)))
 536      ((and (setq name (symbol-name feature-name))
 537            (string-match "\\*" name))
 538       (www-format-feature-name-as-metadata feature-name lang))
 539      (t
 540       (setq fn feature-name)
 541       (while (and (setq parent (char-feature-name-parent fn))
 542                   (null (setq ret
 543                               (or (and lang
 544                                        (char-feature-property
 545                                         parent
 546                                         (intern (format "name@%s" lang))))
 547                                   (char-feature-property
 548                                    parent 'name)))))
 549         (setq fn parent))
 550       (cond
 551        (ret
 552         (concat ret (substring (symbol-name feature-name)
 553                                (length (symbol-name parent)))))
 554        ((find-charset feature-name)
 555         (www-format-feature-name-as-CCS feature-name))
 556        ((string-match "^\\(->\\)" name)
 557         (www-format-feature-name-as-rel-to feature-name))
 558        ((string-match "^\\(<-\\)" name)
 559         (www-format-feature-name-as-rel-from feature-name))
 560        (t
 561         (www-format-feature-name-default feature-name)
 562         ))
 563       ))))
 564
 565 (defun www-format-feature-name (feature-name &optional lang)
 566   (www-format-encode-string
 567    (www-format-feature-name* feature-name lang)))
 568
 569
 570 ;;; @ HTML generator
 571 ;;;
 572
 573 (defvar www-format-char-img-style "vertical-align:bottom;")
 574
 575 (defun www-format-encode-string (string &optional without-tags as-body)
 576   (with-temp-buffer
 577     (insert string)
 578     (let (plane code start end char variants ret rret)
 579       (when as-body
 580         (goto-char (point-min))
 581         (while (search-forward "&" nil t)
 582           (replace-match "&amp;" nil t)))
 583       (goto-char (point-min))
 584       (while (search-forward "<" nil t)
 585         (replace-match "&lt;" nil t))
 586       (goto-char (point-min))
 587       (while (search-forward ">" nil t)
 588         (replace-match "&gt;" nil t))
 589       (if without-tags
 590           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 591         (let ((coded-charset-entity-reference-alist
 592                (list*
 593                 '(=gt                   "GT-" 5 d)
 594                 '(=cns11643-1           "C1-" 4 X)
 595                 '(=cns11643-2           "C2-" 4 X)
 596                 '(=cns11643-3           "C3-" 4 X)
 597                 '(=cns11643-4           "C4-" 4 X)
 598                 '(=cns11643-5           "C5-" 4 X)
 599                 '(=cns11643-6           "C6-" 4 X)
 600                 '(=cns11643-7           "C7-" 4 X)
 601                 '(=gb2312               "G0-" 4 X)
 602                 '(=gb12345              "G1-" 4 X)
 603                 '(=jis-x0208@1990       "J90-" 4 X)
 604                 '(=jis-x0212            "JSP-" 4 X)
 605                 '(=cbeta                "CB" 5 d)
 606                 '(=jis-x0208@1997       "J97-" 4 X)
 607                 '(=jis-x0208@1978       "J78-" 4 X)
 608                 '(=jis-x0208@1983       "J83-" 4 X)
 609                 '(=ruimoku-v6           "RUI6-" 4 X)
 610                 '(=zinbun-oracle        "ZOB-" 4 d)
 611                 '(=jef-china3           "JC3-" 4 X)
 612                 '(=daikanwa             "M-" 5 d)
 613                 coded-charset-entity-reference-alist)))
 614           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 615
 616           (goto-char (point-min))
 617           (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
 618             (setq code (string-to-int (match-string 1)))
 619             (replace-match
 620              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\"
 621 style=\"%s\">"
 622                      code
 623                      chise-wiki-bitmap-glyphs-url
 624                      (/ code 1000) code
 625                      www-format-char-img-style)
 626              t 'literal))
 627
 628           (goto-char (point-min))
 629           (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)
 630             (setq plane (match-string 2)
 631                   code (string-to-int (match-string 3) 16))
 632             (replace-match
 633              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\"
 634 style=\"%s\">"
 635                      plane code
 636                      chise-wiki-bitmap-glyphs-url
 637                      plane
 638                      (- (lsh code -8) 32)
 639                      (- (logand code 255) 32)
 640                      www-format-char-img-style)
 641              t 'literal))
 642
 643           (goto-char (point-min))
 644           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 645             (setq plane (string-to-int (match-string 1))
 646                   code (string-to-int (match-string 2) 16))
 647             (replace-match
 648              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\"
 649 style=\"%s\">"
 650                      plane code
 651                      chise-wiki-bitmap-glyphs-url
 652                      plane
 653                      (- (lsh code -8) 32)
 654                      (- (logand code 255) 32)
 655                      www-format-char-img-style)
 656              t 'literal))
 657
 658           (goto-char (point-min))
 659           (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 660             (setq plane (string-to-int (match-string 1))
 661                   code (string-to-int (match-string 2) 16))
 662             (replace-match
 663              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\"
 664 style=\"%s\">"
 665                      plane code
 666                      chise-wiki-bitmap-glyphs-url
 667                      plane code
 668                      www-format-char-img-style)
 669              t 'literal))
 670
 671           (goto-char (point-min))
 672           (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 673             (setq code (string-to-int (match-string 1) 16))
 674             (replace-match
 675              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 676                      code code)
 677              t 'literal))
 678
 679           (goto-char (point-min))
 680           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
 681             (setq code (string-to-int (match-string 2)))
 682             (replace-match
 683              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\"
 684 style=\"vertical-align:middle\">"
 685                      code
 686                      chise-wiki-bitmap-glyphs-url
 687                      code
 688                      www-format-char-img-style)
 689              t 'literal))
 690
 691           (goto-char (point-min))
 692           (while (re-search-forward "&\\(G-\\|g2-\\)?GT-\\([0-9]+\\);" nil t)
 693             (setq code (string-to-int (match-string 2)))
 694             (replace-match
 695              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\"
 696 style=\"%s\">"
 697                      code
 698                      chise-wiki-glyph-cgi-url
 699                      code
 700                      www-format-char-img-style)
 701              t 'literal))
 702
 703           (goto-char (point-min))
 704           (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
 705             (setq code (string-to-int (match-string 2)))
 706             (replace-match
 707              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\"
 708 style=\"%s\">"
 709                      code
 710                      chise-wiki-glyph-cgi-url
 711                      code
 712                      www-format-char-img-style)
 713              t 'literal))
 714
 715           (goto-char (point-min))
 716           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
 717             (setq code (string-to-int (match-string 1) 16))
 718             (replace-match
 719              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\"
 720 style=\"%s\">"
 721                      code
 722                      chise-wiki-glyph-cgi-url
 723                      code
 724                      www-format-char-img-style)
 725              t 'literal))
 726
 727           (goto-char (point-min))
 728           (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
 729             (setq code (string-to-int (match-string 1) 16))
 730             (replace-match
 731              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\"
 732 style=\"%s\">"
 733                      code
 734                      chise-wiki-glyph-cgi-url
 735                      code
 736                      www-format-char-img-style)
 737              t 'literal))
 738
 739           (goto-char (point-min))
 740           (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
 741             (setq code (string-to-int (match-string 1) 16))
 742             (replace-match
 743              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\"
 744 style=\"vertical-align:middle\">"
 745                      code
 746                      chise-wiki-glyph-cgi-url
 747                      code
 748                      www-format-char-img-style)
 749              t 'literal))
 750
 751           (goto-char (point-min))
 752           (while (re-search-forward "&\\(A-\\)?\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
 753             (setq code (string-to-int (match-string 3) 16))
 754             (replace-match
 755              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\"
 756 style=\"vertical-align:middle\">"
 757                      code
 758                      code
 759                      www-format-char-img-style)
 760              t 'literal))
 761
 762           (goto-char (point-min))
 763           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
 764             (setq code (string-to-int (match-string 1) 16))
 765             (setq start (match-beginning 0)
 766                   end (match-end 0))
 767             (setq char (decode-char 'system-char-id code))
 768             (cond
 769              ((and (setq variants
 770                          (or (www-get-feature-value char '->subsumptive)
 771                              (www-get-feature-value char '->denotational)))
 772                    (progn
 773                      (while (and variants
 774                                  (setq ret (www-format-encode-string
 775                                             (char-to-string (car variants))))
 776                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
 777                        (setq variants (cdr variants)))
 778                      ret))
 779               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
 780                 (goto-char start)
 781                 (delete-region start end)
 782                 (insert ret))
 783               )
 784              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
 785                             (www-get-feature-value char 'ideographic-structure)))
 786               (setq ret
 787                     (mapconcat
 788                      (lambda (ch)
 789                        (if (listp ch)
 790                            (if (characterp (setq rret (find-char ch)))
 791                                (setq ch rret)))
 792                        (if (characterp ch)
 793                            (www-format-encode-string
 794                             (char-to-string ch) without-tags)
 795                          (www-format-encode-string
 796                           (format "%S" ch) without-tags)))
 797                      ret ""))
 798               (when ret
 799                 (goto-char start)
 800                 (delete-region start end)
 801                 (insert ret))
 802               )))
 803           ))
 804       ;; (goto-char (point-min))
 805       ;; (while (search-forward "&GT-" nil t)
 806       ;;   (replace-match "&amp;GT-" t 'literal))
 807       (buffer-string))))
 808
 809 (defun www-html-display-text (text)
 810   (princ
 811    (with-temp-buffer
 812      (insert text)
 813      (goto-char (point-min))
 814      (while (search-forward "<" nil t)
 815        (replace-match "&lt;" nil t))
 816      (goto-char (point-min))
 817      (while (search-forward ">" nil t)
 818        (replace-match "&gt;" nil t))
 819      (goto-char (point-min))
 820      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
 821        (replace-match
 822         (format "<a href=\"%s\">%s</a>"
 823                 (match-string 2)
 824                 (match-string 1))
 825         nil t))
 826      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 827      (goto-char (point-min))
 828      (while (search-forward "&GT-" nil t)
 829        (replace-match "&amp;GT-" nil t))
 830      (buffer-string))))
 831
 832 (defun www-html-display-paragraph (text)
 833   (princ "<p>")
 834   (www-html-display-text text)
 835   (princ "</p>\n"))
 836
 837
 838 ;;; @ for GlyphWiki
 839 ;;;
 840
 841 (defvar coded-charset-GlyphWiki-id-alist
 842   '((=ucs               "u"     4 x nil)
 843     (=ucs@JP            "u"     4 x nil)
 844     (=ucs@jis           "u"     4 x nil)
 845     (=ucs@gb            "u"     4 x "-g")
 846     (=ucs@cns           "u"     4 x "-t")
 847     (=ucs@ks            "u"     4 x "-k")
 848     (=ucs@iso           "u"     4 x "-u")
 849     (=ucs@unicode       "u"     4 x "-us")
 850     (=adobe-japan1-6    "aj1-"  5 d nil)
 851     (=gt                "gt-"   5 d nil)
 852     (=big5-cdp          "cdp-"  4 x nil)
 853     (=cbeta             "cb"    5 d nil)
 854     (=jis-x0208@1978/1pr "j78-" 4 x nil)
 855     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
 856     (=jis-x0208@1978    "j78-"  4 x nil)
 857     (=jis-x0208@1983    "j83-"  4 x nil)
 858     (=jis-x0208@1990    "j90-"  4 x nil)
 859     (=jis-x0212         "jsp-"  4 x nil)
 860     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
 861     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
 862     (=jis-x0213-2       "jx2-"  4 x nil)
 863     (=cns11643-1        "c1-"   4 x nil)
 864     (=cns11643-2        "c2-"   4 x nil)
 865     (=cns11643-3        "c3-"   4 x nil)
 866     (=cns11643-4        "c4-"   4 x nil)
 867     (=cns11643-5        "c5-"   4 x nil)
 868     (=cns11643-6        "c6-"   4 x nil)
 869     (=cns11643-7        "c7-"   4 x nil)
 870     (=daikanwa          "dkw-"  5 d nil)
 871     (=gt-k              "gt-k"  5 d nil)
 872     (=jef-china3        "jc3-"  4 x nil)
 873     (=big5              "b-"    4 x nil)
 874     (=ks-x1001          "k0-"   4 x nil)
 875     ))
 876
 877 (defun char-GlyphWiki-id (char)
 878   (let ((rest coded-charset-GlyphWiki-id-alist)
 879         spec ret code)
 880     (while (and rest
 881                 (setq spec (pop rest))
 882                 (null (setq ret (char-feature char (car spec))))))
 883     (when ret
 884       (or
 885        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
 886             (cond
 887              ((and (or (encode-char char '=jis-x0208@1990)
 888                        (encode-char char '=jis-x0212)
 889                        (encode-char char '=jis-x0213-1))
 890                    (setq code (encode-char char '=ucs@jis)))
 891               (format "u%04x" code)
 892               )
 893              ((and (or (encode-char char '=gb2312)
 894                        (encode-char char '=gb12345))
 895                    (setq code (encode-char char '=ucs@gb)))
 896               (format "u%04x-g" code)
 897               )
 898              ((and (or (encode-char char '=cns11643-1)
 899                        (encode-char char '=cns11643-2)
 900                        (encode-char char '=cns11643-3)
 901                        (encode-char char '=cns11643-4)
 902                        (encode-char char '=cns11643-5)
 903                        (encode-char char '=cns11643-6)
 904                        (encode-char char '=cns11643-7))
 905                    (setq code (encode-char char '=ucs@cns)))
 906               (format "u%04x-t" code)
 907               )
 908              ((and (encode-char char '=ks-x1001)
 909                    (setq code (encode-char char '=ucs@ks)))
 910               (format "u%04x-k" code)
 911               )))
 912        (format (format "%s%%0%d%s%s"
 913                        (nth 1 spec)
 914                        (nth 2 spec)
 915                        (nth 3 spec)
 916                        (or (nth 4 spec) ""))
 917                ret)))))
 918
 919
 920 ;;; @ End.
 921 ;;;
 922
 923 (provide 'cwiki-common)
 924
 925 ;;; cwiki-common.el ends here