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