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