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