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