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