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