cwiki-common.el

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