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 (concord-assign-genre 'creator "/usr/local/var/ruimoku/db")
   7 (concord-assign-genre 'bibliography "/usr/local/var/ruimoku/db")
   8 (concord-assign-genre 'era "/usr/local/var/ruimoku/db")
   9 (concord-assign-genre 'period "/usr/local/var/ruimoku/db")
  10 (concord-assign-genre 'journal "/usr/local/var/ruimoku/db")
  11
  12 (defvar chise-wiki-view-url "view.cgi")
  13 (defvar chise-wiki-edit-url "edit.cgi")
  14
  15 (defvar chise-wiki-bitmap-glyphs-url
  16   "http://chise.zinbun.kyoto-u.ac.jp/glyphs")
  17
  18 (defvar chise-wiki-glyph-cgi-url
  19   "http://chise.zinbun.kyoto-u.ac.jp/chisewiki/glyph.cgi")
  20
  21 (defvar chise-wiki-displayed-features nil)
  22
  23 (defun decode-uri-string (string &optional coding-system)
  24   (if (> (length string) 0)
  25       (let ((i 0)
  26             dest)
  27         (setq string
  28               (mapconcat (lambda (char)
  29                            (if (eq char ?+)
  30                                " "
  31                              (char-to-string char)))
  32                          string ""))
  33         (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
  34           (setq dest (concat dest
  35                              (substring string i (match-beginning 0))
  36                              (char-to-string
  37                               (int-char
  38                                (string-to-int (match-string 1 string) 16))))
  39                 i (match-end 0)))
  40         (decode-coding-string
  41          (concat dest (substring string i))
  42          coding-system))))
  43
  44 (defun www-get-genre (object)
  45   (if (characterp object)
  46       'character
  47     'default))
  48
  49 (defun www-feature-type (feature-name)
  50   (or (char-feature-property feature-name 'type)
  51       (let ((str (symbol-name feature-name)))
  52         (cond
  53          ((string-match "\\*note\\(@[^*]+\\)?$" str)
  54           'stext)
  55          ((string-match "\\*sources\\(@[^*]+\\)?$" str)
  56           'domain-list)
  57          ((string-match "\\*" str)
  58           nil)
  59          ((string-match "^\\(->\\|<-\\)" str)
  60           'relation)
  61          ((string-match "^ideographic-structure\\(@\\|$\\)" str)
  62           'structure)
  63          ))))
  64
  65 (defun www-feature-format (feature-name)
  66   (or (char-feature-property feature-name 'format)
  67       (let (fn parent ret)
  68         (setq fn feature-name)
  69         (while (and (setq parent (char-feature-name-parent fn))
  70                     (null (setq ret
  71                                 (char-feature-property
  72                                  parent 'format))))
  73           (setq fn parent))
  74         ret)
  75       '((name) " : " (value))))
  76
  77 (defun www-feature-value-format (feature-name)
  78   (or (char-feature-property feature-name 'value-format)
  79       (let (fn parent ret)
  80         (setq fn feature-name)
  81         (while (and (setq parent (char-feature-name-parent fn))
  82                     (null (setq ret
  83                                 (char-feature-property
  84                                  parent 'value-format))))
  85           (setq fn parent))
  86         ret)
  87       (let ((type (www-feature-type feature-name)))
  88         (cond ((eq type 'relation)
  89                'space-separated-char-list)
  90               ((eq type 'structure)
  91                'space-separated-ids)
  92               ((eq type 'stext)
  93                'wiki-text)
  94               ))
  95       (if (find-charset feature-name)
  96           (if (and (= (charset-dimension feature-name) 2)
  97                    (= (charset-chars feature-name) 94))
  98               '("0x" (HEX)
  99                 " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
 100             '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))))
 101
 102 (defun char-feature-name-at-domain (feature-name domain)
 103   (if domain
 104       (let ((name (symbol-name feature-name)))
 105         (cond
 106          ((string-match "@[^*]+$" name)
 107           (intern (format "%s/%s" name domain))
 108           )
 109          (t
 110           (intern (format "%s@%s" name domain))
 111           )))
 112     feature-name))
 113
 114 (defun char-feature-name-parent (feature-name)
 115   (let ((name (symbol-name feature-name)))
 116     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 117         (intern (substring name 0 (car (last (match-data) 2)))))))
 118
 119 (defun char-feature-name-domain (feature-name)
 120   (let ((name (symbol-name feature-name)))
 121     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 122         (intern (substring name (1+ (match-beginning 0)))))))
 123
 124 (defun char-feature-name-sans-versions (feature)
 125   (let ((feature-name (symbol-name feature)))
 126     (if (string-match "[@/]\\$rev=latest$" feature-name)
 127         (intern (substring feature-name 0 (match-beginning 0)))
 128       feature)))
 129
 130 (defun www-get-feature-value (object feature)
 131   (let ((genre (www-get-genre object))
 132         (latest-feature (char-feature-name-at-domain feature '$rev=latest)))
 133     (cond
 134      ((eq genre 'character)
 135       (mount-char-attribute-table latest-feature)
 136       (or (char-feature object latest-feature)
 137           (char-feature object feature))
 138       )
 139      (t
 140       (or (concord-object-get object latest-feature)
 141           (concord-object-get object feature))
 142       ))))
 143
 144 (defun get-previous-code-point (ccs code)
 145   (let ((chars (charset-chars ccs))
 146         (dim (charset-dimension ccs))
 147         (i 0)
 148         mask byte-min byte-max
 149         bytes dest)
 150     (cond
 151      ((= chars 94)
 152       (setq mask #x7F
 153             byte-min 33
 154             byte-max 126)
 155       )
 156      ((= chars 96)
 157       (setq mask #x7F
 158             byte-min 32
 159             byte-max 127)
 160       )
 161      ((= chars 128)
 162       (setq mask #x7F
 163             byte-min 0
 164             byte-max #xFF)
 165       )
 166      (t ; (= chars 256)
 167       (setq mask #xFF
 168             byte-min 0
 169             byte-max #xFF)
 170       ))
 171     (setq bytes (make-vector dim 0))
 172     (while (< i dim)
 173       (aset bytes i (logand (lsh code (* i -8)) mask))
 174       (setq i (1+ i)))
 175     (setq i 0)
 176     (while (and (< i dim)
 177                 (progn
 178                   (aset bytes i (1- (aref bytes i)))
 179                   (< (aref bytes i) byte-min)))
 180       (aset bytes i byte-max)
 181       (setq i (1+ i)))
 182     (when (< i dim)
 183       (setq dest (aref bytes 0)
 184             i 1)
 185       (while (< i dim)
 186         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 187               i (1+ i)))
 188       dest)))
 189
 190 (defun get-next-code-point (ccs code)
 191   (let ((chars (charset-chars ccs))
 192         (dim (charset-dimension ccs))
 193         (i 0)
 194         mask byte-min byte-max
 195         bytes dest)
 196     (cond
 197      ((= chars 94)
 198       (setq mask #x7F
 199             byte-min 33
 200             byte-max 126)
 201       )
 202      ((= chars 96)
 203       (setq mask #x7F
 204             byte-min 32
 205             byte-max 127)
 206       )
 207      ((= chars 128)
 208       (setq mask #x7F
 209             byte-min 0
 210             byte-max #xFF)
 211       )
 212      (t ; (= chars 256)
 213       (setq mask #xFF
 214             byte-min 0
 215             byte-max #xFF)
 216       ))
 217     (setq bytes (make-vector dim 0))
 218     (while (< i dim)
 219       (aset bytes i (logand (lsh code (* i -8)) mask))
 220       (setq i (1+ i)))
 221     (setq i 0)
 222     (while (and (< i dim)
 223                 (progn
 224                   (aset bytes i (1+ (aref bytes i)))
 225                   (> (aref bytes i) byte-max)))
 226       (aset bytes i byte-min)
 227       (setq i (1+ i)))
 228     (when (< i dim)
 229       (setq dest (aref bytes 0)
 230             i 1)
 231       (while (< i dim)
 232         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 233               i (1+ i)))
 234       dest)))
 235
 236 (defun find-previous-defined-code-point (ccs code)
 237   (let ((i (get-previous-code-point ccs code))
 238         char)
 239     (cond
 240      ((eq ccs '=jis-x0208)
 241       (setq ccs '=jis-x0208@1990))
 242      ((eq ccs '=jis-x0213-1)
 243       (setq ccs '=jis-x0213-1@2004)))
 244     (while (and i
 245                 (>= i 0)
 246                 (null (setq char (decode-char ccs i
 247                                               (unless (eq ccs '=ucs)
 248                                                 'defined-only)))))
 249       (setq i (get-previous-code-point ccs i)))
 250     char))
 251
 252 (defun find-next-defined-code-point (ccs code)
 253   (let ((i (get-next-code-point ccs code))
 254         max char)
 255     (setq max (+ code 1000))
 256     (cond
 257      ((eq ccs '=jis-x0208)
 258       (setq ccs '=jis-x0208@1990))
 259      ((eq ccs '=jis-x0213-1)
 260       (setq ccs '=jis-x0213-1@2004)))
 261     (while (and i
 262                 (<= i max)
 263                 (null (setq char (decode-char ccs i
 264                                               (unless (eq ccs '=ucs)
 265                                                 'defined-only)))))
 266       (setq i (get-next-code-point ccs i)))
 267     char))
 268
 269
 270 ;;; @ URI representation
 271 ;;;
 272
 273 (defun www-uri-decode-feature-name (uri-feature)
 274   (let (feature)
 275     (cond
 276      ((string-match "^from\\." uri-feature)
 277       (intern (format "<-%s" (substring uri-feature (match-end 0))))
 278       )
 279      ((string-match "^to\\." uri-feature)
 280       (intern (format "->%s" (substring uri-feature (match-end 0))))
 281       )
 282      ((string-match "^rep\\." uri-feature)
 283       (intern (format "=%s" (substring uri-feature (match-end 0))))
 284       )
 285      ((string-match "^g\\." uri-feature)
 286       (intern (format "=>>%s" (substring uri-feature (match-end 0))))
 287       )
 288      ((string-match "^gi\\." uri-feature)
 289       (intern (format "=>>>%s" (substring uri-feature (match-end 0))))
 290       )
 291      ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
 292       (intern (format "=>>%s%s"
 293                       (make-string (string-to-int
 294                                     (match-string 1 uri-feature))
 295                                    ?>)
 296                       (substring uri-feature (match-end 0))))
 297       )
 298      ((string-match "^a\\." uri-feature)
 299       (intern (format "=>%s" (substring uri-feature (match-end 0))))
 300       )
 301      ((string-match "^a\\([0-9]+\\)\\." uri-feature)
 302       (intern (format "%s>%s"
 303                       (make-string (string-to-int
 304                                     (match-string 1 uri-feature))
 305                                    ?=)
 306                       (substring uri-feature (match-end 0))))
 307       )
 308      ((and (setq feature (intern (format "=>%s" uri-feature)))
 309            (find-charset feature))
 310       feature)
 311      ((and (setq feature (intern (format "=>>%s" uri-feature)))
 312            (find-charset feature))
 313       feature)
 314      ((and (setq feature (intern (format "=>>>%s" uri-feature)))
 315            (find-charset feature))
 316       feature)
 317      ((and (setq feature (intern (format "=%s" uri-feature)))
 318            (find-charset feature))
 319       feature)
 320      (t (intern uri-feature)))))
 321
 322 (defun www-uri-encode-feature-name (feature-name)
 323   (setq feature-name (symbol-name feature-name))
 324   (cond
 325    ((string-match "^=\\([^=>]+\\)" feature-name)
 326     (concat "rep." (substring feature-name (match-beginning 1)))
 327     )
 328    ((string-match "^=>>\\([^=>]+\\)" feature-name)
 329     (concat "g." (substring feature-name (match-beginning 1)))
 330     )
 331    ((string-match "^=>>>\\([^=>]+\\)" feature-name)
 332     (concat "gi." (substring feature-name (match-beginning 1)))
 333     )
 334    ((string-match "^=>>\\(>+\\)" feature-name)
 335     (format "gi%d.%s"
 336             (length (match-string 1 feature-name))
 337             (substring feature-name (match-end 1)))
 338     )
 339    ((string-match "^=>\\([^=>]+\\)" feature-name)
 340     (concat "a." (substring feature-name (match-beginning 1)))
 341     )
 342    ((string-match "^\\(=+\\)>" feature-name)
 343     (format "a%d.%s"
 344             (length (match-string 1 feature-name))
 345             (substring feature-name (match-end 0)))
 346     )
 347    ((string-match "^->" feature-name)
 348     (concat "to." (substring feature-name (match-end 0)))
 349     )
 350    ((string-match "^<-" feature-name)
 351     (concat "from." (substring feature-name (match-end 0)))
 352     )
 353    (t feature-name)))
 354
 355 (defun www-uri-make-feature-name-url (uri-feature-name uri-char)
 356   (format "%s?feature=%s&char=%s"
 357           chise-wiki-view-url uri-feature-name uri-char))
 358
 359 (defun www-uri-decode-object (genre char-rep)
 360   (let (ccs cpos)
 361     (cond
 362      ((string-match "\\(%3A\\|:\\)" char-rep)
 363       (setq ccs (substring char-rep 0 (match-beginning 0))
 364             cpos (substring char-rep (match-end 0)))
 365       (setq ccs (www-uri-decode-feature-name ccs))
 366       (cond
 367        ((string-match "^0x" cpos)
 368         (setq cpos
 369               (string-to-number (substring cpos (match-end 0)) 16))
 370         )
 371        (t
 372         (setq cpos (car (read-from-string cpos)))
 373         ))
 374       (if (and (eq genre 'character)
 375                (numberp cpos))
 376           (decode-char ccs cpos)
 377         (concord-decode-object ccs cpos genre))
 378       )
 379      (t
 380       (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
 381       (cond
 382        ((eq genre 'character)
 383         (when (= (length char-rep) 1)
 384           (aref char-rep 0))
 385         )
 386        ((eq genre 'feature)
 387         (concord-decode-object
 388          '=id (www-uri-decode-feature-name char-rep) 'feature)
 389         )
 390        (t
 391         (concord-decode-object
 392          '=id (car (read-from-string char-rep)) genre)
 393         ))))))
 394
 395 (defun www-uri-encode-char (char)
 396   (if (encode-char char '=ucs)
 397       (mapconcat
 398        (lambda (byte)
 399          (format "%%%02X" byte))
 400        (encode-coding-string (char-to-string char) 'utf-8-mcs-er)
 401        "")
 402     (let ((ccs-list '(; =ucs
 403                       =cns11643-1 =cns11643-2 =cns11643-3
 404                       =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
 405                       =gb2312 =gb12345
 406                       =jis-x0208 =jis-x0208@1990
 407                       =jis-x0212
 408                       =cbeta =jef-china3
 409                       =jis-x0213-1@2000 =jis-x0213-1@2004
 410                       =jis-x0208@1983 =jis-x0208@1978
 411                       =zinbun-oracle =>zinbun-oracle
 412                       =daikanwa
 413                       =gt =gt-k
 414                       =>>jis-x0208 =>>jis-x0213-1
 415                       =>jis-x0208 =>jis-x0213-1
 416                       =>>gt
 417                       =ruimoku-v6
 418                       =big5
 419                       =big5-cdp))
 420           ccs ret)
 421       (while (and ccs-list
 422                   (setq ccs (pop ccs-list))
 423                   (not (setq ret (encode-char char ccs 'defined-only)))))
 424       (cond (ret
 425              (format "%s:0x%X"
 426                      (www-uri-encode-feature-name ccs)
 427                      ret))
 428             ((and (setq ccs (car (split-char char)))
 429                   (setq ret (encode-char char ccs)))
 430              (format "%s:0x%X"
 431                      (www-uri-encode-feature-name ccs)
 432                      ret))
 433             (t
 434              (format "system-char-id:0x%X"
 435                      (encode-char char 'system-char-id))
 436              )))))
 437
 438
 439 ;;; @ Feature name presentation
 440 ;;;
 441
 442 (defun www-format-feature-name-default (feature-name)
 443   (mapconcat
 444    #'capitalize
 445    (split-string
 446     (symbol-name feature-name)
 447     "-")
 448    " "))
 449
 450 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
 451   (let ((str (symbol-name feature-name))
 452         base meta)
 453     (cond
 454      ((string-match "\\*[^*]+$" str)
 455       (setq base (substring str 0 (match-beginning 0))
 456             meta (substring str (match-beginning 0)))
 457       (concat (www-format-feature-name* (intern base) lang)
 458               meta))
 459      (t
 460       (www-format-feature-name-default feature-name)
 461       ))))
 462
 463 (defun www-format-feature-name-as-rel-to (feature-name)
 464   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 465
 466 (defun www-format-feature-name-as-rel-from (feature-name)
 467   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 468
 469 (defun www-format-feature-name-as-CCS (feature-name)
 470   (let* ((rest
 471           (split-string
 472            (symbol-name feature-name)
 473            "-"))
 474          (dest (upcase (pop rest))))
 475     (when (string-match "^=+>*" dest)
 476       (setq dest (concat (substring dest 0 (match-end 0))
 477                          " "
 478                          (substring dest (match-end 0)))))
 479     (cond
 480      (rest
 481       (while (cdr rest)
 482         (setq dest (concat dest " " (upcase (pop rest)))))
 483       (if (string-match "^[0-9]+$" (car rest))
 484           (concat dest "-" (car rest))
 485         (concat dest " " (upcase (car rest))))
 486       )
 487      (t dest))))
 488
 489 (defun www-format-feature-name* (feature-name &optional lang)
 490   (let (name fn parent ret)
 491     (cond
 492      ((or (and lang
 493                (char-feature-property
 494                 feature-name
 495                 (intern (format "name@%s" lang))))
 496           (char-feature-property
 497            feature-name 'name)))
 498      ((and (setq name (symbol-name feature-name))
 499            (string-match "\\*" name))
 500       (www-format-feature-name-as-metadata feature-name lang))
 501      (t
 502       (setq fn feature-name)
 503       (while (and (setq parent (char-feature-name-parent fn))
 504                   (null (setq ret
 505                               (or (and lang
 506                                        (char-feature-property
 507                                         parent
 508                                         (intern (format "name@%s" lang))))
 509                                   (char-feature-property
 510                                    parent 'name)))))
 511         (setq fn parent))
 512       (cond
 513        (ret
 514         (concat ret (substring (symbol-name feature-name)
 515                                (length (symbol-name parent)))))
 516        ((find-charset feature-name)
 517         (www-format-feature-name-as-CCS feature-name))
 518        ((string-match "^\\(->\\)" name)
 519         (www-format-feature-name-as-rel-to feature-name))
 520        ((string-match "^\\(<-\\)" name)
 521         (www-format-feature-name-as-rel-from feature-name))
 522        (t
 523         (www-format-feature-name-default feature-name)
 524         ))
 525       ))))
 526
 527 (defun www-format-feature-name (feature-name &optional lang)
 528   (www-format-encode-string
 529    (www-format-feature-name* feature-name lang)))
 530
 531
 532 ;;; @ Feature value presentation
 533 ;;;
 534
 535 (defun www-format-value-as-kuten (value)
 536   (format "%02d-%02d"
 537           (- (lsh value -8) 32)
 538           (- (logand value 255) 32)))
 539
 540 (defun www-format-value-default (value &optional without-tags)
 541   (if (listp value)
 542       (mapconcat
 543        (lambda (unit)
 544          (www-format-encode-string
 545           (format "%S" unit)
 546           without-tags))
 547        value " ")
 548     (www-format-encode-string (format "%S" value) without-tags)))
 549
 550 (defun www-format-value-as-char-list (value &optional without-tags)
 551   (if (listp value)
 552       (mapconcat
 553        (if without-tags
 554            (lambda (unit)
 555              (www-format-encode-string
 556               (format (if (characterp unit)
 557                           "%c"
 558                         "%s")
 559                       unit)
 560               'without-tags))
 561          (lambda (unit)
 562            (if (characterp unit)
 563                (format "<a href=\"%s?char=%s\">%s</a>"
 564                        chise-wiki-view-url
 565                        (www-uri-encode-char unit)
 566                        (www-format-encode-string (char-to-string unit)))
 567              (www-format-encode-string (format "%s" unit)))))
 568        value " ")
 569     (www-format-encode-string (format "%s" value) without-tags)))
 570
 571 (defun www-format-value-as-domain-list (value &optional without-tags)
 572   (let (name source0 source num dest rest unit start end ddest)
 573     (if (listp value)
 574         (if without-tags
 575             (mapconcat
 576              (lambda (unit)
 577                (format "%s" unit))
 578              value " ")
 579           (setq rest value)
 580           (while rest
 581             (setq unit (pop rest))
 582             (if (symbolp unit)
 583                 (setq name (symbol-name unit)))
 584             (setq dest
 585                   (concat
 586                    dest
 587                    (cond
 588                     ((string-match "^zob1968=" name)
 589                      (setq source (intern (substring name 0 (match-end 0)))
 590                            num (substring name (match-end 0)))
 591                      (if (string-match "^\\([0-9]+\\)-\\([0-9]+\\)$" num)
 592                          (setq start (string-to-number
 593                                       (match-string 1 num))
 594                                end (string-to-number
 595                                     (match-string 2 num)))
 596                        (setq start (string-to-number num)
 597                              end start))
 598                      (setq ddest
 599                            (if (eq source source0)
 600                                (format
 601                                 ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
 602                                 start start)
 603                              (setq source0 source)
 604                              (format
 605                               " <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/\">%s</a>=<a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
 606                               (www-format-encode-string "\u4EAC大人\u6587研甲\u9AA8")
 607                               start start)))
 608                      (setq start (1+ start))
 609                      (while (<= start end)
 610                        (setq ddest
 611                              (concat
 612                               ddest
 613                               (format
 614                                ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
 615                                start start)))
 616                        (setq start (1+ start)))
 617                      ddest)
 618                     (t
 619                      (setq source unit)
 620                      (if (eq source source0)
 621                          ""
 622                        (setq source0 source)
 623                        (concat " " name))
 624                      )))))
 625           dest)
 626       (www-format-encode-string (format "%s" value) without-tags))))
 627
 628 (defun www-format-value-as-ids (value &optional without-tags)
 629   (if (listp value)
 630       (mapconcat
 631        (if without-tags
 632            (lambda (unit)
 633              (www-format-encode-string
 634               (format (if (characterp unit)
 635                           "%c"
 636                         "%s")
 637                       unit)
 638               'without-tags))
 639          (lambda (unit)
 640            (if (characterp unit)
 641                (format "<a href=\"%s?char=%s\">%s</a>"
 642                        chise-wiki-view-url
 643                        (www-uri-encode-char unit)
 644                        (www-format-encode-string (char-to-string unit)))
 645              (www-format-encode-string (format "%s" unit)))))
 646        (ideographic-structure-to-ids value) " ")
 647     (www-format-encode-string (format "%s" value) without-tags)))
 648
 649 (defun www-format-value-as-S-exp (value &optional without-tags)
 650   (www-format-encode-string (format "%S" value) without-tags))
 651
 652 (defun www-format-value-as-HEX (value)
 653   (if (integerp value)
 654       (format "%X" value)
 655     (www-format-value-as-S-exp value)))
 656
 657 (defun www-format-value-as-CCS-default (value)
 658   (if (integerp value)
 659       (format "0x%s (%d)"
 660               (www-format-value-as-HEX value)
 661               value)
 662     (www-format-value-as-S-exp value)))
 663
 664 (defun www-format-value-as-CCS-94x94 (value)
 665   (if (integerp value)
 666       (format "0x%s [%s] (%d)"
 667               (www-format-value-as-HEX value)
 668               (www-format-value-as-kuten value)
 669               value)
 670     (www-format-value-as-S-exp value)))
 671
 672 (defun www-format-value-as-kangxi-radical (value)
 673   (if (and (integerp value)
 674            (<= 0 value)
 675            (<= value 214))
 676       (www-format-encode-string
 677        (format "%c" (ideographic-radical value)))
 678     (www-format-value-as-S-exp value)))
 679
 680 (defun www-format-value (object feature-name
 681                                 &optional value format
 682                                 without-tags without-edit)
 683   (unless value
 684     (setq value (www-get-feature-value object feature-name)))
 685   (www-format-apply-value object feature-name
 686                           format nil value nil nil
 687                           without-tags without-edit)
 688   )
 689
 690
 691 ;;; @ format evaluator
 692 ;;;
 693
 694 (defun www-format-encode-string (string &optional without-tags)
 695   (with-temp-buffer
 696     (insert string)
 697     (let (plane code start end char variants ret rret)
 698       (goto-char (point-min))
 699       (while (search-forward "<" nil t)
 700         (replace-match "&lt;" nil t))
 701       (goto-char (point-min))
 702       (while (search-forward ">" nil t)
 703         (replace-match "&gt;" nil t))
 704       (if without-tags
 705           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 706         (let ((coded-charset-entity-reference-alist
 707                (list*
 708                 '(=gt                   "GT-" 5 d)
 709                 '(=cns11643-1           "C1-" 4 X)
 710                 '(=cns11643-2           "C2-" 4 X)
 711                 '(=cns11643-3           "C3-" 4 X)
 712                 '(=cns11643-4           "C4-" 4 X)
 713                 '(=cns11643-5           "C5-" 4 X)
 714                 '(=cns11643-6           "C6-" 4 X)
 715                 '(=cns11643-7           "C7-" 4 X)
 716                 '(=gb2312               "G0-" 4 X)
 717                 '(=gb12345              "G1-" 4 X)
 718                 '(=jis-x0208@1990       "J90-" 4 X)
 719                 '(=jis-x0212            "JSP-" 4 X)
 720                 '(=cbeta                "CB" 5 d)
 721                 '(=jis-x0208@1997       "J97-" 4 X)
 722                 '(=jis-x0208@1978       "J78-" 4 X)
 723                 '(=jis-x0208@1983       "J83-" 4 X)
 724                 '(=ruimoku-v6           "RUI6-" 4 X)
 725                 '(=zinbun-oracle        "ZOB-" 4 d)
 726                 '(=jef-china3           "JC3-" 4 X)
 727                 '(=daikanwa             "M-" 5 d)
 728                 coded-charset-entity-reference-alist)))
 729           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 730
 731           (goto-char (point-min))
 732           (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
 733             (setq code (string-to-int (match-string 1)))
 734             (replace-match
 735              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\">"
 736                      code
 737                      chise-wiki-bitmap-glyphs-url
 738                      (/ code 1000) code)
 739              t 'literal))
 740
 741           (goto-char (point-min))
 742           (while (re-search-forward "&J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 743             (setq plane (match-string 1)
 744                   code (string-to-int (match-string 2) 16))
 745             (replace-match
 746              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\">"
 747                      plane code
 748                      chise-wiki-bitmap-glyphs-url
 749                      plane
 750                      (- (lsh code -8) 32)
 751                      (- (logand code 255) 32))
 752              t 'literal))
 753
 754           (goto-char (point-min))
 755           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 756             (setq plane (string-to-int (match-string 1))
 757                   code (string-to-int (match-string 2) 16))
 758             (replace-match
 759              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\">"
 760                      plane code
 761                      chise-wiki-bitmap-glyphs-url
 762                      plane
 763                      (- (lsh code -8) 32)
 764                      (- (logand code 255) 32))
 765              t 'literal))
 766
 767           (goto-char (point-min))
 768           (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 769             (setq plane (string-to-int (match-string 1))
 770                   code (string-to-int (match-string 2) 16))
 771             (replace-match
 772              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\">"
 773                      plane code
 774                      chise-wiki-bitmap-glyphs-url
 775                      plane code)
 776              t 'literal))
 777
 778           (goto-char (point-min))
 779           (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 780             (setq code (string-to-int (match-string 1) 16))
 781             (replace-match
 782              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 783                      code code)
 784              t 'literal))
 785
 786           (goto-char (point-min))
 787           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
 788             (setq code (string-to-int (match-string 2)))
 789             (replace-match
 790              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\">"
 791                      code
 792                      chise-wiki-bitmap-glyphs-url
 793                      code)
 794              t 'literal))
 795
 796           (goto-char (point-min))
 797           (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
 798             (setq code (string-to-int (match-string 2)))
 799             (replace-match
 800              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\">"
 801                      code
 802                      chise-wiki-glyph-cgi-url
 803                      code)
 804              t 'literal))
 805
 806           (goto-char (point-min))
 807           (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
 808             (setq code (string-to-int (match-string 2)))
 809             (replace-match
 810              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\">"
 811                      code
 812                      chise-wiki-glyph-cgi-url
 813                      code)
 814              t 'literal))
 815
 816           (goto-char (point-min))
 817           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
 818             (setq code (string-to-int (match-string 1) 16))
 819             (replace-match
 820              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\">"
 821                      code
 822                      chise-wiki-glyph-cgi-url
 823                      code)
 824              t 'literal))
 825
 826           (goto-char (point-min))
 827           (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
 828             (setq code (string-to-int (match-string 1) 16))
 829             (replace-match
 830              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\">"
 831                      code
 832                      chise-wiki-glyph-cgi-url
 833                      code)
 834              t 'literal))
 835
 836           (goto-char (point-min))
 837           (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
 838             (setq code (string-to-int (match-string 1) 16))
 839             (replace-match
 840              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\">"
 841                      code
 842                      chise-wiki-glyph-cgi-url
 843                      code)
 844              t 'literal))
 845
 846           (goto-char (point-min))
 847           (while (re-search-forward "&\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
 848             (setq code (string-to-int (match-string 2) 16))
 849             (replace-match
 850              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\">"
 851                      code
 852                      code)
 853              t 'literal))
 854
 855           (goto-char (point-min))
 856           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
 857             (setq code (string-to-int (match-string 1) 16))
 858             (setq start (match-beginning 0)
 859                   end (match-end 0))
 860             (setq char (decode-char 'system-char-id code))
 861             (cond
 862              ((and (setq variants
 863                          (or (www-get-feature-value char '->subsumptive)
 864                              (www-get-feature-value char '->denotational)))
 865                    (progn
 866                      (while (and variants
 867                                  (setq ret (www-format-encode-string
 868                                             (char-to-string (car variants))))
 869                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
 870                        (setq variants (cdr variants)))
 871                      ret))
 872               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
 873                 (goto-char start)
 874                 (delete-region start end)
 875                 (insert ret))
 876               )
 877              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
 878                             (www-get-feature-value char 'ideographic-structure)))
 879               (setq ret
 880                     (mapconcat
 881                      (lambda (ch)
 882                        (if (listp ch)
 883                            (if (characterp (setq rret (find-char ch)))
 884                                (setq ch rret)))
 885                        (if (characterp ch)
 886                            (www-format-encode-string
 887                             (char-to-string ch) without-tags)
 888                          (www-format-encode-string
 889                           (format "%S" ch) without-tags)))
 890                      ret ""))
 891               (when ret
 892                 (goto-char start)
 893                 (delete-region start end)
 894                 (insert ret))
 895               )))
 896           ))
 897       ;; (goto-char (point-min))
 898       ;; (while (search-forward "&GT-" nil t)
 899       ;;   (replace-match "&amp;GT-" t 'literal))
 900       (buffer-string))))
 901
 902 (defun www-format-props-to-string (props &optional format)
 903   (unless format
 904     (setq format (plist-get props :format)))
 905   (concat "%"
 906           (plist-get props :flag)
 907           ;; (if (plist-get props :zero-padding)
 908           ;;     "0")
 909           (if (plist-get props :len)
 910               (format "0%d"
 911                       (let ((ret (plist-get props :len)))
 912                         (if (stringp ret)
 913                             (string-to-int ret)
 914                           ret))))
 915           (cond
 916            ((eq format 'decimal) "d")
 917            ((eq format 'hex) "x")
 918            ((eq format 'HEX) "X")
 919            ((eq format 'S-exp) "S")
 920            (t "s"))))
 921
 922 (defun www-format-apply-value (object feature-name
 923                                       format props value
 924                                       &optional uri-char uri-feature
 925                                       without-tags without-edit)
 926   (let (ret)
 927     (setq ret
 928           (cond
 929            ((memq format '(decimal hex HEX))
 930             (if (integerp value)
 931                 (format (www-format-props-to-string props format)
 932                         value)
 933               (www-format-encode-string
 934                (format "%s" value)
 935                without-tags))
 936             )
 937            ((eq format 'wiki-text)
 938             (if without-tags
 939                 (www-xml-format-list value)
 940               (www-format-eval-list value object feature-name nil uri-char
 941                                     without-tags without-edit))
 942             )
 943            ((eq format 'S-exp)
 944             (www-format-encode-string
 945              (format (www-format-props-to-string props format)
 946                      value)
 947              without-tags))
 948            ((eq format 'ku-ten)
 949             (www-format-value-as-kuten value))
 950            ((eq format 'kangxi-radical)
 951             (www-format-value-as-kangxi-radical value))
 952            ((eq format 'space-separated-char-list)
 953             (www-format-value-as-char-list value without-tags))
 954            ((eq format 'space-separated-ids)
 955             (www-format-value-as-ids value without-tags))
 956            ((eq format 'space-separated-domain-list)
 957             (www-format-value-as-domain-list value without-tags))
 958            ((eq format 'string)
 959             (www-format-encode-string (format "%s" value) without-tags)
 960             )
 961            (t
 962             (www-format-value-default value without-tags)
 963             ))
 964           )
 965     (if (or without-tags
 966             without-edit
 967             (eq (plist-get props :mode) 'peek))
 968         ret
 969       (format "%s <a href=\"%s?char=%s&feature=%s&format=%s\"
 970 ><input type=\"submit\" value=\"edit\" /></a>"
 971               ret
 972               chise-wiki-edit-url
 973               uri-char uri-feature format))))
 974
 975 (defun www-format-eval-feature-value (char
 976                                       feature-name
 977                                       &optional format lang uri-char value
 978                                       without-tags without-edit)
 979   (unless value
 980     (setq value (www-get-feature-value char feature-name)))
 981   (unless format
 982     (setq format (www-feature-value-format feature-name)))
 983   (cond
 984    ((symbolp format)
 985     (www-format-apply-value
 986      char feature-name
 987      format nil value
 988      uri-char (www-uri-encode-feature-name feature-name)
 989      without-tags without-edit)
 990     )
 991    ((consp format)
 992     (cond ((null (cdr format))
 993            (setq format (car format))
 994            (www-format-apply-value
 995             char feature-name
 996             (car format) (nth 1 format) value
 997             uri-char (www-uri-encode-feature-name feature-name)
 998             without-tags without-edit)
 999            )
1000           (t
1001            (www-format-eval-list format char feature-name lang uri-char
1002                                  without-tags without-edit)
1003            )))))
1004
1005 (defun www-format-eval-unit (exp char feature-name
1006                                  &optional lang uri-char value
1007                                  without-tags without-edit)
1008   (unless value
1009     (setq value (www-get-feature-value char feature-name)))
1010   (unless uri-char
1011     (setq uri-char (www-uri-encode-char char)))
1012   (cond
1013    ((stringp exp) (www-format-encode-string exp))
1014    ((null exp) "")
1015    ((consp exp)
1016     (cond
1017      ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
1018                               S-exp string default))
1019       (let ((fn (plist-get (nth 1 exp) :feature))
1020             domain domain-fn ret)
1021         (when fn
1022           (when (stringp fn)
1023             (setq fn (intern fn)))
1024           (setq domain (char-feature-name-domain feature-name))
1025           (setq domain-fn (char-feature-name-at-domain fn domain))
1026           (if (setq ret (www-get-feature-value char domain-fn))
1027               (setq feature-name domain-fn
1028                     value ret)
1029             (setq feature-name fn
1030                   value (www-get-feature-value char fn)))
1031           (push feature-name chise-wiki-displayed-features)
1032           ))
1033       (if (eq (car exp) 'value)
1034           (www-format-eval-feature-value char feature-name
1035                                          (plist-get (nth 1 exp) :format)
1036                                          lang uri-char value
1037                                          without-tags without-edit)
1038         (www-format-apply-value
1039          char feature-name
1040          (car exp) (nth 1 exp) value
1041          uri-char (www-uri-encode-feature-name feature-name)
1042          without-tags without-edit))
1043       )
1044      ((eq (car exp) 'name)
1045       (let ((fn (plist-get (nth 1 exp) :feature))
1046             domain domain-fn)
1047         (when fn
1048           (setq domain (char-feature-name-domain feature-name))
1049           (when (stringp fn)
1050             (setq fn (intern fn)))
1051           (setq domain-fn (char-feature-name-at-domain fn domain))
1052           (setq feature-name domain-fn)))
1053       (if without-tags
1054           (www-format-feature-name feature-name lang)
1055         (format "<a href=\"%s\">%s</a>"
1056                 (www-uri-make-feature-name-url
1057                  (www-uri-encode-feature-name feature-name)
1058                  uri-char)
1059                 (www-format-feature-name feature-name lang))
1060         )
1061       )
1062      ((eq (car exp) 'name-url)
1063       (let ((fn (plist-get (nth 1 exp) :feature))
1064             domain domain-fn)
1065         (when fn
1066           (setq domain (char-feature-name-domain feature-name))
1067           (when (stringp fn)
1068             (setq fn (intern fn)))
1069           (setq domain-fn (char-feature-name-at-domain fn domain))
1070           (setq feature-name domain-fn)))
1071       (www-uri-make-feature-name-url
1072        (www-uri-encode-feature-name feature-name)
1073        uri-char)
1074       )
1075      ((eq (car exp) 'domain-name)
1076       (let ((domain (char-feature-name-domain feature-name)))
1077         (if domain
1078             (format "@%s" domain))))
1079      ((eq (car exp) 'prev-char)
1080       (if without-tags
1081           ""
1082         (let ((prev-char (find-previous-defined-code-point
1083                           feature-name value)))
1084           (if prev-char
1085               (format "\n<a href=\"%s?char=%s\">%s</a>"
1086                       chise-wiki-view-url
1087                       (www-uri-encode-char prev-char)
1088                       "<input type=\"submit\" value=\"-\" />"
1089                       ;; (www-format-encode-string
1090                       ;;  (char-to-string prev-char))
1091                       )
1092             "")))
1093       )
1094      ((eq (car exp) 'next-char)
1095       (if without-tags
1096           ""
1097         (let ((next-char (find-next-defined-code-point
1098                           feature-name value)))
1099           (if next-char
1100               (format "<a href=\"%s?char=%s\">%s</a>"
1101                       chise-wiki-view-url
1102                       (www-uri-encode-char next-char)
1103                       "<input type=\"submit\" value=\"+\" />"
1104                       ;; (www-format-encode-string
1105                       ;;  (char-to-string next-char))
1106                       )
1107             "")))
1108       )
1109      ((eq (car exp) 'link)
1110       (if without-tags
1111           (www-format-eval-list (nthcdr 2 exp)
1112                                 char feature-name lang uri-char
1113                                 without-tags without-edit)
1114         (format "<a
1115  href=\"%s\"
1116 >%s</a
1117 >"
1118                 (www-format-eval-list (plist-get (nth 1 exp) :ref)
1119                                       char feature-name lang uri-char
1120                                       'without-tags 'without-edit)
1121                 (www-format-eval-list (nthcdr 2 exp)
1122                                       char feature-name lang uri-char
1123                                       without-tags without-edit)))
1124       )
1125      (t
1126       (format "<%s
1127 >%s</%s
1128 >"
1129               (car exp)
1130               (www-format-eval-list (nthcdr 2 exp) char feature-name
1131                                     lang uri-char
1132                                     without-tags without-edit)
1133               (car exp)))))))
1134
1135 (defun www-format-eval-list (format-list char feature-name
1136                                          &optional lang uri-char
1137                                          without-tags without-edit)
1138   (if (consp format-list)
1139       (mapconcat
1140        (lambda (exp)
1141          (www-format-eval-unit exp char feature-name lang uri-char
1142                                nil without-tags without-edit))
1143        format-list "")
1144     (www-format-eval-unit format-list char feature-name lang uri-char
1145                           nil without-tags without-edit)))
1146
1147
1148 ;;; @ XML generator
1149 ;;;
1150
1151 (defun www-xml-format-props (props)
1152   (let ((dest "")
1153         key val)
1154     (while props
1155       (setq key (pop props)
1156             val (pop props))
1157       (if (symbolp key)
1158           (setq key (symbol-name key)))
1159       (if (eq (aref key 0) ?:)
1160           (setq key (substring key 1)))
1161       (setq dest
1162             (format "%s %s=\"%s\""
1163                     dest key
1164                     (www-format-encode-string
1165                      (format "%s" val) 'without-tags))))
1166     dest))
1167
1168 (defun www-xml-format-unit (format-unit)
1169   (let (name props children ret)
1170     (cond
1171      ((stringp format-unit)
1172       (mapconcat (lambda (c)
1173                    (cond
1174                     ((eq c ?&) "&amp;")
1175                     ;; ((eq c ?<) "&amp;lt;")
1176                     ;; ((eq c ?>) "&amp;gt;")
1177                     (t
1178                      (char-to-string c))))
1179                  (www-format-encode-string format-unit 'without-tags)
1180                  "")
1181       )
1182      ((consp format-unit)
1183       (setq name (car format-unit)
1184             props (nth 1 format-unit)
1185             children (nthcdr 2 format-unit))
1186       (when (eq name 'link)
1187         (setq ret (plist-get props :ref))
1188         (unless (stringp ret)
1189           (setq props (plist-remprop (copy-list props) :ref))
1190           (setq children
1191                 (cons (list* 'ref nil ret)
1192                       children))))
1193       (if children
1194           (format "<%s%s>%s</%s>"
1195                   name
1196                   (if props
1197                       (www-xml-format-props props)
1198                     "")
1199                   (www-xml-format-list children)
1200                   name)
1201         (format "<%s%s/>"
1202                 name (www-xml-format-props props)))
1203       )
1204      (t
1205       (format "%s" format-unit)))))
1206
1207 (defun www-xml-format-list (format-list)
1208   (if (atom format-list)
1209       (www-xml-format-unit format-list)
1210     (mapconcat #'www-xml-format-unit
1211                format-list "")))
1212
1213
1214 ;;; @ HTML generator
1215 ;;;
1216
1217 (defun www-html-display-text (text)
1218   (princ
1219    (with-temp-buffer
1220      (insert text)
1221      (goto-char (point-min))
1222      (while (search-forward "<" nil t)
1223        (replace-match "&lt;" nil t))
1224      (goto-char (point-min))
1225      (while (search-forward ">" nil t)
1226        (replace-match "&gt;" nil t))
1227      (goto-char (point-min))
1228      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
1229        (replace-match
1230         (format "<a href=\"%s\">%s</a>"
1231                 (match-string 2)
1232                 (match-string 1))
1233         nil t))
1234      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
1235      (goto-char (point-min))
1236      (while (search-forward "&GT-" nil t)
1237        (replace-match "&amp;GT-" nil t))
1238      (buffer-string))))
1239
1240 (defun www-html-display-paragraph (text)
1241   (princ "<p>")
1242   (www-html-display-text text)
1243   (princ "</p>\n"))
1244
1245
1246 ;;; @ for GlyphWiki
1247 ;;;
1248
1249 (defvar coded-charset-GlyphWiki-id-alist
1250   '((=ucs               "u"     4 x nil)
1251     (=ucs@JP            "u"     4 x nil)
1252     (=ucs@jis           "u"     4 x nil)
1253     (=ucs@gb            "u"     4 x "-g")
1254     (=ucs@cns           "u"     4 x "-t")
1255     (=ucs@ks            "u"     4 x "-k")
1256     (=ucs@iso           "u"     4 x "-u")
1257     (=ucs@unicode       "u"     4 x "-us")
1258     (=adobe-japan1-6    "aj1-"  5 d nil)
1259     (=gt                "gt-"   5 d nil)
1260     (=big5-cdp          "cdp-"  4 x nil)
1261     (=cbeta             "cb"    5 d nil)
1262     (=jis-x0208@1978/1pr "j78-" 4 x nil)
1263     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
1264     (=jis-x0208@1978    "j78-"  4 x nil)
1265     (=jis-x0208@1983    "j83-"  4 x nil)
1266     (=jis-x0208@1990    "j90-"  4 x nil)
1267     (=jis-x0212         "jsp-"  4 x nil)
1268     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
1269     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
1270     (=jis-x0213-2       "jx2-"  4 x nil)
1271     (=cns11643-1        "c1-"   4 x nil)
1272     (=cns11643-2        "c2-"   4 x nil)
1273     (=cns11643-3        "c3-"   4 x nil)
1274     (=cns11643-4        "c4-"   4 x nil)
1275     (=cns11643-5        "c5-"   4 x nil)
1276     (=cns11643-6        "c6-"   4 x nil)
1277     (=cns11643-7        "c7-"   4 x nil)
1278     (=daikanwa          "dkw-"  5 d nil)
1279     (=gt-k              "gt-k"  5 d nil)
1280     (=jef-china3        "jc3-"  4 x nil)
1281     (=big5              "b-"    4 x nil)
1282     (=ks-x1001          "k0-"   4 x nil)
1283     ))
1284
1285 (defun char-GlyphWiki-id (char)
1286   (let ((rest coded-charset-GlyphWiki-id-alist)
1287         spec ret code)
1288     (while (and rest
1289                 (setq spec (pop rest))
1290                 (null (setq ret (char-feature char (car spec))))))
1291     (when ret
1292       (or
1293        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
1294             (cond
1295              ((and (or (encode-char char '=jis-x0208@1990)
1296                        (encode-char char '=jis-x0212)
1297                        (encode-char char '=jis-x0213-1))
1298                    (setq code (encode-char char '=ucs@jis)))
1299               (format "u%04x" code)
1300               )
1301              ((and (or (encode-char char '=gb2312)
1302                        (encode-char char '=gb12345))
1303                    (setq code (encode-char char '=ucs@gb)))
1304               (format "u%04x-g" code)
1305               )
1306              ((and (or (encode-char char '=cns11643-1)
1307                        (encode-char char '=cns11643-2)
1308                        (encode-char char '=cns11643-3)
1309                        (encode-char char '=cns11643-4)
1310                        (encode-char char '=cns11643-5)
1311                        (encode-char char '=cns11643-6)
1312                        (encode-char char '=cns11643-7))
1313                    (setq code (encode-char char '=ucs@cns)))
1314               (format "u%04x-t" code)
1315               )
1316              ((and (encode-char char '=ks-x1001)
1317                    (setq code (encode-char char '=ucs@ks)))
1318               (format "u%04x-k" code)
1319               )))
1320        (format (format "%s%%0%d%s%s"
1321                        (nth 1 spec)
1322                        (nth 2 spec)
1323                        (nth 3 spec)
1324                        (or (nth 4 spec) ""))
1325                ret)))))
1326
1327
1328 ;;; @ End.
1329 ;;;
1330
1331 (provide 'cwiki-common)
1332
1333 ;;; cwiki-common.el ends here